(** * Non-unital lB0-systems

By Vladimir Voevodsky, started on Jan. 24, 2015 *)

Require Import UniMath.Foundations.All.

Require Import TypeTheory.Csystems.hSet_ltowers.

Require Export TypeTheory.Bsystems.prelB.
Require Export TypeTheory.Bsystems.TS_ST.
Require Export TypeTheory.Bsystems.STid .
Require Export TypeTheory.Bsystems.dlt .

(** ** Definitions of the main layers *)

(** *** The layer associated with operations T *)

Definition T_layer ( BB : lBsystem_carrier ) :=
  ∑ T : T_layer_0 BB, ( T_ax1a_type T ) × ( T_ax1b_type T ).

(** Warning: [T_layer_0] refers to a pre-lB-system, [T_layer] refers to a lB0-system. *)

Definition T_layer_to_T_layer_0 ( BB : lBsystem_carrier ) : T_layer BB -> T_layer_0 BB :=
  pr1 .
Coercion T_layer_to_T_layer_0 : T_layer >-> T_layer_0 .

(** *** The layer associated with operations Tt *)

Definition Tt_layer { BB : lBsystem_carrier } ( T : T_ops_type BB ) :=
  ∑ Tt : Tt_ops_type BB, Tt_ax1_type T Tt.

Definition Tt_layer_to_Tt_ops_type ( BB : lBsystem_carrier ) ( T : T_ops_type BB )
  ( Tt : Tt_layer T ) : Tt_ops_type BB := pr1 Tt .
Coercion Tt_layer_to_Tt_ops_type : Tt_layer >-> Tt_ops_type .

(** *** The structure formed by operations T and Tt *)

Definition T_Tt_layer ( BB : lBsystem_carrier ) :=
  ∑ T : T_layer BB, Tt_layer T.

Definition T_Tt_layer_to_T_layer { BB : lBsystem_carrier } ( T_Tt : T_Tt_layer BB ) :
  T_layer BB := pr1 T_Tt .
Coercion T_Tt_layer_to_T_layer : T_Tt_layer >->  T_layer .

Definition T_Tt_layer_to_Tt_layer { BB : lBsystem_carrier } ( T_Tt : T_Tt_layer BB ) :
  Tt_layer T_Tt := pr2 T_Tt .
Coercion T_Tt_layer_to_Tt_layer : T_Tt_layer >-> Tt_layer .

(** *** The layer associated with operations S *)

Definition S_layer ( BB : lBsystem_carrier ) :=
  ∑ S : S_layer_0 BB, ( S_ax1a_type S ) × ( S_ax1b_type S ).

Definition S_layer_to_S_layer_0 ( BB : lBsystem_carrier ) :
  S_layer BB -> S_layer_0 BB := pr1 .
Coercion S_layer_to_S_layer_0 : S_layer >-> S_layer_0 .

(** *** The layer associated with operations St *)

Definition St_layer { BB : lBsystem_carrier } ( S : S_ops_type BB ) :=
  ∑ St : St_ops_type BB, St_ax1_type S St.

Definition St_layer_to_St_ops_type ( BB : lBsystem_carrier ) ( S : S_ops_type BB )
  ( St : St_layer S ) : St_ops_type BB := pr1 St.
Coercion St_layer_to_St_ops_type : St_layer >-> St_ops_type .

(** *** The structure formed by operations S and St *)

Definition S_St_layer ( BB : lBsystem_carrier ) :=
  ∑ S : S_layer BB, St_layer S.

Definition S_St_layer_to_S_layer { BB : lBsystem_carrier } ( S_St : S_St_layer BB ) :
  S_layer BB := pr1 S_St .
Coercion S_St_layer_to_S_layer : S_St_layer >->  S_layer .

Definition S_St_layer_to_St_layer { BB : lBsystem_carrier } ( S_St : S_St_layer BB ) :
  St_layer S_St := pr2 S_St .
Coercion S_St_layer_to_St_layer : S_St_layer >-> St_layer .

(** ** Complete definition of a non-unital lB0-system *)

Definition T_ax1_type ( BB : prelBsystem_non_unital ) :=
  ( T_ax1a_type ( @T_op BB ) ) × ( T_ax1b_type ( @T_op BB ) ) .

Definition Tt_ax1_type' ( BB : prelBsystem_non_unital ) :=
  Tt_ax1_type ( @T_op BB ) ( @Tt_op BB ) .

Definition S_ax1_type ( BB : prelBsystem_non_unital ) :=
  ( S_ax1a_type ( @S_op BB ) ) × ( S_ax1b_type ( @S_op BB ) ) .

Definition St_ax1_type' ( BB : prelBsystem_non_unital ) :=
  St_ax1_type ( @S_op BB ) ( @St_op BB ) .

Definition lB0system_non_unital :=
  ∑ BB : prelBsystem_non_unital,
               ( ( T_ax1_type BB ) × ( Tt_ax1_type' BB ) ) ×
               ( ( S_ax1_type BB ) × ( St_ax1_type' BB ) ).

(** This definition corresponds to Definition 2.5 in arXiv:1410.5389v1 modulo
    the details on the treatment of the second cases of 2.5.2 and 2.5.4, discussed
    elsewhere (see the definition of [T_ax1b_type] and [S_ax1b_type] and the lemmas
    [ft_T] and [ft_S]). *)

Definition lB0system_non_unital_pr1 : lB0system_non_unital -> prelBsystem_non_unital := pr1 .
Coercion lB0system_non_unital_pr1 : lB0system_non_unital >-> prelBsystem_non_unital .

(** *** Access functions to the axioms *)

Definition T_ax1a { BB : lB0system_non_unital } : T_ax1a_type ( @T_op BB ) :=
  pr1 ( pr1 ( pr1 ( pr2 BB ) ) ) .

Definition T_ax1b { BB : lB0system_non_unital } : T_ax1b_type ( @T_op BB ) :=
  pr2 ( pr1 ( pr1 ( pr2 BB ) ) ) .

Definition Tt_ax1 { BB : lB0system_non_unital } : Tt_ax1_type ( @T_op BB ) ( @Tt_op BB ) :=
  pr2 ( pr1 ( pr2 BB ) ) .

Definition Tt_ax0 { BB : lB0system_non_unital } : Tt_ax0_type ( @Tt_op BB ) :=
  Tt_ax1_to_Tt_ax0 ( @T_ax0 BB ) ( @Tt_ax1 BB ) .

Definition S_ax1a { BB : lB0system_non_unital } : S_ax1a_type ( @S_op BB ) :=
  pr1 ( pr1 ( pr2 ( pr2 BB ) ) ) .

Definition S_ax1b { BB : lB0system_non_unital } : S_ax1b_type ( @S_op BB ) :=
  pr2 ( pr1 ( pr2 ( pr2 BB ) ) ) .

Definition St_ax1 { BB : lB0system_non_unital } : St_ax1_type ( @S_op BB ) ( @St_op BB ) :=
  pr2 ( pr2 ( pr2 BB ) ) .

Definition St_ax0 { BB : lB0system_non_unital } : St_ax0_type ( @St_op BB ) :=
  St_ax1_to_St_ax0 ( @S_ax0 BB ) ( @St_ax1 BB ) .

(** ** Derived operations re-defined in a more streamlined form *)

(** *** Derived operations related to operation T *)

Definition T_fun { BB : lB0system_non_unital } ( X : BB ) ( gt0 : ll X > 0 ) :
  ltower_fun ( ltower_over ( ft X ) ) ( ltower_over X ) :=
  T_fun.T_fun ( @T_ax0 BB ) ( @T_ax1a BB ) ( @T_ax1b BB ) gt0 .

Definition Tj_fun { BB : lB0system_non_unital } { A X1 : BB } ( isov : isover X1 A ) :
  ltower_fun ( ltower_over A ) ( ltower_over X1 ) :=
  T_fun.Tj_fun ( @T_ax0 BB ) ( @T_ax1a BB ) ( @T_ax1b BB ) isov .

Definition Tj_fun_compt { BB : lB0system_non_unital } { X Y : BB } ( isab : isabove X Y ) :
  Tj_fun isab = ltower_funcomp ( Tj_fun ( isover_ft' isab ) ) ( T_fun X ( isabove_gt0 isab ) ) :=
  Tj_fun_compt ( @T_ax0 BB ) ( @T_ax1a BB ) ( @T_ax1b BB ) isab .

Definition Tj { BB : lB0system_non_unital } { X A Y : BB }
           ( isov1 : isover X A ) ( isov2 : isover Y A ) : BB :=
  pocto ( Tj_fun isov1 (  obj_over_constr isov2 ) ) .

Definition isover_Tj { BB : lB0system_non_unital } { X A Y : BB }
           ( isov1 : isover X A ) ( isov2 : isover Y A ) : isover ( Tj isov1 isov2 ) X :=
  pr2 ( Tj_fun isov1 (  obj_over_constr isov2 ) ) .

Definition Tj_compt { BB : lB0system_non_unital } { X A Y : BB }
           ( isab : isabove X A ) ( isov2 : isover Y A ) :
  Tj isab isov2 =
  T_ext X ( Tj ( isover_ft' isab ) isov2 ) ( isabove_gt0 isab ) ( isover_Tj ( isover_ft' isab ) isov2 ) .
Proof.
  unfold Tj .
  rewrite Tj_fun_compt .
  apply idpath .
Defined.

Definition Tprod_over { BB : lB0system_non_unital } ( X1 : BB ) :
  ltower_fun BB ( ltower_over X1 ) :=
  T_fun.Tprod_fun ( @T_ax0 BB ) ( @T_ax1a BB ) ( @T_ax1b BB ) X1 .

Definition Tprod { BB : lB0system_non_unital } ( X Y : BB ) : BB := pocto ( Tprod_over X Y ) .

Definition isover_Tprod { BB : lB0system_non_unital } ( X Y : BB ) :
  isover ( Tprod X Y ) X := pr2 ( Tprod_over X Y ) .

Lemma ll_Tprod { BB : lB0system_non_unital } ( X Y : BB ) : ll ( Tprod X Y ) = ll X + ll Y .
Proof.
  unfold Tprod .
  rewrite ll_pocto .
  rewrite natpluscomm .
  rewrite ( @ll_ltower_fun BB _ ( Tprod_over X ) ) .
  apply idpath .
Defined.

Definition Tprod_compt { BB : lB0system_non_unital } ( X Y : BB ) ( gt0 : ll X > 0 ) :
  Tprod X Y = T_ext X ( Tprod ( ft X ) Y ) gt0 ( isover_Tprod _ _ ) .
Proof.
  set ( int :=
             T_fun.Tprod_compt
               ( @T_ax0 BB ) ( @T_ax1a BB ) ( @T_ax1b BB ) X Y gt0 ).
  exact ( maponpaths pocto int ) .
Defined.

(** *** Derived operations related to operation S *)

Lemma ll_S_ext { BB : lB0system_non_unital }
      ( r : Tilde BB ) ( X : BB ) ( inn : isover X ( dd r )  ) : ll ( S_ext r X inn ) = ll X - 1.
Proof.
  apply S_fun.ll_S_ext .
  + apply ( @S_ax0 BB ) .
  + apply ( @S_ax1b BB ) .
Defined.

Definition S_fun { BB : lB0system_non_unital } ( r : Tilde BB ) :
  ltower_fun ( ltower_over ( dd r ) ) ( ltower_over ( ft ( dd r ) ) ) :=
  ltower_fun_S ( @S_ax0 BB ) ( @S_ax1a BB ) ( @S_ax1b BB ) r .

(* End of the file lB0_non_unital.v *)


(* -*- company-coq-local-symbols: (("|=" . ?⊨) ("=|" . ?⫤) ("->>" . ?↠) ("=~" . ?≈) ("<|" . ?⟨) ("|>" . ?⟩) ); -*- *)
Set Warnings "-notation-overridden".

Require Import Prelude.Prelude.
Require Import Defs.Defs.

Require Import Complete.SameShape.

Definition subst_name (x__in x__out x : termvar) : termvar := (if eq_var x x__out then x__in else x).
#[export] Hint Unfold subst_name : core.

Fixpoint subst_name_Env (x__in x__out : termvar) (env:Env) : Env :=
  match env with
  | Env_Empty            => Env_Empty
  | (Env_Skol env' skA ) => Env_Skol (subst_name_Env x__in x__out env') skA
  | (Env_A env' a      ) => Env_A (subst_name_Env x__in x__out env') a
  | (Env_Var env' x sch) => Env_Var (subst_name_Env x__in x__out env') (subst_name x__in x__out x) sch
  | (Env_Obj env' obj  ) => Env_Obj (subst_name_Env x__in x__out env') obj
end.
#[export] Hint Unfold subst_name_Env : core.

Definition Inf_rename_binding__def := forall (env__in : Env) (e : e) (a : A) (ty : Ty) (env__out : Env),
    env__in |= e ▸ ⟨a⟩ ty =| env__out
  -> forall x__in x__out,
    (subst_name_Env x__in x__out env__in) |= subst_tm_e (e_Var_f x__in) x__out e ▸ ⟨a⟩ ty =| (subst_name_Env x__in x__out env__out).

Definition Gen_rename_binding__def := forall (env__in : Env) (e : e) (sch : Sch) (env__out : Env),
    env__in |= e ▸ sch =| env__out
  -> forall x__in x__out,
    (subst_name_Env x__in x__out env__in) |= subst_tm_e (e_Var_f x__in) x__out e ▸ sch =| (subst_name_Env x__in x__out env__out).

Theorem subst_name_Env_lookup: forall (env : Env) (x__in x__out x : termvar) (sch : Sch),
    SchPSI.In (x, sch) (Env_bindings env)
  -> SchPSI.In (subst_name x__in x__out x, sch) (Env_bindings (subst_name_Env x__in x__out env)).
Proof.
  introv IN. induction env.
  - crush.
  - simpl. rewr in IN. rewr. eauto.
  - simpl. rewr in IN. rewr. eauto.
  - simpl. rewr in IN. rewr. indestr.
    + eauto.
    + rewr in H. crush.
  - simpl. rewr in IN. rewr. eauto.
Qed.

Theorem Inst_Env_sub : forall env1 env2 sch a ty,
    Inst env1 sch a ty
  -> env1 [=]e# env2
  -> Inst env2 sch a ty.
Proof.
  intros. gen env2. induction H; intros. crush.
  econstructor. unfold Env_fr_eq in H0. fsetdec. intros.
  eapply H. eassumption. crush.
Qed.

Theorem subst_name_Env_Env_eq : forall x__in x__out env,
    subst_name_Env x__in x__out env [=]e env.
Proof.
  induction env. 1,2,3,5: crush.
  rewr_erel. unfold Env_eq in IHenv. destr. split.
  simpl. rewr. assumption.
  simpl. rewr. assumption.
Qed.
#[export] Hint Resolve subst_name_Env_Env_eq : core.

Theorem subst_name_Env_Env_fr_eq : forall x__in x__out env,
    subst_name_Env x__in x__out env [=]e# env.
Proof.
  induction env. 1,2,3,5: crush.
  rewr_erel. unfold Env_fr_eq in IHenv. destr. split.
  simpl. rewr. assumption.
  simpl. rewr. assumption.
Qed.
#[export] Hint Resolve subst_name_Env_Env_fr_eq : core.

Theorem subst_name_Env_cons_o : forall env obj x__in x__out,
    subst_name_Env x__in x__out (env ::o obj) = subst_name_Env x__in x__out env ::o obj.
Proof. reflexivity. Qed.
#[export] Hint Rewrite subst_name_Env_cons_o : core.

Theorem subst_name_Env_app : forall x__in x__out env1 env2,
    subst_name_Env x__in x__out (env1 +++ env2)
  = subst_name_Env x__in x__out env1 +++ subst_name_Env x__in x__out env2.
Proof. induction env2; crush. Qed.
#[export] Hint Rewrite subst_name_Env_app : core.

Theorem subst_name_Envsubst_exvar_Env : forall x__in x__out ty exA env,
    subst_name_Env x__in x__out (subst_exvar_Env ty exA env)
  = subst_exvar_Env ty exA (subst_name_Env x__in x__out env).
Proof. induction env; rewr; crush. Qed.

Theorem subst_name_Env_Sub_app_Env : forall x__in x__out env sub,
    subst_name_Env x__in x__out (Sub_app_Env env sub)
  = Sub_app_Env (subst_name_Env x__in x__out env) sub.
Proof.
  intros. induction sub. crush.
  destruct a. simpl. rewr.
  rewrite <- IHsub. rewrite subst_name_Envsubst_exvar_Env. reflexivity.
Qed.

Theorem subst_name_Env_U : forall (x__in x__out : termvar) (env__in env__out : Env) (E : Eqs),
    U env__in E env__out
  -> U (subst_name_Env x__in x__out env__in) E (subst_name_Env x__in x__out env__out).
Proof.
  introv U. destruct U. econstructor.
  induction Us. crush.
  forwards: subst_name_Env_Sub_app_Env. rewrite H in IHUs.
  econstructor. 2:eassumption. clear H. destruct UNI. 1,2,3: auto.
  - assert (FrA [exA2; exA1] (subst_name_Env x__in x__out (Env1 ::a (A2 ++ exA :: A1) +++ Env2))). eauto.
    rewr. rewr in H2. simpl. applys_eq UssSplitL. rewr in H3. eassumption. rewr. eassumption.
  - assert (FrA [exA2; exA1] (subst_name_Env x__in x__out (Env1 ::a (A2 ++ exA :: A1) +++ Env2))). eauto.
    rewr. rewr in H2. simpl. applys_eq UssSplitR. rewr in H3. eassumption. rewr. eassumption.
  - rewr. applys_eq UssSubExL. fold subst_name_Env.
    assert (subst_name_Env x__in x__out (Env1 ::a A1) [=]e Env1 ::a A1). eauto. unfold Env_eq in H1. destr. rewrite H2. assumption.
  - assert (exA `in` Env_exvars (subst_name_Env x__in x__out Env1 ::a A1)).
      assert (subst_name_Env x__in x__out (Env1 ::a A1) [=]e Env1 ::a A1). eauto. unfold Env_eq in H1. destr. rewrite H2. assumption.
    rewr. applys_eq UssSubExR. eassumption.
  - rewr. applys_eq UssSubUnitAL.
  - rewr. applys_eq UssSubUnitAR.
Qed.

Theorem Inf_Gen_Wf :
  Inf_rename_binding__def /\ Gen_rename_binding__def.
Proof.
  apply Inf_Gen_mut.

  - introv IN SS. intros x__in x__out.
    forwards IN': subst_name_Env_lookup x__in x__out. eassumption.
    unfold subst_name in IN'. destruct (x == x__out).
    + simpl. if_taut. intros. econstructor. eassumption.
      eapply Inst_Env_sub. eassumption. auto using subst_name_Env_Env_fr_eq.
    + simpl. if_taut. intros. econstructor. eassumption.
      eapply Inst_Env_sub. eassumption. auto using subst_name_Env_Env_fr_eq.

  - intros. simpl. crush.

  - introv NIE INF IH. intros.
    forwards EQ: subst_name_Env_Env_fr_eq x__in x__out Envin.
    simpl. applys InfAbs (L \u singleton x__out). unfold Env_fr_eq in EQ. destr. rewrite e0. eassumption.
    intros y NI__y.
    forwards: IH y x__in x__out. fsetdec.
    assert (y <> x__out). unfold not. intros. apply NI__y. fsetdec.
    asserts_rewrite ( subst_tm_e (e_Var_f x__in) x__out (open_e_wrt_e e5 (e_Var_f y))
                    = open_e_wrt_e (subst_tm_e (e_Var_f x__in) x__out e5) (e_Var_f y)) in H.
      rewrite subst_tm_e_open_e_wrt_e. simpl. ifdec. contradiction. reflexivity. auto.
    asserts_rewrite (subst_name x__in x__out y = y) in H.
      unfold subst_name. ifdec. contradiction. reflexivity.
    assumption.

  - introv NIE INF__e1 IH__e1 INF__e2 IH__e2 U. intros.
    simpl.
    forwards IH1: IH__e1 x__in x__out.
    forwards IH2: IH__e2 x__in x__out.
    applys InfApp exB.
    2:apply IH1.
    2:apply IH2.
    + forwards EQ: subst_name_Env_Env_fr_eq x__in x__out (Env2 ::a (A2 ++ A1')).
      unfold Env_fr_eq in EQ. destr. rewrite H0. eassumption.
    + forwards U': subst_name_Env_U x__in x__out. eassumption.
      rewr in U'. assumption.

  - introv GEN IH__gen MON IH__mon. intros.
    forwards: IH__gen.
    simpl. applys InfLet (L \u singleton x__out).
    + eassumption.
    + intros y NI__y. forwards: IH__mon y x__in x__out. fsetdec.
      assert (y <> x__out). unfold not. intros. apply NI__y. fsetdec.
      asserts_rewrite ( subst_tm_e (e_Var_f x__in) x__out (open_e_wrt_e e2 (e_Var_f y))
                      = open_e_wrt_e (subst_tm_e (e_Var_f x__in) x__out e2) (e_Var_f y)) in H0.
        rewrite subst_tm_e_open_e_wrt_e. simpl. ifdec. contradiction. reflexivity. auto.
      asserts_rewrite (subst_name x__in x__out y = y) in H0.
        unfold subst_name. ifdec. contradiction. reflexivity.
      eassumption.

  - introv INF IH__inf GEN. intros.
    forwards: IH__inf.
    econstructor. eassumption. assumption.
Qed.

Theorem subst_name_Env_notin_involuntive : forall (x__out x__in : termvar) (env : Env),
    x__out \notin Env_boundvars env
  -> subst_name_Env x__in x__out env = env.
Proof.
  induction env.
  - crush.
  - crush.
  - crush.
  - intros. simpl. unfold subst_name. ifdec; crush.
  - crush.
Qed.

Theorem SameShape_boundvars : forall env1 env2,
    SameShape env1 env2
  -> Env_boundvars env1 = Env_boundvars env2.
Proof. introv SS. induction SS; crush. Qed.

Theorem Inf_rename_binding' : forall y env__in x sch e a ty env__out sch',
    (env__in ::x x :- sch) |=                          e ▸ ⟨a⟩ ty =| (env__out ::x x :- sch')
  -> x \notin (Env_boundvars env__in)
  -> (env__in ::x y :- sch) |= subst_tm_e (e_Var_f y) x e ▸ ⟨a⟩ ty =| (env__out ::x y :- sch').
Proof.
  introv INF NIE. destruct (x == y).
  - subst.
    asserts_rewrite (subst_tm_e (e_Var_f y) y e = e). rewrite subst_tm_e_spec. crush.
    assumption.
  - forwards: proj1 Inf_Gen_Wf. unfold Inf_rename_binding__def in H. forwards: H y x. eassumption.
    simpl in H0. unfold subst_name in H0. if_taut.
    assert (x \notin Env_boundvars env__out).
      forwards: Inf_SameShape. apply INF. inverts H1. apply SameShape_boundvars in H4. crush.
    forwards REWR1: subst_name_Env_notin_involuntive x env__in.  fsetdec. rewrite REWR1 in H0.
    forwards REWR2: subst_name_Env_notin_involuntive x env__out. fsetdec. rewrite REWR2 in H0.
    assumption.
Qed.


Require Import List Ascii.
Require Import Ynot.
Require Import IO Net FS.

Open Local Scope hprop_scope.
Open Local Scope stsepi_scope.
Open Local Scope char_scope.

Set Implicit Arguments.

Inductive trace (local remote : Net.SockAddr) : IO.Trace -> Prop :=
| NilCorrect : trace local remote nil
| ConsCorrect : forall data reply past wait, trace local remote past ->
  (forall msg, ~In (UDP.Recd local remote msg) wait) ->
  trace local remote
      (WroteString stdout reply ++
       UDP.Recd local remote reply :: wait ++ UDP.Sent local remote data ::
       ReadLine stdin data ++ past).

Lemma proj_inv : forall (T1 T2 : Type) (a b : T1) (c d : T2),
  (a,c) = (b,d) -> a = b /\ c = d.
  intros; inversion H; auto.
Qed.

Definition waitReceive : forall (local remote : Net.SockAddr) (tr : [Trace]),
  STsep (tr ~~ IO.traced tr)
        (fun res:(list ascii * [Trace]) => tr ~~
          im :~~ (snd res) in IO.traced (UDP.Recd local remote (fst res) :: (im ++ tr))).
  refine (fun local remote tr =>
    {{Fix (fun im => im ~~ tr ~~ IO.traced (im ++ tr))
        (fun _ (res:list ascii * [Trace]) => tr ~~
           im :~~ (snd res) in IO.traced (UDP.Recd local remote (fst res) :: (im ++ tr)))
        (fun self im =>
           reply <- UDP.recv local (inhabit_unpack2 im tr (fun im tr => im ++ tr));
           if sock_eq remote (fst reply) then
             {{Return (snd reply, im)}}
           else
             {{self (im ~~~ (UDP.Recd local (fst reply) (snd reply)) :: im)}}
         ) [@nil Action]%inhabited}});
  solve [ sep fail auto
        | sep fail auto; apply proj_inv in H; destruct H; sep fail auto ].
Qed.

Definition iter : forall (local remote : Net.SockAddr) (tr : [Trace]),
  STsep (tr ~~ IO.traced tr * handle FS.stdin * handle FS.stdout)
        (fun _:unit => tr ~~ Exists request :@ list ascii, Exists reply :@ list ascii, Exists q :@ Trace,
          handle FS.stdin * handle FS.stdout *
          IO.traced (WroteString FS.stdout reply  ++
            (UDP.Recd local remote reply :: (q ++ UDP.Sent local remote request ::
              (ReadLine FS.stdin request ++ tr))))).
  refine (fun local remote tr =>
    ln <- readline FS.stdin FS.ro_readable tr <@> _ ;
    UDP.send local remote ln (tr ~~~ ReadLine FS.stdin ln ++ tr) <@> _ ;;
    reply <- waitReceive local remote (tr ~~~ UDP.Sent local remote ln :: (ReadLine FS.stdin ln ++ tr)) <@> _;
    writeline FS.stdout (fst reply) FS.wo_writeable (inhabit_unpack2 tr (snd reply)
      (fun tr q => (UDP.Recd local remote (fst reply)) :: q ++ (UDP.Sent local remote ln ::
        (ReadLine FS.stdin ln ++ tr)))) <@> _ ;;
    {{Return tt}});
  solve [ inhabiter; unpack_conc; rsep fail auto; sep fail auto; rsep fail auto ].
Qed.

Theorem list_no_cycle' : forall (T : Type) (l1 l2 : list T),
  l2 <> nil -> l2 ++ l1 <> l1.
  intros; pose (@list_no_cycle T l1 l2); unfold not in *; auto.
Qed.

Definition client : forall (local remote : Net.SockAddr) (tr : [Trace]),
  STsep (tr ~~ [trace local remote tr] * IO.traced tr * handle FS.stdin * handle FS.stdout)
        (fun _:unit => tr ~~ Exists v :@ Trace, [v <> tr] * [trace local remote tr] *
             IO.traced v * handle FS.stdin * handle FS.stdout).
  intros. refine ({{iter local remote tr <@> (tr ~~ [trace local remote tr])}}).
  sep fail auto.
  intros; inhabiter. sep fail auto. assert (WroteString stdout v1 ++
      (UDP.Recd local remote v1
       :: v2 ++ UDP.Sent local remote v0 :: ReadLine stdin v0 ++ x) <> x).
  unfold WroteString, ReadLine. assert ((WroteString stdout v1 ++
   UDP.Recd local remote v1
   :: v2 ++
      UDP.Sent local remote v0
      :: ReadLine stdin v0) ++ x <> x).
  eapply list_no_cycle'. firstorder. rewrite app_ass in H3. simpl in *. rewrite app_ass in H3. simpl in *. firstorder.
  sep fail auto.
Qed.


Require Export CatSem.PROP_untyped.arities.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

(** ** Category of representations *)
(** we define a category of representations of a signature Sig  *)
(** main work has been done in ./arities.v , remains to do:
	- identity representation morphism
	- composition of rep morphs
*)

(**  Morphisms of representations are just monad morphisms which verify
    some property. It is hence sufficient to check those properties.
    No new data is defined here. *)

Section cat_of_reps.

Notation "[ T ]" := (list T) (at level 5).

Variable S : Signature.

(** ** Identity
    identity representation morphism *)

Section id.

Variable P : Representation S.

Hint Extern 1 (CONSTR _ _ = CONSTR _ _) => apply CONSTR_eq.

Lemma Prod_mor_c_id V i (x : prod_mod_c _ V (sig (s:= S) i)):
 Prod_mor_c (RMonad_id P) (l:=sig (s:=S) i) (V:=V) x = x.
Proof.
  induction x; simpl; intros; auto.
Qed.

Hint Rewrite Prod_mor_c_id : bla.

Obligation Tactic := unfold commute, commute_left, commute_right;
     simpl; intros; autorewrite with bla; auto.

Hint Extern 1 (_ = _) => apply f_equal.

Program Instance Rep_Id_struct : Representation_Hom_struct (RMonad_id P).

Definition Rep_Id := Build_Representation_Hom Rep_Id_struct.

End id.

Hint Extern 1 (CONSTR _ _ = CONSTR _ _) => apply CONSTR_eq.

(** ** Composition
       composition of rep homs, preparation *)

Section comp_prepar.

Variables P Q R : RMonad SM_po.
Variable f : RMonad_Hom P Q.
Variable g : RMonad_Hom Q R.

Lemma prod_ind_mod_mor_comp l (V : TYPE) (t : prod_mod_c _ V l) :
    Prod_mor_c (RMonad_comp f g) t = Prod_mor_c g (Prod_mor_c f t).
Proof.
  induction t; simpl; auto.
Qed.

Hint Rewrite prod_ind_mod_mor_comp : bla.

Lemma comp_hophop l
       (MR : modhom_from_arity R (l))
       (MP : modhom_from_arity P (l))
       (MQ : modhom_from_arity Q (l))
       (HMf : commute f MP MQ)
       (HMg : commute g MQ MR):
       commute (RMonad_comp f g) MP MR.
Proof.
  intros;
  unfold commute, commute_left in *;
  simpl in *; intros;
  rerew_all;
  autorewrite with bla; auto.
Qed.

End comp_prepar.

(** composition of rep homs *)

Section comp.

Variables P Q R : Representation S.
Variable f : Representation_Hom P Q.
Variable g : Representation_Hom Q R.

Obligation Tactic := simpl; intros;
   apply comp_hophop with (repr Q _ );
   match goal with
       [H:Representation_Hom _ _ |- _ ] => apply H end.

Program Instance Rep_comp_struct :
   Representation_Hom_struct (RMonad_comp f g).

Definition Rep_Comp := Build_Representation_Hom Rep_comp_struct.

End comp.

(** ** Equality of Representation Morphisms
rep homs are equal if their resp carriers (monad homs) are *)

Section Req_equiv.

Variables P R : Representation S.

Ltac equiv := match goal with
     | [|- Reflexive _ ] => unfold Reflexive; intro;
                            apply Equivalence_Reflexive
     | [|- Symmetric _] => unfold Symmetric; do 2 intro;
                            apply Equivalence_Symmetric
     | [|- Transitive _ ] => unfold Transitive; do 3 intro;
                             apply Equivalence_Transitive end.

Existing Instance RMonad_Hom_oid.

Lemma eq_Rep_equiv :
   @Equivalence (Representation_Hom P R)
     (fun a c => repr_hom_c a == repr_hom_c c).
Proof.
  constructor; equiv.
Qed.

Definition eq_Rep_oid := Build_Setoid (eq_Rep_equiv).

End Req_equiv.

Existing Instance RMONAD_struct.

Obligation Tactic := simpl; intros; try unf_Proper;
        simpl; intros;
   repeat match goal with [H:_ |-_]=>rewrite H end;
   auto.

(** ** Category of Representations *)

Program Instance REP_struct :
         Cat_struct (@Representation_Hom S) := {
  mor_oid a c := eq_Rep_oid a c;
  id a := Rep_Id a;
  comp P Q R f g := Rep_Comp f g }.

Definition REP := Build_Cat REP_struct.

End cat_of_reps.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Relations.Relations.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Traversable.
Require Import ExtLib.Data.Option.
Require Import ExtLib.Data.Prop.
Require Import ExtLib.Data.Pair.
Require Import ExtLib.Data.List.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Tactics.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.SubstI.
Require Import MirrorCore.RTac.Core.
Require Import MirrorCore.RTac.CoreK.

Require Import MirrorCore.Util.Quant.
Require Import MirrorCore.Util.Forwardy.

Set Implicit Arguments.
Set Strict Implicit.

Section spec_lemmas.
  Context {typ : Set}.
  Context {expr : Set}.

  Context {RType_typ : RType typ}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {Typ0_Prop : Typ0 _ Prop}.
  Context {Expr_expr : Expr typ expr}.
  Context {ExprOk_expr : ExprOk Expr_expr}.
  Context {ExprUVar_expr : ExprUVar expr}.
  Context {ExprUVarOk_expr : ExprUVarOk ExprUVar_expr}.

  Local Hint Constructors WellFormed_ctx_subst.
  Lemma WellFormed_ctx_subst_fromAll
  : forall t (c : Ctx typ expr) (cs : ctx_subst (CAll c t)),
      WellFormed_ctx_subst cs ->
      WellFormed_ctx_subst (fromAll cs).
  Proof.
    intros.
    refine match H in @WellFormed_ctx_subst _ _ _ _ C cs
                 return match C as C return ctx_subst C -> Prop with
                          | CAll _ _ => fun x => WellFormed_ctx_subst (fromAll x)
                          | _ => fun _ => True
                        end cs
           with
             | @WF_AllSubst _ _ _ _ _ _ _ pf => pf
             | _ => I
           end.
  Qed.

  Lemma WellFormed_ctx_subst_fromHyp
  : forall t (c : Ctx typ expr) (cs : ctx_subst (CHyp c t)),
      WellFormed_ctx_subst cs ->
      WellFormed_ctx_subst (fromHyp cs).
  Proof.
    intros.
    refine match H in @WellFormed_ctx_subst _ _ _ _ C cs
                 return match C as C return ctx_subst C -> Prop with
                          | CHyp _ _ => fun x => WellFormed_ctx_subst (fromHyp x)
                          | _ => fun _ => True
                        end cs
           with
             | @WF_HypSubst _ _ _ _ _ _ _ pf => pf
             | _ => I
           end.
  Qed.
  Local Hint Resolve WellFormed_ctx_subst_fromAll WellFormed_ctx_subst_fromHyp.

  Lemma pctxD_remembers {c s l a sD pD}
  : forall (WFp : WellFormed_bimap (length (getUVars c)) (length l) (length (getVars c)) a),
      WellFormed_ctx_subst s ->
    pctxD s = Some sD ->
    amap_substD (getUVars c ++ l) (getVars c) a = Some pD ->
    exists sD',
      pctxD (remembers s l a) = Some sD' /\
      forall us vs (P : exprT _ _ Prop),
        (sD (fun us vs =>
               forall us', pD (hlist_app us us') vs -> P (hlist_app us us') vs) us vs <->
         sD' P us vs).
  Proof.
    simpl. intros.
    rewrite H0.
    destruct (pctxD_substD H H0) as [ ? [ ? ? ] ].
    eapply amap_instantiates_substD
      with (f := fun u => ctx_lookup u s)
           (C := fun (P : exprT (getUVars c ++ l) (getVars c) Prop) =>
                   forall us vs, sD (fun us vs => x us vs -> forall us', P (hlist_app us us') vs) us vs)
           in H1; try eassumption.
    forward_reason.
    rewrite H1.
    eexists; split; eauto.
    simpl. intros.
    split.
    { eapply Ap_pctxD; eauto.
      generalize (H3 us vs); clear H3.
      eapply Ap_pctxD; eauto.
      generalize (H4 us vs); clear H4.
      eapply Ap_pctxD; eauto.
      eapply Pure_pctxD; eauto.
      intros.
      eapply _forall_sem; intros.
      eapply H5; clear H5.
      eapply H3; eauto. }
    { eapply Ap_pctxD; eauto.
      generalize (H3 us vs); clear H3.
      eapply Ap_pctxD; eauto.
      generalize (H4 us vs); clear H4.
      eapply Ap_pctxD; eauto.
      eapply Pure_pctxD; eauto.
      intros.
      eapply _forall_sem with (x := us') in H5; intros.
      eapply H5; clear H5.
      eapply H3; eauto. }
    { clear - H0. constructor.
      { intros. eapply Pure_pctxD; eauto. }
      { intros. generalize (H1 us vs).
        eapply Ap_pctxD; eauto.
        generalize (H us vs).
        eapply Ap_pctxD; eauto.
        eapply Pure_pctxD; eauto. } }
    { red. intros.
      destruct (pctxD_substD H H0) as [ ? [ ? ? ] ].
      eapply ctx_substD_lookup in H4; eauto.
      forward_reason.
      eapply exprD_weakenU with (tus' := l) in H8; eauto.
      destruct H8 as [ ? [ ? ? ] ].
      eapply nth_error_get_hlist_nth_weaken in H4.
      revert H4. instantiate (1 := l).
      simpl. destruct 1 as [ ? [ ? ? ] ].
      rewrite H5 in H4. inv_all. subst.
      eexists; split; eauto.
      intros us vs.
      generalize (H7 us vs); clear H7.
      eapply Ap_pctxD; eauto.
      eapply Pure_pctxD; eauto. intros.
      rewrite <- H11; clear H11; eauto.
      rewrite <- H10; clear H10.
      eauto. }
  Qed.

  Lemma _exists_impl : forall l (P Q : hlist typD l -> Prop),
                         (forall x, P x -> Q x) ->
                         _exists _ l P -> _exists _ l Q.
  Proof using.
    intros.
    eapply _exists_sem in H0. eapply _exists_sem.
    destruct H0. exists x. auto.
  Qed.

  Lemma Ap_impls : forall (Ps : list Prop) (P Q : Prop),
                     _impls Ps (P -> Q) ->
                     _impls Ps P -> _impls Ps Q.
  Proof using.
    induction Ps; simpl; eauto.
  Qed.

  Opaque remembers.

  Lemma GoalImplies_GConj_
  : forall c (cs : ctx_subst c) l r,
      GoalImplies (cs, GConj l r) (cs, GConj_ l r).
  Proof.
    simpl; intros.
    split; auto.
    split.
    { destruct l; destruct r; inversion H; try constructor; eauto;
      try constructor. }
    { forward.
      assert (   (l = GSolved /\ r = GConj l r)
                 \/ (r = GSolved /\ l = GConj l r)
                 \/ (GConj_ l r = GConj l r)).
      { clear. destruct l; destruct r; simpl;
               try solve [ left; eauto | right; left; eauto | right; right; congruence ]. }
      destruct H3 as [ ? | [ ? | ? ] ]; forward_reason.
      { subst l. destruct H4. simpl.
        rewrite H2.
        split; [ reflexivity | ].
        intros.
        eapply Pure_pctxD; eauto. intros; tauto. }
      { destruct H4; subst. simpl.
        rewrite H2.
        split; [ reflexivity | ].
        intros.
        eapply Pure_pctxD; eauto. intros; tauto. }
      { destruct H3.
        simpl in *. forward.
        split; [ reflexivity | ].
        inv_all; subst.
        intros.
        eapply Pure_pctxD; eauto. } }
  Qed.

  Lemma GoalImplies_GConj
  : forall c (cs : ctx_subst c) l r,
      GoalImplies (cs, GConj_ l r) (cs, GConj l r).
  Proof.
    simpl; intros.
    split; auto.
    split.
    { inversion H; subst.
      destruct l; destruct r; simpl; auto; try constructor; auto. }
    { forward.
      assert (   (l = GSolved /\ r = GConj l r)
                 \/ (r = GSolved /\ l = GConj l r)
                 \/ (GConj_ l r = GConj l r)).
      { clear. destruct l; destruct r; simpl;
               try solve [ left; eauto | right; left; eauto | right; right; congruence ]. }
      destruct H5 as [ ? | [ ? | ? ] ]; forward_reason.
      { subst l. destruct H6. simpl.
        rewrite H3.
        split; [ reflexivity | ].
        intros.
        eapply Pure_pctxD; eauto. inv_all; subst. intros; tauto. }
      { destruct H6; subst. simpl.
        rewrite H2.
        split; [ reflexivity | ].
        intros.
        eapply Pure_pctxD; eauto. inv_all; subst. intros; tauto. }
      { destruct H5.
        simpl in *. forward.
        split; [ reflexivity | ].
        inv_all; subst.
        intros.
        eapply Pure_pctxD; eauto. } }
  Qed.

  Lemma rtac_spec_All_More
    : forall ctx s t g c g',
      rtac_spec (AllSubst (t:=t) s) g (More_ c g') ->
      rtac_spec (ctx:=ctx) s (GAll t g) (More_ (fromAll c) (GAll t g')).
  Proof using.
    unfold rtac_spec; simpl; intros.
    inv_all. forward_reason.
    forward_reason.
    rewrite (ctx_subst_eta c) in *.
    simpl in *; inv_all; subst.
    split; auto. split; auto.
    { constructor. auto. }
    forward. inv_all; subst.
    destruct H7. inv_all. subst.
    split; auto.
    intros. gather_facts.
    eapply Pure_pctxD; eauto.
  Qed.

  Lemma rtac_spec_All_Solved
    : forall ctx s t g c,
      rtac_spec (AllSubst (t:=t) s) g (Solved c) ->
      rtac_spec (ctx:=ctx) s (GAll t g) (Solved (fromAll c)).
  Proof using RTypeOk_typ.
    intros.
    eapply Proper_rtac_spec.
    3: eapply rtac_spec_All_More.
    - reflexivity.
    - change (Solved (fromAll c)) with (More (fromAll c) GSolved).
      eapply More_More_.
      instantiate (1 := GSolved).
      red. split.
      { split; constructor. constructor. }
      { simpl.
        constructor. constructor; auto. }
    - eapply Proper_rtac_spec.
      + reflexivity.
      + symmetry. eapply More_More_. reflexivity.
      + apply H.
  Qed.

  Lemma rtac_spec_GConj_Solved
    : forall ctx c s g1 g2 r,
      rtac_spec s g1 (Solved (c:=ctx) c) ->
      rtac_spec c g2 r ->
      rtac_spec s (GConj_ g1 g2) r.
  Proof.
    unfold rtac_spec. intros.
    destruct r; auto;
    intros; inv_all; forward_reason.
    { split; auto.
      split; auto.
      simpl.
      forward.
      forward_reason.
      split.
      { etransitivity; eauto. }
      intros. gather_facts.
      eapply pctxD_SubstMorphism; eauto.
      gather_facts.
      eapply Pure_pctxD; eauto. }
    { split; auto.
      simpl. forward; forward_reason.
      split.
      { etransitivity; eauto. }
      intros. gather_facts.
      eapply pctxD_SubstMorphism; eauto.
      gather_facts.
      eapply Pure_pctxD; eauto. }
  Qed.
  Lemma rtac_spec_GConj_More_
    : forall ctx c s g1 g2 r g,
      rtac_spec s g1 (More_ (c:=ctx) c g) ->
      rtac_spec c g2 r ->
      rtac_spec c (GConj_ g g2) r ->
      rtac_spec s (GConj_ g1 g2) r.
  Proof.
    unfold rtac_spec. intros.
    destruct r; auto;
    intros; inv_all; forward_reason.
    { split; auto.
      split; auto.
      simpl.
      destruct H1; auto.
      { constructor; eauto. }
      simpl in H9. destruct H9.
      forward.
      forward_reason.
      split.
      { etransitivity; eauto. }
      intros. gather_facts.
      eapply pctxD_SubstMorphism; eauto.
      gather_facts.
      eapply Pure_pctxD; eauto.
      tauto. }
    { split; auto.
      simpl.
      destruct H1; eauto.
      { constructor; auto. }
      simpl in *.
      forward; forward_reason.
      split.
      { etransitivity; eauto. }
      intros. gather_facts.
      eapply pctxD_SubstMorphism; eauto.
      gather_facts.
      eapply Pure_pctxD; eauto. tauto. }
  Qed.

  Lemma rtac_spec_Hyp_Solved
    : forall e (ctx : Ctx typ expr) (s : ctx_subst ctx)
             (c : ctx_subst (CHyp ctx e)) (g : Goal typ expr),
      rtac_spec (HypSubst s) g (Solved c) ->
      rtac_spec s (GHyp e g) (Solved (fromHyp c)).
  Proof using.
    simpl. intros.
    inv_all. destruct H; auto.
    split; auto.
    forward.
    destruct H6. inv_all; subst.
    simpl in *.
    forward. inv_all. subst.
    split; auto.
  Qed.

  Lemma rtac_spec_Hyp_More
    : forall (g0 g : Goal typ expr) (e : expr) (ctx : Ctx typ expr)
             (s : ctx_subst ctx) (c : ctx_subst (CHyp ctx e)),
      rtac_spec (HypSubst s) g (More_ c g0) ->
      rtac_spec s (GHyp e g) (More_ (fromHyp c) (GHyp e g0)).
  Proof using.
    simpl. intros. inv_all.
    forward_reason.
    split; auto.
    split.
    { constructor. auto. }
    forward. forward_reason.
    inv_all. subst.
    simpl in *. forward. inv_all; subst.
    split; auto.
    intros. gather_facts.
    eapply Pure_pctxD; eauto.
  Qed.

  Lemma rtac_spec_Conj_Solved
    : forall ctx s g1 g2 c r,
      rtac_spec s g1 (Solved c) ->
      rtac_spec c g2 r ->
      rtac_spec (ctx:=ctx) s (GConj_ g1 g2) r.
  Proof using.
    simpl.
    destruct r; simpl; auto; intros; inv_all; forward_reason.
    { split; auto. split; auto.
      forward. forward_reason.
      split.
      { etransitivity; eauto. }
      { intros; gather_facts.
        eapply pctxD_SubstMorphism; eauto.
        gather_facts.
        eapply Pure_pctxD; eauto. } }
    { split; auto.
      forward. forward_reason.
      split.
      { etransitivity; eauto. }
      { intros; gather_facts.
        eapply pctxD_SubstMorphism; eauto.
        gather_facts.
        eapply Pure_pctxD; eauto. } }
  Qed.

  Lemma rtac_spec_GConj_More_Solved
    : forall ctx s s' s'' g1 g2 g1',
      rtac_spec s g1 (More_ s' g1') ->
      rtac_spec s' g2 (Solved s'') ->
      rtac_spec (ctx:=ctx) s (GConj_ g1 g2) (More_ s'' g1').
  Proof using.
    simpl.
    intros; inv_all. forward_reason.
    split; auto. split; auto.
    forward. forward_reason.
    split.
    { etransitivity; eauto. }
    intros; gather_facts.
    eapply pctxD_SubstMorphism; eauto.
    gather_facts.
    eapply Pure_pctxD; eauto.
  Qed.

  Lemma rtac_spec_GConj_More_More
    : forall ctx s s' s'' g1 g2 g1' g2',
      rtac_spec s g1 (More_ s' g1') ->
      rtac_spec s' g2 (More_ s'' g2') ->
      rtac_spec (ctx:=ctx) s (GConj_ g1 g2) (More_ s'' (GConj_ g1' g2')).
  Proof using.
    simpl.
    intros; inv_all. forward_reason.
    split; auto.
    split.
    { constructor; auto. }
    forward. forward_reason.
    split.
    { etransitivity; eauto. }
    intros; gather_facts.
    eapply pctxD_SubstMorphism; eauto.
    gather_facts.
    eapply Pure_pctxD; eauto.
    tauto.
  Qed.

  Lemma rtac_spec_GSolved_Solved
    : forall ctx s, rtac_spec (ctx:=ctx) s GSolved (Solved s).
  Proof using.
    simpl.
    intros. split; auto.
    forward. split. reflexivity.
    eapply Pure_pctxD; eauto.
  Qed.

  Lemma ExprTApplicative_with_extra
    : forall (l : list typ) (ctx : Ctx typ expr) (s : ctx_subst ctx)
             (e : exprT (getUVars ctx) (getVars ctx) Prop ->
                  exprT (getAmbientUVars ctx) (getAmbientVars ctx) Prop),
      pctxD s = Some e ->
      CtxLogic.ExprTApplicative
        (fun P : exprT (getUVars ctx ++ l) (getVars ctx) Prop =>
           forall (us : hlist typD (getAmbientUVars ctx))
                  (vs : hlist typD (getAmbientVars ctx)),
             e
               (fun (us0 : hlist typD (getUVars ctx))
                    (vs0 : hlist typD (getVars ctx)) =>
                  forall z : hlist typD l, P (hlist_app us0 z) vs0) us vs).
  Proof using.
    constructor.
    { intros. eapply Pure_pctxD; eauto. }
    { intros. gather_facts. eapply Pure_pctxD; eauto. }
  Qed.

  Lemma rtac_spec_remembers_full_Solved
    : forall (l : list typ)
             (a : amap expr)
             (g : Goal typ expr)
             (ctx : Ctx typ expr)
             (s : ctx_subst ctx)
             (c : ctx_subst (CExs ctx l)),
      amap_is_full (length l) (fst (fromExs c)) = true ->
      rtac_spec (remembers s l a) g (Solved c) ->
      rtac_spec s (GExs l a g) (Solved (snd (fromExs c))).
  Proof using RTypeOk_typ ExprOk_expr.
    unfold rtac_spec. simpl.
    intros. inv_all.
    Transparent remembers. unfold remembers in *. Opaque remembers.
    forward_reason.
    assert (WellFormed_ctx_subst
              (ExsSubst (ts:=l) s (amap_instantiate (fun u : nat => ctx_lookup u s) a))).
    { edestruct remembers_sound; eauto with typeclass_instances. }
    forward_reason. clear H1.
    rewrite (ctx_subst_eta c) in *; simpl in *.
    generalize dependent (snd (fromExs c)).
    generalize dependent (fst (fromExs c)).
    intros. inv_all.
    split; auto.
    forward. inv_all. subst.
    assert (sem_preserves_if_ho
              (fun P : exprT (getUVars ctx ++ l) (getVars ctx) Prop =>
                 forall (us : hlist typD (getAmbientUVars ctx))
                        (vs : hlist typD (getAmbientVars ctx)),
                   e (fun us vs => forall z, P (hlist_app us z) vs) us vs) (fun u : uvar => subst_lookup u s)).
    { clear H7. red.
      intros.
      generalize H0.
      eapply pctxD_substD in H0; try eassumption.
      destruct H0 as [ ? [ ? ? ] ].
      eapply substD_lookup
      with (SubstOk := @SubstOk_ctx_subst _ _ _ _ _ _ _) in H7;
        try eassumption.
      forward_reason.
      eapply nth_error_get_hlist_nth_weaken with (ls' := l) in H7.
      simpl in H7. rewrite H9 in H7.
      forward_reason. inv_all. subst.
      eapply exprD_weakenU with (tus' := l) in H11; eauto.
      destruct H11 as [ ? [ ? ? ] ].
      eexists; split; eauto.
      intros. gather_facts. eapply Pure_pctxD; eauto.
      intros. rewrite <- H13; clear H13; eauto.
      rewrite <- H11; clear H11.
      eauto.
      Unshelve. eassumption. eassumption. }
    generalize (fun AC => @amap_instantiates_substD _ _ _ _ _ (getUVars ctx ++ l) (getVars ctx) _ AC (fun u : nat => ctx_lookup u s) _ _ _ _ _ H4 H8 H9).
    clear H9. destruct 1 as [ ? [ ? ? ] ].
    { clear - H0.
      revert H0. revert e; revert s; revert ctx; revert l.
      eapply ExprTApplicative_with_extra. }
    rewrite H9 in *.
    forward. inv_all; subst.
    forward_reason. inv_all; subst.
    split; eauto.
    intros. gather_facts.
    rewrite H0 in *. rewrite H9 in *.
    rewrite H12 in *. rewrite H7 in *.
    gather_facts.
    eapply subst_getInstantiation in H7;
      eauto using WellFormed_entry_WellFormed_pre_entry.
    destruct H7.
    eapply pctxD_SubstMorphism; eauto.
    gather_facts.
    eapply Pure_pctxD; eauto.
    clear - H7.
    intros. specialize (H7 us vs).
    eapply _exists_sem.
    exists (hlist_map
              (fun (t : typ) (x0 : exprT (getUVars ctx) (getVars ctx) (typD t)) =>
                 x0 us vs) x2).
    rewrite _forall_sem in H1.
    split.
    { eapply H. eapply H0. eapply H7. }
    { eapply H1. eapply H7. }
  Qed.

  Lemma rtac_spec_Exs_More
    : forall ctx (s : ctx_subst ctx) l a g c g',
      rtac_spec (remembers s l a) g (More_ c g') ->
      rtac_spec s (GExs l a g)
                (More_ (snd (fromExs c)) (GExs l (fst (fromExs c)) g')).
  Proof using RTypeOk_typ ExprOk_expr.
    unfold rtac_spec.
    Transparent remembers. unfold remembers. Opaque remembers.
    intros. inv_all.
    forward_reason.
    destruct H.
    { edestruct remembers_sound; eauto with typeclass_instances. }
    simpl in *.
    rewrite (ctx_subst_eta c) in *. simpl in *.
    generalize dependent (snd (fromExs c)).
    generalize dependent (fst (fromExs c)).
    clear c. intros; inv_all; subst.
    split; auto.
    forward_reason.
    split.
    { constructor; eauto using WellFormed_entry_WellFormed_pre_entry. }
    forward. inv_all. subst.
    assert (sem_preserves_if_ho
              (fun P : exprT (getUVars ctx ++ l) (getVars ctx) Prop =>
                 forall (us : hlist typD (getAmbientUVars ctx))
                        (vs : hlist typD (getAmbientVars ctx)),
                   e (fun us vs => forall z, P (hlist_app us z) vs) us vs) (fun u : uvar => subst_lookup u s)).
    { clear H7. red.
      intros.
      generalize H0.
      eapply pctxD_substD in H0; try eassumption.
      destruct H0 as [ ? [ ? ? ] ].
      eapply substD_lookup
      with (SubstOk := @SubstOk_ctx_subst _ _ _ _ _ _ _) in H7;
        try eassumption.
      forward_reason.
      eapply nth_error_get_hlist_nth_weaken with (ls' := l) in H7.
      simpl in H7. rewrite H9 in H7.
      forward_reason. inv_all. subst.
      eapply exprD_weakenU with (tus' := l) in H11; eauto.
      destruct H11 as [ ? [ ? ? ] ].
      eexists; split; eauto.
      intros. gather_facts. eapply Pure_pctxD; eauto.
      intros. rewrite <- H13; clear H13; eauto.
      rewrite <- H11; clear H11.
      eauto.
      Unshelve. eassumption. eassumption. }
    generalize (fun AC => @amap_instantiates_substD _ _ _ _ _ (getUVars ctx ++ l) (getVars ctx) _ AC (fun u : nat => ctx_lookup u s) _ _ _ _ _ H3 H8 H9).
    clear H9. destruct 1 as [ ? [ ? ? ] ].
    { clear - H0.
      revert H0. revert e; revert s; revert ctx; revert l.
      eapply ExprTApplicative_with_extra. }
    rewrite H9 in *.
    forward. inv_all; subst.
    forward_reason. inv_all; subst.
    split; eauto.
    intros. gather_facts.
    rewrite H0 in *. rewrite H9 in *.
    rewrite H13 in *. rewrite H7 in *.
    gather_facts.
    destruct H7.
    eapply pctxD_SubstMorphism; eauto.
    gather_facts.
    eapply Pure_pctxD; eauto.
    clear.
    intros.
    revert H2. eapply _exists_impl.
    rewrite _forall_sem in H1.
    intros. specialize (H x0).
    specialize (H0 x0).
    specialize (H1 x0).
    tauto.
  Qed.

End spec_lemmas.


Require Import Raft.
Require Import CommonDefinitions.
Require Import TraceUtil.

Section OutputCorrect.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Class output_correct_interface : Prop :=
    {
      output_correct_invariant :
        forall client id out failed net tr,
          step_f_star step_f_init (failed, net) tr ->
          in_output_trace client id out tr ->
          output_correct client id out (applied_entries (nwState net))
    }.
End OutputCorrect.


Require Export LL.FOLL.Dyadic.StructuralRules.

Export LLNotations.
Set Implicit Arguments.

Ltac solvell2 :=
 try
 match goal with
 | [ H: LL2N _ ?B ?L |- LL2S ?B ?L] => apply LL2NtoLL2S in H;auto
 end.

Ltac llExact H :=
  let G:= type of H in
  match G with
  | (LL2N ?x ?Gamma ?Delta) =>
    match goal with
    | [ |- LL2N ?x ?Gamma' ?Delta'] =>
      eapply @LL2N_compat with (B1:=Gamma) (L1:=Delta); try perm
    end
  end;auto.

Ltac llExact' H :=
  let G:= type of H in
  match G with
  | (LL2S ?Gamma ?Delta) =>
    match goal with
    | [ |- LL2S ?Gamma' ?Delta'] =>
      eapply @LL2S_compat with (B1:=Gamma) (L1:=Delta); try perm
    end
  end;auto.

Ltac LLExact H :=
  match (type of H) with
  | LL2S _ _  =>  llExact' H
  | LL2N _ _ _ => llExact H
  end.

  Definition CutW {OL:OLSig} (w: nat) :=
    forall i j C A M N B,
    complexity C  < w ->
      (LL2 i |-- B; C::M -> LL2 j |-- B; (dual C)::N -> LL2 |-- B; M ++ N) /\
      (S (complexity A) = complexity C ->
       LL2 i |-- A::B ; M -> LL2 j |-- B; (! dual A)::N -> LL2 |-- B; M++N).

  Definition CutH {OL:OLSig} (w m: nat) :=
    forall i j C A M N B,
   i + j < m ->
    complexity C = w ->
      (LL2 i |-- B; C::M -> LL2 j |-- B; (dual C)::N -> LL2 |-- B; M ++ N) /\
      (S (complexity A) = complexity C ->
      LL2 i |-- A::B ; M -> LL2 j |-- B; (! dual A)::N -> LL2 |-- B; M++N).

Ltac dualSimpl :=
 match goal with
 | H: ?F = ?C^ |- _ =>
    apply dualSubst in H;subst
 | H: ?C^ = ?F |- _ =>
   symmetry in H; apply dualSubst in H;subst
 | H: context [((?C)^)^] |- _ =>
    rewrite <- ng_involutive in H
end;auto.

Ltac putFirst H TT :=
match type of H with
| LL2N ?x ?BB (?FF::TT::?XX) =>
    eapply LL2N_compat with
     (B2:=BB) (L2:= TT::FF::XX) in H;try perm
 | LL2N ?x ?BB (?FF::?GG::TT::?XX) =>
   eapply LL2N_compat with
     (B2:=BB) (L2:= TT::FF::GG::XX) in H;try perm
end.

 Ltac applyCutH :=
  match goal with
  | [ H: CutH _ _ |- LL2N ?x (?FF::?BX) _ ->
         LL2N ?y ?BX _ ->
         LL2S _ _ ] => eapply H with (m := x + y) (C:=Quest FF);sauto
  | [ H: CutH _ _ |- LL2N ?x _ _ ->
         LL2N ?y _ _ ->
         LL2S _ _ ] => eapply H ;sauto
  | _ => idtac end.

Ltac applyCutW :=
  match goal with
 | [ H: CutW _ |- LL2N ?x (?FF::?BX) _ ->
         LL2N ?y ?BX _ ->
         LL2S _ _ ] => eapply @H with (m := x + y) (C:=Quest FF);sauto

  | [ H: CutW _ |- LL2N _ _ (?CF::_) ->
         LL2N _ _ _ ->
         LL2S _ _ ] => eapply H ;sauto
  | _ => idtac end.

Tactic Notation "cutH" constr(P1) constr(P2) :=
   let tP1 := type of P1 in
   let H' := fresh "HCUT" in
   match tP1 with
   | LL2N ?x ?BX (?CF::?CX) => let tP2 := type of P2 in
                    match tP2 with
                    | LL2N ?y ?BX (_::?CY) =>
                           assert(H': tP1 -> tP2 -> LL2S BX (CX++CY));
                           applyCutH; try rewrite app_nil_r in H'
                    | _ => idtac "type of " P2 " is " tP2 end
   | LL2N ?x ?BX (?NF::?CF::?CX2) => let tP2 := type of P2 in
                    match tP2 with
                    | LL2N ?y ?BX (_::?CY) =>
                           assert(LL2N x BX (CF::(NF++CX2)) -> tP2 -> LL2S BX ((NF::CX2)++CY));
                           applyCutH; try rewrite app_nil_r in H'
                    | _ => idtac "type of " P2 " is " tP2 end

   | _ => idtac "type of " P1 " is " tP1 end.

Tactic Notation "cutW" constr(P1) constr(P2) :=
   let tP1 := type of P1 in
   let H' := fresh "WCUT" in
   match tP1 with
   | LL2N ?x ?BX (?CF::?CX) => let tP2 := type of P2 in
                    match tP2 with
                    | LL2N ?y ?BX (_::?CY) =>
                           assert(H': tP1 -> tP2 -> LL2S BX (CX++CY));
                           applyCutW; try rewrite app_nil_r in H'
                    | _ => idtac "type of " P2 " is " tP2 end
   | _ => idtac "type of " P1 " is " tP1 end.

Tactic Notation "cutH'" constr(P1) constr(P2) :=
   let tP1 := type of P1 in
   let H' := fresh "HCUT" in
   match tP1 with
   | LL2N ?x (?CF::?BX) (?CX) => let tP2 := type of P2 in
                    match tP2 with
                    | LL2N ?y ?BX (_::?CY) =>
                           assert(H': tP1 -> tP2 -> LL2S BX (CX++CY));
                           applyCutH; try rewrite app_nil_r in H'
                    | _ => idtac "type of " P2 " is " tP2 end
   | _ => idtac "type of " P1 " is " tP1 end.

Tactic Notation "cutW'" constr(P1) constr(P2) :=
   let tP1 := type of P1 in
   let H' := fresh "WCUT" in
   match tP1 with
   | LL2N ?x (?CF::?BX) ?CX => let tP2 := type of P2 in
                    match tP2 with
                    | LL2N ?y ?BX (_::?CY) =>
                           assert(H': tP1 -> tP2 -> LL2S BX (CX++CY));
                           applyCutW; try rewrite app_nil_r in H'
                    | _ => idtac "type of " P2 " is " tP2 end
   | _ => idtac "type of " P1 " is " tP1 end.


From Perennial.program_proof.mvcc Require Import
     wrbuf_prelude wrbuf_repr wrbuf_sort_ents_by_key
     index_proof
     tuple_repr tuple_own tuple_free tuple_write_lock.

Section heap.
Context `{!heapGS Σ, !mvcc_ghostG Σ}.

(*********************************************************************)
(* func (wrbuf *WrBuf) OpenTuples(tid uint64, idx *index.Index) bool *)
(*********************************************************************)
Theorem wp_wrbuf__OpenTuples wrbuf (tid : u64) (idx : loc) sid mods γ :
  is_index idx γ -∗
  {{{ own_wrbuf_xtpls wrbuf mods ∗ active_tid γ tid sid }}}
    WrBuf__OpenTuples #wrbuf #tid #idx
  {{{ (ok : bool), RET #ok;
      active_tid γ tid sid ∗
      if ok
      then ∃ (tpls : gmap u64 loc), own_wrbuf wrbuf mods tpls ∗ own_tuples_locked (int.nat tid) tpls γ
      else own_wrbuf_xtpls wrbuf mods
  }}}.
Proof.
  iIntros "#Hidx !>" (Φ) "[Hwrbuf Hactive] HΦ".
  wp_call.

  (***********************************************************)
  (* wrbuf.sortEntsByKey()                                   *)
  (***********************************************************)
  wp_apply (wp_wrbuf__sortEntsByKey with "Hwrbuf").
  iIntros "Hwrbuf".
  wp_pures.

  (***********************************************************)
  (* ents := wrbuf.ents                                      *)
  (* var pos uint64 = 0                                      *)
  (* for pos < uint64(len(ents)) {                           *)
  (*     ent := ents[pos]                                    *)
  (*     tpl := idx.GetTuple(ent.key)                        *)
  (*     ret := tpl.Own(tid)                                 *)
  (*     if ret != common.RET_SUCCESS {                      *)
  (*         break                                           *)
  (*     }                                                   *)
  (*     ents[pos] = WrEnt {                                 *)
  (*         key : ent.key,                                  *)
  (*         val : ent.val,                                  *)
  (*         wr  : ent.wr,                                   *)
  (*         tpl : tpl,                                      *)
  (*     }                                                   *)
  (*     pos++                                               *)
  (* }                                                       *)
  (***********************************************************)
  iNamed "Hwrbuf".
  (* Obtain [is_slice_small] and eq about length of [ents]. *)
  iDestruct (is_slice_sz with "HentsS") as "%HentsLen".
  rewrite fmap_length in HentsLen.
  iDestruct (is_slice_small_acc with "HentsS") as "[HentsS HentsC]".
  wp_loadField.
  wp_pures.
  wp_apply (wp_ref_to); first by auto.
  iIntros (pos) "HposR".
  wp_pures.
  set P := (λ (b : bool), ∃ (n : u64) (tpls : gmap u64 loc) (ents' : list wrent),
               let m : dbmap := list_to_map (wrent_to_key_dbval <$> ents) in
               "Hactive"  ∷ active_tid γ tid sid ∗
               "HentsS"   ∷ is_slice_small entsS (struct.t WrEnt) 1 (wrent_to_val <$> ents') ∗
               "HposR"    ∷ pos ↦[uint64T] #n ∗
               "Htokens"  ∷ ([∗ map] k ↦ _ ∈ tpls, mods_token γ k (int.nat tid)) ∗
               "#HtplsRP" ∷ ([∗ map] k ↦ t ∈ tpls, is_tuple t k γ) ∗
               "%Htpls"   ∷ ⌜tpls = list_to_map (wrent_to_key_tpl <$> (take (int.nat n) ents'))⌝ ∗
               "%Hm"      ∷ ⌜m = list_to_map (wrent_to_key_dbval <$> ents')⌝ ∗
               "%Hlen"    ∷ ⌜length ents = length ents'⌝ ∗
               "%HNoDup"  ∷ ⌜NoDup ents'.*1.*1.*1⌝
           )%I.
  wp_apply (wp_forBreak_cond P with "[] [Hactive HentsS HposR]").
  { (* Loop body. *)
    clear Φ HNoDup.
    iIntros (Φ) "!> HP HΦ".
    iNamed "HP".
    wp_load.
    wp_apply (wp_slice_len).
    wp_if_destruct; last first.
    { (* Loop condition. *)
      iApply "HΦ".
      subst P. simpl.
      eauto 10 with iFrame.
    }
    wp_load.
    destruct (list_lookup_lt _ (wrent_to_val <$> ents') (int.nat n)) as [ent Hlookup].
    { rewrite fmap_length. word. }
    wp_apply (wp_SliceGet with "[$HentsS]"); first done.
    iIntros "[HentsS %Hty]".
    wp_pures.
    apply val_to_wrent_with_val_ty in Hty as (k & v & w & t & Hent).
    subst ent.
    wp_pures.
    wp_apply (wp_index__GetTuple with "Hidx").
    iIntros (tpl) "#Htpl".
    wp_pures.
    wp_apply (wp_tuple__Own with "Htpl Hactive").
    iIntros (ret) "[Hactive HpostOwn]".
    wp_pures.
    unfold post_tuple__Own.
    wp_if_destruct.
    { (* Early return due to failed [tuple__Own]. *)
      iApply "HΦ".
      subst P. simpl.
      eauto 10 with iFrame.
    }
    wp_load.
    wp_apply (wp_SliceSet with "[$HentsS]"); first by auto 10.
    iIntros "HentsS".
    wp_load.
    wp_store.
    iApply "HΦ".
    subst P. simpl.
    replace (int.Z 0) with 0 by word.
    set tpls := list_to_map (wrent_to_key_tpl <$> _).
    iExists _, (<[k := tpl]> tpls), _.
    rewrite wrent_to_val_unfold -list_fmap_insert.
    iFrame "HentsS Hactive HposR".
    replace (int.nat (word.add _ _)) with (S (int.nat n)) by word.
    rewrite take_S_insert; last word.
    (* Deduce [k ∉ (take (int.nat i) ents).*1.*1.*1]. *)
    apply wrent_to_val_with_lookup in Hlookup as (k' & v' & w' & t' & Eqx & Hlookup).
    inversion Eqx. subst k' v' w' t'.
    apply take_drop_middle in Hlookup as Eqents.
    rewrite -Eqents in HNoDup.
    do 3 rewrite fmap_app in HNoDup.
    do 3 rewrite fmap_cons in HNoDup.
    simpl in HNoDup.
    (* Before we swap using [NoDup_app_comm], obtain [Hnotin'] which we'll need for proving [HNoDup]. *)
    apply NoDup_app in HNoDup as H.
    destruct H as (_ & Hnotin' & _).
    apply NoDup_app_comm in HNoDup.
    apply NoDup_app in HNoDup as (HNoDup1 & Hnotin & HNoDup2).
    pose proof (elem_of_list_here k (drop (S (int.nat n)) ents').*1.*1.*1) as Helem.
    specialize (Hnotin k Helem).
    assert (HNone : tpls !! k = None).
    { apply not_elem_of_list_to_map_1. clear -Hnotin. set_solver. }
    rewrite big_sepM_insert; last done.
    iFrame "Htokens HpostOwn".
    iSplitL.
    { rewrite big_sepM_insert; last done. by iFrame "#". }
    iPureIntro.
    split.
    { rewrite fmap_snoc.
      unfold wrent_to_key_tpl. simpl. symmetry.
      apply list_to_map_snoc.
      clear -Hnotin. set_solver.
    }
    split.
    { rewrite Hm. f_equal.
      rewrite list_fmap_insert.
      unfold wrent_to_key_dbval. simpl.
      rewrite list_insert_id; first done.
      rewrite list_lookup_fmap Hlookup.
      done.
    }
    split.
    { rewrite Hlen. by rewrite insert_length. }
    { rewrite -Eqents.
      rewrite -insert_take_drop; last first.
      { rewrite -Hlen. word. }
      rewrite list_insert_insert.
      rewrite insert_take_drop; last first.
      { rewrite -Hlen. word. }
      do 3 rewrite fmap_app.
      do 3 rewrite fmap_cons.
      rewrite NoDup_app.
      split; done.
    }
  }
  { (* Loop entry. *)
    subst P. simpl.
    iExists _, ∅, _.
    iFrame.
    replace (int.nat 0) with 0%nat by word.
    rewrite take_0. simpl.
    by do 2 rewrite big_sepM_empty.
  }
  iIntros "HP". subst P. simpl.
  clear HNoDup.
  iNamed "HP".
  (**
   * Here we have [mods_token] and [is_tuple] for each element in [ents].
   *)

  (***********************************************************)
  (* if pos < uint64(len(ents)) {                            *)
  (*     var i uint64 = 0                                    *)
  (*     for i < pos {                                       *)
  (*         tpl := ents[i].tpl                              *)
  (*         tpl.Free()                                      *)
  (*         i++                                             *)
  (*     }                                                   *)
  (*     return false                                        *)
  (* }                                                       *)
  (***********************************************************)
  wp_pures.
  wp_load.
  wp_apply wp_slice_len.
  wp_if_destruct.
  { (* Early return due to failure of acquiring all locks. *)
    wp_apply (wp_ref_to); first by auto.
    iIntros (i) "HiR".
    wp_pures.
    set P := (λ (b : bool), ∃ (m : u64),
                 let tpls' := list_to_map (wrent_to_key_tpl <$> drop (int.nat m) (take (int.nat n) ents')) in
                 "HentsS"   ∷ is_slice_small entsS (struct.t WrEnt) 1 (wrent_to_val <$> ents') ∗
                 "HposR"    ∷ pos ↦[uint64T] #n ∗
                 "HiR"      ∷ i ↦[uint64T] #m ∗
                 "Htokens"  ∷ ([∗ map] k ↦ _ ∈ tpls', mods_token γ k (int.nat tid)))%I.
    wp_apply (wp_forBreak_cond P with "[] [HentsS HposR HiR Htokens]").
    { (* Loop body. *)
      clear Φ.
      iIntros (Φ) "!> HP HΦ".
      subst P. simpl.
      iNamed "HP".
      do 2 wp_load.
      wp_if_destruct; last first.
      { (* Loop condition. *)
        iApply "HΦ".
        eauto 10 with iFrame.
      }
      wp_load.
      destruct (list_lookup_lt _ (wrent_to_val <$> ents') (int.nat m)) as [ent Hlookup].
      { rewrite fmap_length. word. }
      wp_apply (wp_SliceGet with "[$HentsS]"); first done.
      iIntros "[HentsS %Hty]".
      apply val_to_wrent_with_val_ty in Hty as (k & v & w & t & Hent).
      subst ent.
      wp_pures.
      (* Obtain [is_tuple] and [mods_token] for [t]. *)
      set ents'' := (take _ ents').
      apply wrent_to_val_with_lookup in Hlookup as (k' & v' & w' & t' & Eqx & Hlookup).
      inversion Eqx. subst k' v' w' t'.
      iDestruct (big_sepM_lookup _ _ k t with "HtplsRP") as "#HtplRP".
      { rewrite Htpls.
        rewrite -elem_of_list_to_map; last first.
        { pose proof HNoDup as HNoDup'.
          rewrite -(take_drop (int.nat m) ents') in HNoDup.
          do 3 rewrite fmap_app in HNoDup.
          apply NoDup_app in HNoDup as [HNoDup _].
          replace _.*1 with ents''.*1.*1.*1; last first.
          { do 3 rewrite -list_fmap_compose. set_solver. }
          rewrite -(take_drop (int.nat n) ents') in HNoDup'.
          do 3 rewrite fmap_app in HNoDup'.
          by apply NoDup_app in HNoDup' as [HNoDup' _].
        }
        apply (elem_of_list_lookup_2 _ (int.nat m)).
        rewrite fmap_take.
        rewrite lookup_take; last word.
        by rewrite list_lookup_fmap Hlookup.
      }
      rewrite (drop_S _ (k, v, w, t)); last first.
      { subst ents''. rewrite lookup_take; [done | word]. }
      rewrite fmap_cons list_to_map_cons. simpl.
      rewrite big_sepM_insert; last first.
      { apply not_elem_of_list_to_map_1.
        apply take_drop_middle in Hlookup.
        rewrite -Hlookup in HNoDup.
        do 3 rewrite fmap_app in HNoDup.
        apply NoDup_app in HNoDup as (_ & _ & HNoDup).
        apply NoDup_cons in HNoDup as [Hnotin _]. simpl in Hnotin.
        rewrite -(take_drop (int.nat n) ents') in Hnotin.
        rewrite drop_app_le in Hnotin; last first.
        { rewrite take_length_le; first word. rewrite -Hlen. word. }
        clear -Hnotin. set_solver.
      }
      iDestruct "Htokens" as "[Htoken Htokens]".
      wp_apply (wp_tuple__Free with "HtplRP Htoken").
      wp_pures.
      wp_load.
      wp_store.
      iApply "HΦ".
      iExists _.
      iFrame.
      replace (int.nat (word.add _ _)) with (S (int.nat m)) by word.
      by iFrame.
    }
    { subst P. simpl.
      iExists _. iFrame.
      replace (int.nat 0) with 0%nat by word.
      rewrite drop_0. by subst tpls.
    }
    iIntros "HP".
    iNamed "HP".
    wp_pures.
    iApply "HΦ".
    iDestruct ("HentsC" with "HentsS") as "HentsS".
    rewrite Hm in Hmods.
    eauto 10 with iFrame.
  }

  (***********************************************************)
  (* for _, ent := range ents {                              *)
  (*     ent.tpl.WriteLock()                                 *)
  (* }                                                       *)
  (***********************************************************)
  replace (take (int.nat n) ents') with ents' in Htpls; last first.
  { apply Znot_lt_ge in Heqb. symmetry. apply take_ge. word. }
  set P := (λ (i : u64),
              let tpls_take := (list_to_map (wrent_to_key_tpl <$> (take (int.nat i) ents'))) in
              let tpls_drop := (list_to_map (wrent_to_key_tpl <$> (drop (int.nat i) ents'))) in
              "Htokens"  ∷ ([∗ map] k ↦ _ ∈ tpls_drop, mods_token γ k (int.nat tid)) ∗
              "HtplsOwn" ∷ own_tuples_locked (int.nat tid) tpls_take γ
           )%I.
  wp_apply (wp_forSlice P with "[] [$HentsS Htokens]").
  { (* Loop body. *)
    clear Φ.
    iIntros (j e).
    iIntros (Φ) "!> (HP & %Hbound & %Hlookup) HΦ".
    subst P. simpl.
    iNamed "HP".
    apply wrent_to_val_with_lookup in Hlookup as (k & v & w & t & Eqx & Hlookup).
    subst e.
    wp_pures.
    (* Retrieve [is_tuple] of key [k]. *)
    iDestruct (big_sepM_lookup _ _ k t with "HtplsRP") as "HtplRP".
    { rewrite Htpls.
      rewrite -elem_of_list_to_map; last first.
      { replace _.*1 with ents'.*1.*1.*1; first done.
        do 3 rewrite -list_fmap_compose. set_solver.
      }
      apply elem_of_list_lookup_2, (elem_of_list_fmap_1 wrent_to_key_tpl) in Hlookup.
      done.
    }
    (**
     * Deduce [k ∉ (drop (S (int.nat i)) ents').*1.*1.*1], which we need in [big_sepM_insert].
     * Deduce [k ∉ (take (int.nat i) ents').*1.*1.*1], which we need in [list_to_map_snoc] and [big_sepM_insert].
     *)
    apply take_drop_middle in Hlookup as Eqents.
    rewrite -Eqents in HNoDup.
    do 3 rewrite fmap_app in HNoDup.
    do 3 rewrite fmap_cons in HNoDup.
    simpl in HNoDup.
    apply NoDup_app_comm in HNoDup as HNoDup'.
    apply NoDup_app in HNoDup as (_ & _ & HNoDup).
    apply NoDup_cons in HNoDup as [Hnotin _].
    apply NoDup_app in HNoDup' as (_ & Hnotin' & _).
    specialize (Hnotin' k).
    pose proof (elem_of_list_here k (drop (S (int.nat j)) ents').*1.*1.*1) as Helem.
    specialize (Hnotin' Helem).
    (* Q: How to rewrite [P -> Q] to [Q] and prove [P]. *)
    (* specialize (Hnotin' elem_of_list_here). doesn't work. *)
    (* Retrieve [mods_token] of key [k]. *)
    rewrite (drop_S _ _ _ Hlookup).
    rewrite fmap_cons list_to_map_cons. simpl.
    rewrite big_sepM_insert; last first.
    { apply not_elem_of_list_to_map_1. set_solver. }
    iDestruct "Htokens" as "[Htoken Htokens]".

    wp_apply (wp_tuple__WriteLock with "HtplRP Htoken").
    iIntros (phys) "Htpl".
    iApply "HΦ".
    replace (int.nat (word.add _ _)) with (S (int.nat j)) by word.
    iFrame "Htokens".
    rewrite (take_S_r _ _ _ Hlookup).
    rewrite fmap_snoc list_to_map_snoc; last first.
    { simpl. rewrite -list_fmap_compose. set_solver. }
    unfold named. rewrite {2} /own_tuples_locked.
    rewrite big_sepM_insert; last first.
    { apply not_elem_of_list_to_map_1. set_solver. }
    iFrame "HtplsOwn".
    by iExists phys.
  }
  { (* Loop entry. *)
    subst P. simpl.
    replace (int.nat 0) with 0%nat by word.
    rewrite drop_0 take_0 -Htpls. simpl.
    iFrame "Htokens".
    by iApply big_sepM_empty.
  }
  iIntros "[HP HentsS]".
  subst P. simpl.
  iNamed "HP".
  iDestruct ("HentsC" with "HentsS") as "HentsS".
  wp_pures.

  (***********************************************************)
  (* return true                                             *)
  (***********************************************************)
  iApply "HΦ".
  iFrame "Hactive".
  iExists _.
  rewrite -HentsLen Hlen firstn_all.
  iFrame "HtplsOwn".
  rewrite Hm in Hmods.
  eauto 10 with iFrame.
Qed.

End heap.


Require Problem.
Require Solution.

Theorem checker : Problem.task.
Proof. exact Solution.solution. Qed.


Require Import SpecCert.x86.Architecture.

Definition open_smram_pre
           {Label: Type}
           (a:     Architecture Label) :=
  smramc_is_unlocked (memory_controller a).

Definition open_smram_post
           {Label: Type}
           (a a':  Architecture Label) :=
    exists h, let m' := open_smram (memory_controller a) h
    in a' = update_memory_controller a m'.