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

(** Support for creating and reasoning about fresh names (represented
as strings). *)

Require Import String.
Require Import List.
Require Import Permutation.
Require Import Arith Min.
Require Import EquivDec.
Require Import Morphisms.
Require Import Lia.
Require Import CoqLibAdd.
Require Import ListAdd.
Require Import StringAdd.
Require Import Digits.
Require Import Lift.
Require Import Sublist.

Section Fresh.

  Section finder.
    Context {A:Type}.
    Context (incr:A->A).
    Context (f:A->bool).

    Fixpoint find_bounded (bound:nat) (init:A)
      := match bound with
         | O => None
         | S n =>
           if f init
           then Some init
           else find_bounded n (incr init)
         end.

    Lemma find_bounded_correct bound init y :
      find_bounded bound init = Some y ->
      f y = true.
    Proof.
      revert init.
      induction bound; simpl; intros.
      - discriminate.
      - match_case_in H; intros eqq; rewrite eqq in H.
        + inversion H; congruence.
        + eauto.
    Qed.
  End finder.

  Lemma find_bounded_S_ge f bound init y :
    find_bounded S f bound init = Some y ->
    y >= init.
  Proof.
    revert init y.
    induction bound; simpl; intros.
    - discriminate.
    - match_destr_in H.
      + inversion H; subst; lia.
      + specialize (IHbound (S init) _ H).
        lia.
  Qed.

  Lemma find_bounded_S_seq f bound init :
    find_bounded S f bound init = find f (seq init bound).
  Proof.
    revert init.
    induction bound; simpl; trivial; intros.
    match_destr; auto.
  Qed.

  Lemma find_bounded_S_nin_finds' {A:Type} f {dec:EqDec A eq} (dom:list A)
        (bound:nat) (pf:bound > length dom)
        (inj:forall x y, f x = f y -> x = y) :
    {y:A | lift f (find_bounded S
                                (fun x =>
                                   if in_dec equiv_dec (f x) dom
                                   then false else true)
                                bound 0) = Some y}.
  Proof.
    rewrite find_bounded_S_seq.
    rewrite <- (find_over_map (fun x  => if in_dec equiv_dec x dom then false else true) f).
    apply find_fresh_from.
    - rewrite map_length.
      rewrite seq_length.
      trivial.
    - apply map_inj_NoDup; trivial.
      apply seq_NoDup.
  Defined.

  (* This version has better computational properties *)
  Definition find_bounded_S_nin_finds {A:Type} f {dec:EqDec A eq} (dom:list A)
             (bound:nat) (pf:bound > length dom)
             (inj:forall x y, f x = f y -> x = y) :
    {y:A | lift f (find_bounded S
                                (fun x =>
                                   if in_dec equiv_dec (f x) dom
                                   then false else true)
                                bound 0) = Some y}.
  Proof.
    case_eq (find_bounded S
                          (fun x : nat => if in_dec equiv_dec (f x) dom then false else true)
                          bound 0).
    - intros; simpl.
      exists (f n); reflexivity.
    - destruct (find_bounded_S_nin_finds' f dom bound pf inj); intros.
      rewrite H in e.
      simpl in e. discriminate.
  Defined.

  Definition find_fresh_inj_f {A:Type} {dec:EqDec A eq} f (inj:forall x y, f x = f y -> x = y) (dom:list A) : A
    := proj1_sig (find_bounded_S_nin_finds f dom (S (length dom)) (gt_Sn_n _) inj).

  Lemma find_fresh_inj_f_fresh {A:Type} {dec:EqDec A eq} f (inj:forall x y, f x = f y -> x = y) (dom:list A) :
    ~ In (find_fresh_inj_f f inj dom) dom.
  Proof.
    unfold find_fresh_inj_f.
    match goal with
    | [|- context[ proj1_sig ?x ]] => destruct x
    end; simpl.
    apply some_lift in e.
    destruct e as [? e ?]; subst.
    apply find_bounded_correct in e.
    match_destr_in e.
  Qed.

  Definition find_fresh_string (dom:list string)
    := find_fresh_inj_f
         nat_to_string16
         nat_to_string16_inj
         dom.

  Lemma find_fresh_string_is_fresh (dom:list string) :
    ~ In (find_fresh_string dom) dom.
  Proof.
    unfold find_fresh_string.
    apply find_fresh_inj_f_fresh.
  Qed.

  (* Java equivalent: NnrcOptimizer.fresh_var (serves same purpose, not an exact translation) *)
  Definition fresh_var (pre:string) (dom:list string) :=
    let problems:=filter (prefix pre) dom in
    let problemEnds:=
        map (fun x => substring (String.length pre) (String.length x - String.length pre) x) problems in
    append pre (find_fresh_string problemEnds).

  Lemma fresh_var_fresh pre (dom:list string) :
    ~ In (fresh_var pre dom) dom.
  Proof.
    unfold fresh_var.
    intros inn.
    rewrite in_of_append in inn.
    apply find_fresh_string_is_fresh in inn.
    trivial.
  Qed.

  Lemma fresh_var_fresh1 x1 pre dom :
    x1 <> fresh_var pre (x1::dom).
  Proof.
    intro inn.
    apply (fresh_var_fresh pre (x1::dom)).
    rewrite <- inn.
    simpl; intuition.
  Qed.

  Lemma fresh_var_fresh2 x1 x2 pre dom :
    x2 <> fresh_var pre (x1::x2::dom).
  Proof.
    intro inn.
    apply (fresh_var_fresh pre (x1::x2::dom)).
    rewrite <- inn.
    simpl; intuition.
  Qed.

  Lemma fresh_var_fresh3 x1 x2 x3 pre dom :
    x3 <> fresh_var pre (x1::x2::x3::dom).
  Proof.
    intro inn.
    apply (fresh_var_fresh pre (x1::x2::x3::dom)).
    rewrite <- inn.
    simpl; intuition.
  Qed.

  Lemma fresh_var_fresh4 x1 x2 x3 x4 pre dom :
    x4 <> fresh_var pre (x1::x2::x3::x4::dom).
  Proof.
    intro inn.
    apply (fresh_var_fresh pre (x1::x2::x3::x4::dom)).
    rewrite <- inn.
    simpl; intuition.
  Qed.

  Definition fresh_var2 pre1 pre2 (dom:list string) :=
    let fresh_var1 := fresh_var pre1 dom in
    (fresh_var1, fresh_var pre2 (fresh_var1::dom)).

  Lemma fresh_var2_distinct pre1 pre2 dom :
    (fst (fresh_var2 pre1 pre2 dom)) <>
    (snd (fresh_var2 pre1 pre2 dom)).
  Proof.
    unfold fresh_var2; simpl.
    apply fresh_var_fresh1.
  Qed.

  Definition fresh_var3 pre1 pre2 pre3 (dom:list string) :=
    let fresh_var1 := fresh_var pre1 dom in
    let fresh_var2 := fresh_var pre2 (fresh_var1::dom) in
    let fresh_var3 := fresh_var pre3 (fresh_var2::fresh_var1::dom) in
    (fresh_var1, fresh_var2, fresh_var3).

  Lemma fresh_var3_distinct pre1 pre2 pre3 dom :
    (fst (fst (fresh_var3 pre1 pre2 pre3 dom))) <>
    (snd (fst (fresh_var3 pre1 pre2 pre3 dom))) /\
    (snd (fst (fresh_var3 pre1 pre2 pre3 dom))) <>
    (snd (fresh_var3 pre1 pre2 pre3 dom)) /\
    (fst (fst (fresh_var3 pre1 pre2 pre3 dom))) <>
    (snd (fresh_var3 pre1 pre2 pre3 dom)).
  Proof.
    unfold fresh_var3; simpl.
    split;[|split].
    - apply fresh_var_fresh1.
    - apply fresh_var_fresh1.
    - apply fresh_var_fresh2.
  Qed.

  (* given a variable, gets the "base": the part before the last seperator *)
  Definition get_var_base (sep:string) (var:string)
    := match index 0 (string_reverse sep) (string_reverse var) with
       | Some n => substring 0 (String.length var - (S n)) var
       | None => var
       end.

  Lemma get_var_base_pre sep var :
    prefix (get_var_base sep var) var = true.
  Proof.
    unfold get_var_base.
    match_destr; simpl.
    - apply substring_prefix.
    - apply prefix_refl.
  Qed.

  Definition fresh_var_from sep (oldvar:string) (dom:list string) : string
    := if in_dec string_dec oldvar dom
       then fresh_var (append (get_var_base sep oldvar) sep) dom
       else oldvar.

  Lemma fresh_var_from_fresh sep oldvar (dom:list string) :
    ~ In (fresh_var_from sep oldvar dom) dom.
  Proof.
    unfold fresh_var_from.
    match_destr.
    apply fresh_var_fresh.
  Qed.

  Lemma find_fresh_inj_f_equivlist x y :
    equivlist x y ->
    find_fresh_inj_f nat_to_string16 nat_to_string16_inj x =
    find_fresh_inj_f nat_to_string16 nat_to_string16_inj y.
  Proof.
    intros.
    unfold find_fresh_inj_f; simpl.
    repeat (match goal with
            | [|- context[ proj1_sig ?x ]] => destruct x
            end; simpl).
    apply some_lift in e.
    destruct e as [? e ?]; subst.
    apply some_lift in e0.
    destruct e0 as [? e0 ?]; subst.
    f_equal.
    rewrite find_bounded_S_seq in e, e0.
    rewrite (find_ext
               (fun x0 : nat => if in_dec equiv_dec (nat_to_string16 x0) x then false else true)
               (fun x0 : nat => if in_dec equiv_dec (nat_to_string16 x0) y then false else true)) in e.
    - eapply find_seq_same; eauto.
    - intros.
      do 2 match_destr.
      + rewrite H in i; congruence.
      + rewrite <- H in i; congruence.
  Qed.

  Global Instance find_fresh_string_equivlist : Proper (equivlist ==> eq) find_fresh_string.
  Proof.
    intros ???.
    unfold find_fresh_string.
    apply find_fresh_inj_f_equivlist; trivial.
  Qed.
  (*
Eval vm_compute in
      fresh_var_from "$"%string "cat_var$5"%string ("cat_var$0"::"i"::"cat_var$5"::"tmp1"::"tmp2"::"cat_var1"::nil)%string.
   *)

  Global Instance fresh_var_equivlist : Proper (eq ==> equivlist ==> eq) fresh_var.
  Proof.
    intros ??????; subst.
    unfold fresh_var.
    rewrite H0.
    reflexivity.
  Qed.

  Lemma fresh_var_from_id sep v l :
    ~ In v l ->
    fresh_var_from sep v l = v.
  Proof.
    unfold fresh_var_from.
    match_destr; tauto.
  Qed.

  Lemma fresh_var_from_nincl {sep v l l2} :
    In (fresh_var_from sep v l) l2 -> ~ incl l2 l.
  Proof.
    intros inn1 incl.
    apply (fresh_var_from_fresh sep v l).
    apply incl; trivial.
  Qed.

  Lemma fresh_var_from_incl_nin sep v l1 l2 :
    incl l2 l1 ->
    ~ In (fresh_var_from sep v l1) l2.
  Proof.
    intros incl1 inn.
    apply (fresh_var_from_nincl inn); trivial.
  Qed.

End Fresh.

Ltac prove_fresh_nin
  := match goal with
     | [ |- ~ In (fresh_var ?pre ?l) _ ] =>
       solve[generalize (fresh_var_fresh pre l); simpl; intuition]
     | [ |- In (fresh_var ?pre ?l) _ -> False] =>
       solve[generalize (fresh_var_fresh pre l); simpl; intuition]
     | [ |- ~ (fresh_var ?pre ?l) = _ ] =>
       solve[generalize (fresh_var_fresh pre l); simpl; intuition]
     | [ |-  (fresh_var ?pre ?l) <> _ ] =>
       solve[generalize (fresh_var_fresh pre l); simpl; intuition]
     | [ H:In (fresh_var ?pre ?l) _ |- _ ] =>
       solve[generalize (fresh_var_fresh pre l); simpl; intuition]
     | [ H:(fresh_var ?pre ?l) = _ |- _ ] =>
       solve[generalize (fresh_var_fresh pre l); simpl; intuition]
     end.


(** printing ⊢k #⊢k# *)
(** printing ⊢! #⊢# *)
(** printing k⊣ #⊣# *)
(** printing |- #⊢# *)
(** printing ⦂ #:# *)
(** printing <⦂ #<:# *)
(** printing [<=] #⊆# *)
(** printing `union` #∪# *)
(** printing \u #∪# *)
(** printing `notin` #∉# *)
(** printing `in` #∈# *)
(** printing ⊆<⦂ #⊆<:# *)

Set Implicit Arguments.
Require Import Definitions.

(** * Miscellaneous Definitions

    This file defines well-formedness of contexts, and some structural measures.
 *)

(** ** Definition of Well-formedness of Contexts *)
Inductive wf_env : env -> Prop :=
(** [――――――――――] Wf-Nil #
#
    [wf ⋅]  *)
| wf_nil : wf_env nil
(** [x ∉ fv T ∪ fv G] #
#
    [fv T ⊆ dom G] #
#
    [wf G] #
#
    [――――――――――] Wf-Cons #
#
    [wf G ; x : T]  *)
| wf_cons : forall {x T G}, x \notin fv T \u fv G ->
                       fv T [<=] dom G ->
                       wf_env G ->
                       lc T ->
                       wf_env (x ~ T ++ G).
Hint Constructors wf_env.

Lemma wf_decons : forall x T G, wf_env (x ~ T ++ G) -> x \notin fv T.
Proof. routine. Qed.

Lemma wf_deapp : forall G1 G2, wf_env (G1 ++ G2) -> wf_env G2.
Proof. induction on env; routine. Qed.

Lemma wf_uniq : forall G, wf_env G -> uniq G.
Proof. induction on env; routine. Qed.

Lemma wf_var_in : forall G1 G2 v,
    wf_env (G1 ++ G2) ->
    v `in` dom G2 ->
         v `notin` dom G1.
Proof.
  induction G1; intros.
  - routine.
  - tidy_up. repeat rewrite dom_app in *.
    destruct_notin.
    rewrite AtomSetProperties.add_union_singleton.
    intro Contra.
    apply AtomSetImpl.union_1 in Contra.
    destruct Contra.
    + apply AtomSetImpl.singleton_1 in H1. subst.
      intuition.
    + eapply IHG1; eassumption.
Qed.

Lemma wf_fv_is_dom : forall G,
    wf_env G ->
    fv G [=] dom G.
Proof.
  induction on wf_env; set solve.
  autorewrite with meta_ext. rewrite IHwf_env.
  simpl. fsetdec.
Qed.

(** ** Definition of Structural Measures *)

Fixpoint typ_struct_measure (T : typ) :=
  match T with
  | typ_top => 1
  | typ_bot => 1
  | typ_sel x => 2
  | typ_all T U => S $ typ_struct_measure T + typ_struct_measure U
  | typ_bnd T U => S $ typ_struct_measure T + typ_struct_measure U
  end.

Fixpoint trm_struct_measure (t : trm) :=
  match t with
  | trm_var _ => 1
  | trm_val vl => val_struct_measure vl
  | trm_app _ _ => 1
  | trm_let s t => S $ trm_struct_measure s + trm_struct_measure t
  end
with
val_struct_measure (vl : val) :=
  match vl with
  | val_bnd T => S $ typ_struct_measure T
  | val_lam T t => S $ typ_struct_measure T + trm_struct_measure t
  end.

Local Ltac simplify :=
  intros; cbn in *; try lia.

Local Ltac finish :=
  repeat match goal with
         | H : context[forall _, _ = _] |- _ =>
           rewrite H; clear H
         end;
  reflexivity.

(** The following are properties of the measures. *)
Lemma open_typ_same_measure : forall T k u,
    typ_struct_measure $ open_rec_typ k u T = typ_struct_measure T.
Proof.
  induction T; simplify; finish.
Qed.

Lemma open_trm_same_measure : forall t k u,
    trm_struct_measure $ open_rec_trm k u t = trm_struct_measure t
with
open_val_same_measure : forall vl k u,
    val_struct_measure $ open_rec_val k u vl = val_struct_measure vl.
Proof.
  - induction t; simplify; finish.
  - pose proof open_typ_same_measure.
    induction vl; simplify; finish.
Qed.

Lemma typ_struct_measure_ge_1 : forall T,
    typ_struct_measure T >= 1.
Proof. destruct T; routine. Qed.

Definition total (ns : list nat) : nat :=
  fold_right plus 0 ns.

Lemma total_app : forall ns1 ns2,
    total (ns1 ++ ns2) = total ns1 + total ns2.
Proof.
  unfold total.
  induction on list; simpl in *; intros; trivial.
  rewrite IHlist. lia.
Qed.

(** The measure of a context is just the sum of all measures of the types in it. *)
Definition env_measure (G : env) : nat :=
  total (List.map (fun (tup : var * typ) =>
        let (x, T) := tup in typ_struct_measure T) G).

Lemma env_measure_cons : forall x T G,
    env_measure ((x, T) :: G) = typ_struct_measure T + env_measure G.
Proof. routine. Qed.

Lemma env_measure_app : forall G1 G2,
    env_measure (G2 ++ G1) = env_measure G2 + env_measure G1.
Proof.
  induction G2; simpl; trivial.
  destruct a. rewrite! env_measure_cons.
  rewrite IHG2. lia.
Qed.

Arguments env_measure G : simpl never.
Create HintDb measures discriminated.
Hint Rewrite -> env_measure_cons env_measure_app total_app : measures.
Hint Rewrite -> open_typ_same_measure : measures.

(** The following are predicates to test a type. *)
Section Predicates.

  Definition is_top (T : typ) :=
    match T with
    | typ_top => True
    | _ => False
    end.

  Definition is_top_dec (T : typ) : {is_top T} + {~is_top T}.
  Proof. destruct T; simpl; auto. Defined.

  Definition is_bot (T : typ) :=
    match T with
    | typ_bot => True
    | _ => False
    end.

  Definition is_bot_dec (T : typ) : {is_bot T} + {~is_bot T}.
  Proof. destruct T; simpl; auto. Defined.

  Definition is_sel (T : typ) :=
    match T with
    | typ_sel _ => True
    | _ => False
    end.

  Definition is_sel_dec (T : typ) : {A | T = typ_sel A } + {~is_sel T}.
  Proof. destruct T; simpl; eauto. Defined.

  Definition is_all (T : typ) :=
    match T with
    | typ_all _ _ => True
    | _ => False
    end.

  Definition is_all_dec (T : typ) : {S & { U | T = typ_all S U } } + {~is_all T}.
  Proof. destruct T; simpl; eauto. Defined.

  Definition is_bnd (T : typ) :=
    match T with
    | typ_bnd _ _ => True
    | _ => False
    end.

  Definition is_bnd_dec (T : typ) : {S & { U | T = typ_bnd S U } } + {~is_bnd T}.
  Proof. destruct T; simpl; eauto. Defined.

End Predicates.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Structure.Cartesian.
Require Import Category.Construction.Product.
Require Import Category.Instance.Cat.

Generalizable All Variables.

#[export]
Program Instance Cat_Cartesian : @Cartesian Cat := {
  product_obj := @Product;
  fork := fun _ _ _ F G =>
            {| fobj := fun x => (F x, G x)
             ; fmap := fun _ _ f => (fmap[F] f, fmap[G] f) |};
  exl := fun _ _ =>
            {| fobj := fst
             ; fmap := fun _ _ => fst |};
  exr := fun _ _ =>
            {| fobj := snd
             ; fmap := fun _ _ => snd |};
}.
Next Obligation. proper; apply fmap_respects; auto. Qed.
Next Obligation. simplify; rewrite !fmap_comp; intuition. Qed.
Next Obligation.
  rename x into A.
  rename y into B.
  rename z into C.
  proper.
  - isomorphism; simpl; split.
    + apply x2.
    + apply x1.
    + apply (from (x2 _)).
    + apply (from (x1 _)).
    + apply iso_to_from.
    + apply iso_to_from.
    + apply iso_from_to.
    + apply iso_from_to.
  - apply e0.
  - apply e.
Qed.
Next Obligation.
  rename x into A.
  rename y into B.
  rename z into C.
  split; intros; simplify.
  - isomorphism.
    + exact (fst (to (x x0))).
    + exact (fst (from (x x0))).
    + exact (fst (iso_to_from (x x0))).
    + exact (fst (iso_from_to (x x0))).
  - apply (fst (e _ _ _)).
  - isomorphism.
    + exact (snd (to (x x0))).
    + exact (snd (from (x x0))).
    + exact (snd (iso_to_from (x x0))).
    + exact (snd (iso_from_to (x x0))).
  - apply (snd (e _ _ _)).
  - isomorphism.
    + exact(to (x0 x1), to (x x1)).
    + exact(from (x0 x1), from (x x1)).
    + exact(iso_to_from (x0 x1), iso_to_from (x x1)).
    + exact(iso_from_to (x0 x1), iso_from_to (x x1)).
  - apply e0.
  - apply e.
Qed.


(** * Definition of a boolean-returning CFG parser-recognizer *)
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List Coq.Program.Program Coq.Program.Wf Coq.Arith.Wf_nat Coq.Arith.Compare_dec Coq.Classes.RelationClasses Coq.Strings.String.
Require Import ParsingParses.Parsers.ContextFreeGrammar ParsingParses.Parsers.ContextFreeGrammarNotations.
Require Import ParsingParses.Parsers.BaseTypes ParsingParses.Parsers.BooleanBaseTypes.
Require Import ParsingParses.Parsers.Grammars.Trivial ParsingParses.Parsers.Grammars.ABStar.
Require Import ParsingParses.Parsers.Splitters.RDPList ParsingParses.Parsers.Splitters.BruteForce.
Require Import ParsingParses.Common ParsingParses.Common.Wf.

Set Implicit Arguments.
Local Open Scope string_like_scope.

(** TODO: Allow stubbing out of individual sub-parse methods *)
Section recursive_descent_parser.
  Context {CharType}
          {String : string_like CharType}
          {G : grammar CharType}.
  Context `{data : @boolean_parser_dataT _ String}.

  Section bool.
    Section parts.
      Definition parse_item
                 (str_matches_nonterminal : string -> bool)
                 (str : StringWithSplitState String split_stateT)
                 (it : item CharType)
      : bool
        := match it with
             | Terminal ch => [[ ch ]] =s str
             | NonTerminal nt => str_matches_nonterminal nt
           end.

      Section production.
        Context {str0}
                (parse_nonterminal
                 : forall (str : StringWithSplitState String split_stateT),
                     str ≤s str0
                     -> string
                     -> bool).

        (** To match a [production], we must match all of its items.
            But we may do so on any particular split. *)
        Fixpoint parse_production
                 (str : StringWithSplitState String split_stateT)
                 (pf : str ≤s str0)
                 (prod : production CharType)
        : bool.
        Proof.
          refine
            match prod with
              | nil =>
                (** 0-length production, only accept empty *)
                str =s Empty _
              | it::its
                => let parse_production' := fun str pf => parse_production str pf its in
                   fold_right
                     orb
                     false
                     (let mapF f := map f (combine_sig (split_string_for_production_correct it its str)) in
                      mapF (fun s1s2p =>
                              (parse_item
                                 (parse_nonterminal (fst (proj1_sig s1s2p)) _)
                                 (fst (proj1_sig s1s2p))
                                 it)
                                && parse_production' (snd (proj1_sig s1s2p)) _)%bool)
            end;
          revert pf; clear; intros;
          abstract (
              destruct str;
              repeat first [ progress destruct_head sig
                           | progress destruct_head and
                           | etransitivity; eassumption
                           | etransitivity; try eassumption; []
                           | progress subst
                           | idtac; match goal with H : (_ =s _) = true |- _ => apply bool_eq_correct in H end
                           | apply str_le1_append
                           | apply str_le2_append ]
            ).
        Defined.
      End production.

      Section productions.
        Context {str0}
                (parse_nonterminal
                 : forall (str : StringWithSplitState String split_stateT)
                          (pf : str ≤s str0),
                     string -> bool).

        (** To parse as a given list of [production]s, we must parse as one of the [production]s. *)
        Definition parse_productions
                   (str : StringWithSplitState String split_stateT)
                   (pf : str ≤s str0)
                   (prods : productions CharType)
        : bool
          := fold_right orb
                        false
                        (map (parse_production parse_nonterminal str pf)
                             prods).
      End productions.

      Section nonterminals.
        Section step.
          Context {str0 valid}
                  (parse_nonterminal
                   : forall (p : String * nonterminals_listT),
                       prod_relation (ltof _ Length) nonterminals_listT_R p (str0, valid)
                       -> forall str : StringWithSplitState String split_stateT,
                            str ≤s fst p -> string -> bool).

          Definition parse_nonterminal_step
                     (str : StringWithSplitState String split_stateT)
                     (pf : str ≤s str0)
                     (nt : string)
          : bool.
          Proof.
            refine
              (if lt_dec (Length str) (Length str0)
               then (** [str] got smaller, so we reset the valid nonterminals list *)
                 parse_productions
                   (@parse_nonterminal
                      (str : String, initial_nonterminals_data)
                      (or_introl _))
                   _
                   (or_intror eq_refl)
                   (Lookup G nt)
               else (** [str] didn't get smaller, so we cache the fact that we've hit this nonterminal already *)
                 if Sumbool.sumbool_of_bool (is_valid_nonterminal valid nt)
                 then (** It was valid, so we can remove it *)
                   parse_productions
                     (@parse_nonterminal
                        (str0 : String, remove_nonterminal valid nt)
                        (or_intror (conj eq_refl (remove_nonterminal_dec _ nt _))))
                     str
                     _
                     (Lookup G nt)
                 else (** oops, we already saw this nonterminal in the past.  ABORT! *)
                   false);
            assumption.
          Defined.
        End step.

        Section wf.
          (** TODO: add comment explaining signature *)
          Definition parse_nonterminal_or_abort
          : forall (p : String * nonterminals_listT)
                   (str : StringWithSplitState String split_stateT),
              str ≤s fst p
              -> string
              -> bool
            := Fix3
                 _ _ _
                 (well_founded_prod_relation
                    (well_founded_ltof _ Length)
                    ntl_wf)
                 _
                 (fun sl => @parse_nonterminal_step (fst sl) (snd sl)).

          Definition parse_nonterminal
                     (str : StringWithSplitState String split_stateT)
                     (nt : string)
          : bool
            := @parse_nonterminal_or_abort
                 (str : String, initial_nonterminals_data) str
                 (or_intror eq_refl) nt.
        End wf.
      End nonterminals.
    End parts.
  End bool.
End recursive_descent_parser.

(** TODO: move this elsewhere *)
Section example_parse_string_grammar.
  Context (G : grammar Ascii.ascii).

  Definition brute_force_parse_nonterminal
  : @String Ascii.ascii string_stringlike
    -> string
    -> bool
    := let data := @brute_force_data G in parse_nonterminal (G := G).

  Definition brute_force_parse
  : string -> bool
    := fun str => brute_force_parse_nonterminal str G.
End example_parse_string_grammar.

Module example_parse_empty_grammar.
  Definition parse : string -> bool
    := brute_force_parse (trivial_grammar _).

  Time Compute parse "".
  Check eq_refl : true = parse "".
  Time Compute parse "a".
  Check eq_refl : false = parse "a".
  Time Compute parse "aa".
  Check eq_refl : false = parse "aa".
End example_parse_empty_grammar.

Section examples.
  Section ab_star.
    Local Open Scope string_scope.

    Definition parse : string -> bool
      := brute_force_parse ab_star_grammar.

    Time Eval lazy in parse "".
    Check eq_refl : parse "" = true.
    Time Eval lazy in parse "a".
    Check eq_refl : parse "a" = false.
    Time Eval lazy in parse "ab".
    Check eq_refl : parse "ab" = true.
    Time Eval lazy in parse "aa".
    Check eq_refl : parse "aa" = false.
    Time Eval lazy in parse "ba".
    Check eq_refl : parse "ba" = false.
    Time Eval lazy in parse "aba".
    Check eq_refl : parse "aba" = false.
    Time Eval lazy in parse "abab".
    Time Eval lazy in parse "ababab".
    Check eq_refl : parse "ababab" = true.
  (* For debugging: *)(*
    Goal True.
    pose proof (eq_refl (parse "")) as s.
    unfold parse in s.
    unfold brute_force_parse, brute_force_parse_nonterminal in s.
    cbv beta zeta delta [parse_nonterminal] in s.
    cbv beta zeta delta [parse_nonterminal_or_abort] in s.
    rewrite Fix3_eq in s.
    Ltac do_compute_in c H :=
      let c' := fresh in
      set (c' := c) in H;
        compute in c';
        subst c'.
    Tactic Notation "do_compute" open_constr(c) "in" ident(H) :=
      match type of H with
        | appcontext[?c0] => unify c c0
      end;
      do_compute_in c H.
    cbv beta zeta delta [parse_nonterminal_step] in s.
    change (fst (?a, ?b)) with a in s.
    change (snd (?a, ?b)) with b in s.
    unfold split_stateT, brute_force_data, default_string_with_no_state, default_String_with_no_state in s.
    repeat change (string_val {| string_val := ?x |}) with x in s.
    do_compute_in (Start_symbol ab_star_grammar) s.
    do_compute_in (@Length Ascii.ascii string_stringlike "ab_star") s.
    do_compute (lt_dec _ _) in s.
    cbv beta iota zeta in s.
    unfold is_valid_nonterminal, initial_nonterminals_data in s.
    do_compute (is_valid_nonterminal initial_nonterminals_data "") in s.
    set (n := @Length Ascii.ascii string_stringlike ab_star_grammar) in s.
    pose ((Length ab_star_grammar)).
    do_compute_in (Length ab_star_grammar) s.
    do_compute_in (lt_dec (Length ab_star_grammar) (Length string_stringlike "abab"%string)) s.
    change (if in_right then ?x else ?y) with y in s.
    cbv beta zeta delta [rdp_list_is_valid_nonterminal] in s.*)
  End ab_star.
End examples.


From iris.algebra Require Import excl_auth excl auth list.    (* stuff for ghost state *)
From iris.base_logic.lib Require Import invariants cancelable_invariants.
From iris.bi.lib Require Import fractional.
From iris.program_logic Require Import atomic.      (* atomic triples/update *)
From iris.proofmode Require Import tactics.
From iris.heap_lang Require Import lib.par proofmode notation. (* atomic_heap *)

(* Useful reading:
   - https://github.com/tchajed/coq-tricks
   - https://coq.inria.fr/refman/proof-engine/tactics.html#intro-patterns
 *)

(** Simple concurrent stack, with comments, lots of them *)

(* Ghost state is central in Iris, it is defined with resource
   algebras (CMRA). CMRAs are a generalization of partial
   commutative monoids. The composition law of an RA is what
   will give the rules that govern the separating conjunction
   of two ghost state assertions; indeed:

     own a ∗ own b ⊣⊢ own (a ⋅ b)

   where own is how we "lift" an RA element into a proposition.

   The ghost state for our stack, we use the CMRA:

     Auth(Option(Excl(ListOfe)))
       where ListOfe = List(Val)

   Auth takes a CMRA with 'unit' and Excl has no unit, this is
   why we insert Option in the middle.

   Auth is the authoritative monoid, it lets us split some
   knowledge in two parts ● and ◯; ● being the so-called
   authoritative part (usually hidden in an invariant)
   while ◯ is left for clients.

   Excl(X) is a simple monoid parameterized by a set X. It
   composes only trivially (x ⋅ ε) = (ε ⋅ x) = x (where
   x ∈ X); all other compositions are undefined.

   In reality, X in Excl(X) is not a mere set (as described in
   the POPL'15 paper), but an ofe (ordered family of equivalence);
   that is because of a refinement Iris got to support so-called
   "higher-order ghost state" (technically, the step-indexing
   had to make its way into ghost state).

   Note: This CMRA happens to be in the standard library of Iris
   in iris/algebra/lib/excl_auth.v; so we could marginally
   simplify our development using 'excl_authR (list0 val0)'
   directly.
 *)
Class stackG Σ :=
  (* The :> syntax means that when an instance of stackG Σ can
     automatically be seen as an instance of inG Σ (authR ...) *)
  stack_stateG :> inG Σ (authR (optionUR (exclR (listO valO)))).

(* Alternative definition (because there is a single field): *)
(* Class stackG Σ := StackG :> inG Σ (authR (optionUR (exclR (listO valO)))). *)

Section stack.
  (* Context introduces parameters for all the subsequent definitions &
     theorems. Here we assume that we have the ghost state to represent
     a heap (ℓ ↦ v is not buitin, it's coming from the heapG CMRA). And
     also the ghost state for our stack.

     I believe the `{ ... } syntax tells Coq 2 things. First, we want
     it to generalize free variables in ... as "implicit" and
     "maximally inserted" arguments. Second, the `{A, B} syntax lets
     us add variables in our context of type A and B without naming
     them. If we remove the `, we have to give names for the variables.

     Some more details about "maximally inserted" and "implict".
     Implicit means that they are left for Coq to figure out, and
     maximally inserted means that they should be inserted even when no
     explicit arguments are given. 'cons' (the empty list) for instance
     has an implicit argument A : Type that is implicit and maximally
     inserted, so 'Print cons.' will show an unresolved existential for
     this argument A.

     The ! is here to ask Coq not to implicitly add typeclass arguments
     but instead try to resolve them. I believe that in our case it is
     of no use since both heapG and stackG do not have typeclass
     parameters.

     Relevant doc:
       https://coq.inria.fr/refman/language/extensions/implicit-arguments.html#implicit-generalization
       https://softwarefoundations.cis.upenn.edu/draft/qc-current/Typeclasses.html#lab21
   *)
  Context `{!heapG Σ, !stackG Σ} (N : namespace).
  Notation iProp := (iProp Σ).

  (* Heaplang syntax is relatively nice and self-explanatory,
     for a change! *)
  Definition new_stack : val :=
    λ: <>,
      (* Heaplang values & expressions can be explored using

           Print val.

         or, in emacs:  C-c C-a C-p val <ENTER>

         You will see that NONE is not an expression, it is in
         fact a notation defined in iris.heap_lang.notation and
         expands to (InjL #()). Similarly (SOME x) expands to
         (InjR x).
       *)
      let: "head" := ref NONE in
      "head".

  Definition push : val :=
    rec: "push" "stack" "val" :=
      let: "head_old" := !"stack" in
      let: "head_new" := ref ("val", "head_old") in
      if: CAS "stack" "head_old" (SOME "head_new") then
        (* The value is inserted, we are done. *)
        #()
      else
        (* Else, retry. *)
        "push" "stack" "val".

  Definition pop : val :=
    rec: "pop" "stack" :=
      match: !"stack" with
        NONE => NONE (* stack empty *)
      | SOME "head_old" =>
        let: "head_old_data" := !"head_old" in
        (* See if we can change the master head pointer *)
        if: CAS "stack" (SOME "head_old") (Snd "head_old_data") then
          (* The CAS worked. Return the value. *)
          SOME (Fst "head_old_data")
        else
          (* Else, retry. *)
          "pop" "stack"
      end.

  (* Use our ghost state to define a proposition capturing the
     contents of the stack; we are using ◯ because that is the
     proposition we will be giving to clients *)
  Definition stack_content (γs : gname) (l : list val) : iProp :=
    (own γs (◯ Excl' l))%I.

  (* Turn a Coq representation of a stack element into a heaplang
     value *)
  Definition stack_elem_to_val (stack_rep : option loc) : val :=
    match stack_rep with
    | None => NONEV
    | Some l => SOMEV #l
    end.

  (* We can prove that stack_elem_to_val is an injective function.
     Inj is from stdpp, the standard library extended by Iris folks;
     it takes the equivalence relations on the domain and co-domain
     as arguments. Here, we use leibniz equality.

     Local is used because stack_elem_to_val is a notion internal to
     our proof/module. Instance is used because Inj is a typeclass.

     Reference doc:
       https://plv.mpi-sws.org/coqdoc/stdpp/stdpp.base.html#lab8
   *)
  Local Instance stack_elem_to_val_inj : Inj (=) (=) stack_elem_to_val.
  Proof.
    (* Here we use an ssreflect rewrite tactic. /Foo unfolds the
       constant Foo; => is a 'tactical' that moves stuff from the
       goal to the context. In this case we move two universally
       quantified variable x and y. Instead of giving them names
       we use ? to have ssreflect "invent" a name. Note: the invented
       names cannot be mentioned further down in the proof script
       for script-robustness purposes (their names are mangled: _x_
       and _y_).

       Reference doc:
         https://coq.inria.fr/refman/proof-engine/ssreflect-proof-language.html#rewriting
     *)
    rewrite /Inj /stack_elem_to_val => ? ?.
    (* case_match is a tactic from stdpp:
       https://plv.mpi-sws.org/coqdoc/stdpp/stdpp.tactics.html *)
    repeat case_match; congruence.
  Qed.

  (* The classic inductively-defined 'list' separation logic
     predicate *)
  Fixpoint list_inv (l : list val) (rep : option loc) : iProp :=
    match l with
      (* ⌜ ⌝ is used to lift pure Coq/math propositions in iProp *)
    | nil => ⌜rep = None⌝
    | v::l => ∃ (ℓ : loc) (rep' : option loc),
                ⌜rep = Some ℓ⌝ ∗
                ℓ ↦ (v, stack_elem_to_val rep') ∗
                list_inv l rep'
    end%I. (* %I is here to put the whole expression in the correct Coq
              notation namespace; namely the one of Iris propositions *)

  Definition stack_inv (γs : gname) (head : loc) : iProp :=
    (∃ stack_rep l, own γs (● Excl' l) ∗
       head ↦ stack_elem_to_val stack_rep ∗ list_inv l stack_rep)%I.

  (* Name for our local invariant; names are necessary in Iris
     to avoid allowing opening the same invariant in a nested
     fashion; apparently, that'd be unsound. *)
  Let stackN := N .@ "stack".

  (* Finally, define what it is to be a stack; mostly, is_stack holds when
     we hold the stack invariant. *)
  Definition is_stack (γs : gname) (s : val) : iProp :=
    (∃ head : loc, ⌜s = (#head)%V⌝ ∗ inv stackN (stack_inv γs head))%I.

  (* is_stack is a persistent proposition, because both inv and pure propositions
     are persistent; Coq can figure it out without any help via typeclass resolution *)
  Global Instance is_stack_persistent γs s : Persistent (is_stack γs s) := _.

  (* Now for some proofs! *)
  Lemma new_stack_spec :
    {{{ True }}} new_stack #() {{{ γs s, RET s; is_stack γs s ∗ stack_content γs [] }}}.
  Proof.
    iIntros (Φ) "_ HΦ". wp_lam.
    wp_alloc head as "Hhead". wp_let.
    (* The important part of the proof is assembling our invariant.
       We first need to allocate the ghost state. *)
    iMod (own_alloc (● Excl' [] ⋅ ◯ Excl' [])) as (γs) "[Hs● Hs◯]".
    { (* proving: ✓ (● Excl' [] ⋅ ◯ Excl' []) follows from the Auth RA rules *)
      apply auth_both_valid_discrete. split.
      - (* ≼ is a reflexive relation; as such it implements the
           Reflexive typeclass, and Coq can figure it out! The
           real name of ≼ is 'included', as we can read in
           iris/algbra/cmra.v *)
        apply (_ : Reflexive included).
        (* Equivalently, we could have used 'reflexivity.'
           see: https://coq.inria.fr/refman/addendum/generalized-rewriting.html

           One final way to do it is merely to use 'done.'
           which tries a bunch of things it knows about *)

      - (* done. solves this goal, but let's try to figure out
           a proof ourselves to understand what's going on.

           Inspecting the Iris definitions for validity in
           the option and auth CMRAs, it looks like we can
           simply compute in the goal to reduce it to True.
         *)
        exact I. (* so this works! (I is a (the?) proof of True) *)
      (* we're done; all these ramblings could be replaced with
         'by split.' or 'done.'; but here it's about the journey,
         not the destination! *)
    }
    (* Then we allocate the invariant; here we use a "negative"
       specialization pattern to frame all the hypotheses but
       HΦ and Hs◯; we could have equally used with "[Hhead Hs●]" *)
    iMod (inv_alloc stackN _ (stack_inv γs head) with "[-HΦ Hs◯]").
    { iModIntro.                 (* use that P ⊢ ▷P *)
      rewrite /stack_inv.        (* open the stack invariant *)
      iExists None, []. iFrame.  (* set the initial stack representation *)
      done.                      (* boils down to ⌜ None = None ⌝ which done proves *)
    }
    iApply "HΦ". iModIntro.
    iFrame.     (* solves stack_contents ?x [] *)
    iExists _.  (* we can use iExists even with is_stack folded *)
    (* auto. *) (* the last three steps can be solved with auto *)
    iFrame.     (* uses the invariant we proved *)
    iPureIntro. reflexivity.
  Qed.

  (* Some remarks about Iris modalities.
     It is the case that
       P ⊢ |={E}=> P and
       P ⊢ ▷ P
  *)
  Goal ∀(P : iProp) E, (P ⊢ |={E}=> P) ∧ (P ⊢ ▷ P).
  Proof.
    intros. split; iIntros "?"; iModIntro; iAssumption.
  Qed.

  (* Here we prove an atomic triple (using the <<< >>> syntax). This
     is what makes the stack usable in a concurrent setting: as far as
     the user is concerned, a push operation happens atomically (logically
     atomically, to be precise). In particular, this means that the user
     can open invariants around the call to push!

     There is an 'is_stack γs s' assumption, but it is easy to fulfill
     because it is a persistent formula; as such, the library user
     can copy it for all the threads that'll be interacting with the
     stack

     The part '⊤ ∖ ↑N' in the atomic triple specifies an 'outer' mask.
     (See the definition of the notation in iris/program_logic/atomic.v)
     This outer mask makes sure that, when a client uses the atomic
     triple, it does not use an invariant in the upward closure of
     the namespace N (introduced at the beginning of the section).
     That is important because, in the proof of push, we will want
     to open stackN and that's only possible if no enclosing namespace
     is already opened. *)
  Lemma push_spec γs s (v : val) :
    is_stack γs s -∗
    <<< ∀ l : list val, stack_content γs l >>>
      push s v @ ⊤ ∖ ↑N
    <<< stack_content γs (v::l), RET #() >>>.
  Proof.
    (* The first tactic moves is_stack into the persistent context
       using #; the second tactic digs into the syntactic sugar of
       atomic triples.

       Reference doc (about introduction & specialization patterns):
         https://gitlab.mpi-sws.org/iris/iris/-/blob/master/docs/proof_mode.md
     *)
    iIntros "#Hinv". iIntros (Φ) "AU".
    (* First thing we do is open the is_stack predicate; it's a
       black box for the user, but we need it as module implementers.
       The destruct pattern comes in two parts:
         1. a regular Coq part (head)
         2. an Iris part "[-> #Hinv]"
       The Coq pattern is straightforward; the Iris pattern will
       split the separating conjunction ∗ in is_stack in two,
       use the first part as a rewrite rule with ->, and send
       the second part in the persistent context (with #). *)
    iDestruct "Hinv" as (head) "[-> #Hinv]".
    (* We might be calling ourselves recursively, now is a good time
       to use induction because we have not yet expanded the definition
       of push. *)
    iLöb as "IH".
    wp_lam. wp_let.
    (* You might be tempted to use wp_load here (and I tried to!);
       but it will not work.

       Why? because we will only know something about the head
       pointer when we open the invariant. So the first thing to
       do is to focus the WP on an atomic statement (the load),
       then we will be able to open the invariant. *)
    wp_bind (Load _).
    (* The load is focused, we can now use the stack invariant
       for the duration of the load (because it is atomic!).
       When we are done loading, we will have to close the
       invariant for it to be used by other threads. That should
       be easy though, since no mutation happened. *)
    iInv stackN as (stack_rep l) "(H● & H↦ & Hl)" "Hclose".
    (* We now have a head ↦ ? assertion in scope we can use for
       the load. *)
    wp_load.
    (* The load is done, we must close the invariant; we
       simply use all the assertions we got when opening it. *)
    iMod ("Hclose" with "[H● H↦ Hl]").
    { iModIntro. iExists _,_. iFrame. }
    clear l. (* we can get rid of l now *)
    (* Okay, we're done with the first load! *)
    (* We now go though the let; it's easy because we now have
       the value resulting from the load. *)
    iModIntro. wp_let.
    wp_alloc head_new as "Hhead_new". (* execute the allocation *)
    wp_let.
    (* We now reach the second tricky operation of the push function:
       the compare & swap. Again, we'll have to open the invariant,
       so we start by focusing the CAS. *)
    wp_bind (CmpXchg _ _ _).
    (* The CAS will be atomic only if all its arguments are values;
       here we have an InjR argument which we first need to turn into
       a value. *)
    wp_pures.
    (* We can now open the invariant.

       I used a fancy Iris intro pattern to destruct a separating
       conjunction with three elements and strip some ▷ modalities
       (when possible) using ">".

       Unlike for the load above we will not use "Hclose" as
       last parameter here. That makes the proof slightly easier
       as it plays better with the atomic update AU.

       It is nonetheless possible to use "Hclose". The proof has
       to be adapted by splitting the fancy update |={∅,⊤}=> that
       will appear later using transitivity into
       |={∅,⊤∖↑stackN}=> |={⊤∖↑stackN,⊤}=> and eliminating
       the first one using the closing hypothesis given by the
       atomic triple and the second one using Hclose. A comment
       is inserted below to mark the point where transitivity
       would have to be used. If you really want to understand
       what is going on, be sure to edit the proof and use
       "Hclose". *)
    iInv stackN as (stack_rep' l) "(>H● & >H↦ & Hl)".
    (* Note that we may, a priori, get a different stack_rep and a
       different l from the one we got in the first load. That is
       because, in the meantime, some other thread might have changed
       the stack.

       To continue we need to perform a case analysis and find out if
       the CAS will succeed or fail. Equality on loc, and consequently
       on option loc is decidable, so we can use the Decision type
       class. *)
    destruct (decide (stack_elem_to_val stack_rep' = stack_elem_to_val stack_rep))
             (* Fancy Coq intro pattern to
                  1. apply the stack_elem_to_val_inj theorem
                  2. use the result (stack_rep' = stack_rep) as a
                     rewrite rule.
                Reference doc:
                  https://coq.inria.fr/refman/proof-engine/tactics.html#intro-patterns *)
             as [->%stack_elem_to_val_inj|?].
    (* The first case is when the CAS succeeds (stack_rep' = stack_rep). *)
    - wp_cmpxchg_suc.
      { (* The first subgoal is to prove that it is *safe* to compare the two
           values CAS is comparing.

           In iris_heap_lang/lang.v we can find that it is safe when the value
           fit in 64bits. That's a bit weird IMO, considering we've never heard
           of "bits" so far.

           Anyway, looking at the definition of vals_compare_safe, and then
           val_is_unboxed, we see that whatever stack_elem_to_val returns we
           should be okay. So we simply perform a case analysis on stack_rep to
           deal with both cases.
         *)
        destruct stack_rep; simpl; auto.
      }
      (* We now have to close the invariant; it is the non-trivial case,
         because we managed to update the stack! Exciting. Let's try to
         use Hclose.

         I think at this point we'd like to change the list 'l' in the
         invariant and append the new value v to it. For this to work
         we need both (● Excl' l') and (◯ Excl' l'); while we do have the
         former, the latter is hidden in the AU assumption... We'll have
         to get it from there.

         Looking at my main example, it is precisely the point where we
         have to use AU. Let's go.

         That's interesting, AU is really what'll let us close the
         stackN invariant; the Iris destruct pattern below will give
         us two things: a list latomic together with the assumption
         that 'stack_content γs latomic' holds; and a CHOICE expressed
         as a conjunction ∧ of two iProps. We need to choose between:

           1. the blue pill: if the atomic update stays in its
              precondition state
           2. the red pill: if we decide to take the atomic step
              and move to the side of the postcondition; in this
              case, we'll have a way to show Φ, our "final"
              predicate.

         Here we take the red pill!
       *)
      iMod ("AU") as (l') "[H◯ [_ Hredpill]]".
      (* The goal now is to re-establish the invariant;
         for that we need to show 'list_inv (v :: l) ?'.

         First, we use the fact that we have both ● Excl' l and
         ◯ Excl' l' to infer that l = l'. The fancy intro pattern
         goes from ✓ (● Excl' l) (◯ Excl' l') to l' = l; and
         uses this equality to rewrite the goal. *)
      iDestruct (own_valid_2 with "H● H◯") as
        %[->%Excl_included%leibniz_equiv _]%auth_both_valid_discrete.
      (* We now want to go from ● Excl' l to ● Excl' (v :: l).
         To this end, we use the own_update_2 theorem. *)
      iMod (own_update_2 with "H● H◯") as "[H● H◯]".
      { (* The theorems in the comma-separated list below are applied in
           sequence. *)
        apply auth_update, option_local_update.
        apply (exclusive_local_update _ (Excl (v :: l))).
        done.
      }
      (* We'll now use the red pill and, to do so, restore the
         stack invariant with the updated list. *)
      (* If you used Hclose when opening the invariant, now is
         the time to use transitivity of the fancy update
         with iApply fupd_trans. *)
      iMod ("Hredpill" with "H◯") as "HΦ".
      iModIntro. (* c.f. my remarks about modalities *)
      iSplitR "HΦ".
      { iNext. iExists (Some head_new), (v :: l).
        iFrame.  iExists _,_. iFrame. done. }
      (* We're now almost done; concluding is merely a matter of
         using HΦ *)
      wp_pures. by iApply "HΦ".
    (* Moving on to the failure case of the CAS. *)
    - wp_cmpxchg_fail.
      { (* copied from above *) destruct stack_rep; compute; auto. }
      (* We will not use AU directly in the branch because we don't
         need to update the stack invariant. So concluding will be
         a mere matter of applying the Löb induction hypothesis. *)
      iSplitR "AU".
      { iModIntro. iExists _, _. iFrame. }
      iModIntro. wp_pures. by iApply ("IH" with "AU").
  Qed.

End stack.

(* In the following section we use the atomic triple for push to
   prove regular triples on programs that make sequential and
   concurrent access to the stack data structure. *)
Section examples.
  (* We need a bunch of ghost state, heapG is the base,
     spawnG is required to use the par contruct ( ||| ) in
     heaplang, stackG is required for our stack ADT,
     and finally, cinvG is added to support so-called
     cancellable invariants (more on this later). *)
  Context `{!heapG Σ, !spawnG Σ, !stackG Σ, !cinvG Σ} (N : namespace).

  (* The atomic spec is usable to prove regular triples
     about the push operation. *)
  Lemma example_push_twice_seq γs s :
    {{{ is_stack N γs s ∗ stack_content γs [] }}}
      push s #0 ;; push s #1
    {{{ RET #(); stack_content γs [ #1; #0 ] }}}.
  Proof.
    (* We move is_stack into the persistent context to be
       able to use it twice in sequence. *)
    iIntros (Φ) "[#His Hsc] HΦ".
    (* Instead of using wp_apply as we do for regular
       triples we use the awp_apply tactic to use the atomic
       triple. After doing so we end up with a single AACC
       (atomic accessor) proof obligation. *)
    awp_apply (push_spec with "His").
    (* To prove AACC << pre >> mask << pst >> we can use the dedicated
       iAaccIntro tactic. In iris/bi/lib/atomic.v it is also suggested
       that [rewrite /atomic_acc /=] can be used, it might be a good
       exercise to go down this alternative route.

       The iAaccIntro is handy when the precondition of the atomic
       triple is at hand, we can then use iAaccIntro with "Hpre".
       After iAaccIntro, we're required to prove two view shifts:
       one used when the atomic update internally "aborts" (e.g., a
       CAS fails), and one when the update succeeds. *)
    iAaccIntro with "Hsc".
    (* The "abort" view shift is easily proved. *)
    { by eauto with iFrame. }
    (* The success outcome gives us what we need to continue proving
       the sequence of pushed. *)
    iIntros "Hsc". iModIntro. wp_seq.
    (* For some reason I do not understand yet, we have to add the
       without "HΦ" clause, or else we get an error saying "not
       all spatial assumptions are laterable". *)
    awp_apply (push_spec with "His") without "HΦ".
    (* The rest of the proof merely replicates what we've done
       earlier. *)
    iAaccIntro with "Hsc"; first by eauto with iFrame.
    iIntros "Hsc". iModIntro. iIntros "HΦ".
    iApply "HΦ". iAssumption.
  Qed.

  (* Let us now move to a use of our stack in a concurrent context.
     We will simply consider two pushes in parallel to begin with.
     The proof structure will follow rather closely the example 04
     (parallel add) from the POPL 2021 tutorial. *)

  (* Like in the parallel add example in the POPL 2021 tutorial
     we will need a local invariant.

     We use ●E (and ◯E) as succinct notations for ● Excl'
     (and ◯ Excl').

     The invariant says that there are two lists l1 and l2 such
     that the contents of the stack is l1 ++ l2 up to permutation.
     Initially l1 and l2 will be [] and, at the end of the parallel
     push, they will be [0] and [1], respectively. *)
  Definition push_par_inv (γs γ1 γ2 : gname) : iProp Σ :=
    (∃ l l1 l2, ⌜ l ≡ₚ l1 ++ l2 ⌝ ∗  stack_content γs l ∗
       own γ1 (●E l1) ∗ own γ2 (●E l2))%I.

  (* The two pushes can happen in any order, depending on what the
     scheduler does, so we can only prove that the stack contents
     will be the list [1; 0] up to permutation. We use std++'s ≡ₚ
     relation to that end.

     See:
       https://plv.mpi-sws.org/coqdoc/stdpp/stdpp.list.html *)
  Lemma example_push_par γs s :
    {{{ is_stack (N.@"stack") γs s ∗ stack_content γs [] }}}
      ((push s #0) ||| (push s #1)) ;; #()
    {{{ RET #(); ∃ l, ⌜ l ≡ₚ [ #1; #0 ] ⌝ ∗ stack_content γs l }}}.
  Proof.
    (* Again we move is_stack into the permanent context to use it
       in both branches of the parallel composition statement. *)
    iIntros (Φ) "[#His Hsc] HΦ".

    (* We now allocate two pieces of ghost state for l1 and l2.
       It so happens that the ghost state we need here is precisely
       the same as the one in stackG, so we don't need to add anything
       in the Section's Context to have access to it. *)
    iMod (own_alloc (●E[] ⋅ ◯E[])) as (γ1) "[Hγ1● Hγ1◯]";
      first by apply auth_both_valid_discrete.
    iMod (own_alloc (●E[] ⋅ ◯E[])) as (γ2) "[Hγ2● Hγ2◯]";
      first by apply auth_both_valid_discrete.
    (* Here, we depart from the parallel add exercise of the tutorial,
       we use "cinv_alloc" instead of "inv_alloc" to allocate a
       so-called cancellable invariant.

       Cancellable invariants give the user a fractional token; when
       this token is owned in full, it can be used to "cancel" the
       invariant, and recover its contents (for the last time).
       This is critical to be able to recover 'stack_content γs l'
       after the ||| expression terminates. *)
    iMod (cinv_alloc _ (N.@"client") (push_par_inv γs γ1 γ2)
          with "[Hsc Hγ1● Hγ2●]")
      as (γi) "[#Hinv [Ho1 Ho2]]".
    { iExists _,_,_. by iFrame. }

    (* We can now verify the ||| expression; for each branch, we
       have to specify the postcondition. In this case, we want
       that after branch 1 is done the ghost list l1 is [0] and
       the ghost list l2 is [1]. We also want to get back the
       fractions of the cancelation token to be able to cancel
       the invariant. *)
    wp_smart_apply
      (wp_par (λ _, own γ1 (◯E[ #0 ]) ∗ cinv_own γi (1/2))%I
              (λ _, own γ2 (◯E[ #1 ]) ∗ cinv_own γi (1/2))%I
       with "[Hγ1◯ Ho1] [Hγ2◯ Ho2]").

    (* We begin with the first push s #0 expression. Like in the
       sequential example, we use awp_apply push_spec. *)
    - awp_apply (push_spec with "His").
      (* The second thing we need to do is to open our invariant
         Hinv "over" the atomic access. This is where the magic
         of logical atomicity comes into play! Even though push
         is not physically atomic, the logic lets us open our
         local invariant. *)
      iInv "Hinv" as "[>Hppi Ho1]".
      iDestruct "Hppi" as (l l1 l2) "(% & Hsc & Hγ1● & Hγ2●)".
      (* We now have both pieces of the ghost state for l1 so
         we know it is the empty list. *)
      iDestruct (own_valid_2 with "Hγ1● Hγ1◯") as %->%excl_auth_agree_L.
      (* Like in the sequential case, we use iAaccIntro to turn
         the AACC << >> << >> goal into two view shifts. Except,
         this time, there is a tiny bit more work to prove them. *)
      iAaccIntro with "Hsc".
      + (* In the abort case, we have to restore push_par_inv
           invariant as well as the hypotheses we had in our
           linear context right before the call. *)
        iIntros "Hsc". iFrame.
        iExists _,_,_. by iFrame.
      + (* In case of a success, we need to update l1 from []
           to [0]. That is done with the usual own_update_2
           lemma. *)
        iMod (own_update_2 _ _ _ (●E[ #0 ] ⋅ ◯E[ #0 ]) with "Hγ1● Hγ1◯")
          as "[Hγ1● Hγ1◯]"; first by apply excl_auth_update.
        (* Then we can prove that 1/ the postcondition of the
           current ||| branch holds, and 2/ the push_par_inv
           invariant is restored. *)
        iIntros "Hsc". iFrame.
        iExists _,_,_. iFrame. by rewrite H.

    (* The following block is identical to the previous one
       with only minor changes to some indices and #1 where
       #0 was. *)
    - awp_apply (push_spec with "His").
      iInv "Hinv" as "[>Hppi Ho1]".
      iDestruct "Hppi" as (l l1 l2) "(% & Hsc & Hγ1● & Hγ2●)".
      iDestruct (own_valid_2 with "Hγ2● Hγ2◯") as %->%excl_auth_agree_L.
      iAaccIntro with "Hsc".
      + iIntros "Hsc". iFrame.
        iExists _,_,_. by iFrame.
      + iMod (own_update_2 _ _ _ (●E[ #1 ] ⋅ ◯E[ #1 ]) with "Hγ2● Hγ2◯")
          as "[Hγ2● Hγ2◯]"; first by apply excl_auth_update.
        iIntros "Hsc". iFrame.
        iExists _,_,_. iFrame.
        by rewrite H (right_id [] (++)) (comm (++)).

    (* Finally, we need to merge the two branches and prove
       the postcondition. *)
    - iIntros (? ?) "[[Hγ1◯ Ho1] [Hγ2◯ Ho2]]".
      iNext. wp_seq.
      (* We have full ownership of the cancellable invariant, so
         we can cancel it and extract stack_content predicate out
         of it. Note: It as a bit finicky to find when this iMod
         has to happen. I would like to have a clearer understanding
         of the conditions under which an iMod can be applied. *)
      iMod (cinv_cancel with "Hinv [Ho1 Ho2]") as ">Hppi";
        [done|by iApply (fractional_half_2 with "Ho1 Ho2")|].
      (* After we retrieved the contents of push_par_inv, it is
         fairly straightforward to prove the postcondition and
         finish the poof. *)
      iDestruct "Hppi" as (l l1 l2) "(% & Hsc & Hγ1● & Hγ2●)".
      iDestruct (own_valid_2 with "Hγ1● Hγ1◯") as %->%excl_auth_agree_L.
      iDestruct (own_valid_2 with "Hγ2● Hγ2◯") as %->%excl_auth_agree_L.
      iModIntro. iApply ("HΦ" with "[Hsc]"). iExists l. iFrame.
      by rewrite H (comm (++)).
  Qed.

End examples.


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

Require Import Cava.Cava.
Require Import AesImpl.Pkg.
Import Vec.BitVecNotations.
Open Scope bitvec_scope.

Local Notation byte := (Vec Bit 8) (only parsing).
Local Notation "v [@ n ]" := (indexConst v n) (at level 1, format "v [@ n ]").

Section WithCava.
  Context {signal} {semantics : Cava signal}.

  Definition aes_mix_single_column
    (op_i: signal Bit) (data_i: signal (Vec byte 4))
    : cava (signal (Vec byte 4)) :=
    (*
    //
    // AES MixColumns for one single column of the state matrix
    //
    // For details, see Equations 4-7 of:
    // Satoh et al., "A Compact Rijndael Hardware Architecture with S-Box Optimization"
     *)

    (* Get separate bytes from the input column *)
    data_i_0 <- data_i[@0] ;;
    data_i_1 <- data_i[@1] ;;
    data_i_2 <- data_i[@2] ;;
    data_i_3 <- data_i[@3] ;;

    (* // Drive x *)
    (* assign x[0] = data_i[0] ^ data_i[3]; *)
    (* assign x[1] = data_i[3] ^ data_i[2]; *)
    (* assign x[2] = data_i[2] ^ data_i[1]; *)
    (* assign x[3] = data_i[1] ^ data_i[0]; *)
    x_0 <- data_i_0 ^ data_i_3 ;;
    x_1 <- data_i_3 ^ data_i_2 ;;
    x_2 <- data_i_2 ^ data_i_1 ;;
    x_3 <- data_i_1 ^ data_i_0 ;;

    (* // Mul2(x) *)
    (*   for (genvar i = 0; i < 4; i++) begin : gen_x_mul2 *)
    (*     assign x_mul2[i] = aes_mul2(x[i]); *)
    (*   end *)
    x_mul2_0 <- aes_mul2 x_0 ;;
    x_mul2_1 <- aes_mul2 x_1 ;;
    x_mul2_2 <- aes_mul2 x_2 ;;
    x_mul2_3 <- aes_mul2 x_3 ;;

    (* // Drive y_pre_mul4 *)
    (* assign y_pre_mul4[0] = data_i[3] ^ data_i[1]; *)
    (* assign y_pre_mul4[1] = data_i[2] ^ data_i[0]; *)
    y_pre_mul4_0 <- data_i_3 ^ data_i_1 ;;
    y_pre_mul4_1 <- data_i_2 ^ data_i_0 ;;
    (* // Mul4(y_pre_mul4) *)
    (* for (genvar i = 0; i < 2; i++) begin : gen_mul4 *)
    (*   assign y[i] = aes_mul4(y_pre_mul4[i]); *)
    (* end *)
    y_0 <- aes_mul4 y_pre_mul4_0 ;;
    y_1 <- aes_mul4 y_pre_mul4_1 ;;

    (* // Drive y2_pre_mul2 *)
    (* assign y2_pre_mul2 = y[0] ^ y[1]; *)
    y2_pre_mul2 <- y_0 ^ y_1 ;;
    (* // Mul2(y) *)
    (* assign y2 = aes_mul2(y2_pre_mul2); *)
    y2 <- aes_mul2 y2_pre_mul2 ;;

    (* // Drive z *)
    (* assign z[0] = y2 ^ y[0]; *)
    (* assign z[1] = y2 ^ y[1]; *)
    z_0 <- y2 ^ y_0 ;;
    z_1 <- y2 ^ y_1 ;;

    (* // Mux z *)
    (* assign z_muxed[0] = (op_i == CIPH_FWD) ? 8'b0 : z[0]; *)
    (* assign z_muxed[1] = (op_i == CIPH_FWD) ? 8'b0 : z[1]; *)
    zero_byte <- zero_byte ;;
    z_muxed_0 <- mux2 op_i (zero_byte, z_0) ;;
    z_muxed_1 <- mux2 op_i (zero_byte, z_1) ;;

    (* // Drive outputs *)
    (* assign data_o[0] = data_i[1] ^ x_mul2[3] ^ x[1] ^ z_muxed[1]; *)
    (* assign data_o[1] = data_i[0] ^ x_mul2[2] ^ x[1] ^ z_muxed[0]; *)
    (* assign data_o[2] = data_i[3] ^ x_mul2[1] ^ x[3] ^ z_muxed[1]; *)
    (* assign data_o[3] = data_i[2] ^ x_mul2[0] ^ x[3] ^ z_muxed[0]; *)
    data_o0 <- (data_i_1 ^ x_mul2_3 ^ x_1 ^ z_muxed_1) ;;
    data_o1 <- (data_i_0 ^ x_mul2_2 ^ x_1 ^ z_muxed_0) ;;
    data_o2 <- (data_i_3 ^ x_mul2_1 ^ x_3 ^ z_muxed_1) ;;
    data_o3 <- (data_i_2 ^ x_mul2_0 ^ x_3 ^ z_muxed_0) ;;

    packV [data_o0; data_o1; data_o2; data_o3].

  Definition aes_mix_columns
             (op_i : signal Bit)
    : signal (Vec (Vec (Vec Bit 8) 4) 4)
      -> cava (signal (Vec (Vec (Vec Bit 8) 4) 4)) :=
    (* // Transpose to operate on columns
    logic [3:0][3:0][7:0] data_i_transposed;
    logic [3:0][3:0][7:0] data_o_transposed;

    assign data_i_transposed = aes_transpose(data_i);

    // Individually mix columns
    for (genvar i = 0; i < 4; i++) begin : gen_mix_column
      aes_mix_single_column aes_mix_column_i (
        .op_i   ( op_i                 ),
        .data_i ( data_i_transposed[i] ),
        .data_o ( data_o_transposed[i] )
      );
    end

    assign data_o = aes_transpose(data_o_transposed); *)
    aes_transpose >=> Vec.map (aes_mix_single_column op_i)
                  >=> aes_transpose.

End WithCava.


(************************************************************************)
(* Copyright (c) 2017-2018, Ajay Kumar Eeralla <ae266@mail.missouri.edu>*)
(************************************************************************)

Require Export lemma_26.

Set Nested Proofs Allowed.

Import ListNotations.
Axiom ext_blind_enc:  forall {n} (t t0 t1 : message) (z:mylist n), let v0 := (V0 (nonce 0)) in

                                                                     let v1 := (V1 (nonce 0)) in
                                                                                (|v0|#?|v1|) ## TRue ->  (Fresh [1; 2; 3; 4] ([msg t, msg v0, msg v1, msg t0, msg t1])  = true) ->  closMylist ([msg t]) = true -> ((Datatypes.length (distMvars [msg t0, msg t1]))=?  2)%nat = true -> bVarMylist [msg t0, msg t1] = nil  ->
    let mvl:= [5; 6] in  (mVarMsg t0) = mvl /\ (mVarMsg t1) = mvl ->
                 let r0 := (r 1) in
                 let r1 := (r 2) in
                 let k0 := (kc (nonce 3)) in
                 let k1 := (kc (nonce 4)) in
                 let c00 := (comm v0 k0) in
                 let c01 := (comm v0 k1) in
                 let c10 := (comm v1 k0) in
                 let c11 := (comm v1 k1) in
                 let t2 := ({{ 5 := (bl c00 t r0) }} ({{ 6:=(bl c11 t r1) }} t0)) in
                 let t3 := ({{ 5 := (bl c00 t r0) }} ({{ 6:=(bl c11 t r1) }} t1)) in
                 let t4 := ({{ 5 := (bl c10 t r0) }} ({{ 6:=(bl c01 t r1) }} t0)) in
                 let t5 := ({{ 5 := (bl c10 t r0) }} ({{ 6:=(bl c01 t r1) }} t1)) in
                 let e00 := (enc ((c00, ((ub c00 t r0 t2), (nonce 0))), TWO) (pke 11) (er 7)) in
                 let e11 := (enc ((c11, ((ub c11 t r1 t3), (nonce 1))), TWO) (pke 11) (er 8)) in
                 let e10 := (enc ((c10, ((ub c10 t r0 t4), (nonce 0))), TWO) (pke 11) (er 7)) in
                 let e01 := (enc ((c01, ((ub c01 t r1 t5), (nonce 1))), TWO) (pke 11) (er 8)) in
                 (occur_name_mylist 100 [msg t, msg t0, msg t1] = false) ->
                 (z++[msg (bl c00 t r0), msg (bl c11 t r1), bol (acc c00 t r0 t2)& (acc c11 t r1 t3),
                        msg (If (acc c00 t r0 t2)& (acc c11 t r1 t3) then (((e00, e11), ((c00, k0), (c11, k1))), ((c00, ((ub c00 t r0 t2), (nonce 0))), (c11, ((ub c11 t r1 t3), (nonce 1))))) else |_ )])
                    ~

                    (z++[msg (bl c10 t r0), msg (bl c01 t r1), bol (acc c10 t r0 t4)& (acc c01 t r1 t5),
                           msg (If (acc c10 t r0 t4)& (acc c01 t r1 t5) then (((e10, e01),((c01, k1), (c10, k0))), ((c01, ((ub c01 t r1 t5), (nonce 1))),(c10, ((ub c10 t r0 t4), (nonce 0))))) else |_)]).

(** This is the lemma14. *)
Lemma lemma_27_opening_phase: forall t t0 t1 : message,
      let v0 := V0 (nonce 0) in
      let v1 := V1 (nonce 0) in
      (| v0 |) #? (| v1 |) ## TRue ->
      Fresh [1; 2; 3; 4] [msg t, msg v0, msg v1, msg t0, msg t1] = true ->
      closMylist [msg t] = true ->
      (Datatypes.length (distMvars [msg t0, msg t1]) =? 2)%nat = true ->
      bVarMylist [msg t0, msg t1] = nil ->
      let mvl := [5; 6] in
      mVarMsg t0 = mvl /\ mVarMsg t1 = mvl ->

                 let r0 := (r 1) in
                 let r1 := (r 2) in
                 let k0 := (kc (nonce 3)) in
                 let k1 := (kc (nonce 4)) in
                 let c00 := (comm v0 k0) in
                 let c01 := (comm v0 k1) in
                 let c10 := (comm v1 k0) in
                 let c11 := (comm v1 k1) in
                 let b00 := (bl c00 t r0) in
                 let b11 := (bl c11 t r1) in
                 let b10 := (bl c10 t r0) in
                 let b01 := (bl c01 t r1) in
                 let t2 := ({{ 5 := (bl c00 t r0) }} ({{ 6:=(bl c11 t r1) }} t0)) in
                 let t3 := ({{ 5 := (bl c00 t r0) }} ({{ 6:=(bl c11 t r1) }} t1)) in
                 let t4 := ({{ 5 := (bl c10 t r0) }} ({{ 6:=(bl c01 t r1) }} t0)) in
                 let t5 := ({{ 5 := (bl c10 t r0) }} ({{ 6:=(bl c01 t r1) }} t1)) in
                 let e00 := (enc ((c00, ((ub c00 t r0 t2), (nonce 0))), TWO) (pke 11) (er 7)) in
                 let e11 := (enc ((c11, ((ub c11 t r1 t3), (nonce 1))), TWO) (pke 11) (er 8)) in
                 let e10 := (enc ((c10, ((ub c10 t r0 t4), (nonce 0))), TWO) (pke 11) (er 7)) in
                 let e01 := (enc ((c01, ((ub c01 t r1 t5), (nonce 1))), TWO) (pke 11) (er 8)) in
                 let pv00 := (c00, ((ub c00 t r0 t2), (nonce 0))) in
                 let pv11 := (c11, ((ub c11 t r1 t3), (nonce 1))) in
                 let pv10 := (c10, ((ub c10 t r0 t4), (nonce 0))) in
                 let pv01 := (c01, ((ub c01 t r1 t5), (nonce 1))) in
                 let phi02:= [msg b00, msg b11, msg e00, msg e11] in
                 let phi12:= [msg b10, msg b01, msg e10, msg e01] in
                 let fphi02:= f (toListm phi02) in
                 let s0 := (If (e00 #? (tau 1 fphi02)) & (e11 #? (tau 2 fphi02)) then (shufl pv00 pv11 (pi1 (d 3 fphi02)))
                            else (If (e00 #? (tau 1 fphi02)) & (e11 #? (tau 3 fphi02)) then (shufl pv00 (pi1 (d 2 fphi02)) pv11)
                                  else (If (e00 #? (tau 2 fphi02)) & (e11 #? (tau 1 fphi02)) then (shufl pv11 pv00  (pi1 (d 3 fphi02)))
                                        else (If (e00 #? (tau 3 fphi02)) & (e11 #? (tau 1 fphi02)) then (shufl pv11  (pi1 (d 2 fphi02)) pv00)
                                              else (If (e00 #? (tau 2 fphi02)) & (e11 #? (tau 3 fphi02)) then (shufl  (pi1 (d 1 fphi02)) pv11 pv00)
                                                    else (If (e00 #? (tau 3 fphi02)) & (e11 #? (tau 2 fphi02)) then (shufl  (pi1 (d 1 fphi02)) pv00 pv11)
                                                          else O)))))) in

                 let dv0 := (If (dist fphi02) & (pvchecks fphi02) then s0 else |_) in
                 let fphi12:= f (toListm phi12) in
                  let s1 := (If (e10 #? (tau 1 fphi12)) & (e01 #? (tau 2 fphi12)) then (shufl pv10 pv01 (pi1 (d 3 fphi12)))
                            else (If (e10 #? (tau 1 fphi12)) & (e01 #? (tau 3 fphi12)) then (shufl pv10 (pi1 (d 2 fphi12)) pv01)
                                  else (If (e10 #? (tau 2 fphi12)) & (e01 #? (tau 1 fphi12)) then (shufl pv01 pv10 (pi1 (d 3 fphi12)))
                                        else (If (e10 #? (tau 3 fphi12)) & (e01 #? (tau 1 fphi12)) then (shufl pv01 (pi1 (d 2 fphi12)) pv10)
                                              else (If (e10 #? (tau 2 fphi12)) & (e01 #? (tau 3 fphi12)) then (shufl (pi1 (d 1 fphi12)) pv01 pv10)
                                                    else (If (e10 #? (tau 3 fphi12)) & (e01 #? (tau 2 fphi12)) then (shufl (pi1 (d 1 fphi12)) pv10 pv01)
                                                          else O)))))) in

                 let dv1 := (If (dist fphi12) & (pvchecks fphi12) then s1 else |_) in
                 let acc00 := (acc c00 t r0 t2) in
                 let acc11 := (acc c11 t r1 t3) in
                 let acc10 := (acc c10 t r0 t4) in
                 let acc01 := (acc c01 t r1 t5) in
                 let phi03:= phi02 ++[msg dv0] in
                 let phi13:= phi12 ++[msg dv1] in
                 let fphi03 := f (toListm phi03) in
                 let l00 := (If (bnlcheck c00 (nonce 0) fphi03) then (enc ((label c00 fphi03), (k0, THREE)) (pke 11) (er 9)) else O) in
                 let l11 := (If (bnlcheck c11 (nonce 1) fphi03) then (enc ((label c11 fphi03), (k1, THREE)) (pke 11) (er 10)) else O) in
                 let fphi13 := f (toListm phi13) in
                 let l10 := (If (bnlcheck c10 (nonce 0) fphi13) then (enc ((label c10 fphi13), (k0, THREE)) (pke 11) (er 9)) else O) in
                 let l01 := (If (bnlcheck c01 (nonce 1) fphi13) then (enc ((label c01 fphi13), (k1, THREE)) (pke 11) (er 10)) else O) in
                 let phi05:= phi03++[msg l00, msg l11] in
                 let phi15:= phi13++[msg l10, msg l01] in
                 let fphi05 := f (toListm phi05) in
                 let fphi15 := f (toListm phi15) in
                 let do0 := (If (dist fphi05)& (pochecks fphi05)& (((isink k0 fphi05)&(isink k1 fphi05)) or (! ((isink k0 fphi05)or (isink k1 fphi05)))) then (sotrm fphi05) else |_) in
   let do1 := (If (dist fphi15)& (pochecks fphi15)& (((isink k0 fphi15)&(isink k1 fphi15)) or (! ((isink k0 fphi15)or (isink k1 fphi15)))) then (sotrm fphi15) else |_) in
                 let t0s0 := (If acc00 & acc11 then ((e00, (e11, dv0)), (l00, (l11, do0))) else |_) in
                 let t1s1 := (If acc10 & acc01 then ((e10, (e01, dv1)), (l10, (l01, do1))) else |_) in
                 (occur_name_mylist 100 [msg t, msg t0, msg t1] = false) -> (Fresh (cons 0 nil) [msg t, msg t2, msg t3, msg t4, msg t5] = true) ->
                 [msg b00, msg b11, msg t0s0] ~ [msg b10, msg b01, msg t1s1].

Proof. Admitted.


Require String.
Require Import RelationClasses.
Require Import List.
Require Import PArith.
Require Import Omega.
Require Import UsualFMapPositive.
Require Import FMapFacts.
Require Import MSetList.

From sflib Require Import sflib.

Require Import DataStructure.

Set Implicit Arguments.

Ltac refl := reflexivity.
Ltac etrans := etransitivity.
Ltac congr := congruence.

Module Ident <: OrderedTypeWithLeibniz.
  Include Pos.

  Lemma eq_leibniz (x y: t): eq x y -> x = y.
  Proof. auto. Qed.

  Parameter of_string: String.string -> t.
  Hypothesis of_string_inject:
    forall s1 s2 (H12: s1 <> s2), of_string s1 <> of_string s2.

  Ltac ltb_tac :=
    match goal with
    | [H: compare ?x1 ?x2 = _ |- _] =>
      generalize (compare_spec x1 x2); rewrite H; clear H;
      intro H; inversion H; subst; clear H
    | [H: lt ?x ?x |- _] =>
      destruct lt_strorder; congruence
    | [H: lt ?x ?y |- _] =>
      rewrite H in *; clear H
    | [H: eq ?x ?y |- _] =>
      rewrite H in *; clear H
    end.

  Lemma eq_dec_eq A i (a1 a2:A):
    (if eq_dec i i then a1 else a2) = a1.
  Proof.
    destruct (eq_dec i i); [|congruence]. auto.
  Qed.

  Lemma eq_dec_neq A i1 i2 (a1 a2:A)
        (NEQ: i1 <> i2):
    (if eq_dec i1 i2 then a1 else a2) = a2.
  Proof.
    destruct (eq_dec i1 i2); [congruence|]. auto.
  Qed.
End Ident.

Module IdentFun := UsualFun (Ident).
Module IdentSet := UsualSet (Ident).
Module IdentMap := UsualPositiveMap.

Notation rtc := (clos_refl_trans_1n _). (* reflexive transitive closure *)
Notation rc := (clos_refl _). (* reflexive transitive closure *)
Notation tc := (clos_trans _). (* transitive closure *)
Hint Immediate rt1n_refl rt1n_trans t_step.
Hint Resolve Relation_Operators.rt1n_trans.

Program Instance rtc_PreOrder A (R:A -> A -> Prop): PreOrder (rtc R).
Next Obligation.
  ii. revert H0. induction H; auto. i.
  exploit IHclos_refl_trans_1n; eauto.
Qed.
Hint Resolve rtc_PreOrder_obligation_2.

Lemma rtc_tail A R
      (a1 a3:A)
      (REL: rtc R a1 a3):
  (exists a2, rtc R a1 a2 /\ R a2 a3) \/
  (a1 = a3).
Proof.
  induction REL; auto. des; subst.
  - left. eexists. splits; [|eauto].
    econs; eauto.
  - left. eexists. splits; eauto.
Qed.

Lemma rtc_implies A (R1 R2: A -> A -> Prop)
      (IMPL: forall a b, R1 a b -> R2 a b):
  forall a b, rtc R1 a b -> rtc R2 a b.
Proof.
  i. induction H; eauto.
Qed.

Lemma rtc_refl
      A R (a b:A)
      (EQ: a = b):
  rtc R a b.
Proof. subst. econs. Qed.

Lemma rtc_n1
      A R (a b c:A)
      (AB: rtc R a b)
      (BC: R b c):
  rtc R a c.
Proof.
  etrans; eauto.
Qed.

Lemma rtc_reverse
      A R (a b:A)
      (RTC: rtc R a b):
  rtc (fun x y => R y x) b a.
Proof.
  induction RTC; eauto.
  etrans; eauto.
Qed.

Lemma fapp A (B:A->Type) (a:A) (P Q:forall (a:A), B a)
      (EQ: P = Q):
  P a = Q a.
Proof. rewrite EQ. auto. Qed.

Inductive rtcn A (R: A -> A -> Prop): forall (n:nat) (a1 a2:A), Prop :=
| rtcn_nil
    a:
    rtcn R 0 a a
| rtcn_cons
    a1 a2 a3 n
    (A12: R a1 a2)
    (A23: rtcn R n a2 a3):
    rtcn R (S n) a1 a3
.
Hint Constructors rtcn.

Lemma rtcn_rtc A (R: A -> A -> Prop) n a1 a2
      (RTCN: rtcn R n a1 a2):
  rtc R a1 a2.
Proof.
  induction RTCN; auto. econs; eauto.
Qed.

Lemma rtc_rtcn A (R: A -> A -> Prop) a1 a2
      (RTC: rtc R a1 a2):
  exists n, rtcn R n a1 a2.
Proof.
  induction RTC; eauto. i. des.
  esplits; eauto.
Qed.

Lemma rtcn_imply
      A (R1 R2: A -> A -> Prop) n a1 a2
      (LE: forall a b, R1 a b -> R2 a b)
      (RTCN: rtcn R1 n a1 a2):
  rtcn R2 n a1 a2.
Proof.
  induction RTCN; auto. econs; eauto.
Qed.

Lemma strong_induction
      (P : nat -> Prop)
      (IH: forall (n:nat) (IH: forall k (LT: k < n), P k), P n):
  forall n : nat, P n.
Proof.
  i. cut (forall m k, k < m -> P k); [by eauto|].
  induction m.
  - i. omega.
  - i. apply lt_le_S in H. inv H; eauto.
Qed.

Definition option_app {A} (a b: option A) : option A :=
  if a then a else b.

Definition option_rel {A B} (P: A -> B -> Prop) : option A -> option B -> Prop :=
  fun a b => match a, b with
             | Some x, Some y => P x y
             | None, None => True
             | _, _ => False end.

Definition option_rel3 {A B C} (P: A -> B -> C -> Prop):
  option A -> option B -> option C -> Prop :=
  fun a b c => match a, b, c with
            | Some x, Some y, Some z => P x y z
            | None, None, None => True
            | _, _, _ => False
            end.

Lemma strengthen
      (A B: Prop)
      (H: A /\ (A -> B)):
  A /\ B.
Proof. intuition. Qed.

Lemma option_map_map
      A B C (f: B -> C) (g: A -> B) (a: option A):
  option_map f (option_map g a) = option_map (fun x => f (g x)) a.
Proof.
  destruct a; eauto.
Qed.

Definition is_some {A} (o:option A): bool :=
  match o with
  | Some _ => true
  | None => false
  end.
Coercion is_some: option >-> bool.

Ltac condtac :=
  match goal with
  | [|- context[if ?c then _ else _]] =>
    let COND := fresh "COND" in
    destruct c eqn:COND
  end.

Definition proj_sumbool (P Q: Prop) (a: {P} + {Q}) : bool :=
  if a then true else false.

Arguments proj_sumbool [P Q].

Coercion proj_sumbool: sumbool >-> bool.

Lemma proj_sumbool_true:
  forall (P Q: Prop) (a: {P}+{Q}), proj_sumbool a = true -> P.
Proof.
  intros P Q a. destruct a; simpl. auto. congruence.
Qed.

Lemma orb_symm (a b: bool): orb a b -> orb b a.
Proof. destruct a,b; eauto. Qed.

Hint Resolve orb_symm.

Lemma in_prod
      A B
      (a: A)
      (b: B)
      (l: list (A * B))
      (IN: List.In (a, b) l):
  List.In a (List.map (fun x => fst x) l).
Proof.
  revert a b IN. induction l; ss; i. des.
  - destruct a. ss. inv IN. esplits; eauto.
  - exploit IHl; eauto.
Qed.

Lemma in_prod_inv
      A B
      (a: A)
      (l: list (A * B))
      (IN: List.In a (List.map (fun x => fst x) l)):
  exists b, List.In (a, b) l.
Proof.
  revert a IN. induction l; ss; i. des.
  - destruct a. ss. subst. esplits; eauto.
  - exploit IHl; eauto. i. des. eauto.
Qed.

Lemma prod_in
      A B
      (a: A)
      (b: B)
      (l: list B)
      (IN: List.In b l):
  List.In (a, b) (List.map (fun x => (a, x)) l).
Proof.
  revert b IN. induction l; ss; i.
  des; subst; eauto.
Qed.

Lemma Forall_app
      A
      (P: A -> Prop)
      (l1 l2: list A)
      (FORALL1: List.Forall P l1)
      (FORALL2: List.Forall P l2):
  List.Forall P (l1 ++ l2).
Proof.
  induction l1; ss.
  inv FORALL1. eauto.
Qed.

Lemma Forall_app_inv
      A
      (P: A -> Prop)
      (l1 l2: list A)
      (FORALL: List.Forall P (l1 ++ l2)):
  <<FORALL1: List.Forall P l1>> /\
             <<FORALL2: List.Forall P l2>>.
Proof.
  induction l1; split; ss.
  - inv FORALL. exploit IHl1; eauto. i. des. eauto.
  - inv FORALL. exploit IHl1; eauto. i. des. ss.
Qed.


From iris.algebra Require Import frac.
From iris.proofmode Require Import tactics.
From iris.base_logic Require Import invariants.
From cap_machine Require Import stdpp_extra.

Lemma big_sepM_to_big_sepL {Σ : gFunctors} {A B : Type} `{EqDecision A} `{Countable A}
      (r : gmap A B) (lr : list A) (φ : A → B → iProp Σ) :
  NoDup lr →
  (∀ r0, r0 ∈ lr → ∃ b, r !! r0 = Some b) →
  ([∗ map] k↦y ∈ r, φ k y) -∗ ([∗ list] y ∈ lr, ∃ b, φ y b).
Proof.
  iInduction (lr) as [ | r0 ] "IHl" forall (r); iIntros (Hdup Hlookup) "Hmap".
  - done.
  - assert (∃ b, r !! r0 = Some b) as [b Hr0].
    { apply Hlookup. apply elem_of_cons. by left. }
    iDestruct (big_sepM_delete _ _ r0 with "Hmap") as "[Hr0 Hmap]"; eauto.
    iSplitL "Hr0".
    + iExists b. iFrame.
    + iApply ("IHl" with "[] [] [$Hmap]").
      { iPureIntro. apply NoDup_cons_12 in Hdup. auto. }
      iPureIntro.
      intros r1 Hr1.
      destruct (decide (r0 = r1)).
      * subst. apply NoDup_cons in Hdup as [Hnelem Hdup]. contradiction.
      * rewrite lookup_delete_ne;auto. apply Hlookup.
        apply elem_of_cons. by right.
Qed.

Lemma NoDup_of_sepL2_exclusive {Σ : gFunctors} {A B: Type} (l1: list A) (l2: list B) (Φ: A -> B -> iProp Σ):
  (∀ a x1 x2, Φ a x1 -∗ Φ a x2 -∗ False) -∗
  ([∗ list] a;x ∈ l1;l2, Φ a x) -∗
  ⌜NoDup l1⌝.
Proof.
  revert l2. induction l1 as [| a1' l1].
  { iIntros (?) "_ _". iPureIntro. constructor. }
  { iIntros (l2) "HΦ H". destruct l2 as [| a2' l2]; [done|]. cbn. iDestruct "H" as "[Ha1 H]".
    iDestruct (IHl1 with "HΦ H") as %?.
    iAssert (⌜a1' ∉ l1⌝)%I as %?.
    { iIntros (Hin). destruct (elem_of_list_lookup_1 _ _ Hin) as [k ?].
      iDestruct (big_sepL2_length with "H") as %Hlen12.
      destruct (lookup_lt_is_Some_2 l2 k).
      { rewrite -Hlen12 -lookup_lt_is_Some; eauto. }
      iDestruct (big_sepL2_lookup with "H") as "Ha1'"; eauto.
      iApply ("HΦ" with "Ha1 Ha1'"). }
    iPureIntro. by constructor. }
Qed.

Lemma big_sepL2_extract_l `{Σ : gFunctors} {A B : Type}
      (i : nat) (ai : A) (a : list A) (b : list B) (φ : A -> B -> iProp Σ) :
  a !! i = Some ai ->
  (([∗ list] a_i;b_i ∈ a;b, φ a_i b_i) -∗
    (∃ b', [∗ list] a_i;b_i ∈ (delete i a);b', φ a_i b_i) ∗ ∃ b, φ ai b)%I.
Proof.
  iIntros (Hsome) "Hl".
  iDestruct (big_sepL2_length with "Hl") as %Hlength.
  assert (take i a ++ drop i a = a) as Heqa;[apply take_drop|].
  assert (take i b ++ drop i b = b) as Heqb;[apply take_drop|].
  rewrite -Heqa -Heqb.
  iDestruct (big_sepL2_app_inv with "Hl") as "[Htake Hdrop]".
  { apply lookup_lt_Some in Hsome.
    do 2 (rewrite take_length_le;[|lia]). done.
  }
  apply take_drop_middle in Hsome as Hcons.
  assert (ai :: drop (S i) a = drop i a) as Hh.
  { apply app_inv_head with (take i a). congruence. }
  rewrite -Hh.
  iDestruct (big_sepL2_length with "Hdrop") as %Hlength'.
  destruct (drop i b);[inversion Hlength'|].
  iDestruct "Hdrop" as "[Hφ Hdrop]".
  iSplitR "Hφ";[|eauto].
  iExists (take i b ++ l). rewrite Hcons.
  iDestruct (big_sepL2_app with "Htake Hdrop") as "Hl".
  rewrite delete_take_drop. iFrame.
Qed.

Lemma big_sepL2_extract_l' {Σ : gFunctors} {A B : Type} (i : nat) (ai : A) (a : list A) (b : list B) (φ : A -> B -> iProp Σ) :
    a !! i = Some ai ->
    (([∗ list] a_i;b_i ∈ a;b, φ a_i b_i) -∗
     ([∗ list] a_i;b_i ∈ (delete i a);(delete i b), φ a_i b_i) ∗ ∃ b, φ ai b)%I.
Proof.
  iIntros (Hsome) "Hl".
  iDestruct (big_sepL2_length with "Hl") as %Hlength.
  assert (take i a ++ drop i a = a) as Heqa;[apply take_drop|].
  assert (take i b ++ drop i b = b) as Heqb;[apply take_drop|].
  rewrite -Heqa -Heqb.
  iDestruct (big_sepL2_app_inv with "Hl") as "[Htake Hdrop]".
  { apply lookup_lt_Some in Hsome.
    do 2 (rewrite take_length_le;[|lia]). done.
  }
  apply take_drop_middle in Hsome as Hcons.
  assert (ai :: drop (S i) a = drop i a) as Hh.
  { apply app_inv_head with (take i a). congruence. }
  rewrite -Hh.
  iDestruct (big_sepL2_length with "Hdrop") as %Hlength'.
  destruct (drop i b);[inversion Hlength'|].
  iDestruct "Hdrop" as "[Hφ Hdrop]".
  iSplitR "Hφ";[|eauto].
  rewrite Hcons. iDestruct (big_sepL2_app with "Htake Hdrop") as "Hl".
  rewrite Heqb. rewrite (delete_take_drop a).
  rewrite (delete_take_drop b).
  assert (drop (S i) b = l) as Hb.
  { pose proof (take_drop_middle b i b0) as HH.
    enough (b0 :: drop (S i) b = b0 :: l) as He by (inversion He; auto).
    eapply (app_inv_head (take i b)). rewrite HH //.
    rewrite -Heqb. apply list_lookup_middle.
    rewrite take_length_le //. enough (i < length b) by lia.
    rewrite -Hlength. apply lookup_lt_is_Some. eauto. }
  rewrite Hb. iFrame.
Qed.

Lemma big_sepL2_extract' {Σ : gFunctors} {A B : Type} (i : nat) (ai : A) (bi : B) (a : list A) (b : list B) (φ : A -> B -> iProp Σ) :
  a !! i = Some ai -> b !! i = Some bi ->
  (([∗ list] a_i;b_i ∈ a;b, φ a_i b_i) -∗
   ([∗ list] a_i;b_i ∈ (delete i a);(delete i b), φ a_i b_i) ∗ φ ai bi)%I.
Proof.
  iIntros (Hsome Hsome') "Hl".
  iDestruct (big_sepL2_length with "Hl") as %Hlength.
  assert (take i a ++ drop i a = a) as Heqa;[apply take_drop|].
  assert (take i b ++ drop i b = b) as Heqb;[apply take_drop|].
  rewrite -Heqa -Heqb.
  iDestruct (big_sepL2_app_inv with "Hl") as "[Htake Hdrop]".
  { apply lookup_lt_Some in Hsome.
    do 2 (rewrite take_length_le;[|lia]). done.
  }
  apply take_drop_middle in Hsome as Hcons.
  apply take_drop_middle in Hsome' as Hcons'.
  assert (ai :: drop (S i) a = drop i a) as Hh.
  { apply app_inv_head with (take i a). congruence. }
  assert (bi :: drop (S i) b = drop i b) as Hhb.
  { apply app_inv_head with (take i b). congruence. }
  rewrite -Hh. rewrite -Hhb.
  iDestruct "Hdrop" as "[Hφ Hdrop]".
  iSplitR "Hφ";[|eauto].
  rewrite Hcons. rewrite Hcons'. iDestruct (big_sepL2_app with "Htake Hdrop") as "Hl".
  rewrite (delete_take_drop b). rewrite (delete_take_drop a). iFrame.
Qed.

Lemma big_sepL2_close_l {Σ : gFunctors} {A B : Type} (i : nat) (ai : A) (bi : B) (a : list A) (b : list B) (φ : A -> B -> iProp Σ) :
  length a = length b ->
  a !! i = Some ai ->
  (([∗ list] a_i;b_i ∈ (delete i a);(delete i b), φ a_i b_i) ∗ φ ai bi -∗
                                                             ([∗ list] a_i;b_i ∈ a;<[i:= bi]> b, φ a_i b_i) )%I.
Proof.
  iIntros (Hlen Hsome) "[Hl Hb]".
  iDestruct (big_sepL2_length with "Hl") as %Hlength.
  repeat rewrite delete_take_drop.
  apply lookup_lt_Some in Hsome as Hlt.
  assert (i < strings.length b) as Hlt';[lia|].
  iDestruct (big_sepL2_app_inv with "Hl") as "[Htake Hdrop]".
  { repeat rewrite take_length. lia. }
  apply take_drop_middle in Hsome as Hcons.
  assert (ai :: drop (S i) a = drop i a) as Hh.
  { apply app_inv_head with (take i a). rewrite Hcons. by rewrite take_drop. }
  iAssert ([∗ list] y1;y2 ∈ ai :: drop (S i) a;bi :: drop (S i) b, φ y1 y2)%I
    with "[Hb Hdrop]" as "Hdrop";[iFrame|].
  rewrite Hh.
  iDestruct (big_sepL2_app with "Htake Hdrop") as "Hab".
  rewrite take_drop.
  assert (take i b ++ bi :: drop (S i) b = <[i:=bi]> b) as ->;[|iFrame].
  assert (<[i:=bi]> b !! i = Some bi) as Hsome'.
  { apply list_lookup_insert. lia. }
  apply take_drop_middle in Hsome'. rewrite -Hsome'.
  rewrite take_insert;[|lia]. rewrite drop_insert;[|lia]. done.
Qed.

Lemma region_addrs_exists `{Σ : gFunctors} {A B: Type} (a : list A) (φ : A → B → iProp Σ) :
     (([∗ list] a0 ∈ a, (∃ b0, φ a0 b0)) ∗-∗
      (∃ (ws : list B), [∗ list] a0;b0 ∈ a;ws, φ a0 b0))%I.
Proof.
  iSplit.
  - iIntros "Ha".
    iInduction (a) as [ | a0] "IHn".
    + iExists []. done.
    + iDestruct "Ha" as "[Ha0 Ha]".
      iDestruct "Ha0" as (w0) "Ha0".
      iDestruct ("IHn" with "Ha") as (ws) "Ha'".
      iExists (w0 :: ws). iFrame.
  - iIntros "Ha".
    iInduction (a) as [ | a0] "IHn".
    + done.
    + iDestruct "Ha" as (ws) "Ha".
      destruct ws;[by iApply bi.False_elim|].
      iDestruct "Ha" as "[Ha0 Ha]".
      iDestruct ("IHn" with "[Ha]") as "Ha'"; eauto.
      iFrame. eauto.
Qed.

Lemma region_addrs_exists_zip `{Σ : gFunctors} {A B C: Type} (a : list A) (φ : A → B → C -> iProp Σ) :
  (([∗ list] a0 ∈ a, (∃ b0 c0, φ a0 b0 c0)) ∗-∗
  (∃ (ws : list (B * C)), [∗ list] a0;bc0 ∈ a;ws, φ a0 bc0.1 bc0.2))%I.
Proof.
  iSplit.
  - iIntros "Ha".
    iInduction (a) as [ | a0] "IHn".
    + iExists []. done.
    + iDestruct "Ha" as "[Ha0 Ha]".
      iDestruct "Ha0" as (w0 p0) "Ha0".
      iDestruct ("IHn" with "Ha") as (ws) "Ha'".
      iExists ((w0,p0) :: ws). iFrame.
  - iIntros "Ha".
    iInduction (a) as [ | a0] "IHn".
    + done.
    + iDestruct "Ha" as (ws) "Ha".
      destruct ws;[by iApply bi.False_elim|].
      iDestruct "Ha" as "[Ha0 Ha]".
      iDestruct ("IHn" with "[Ha]") as "Ha'"; eauto.
      iFrame. eauto.
Qed.

Lemma region_addrs_exists2 `{Σ : gFunctors} {A B C: Type} (a : list A) (b : list B) (φ : A → B → C -> iProp Σ) :
     (([∗ list] a0;b0 ∈ a;b, (∃ c0, φ a0 b0 c0)) ∗-∗
      (∃ (ws : list C), ⌜length ws = length b⌝ ∗ [∗ list] a0;bc0 ∈ a;(zip b ws), φ a0 bc0.1 bc0.2))%I.
Proof.
  iSplit.
  - iIntros "Ha".
    iInduction (a) as [ | a0] "IHn" forall (b).
    + iExists []. iDestruct (big_sepL2_length with "Ha") as %Hlength.
      destruct b;inversion Hlength. iSplit;auto.
    + iDestruct (big_sepL2_length with "Ha") as %Hlength.
      destruct b; [inversion Hlength|].
      iDestruct "Ha" as "[Ha0 Ha]".
      iDestruct "Ha0" as (w0) "Ha0".
      iDestruct ("IHn" with "Ha") as (ws Hlen) "Ha'".
      iExists (w0 :: ws). simpl. iSplit;auto. iFrame.
   - iIntros "Ha".
     iInduction (a) as [ | a0] "IHn" forall (b).
     + iDestruct "Ha" as (ws Hlen) "Ha".
       iDestruct (big_sepL2_length with "Ha") as %Hlength. destruct b,ws;inversion Hlength; done.
     + iDestruct "Ha" as (ws Hlen) "Ha".
       destruct ws,b;try by iApply bi.False_elim. simpl.
       iDestruct "Ha" as "[Ha0 Ha]". iDestruct (big_sepL2_length with "Ha") as %Hlength.
       iDestruct ("IHn" with "[Ha]") as "Ha'"; iFrame; eauto.
Qed.

Lemma big_sepL2_to_big_sepL_r `{Σ : gFunctors} {A B : Type} (φ : B → iProp Σ) (l1 : list A) l2 :
  length l1 = length l2 →
  (([∗ list] _;y2 ∈ l1;l2, φ y2) ∗-∗
                                 ([∗ list] y ∈ l2, φ y))%I.
Proof.
  iIntros (Hlen).
  iSplit.
  - iIntros "Hl2". iRevert (Hlen).
    iInduction (l2) as [ | y2] "IHn" forall (l1); iIntros (Hlen).
    + done.
    + destruct l1;[by iApply bi.False_elim|].
      iDestruct "Hl2" as "[$ Hl2]".
      iApply ("IHn" with "Hl2"). auto.
  - iIntros "Hl2".
    iRevert (Hlen).
    iInduction (l2) as [ | y2] "IHn" forall (l1); iIntros (Hlen).
    + destruct l1; inversion Hlen. done.
    + iDestruct "Hl2" as "[Hy2 Hl2]".
      destruct l1; inversion Hlen.
      iDestruct ("IHn" $! l1 with "Hl2") as "Hl2".
      iFrame. iApply "Hl2". auto.
Qed.

Lemma big_sepL2_to_big_sepL_l `{Σ : gFunctors} {A B : Type} (φ : A → iProp Σ) (l1 : list A)
      (l2 : list B) :
  length l1 = length l2 →
  (([∗ list] y1;_ ∈ l1;l2, φ y1) ∗-∗
  ([∗ list] y ∈ l1, φ y))%I.
Proof.
  iIntros (Hlen).
  iSplit.
  - iIntros "Hl2". iRevert (Hlen).
    iInduction (l1) as [ | y1] "IHn" forall (l2); iIntros (Hlen).
    + done.
    + destruct l2;[by iApply bi.False_elim|].
      iDestruct "Hl2" as "[$ Hl2]".
      iApply ("IHn" with "Hl2"). auto.
  - iIntros "Hl2".
    iRevert (Hlen).
    iInduction (l1) as [ | y1] "IHn" forall (l2); iIntros (Hlen).
    + destruct l2; inversion Hlen. done.
    + iDestruct "Hl2" as "[Hy2 Hl2]".
      destruct l2; inversion Hlen.
      iDestruct ("IHn" $! l2 with "Hl2") as "Hl2".
      iFrame. iApply "Hl2". auto.
Qed.

Lemma big_sepL2_app'
      (PROP : bi) (A B : Type) (Φ : nat → A → B → PROP) (l1 l2 : list A)
      (l1' l2' : list B) :
  (length l1) = (length l1') →
  (([∗ list] k↦y1;y2 ∈ l1;l1', Φ k y1 y2)
     ∗ ([∗ list] k↦y1;y2 ∈ l2;l2', Φ (strings.length l1 + k) y1 y2))%I
   ≡ ([∗ list] k↦y1;y2 ∈ (l1 ++ l2);(l1' ++ l2'), Φ k y1 y2)%I.
Proof.
  intros Hlenl1.
  iSplit.
  - iIntros "[Hl1 Hl2]". iApply (big_sepL2_app with "Hl1 Hl2").
  - iIntros "Happ".
    iAssert (∃ l0' l0'' : list A,
                ⌜(l1 ++ l2) = l0' ++ l0''⌝
                ∧ ([∗ list] k↦y1;y2 ∈ l0';l1', Φ k y1 y2)
                    ∗ ([∗ list] k↦y1;y2 ∈ l0'';l2', Φ (strings.length l1' + k) y1 y2))%I
      with "[Happ]" as (l0' l0'') "(% & Happl0' & Happl0'')".
    { by iApply (big_sepL2_app_inv_r with "Happ"). }
    iDestruct (big_sepL2_length with "Happl0'") as %Hlen1.
    iDestruct (big_sepL2_length with "Happl0''") as %Hlen2.
    rewrite -Hlenl1 in Hlen1.
    assert (l1 = l0' ∧ l2 = l0'') as [Heq1 Heq2]; first by apply app_inj_1.
    simplify_eq; rewrite Hlenl1.
    iFrame.
Qed.

Lemma big_sepL2_split_at `{Σ : gFunctors} {A B: Type} `{EqDecision A} `{Countable A}
      (k: nat) (l1: list A) (l2: list B) (φ : A → B → iProp Σ):
  ([∗ list] a;b ∈ l1;l2, φ a b) -∗
  ([∗ list] a;b ∈ (take k l1);(take k l2), φ a b) ∗ ([∗ list] a;b ∈ (drop k l1);(drop k l2), φ a b).
Proof.
  iIntros "H".
  iDestruct (big_sepL2_length with "H") as %?.
  rewrite -{1}(take_drop k l1) -{1}(take_drop k l2).
  iDestruct (big_sepL2_app' with "H") as "[? ?]".
  { rewrite !take_length. lia. }
  iFrame.
Qed.

Lemma big_sepL_delete' {PROP: bi} {A: Type} (φ: A -> PROP) (l: list A):
      forall k, (([∗ list] k0↦y ∈ l, if decide (k0 = k) then emp else φ y) -∗
           ([∗ list] k0↦x0 ∈ delete k l, (λ (_ : nat) (x1 : A), φ x1) k0 x0))%I.
Proof.
  iInduction (l) as [|x l] "IH"; simpl; auto; iIntros (k) "H".
  iDestruct "H" as "[H1 H2]".
  rewrite /delete /=. destruct k.
  - iApply (big_sepL_impl with "H2").
    iClear "H1". iModIntro. iIntros. destruct (decide (S k = 0)); auto. lia.
  - simpl. iFrame. iApply ("IH" with "[H2]").
    iApply (big_sepL_impl with "H2").
    iModIntro; iIntros. destruct (decide (k0 = k)); destruct (decide (S k0 = S k)); auto; lia.
Qed.

Lemma big_sepL_merge {PROP: bi} {A: Type} (l: list A) (HNoDup: NoDup l) (φ: A -> PROP) {Haffine: forall a, Affine (φ a)}:
  forall l1 l2, (forall a, a ∈ l -> a ∈ l1 \/ a ∈ l2) ->
           (([∗ list] a ∈ l1, φ a) -∗
            ([∗ list] a ∈ l2, φ a) -∗
            ([∗ list] a ∈ l, φ a))%I.
Proof.
  iInduction (l) as [|x l] "IH"; iIntros (l1 l2 H) "Hl1 Hl2".
  - iApply big_sepL_nil; auto.
  - iApply big_sepL_cons. destruct (H x ltac:(eapply elem_of_list_here)) as [H'|H']; eapply elem_of_list_lookup in H'; destruct H' as [k H'].
    + iDestruct (big_sepL_delete with "Hl1") as "[$ Hl1]"; eauto.
      iAssert ([∗ list] a ∈ delete k l1, φ a)%I with "[Hl1]" as "Hl1".
      { iApply (big_sepL_impl with "[Hl1]"); auto.
        iApply (big_sepL_delete' with "Hl1"). }
      assert (Hincl: ∀ a : A, a ∈ l → a ∈ delete k l1 ∨ a ∈ l2).
      { intros. destruct (H a ltac:(eapply elem_of_list_further; eauto)).
        - left. eapply elem_of_list_lookup in H1. destruct H1.
          eapply elem_of_list_lookup. assert (x0 <> k).
          + red; intros; subst x0. rewrite H1 in H'; inversion H'.
            inversion HNoDup. eapply H5. subst. auto.
          + assert  (x0 < k \/ k <= x0) by lia. destruct H3.
            * exists x0. rewrite lookup_delete_lt; auto.
            * exists (x0 - 1). rewrite lookup_delete_ge; auto; try lia.
              replace (S (x0 - 1)) with x0; auto. lia.
        - right. auto. }
      inversion HNoDup. iApply ("IH" $! H3 (delete k l1) l2 Hincl with "[$Hl1] [$Hl2]").
    + iDestruct (big_sepL_delete with "Hl2") as "[$ Hl2]"; eauto.
      iAssert ([∗ list] a ∈ delete k l2, φ a)%I with "[Hl2]" as "Hl2".
      { iApply (big_sepL_impl with "[Hl2]"); auto.
        iApply (big_sepL_delete' with "Hl2"). }
      assert (Hincl: ∀ a : A, a ∈ l → a ∈ l1 ∨ a ∈ delete k l2).
      { intros. destruct (H a ltac:(eapply elem_of_list_further; eauto)).
        - left. auto.
        - right. eapply elem_of_list_lookup in H1. destruct H1.
          eapply elem_of_list_lookup. assert (x0 <> k).
          + red; intros; subst x0. rewrite H1 in H'; inversion H'.
            inversion HNoDup. subst. eapply H5. auto.
          + assert  (x0 < k \/ k <= x0) by lia. destruct H3.
            * exists x0. rewrite lookup_delete_lt; auto.
            * exists (x0 - 1). rewrite lookup_delete_ge; auto; try lia.
              replace (S (x0 - 1)) with x0; auto. lia. }
      inversion HNoDup. iApply ("IH" $! H3 l1 (delete k l2) Hincl with "[$Hl1] [$Hl2]").
Qed.

Lemma big_sepL2_to_big_sepM (PROP : bi) (A B : Type) `{EqDecision A} `{Countable A}
      (φ: A -> B -> PROP) (l1: list A) (l2: list B):
      NoDup l1 ->
      (([∗ list] y1;y2 ∈ l1;l2, φ y1 y2) -∗
      ([∗ map] y1↦y2 ∈ list_to_map (zip l1 l2), φ y1 y2))%I.
Proof.
  revert l2. iInduction (l1) as [|x l1] "IH"; iIntros (l2 Hnd) "H".
  - iSimpl. iDestruct (big_sepL2_length with "H") as "%".
    destruct l2; simpl in H0; inversion H0.
    iApply big_sepM_empty. auto.
  - iDestruct (big_sepL2_length with "H") as "%".
    destruct l2; simpl in H0; inversion H0.
    simpl. inversion Hnd. iDestruct "H" as "[A B]".
    iApply (big_sepM_insert with "[A B]").
    + eapply not_elem_of_list_to_map.
      rewrite fst_zip; auto. lia.
    + iFrame. iApply ("IH" $! l2 H5 with "B"); auto.
Qed.

Lemma big_sepL2_bupd
   : ∀ (PROP : bi) (H : BiBUpd PROP) (A B : Type) (Φ : A → B → PROP) (l1 : list A) (l2: list B),
       ([∗ list] k;x ∈ l1;l2, |==> Φ k x) -∗ |==> [∗ list] k;x ∈ l1;l2, Φ k x.
Proof.
  intros. revert l2. induction l1 as [| x l1].
  { intros. iIntros "H".
    iDestruct (big_sepL2_length with "H") as %Hlen. cbn in Hlen.
    destruct l2; [| by inversion Hlen]. cbn. eauto. }
  { intros. iIntros "H".
    iDestruct (big_sepL2_length with "H") as %Hlen. cbn in Hlen.
    destruct l2; [by inversion Hlen |]. cbn. iDestruct "H" as "[>? H]".
    iDestruct (IHl1 with "H") as ">?". iModIntro. iFrame. }
Qed.

(* Helper lemma for reasoning about the current state of a region map *)
Lemma big_sepM_exists `{Σ : gFunctors} {A B C : Type} `{EqDecision A, Countable A} (m : gmap A B) (φ : A → C -> B → iProp Σ) :
  (([∗ map] a↦b ∈ m, ∃ c, φ a c b) ∗-∗ (∃ (m' : gmap A C), [∗ map] a↦c;b ∈ m';m, φ a c b))%I.
Proof.
  iSplit.
  - iIntros "Hmap".
    iInduction (m) as [| a x m Hnone] "IH" using map_ind.
    + iExists empty. done.
    + iDestruct (big_sepM_insert with "Hmap") as "[Hc Hmap]"; auto.
      iDestruct "Hc" as (c) "Hc".
      iDestruct ("IH" with "Hmap") as (m') "Hmap".
      iExists (<[a:=c]> m').
      iApply (big_sepM2_insert_2 with "Hc").
      iFrame.
  - iIntros "Hmap".
    iDestruct "Hmap" as (m') "Hmap".
    iInduction (m) as [| a x m Hnone] "IH" using map_ind forall (m').
    + done.
    + iDestruct (big_sepM2_dom with "Hmap") as %Hdom.
      assert (is_Some (m' !! a)) as [ρ Hρ].
      { apply elem_of_gmap_dom. rewrite Hdom dom_insert_L.
        apply elem_of_union_l, elem_of_singleton; auto. }
      rewrite -(insert_id m' a ρ); auto.
      rewrite -insert_delete.
      iDestruct (big_sepM2_insert with "Hmap") as "[Hφ Hmap]";[apply lookup_delete|auto|].
      iApply big_sepM_insert;auto.
      iDestruct ("IH" with "Hmap") as "Hmap". iFrame.
      iExists ρ. iFrame.
Qed.