Require Import Coqlib Maps Integers Floats Errors Globalenvs.
Require Import AST Linking Values Memory Events.

Record attr : Type := mk_attr {
                          attr_volatile: bool;
                          attr_alignas: option N         (**r log2 of required alignment *)
                        }.

Inductive signedness : Type :=
| Signed: signedness
| Unsigned: signedness.

Inductive intsize : Type :=
| I8: intsize
| I16: intsize
| I32: intsize
| IBool: intsize.

Inductive floatsize : Type :=
| F32: floatsize
| F64: floatsize.

Inductive type : Type :=
| Tvoid: type                                    (**r the [void] type *)
| Tint: intsize -> signedness -> attr -> type    (**r integer types *)
| Tlong: signedness -> attr -> type              (**r 64-bit integer types *)
| Tfloat: floatsize -> attr -> type              (**r floating-point types *)
| Tpointer: type -> attr -> type                 (**r pointer types ([*ty]) *)
| Tarray: type -> Z -> attr -> type              (**r array types ([ty[len]]) *)
| Tfunction: typelist -> type -> calling_convention -> type    (**r function types *)
| Tstruct: ident -> attr -> type                 (**r struct types *)
| Tunion: ident -> attr -> type                  (**r union types *)
with typelist : Type :=
     | Tnil: typelist
     | Tcons: type -> typelist -> typelist.

Inductive expr : Type :=
| Eval (v: val) (ty: type)
| Evar (x: ident) (ty: type)
| Eseqand (r1 r2: expr) (ty: type)
| Econdition (r1 r2 r3: expr) (ty: type)
| Eparen (r: expr) (tycast: type) (ty: type).

Inductive kind : Type := LV | RV.

Inductive context: kind -> kind -> (expr -> expr) -> Prop :=
| ctx_top: forall k,
    context k k (fun x => x)
| ctx_seqand: forall k C r2 ty,
    context k RV C -> context k RV (fun x => Eseqand (C x) r2 ty)
| ctx_condition: forall k C r2 r3 ty,
    context k RV C -> context k RV (fun x => Econdition (C x) r2 r3 ty)
| ctx_paren: forall k C ty tycast,
    context k RV C -> context k RV (fun x => Eparen (C x) tycast ty).

(** Strategy for reducing expressions. We reduce the leftmost innermost
  non-simple subexpression, evaluating its arguments (which are necessarily
  simple expressions) with the big-step semantics.
  If there are none, the whole expression is simple and is evaluated in
  one big step. *)
Definition env := PTree.t block.
Definition empty_env: env := (PTree.empty block).

Section SIMPLE_EXPRS.

  Variable e: env.

  Inductive eval_simple_lvalue: expr -> block -> ptrofs -> Prop :=
  | esl_var_local: forall x b ty,
      e!x = Some b ->
      eval_simple_lvalue (Evar x ty) b Ptrofs.zero.

  Inductive eval_simple_rvalue: expr -> val -> Prop :=
  | esr_val: forall v ty, eval_simple_rvalue (Eval v ty) v.

End SIMPLE_EXPRS.

Inductive state: Type :=
| ExprState                           (**r reduction of an expression *)
    (r: expr)
    (e: env)
    (m: mem) : state.

Inductive classify_bool_cases : Type :=
| bool_case_i                           (**r integer *)
| bool_case_l                           (**r long *)
| bool_case_f                           (**r double float *)
| bool_case_s                           (**r single float *)
| bool_default.

Definition noattr := {| attr_volatile := false; attr_alignas := None |}.

Definition change_attributes (f: attr -> attr) (ty: type) : type :=
  match ty with
  | Tvoid => ty
  | Tint sz si a => Tint sz si (f a)
  | Tlong si a => Tlong si (f a)
  | Tfloat sz a => Tfloat sz (f a)
  | Tpointer elt a => Tpointer elt (f a)
  | Tarray elt sz a => Tarray elt sz (f a)
  | Tfunction args res cc => ty
  | Tstruct id a => Tstruct id (f a)
  | Tunion id a => Tunion id (f a)
  end.

Definition remove_attributes (ty: type) : type :=
  change_attributes (fun _ => noattr) ty.

Definition typeconv (ty: type) : type :=
  match ty with
  | Tint (I8 | I16 | IBool) _ _ => Tint I32 Signed noattr
  | Tarray t sz a       => Tpointer t noattr
  | Tfunction _ _ _     => Tpointer ty noattr
  | _                   => remove_attributes ty
  end.

Definition classify_bool (ty: type) : classify_bool_cases :=
  match typeconv ty with
  | Tint _ _ _ => bool_case_i
  | Tpointer _ _ => if Archi.ptr64 then bool_case_l else bool_case_i
  | Tfloat F64 _ => bool_case_f
  | Tfloat F32 _ => bool_case_s
  | Tlong _ _ => bool_case_l
  | _ => bool_default
  end.

Definition bool_val (v: val) (t: type) (m: mem) : option bool :=
  match classify_bool t with
  | bool_case_i =>
    match v with
    | Vint n => Some (negb (Int.eq n Int.zero))
    | Vptr b ofs =>
      if Archi.ptr64 then None else
        if Mem.weak_valid_pointer m b (Ptrofs.unsigned ofs) then Some true else None
    | _ => None
    end
  | bool_case_l =>
    match v with
    | Vlong n => Some (negb (Int64.eq n Int64.zero))
    | Vptr b ofs =>
      if negb Archi.ptr64 then None else
        if Mem.weak_valid_pointer m b (Ptrofs.unsigned ofs) then Some true else None
    | _ => None
    end
  | bool_case_f =>
    match v with
    | Vfloat f => Some (negb (Float.cmp Ceq f Float.zero))
    | _ => None
    end
  | bool_case_s =>
    match v with
    | Vsingle f => Some (negb (Float32.cmp Ceq f Float32.zero))
    | _ => None
    end
  | bool_default => None
  end.

Definition typeof (a: expr) : type :=
  match a with
  | Evar _ ty => ty
  | Eval _ ty => ty
  | Econdition _ _ _ ty => ty
  | Eseqand _ _ ty => ty
  | Eparen _ _ ty => ty
  end.

Inductive classify_cast_cases : Type :=
  | cast_case_pointer                              (**r between pointer types or intptr_t types *)
  | cast_case_i2i (sz2:intsize) (si2:signedness)   (**r int -> int *)
  | cast_case_f2f                                  (**r double -> double *)
  | cast_case_s2s                                  (**r single -> single *)
  | cast_case_f2s                                  (**r double -> single *)
  | cast_case_s2f                                  (**r single -> double *)
  | cast_case_i2f (si1: signedness)                (**r int -> double *)
  | cast_case_i2s (si1: signedness)                (**r int -> single *)
  | cast_case_f2i (sz2:intsize) (si2:signedness)   (**r double -> int *)
  | cast_case_s2i (sz2:intsize) (si2:signedness)   (**r single -> int *)
  | cast_case_l2l                       (**r long -> long *)
  | cast_case_i2l (si1: signedness)     (**r int -> long *)
  | cast_case_l2i (sz2: intsize) (si2: signedness) (**r long -> int *)
  | cast_case_l2f (si1: signedness)                (**r long -> double *)
  | cast_case_l2s (si1: signedness)                (**r long -> single *)
  | cast_case_f2l (si2:signedness)                 (**r double -> long *)
  | cast_case_s2l (si2:signedness)                 (**r single -> long *)
  | cast_case_i2bool                               (**r int -> bool *)
  | cast_case_l2bool                               (**r long -> bool *)
  | cast_case_f2bool                               (**r double -> bool *)
  | cast_case_s2bool                               (**r single -> bool *)
  | cast_case_struct (id1 id2: ident)              (**r struct -> struct *)
  | cast_case_union  (id1 id2: ident)              (**r union -> union *)
  | cast_case_void                                 (**r any -> void *)
  | cast_case_default.

Lemma intsize_eq: forall (s1 s2: intsize), {s1=s2} + {s1<>s2}.
Proof.
  decide equality.
Defined.

Definition classify_cast (tfrom tto: type) : classify_cast_cases :=
  match tto, tfrom with
  (* To [void] *)
  | Tvoid, _ => cast_case_void
  (* To [_Bool] *)
  | Tint IBool _ _, Tint _ _ _ => cast_case_i2bool
  | Tint IBool _ _, Tlong _ _ => cast_case_l2bool
  | Tint IBool _ _, Tfloat F64 _ => cast_case_f2bool
  | Tint IBool _ _, Tfloat F32 _ => cast_case_s2bool
  | Tint IBool _ _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) =>
      if Archi.ptr64 then cast_case_l2bool else cast_case_i2bool
  (* To [int] other than [_Bool] *)
  | Tint sz2 si2 _, Tint _ _ _ =>
      if Archi.ptr64 then cast_case_i2i sz2 si2
      else if intsize_eq sz2 I32 then cast_case_pointer
      else cast_case_i2i sz2 si2
  | Tint sz2 si2 _, Tlong _ _ => cast_case_l2i sz2 si2
  | Tint sz2 si2 _, Tfloat F64 _ => cast_case_f2i sz2 si2
  | Tint sz2 si2 _, Tfloat F32 _ => cast_case_s2i sz2 si2
  | Tint sz2 si2 _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) =>
      if Archi.ptr64 then cast_case_l2i sz2 si2
      else if intsize_eq sz2 I32 then cast_case_pointer
      else cast_case_i2i sz2 si2
  (* To [long] *)
  | Tlong _ _, Tlong _ _ =>
      if Archi.ptr64 then cast_case_pointer else cast_case_l2l
  | Tlong _ _, Tint sz1 si1 _ => cast_case_i2l si1
  | Tlong si2 _, Tfloat F64 _ => cast_case_f2l si2
  | Tlong si2 _, Tfloat F32 _ => cast_case_s2l si2
  | Tlong si2 _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) =>
      if Archi.ptr64 then cast_case_pointer else cast_case_i2l si2
  (* To [float] *)
  | Tfloat F64 _, Tint sz1 si1 _ => cast_case_i2f si1
  | Tfloat F32 _, Tint sz1 si1 _ => cast_case_i2s si1
  | Tfloat F64 _, Tlong si1 _ => cast_case_l2f si1
  | Tfloat F32 _, Tlong si1 _ => cast_case_l2s si1
  | Tfloat F64 _, Tfloat F64 _ => cast_case_f2f
  | Tfloat F32 _, Tfloat F32 _ => cast_case_s2s
  | Tfloat F64 _, Tfloat F32 _ => cast_case_s2f
  | Tfloat F32 _, Tfloat F64 _ => cast_case_f2s
  (* To pointer types *)
  | Tpointer _ _, Tint _ _ _ =>
      if Archi.ptr64 then cast_case_i2l Unsigned else cast_case_pointer
  | Tpointer _ _, Tlong _ _ =>
      if Archi.ptr64 then cast_case_pointer else cast_case_l2i I32 Unsigned
  | Tpointer _ _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) => cast_case_pointer
  (* To struct or union types *)
  | Tstruct id2 _, Tstruct id1 _ => cast_case_struct id1 id2
  | Tunion id2 _, Tunion id1 _ => cast_case_union id1 id2
  (* Catch-all *)
  | _, _ => cast_case_default
  end.

Definition cast_int_int (sz: intsize) (sg: signedness) (i: int) : int :=
  match sz, sg with
  | I8, Signed => Int.sign_ext 8 i
  | I8, Unsigned => Int.zero_ext 8 i
  | I16, Signed => Int.sign_ext 16 i
  | I16, Unsigned => Int.zero_ext 16 i
  | I32, _ => i
  | IBool, _ => if Int.eq i Int.zero then Int.zero else Int.one
  end.

Definition cast_int_float (si: signedness) (i: int) : float :=
  match si with
  | Signed => Float.of_int i
  | Unsigned => Float.of_intu i
  end.

Definition cast_float_int (si : signedness) (f: float) : option int :=
  match si with
  | Signed => Float.to_int f
  | Unsigned => Float.to_intu f
  end.

Definition cast_int_single (si: signedness) (i: int) : float32 :=
  match si with
  | Signed => Float32.of_int i
  | Unsigned => Float32.of_intu i
  end.

Definition cast_single_int (si : signedness) (f: float32) : option int :=
  match si with
  | Signed => Float32.to_int f
  | Unsigned => Float32.to_intu f
  end.

Definition cast_int_long (si: signedness) (i: int) : int64 :=
  match si with
  | Signed => Int64.repr (Int.signed i)
  | Unsigned => Int64.repr (Int.unsigned i)
  end.

Definition cast_long_float (si: signedness) (i: int64) : float :=
  match si with
  | Signed => Float.of_long i
  | Unsigned => Float.of_longu i
  end.

Definition cast_long_single (si: signedness) (i: int64) : float32 :=
  match si with
  | Signed => Float32.of_long i
  | Unsigned => Float32.of_longu i
  end.

Definition cast_float_long (si : signedness) (f: float) : option int64 :=
  match si with
  | Signed => Float.to_long f
  | Unsigned => Float.to_longu f
  end.

Definition cast_single_long (si : signedness) (f: float32) : option int64 :=
  match si with
  | Signed => Float32.to_long f
  | Unsigned => Float32.to_longu f
  end.

Definition sem_cast (v: val) (t1 t2: type) (m: mem): option val :=
  match classify_cast t1 t2 with
  | cast_case_pointer =>
      match v with
      | Vptr _ _ => Some v
      | Vint _ => if Archi.ptr64 then None else Some v
      | Vlong _ => if Archi.ptr64 then Some v else None
      | _ => None
      end
  | cast_case_i2i sz2 si2 =>
      match v with
      | Vint i => Some (Vint (cast_int_int sz2 si2 i))
      | _ => None
      end
  | cast_case_f2f =>
      match v with
      | Vfloat f => Some (Vfloat f)
      | _ => None
      end
  | cast_case_s2s =>
      match v with
      | Vsingle f => Some (Vsingle f)
      | _ => None
      end
  | cast_case_s2f =>
      match v with
      | Vsingle f => Some (Vfloat (Float.of_single f))
      | _ => None
      end
  | cast_case_f2s =>
      match v with
      | Vfloat f => Some (Vsingle (Float.to_single f))
      | _ => None
      end
  | cast_case_i2f si1 =>
      match v with
      | Vint i => Some (Vfloat (cast_int_float si1 i))
      | _ => None
      end
  | cast_case_i2s si1 =>
      match v with
      | Vint i => Some (Vsingle (cast_int_single si1 i))
      | _ => None
      end
  | cast_case_f2i sz2 si2 =>
      match v with
      | Vfloat f =>
          match cast_float_int si2 f with
          | Some i => Some (Vint (cast_int_int sz2 si2 i))
          | None => None
          end
      | _ => None
      end
  | cast_case_s2i sz2 si2 =>
      match v with
      | Vsingle f =>
          match cast_single_int si2 f with
          | Some i => Some (Vint (cast_int_int sz2 si2 i))
          | None => None
          end
      | _ => None
      end
  | cast_case_i2bool =>
      match v with
      | Vint n =>
          Some(Vint(if Int.eq n Int.zero then Int.zero else Int.one))
      | Vptr b ofs =>
          if Archi.ptr64 then None else
          if Mem.weak_valid_pointer m b (Ptrofs.unsigned ofs) then Some Vone else None
      | _ => None
      end
  | cast_case_l2bool =>
      match v with
      | Vlong n =>
          Some(Vint(if Int64.eq n Int64.zero then Int.zero else Int.one))
      | Vptr b ofs =>
          if negb Archi.ptr64 then None else
          if Mem.weak_valid_pointer m b (Ptrofs.unsigned ofs) then Some Vone else None

      | _ => None
      end
  | cast_case_f2bool =>
      match v with
      | Vfloat f =>
          Some(Vint(if Float.cmp Ceq f Float.zero then Int.zero else Int.one))
      | _ => None
      end
  | cast_case_s2bool =>
      match v with
      | Vsingle f =>
          Some(Vint(if Float32.cmp Ceq f Float32.zero then Int.zero else Int.one))
      | _ => None
      end
  | cast_case_l2l =>
      match v with
      | Vlong n => Some (Vlong n)
      | _ => None
      end
  | cast_case_i2l si =>
      match v with
      | Vint n => Some(Vlong (cast_int_long si n))
      | _ => None
      end
  | cast_case_l2i sz si =>
      match v with
      | Vlong n => Some(Vint (cast_int_int sz si (Int.repr (Int64.unsigned n))))
      | _ => None
      end
  | cast_case_l2f si1 =>
      match v with
      | Vlong i => Some (Vfloat (cast_long_float si1 i))
      | _ => None
      end
  | cast_case_l2s si1 =>
      match v with
      | Vlong i => Some (Vsingle (cast_long_single si1 i))
      | _ => None
      end
  | cast_case_f2l si2 =>
      match v with
      | Vfloat f =>
          match cast_float_long si2 f with
          | Some i => Some (Vlong i)
          | None => None
          end
      | _ => None
      end
  | cast_case_s2l si2 =>
      match v with
      | Vsingle f =>
          match cast_single_long si2 f with
          | Some i => Some (Vlong i)
          | None => None
          end
      | _ => None
      end
  | cast_case_struct id1 id2 =>
      match v with
      | Vptr b ofs =>
          if ident_eq id1 id2 then Some v else None
      | _ => None
      end
  | cast_case_union id1 id2 =>
      match v with
      | Vptr b ofs =>
          if ident_eq id1 id2 then Some v else None
      | _ => None
      end
  | cast_case_void =>
      Some v
  | cast_case_default =>
      None
  end.

Definition type_int32s := Tint I32 Signed noattr.

Definition type_bool := Tint IBool Signed noattr.

Inductive estep: state -> trace -> state -> Prop :=
| step_expr: forall r e m v ty,
    eval_simple_rvalue r v ->
    match r with Eval _ _ => False | _ => True end ->
    ty = typeof r ->
    estep (ExprState r e m)
          E0 (ExprState (Eval v ty) e m)
| step_seqand_true: forall C r1 r2 ty e m v,
    context RV RV C ->
    eval_simple_rvalue r1 v ->
    bool_val v (typeof r1) m = Some true ->
    estep (ExprState (C (Eseqand r1 r2 ty)) e m)
          E0 (ExprState (C (Eparen r2 type_bool ty)) e m)
| step_seqand_false: forall C r1 r2 ty e m v,
    context RV RV C ->
    eval_simple_rvalue r1 v ->
    bool_val v (typeof r1) m = Some false ->
    estep (ExprState (C (Eseqand r1 r2 ty)) e m)
          E0 (ExprState (C (Eval (Vint Int.zero) ty)) e m)
| step_condition: forall C r1 r2 r3 ty e m v b,
    context RV RV C ->
    eval_simple_rvalue r1 v ->
    bool_val v (typeof r1) m = Some b ->
    estep (ExprState (C (Econdition r1 r2 r3 ty)) e m)
          E0 (ExprState (C (Eparen (if b then r2 else r3) ty ty)) e m)
| step_paren: forall C r tycast ty e m v1 v,
    context RV RV C ->
    eval_simple_rvalue r v1 ->
    sem_cast v1 (typeof r) tycast m = Some v ->
    estep (ExprState (C (Eparen r tycast ty)) e m)
          E0 (ExprState (C (Eval v ty)) e m).


(**************************  uc/OS-II  ******************************)
(*************************** OS_MUTEX.C *****************************)
(****Proofs for API Fucntion:  void* OSMutexAccept(OS_EVENT* pevent**)
(***************************** Code: ********************************)
(***
Int8u ·OSMutexAccept·(⌞pevent @ OS_EVENT∗⌟)··{
        ⌞
          legal @ Int8u;
          pip @ Int8u
        ⌟;

1         If(pevent′ ==ₑ NULL)
          {
2             RETURN ′0
          };ₛ
3         ENTER_CRITICAL;ₛ
4         legal′ =ᶠ OS_EventSearch(·pevent′·);ₛ
5         If (legal′ ==ₑ ′0)
          {
6             EXIT_CRITICAL;ₛ
7             RETURN ′0
          };ₛ
8         If (pevent′→OSEventType !=ₑ ′OS_EVENT_TYPE_MUTEX)
          {
9           EXIT_CRITICAL;ₛ
10          RETURN ′0
          };ₛ
11        pip′  =ₑ 〈Int8u〉(pevent′→OSEventCnt ≫ ′8);ₛ
12        If ((OSTCBCur′→OSTCBPrio <ₑ pip′) ||ₑ (OSTCBCur′→OSTCBPrio ==ₑ pip′))
          {
13          EXIT_CRITICAL;ₛ
14          RETURN ′OS_ERR_MUTEX_PRIO
          };ₛ
15        If ((pevent′→OSEventCnt &ₑ ′OS_MUTEX_KEEP_LOWER_8) ==ₑ ′OS_MUTEX_AVAILABLE)
          {
16          pevent′→OSEventCnt =ₑ pevent′→OSEventCnt &ₑ ′OS_MUTEX_KEEP_UPPER_8;ₛ
17          pevent′→OSEventCnt =ₑ pevent′→OSEventCnt |ₑ OSTCBCur′→OSTCBPrio;ₛ
18          pevent′→OSEventPtr =ₑ ′OSTCBCur;ₛ
19          EXIT_CRITICAL;ₛ
20          RETURN ′1
          };ₛ
21        EXIT_CRITICAL;ₛ
22        RETURN ′0
*)

Require Import ucos_include.
Require Import OSMutex_common.
Require Import os_ucos_h.
Require Import mutex_absop_rules.
Local Open Scope code_scope.
Local Open Scope Z_scope.
Local Open Scope int_scope.

Theorem OSMutexAccepteRight:
  forall vl p r tid,
    Some p = BuildPreA' os_api OSMutexAccept mutexaccapi vl OSLInv tid init_lg->
    Some r = BuildRetA' os_api OSMutexAccept mutexaccapi vl OSLInv tid init_lg->
    exists t d1 d2 s,
      os_api OSMutexAccept = Some (t, d1, d2, s) /\ {| OS_spec, GetHPrio, OSLInv, I, r, Afalse |} |- tid {{ p }} s {{ Afalse }}.
Proof.
  init_spec.
  destruct x.
  unfolds in H1;destruct H1; intros;  inversion H;
  try solve [inversion H;  inversion H0].
  Focus 2.
  unfolds in H1.
  elim H1; intros; inversion H.
  simpljoin.
  inversion H.

  hoare forward.
  (* intro; tryfalse. *)
  hoare unfold.
  hoare abscsq.
  apply noabs_oslinv.
  eapply  mutexacc_null_absinfer.
  go.
  hoare forward.
  hoare forward.

  hoare unfold.
  false.
  elim H; intros; tryfalse.
  hoare forward.
  destruct a.
  intro; tryfalse.
  hoare unfold.
  instantiate (1:=Afalse).
  false.
  destruct a.
  simpl in H.
  apply H; auto.
  hoare forward.
  hoare unfold.

  hoare forward prim.
  hoare unfold.
  hoare forward.
  sep cancel Aie.
  sep cancel Ais.
  sep cancel Acs.
  sep cancel Aisr.
  sep cancel AECBList.
  sep cancel AOSTCBList.
  sep cancel tcbdllflag.
  sep cancel AOSRdyTblGrp.
  sep cancel AOSTCBPrioTbl.
  sep cancel 1%nat 1%nat.
  eauto 1.
  go.
  go.
  exact retpost_osev.
  intro.
  intros.
  {
    Require Import linv_solver.
    linv_solver.
  }
    linv_solver.
  hoare unfold.
  eapply backward_rule1.

  intros;eapply disj_star_elim.
  eauto.
  hoare forward.
  Focus 2.
  hoare unfold.
  hoare forward.
  change (Int.eq ($ 0) ($ 0)) with true.
  simpl.
  (* intro; tryfalse. *)
  hoare_split_pure_all.
  inverts H7.
  hoare abscsq.
  apply noabs_oslinv.
  eapply mutexacc_no_mutex_err_absinfer.
  go.
  intro.
  simpljoin.
  rewrite H8 in H6.
  tryfalse.
  hoare forward prim.
  sep cancel tcbdllflag.
  eauto.
  go.
  hoare forward.
  hoare forward .
  hoare unfold.
  false.
  clear -H5.
  elim H5; intros.
  int auto.
  int auto.
  hoare unfold.
  inverts H17.
  hoare forward.
  change ( Int.eq ($ 1) ($ 0)) with false.
  (* simpl; intro; tryfalse. *)
  hoare unfold.
  false.
  clear -H11 H12 H13.
  int auto.
  instantiate (1:=Afalse).
  hoare forward.
  hoare unfold.
  hoare forward.
  (* intro; tryfalse. *)

  go.
  destruct (Int.eq i0 ($ OS_EVENT_TYPE_MUTEX)); simpl; intro; tryfalse.
  destruct (Int.eq i0 ($ OS_EVENT_TYPE_MUTEX)); simpl; intro; tryfalse.
  hoare unfold.
  assert (Int.eq i0 ($ OS_EVENT_TYPE_MUTEX) = false).
  clear -H12.
  pauto.

  destruct v'41;
    unfold AEventData;
    hoare_split_pure_all;
    inverts H29;
    unfolds in H6;
    destruct v'46;
    destruct e;
    try solve [inversion H6];
    simpljoin.
  assert (~exists x y w, EcbMod.get v'35 (v'26, Int.zero) = Some (absmutexsem x y, w))  by
          (
        intro;
        assert (EcbMod.get v'35 (v'26, Int.zero) = Some (absmsgq l m, w)) by
            (
              eapply EcbMod.join_get_r; eauto;
              eapply EcbMod.join_get_l; eauto;
              apply EcbMod.get_a_sig_a;
              go);
        simpljoin;
        rewrite H29 in H6; inversion H6).

  hoare abscsq.
  apply noabs_oslinv.
  eapply mutexacc_no_mutex_err_absinfer.
  go.
  auto.
  hoare forward prim.
  unfold AECBList.
  sep pauto.
  2:eauto.
  eapply evsllseg_merge.
  auto.
  simpl.
  sep lift 5%nat in H29.
  apply evsllseg_list_len_eq in H29.
  auto.
  do 2 rewrite l2.
  unfold1 evsllseg.
  sep pauto.
  unfold AEventNode.
  unfold AEventData.
  unfold AOSEvent.
  unfold node.
  unfold AOSEventTbl.
  sep pauto.
  sep cancel Astruct.
  sep cancel Aarray.
  sep cancel 2%nat 1%nat.
  sep cancel evsllseg.
  eauto.
  eauto.
  go.
  go.
  go.
  go.
  go.
  hoare forward.

  assert (~exists x y w, EcbMod.get v'35 (v'26, Int.zero) = Some (absmutexsem x y, w)).
  intro;
    assert (EcbMod.get v'35 (v'26, Int.zero) = Some (abssem i1, w)) by (
                                                                        eapply EcbMod.join_get_r; eauto;
                                                                        eapply EcbMod.join_get_l; eauto;
                                                                        apply EcbMod.get_a_sig_a;
                                                                        go);
    simpljoin.
  rewrite H29 in H6; inversion H6.

  hoare abscsq.
  apply noabs_oslinv.
  eapply mutexacc_no_mutex_err_absinfer.
  go.
  auto.
  hoare forward prim.
  unfold AECBList.
  sep pauto.
  2:eauto.
  eapply evsllseg_merge.
  auto.
  simpl.
  sep lift 4%nat in H29.
  apply evsllseg_list_len_eq in H29.
  auto.

  do 2 rewrite l2.
  unfold1 evsllseg.
  sep pauto.
  unfold AEventNode.
  unfold AEventData.
  unfold AOSEvent.
  unfold node.
  unfold AOSEventTbl.
  sep pauto.
  sep cancel Astruct.
  sep cancel Aarray.
  sep cancel 2%nat 1%nat.
  sep cancel evsllseg.
  eauto.
  go.
  go.
  go.
  go.
  go.
  go.
  hoare forward.

  assert (~exists x y w, EcbMod.get v'35 (v'26, Int.zero) = Some (absmutexsem x y, w)).
  intro;
    assert (EcbMod.get v'35 (v'26, Int.zero) = Some (absmbox m0, w)) by (
                                                                         eapply EcbMod.join_get_r; eauto;
                                                                         eapply EcbMod.join_get_l; eauto;
                                                                         apply EcbMod.get_a_sig_a;
                                                                         go);
    simpljoin.
  rewrite H30 in H6; inversion H6.

  hoare abscsq.
  apply noabs_oslinv.
  eapply mutexacc_no_mutex_err_absinfer.
  go.
  auto.
  hoare forward prim.
  unfold AECBList.
  sep pauto.
  2:eauto.
  eapply evsllseg_merge.
  auto.
  simpl.
  sep lift 4%nat in H30.
  apply evsllseg_list_len_eq in H30.
  auto.

  do 2 rewrite l2.
  unfold1 evsllseg.
  sep pauto.
  unfold AEventNode.
  unfold AEventData.
  unfold AOSEvent.
  unfold node.
  unfold AOSEventTbl.
  sep pauto.
  sep cancel Astruct.
  sep cancel Aarray.
  sep cancel 2%nat 1%nat.
  sep cancel evsllseg.
  eauto.
  eauto.
  go.
  go.
  go.
  go.
  go.
  hoare forward.
  false.
  inverts H28.

  clear -H27.
  int auto.
  hoare forward.

  hoare unfold.

  apply val_inj_eq in H12.
  subst i0.

  unfold AEventData.
  destruct v'41; hoare_split_pure_all.
  inverts H15.
  inverts H12.
  inverts H12.
  inverts H15.
  inverts H17.
  clear H12.
  unfolds in H6.
  destruct v'46; destruct e; tryfalse.

  hoare forward.
  (* intro; tryfalse. *)
  go.
  change (Int.ltu ($ 8) Int.iwordsize ) with true.
  simpl.
  eauto.
  (* intro; tryfalse. *)

 (* skip. (* int32 = int 16 *)  *)

  hoare unfold.
  hoare forward .
  go.

  Local Ltac if_invert := let HH := fresh in
                    match goal with
                      | |- (if ?e then true else false) = false => cut (e = false); [intro HH; rewrite HH; reflexivity| idtac]
                      | |- (if ?e then true else false) = true  => cut (e = true); [intro HH; rewrite HH; reflexivity| idtac]
                    end.
  if_invert.
  rewrite Z.leb_le.
  apply acpt_intlemma1.
  auto.
  clear.
  destruct (Int.ltu i6 (Int.modu (i1 >>ᵢ $ 8) ($ Byte.modulus))); simpl; intro; tryfalse.
  go.

  if_invert.
  rewrite Z.leb_le.
  apply acpt_intlemma1.
  auto.
  destruct (Int.eq i6 (Int.modu (i1 >>ᵢ $ 8) ($ Byte.modulus))); simpl; intro; tryfalse.
  destruct (Int.eq i6 (Int.modu (i1 >>ᵢ $ 8) ($ Byte.modulus))); destruct (Int.ltu i6 (Int.modu (i1 >>ᵢ $ 8) ($ Byte.modulus))); simpl; intro; tryfalse.
  hoare unfold.

  apply or_true_ltrue_rtrue in H15.

  apply val_inj_or in H15.

  rewrite le65535shr8mod255self in H15.
  unfolds in H6.
  simpljoin.
  unfolds in H34.
  simpljoin.

  lets backup : H31.
  unfold1 TCBList_P in H31.
  simpljoin.
  unfolds in H44.
  destruct x4.
  destruct p.
  simpljoin.
  inverts H31.

  inverts H46.
  inverts H6.
  hoare abscsq.
  apply noabs_oslinv.
  eapply mutexacc_prio_err_absinfer.
  go.

  joinsig_solver.
  unfold TcbJoin in H34.
  unfold TcbJoin in *.
  unfold join in *.
  simpl in H34.
  simpl in H29.
  eapply TcbMod.join_get_r.
  eauto.
  eapply TcbMod.join_get_l.
  eauto.
  eapply TcbMod.get_a_sig_a.
  go.

  inverts e.
  clear -H15.
  remember (Int.shru x ($ 8)).
  clear Heqi.
  destruct H15; intros.
  int auto.
  int auto.
  hoare forward prim.
  unfold AOSTCBList.
  unfold tcbdllseg.
  sep pauto.
  sep cancel 3%nat 1%nat.
  unfold dllseg; fold dllseg.
  unfold node.
  sep pauto.
  sep cancel 1%nat 1%nat.
  sep cancel 1%nat 1%nat.
  instantiate (3:=
                 (v'22 ++
                       ((V$OS_EVENT_TYPE_MUTEX
                          :: Vint32 i :: Vint32 i1 :: v0 :: x3 :: v'42 :: nil, v'40) :: nil) ++
                       v'23)).
  instantiate (2:=(v'24 ++ (DMutex (Vint32 i1) v0 :: nil) ++ v'25)).
  do 2 rewrite list_prop1.
  unfold AECBList.
  sep pauto.
  eapply evsllseg_merge.
  auto.
  simpl.
  sep lift 5%nat in H6.
  lets aaa : evsllseg_list_len_eq H6.
  auto.
  sep cancel 4%nat 1%nat.
  unfold1 evsllseg.
  unfold AEventNode.
  unfold AEventData.
  unfold AOSEvent.
  unfold node.
  unfold AOSEventTbl.
  sep pauto.
  sep cancel Astruct.
  sep cancel Aarray.
  sep cancel evsllseg.
  eauto.

  go.
  go.
  go.
  go.
  go.
  go.
  go.
  go.
  go.
  go.
  go.
  go.
  hoare forward.
  auto.

  hoare forward.
  hoare unfold.
  (**)
  hoare forward.
  (* intro; tryfalse. *)
  go.
  (* intro; tryfalse. *)
  clear; destruct (Int.eq (i1&ᵢ$ OS_MUTEX_KEEP_LOWER_8) ($ OS_MUTEX_AVAILABLE)); intro; tryfalse.
  instantiate (1:=Afalse).
  Focus 2.
  hoare forward.
  hoare unfold.

  assert ( (i1&ᵢ$ OS_MUTEX_KEEP_LOWER_8) <> ($ OS_MUTEX_AVAILABLE)).
  clear -H17.

  intro.
  assert (Int.eq  (i1&ᵢ$ OS_MUTEX_KEEP_LOWER_8) ($ OS_MUTEX_AVAILABLE) = true).
  rewrite H; clear ; int auto.
  rewrite H0 in H17.
  simpl in H17;elim H17; intros; clear -H1.
  int auto.
  int auto.
  unfolds in H6.
  simpljoin.
  inverts H6.
  lets aaa: H48 H32.
  simpljoin.

  hoare abscsq.
  apply noabs_oslinv.
  eapply  mutexacc_no_available_absinfer.
  go.
  joinsig_solver.
  hoare forward prim.

  unfold AOSTCBList.
  unfold tcbdllseg.
  sep pauto.
  sep cancel 3%nat 1%nat.
  unfold dllseg; fold dllseg.
  unfold node.
  sep pauto.
  sep cancel 1%nat 1%nat.
  sep cancel 1%nat 1%nat.

  instantiate (3:=
                 (v'22 ++
                       ((V$OS_EVENT_TYPE_MUTEX
                          :: Vint32 i :: Vint32 x :: Vptr x0 :: x3 :: v'42 :: nil, v'40)
                          :: nil) ++ v'23)).

  instantiate (2:= (v'24 ++ (DMutex (Vint32 x) (Vptr x0) :: nil) ++ v'25)).
  do 2 rewrite list_prop1.
  unfold AECBList.
  sep pauto.
  eapply evsllseg_merge.
  auto.
  simpl.
  sep lift 5%nat in H6.
  lets aaa : evsllseg_list_len_eq H6.
  auto.
  sep cancel 4%nat 1%nat.
  unfold1 evsllseg.
  unfold AEventNode.
  unfold AEventData.
  unfold AOSEvent.
  unfold node.
  unfold AOSEventTbl.
  sep pauto.
  unfold1 evsllseg.
  sep cancel Astruct.
  sep cancel Aarray.
  sep cancel evsllseg.
  eauto.
  go.
  go.
  go.
  go.
  go.
  go.
  go.
  go.
  go.
  go.
  go.
  go.
  hoare forward.

  (* succ *)
  hoare unfold.
  hoare forward.
  (* intro; tryfalse. *)
  go.
  (* intro; tryfalse. *)
  hoare unfold.
  hoare forward.
  (* intro; tryfalse. *)
  go.
  assert (  Int.unsigned (i1&ᵢ$ OS_MUTEX_KEEP_UPPER_8) <= Int16.max_unsigned ).

  apply acpt_int_lemma0; auto.
  clear -H47 H48.
  omega.
  go.
  (* intro; tryfalse. *)
  hoare unfold.

  hoare forward.
  lets acopy : H10.

  unfolds in H6.
  simpljoin.
  apply acpt_intlemma2 in H17.
  inverts H6.
  lets aaa: H48 H17.
  simpljoin.
  unfolds in H10.
  simpljoin.

  hoare abscsq.
  apply noabs_oslinv.
  eapply  mutexacc_succ_absinfer.
  go.
  go.
  go.

  unfolds in H31.
  simpljoin.
  unfolds in H47.
  destruct x9; destruct p.
  simpljoin.
  inverts H51.
  inverts H10.
  assert (TcbMod.get v'36 (v'48, Int.zero) = Some (p, t, m)).
  eapply TcbMod.join_get_r.
  eauto.
  eapply TcbMod.join_get_l; eauto.
  exact H46.
  apply TcbMod.get_a_sig_a.
  go.
  unfold get in H6; simpl in H6.
  rewrite H10 in H6.
  inverts H6.

  rewrite  intlemma13 in H15.

  apply intlemma11; auto.
  change (Int.unsigned ($ Byte.modulus)) with 256.
  assert (Int.unsigned (Int.shru  x ($ 8)) <= 255).
  apply  acpt_intlemma10; auto.
  clear -H6; omega.

  apply intlemma11 in H15.
  rewrite intlemma13 in H15.
  Focus 2.
    change (Int.unsigned ($ Byte.modulus)) with 256.
    assert (Int.unsigned (Int.shru  x ($ 8)) <= 255).
    apply  acpt_intlemma10; auto.
    clear -H10; omega.

  lets backup_tcbp : H31.
  unfold1 TCBList_P in H31.
  simpljoin.
  unfold TCBNode_P in H47.
  inverts H31.
  destruct x9; destruct p.
  simpljoin.
  inverts H47; inverts H31; inverts H10.
  assert ( TcbMod.get v'36 (v'48, Int.zero) = Some (p, t, m)).
  eapply TcbMod.join_get_r.
  eauto.
  eapply TcbMod.join_get_l; eauto.
  exact H46.
  apply TcbMod.get_a_sig_a.
  go.
  unfold get in H6; simpl in H6.
  rewrite H6 in H10.
  inverts H10.
  lets backup_ecbp : H3.
  do 2 rewrite list_prop1 in H3.

  apply ecblist_p_decompose in H3.
  simpljoin.
  2:auto.

  unfold ECBList_P in H10; fold ECBList_P in H10.
  simpljoin.
  inverts H54.
  lets aaa: ecblist_p_eqh H5 H57.
  instantiate (1:=v'35).
  unfolds.
  unfold EcbMod.lookup.
  intros.
  go.
  unfolds.
  unfold EcbMod.lookup.
  unfold TcbJoin in H55.
  unfold join in H55.
  simpl in H55.
  unfolds in H57.
  intros.
  go.
  simpljoin.

  lets aaa: ecblist_p_eqh H3 H4.
  instantiate (1:=v'35).
  unfolds.
  unfold EcbMod.lookup.
  intros.
  go.
  unfolds.
  unfold EcbMod.lookup.
  intros.
  go.
  simpljoin.
  inverts H10.

  destruct x7.
(* ** ac:   Check mutex_no_owner_nil_wls. *)
  lets aa: mutex_no_owner_nil_wls H56.

  subst w0.
  lets aaa: mutex_no_owner_nil_wls' H34.
  subst w.

  hoare forward prim.
  instantiate (12:=(v'22 ++
                        ((V$OS_EVENT_TYPE_MUTEX
                           :: Vint32 i ::  Vint32 (Int.or (x&ᵢ$ OS_MUTEX_KEEP_UPPER_8) p)
                           :: Vptr (v'48, Int.zero) :: x3 :: x10 :: nil, v'40)
                           :: nil) ++ v'23)).
  instantiate (11:=  (v'24 ++ (DMutex  (Vint32 (Int.or (x&ᵢ $ OS_MUTEX_KEEP_UPPER_8) p)) (Vptr (v'48, Int.zero)) :: nil) ++ v'25) ).
  unfold AECBList.
  unfold AOSTCBList.
  unfold tcbdllseg.
  sep pauto.
  sep cancel 5%nat 1%nat.
  unfold1 dllseg.
  unfold node.
  sep pauto.
  sep cancel 3%nat 1%nat.
  sep cancel 3%nat 1%nat.
  do 2 rewrite list_prop1.
  eapply evsllseg_merge.
  auto.
  sep lift 6%nat in H10.
  simpl.
  lets aaa:  evsllseg_list_len_eq H10.
  auto.

  sep cancel 5%nat 1%nat.
  unfold1 evsllseg.
  unfold AEventNode.
  unfold AOSEvent.
  unfold AEventData.
  unfold node.
  unfold AOSEventTbl.
  sep pauto.
  sep cancel Astruct.
  sep cancel Aarray.
  sep cancel evsllseg.
  eauto.

  go.
  go.
  go.
  go.
  go.

  assert ( Int.unsigned (Int.or (x&ᵢ$ OS_MUTEX_KEEP_UPPER_8) p) <= Int16.max_unsigned).

  apply acpt_intlemma6.
  lets aaa: tcbblk_prio_range H51.
  unfold V_OSTCBPrio in aaa.
  simpl in aaa.
  instantiate (1:=p) in aaa.
  lets bbb: aaa (eq_refl (Some (Vint32 p))).
  clear -bbb.
  omega.
  clear -H58 H59; omega.

  go.
  go.
  go.
  do 2 rewrite list_prop1.

  eapply ecblist_p_compose.
  2:exact H3.

  Focus 2.

  unfold1 ECBList_P.
  eexists; splits.
  eauto.

  apply R_ECB_ETbl_P_high_ecb_mutex_acpt_hold.
  auto.

  do 3 eexists; splits.
  go.
  3:go.
  instantiate (2:= (absmutexsem (Int.shru ( Int.or (x &ᵢ $ OS_MUTEX_KEEP_UPPER_8) p) ($ 8)) ( Some
                                                                                (v'48, Int.zero, p)), nil)).

  eapply ecb_sig_join_sig'_set.
  eauto.

  eapply  RLH_ECBData_p_high_mbox_acpt_hold.

  lets aaa: tcbblk_prio_range H51.
  unfold V_OSTCBPrio in aaa.
  simpl in aaa.
  instantiate (1:=p) in aaa.
  lets bbb: aaa (eq_refl (Some (Vint32 p))).
  clear -bbb.
  omega.
  auto.

  eauto.
  rewrite acpt_intlemma4.
  2:auto.
  eapply EcbMod.join_set_r.
  auto.
  unfolds.
  eexists.
  go.
  lets aaa: tcbblk_prio_range H51.
  unfold V_OSTCBPrio in aaa.
  simpl in aaa.
  instantiate (1:=p) in aaa.
  lets bbb: aaa (eq_refl (Some (Vint32 p))).
  clear -bbb.
  omega.

  eauto.
  eauto.
  go.

  eapply mutex_acpt_rh_tcblist_ecblist_p_hold.
  go.
  go.
  go.
  go.
  hoare forward.

Qed.


From stdpp Require Import namespaces.
From iris.algebra Require Export gmap coPset local_updates.
From iris.algebra Require Import updates proofmode_classes.
From iris.prelude Require Import options.

(** The camera [namespace_map A] over a camera [A] provides the connectives
[namespace_map_data N a], which associates data [a : A] with a namespace [N],
and [namespace_map_token E], which says that no data has been associated with
the namespaces in the mask [E]. The important properties of this camera are:

- The lemma [namespace_map_token_union] enables one to split [namespace_map_token]
  w.r.t. disjoint union. That is, if we have [E1 ## E2], then we get
  [namespace_map_token (E1 ∪ E2) = namespace_map_token E1 ⋅ namespace_map_token E2]
- The lemma [namespace_map_alloc_update] provides a frame preserving update to
  associate data to a namespace [namespace_map_token E ~~> namespace_map_data N a]
  provided [↑N ⊆ E] and [✓ a]. *)

Record namespace_map (A : Type) := NamespaceMap {
  namespace_map_data_proj : gmap positive A;
  namespace_map_token_proj : coPset_disj
}.
Add Printing Constructor namespace_map.
Global Arguments NamespaceMap {_} _ _.
Global Arguments namespace_map_data_proj {_} _.
Global Arguments namespace_map_token_proj {_} _.
Global Instance: Params (@NamespaceMap) 1 := {}.
Global Instance: Params (@namespace_map_data_proj) 1 := {}.
Global Instance: Params (@namespace_map_token_proj) 1 := {}.

(** TODO: [positives_flatten] violates the namespace abstraction. *)
Definition namespace_map_data {A : cmra} (N : namespace) (a : A) : namespace_map A :=
  NamespaceMap {[ positives_flatten N := a ]} ε.
Definition namespace_map_token {A : cmra} (E : coPset) : namespace_map A :=
  NamespaceMap ∅ (CoPset E).
Global Instance: Params (@namespace_map_data) 2 := {}.

(* Ofe *)
Section ofe.
Context {A : ofe}.
Implicit Types x y : namespace_map A.

Local Instance namespace_map_equiv : Equiv (namespace_map A) := λ x y,
  namespace_map_data_proj x ≡ namespace_map_data_proj y ∧
  namespace_map_token_proj x = namespace_map_token_proj y.
Local Instance namespace_map_dist : Dist (namespace_map A) := λ n x y,
  namespace_map_data_proj x ≡{n}≡ namespace_map_data_proj y ∧
  namespace_map_token_proj x = namespace_map_token_proj y.

Global Instance NamespaceMap_ne : NonExpansive2 (@NamespaceMap A).
Proof. by split. Qed.
Global Instance NamespaceMap_proper : Proper ((≡) ==> (=) ==> (≡)) (@NamespaceMap A).
Proof. by split. Qed.
Global Instance namespace_map_data_proj_ne: NonExpansive (@namespace_map_data_proj A).
Proof. by destruct 1. Qed.
Global Instance namespace_map_data_proj_proper :
  Proper ((≡) ==> (≡)) (@namespace_map_data_proj A).
Proof. by destruct 1. Qed.

Definition namespace_map_ofe_mixin : OfeMixin (namespace_map A).
Proof.
  by apply (iso_ofe_mixin
    (λ x, (namespace_map_data_proj x, namespace_map_token_proj x))).
Qed.
Canonical Structure namespace_mapO :=
  Ofe (namespace_map A) namespace_map_ofe_mixin.

Global Instance NamespaceMap_discrete a b :
  Discrete a → Discrete b → Discrete (NamespaceMap a b).
Proof. intros ?? [??] [??]; split; unfold_leibniz; by eapply discrete. Qed.
Global Instance namespace_map_ofe_discrete :
  OfeDiscrete A → OfeDiscrete namespace_mapO.
Proof. intros ? [??]; apply _. Qed.
End ofe.

Global Arguments namespace_mapO : clear implicits.

(* Camera *)
Section cmra.
Context {A : cmra}.
Implicit Types a b : A.
Implicit Types x y : namespace_map A.

Global Instance namespace_map_data_ne i : NonExpansive (@namespace_map_data A i).
Proof. solve_proper. Qed.
Global Instance namespace_map_data_proper N :
  Proper ((≡) ==> (≡)) (@namespace_map_data A N).
Proof. solve_proper. Qed.
Global Instance namespace_map_data_discrete N a :
  Discrete a → Discrete (namespace_map_data N a).
Proof. intros. apply NamespaceMap_discrete; apply _. Qed.
Global Instance namespace_map_token_discrete E : Discrete (@namespace_map_token A E).
Proof. intros. apply NamespaceMap_discrete; apply _. Qed.

Local Instance namespace_map_valid_instance : Valid (namespace_map A) := λ x,
  match namespace_map_token_proj x with
  | CoPset E =>
     ✓ (namespace_map_data_proj x) ∧
     (* dom (namespace_map_data_proj x) ⊥ E *)
     ∀ i, namespace_map_data_proj x !! i = None ∨ i ∉ E
  | CoPsetBot => False
  end.
Global Arguments namespace_map_valid_instance !_ /.
Local Instance namespace_map_validN_instance : ValidN (namespace_map A) := λ n x,
  match namespace_map_token_proj x with
  | CoPset E =>
     ✓{n} (namespace_map_data_proj x) ∧
     (* dom (namespace_map_data_proj x) ⊥ E *)
     ∀ i, namespace_map_data_proj x !! i = None ∨ i ∉ E
  | CoPsetBot => False
  end.
Global Arguments namespace_map_validN_instance !_ /.
Local Instance namespace_map_pcore_instance : PCore (namespace_map A) := λ x,
  Some (NamespaceMap (core (namespace_map_data_proj x)) ε).
Local Instance namespace_map_op_instance : Op (namespace_map A) := λ x y,
  NamespaceMap (namespace_map_data_proj x ⋅ namespace_map_data_proj y)
               (namespace_map_token_proj x ⋅ namespace_map_token_proj y).

Definition namespace_map_valid_eq :
  valid = λ x, match namespace_map_token_proj x with
               | CoPset E =>
                  ✓ (namespace_map_data_proj x) ∧
                  (* dom (namespace_map_data_proj x) ⊥ E *)
                  ∀ i, namespace_map_data_proj x !! i = None ∨ i ∉ E
               | CoPsetBot => False
               end := eq_refl _.
Definition namespace_map_validN_eq :
  validN = λ n x, match namespace_map_token_proj x with
                  | CoPset E =>
                     ✓{n} (namespace_map_data_proj x) ∧
                     (* dom (namespace_map_data_proj x) ⊥ E *)
                     ∀ i, namespace_map_data_proj x !! i = None ∨ i ∉ E
                  | CoPsetBot => False
                  end := eq_refl _.

Lemma namespace_map_included x y :
  x ≼ y ↔
    namespace_map_data_proj x ≼ namespace_map_data_proj y ∧
    namespace_map_token_proj x ≼ namespace_map_token_proj y.
Proof.
  split; [intros [[z1 z2] Hz]; split; [exists z1|exists z2]; apply Hz|].
  intros [[z1 Hz1] [z2 Hz2]]; exists (NamespaceMap z1 z2); split; auto.
Qed.

Lemma namespace_map_data_proj_validN n x : ✓{n} x → ✓{n} namespace_map_data_proj x.
Proof. by destruct x as [? [?|]]=> // -[??]. Qed.
Lemma namespace_map_token_proj_validN n x : ✓{n} x → ✓{n} namespace_map_token_proj x.
Proof. by destruct x as [? [?|]]=> // -[??]. Qed.

Lemma namespace_map_cmra_mixin : CmraMixin (namespace_map A).
Proof.
  apply cmra_total_mixin.
  - eauto.
  - by intros n x y1 y2 [Hy Hy']; split; simpl; rewrite ?Hy ?Hy'.
  - solve_proper.
  - intros n [m1 [E1|]] [m2 [E2|]] [Hm ?]=> // -[??]; split; simplify_eq/=.
    + by rewrite -Hm.
    + intros i. by rewrite -(dist_None n) -Hm dist_None.
  - intros [m [E|]]; rewrite namespace_map_valid_eq namespace_map_validN_eq /=
      ?cmra_valid_validN; naive_solver eauto using O.
  - intros n [m [E|]]; rewrite namespace_map_validN_eq /=;
      naive_solver eauto using cmra_validN_S.
  - split; simpl; [by rewrite assoc|by rewrite assoc_L].
  - split; simpl; [by rewrite comm|by rewrite comm_L].
  - split; simpl; [by rewrite cmra_core_l|by rewrite left_id_L].
  - split; simpl; [by rewrite cmra_core_idemp|done].
  - intros ??; rewrite! namespace_map_included; intros [??].
    by split; simpl; apply: cmra_core_mono. (* FIXME: FIXME(Coq #6294): needs new unification *)
  - intros n [m1 [E1|]] [m2 [E2|]]=> //=; rewrite namespace_map_validN_eq /=.
    rewrite {1}/op /cmra_op /=. case_decide; last done.
    intros [Hm Hdisj]; split; first by eauto using cmra_validN_op_l.
    intros i. move: (Hdisj i). rewrite lookup_op.
    case: (m1 !! i)=> [a|]; last auto.
    move=> [].
    { by case: (m2 !! i). }
    set_solver.
  - intros n x y1 y2 ? [??]; simpl in *.
    destruct (cmra_extend n (namespace_map_data_proj x)
      (namespace_map_data_proj y1) (namespace_map_data_proj y2))
      as (m1&m2&?&?&?); auto using namespace_map_data_proj_validN.
    destruct (cmra_extend n (namespace_map_token_proj x)
      (namespace_map_token_proj y1) (namespace_map_token_proj y2))
      as (E1&E2&?&?&?); auto using namespace_map_token_proj_validN.
    by exists (NamespaceMap m1 E1), (NamespaceMap m2 E2).
Qed.
Canonical Structure namespace_mapR :=
  Cmra (namespace_map A) namespace_map_cmra_mixin.

Global Instance namespace_map_cmra_discrete :
  CmraDiscrete A → CmraDiscrete namespace_mapR.
Proof.
  split; first apply _.
  intros [m [E|]]; rewrite namespace_map_validN_eq namespace_map_valid_eq //=.
  by intros [?%cmra_discrete_valid ?].
Qed.

Local Instance namespace_map_empty_instance : Unit (namespace_map A) := NamespaceMap ε ε.
Lemma namespace_map_ucmra_mixin : UcmraMixin (namespace_map A).
Proof.
  split; simpl.
  - rewrite namespace_map_valid_eq /=. split; [apply ucmra_unit_valid|]. set_solver.
  - split; simpl; [by rewrite left_id|by rewrite left_id_L].
  - do 2 constructor; [apply (core_id_core _)|done].
Qed.
Canonical Structure namespace_mapUR :=
  Ucmra (namespace_map A) namespace_map_ucmra_mixin.

Global Instance namespace_map_data_core_id N a :
  CoreId a → CoreId (namespace_map_data N a).
Proof. do 2 constructor; simpl; auto. apply core_id_core, _. Qed.

Lemma namespace_map_data_valid N a : ✓ (namespace_map_data N a) ↔ ✓ a.
Proof. rewrite namespace_map_valid_eq /= singleton_valid. set_solver. Qed.
Lemma namespace_map_token_valid E : ✓ (namespace_map_token E).
Proof. rewrite namespace_map_valid_eq /=. split; first done. by left. Qed.
Lemma namespace_map_data_op N a b :
  namespace_map_data N (a ⋅ b) = namespace_map_data N a ⋅ namespace_map_data N b.
Proof.
  by rewrite {2}/op /namespace_map_op_instance /namespace_map_data /= singleton_op left_id_L.
Qed.
Lemma namespace_map_data_mono N a b :
  a ≼ b → namespace_map_data N a ≼ namespace_map_data N b.
Proof. intros [c ->]. rewrite namespace_map_data_op. apply cmra_included_l. Qed.
Global Instance namespace_map_data_is_op N a b1 b2 :
  IsOp a b1 b2 →
  IsOp' (namespace_map_data N a) (namespace_map_data N b1) (namespace_map_data N b2).
Proof. rewrite /IsOp' /IsOp=> ->. by rewrite namespace_map_data_op. Qed.

Lemma namespace_map_token_union E1 E2 :
  E1 ## E2 →
  namespace_map_token (E1 ∪ E2) = namespace_map_token E1 ⋅ namespace_map_token E2.
Proof.
  intros. by rewrite /op /namespace_map_op_instance
    /namespace_map_token /= coPset_disj_union // left_id_L.
Qed.
Lemma namespace_map_token_difference E1 E2 :
  E1 ⊆ E2 →
   namespace_map_token E2 = namespace_map_token E1 ⋅ namespace_map_token (E2 ∖ E1).
Proof.
  intros. rewrite -namespace_map_token_union; last set_solver.
  by rewrite -union_difference_L.
Qed.
Lemma namespace_map_token_valid_op E1 E2 :
  ✓ (namespace_map_token E1 ⋅ namespace_map_token E2) ↔ E1 ## E2.
Proof.
  rewrite namespace_map_valid_eq /= {1}/op /cmra_op /=. case_decide; last done.
  split; [done|]; intros _. split.
  - by rewrite left_id.
  - intros i. rewrite lookup_op lookup_empty. auto.
Qed.

(** [↑N ⊆ E] is stronger than needed, just [positives_flatten N ∈ E] would be
sufficient. However, we do not have convenient infrastructure to prove the
latter, so we use the former. *)
Lemma namespace_map_alloc_update E N a :
  ↑N ⊆ E → ✓ a → namespace_map_token E ~~> namespace_map_data N a.
Proof.
  assert (positives_flatten N ∈ (↑N : coPset)).
  { rewrite nclose_eq. apply elem_coPset_suffixes.
    exists 1%positive. by rewrite left_id_L. }
  intros ??. apply cmra_total_update=> n [mf [Ef|]] //.
  rewrite namespace_map_validN_eq /= {1}/op /cmra_op /=. case_decide; last done.
  rewrite left_id_L {1}left_id. intros [Hmf Hdisj]; split.
  - destruct (Hdisj (positives_flatten N)) as [Hmfi|]; last set_solver.
    move: Hmfi. rewrite lookup_op lookup_empty left_id_L=> Hmfi.
    intros j. rewrite lookup_op.
    destruct (decide (positives_flatten N = j)) as [<-|].
    + rewrite Hmfi lookup_singleton right_id_L. by apply cmra_valid_validN.
    + by rewrite lookup_singleton_ne // left_id_L.
  - intros j. destruct (decide (positives_flatten N = j)); first set_solver.
    rewrite lookup_op lookup_singleton_ne //.
    destruct (Hdisj j) as [Hmfi|?]; last set_solver.
    move: Hmfi. rewrite lookup_op lookup_empty; auto.
Qed.
Lemma namespace_map_updateP P (Q : namespace_map A → Prop) N a :
  a ~~>: P →
  (∀ a', P a' → Q (namespace_map_data N a')) → namespace_map_data N a ~~>: Q.
Proof.
  intros Hup HP. apply cmra_total_updateP=> n [mf [Ef|]] //.
  rewrite namespace_map_validN_eq /= left_id_L. intros [Hmf Hdisj].
  destruct (Hup n (mf !! positives_flatten N)) as (a'&?&?).
  { move: (Hmf (positives_flatten N)).
    by rewrite lookup_op lookup_singleton Some_op_opM. }
  exists (namespace_map_data N a'); split; first by eauto.
  rewrite /= left_id_L. split.
  - intros j. destruct (decide (positives_flatten N = j)) as [<-|].
    + by rewrite lookup_op lookup_singleton Some_op_opM.
    + rewrite lookup_op lookup_singleton_ne // left_id_L.
      move: (Hmf j). rewrite lookup_op. eauto using cmra_validN_op_r.
  - intros j. move: (Hdisj j).
    rewrite !lookup_op !op_None !lookup_singleton_None. naive_solver.
Qed.
Lemma namespace_map_update N a b :
  a ~~> b → namespace_map_data N a ~~> namespace_map_data N b.
Proof.
  rewrite !cmra_update_updateP. eauto using namespace_map_updateP with subst.
Qed.
End cmra.

Global Arguments namespace_mapR : clear implicits.
Global Arguments namespace_mapUR : clear implicits.


Require Import Coq.Strings.String Coq.Lists.List.
Require Import Fiat.Parsers.ContextFreeGrammar.Core Fiat.Parsers.ContextFreeGrammar.Notations.
Require Import Fiat.Parsers.StringLike.String.

Require Import Fiat.Parsers.Grammars.JSON.

Local Arguments Equality.ascii_beq !_ !_.
Local Arguments Equality.string_beq !_ !_.
Local Arguments list_to_productions / _ _ _ _.
Local Arguments ascii_of_nat !_ / .
Local Arguments ascii_of_pos !_ / .

Local Notation LF := (ascii_of_nat 10).
Local Notation CR := (ascii_of_nat 13).
Local Notation TAB := (ascii_of_nat 9).
Local Notation SPACE := " "%char.

Local Coercion test_string_of_ascii (ch : ascii) := String.String ch EmptyString.
Global Arguments test_string_of_ascii / _.

Local Notation newline := (String.String LF EmptyString).

Local Ltac unfolder :=
  unfold Lookup;
  repeat match goal with
         | [ |- context[Operations.List.first_index_error ?f ?ls] ]
           => let c := constr:(Operations.List.first_index_error f ls) in
              let c' := (eval cbv in c) in
              change c with c'
         | _ => progress unfold option_rect
         | _ => progress unfold nth
         end.

Local Ltac safe_step :=
  idtac;
  (match goal with
   | _ => reflexivity
   | [ |- context[Valid_nonterminals ?G] ]
     => let c := constr:(Valid_nonterminals G) in
        let c' := (eval cbv in c) in
        change c with c'
   | [ |- context G[Lookup ?x ?y] ]
     => is_var x;
        let x' := (eval unfold x in x) in
        let G' := context G[Lookup x' y] in
        change G';
        unfolder
   | [ |- parse_of_production _ ?s (Terminal _ :: _) ]
     => apply ParseProductionCons with (n := 1)
   | [ |- parse_of_production _ ?s (_ :: nil) ]
     => apply ParseProductionCons with (n := String.length s)
   | [ |- parse_of_production _ ?s (_ :: nil) ]
     => apply ParseProductionCons with (n := String.length s)
   | [ |- parse_of_production _ ?s (_ :: Terminal _ :: nil) ]
     => apply ParseProductionCons with (n := String.length s - 1)
   | [ |- parse_of_production _ ?s (_ :: Terminal _ :: Terminal _ :: nil) ]
     => apply ParseProductionCons with (n := String.length s - 2)
   | [ |- parse_of_production _ _ nil ]
     => apply ParseProductionNil
   | [ |- parse_of_item _ (String.String ?ch EmptyString) (Terminal _) ]
     => refine (ParseTerminal _ _ ch _ _ _); simpl; reflexivity
   | [ |- parse_of_item _ _ (Terminal _) ]
     => (refine (ParseTerminal _ _ _ _ _ _);
          simpl;
          erewrite ?Equality.ascii_lb by reflexivity;
          reflexivity)
   | [ |- parse_of_item _ _ (NonTerminal _) ]
     => apply ParseNonTerminal
   | [ |- parse_of _ _ (_::nil) ] => apply ParseHead
   | [ |- parse_of _ ?s (nil::_) ]
     => first [ unify s ""%string; apply ParseHead
              | apply ParseTail ]
    | [ |- parse_of _ (String.String ?ch _) (((Terminal (Equality.ascii_beq ?ch')):: _)::_) ]
      => first [ unify ch ch'; fail 1
               | apply ParseTail ]
   | [ |- is_true (is_char (take 1 _) _) ] => apply get_0
   | _ => progress simpl
   | _ => tauto
   end).

Section json.
  Example json_parses_singleline : parse_of_grammar ("[ " ++ CR ++ LF ++ TAB ++ """xy ]z\"""" ]")%string json_grammar.
  Proof.
    hnf; simpl.
    apply ParseTail; repeat safe_step.
    apply ParseHead; repeat safe_step.
    apply ParseProductionCons with (n := 4); repeat safe_step.
    apply ParseProductionCons with (n := 9); simpl; repeat safe_step.
    { apply ParseHead; repeat safe_step.
      apply ParseProductionCons with (n := 1); repeat safe_step.
      apply ParseProductionCons with (n := 1); repeat safe_step.
      apply ParseProductionCons with (n := 1); repeat safe_step.
      apply ParseProductionCons with (n := 1); repeat safe_step.
      apply ParseProductionCons with (n := 1); repeat safe_step.
      apply ParseHead; repeat safe_step.
      apply ParseProductionCons with (n := 1); repeat safe_step. }
    { apply ParseProductionCons with (n := 1); simpl; repeat safe_step. }
  Qed.
End json.


(** * Properties about Context Free Grammars *)
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Common Fiat.Common.UIP.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.Equality.

Set Implicit Arguments.

Local Open Scope list_scope.

Global Instance item_rect_Proper {Char T}
: Proper (pointwise_relation _ eq ==> pointwise_relation _ eq ==> eq ==> eq)
         (@item_rect Char (fun _ => T)).
Proof.
  lazy.
  intros ?? H ?? H' ? [?|?] ?; subst; eauto with nocore.
Qed.
Global Instance item_rect_Proper_forall {Char T}
: Proper (forall_relation (fun _ => eq) ==> forall_relation (fun _ => eq) ==> forall_relation (fun _ => eq))
         (@item_rect Char T).
Proof.
  lazy.
  intros ?? H ?? H' [?|?]; subst; eauto with nocore.
Qed.

Global Instance item_rect_Proper_forall_R {C A} {R : relation A}
  : Proper
      ((pointwise_relation _ R)
         ==> (pointwise_relation _ R)
         ==> forall_relation (fun _ : item C => R))
      (item_rect (fun _ : item C => A)).
Proof.
  lazy; intros ?????? [?|?]; trivial.
Qed.

Hint Extern 1 (Proper _ (@item_rect _ _)) => exact item_rect_Proper : typeclass_instances.
Hint Extern 0 (Proper _ (@item_rect _ _)) => exact item_rect_Proper_forall : typeclass_instances.
Hint Extern 0 (Proper (pointwise_relation _ _ ==> pointwise_relation _ _ ==> forall_relation _) (item_rect _))
=> refine item_rect_Proper_forall_R : typeclass_instances.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} (G : grammar Char).

  Definition parse_of_item_respectful'
             (parse_of_respectful : forall {str1 str2} (H : str1 =s str2) {pats pats'} (Hpats : productions_code pats pats') (p : parse_of G str1 pats), parse_of G str2 pats')
             {str1 str2} (H : str1 =s str2) {it it'} (Hit : item_code it it') (p : parse_of_item G str1 it)
  : parse_of_item G str2 it'
    := match p in (parse_of_item _ _ it), it' return item_code it it' -> parse_of_item G str2 it' with
         | ParseTerminal ch P pf0 pf1, Terminal P' => fun Hit => ParseTerminal G str2 ch P' (transitivity (symmetry (Hit _)) pf0) (transitivity (eq_sym (is_char_Proper H eq_refl)) pf1)
         | ParseTerminal _ _ _ _, NonTerminal _ => fun Hit => match Hit with end
         | ParseNonTerminal nt H' p', NonTerminal nt'
           => fun Hit
              => ParseNonTerminal
                   _
                   (match Hit in (_ = nt') return List.In nt' _ with
                      | eq_refl => H'
                    end)
                   (@parse_of_respectful
                      _ _ H (Lookup G nt) (Lookup G nt')
                      (match Hit in (_ = nt') return productions_code (G nt) (G nt') with
                         | eq_refl => reflexivity _
                       end)
                      p')
         | ParseNonTerminal _ _ _, Terminal _ => fun Hit => match Hit with end
       end Hit.

  Global Arguments parse_of_item_respectful' _ _ _ _ _ !_ _ !_ / .

  Section bodies.
    Context (parse_of_respectful : forall {str1 str2} (H : str1 =s str2) {pats pats'} (Hpats : productions_code pats pats') (p : parse_of G str1 pats), parse_of G str2 pats')
            (parse_of_production_respectful : forall {str1 str2} (H : str1 =s str2) {pat pat'} (Hpat : production_code pat pat') (p : parse_of_production G str1 pat), parse_of_production G str2 pat').

    Definition parse_of_respectful_step {str1 str2} (H : str1 =s str2) {pats pats'} (Hpats : productions_code pats pats') (p : parse_of G str1 pats) : parse_of G str2 pats'.
    Proof.
      refine (match p in (parse_of _ _ pats), pats' return productions_code pats pats' -> parse_of G str2 pats' with
                | ParseHead pat pats p', pat'::pats' => fun Hpats' => ParseHead pats' (@parse_of_production_respectful _ _ H _ _ _ p')
                | ParseTail pat pats p', pat'::pats' => fun Hpats' => ParseTail pat' (@parse_of_respectful _ _ H _ _ _ p')
                | ParseHead _ _ _, nil => fun Hpats' => match _ : False with end
                | ParseTail _ _ _, nil => fun Hpats' => match _ : False with end
              end Hpats);
      try solve [ clear -Hpats'; abstract inversion Hpats'
                | clear -Hpats'; inversion Hpats'; subst; assumption ].
    Defined.

    Definition parse_of_production_respectful_step {str1 str2} (H : str1 =s str2) {pat pat'} (Hpat : production_code pat pat') (p : parse_of_production G str1 pat) : parse_of_production G str2 pat'.
    Proof.
      refine (match p in (parse_of_production _ _ pat), pat' return production_code pat pat' -> parse_of_production G str2 pat' with
                | ParseProductionNil pf, nil => fun Hpat' => ParseProductionNil G str2 (transitivity (eq_sym (length_Proper H)) pf)
                | ParseProductionCons n pat pats p0 p1, pat'::pats' => fun Hpat' => ParseProductionCons _ n (parse_of_item_respectful' (@parse_of_respectful) (take_Proper eq_refl H) _ p0) (@parse_of_production_respectful _ _ (drop_Proper eq_refl H) _ _ _ p1)
                | ParseProductionNil _, _::_ => fun Hpat' => match _ : False with end
                | ParseProductionCons _ _ _ _ _, nil => fun Hpat' => match _ : False with end
              end Hpat);
      try solve [ clear -Hpat'; abstract inversion Hpat'
                | clear -Hpat'; inversion Hpat'; subst; assumption ].
    Defined.

    Global Arguments parse_of_respectful_step _ _ _ _ _ _ !_ / .
    Global Arguments parse_of_production_respectful_step _ _ _ _ _ _ !_ / .
  End bodies.

  Fixpoint parse_of_respectful {str1 str2} (H : str1 =s str2) {pats pats'} (Hpats : productions_code pats pats') (p : parse_of G str1 pats) : parse_of G str2 pats'
    := @parse_of_respectful_step (@parse_of_respectful) (@parse_of_production_respectful) _ _ H _ _ Hpats p
  with parse_of_production_respectful {str1 str2} (H : str1 =s str2) {pat pat'} (Hpat : production_code pat pat') (p : parse_of_production G str1 pat) : parse_of_production G str2 pat'
    := @parse_of_production_respectful_step (@parse_of_respectful) (@parse_of_production_respectful) _ _ H _ _ Hpat p.

  Definition parse_of_item_respectful : forall {str1 str2} H {it it'} Hit p, _
    := @parse_of_item_respectful' (@parse_of_respectful).

  Global Arguments parse_of_item_respectful _ _ _ _ !_ _ !_ / .

  Fixpoint parse_of_respectful_refl {str pf pats Hpats} (p : parse_of G str pats) : parse_of_respectful pf Hpats p = p
    := match p return forall Hpats, parse_of_respectful pf Hpats p = p with
         | ParseHead pat pats p' => fun Hpats => f_equal (ParseHead _) (parse_of_production_respectful_refl p')
         | ParseTail pat pats p' => fun Hpats => f_equal (@ParseTail _ _ _ _ _ _ _) (parse_of_respectful_refl p')
       end Hpats
  with parse_of_production_respectful_refl {str pf pat Hpat} (p : parse_of_production G str pat) : parse_of_production_respectful pf Hpat p = p
       := match p return forall Hpat, parse_of_production_respectful pf Hpat p = p with
            | ParseProductionNil pf => fun Hpat => f_equal (ParseProductionNil _ _) (dec_eq_uip (Nat.eq_dec _) _ _)
            | ParseProductionCons n pat pats p0 p1
              => fun Hpat => f_equal2 (@ParseProductionCons _ _ _ _ _ _ _ _)
                                      (parse_of_item_respectful_refl p0)
                                      (parse_of_production_respectful_refl p1)
          end Hpat
  with parse_of_item_respectful_refl {str pf it Hit} (p : parse_of_item G str it) : parse_of_item_respectful pf Hit p = p
       := match p return forall Hit, parse_of_item_respectful pf Hit p = p with
            | ParseTerminal ch P pf1 pf2 => fun Hit => f_equal2 (ParseTerminal _ _ _ _) (dec_eq_uip (Bool.bool_dec _) _ _) (dec_eq_uip (Bool.bool_dec _) _ _)
            | ParseNonTerminal nt H' p'
              => fun Hit'
                 => f_equal2 (ParseNonTerminal nt)
                             match dec_eq_uip (@Equality.string_eq_dec nt) eq_refl Hit' in (_ = Hit') return match Hit' in (_ = nt') return List.In nt' _ with eq_refl => H' end = H' with
                               | eq_refl => eq_refl
                             end
                             (@parse_of_respectful_refl _ _ _ _ p')
          end Hit.

  (*Global Instance parse_of_Proper : Proper (beq ==> eq ==> iff) (parse_of G).
  Proof.
    split; subst; apply parse_of_respectful; [ assumption | symmetry; assumption ].
  Qed.

  Global Instance parse_of_production_Proper : Proper (beq ==> eq ==> iff) (parse_of_production G).
  Proof.
    split; subst; apply parse_of_production_respectful; [ assumption | symmetry; assumption ].
  Qed.

  Global Instance parse_of_item_Proper : Proper (beq ==> eq ==> iff) (parse_of_item G).
  Proof.
    split; subst; apply parse_of_item_respectful; [ assumption | symmetry; assumption ].
  Qed.*)

  Definition ParseProductionSingleton str it (p : parse_of_item G str it) : parse_of_production G str [ it ].
  Proof.
    econstructor.
    { eapply parse_of_item_respectful; [ | reflexivity | eassumption ].
      rewrite take_long; reflexivity. }
    { constructor.
      rewrite drop_length; auto with arith. }
  Defined.

  Section definitions.
    Context (P : String -> String.string -> Type).

    Definition Forall_parse_of_item'
               (Forall_parse_of : forall {str pats} (p : parse_of G str pats), Type)
               {str it} (p : parse_of_item G str it)
      := match p return Type with
           | ParseTerminal ch P pf1 pf2 => unit
           | ParseNonTerminal nt H' p'
             => (P str nt * Forall_parse_of p')%type
         end.

    Fixpoint Forall_parse_of {str pats} (p : parse_of G str pats)
      := match p with
           | ParseHead pat pats p'
             => Forall_parse_of_production p'
           | ParseTail _ _ p'
             => Forall_parse_of p'
         end
    with Forall_parse_of_production {str pat} (p : parse_of_production G str pat)
         := match p return Type with
              | ParseProductionNil pf => unit
              | ParseProductionCons pat strs pats p' p''
                => (Forall_parse_of_item' (@Forall_parse_of) p' * Forall_parse_of_production p'')%type
            end.

    Definition Forall_parse_of_item {str it} (p : parse_of_item G str it)
      := @Forall_parse_of_item' (@Forall_parse_of) str it p.
  End definitions.

  (*Section expand.
    Context {P P' : String -> String.string -> Type}.

    Definition expand_forall_parse_of_item'
               {str str' str''}
               {Forall_parse_of : forall P {str pats} (p : parse_of G str pats), Type}
               (expand : forall {pats pats' pats''} (Hpats : productions_code pats pats') (Hpats' : productions_code pats' pats'') (H : str =s str') (H' : str =s str'') {p}, @Forall_parse_of P str' pats' (parse_of_respectful H Hpats p) -> @Forall_parse_of P' str'' pats'' (parse_of_respectful H' Hpats' p))
               (f : forall n, P str' n -> P' str'' n)
               {it p} (H : str =s str') (H' : str =s str'')
    : @Forall_parse_of_item' P (@Forall_parse_of P) str' it (parse_of_item_respectful H p)
      -> @Forall_parse_of_item' P' (@Forall_parse_of P') str'' it (parse_of_item_respectful H' p).
    Proof.
      destruct p; simpl.
      { exact (fun x => x). }
      { intro ab.
        exact (f _ (fst ab), expand _ H H' _ (snd ab)). }
    Defined.

    Global Arguments expand_forall_parse_of_item' : simpl never.

    Fixpoint expand_forall_parse_of
             str str' str''
             (f : forall str0' str1', str0' ≤s str -> str0' =s str1' -> forall n, P str0' n -> P' str1' n)
             pats (H : str =s str') (H' : str =s str'') (p : parse_of G str pats)
             {struct p}
    : Forall_parse_of P (parse_of_respectful H p) -> Forall_parse_of P' (parse_of_respectful H' p)
    with expand_forall_parse_of_production
           str str' str''
           (f : forall str0' str1', str0' ≤s str -> str0' =s str1' -> forall n, P str0' n -> P' str1' n)
           pat (H : str =s str') (H' : str =s str'') (p : parse_of_production G str pat)
           {struct p}
         : Forall_parse_of_production P (parse_of_production_respectful H p) -> Forall_parse_of_production P' (parse_of_production_respectful H' p).
    Proof.
      { destruct p.
        simpl.
        { apply expand_forall_parse_of_production; exact f. }
        { refine (expand_forall_parse_of _ _ _ _ _ _ _ p); exact f. } }
      { destruct p as [ | n pat pats pit pits ]; simpl.
        { exact (fun x => x). }
        { pose proof (fun f' f'' => @expand_forall_parse_of_item' _ (take n str') (take n str'') (@Forall_parse_of) (@expand_forall_parse_of _ _ _ f') f'' _ pit) as expand_forall_parse_of_item.
          specialize (fun f' H H' => expand_forall_parse_of_production _ (drop n str') (drop n str'') f' _ H H' pits).
          clear expand_forall_parse_of.
          change (Forall_parse_of_item P (parse_of_item_respectful (take_Proper eq_refl H) pit) * Forall_parse_of_production P (parse_of_production_respectful (drop_Proper eq_refl H) pits)
                  -> Forall_parse_of_item P' (parse_of_item_respectful (take_Proper eq_refl H') pit) * Forall_parse_of_production P' (parse_of_production_respectful (drop_Proper eq_refl H') pits))%type.
          intro xy.
          split.
          { eapply expand_forall_parse_of_item; [ .. | exact (fst xy) ].
            { intros ? ? H''; apply f.
              rewrite str_le_take in H''; assumption. }
            { intro; apply f.
              { clear -H HSLP.
                rewrite str_le_take, H; reflexivity. }
              { rewrite <- H, <- H'; reflexivity. } } }
          { eapply expand_forall_parse_of_production; [ .. | exact (snd xy) ].
            intros ? ? H''; apply f.
            etransitivity; [ eassumption | apply str_le_drop ]. } } }
    Defined.

    Global Arguments expand_forall_parse_of : simpl never.
    Global Arguments expand_forall_parse_of_production : simpl never.

    Definition expand_forall_parse_of_item {str str' str''} f {it} {p : parse_of_item G str it} (H : str =s str') (H' : str =s str'')
      := @expand_forall_parse_of_item' str str' str'' _ (@expand_forall_parse_of str str' str'' f) (f _ _ ((_ : Proper (beq ==> beq ==> impl) str_le) _ _ H _ _ (reflexivity _) (reflexivity _)) (transitivity (symmetry H) H')) it p.

    Global Arguments expand_forall_parse_of_item : simpl never.
  End expand.*)
End cfg.

Ltac simpl_parse_of_respectful :=
  repeat match goal with
           | [ |- context[@parse_of_respectful ?Char ?HSLM ?HSL ?HSLP ?G ?str1 ?str2 ?H ?pat ?pat' ?Hpat ?p] ]
             => change (@parse_of_respectful Char HSLM HSL HSLP G str1 str2 H pat pat' Hpat p)
                with (@parse_of_respectful_step Char HSLM HSL G (@parse_of_respectful Char HSLM HSL HSLP G) (@parse_of_production_respectful Char HSLM HSL HSLP G) str1 str2 H pat pat' Hpat p);
               simpl @parse_of_respectful_step
           | [ |- context[@parse_of_production_respectful ?Char ?HSLM ?HSL ?HSLP ?G ?str1 ?str2 ?H ?pat ?pat' ?Hpat ?p] ]
             => change (@parse_of_production_respectful Char HSLM HSL HSLP G str1 str2 H pat pat' Hpat p)
                with (@parse_of_production_respectful_step Char HSLM HSL G (@parse_of_respectful Char HSLM HSL HSLP G) (@parse_of_production_respectful Char HSLM HSL HSLP G) str1 str2 H pat pat' Hpat p);
               simpl @parse_of_production_respectful_step
           | _ => progress simpl @parse_of_item_respectful
           | _ => progress simpl @parse_of_item_respectful'
         end.

Section parse_of_proper.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char} {G : grammar Char} {str : String}.

  Local Ltac t_parse_of_impl lem :=
    repeat intro;
    match goal with
      | [ H : Proper _ _, H' : _ -> _ |- _ ] => eapply H; [ eassumption.. | apply H'; try clear H H' ]
    end;
    eapply lem; [ .. | eassumption ];
    try first [ assumption
              | reflexivity
              | symmetry; assumption ].

  Section fun0.
    Context {P : _ -> _ -> Prop}
            {H : Proper (@item_code Char ==> @production_code Char ==> impl) P}.

    Global Instance parse_of_item_fun0_Proper
    : Proper (item_code ==> production_code ==> impl) (fun it (its : production Char) => parse_of_item G str it -> P it its).
    Proof. t_parse_of_impl (@parse_of_item_respectful). Qed.
    Global Instance parse_of_production_fun0_Proper
    : Proper (item_code ==> production_code ==> impl) (fun (it : item Char) (its : production Char) => parse_of_production G str its -> P it its).
    Proof. t_parse_of_impl (@parse_of_production_respectful). Qed.
  End fun0.
  Section fun0_flip.
    Context {P : _ -> _ -> Prop}
            {H : Proper (@item_code Char ==> @production_code Char ==> flip impl) P}.

    Global Instance parse_of_item_fun0_Proper_flip
    : Proper (item_code ==> production_code ==> flip impl) (fun it (its : production Char) => parse_of_item G str it -> P it its).
    Proof. t_parse_of_impl (@parse_of_item_respectful). Qed.
    Global Instance parse_of_production_fun0_Proper_flip
    : Proper (item_code ==> production_code ==> flip impl) (fun (it : item Char) (its : production Char) => parse_of_production G str its -> P it its).
    Proof. t_parse_of_impl (@parse_of_production_respectful). Qed.
  End fun0_flip.

  Section fun1.
    Context {A} {RA : relation A}
            {P : _ -> _ -> _ -> Prop}
            {H : Proper (@item_code Char ==> @production_code Char ==> RA ==> impl) P}.

    Global Instance parse_of_item_fun1_Proper
    : Proper (item_code ==> production_code ==> RA ==> impl) (fun it (its : production Char) x => parse_of_item G str it -> P it its x).
    Proof. t_parse_of_impl (@parse_of_item_respectful). Qed.
    Global Instance parse_of_production_fun1_Proper
    : Proper (item_code ==> production_code ==> RA ==> impl) (fun (it : item Char) (its : production Char) x => parse_of_production G str its -> P it its x).
    Proof. t_parse_of_impl (@parse_of_production_respectful). Qed.
  End fun1.
  Section fun1_flip.
    Context {A} {RA : relation A}
            {P : _ -> _ -> _ -> Prop}
            {H : Proper (@item_code Char ==> @production_code Char ==> RA ==> flip impl) P}.

    Global Instance parse_of_item_fun1_Proper_flip
    : Proper (item_code ==> production_code ==> RA ==> flip impl) (fun it (its : production Char) x => parse_of_item G str it -> P it its x).
    Proof. t_parse_of_impl (@parse_of_item_respectful). Qed.
    Global Instance parse_of_production_fun1_Proper_flip
    : Proper (item_code ==> production_code ==> RA ==> flip impl) (fun (it : item Char) (its : production Char) x => parse_of_production G str its -> P it its x).
    Proof. t_parse_of_impl (@parse_of_production_respectful). Qed.
  End fun1_flip.
End parse_of_proper.


From aneris.examples.transaction_commit Require Export
    two_phase_runner_code.
From aneris.examples.transaction_commit Require Import
    two_phase_runner_code two_phase_prelude two_phase_tm two_phase_rm.
(** * A simple runner (without aux. clients), proving safety  *)
Section runner.

  Open Scope nat_scope.
  Definition tm_addr := SocketAddressInet "tm" 80.
  Definition rm1_addr := SocketAddressInet "rm.01" 80.
  Definition rm2_addr := SocketAddressInet "rm.02" 80.
  Definition rm3_addr := SocketAddressInet "rm.03" 80.
  Definition rms : gset socket_address :=
    {[ rm1_addr; rm2_addr; rm3_addr ]}.
  Definition addrs : gset socket_address := {[ tm_addr ]} ∪ rms.
  Definition ips : gset string := {[ "tm"; "rm.01"; "rm.02"; "rm.03" ]}.

  Program Instance my_topo : network_topo :=
    {| RMs := rms; tm := tm_addr |}.
  Solve All Obligations with set_solver.

  Context `{!anerisG (TC_model rms) Σ, !tcG Σ}.

  Notation pending_frac := (dfrac_oneshot.pending tc_oneshot_gname).

  Lemma RMs_size :
    size RMs = 3.
  Proof. rewrite /RMs !size_union ?size_singleton //; set_solver. Qed.

  Lemma runner_spec :
    {{{ inv tcN tc_inv ∗
        tm_addr ⤇ tm_si ∗
        tm_addr ⤳ (∅, ∅) ∗
        ([∗ set] rm ∈ rms, rm ⤇ rm_si) ∗
        ([∗ set] rm ∈ rms, rm ↦●{1/2} WORKING) ∗
        ([∗ set] ip ∈ ips, free_ip ip) ∗
        pending_frac 1 }}}
      runner @["system"]
    {{{ v, RET v; True }}}.
  Proof.
    iIntros (Φ) "(#Hinv & #Htm_si & Htm_a & #Hrms_si & Hwork & Hips & Hpend) HΦ".
    rewrite /runner.
    do 4 (wp_makeaddress; wp_let).
    wp_apply (wp_set_empty socket_address); [done|]; iIntros (?) "%H".
    do 3 (wp_apply (wp_set_add (A := socket_address) with "[//]");
          iIntros (?) "%").
    wp_pures.
    rewrite (pending_split_N _ (size RMs + 1)); [|lia].
    iDestruct (big_sepS_delete _ _ "rm.01" with "Hips") as "(Hrm1 & Hips)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ "rm.02" with "Hips") as "(Hrm2 & Hips)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ "rm.03" with "Hips") as "(Hrm3 & Hips)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ "tm" with "Hips") as "(Htm & _)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ rm1_addr with "Hwork") as "(Hw1 & Hwork)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ rm2_addr with "Hwork") as "(Hw2 & Hwork)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ rm3_addr with "Hwork") as "(Hw3 & _)"; [set_solver|].
    rewrite RMs_size.
    iDestruct (big_sepS_delete _ _ 0 with "Hpend") as "(Hp1 & Hpend)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ 1 with "Hpend") as "(Hp2 & Hpend)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ 2 with "Hpend") as "(Hp3 & Hpend)"; [set_solver|].
    iDestruct (big_sepS_delete _ _ 3 with "Hpend") as "(Ht & _)"; [set_solver|].
    rewrite -RMs_size.
    wp_apply (aneris_wp_start {[port_of_address rm1_addr]}); iFrame.
    iSplitR "Hw1 Hp1"; last first.
    { iIntros "!> Hport".
      wp_apply (resource_manager_spec rm1_addr with "[$] [$] [] [$] [$]");
        [set_solver| |done].
      iApply (big_sepS_elem_of with "Hrms_si"); set_solver. }
    iModIntro; wp_seq.
    wp_apply (aneris_wp_start {[port_of_address rm2_addr]}); iFrame.
    iSplitR "Hw2 Hp2"; last first.
    { iIntros "!> Hport".
      wp_apply (resource_manager_spec rm2_addr with "[$] [$] [] [$] [$] ");
        [set_solver| |done].
      iApply (big_sepS_elem_of with "Hrms_si"); set_solver. }
    iModIntro; wp_seq.
    wp_apply (aneris_wp_start {[port_of_address rm3_addr]}); iFrame.
    iSplitR "Hw3 Hp3"; last first.
    { iIntros "!> Hport".
      wp_apply (resource_manager_spec rm3_addr with "[$] [$] [] [$] [$] ");
        [set_solver| |done].
      iApply (big_sepS_elem_of with "Hrms_si"); set_solver. }
    iModIntro; wp_seq.
    wp_apply (aneris_wp_start {[port_of_address tm_addr]}); iFrame.
    iSplitL "HΦ"; [by iApply "HΦ"|].
    iIntros "!> Hport".
    wp_apply aneris_wp_wand_r; iSplitL.
    { wp_apply (transaction_manager_spec
                  with "[$] [$] [$] [$] [$]").
      by rewrite !union_assoc_L union_empty_r_L in H2. }
    by iIntros (?) "?".
  Qed.

End runner.