theory RedSafeCase
  imports WTLemma RedSafeUnpack
begin

  (* ###### case lemmas *)

lemma safe_app_op_case: "\<lbrakk> app_red_exp OpApp (s1, AppExp (OpExp xop) v) ax (s2, e2); FunTy tx tau r a = op_type xop \<rbrakk> \<Longrightarrow> well_typed env delta r_s1 e2 tau r_s1 empty_use_env"
  apply (case_tac v)
       apply (auto)
  apply (case_tac ax)
   apply (auto)
    (* given xop: op, x1: const, assuming tau matches the return type of xop, we want to show that e2 is well-typed.
        now e2 can either be an op or a const.
    *)
  apply (case_tac "\<not> (\<exists> rop. e2 = OpExp rop)")
   apply (case_tac "\<not> (\<exists> c. e2 = ConstExp c)")
    apply (auto)
        apply (case_tac xop)
             apply (auto)
    (* the hard part is proving that e2 will have the right type. *)
       apply (case_tac xop)
            apply (auto)
         apply (simp add: pure_fun_def)
        apply (simp add: pure_fun_def)
       apply (simp add: pure_fun_def)
      apply (rule_tac id_leq_use_env)
     apply (rule_tac leq_empty_use_env)
    (* op case, same thing *)
    apply (case_tac xop)
         apply (auto)
      apply (simp add: pure_fun_def)
     apply (simp add: pure_fun_def)
    apply (simp add: pure_fun_def)
   apply (rule_tac id_leq_use_env)
  apply (rule_tac leq_empty_use_env)
  done

lemma add_proper_delta: "\<lbrakk> proper_delta s delta; fresh_var s x \<rbrakk> \<Longrightarrow> proper_delta (add_env s x v) (add_delta delta x x)"
  apply (simp add: proper_delta_def)
  apply (auto)
  apply (case_tac "xa \<noteq> x")
   apply (auto)
   apply (simp add: add_env_def)
   apply (case_tac "s xa")
    apply (auto)
   apply (erule_tac x="xa" in allE)
   apply (auto)
   apply (simp add: add_delta_def)
   apply (simp add: add_env_def)
  apply (simp add: add_env_def)
  apply (simp add: add_delta_def)
  done

lemma well_typed_list_incr_perm: "\<lbrakk> well_typed_list env delta r_x l tau; leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> well_typed_list env delta r_s l tau"
  apply (induct l arbitrary: r_x)
   apply (auto)
  apply (rule_tac rx="r_x" in well_typed_incr_req)
    apply (auto)
   apply (rule_tac r_s="r_x" in well_typed_incr_simul_perm)
    apply (auto)
  apply (rule_tac id_leq_use_env)
  done

lemma well_typed_mv_incr_perm: "\<lbrakk> well_typed_mem_value env delta r_x tau v; leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> well_typed_mem_value env delta r_s tau v"
  apply (case_tac v)
    apply (auto)
  apply (rule_tac well_typed_list_incr_perm)
   apply (auto)
  done

    (* the point of this lemma is to state that new values can be added *)
lemma well_typed_state_add_vars: "\<lbrakk> well_typed_state s1 env delta; fresh_var s1 x; well_typed_mem_value env delta empty_use_env tau v \<rbrakk> \<Longrightarrow>
  well_typed_state (add_env s1 x v) (add_env env (Loc x) tau) (add_delta delta x x)"
    (* starts by proving the validity of the env + res map *)
  apply (simp add: well_typed_state_def)
  apply (auto)
    apply (rule_tac dist_add_sub_env)
    apply (simp)(*
    (* the state is still fully covered by the map *)
      apply (simp add: full_nres_map_def)
      apply (auto)
       apply (simp add: add_env_def)
       apply (auto)
      apply (simp add: add_env_def)
      apply (auto)
    (* prove disjointness remains *)
     apply (rule_tac disj_add_nres_map)
      apply (auto)
    (* prove containment remains *)
    apply (rule_tac add_sub_nres_map2)
     apply (rule_tac add_sub_nres_map1)
      apply (simp_all)
    apply (simp add: fresh_var_def)*)
    (* prove properness of delta *)
   apply (rule_tac add_proper_delta)
     apply (auto)
    (* now it remains to prove that all the values are still well-typed. we do the x = xa case first *)
  apply (erule_tac x="xa" in allE)
  apply (case_tac "x = xa")
   apply (case_tac "add_env s1 x v x")
    apply (simp add: add_env_def)
   apply (auto)
   apply (case_tac "add_env env (Loc x) tau (Loc x)")
    apply (simp add: add_env_def)
   apply (auto)
(*
   apply (cut_tac rs_map="rs_map" and x="x" and r_s="r_s" in nres_add_same)
   apply (simp)*)
   apply (case_tac "env (Loc x) \<noteq> None")
    apply (simp add: fresh_var_def)
    apply (simp add: sub_env_def)
    apply (erule_tac x="Loc x" in allE)
    apply (auto)
   apply (rule_tac r_x="empty_use_env" in well_typed_mv_incr_perm)
    apply (rule_tac well_typed_mv_add_vars)
     apply (rule_tac well_typed_mv_add_delta)
      apply (simp add: add_env_def)
     apply (auto)
   apply (rule_tac leq_empty_use_env)
    (* now we do that x \<noteq> xa case *)
  apply (simp add: add_env_def)
  apply (case_tac "s1 xa")
   apply (auto)
  apply (simp add: add_env_def)
  apply (case_tac "env (Loc xa)")
   apply (auto)
  apply (case_tac "add_delta delta x x xa \<noteq> delta xa")
   apply (simp add: add_delta_def)
  apply (rule_tac well_typed_mv_add_vars)
   apply (rule_tac well_typed_mv_add_delta)
    apply (auto)
   apply (simp add: fresh_var_def)
   apply (simp add: sub_env_def)
   apply (erule_tac x="Loc x" in allE)
   apply (auto)
  apply (simp add: fresh_var_def)
  apply (simp add: sub_env_def)
  apply (erule_tac x="Loc x" in allE)
  apply (auto)
  done

lemma sacc_make_act_case: "
        \<lbrakk>well_typed_state s1 env delta; app_red_exp ConstApp (s1, AppExp (ConstExp c) v) (MakeAct x) (s2, e2); sub_use_env s1 r_f;
                well_typed env delta r_s1 v t1 r_s2 rx2; leq_use_env r_s3 (diff_use_env r_s2 (comp_use_env rx1 (lift_use_env rx2 r))); leq_use_env rx r_s3;
                FunTy t1 t2 r a \<in> const_type c; c \<noteq> FixConst; ax = MakeAct x; leq_use_env r_s1 r_f\<rbrakk>
               \<Longrightarrow> well_typed (add_env env (Loc x) t2) (add_delta delta x x) (add_use_env r_s1 (Loc x) OwnPerm) e2 t2 r_s3 rx"
    (* e2 will always be the generated variable *)
  apply (case_tac "e2 \<noteq> VarExp (LocType x)")
   apply (case_tac c)
                apply (auto)
  apply (simp add: add_env_def)
    (* remove simple addition based reqs *)
  apply (case_tac "add_delta delta x x x \<noteq> x")
   apply (simp add: add_delta_def)
  apply (simp add: add_env_def)
  apply (auto)
   apply (case_tac c)
               apply (auto)
   apply (rule_tac ereq_leq_use_envx)
   apply (simp add: add_use_env_def)
    (* prelim: x is fresh *)
  apply (case_tac "\<not> fresh_var s1 x")
   apply (case_tac c)
                apply (auto)
    (* prelim: r_s3 \<le> r_s1 *)
  apply (cut_tac r_sc="r_s3" and r_sb="diff_use_env r_s2 (comp_use_env rx1 (lift_use_env rx2 r))" and r_sa="r_s1" in trans_leq_use_env)
    apply (rule_tac diff_leq_use_env)
    apply (simp_all)
   apply (rule_tac well_typed_perm_leq)
   apply (auto)
    (* we can achieve the desired permissions by removing x from the end perms + reqs (which is okay since they dont appear anywhere else yet). *)
  apply (rule_tac x="one_use_env (Loc x) OwnPerm" in exI)
  apply (auto)
    (* - the end perm bound is possible since we assume r_s3 didnt already contain x2 *)
    apply (rule_tac t=" leq_use_env r_s3 (diff_use_env (add_use_env r_s1 (Loc x) OwnPerm) (comp_use_env (ereq_use_env (Loc x) t2) (one_use_env (Loc x) OwnPerm)))" and
        s=" leq_use_env (rem_use_env r_s3 (Loc x)) (diff_use_env (add_use_env r_s1 (Loc x) OwnPerm) (comp_use_env (ereq_use_env (Loc x) t2) (one_use_env (Loc x) OwnPerm)))" in subst)
     apply (cut_tac r_s="r_s3" and x="Loc x" in ignore_rem_use_env)
      apply (rule_tac r_s="r_s1" in leq_use_none)
       apply (auto)
     apply (simp add: sub_use_env_def)
     apply (simp add: fresh_var_def)
     apply (cut_tac r_x="r_s1" and r_s="r_f" and x="Loc x" in leq_use_none)
       apply (auto)
    (* - given this, we can finish proving the bound *)
    apply (rule_tac rhs_unroll_dcl_use_env)
    apply (rule_tac rhs_unroll_rem_use_env)
    apply (rule_tac dist_rem_leq_use_env)
    apply (rule_tac rhs_weak_leq_use_env)
     apply (rule_tac weak_ereq_use_env)
     apply (case_tac c)
                   apply (auto)
     apply (simp add: pure_fun_def)
     apply (simp add: unlim_def)
    apply (rule_tac rhs_add_leq_use_env)
     apply (auto)
    (* - unrolling definitions to prove the subtracter bound *)
   apply (simp add: leq_use_env_def)
   apply (simp add: one_use_env_def)
   apply (simp add: add_use_env_def)
    (* - proving the requirement bound *)
  apply (rule_tac r_sb="diff_use_env (ereq_use_env (Loc x) t2) (one_use_env (Loc x) OwnPerm)" in trans_leq_use_env)
   apply (simp add: ereq_use_env_def)
   apply (rule_tac diff_one_leq_use_env)
  apply (rule_tac lhs_unroll_dcl_use_env)
  apply (rule_tac dist_diff_leq_use_env)
  apply (rule_tac self_diff_leq_use_env)
  done

lemma add_env_force_ex: "\<lbrakk> \<forall> z. add_env s x v z = add_env s x w z \<rbrakk> \<Longrightarrow> v = w"
  apply (erule_tac x="x" in allE)
  apply (simp add: add_env_def)
  done

lemma add_env_force: "\<lbrakk> add_env s x v = add_env s x w \<rbrakk> \<Longrightarrow> v = w"
  apply (rule_tac s="s" and x="x" and v="v" and w="w" in add_env_force_ex)
  apply (auto)
  done

lemma disj_add_use_env: "\<lbrakk> disj_use_env r_s r_x; r_s x = NoPerm \<rbrakk> \<Longrightarrow> disj_use_env r_s (add_use_env r_x x r)"
  apply (simp add: disj_use_env_def)
  apply (simp add: add_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  done

lemma strong_disj_add_use_env: "\<lbrakk> strong_disj_use_env r_s r_x; r_s x = NoPerm \<rbrakk> \<Longrightarrow> strong_disj_use_env r_s (add_use_env r_x x r)"
  apply (simp add: strong_disj_use_env_def)
  apply (simp add: add_use_env_def)
  done

lemma add_valid_exp_use_env: "\<lbrakk> valid_nres_map s rs_map; valid_exp_use_env s rs_map r_s; fresh_var s x \<rbrakk> \<Longrightarrow>
  valid_exp_use_env (add_env s x v) (add_env rs_map x empty_use_env) (add_use_env r_s (Loc x) OwnPerm)"
  apply (simp add: valid_exp_use_env_def)
  apply (auto)
    (* domain preservation *)
   apply (rule_tac rhs_add_sub_use_env)
   apply (rule_tac add_sub_use_env)
    apply (simp)
   apply (simp add: add_env_def)
    (* separation *)
  apply (simp add: sep_nres_map_def)
  apply (auto)
  apply (case_tac "x = xa")
   apply (auto)
   apply (simp add: nres_add_same)
   apply (rule_tac empty_strong_disj_use_env2)
  apply (simp add: nres_add_diff)
  apply (erule_tac x="xa" in allE)
  apply (rule_tac comm_strong_disj_use_env)
  apply (rule_tac strong_disj_add_use_env)
  apply (rule_tac comm_strong_disj_use_env)
   apply (simp)
  apply (simp add: valid_nres_map_def)
  apply (simp add: sub_nres_map_def)
  apply (auto)
  apply (erule_tac x="xa" in allE)
  apply (simp add: sub_use_env_def)
  apply (simp add: fresh_var_def)
  apply (auto)
  done

    (*
      the hard part that we're dealing with right now is that at the end using pairs does NOT work for the WRITE constants,
        since we want "use" permission for the array, but "own" permission for the value being written.

      what this suggests is that we have to allow for constant + application to be a value.
      even if we do this, we need to give them all their own unique cases, just like for unpacking.
      - this is more complicated than it is with constants, since the contents of the first arg will generally be somewhat complex.

    *)

lemma saccmk2_var_type: "\<lbrakk> env (Loc x) = Some (ChanTy t c_end); delta x = x \<rbrakk> \<Longrightarrow>
  well_typed env delta (one_use_env (Loc x) OwnPerm) (VarExp (LocType x)) (ChanTy t c_end) (one_use_env (Loc x) OwnPerm) (one_use_env (Loc x) OwnPerm)"
  apply (auto)
   apply (rule_tac ereq_leq_use_envx)
   apply (simp add: one_use_env_def)
  apply (rule_tac x="empty_use_env" in exI)
  apply (auto)
     apply (rule_tac rhs_weak_leq_use_env)
      apply (rule_tac dist_weak_comp_use_env)
       apply (rule_tac weak_ereq_use_env)
       apply (simp add: unlim_def)
      apply (simp add: weak_use_env_def)
      apply (simp add: empty_use_env_def)
     apply (rule_tac id_leq_use_env)
     apply (rule_tac id_leq_use_env)
   apply (rule_tac leq_empty_use_env)
  apply (rule_tac diff_leq_use_env)
  apply (rule_tac ereq_leq_use_envx)
  apply (simp add: one_use_env_def)
  done

lemma saccmk2_pair_type: "\<lbrakk> well_typed env delta (one_use_env x1 OwnPerm) v1 t1 (one_use_env x1 OwnPerm) (one_use_env x1 OwnPerm);
  well_typed env delta (one_use_env x2 OwnPerm) v2 t2 (one_use_env x2 OwnPerm) (one_use_env x2 OwnPerm);
  r_s1 x1 = OwnPerm; r_s1 x2 = OwnPerm; r_s2 x1 = NoPerm; r_s2 x2 = NoPerm;
  leq_use_env r_s2 r_s1; leq_use_env rx r_s2; is_own r; x1 \<noteq> x2 \<rbrakk> \<Longrightarrow>
  well_typed env delta r_s1 (PairExp v1 v2) (PairTy t1 t2 r) r_s2 rx"
  apply (auto)
  apply (rule_tac x="r_s1" in exI)
  apply (rule_tac x="r_s1" in exI)
  apply (rule_tac x="one_use_env x1 OwnPerm" in exI)
  apply (auto)
   apply (rule_tac r_s="one_use_env x1 OwnPerm" in well_typed_incr_simul_perm)
    apply (simp add: leq_use_env_def)
    apply (simp add: one_use_env_def)
   apply (simp)
  apply (rule_tac x="one_use_env x2 OwnPerm" in exI)
  apply (auto)
       apply (rule_tac r_s="one_use_env x2 OwnPerm" in well_typed_incr_simul_perm)
        apply (simp add: leq_use_env_def)
        apply (simp add: one_use_env_def)
       apply (simp)
      apply (simp add: is_own_def)
      apply (simp add: leq_use_env_def)
      apply (simp add: one_use_env_def)
     apply (simp add: is_own_def)
     apply (simp add: leq_use_env_def)
     apply (simp add: one_use_env_def)
    apply (simp add: is_own_def)
    apply (case_tac "max_aff (req_type t1) (req_type t2)")
      apply (auto)
   apply (simp add: is_own_def)
   apply (simp add: one_use_env_def)
   apply (simp add: disj_use_env_def)
   apply (simp add: mini_disj_use_env_def)
  apply (rule_tac x="add_use_env (one_use_env x1 OwnPerm) x2 OwnPerm" in exI)
  apply (auto)
    apply (rule_tac mini_disj_diff_leq_use_env2)
     apply (simp)
    apply (simp add: mini_disj_use_env_def)
    apply (simp add: one_use_env_def)
    apply (simp add: add_use_env_def)
    apply (auto)
   apply (rule_tac add_leq_use_env)
    apply (simp add: leq_use_env_def)
    apply (simp add: one_use_env_def)
   apply (auto)
  apply (simp add: pair_req_def)
  apply (auto)
   apply (rule_tac leq_empty_use_env)
  apply (simp add: leq_use_env_def)
  apply (simp add: add_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (simp add: comp_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: is_own_def)
  done

lemma sacc_mk2_act_case: "
  \<lbrakk>well_typed_state s1 env delta; sub_use_env s1 r_f; well_typed env delta r_s1 v t1 r_s2 rx2;
                leq_use_env r_s3 (diff_use_env r_s2 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex));
                leq_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_s2; leq_use_env r_ex r_s1; leq_use_env rx r_s3;
                leq_use_env (app_req rx1 rx2 r t2 r_ex) rx; leq_use_env r_s1 r_f; FunTy t1 t2 r a \<in> const_type c; c \<noteq> FixConst; ax = Mk2Act x31 x32;
                is_value v; app_con s1 c v (Mk2Act x31 x32) (s2, e2)\<rbrakk>
               \<Longrightarrow> \<exists>g_ax. well_typed (red_env env g_ax) (red_delta delta g_ax) (exp_red_use_env r_s1 g_ax) e2 t2 (end_red_use_env r_s3 g_ax) (end_red_use_env rx g_ax) \<and>
                          well_typed_state s2 (red_env env g_ax) (red_delta delta g_ax) \<and>
                          sub_use_env s2 (exp_red_use_env r_f g_ax) \<and>
                          safe_act s1 (infl_use_env r_f r_s3) g_ax \<and> corr_act (Mk2Act x31 x32) g_ax"
  apply (case_tac c)
              apply (auto)
  apply (cut_tac eq_own)
  apply (auto)
  apply (rule_tac x="Add2ResAct x31 x32 tau" in exI)
  apply (auto)
       apply (cut_tac env="add_env (add_env env (Loc x31) (ChanTy tau SEnd)) (Loc x32) (ChanTy tau REnd)" and delta="add_delta (add_delta delta x31 x31) x32 x32" and
        ?r_s1.0="add_use_env (add_use_env r_s1 (Loc x31) OwnPerm) (Loc x32) OwnPerm" and
        ?r_s2.0="r_s3" and ?v1.0="VarExp (LocType x31)" and ?v2.0="VarExp (LocType x32)" and ?t1.0="ChanTy tau SEnd" and ?t2.0="ChanTy tau REnd"
        and ?x1.0="Loc x31" and ?x2.0="Loc x32" in saccmk2_pair_type)
                apply (rule_tac saccmk2_var_type)
                 apply (simp add: add_env_def)
                apply (simp add: add_delta_def)
               apply (rule_tac saccmk2_var_type)
                apply (simp add: add_env_def)
               apply (simp add: add_delta_def)
              apply (auto)
           apply (simp add: add_use_env_def)
          apply (simp add: add_use_env_def)
         apply (rule_tac r_s="r_f" in leq_use_none)
          apply (rule_tac r_sb="r_s1" in trans_leq_use_env)
           apply (simp)
          apply (rule_tac r_sb="diff_use_env r_s2 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
           apply (rule_tac diff_leq_use_env)
           apply (simp_all)
         apply (simp add: fresh_var_def)
         apply (simp add: sub_use_env_def)
         apply (auto)
        apply (rule_tac r_s="r_f" in leq_use_none)
         apply (rule_tac r_sb="r_s1" in trans_leq_use_env)
          apply (simp)
         apply (rule_tac r_sb="diff_use_env r_s2 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
          apply (rule_tac diff_leq_use_env)
          apply (simp_all)
        apply (simp add: fresh_var_def)
        apply (simp add: sub_use_env_def)
        apply (auto)
       apply (rule_tac rhs_add_leq_use_env)
        apply (rule_tac rhs_add_leq_use_env)
         apply (rule_tac r_sb="diff_use_env r_s2 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
          apply (rule_tac diff_leq_use_env)
          apply (simp_all)
      apply (rule_tac x="ChanTy tau REnd" in exI)
      apply (rule_tac x="ra" in exI)
      apply (auto)
       apply (simp add: pure_fun_def)
       apply (simp add: is_own_def)
      apply (rule_tac x="r_s2a" in exI)
      apply (rule_tac x="r_s3a" in exI)
      apply (rule_tac x="rx1a" in exI)
      apply (auto)
      apply (rule_tac x="rx2a" in exI)
      apply (auto)
      apply (rule_tac x="r_exb" in exI)
      apply (auto)
      apply (simp add: pure_fun_def)
      apply (simp add: is_own_def)
    (* proving the state remains well-typed: environment containment *)
     apply (simp add: well_typed_state_def)
     apply (auto)
       apply (rule_tac dist_add_sub_env)
       apply (rule_tac dist_add_sub_env)
       apply (simp)
    (* res_map validity: completeness *)(*
      apply (simp add: valid_nres_map_def)
      apply (auto)
        apply (rule_tac add_full_nres_map)
        apply (rule_tac add_full_nres_map)
        apply (simp)
    (* - disjointness *)
       apply (rule_tac disj_add_nres_map)
        apply (rule_tac disj_add_nres_map)
         apply (simp)
        apply (simp add: sep_nres_map_def)
        apply (simp add: empty_strong_disj_use_env1)
       apply (simp add: sep_nres_map_def)
       apply (simp add: empty_strong_disj_use_env1)
    (* - element containment *)
      apply (rule_tac dist_add_sub_nres_map)
       apply (rule_tac dist_add_sub_nres_map)
        apply (simp)
        apply (rule_tac empty_sub_use_env)
       apply (rule_tac empty_sub_use_env)*)
    (* proving delta remains proper *)
      apply (rule_tac add_proper_delta)
        apply (rule_tac add_proper_delta)
          apply (auto)(*
       apply (simp add: valid_nres_map_def)
       apply (auto)
         apply (rule_tac add_full_nres_map)
         apply (simp)
        apply (rule_tac disj_add_nres_map)
         apply (simp)
        apply (simp add: sep_nres_map_def)
        apply (simp add: empty_strong_disj_use_env1)
       apply (rule_tac dist_add_sub_nres_map)
        apply (simp)
       apply (rule_tac empty_sub_use_env)*)
      apply (simp add: add_env_def)
      apply (simp add: fresh_var_def)
    (* proving that the memory is still well-typed. starting with x = x31 / x = x32 *)
     apply (case_tac "x = x31")
      apply (simp add: add_env_def)
     apply (case_tac "x = x32")
      apply (simp add: add_env_def)
    (* - otherwise compare with the originals *)
     apply (simp add: add_env_def)
     apply (erule_tac x="x" in allE)
     apply (case_tac "s1 x")
      apply (auto)
     apply (simp add: add_env_def)
     apply (case_tac "env (Loc x)")
      apply (auto)
     apply (case_tac "add_delta (add_delta delta x31 x31) x32 x32 x \<noteq> delta x")
      apply (simp add: add_delta_def)
     apply (rule_tac well_typed_mv_add_vars)
      apply (rule_tac well_typed_mv_add_vars)
       apply (rule_tac well_typed_mv_add_delta)
        apply (rule_tac well_typed_mv_add_delta)
         apply (auto)
(*
         apply (simp add: nres_lookup_def)
         apply (simp add: add_env_def)*)
        apply (simp add: fresh_var_def)
        apply (simp add: sub_env_def)
        apply (auto)
       apply (simp add: fresh_var_def)
       apply (simp add: sub_env_def)
       apply (auto)
      apply (simp add: fresh_var_def)
      apply (simp add: sub_env_def)
      apply (auto)
     apply (simp add: add_env_def)
     apply (simp add: fresh_var_def)
     apply (simp add: sub_env_def)
     apply (auto)
    (* proving the new res_map is still valid: expression map containment *)(*
    apply (simp add: valid_exp_use_env_def)
    apply (auto)*)
    apply (rule_tac rhs_add_sub_use_env)
     apply (rule_tac rhs_add_sub_use_env)
      apply (rule_tac add_sub_use_env)
      apply (rule_tac add_sub_use_env)
      apply (simp)
     apply (simp add: add_env_def)
    apply (simp add: add_env_def)
   apply (simp add: fresh_var_def)
   apply (simp add: fresh_var_def)
  apply (simp add: corr_act_def)
  done

lemma max_aff_leq: "\<lbrakk> aff_leq a1 a3; aff_leq a2 a3 \<rbrakk> \<Longrightarrow> aff_leq (max_aff a1 a2) a3"
  apply (case_tac a1)
    apply (auto)
   apply (case_tac a2)
     apply (auto)
  apply (case_tac a2)
    apply (auto)
  done

lemma well_typed_new_list: "well_typed_list env delta empty_use_env (new_arr_value n) tau"
  apply (induct n)
   apply (auto)
  apply (rule_tac id_leq_use_env)
  done

    (* the idea is that if we added a permission, we required it to be a variable not already in the env, ie a variable free in e2.
      so then we can remove x by default. *)
    (* in general, this statement says that given a constant-application, the result can be typed with a certain env + perm set,
      so that the state remains well-typed relative to the env + global perm_map, and the env + perm set remains valid *)
lemma safe_app_con_case: "\<lbrakk> well_typed_state s1 env delta;
    app_red_exp ConstApp (s1, AppExp (ConstExp c) v) ax (s2, e2); sub_use_env s1 r_f;
    well_typed env delta r_s1 v t1 r_s2 rx2;
    leq_use_env r_s3 (diff_use_env r_s2 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex));
    leq_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_s2; leq_use_env r_ex r_s1; disj_use_env rx1 (lift_use_env rx2 r);
    leq_use_env rx r_s3; leq_use_env (app_req rx1 rx2 r t2 r_ex) rx; leq_use_env r_s1 r_f;
    FunTy t1 t2 r a \<in> const_type c; c \<noteq> FixConst\<rbrakk>
       \<Longrightarrow> \<exists>g_ax . well_typed (red_env env g_ax) (red_delta delta g_ax) (exp_red_use_env r_s1 g_ax) e2 t2 (end_red_use_env r_s3 g_ax) (end_red_use_env rx g_ax) \<and>
                  well_typed_state s2 (red_env env g_ax) (red_delta delta g_ax) \<and>
                  sub_use_env s2 (exp_red_use_env r_f g_ax) \<and> safe_act s1 (infl_use_env r_f r_s3) g_ax \<and> corr_act ax g_ax"
  apply (case_tac ax)
     apply (auto)
    (* no action cases *)
     apply (cut_tac ?r_s2.0="r_s2" and ?r_s1.0="r_s1" and env="env" in well_typed_perm_leq)
      apply (auto)
     apply (case_tac c)
                 apply (auto)
     apply (rule_tac sares_unpack_case)
                apply (auto)
     apply (simp add: upc_init_abbrev_def)
     apply (rule_tac x="r_s1" in exI)
     apply (auto)
      apply (rule_tac id_leq_use_env)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
      apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
       apply (simp)
      apply (rule_tac r_sb="comp_use_env rx1 (lift_use_env rx2 r)" in trans_leq_use_env)
       apply (simp)
      apply (rule_tac self_comp_leq_use_env1)
     apply (rule_tac x="rx2" in exI)
     apply (rule_tac x="r_s2" in exI)
     apply (auto)
     apply (rule_tac x="r_s2a" in exI)
     apply (rule_tac x="r_s3a" in exI)
     apply (rule_tac x="rx1a" in exI)
     apply (auto)
    (* new resource cases. in all cases t2 should be the correct type to add *)
    apply (rule_tac x="AddResAct x2 t2" in exI)
    apply (auto)
    (* - lemma for main well-typedness statement *)
        apply (rule_tac ?s2.0="s2" and ?rx1.0="rx1" in sacc_make_act_case)
                 apply (auto)
        apply (rule_tac r_sb="diff_use_env r_s2 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
         apply (rule_tac lhs_unroll_dcl_use_env)
         apply (rule_tac self_diff_leq_use_env)
        apply (simp)
    (* - well typed state. *)
       apply (case_tac "\<not> (\<exists> v. s2 = add_env s1 x2 v)")
        apply (case_tac c)
                    apply (auto)
       apply (rule_tac well_typed_state_add_vars)
           apply (auto)
          apply (case_tac c)
                      apply (auto)
    (* - wt mem val: array case *)
         apply (case_tac c)
                     apply (auto)
         apply (cut_tac s="s1" and x="x2" and v="va" and w="ArrValue (new_arr_value (nat i))" in add_env_force)
        apply (auto)
       apply (rule_tac x="tau" in exI)
       apply (simp add: pure_fun_def)
       apply (rule_tac well_typed_new_list)
(*
    (* - valid res list *)
         apply (rule_tac x="\<lambda> x. None" in exI)
          apply (simp add: valid_res_list_def)
    (* - properness *)
         apply (case_tac c)
                     apply (auto)
         apply (cut_tac s="s1" and x="x2" and v="va" and w="ArrValue []" in add_env_force)
          apply (simp)
         apply (auto)*)
    (* - x22 is contained in rs_map (true because x22 is the empty set)
        apply (simp add: sub_use_env_def)
        apply (simp add: empty_use_env_def)
    (* - map separation + strength *)
       apply (simp add: sep_nres_map_def)
       apply (auto)
       apply (rule_tac empty_strong_disj_use_env1) *)
    (* - valid use env. *)
      apply (case_tac "\<not> (\<exists> v. s2 = add_env s1 x2 v)")
       apply (case_tac c)
                   apply (auto)
      apply (rule_tac rhs_add_sub_use_env)
       apply (rule_tac add_sub_use_env)
       apply (simp)
      apply (simp add: add_env_def)
      apply (case_tac c)
                 apply (auto)
     apply (simp add: fresh_var_def)
  apply (simp add: corr_act_def)
    (* dual new resource case. (basically only channel creation) *)
   apply (rule_tac sacc_mk2_act_case)
                apply (auto)
    (* resource usage case. (currently empty) *)
  apply (case_tac c)
              apply (auto)
(*
   apply (case_tac c)
                apply (auto)
  apply (case_tac c)
               apply (auto)*)
  done

lemma well_typed_empty_state: "well_typed_state empty_env empty_env id"
  apply (simp add: well_typed_state_def)
  apply (auto)
    apply (simp add: sub_env_def)
    apply (simp add: empty_env_def)
   apply (simp add: proper_delta_def)
   apply (simp add: empty_env_def)
  apply (simp add: empty_env_def)
  done

fun state_vars where
  "state_vars s = { x | x. s x \<noteq> None }"

definition fv_restr_env where
  "fv_restr_env e s = (\<lambda> x. if x \<in> free_vars e then s x else None)"

lemma fv_restr_env_use: "\<lbrakk> x \<in> free_vars e \<rbrakk> \<Longrightarrow> fv_restr_env e s x = s x"
  apply (simp add: fv_restr_env_def)
  done

lemma dist_rem_contain_env: "\<lbrakk> contain_env s s' \<rbrakk> \<Longrightarrow> contain_env (rem_env s x) (rem_env s' x)"
  apply (simp add: contain_env_def)
  apply (simp add: rem_env_def)
  apply (auto)
  apply (erule_tac x="xa" in allE)
  apply (case_tac "s' xa")
   apply (auto)
  apply (simp add: rem_env_def)
  done

lemma fv_contain_env: "\<lbrakk> free_vars e' \<subseteq> free_vars e \<rbrakk> \<Longrightarrow> contain_env (fv_restr_env e s) (fv_restr_env e' s)"
  apply (simp add: contain_env_def)
  apply (simp add: fv_restr_env_def)
  apply (auto)
  apply (case_tac "s x")
   apply (auto)
  apply (simp add: fv_restr_env_def)
  apply (auto)
  done

lemma rem_fv_contain_env: "\<lbrakk> free_vars e' - {x} \<subseteq> free_vars e \<rbrakk> \<Longrightarrow> contain_env (fv_restr_env e (rem_env s x)) (fv_restr_env e' (rem_env s x))"
  apply (simp add: contain_env_def)
  apply (simp add: fv_restr_env_def)
  apply (auto)
  apply (simp add: rem_env_def)
  apply (auto)
  apply (case_tac "s xa")
   apply (auto)
  apply (simp add: fv_restr_env_def)
  apply (simp add: rem_env_def)
  apply (auto)
  done

lemma rem_fv_restr_env: "rem_env (fv_restr_env e s) x = fv_restr_env e (rem_env s x)"
  apply (case_tac "\<not> (\<forall> y. rem_env (fv_restr_env e s) x y = fv_restr_env e (rem_env s x) y)")
   apply (auto)
  apply (simp add: rem_env_def)
  apply (simp add: fv_restr_env_def)
  apply (case_tac "x = y")
   apply (auto)
   apply (case_tac "x \<in> free_vars e")
    apply (auto)
  apply (simp add: fv_restr_env_def)
  apply (case_tac "y \<in> free_vars e")
   apply (auto)
  done

    (* the question is, how do we allow for replicable pairs while enforcing full resource disjointness?
        i guess the "natural" way to do it based on what we already have is to simply allow pairs that contain
        values that are not unique to also be values.

        - if x is in the end perms, x is in the reqs. if r is own, (lift rx r) subtracts it out.
        - if r is not own, it means that e is replicable, in which case it is again not a var,
        - x is not in the end perms, which is trivial

        an even cleaner solution is to make a "replicable" pair value and type accordingly.
        in this case e is still a var, however at the level of reduction semantics, we can keep
        the var out of the name set.
     *)

end


theory ProcHoleVars
  imports RedSafeHoleLemma
begin

fun hole_free_vars :: "p_hole \<Rightarrow> string set" where
  "hole_free_vars ExpHole = {}"
| "hole_free_vars (AppHole1 h e) = (hole_free_vars h \<union> free_vars e)"
| "hole_free_vars (AppHole2 v h) = (free_vars v \<union> hole_free_vars h)"
| "hole_free_vars (IfHole h e1 e2) = (hole_free_vars h \<union> free_vars e1 \<union> free_vars e2)"
| "hole_free_vars (PairHole1 h e) = (hole_free_vars h \<union> free_vars e)"
| "hole_free_vars (PairHole2 e h) = (free_vars e \<union> hole_free_vars h)"
(*| "hole_free_vars (UnpackHole e h) = (free_vars e \<union> hole_free_vars h)"    *)

fun hole_res_vars :: "p_hole \<Rightarrow> res_id set" where
  "hole_res_vars ExpHole = {}"
| "hole_res_vars (AppHole1 h e) = (hole_res_vars h \<union> res_vars e)"
| "hole_res_vars (AppHole2 v h) = (res_vars v \<union> hole_res_vars h)"
| "hole_res_vars (IfHole h e1 e2) = (hole_res_vars h \<union> res_vars e1 \<union> res_vars e2)"
| "hole_res_vars (PairHole1 h e) = (hole_res_vars h \<union> res_vars e)"
| "hole_res_vars (PairHole2 e h) = (res_vars e \<union> hole_res_vars h)"

lemma app_hole_free_vars: "\<lbrakk> x \<in> free_vars e \<rbrakk> \<Longrightarrow> x \<in> free_vars (app_hole h e)"
  apply (induct h)
    apply (auto)
  done

lemma app_hole_free_vars2: "\<lbrakk> x \<in> hole_free_vars h \<rbrakk> \<Longrightarrow> x \<in> free_vars (app_hole h e)"
  apply (induct h)
    apply (auto)
  done

lemma app_hole_free_vars_rev: "\<lbrakk> x \<in> free_vars (app_hole h e) \<rbrakk> \<Longrightarrow> x \<in> hole_free_vars h \<or> x \<in> free_vars e"
  apply (induct h)
    apply (auto)
  done

lemma app_hole_res_vars: "\<lbrakk> x \<in> res_vars e \<rbrakk> \<Longrightarrow> x \<in> res_vars (app_hole h e)"
  apply (induct h)
    apply (auto)
  done

lemma app_hole_res_vars2: "\<lbrakk> x \<in> hole_res_vars h \<rbrakk> \<Longrightarrow> x \<in> res_vars (app_hole h e)"
  apply (induct h)
    apply (auto)
  done

lemma app_hole_res_vars_rev: "\<lbrakk> x \<in> res_vars (app_hole h e) \<rbrakk> \<Longrightarrow> x \<in> hole_res_vars h \<or> x \<in> res_vars e"
  apply (induct h)
    apply (auto)
  done

    (* ##### states that if x is a non-prim var in 'e', it will not be a free var in 'h' if 'h (fork e)' is well-typed.  ##### *)

fun strong_fun_ty where
  "strong_fun_ty (FunTy t1 t2 r a) = (r = OwnPerm)"
| "strong_fun_ty tau = False"

fun strong_fun_ty2 where
  "strong_fun_ty2 (FunTy t1 (FunTy t2 t3 r a) rx ax) = (r = OwnPerm)"
| "strong_fun_ty2 tau = False"

fun strong_fun where
  "strong_fun (ConstExp c) = (\<forall> tau. tau \<in> const_type c \<longrightarrow> strong_fun_ty tau)"
| "strong_fun (AppExp (ConstExp c) v) = (\<forall> tau. tau \<in> const_type c \<longrightarrow> strong_fun_ty2 tau)"
| "strong_fun e = False"

lemma strong_fun_own: "\<lbrakk>  well_typed env r_s1 f (FunTy t1 t2 r a) r_s2 rx; strong_fun f \<rbrakk> \<Longrightarrow> is_own r"
  apply (case_tac f)
        apply (auto)
   apply (simp add: is_own_def)
   apply (auto)
  apply (simp add: is_own_def)
  apply (case_tac x71)
        apply (auto)
  done

lemma safe_hole_npv_use_ih: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp f e)) tau r_s2 rx;
  is_value f; strong_fun f; is_value e; x \<in> non_prim_vars env e \<rbrakk> \<Longrightarrow> r_s2 x = NoPerm"
  apply (induct h arbitrary: env r_s1 r_s2 tau rx)
       apply (auto)
    (* base case. x is subtracted out in the lifting of the inflected rx2 *)
       apply (cut_tac env="env" and ?r_s1.0="r_s2a" and e="e" and tau="t1" and ?r_s2.0="r_s3" and rx="rx2" in infl_sexp_wp)
         apply (auto)
        apply (rule_tac value_is_sexp)
        apply (simp)
    (* - r_s3 x has a value since otherwise it would be trivial *)
       apply (case_tac "r_s3 x = NoPerm")
        apply (rule_tac r_s="r_s3" in leq_use_none)
         apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
          apply (rule_tac self_diff_leq_use_env)
         apply (auto)
    (* - we know that rx2 has a value, because otherwise rx2 + [r_s2a - r_s3] would not have a value, altho it is the start perms of e *)
       apply (case_tac "rx2 x = NoPerm")
        apply (cut_tac r_sa="rx2" and r_sb="infl_use_env r_s2a r_s3" and x="x" in comp_use_none)
          apply (simp)
         apply (simp add: infl_use_env_def)
        apply (cut_tac env="env" and ?r_s1.0="comp_use_env rx2 (infl_use_env r_s2a r_s3)" and x="x" in well_typed_no_npv_use)
          apply (auto)
    (* - by construction of strong functions, we also know that r = OwnPerm *)
       apply (cut_tac f="f" and r="r" in strong_fun_own)
         apply (auto)
    (* - from here we can deduce EX x = Own *)
        apply (rule_tac r_s="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in leq_use_none)
         apply (auto)
        apply (rule_tac diff_use_none_ex)
        apply (rule_tac r_x="lift_use_env rx2 r" in leq_use_own)
         apply (simp add: is_own_def)
        apply (rule_tac comp_leq_use_env1)
        apply (rule_tac self_comp_leq_use_env2)
    (* lhs induct. *)
      apply (rule_tac r_s="r_s2a" in leq_use_none)
       apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
        apply (rule_tac diff_leq_use_env)
        apply (rule_tac well_typed_perm_leq)
        apply (auto)
    (* rhs induct. *)
     apply (rule_tac r_s="r_s3" in leq_use_none)
      apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex)" in trans_leq_use_env)
       apply (rule_tac self_diff_leq_use_env)
      apply (auto)
    (* if case. *)
    apply (rule_tac r_s="r_s2a" in leq_use_none)
     apply (rule_tac well_typed_perm_leq)
     apply (auto)
    (* pair case 1. *)
   apply (rule_tac r_s="r_s2a" in leq_use_none)
    apply (rule_tac r_sb="diff_use_env r_s3 r_ex" in trans_leq_use_env)
     apply (rule_tac diff_leq_use_env)
     apply (rule_tac well_typed_perm_leq)
     apply (auto)
    (* pair case 2. *)
  apply (rule_tac r_s="r_s3" in leq_use_none)
   apply (rule_tac r_sb="diff_use_env r_s3 r_ex" in trans_leq_use_env)
    apply (rule_tac self_diff_leq_use_env)
   apply (auto)
  done

lemma safe_hole_npv_use_st: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp f e)) tau r_s2 rx; is_value f; strong_fun f;
 wf_hole h; is_value e \<rbrakk> \<Longrightarrow> x \<notin> non_prim_vars env e \<or> x \<notin> hole_res_vars h"
  apply (induct h arbitrary: env r_s1 tau r_s2 rx)
       apply (auto)
    (* lhs induct. since r_s2a x = None, it cannot be in e2 *)
       apply (cut_tac h="h" and e="e" and ?r_s2.0="r_s2a" and x="x" in safe_hole_npv_use_ih)
            apply (auto)
       apply (cut_tac ?r_s1.0="r_s2a" and e="x2" and x="x" in well_typed_no_npv_use)
         apply (auto)
       apply (simp add: non_prim_vars_def)
    (* rhs induct. r_s2a x has a value. since x is in e2. *)
      apply (case_tac "r_s2a x = NoPerm")
       apply (cut_tac ?r_s1.0="r_s2a" and x="x" and e="app_hole h (AppExp f e)" in well_typed_no_npv_use)
         apply (auto)
       apply (cut_tac h="h" and e="AppExp f e" and x="x" in app_hole_res_vars)
        apply (simp add: non_prim_vars_def)
       apply (simp add: non_prim_vars_def)
    (* - by lemma, rx1 x has a value as well. *)
      apply (cut_tac env="env" and e="x1" and tau="FunTy t1 tau r a" and ?r_s2.0="r_s2a" and rx="rx1" in wt_sexp_req_use)
          apply (auto)
        apply (rule_tac value_is_sexp)
        apply (auto)
       apply (simp add: non_prim_vars_def)
    (* - this is a contradiction, since r_s3 x = None, and rx1 is contained by it *)
      apply (cut_tac r_x="rx1" and r_s="r_s3" and x="x" in leq_use_none)
        apply (rule_tac r_sb="comp_use_env rx1 (lift_use_env rx2 r)" in trans_leq_use_env)
         apply (simp)
        apply (rule_tac self_comp_leq_use_env1)
       apply (rule_tac safe_hole_npv_use_ih)
           apply (auto)
    (* lhs if case. since r_s2a x = None, it cannot be in e2 *)
     apply (cut_tac h="h" and e="e" and ?r_s2.0="r_s2a" and x="x" in safe_hole_npv_use_ih)
          apply (auto)
     apply (cut_tac ?r_s1.0="r_s2a" and e="x2" and x="x" in well_typed_no_npv_use)
       apply (auto)
     apply (simp add: non_prim_vars_def)
    (* rhs if case. since r_s2a x = None, it cannot be in e2 *)
    apply (cut_tac h="h" and e="e" and ?r_s2.0="r_s2a" and x="x" in safe_hole_npv_use_ih)
         apply (auto)
    apply (cut_tac ?r_s1.0="r_s2a" and e="x3" and x="x" in well_typed_no_npv_use)
      apply (auto)
    apply (simp add: non_prim_vars_def)
    (* lhs pair case. same for lhs induct *)
   apply (cut_tac h="h" and e="e" and ?r_s2.0="r_s2a" and x="x" in safe_hole_npv_use_ih)
        apply (auto)
   apply (cut_tac ?r_s1.0="r_s2a" and e="x2" and x="x" in well_typed_no_npv_use)
     apply (auto)
   apply (simp add: non_prim_vars_def)
    (* rhs pair case. same for rhs induct *)
    (* - r_s2a x has a value. since x is in e2 *)
  apply (case_tac "r_s2a x = NoPerm")
   apply (cut_tac ?r_s1.0="r_s2a" and x="x" and e="app_hole h (AppExp f e)" in well_typed_no_npv_use)
     apply (auto)
   apply (cut_tac h="h" and e="AppExp f e" and x="x" in app_hole_res_vars)
    apply (auto)
    apply (simp add: non_prim_vars_def)
   apply (simp add: non_prim_vars_def)
    (* - then rx1 x has a value *)
  apply (cut_tac env="env" and ?r_s1.0="r_s1" and e="x1" and tau="t1" and ?r_s2.0="r_s2a" and rx="rx1" in wt_sexp_req_use)
      apply (auto)
    apply (rule_tac value_is_sexp)
    apply (auto)
   apply (simp add: non_prim_vars_def)
    (* - this is a contradiction, since r_s3 x = None, and rx1 is contained by it *)
  apply (cut_tac r_x="rx1" and r_s="r_s3" and x="x" in leq_use_none)
    apply (rule_tac r_sb="lift_use_env rx1 r" in trans_leq_use_env)
     apply (simp)
    apply (rule_tac self_lift_leq_use_env)
   apply (rule_tac safe_hole_npv_use_ih)
       apply (auto)
  done

lemma safe_fork_hole_npv_use: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp (ConstExp ForkConst) e)) tau r_s2 rx;
 wf_hole h; is_value e; x \<in> non_prim_vars env e \<rbrakk> \<Longrightarrow> x \<notin> hole_res_vars h"
  apply (cut_tac env="env" and ?r_s1.0="r_s1" and h="h" and e="e" and f="ConstExp ForkConst" and x="x" in safe_hole_npv_use_st)
       apply (auto)
  apply (simp add: is_own_def)
  done

lemma safe_send_hole_npv_use: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp (AppExp (ConstExp SendConst) v) e)) tau r_s2 rx;
 wf_hole h; is_value v; is_value e; x \<in> non_prim_vars env e \<rbrakk> \<Longrightarrow> x \<notin> hole_res_vars h"
  apply (cut_tac env="env" and ?r_s1.0="r_s1" and h="h" and e="e" and f="AppExp (ConstExp SendConst) v" and x="x" in safe_hole_npv_use_st)
       apply (auto)
  apply (simp add: pure_fun_def)
  apply (simp add: is_own_def)
  done

end


section\<open>From $M$ to $\calV$\<close>

theory Absolute_Versions
  imports
    CH
    ZF.Cardinal_AC
begin

hide_const (open) Order.pred

subsection\<open>Locales of a class \<^term>\<open>M\<close> hold in \<^term>\<open>\<V>\<close>\<close>

interpretation V: M_trivial \<V>
  using Union_ax_absolute upair_ax_absolute
  by unfold_locales auto

lemmas bad_simps = V.nonempty V.Forall_in_M_iff V.Inl_in_M_iff V.Inr_in_M_iff
  V.succ_in_M_iff V.singleton_in_M_iff V.Equal_in_M_iff V.Member_in_M_iff V.Nand_in_M_iff
  V.Cons_in_M_iff V.pair_in_M_iff V.upair_in_M_iff

lemmas bad_M_trivial_simps[simp del] = V.Forall_in_M_iff V.Equal_in_M_iff
  V.nonempty

lemmas bad_M_trivial_rules[rule del] =  V.pair_in_MI V.singleton_in_MI V.pair_in_MD V.nat_into_M
  V.depth_closed V.length_closed V.nat_case_closed V.separation_closed
  V.Un_closed V.strong_replacement_closed V.nonempty

interpretation V:M_basic \<V>
  using power_ax_absolute separation_absolute replacement_absolute
  by unfold_locales auto

interpretation V:M_eclose \<V>
  by unfold_locales (auto intro:separation_absolute replacement_absolute
      simp:iterates_replacement_def wfrec_replacement_def)

lemmas bad_M_basic_rules[simp del, rule del] =
  V.cartprod_closed V.finite_funspace_closed V.converse_closed
  V.list_case'_closed V.pred_closed

interpretation V:M_cardinal_arith \<V>
  by unfold_locales (auto intro:separation_absolute replacement_absolute
      simp add:iterates_replacement_def wfrec_replacement_def lam_replacement_def)

lemmas bad_M_cardinals_rules[simp del, rule del] =
  V.iterates_closed V.M_nat V.trancl_closed V.rvimage_closed

interpretation V:M_cardinal_arith_jump \<V>
  by unfold_locales (auto intro:separation_absolute replacement_absolute
      simp:wfrec_replacement_def)

lemma choice_ax_Universe: "choice_ax(\<V>)"
proof -
  {
    fix x
    obtain f where "f \<in> surj(|x|,x)"
      using cardinal_eqpoll unfolding eqpoll_def bij_def by fast
    moreover
    have "Ord(|x|)" by simp
    ultimately
    have "\<exists>a. Ord(a) \<and> (\<exists>f. f \<in> surj(a,x))"
      by fast
  }
  then
  show ?thesis  unfolding choice_ax_def rall_def rex_def
    by simp
qed

interpretation V:M_master \<V>
  using choice_ax_Universe
  by unfold_locales (auto intro:separation_absolute replacement_absolute
      simp:lam_replacement_def transrec_replacement_def wfrec_replacement_def
      is_wfrec_def M_is_recfun_def)

named_theorems V_simps

\<comment> \<open>To work systematically, ASCII versions of "\_absolute" theorems as
    those below are preferable.\<close>
lemma eqpoll_rel_absolute[V_simps]: "x \<approx>\<^bsup>\<V>\<^esup> y \<longleftrightarrow> x \<approx> y"
  unfolding eqpoll_def using V.def_eqpoll_rel by auto

lemma cardinal_rel_absolute[V_simps]: "|x|\<^bsup>\<V>\<^esup> = |x|"
  unfolding cardinal_def cardinal_rel_def by (simp add:V_simps)

lemma Card_rel_absolute[V_simps]:"Card\<^bsup>\<V>\<^esup>(a) \<longleftrightarrow> Card(a)"
  unfolding Card_rel_def Card_def by (simp only:V_simps)

lemma csucc_rel_absolute[V_simps]:"(a\<^sup>+)\<^bsup>\<V>\<^esup> = a\<^sup>+"
  unfolding csucc_rel_def csucc_def by (simp add:V_simps)

lemma function_space_rel_absolute[V_simps]:"x \<rightarrow>\<^bsup>\<V>\<^esup> y = x \<rightarrow> y"
  using V.function_space_rel_char by (simp add:V_simps)

lemma cexp_rel_absolute[V_simps]:"x\<^bsup>\<up>y,\<V>\<^esup> = x\<^bsup>\<up>y\<^esup>"
  unfolding cexp_rel_def cexp_def by (simp only:V_simps)

lemma HAleph_rel_absolute[V_simps]:"HAleph_rel(\<V>,a,b) = HAleph(a,b)"
  unfolding HAleph_rel_def HAleph_def by (auto simp add:V_simps)

lemma Aleph_rel_absolute[V_simps]: "Ord(x) \<Longrightarrow> \<aleph>\<^bsub>x\<^esub>\<^bsup>\<V>\<^esup> = \<aleph>\<^bsub>x\<^esub>"
proof -
  assume "Ord(x)"
  have "\<aleph>\<^bsub>x\<^esub>\<^bsup>\<V>\<^esup> = transrec(x, \<lambda>a b. HAleph_rel(\<V>,a,b))"
    unfolding Aleph_rel_def by simp
  also
  have "\<dots> = transrec(x, HAleph)"
    by (simp only:V_simps)
  also from \<open>Ord(x)\<close>
  have "\<dots> = \<aleph>\<^bsub>x\<^esub>"
    using Aleph'_eq_Aleph unfolding Aleph'_def by simp
  finally
  show ?thesis .
qed

text\<open>Example of absolute lemmas obtained from the relative versions.
    Note the \<^emph>\<open>only\<close> declarations\<close>
lemma Ord_cardinal_idem': "Ord(A) \<Longrightarrow> ||A|| = |A|"
  using V.Ord_cardinal_rel_idem by (simp only:V_simps)

lemma Aleph_succ': "Ord(\<alpha>) \<Longrightarrow> \<aleph>\<^bsub>succ(\<alpha>)\<^esub> = \<aleph>\<^bsub>\<alpha>\<^esub>\<^sup>+"
  using V.Aleph_rel_succ by (simp only:V_simps)

text\<open>These two results are new, first obtained in relative form
    (not ported).\<close>
lemma csucc_cardinal:
  assumes "Ord(\<kappa>)" shows "|\<kappa>|\<^sup>+ = \<kappa>\<^sup>+"
  using assms V.csucc_rel_cardinal_rel by (simp only:V_simps)

lemma csucc_le_mono:
  assumes "\<kappa> \<le> \<nu>"  shows "\<kappa>\<^sup>+ \<le> \<nu>\<^sup>+"
  using assms V.csucc_rel_le_mono by (simp only:V_simps)

text\<open>Example of transferring results from a transitive model to \<^term>\<open>\<V>\<close>\<close>
lemma (in M_Perm) eqpoll_rel_transfer_absolute:
  assumes "M(A)" "M(B)" "A \<approx>\<^bsup>M\<^esup> B"
  shows "A \<approx> B"
proof -
  interpret M_N_Perm M \<V>
    by (unfold_locales, simp only:V_simps)
  from assms
  show ?thesis using eqpoll_rel_transfer
    by (simp only:V_simps)
qed

text\<open>The “relationalized” $\CH$ with respect to \<^term>\<open>\<V>\<close> corresponds
    to the real $\CH$.\<close>
lemma is_ContHyp_iff_CH: "is_ContHyp(\<V>) \<longleftrightarrow> ContHyp"
  using V.is_ContHyp_iff
  by (auto simp add:ContHyp_rel_def ContHyp_def V_simps)

end


theory TLB
imports
  "HOL-Word.Word"
  PTABLE_TLBJ.PageTable_seL4
  L3_LIBJ.L3_Lib
begin

record tlb_flags =
  nG       :: "1 word"  (* nG = 0 means global *)
  perm_APX :: "1 word"  (* Access permission bit 2 *)
  perm_AP  :: "2 word"  (* Access permission bits 1 and 0 *)
  perm_XN  :: "1 word"  (* Execute-never bit *)

type_synonym asid = "8 word"

datatype tlb_entry  = EntrySmall   (asid_of :"asid option") "20 word" "20 word"  tlb_flags
                    | EntrySection (asid_of :"asid option") "12 word" "12 word"  tlb_flags

type_synonym tlb = "tlb_entry set"

(* polymorphic lookup type   *)

datatype 'e lookup_type  =  Miss  | Incon  |  Hit 'e

instantiation lookup_type :: (_) order
begin
  definition
    less_eq_lookup_type: "e \<le> e' \<equiv> e' = Incon \<or> e' = e \<or> e = Miss"

  definition
    less_lookup_type: "e < (e'::'a lookup_type) \<equiv> e \<le> e' \<and> e \<noteq> e'"

  instance
     by intro_classes (auto simp add: less_lookup_type less_eq_lookup_type)
end

class entry_op =
  fixes range_of  ::  "'a \<Rightarrow> vaddr set"

begin

definition
  entry_set :: "'a set \<Rightarrow> vaddr \<Rightarrow> 'a set"
where
  "entry_set t v \<equiv> {e\<in>t. v : range_of e}"

end

definition
  lookup :: "(vaddr \<Rightarrow> 'a set ) \<Rightarrow> vaddr \<Rightarrow> 'a lookup_type"
where
   "lookup t v \<equiv> if t v = {} then Miss
                       else if \<exists>x. t v = {x} then Hit (the_elem (t v))
                       else Incon"

(* access a lookup as
   "lookup' t v \<equiv> lookup (entry_set t) v"
*)

(* Address translation  *)

fun
  va_to_pa :: "vaddr \<Rightarrow> tlb_entry \<Rightarrow> paddr"
where
  "va_to_pa va (EntrySmall a vba pba fl)   = Addr ((ucast pba << 12) OR (addr_val va AND mask 12))"
| "va_to_pa va (EntrySection a vba pba fl) = Addr ((ucast pba << 20) OR (addr_val va AND mask 20))"

instantiation tlb_entry ::  entry_op
begin
definition
  "range_of (e :: tlb_entry) \<equiv>
                     case e of EntrySmall a vba pba fl   \<Rightarrow> Addr ` {(ucast vba) << 12 ..
                                                                    ((ucast vba) << 12) + (2^12 - 1)}
                             | EntrySection a vba pba fl \<Rightarrow>  Addr ` {(ucast vba) << 20 ..
                                                                      ((ucast vba) << 20) + (2^20 - 1)}"

instance ..
end

(* page table walk interface *)

definition
  to_tlb_flags :: "arm_perm_bits \<Rightarrow> tlb_flags"
where
  "to_tlb_flags perms \<equiv> \<lparr>nG = arm_p_nG perms, perm_APX = arm_p_APX perms,  perm_AP = arm_p_AP perms, perm_XN = arm_p_XN perms \<rparr>"

definition "tag_conv (a::8 word) fl \<equiv> (if  nG fl = 0 then None else Some a)"

definition
  pt_walk :: "asid \<Rightarrow> heap \<Rightarrow> paddr \<Rightarrow> vaddr \<Rightarrow>  tlb_entry option"
where
  "pt_walk a hp rt v \<equiv>
      case get_pde hp rt v
       of None                 \<Rightarrow> None
       | Some InvalidPDE       \<Rightarrow> None
       | Some ReservedPDE      \<Rightarrow> None
       | Some (SectionPDE bpa perms) \<Rightarrow> Some (EntrySection (tag_conv a (to_tlb_flags perms))  (ucast (addr_val v >> 20) :: 12 word)
                                      ((word_extract 31 20 (addr_val bpa)):: 12 word)
                                       (to_tlb_flags perms))
       | Some (PageTablePDE p) \<Rightarrow>
               (case get_pte hp p v
                 of None                     \<Rightarrow> None
                 |  Some InvalidPTE          \<Rightarrow> None
                 |  Some (SmallPagePTE bpa perms) \<Rightarrow> Some(EntrySmall (tag_conv a (to_tlb_flags perms)) (ucast (addr_val v >> 12) :: 20 word)
                                                     ((word_extract 31 12 (addr_val bpa)):: 20 word)
                                                     (to_tlb_flags perms)))"

definition
  "is_fault e \<equiv> (e = None)"

(* Flush operations *)

datatype flush_type = FlushTLB
                    | Flushvarange "vaddr set"
                    | FlushASID asid
                    | FlushASIDvarange  asid "vaddr set"

definition
  flush_tlb :: "tlb  \<Rightarrow> tlb"
where
  "flush_tlb t  \<equiv> {}"

definition
  flush_tlb_vset :: "tlb \<Rightarrow> vaddr set \<Rightarrow> tlb"
where
  "flush_tlb_vset t vset =  t - (\<Union>v\<in>vset. {e \<in> t. v \<in> range_of e})"

(* consistency polymorphic defs *)

definition
  consistent0 :: "(vaddr \<Rightarrow> 'b lookup_type) \<Rightarrow> (vaddr \<Rightarrow> 'b option) \<Rightarrow> vaddr \<Rightarrow> bool"
where
  "consistent0  lukup ptwalk  va \<equiv>
            (lukup va = Hit (the (ptwalk va)) \<and> \<not>is_fault (ptwalk va)) \<or>  lukup va = Miss"

lemma consistent_not_Incon_imp:
  "consistent0  lukup ptwalk va \<Longrightarrow>
     lukup va \<noteq> Incon \<and> (\<forall>e. lukup va = Hit e \<longrightarrow> e = the (ptwalk va) \<and> ptwalk va \<noteq> None)"
  apply (clarsimp simp: consistent0_def is_fault_def)
  by force

lemma consistent_not_Incon':
  "consistent0  lukup ptwalk va =
  (lukup va \<noteq> Incon \<and> (\<forall>e. lukup va = Hit e \<longrightarrow> e = the (ptwalk va) \<and> ptwalk va \<noteq> None))"
  by ((cases "lukup va"); simp add: consistent0_def is_fault_def)

end


(*
 * Copyright (c) 2020, CleanQ Project - Systems Group, ETH Zurich
 * All rights reserved.
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 *
 * See "LICENSE" for details.
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section \<open>CleanQ Abstract Concurrent Ring Buffer Model\<close>

text \<open>
  This model is the concurrent version of the ring buffer. The \verb+enqueue+ and \verb+deqeue+
  operations are executed in two steps and the frame condition needs to be relaxed in order
  to allow the "other" side to take concurrent actions.
\<close>

theory CleanQ_CRBModel_Simpl
(*<*)
  imports CleanQ_CRBModel
          "../Simpl/Vcg"
(*>*)
begin

(* ==================================================================================== *)
subsection \<open>CleanQ Abstract Concurrent Ring Buffer Model State\<close>
(* ==================================================================================== *)

text \<open>
  the model is exactly the same and we reuse the RB Model.
\<close>

(*<*)
(* Define some global variables to make Simpl/Complex proofs work *)
record 'g CleanQ_CRB_State_vars =
  RingCRB_'  :: "nat CleanQ_RB_State"
  b_' :: "nat"
(*>*)

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Hoare Triples for the Enqueue Operation\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
  We now show that the \verb+enqueue+ operation satisfies the pre and post conditions
  for the predicates P, Q and R.
\<close>

paragraph \<open>Writing the Head Element\<close>

text \<open>
  We show the Hoare triple with \verb+{P) write_head {Q}+.
\<close>

lemma  CleanQ_RB_write_head_x_hoare:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_x_P K \<acute>RingCRB b \<rbrace>
       \<acute>RingCRB :== (CleanQ_RB_write_head_x b \<acute>RingCRB)
    \<lbrace> CleanQ_RB_enq_x_Q K \<acute> RingCRB b \<rbrace>"
  by(vcg, auto)

lemma  CleanQ_RB_write_head_y_hoare:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_y_P K \<acute>RingCRB b \<rbrace>
       \<acute>RingCRB :== (CleanQ_RB_write_head_y b \<acute>RingCRB)
    \<lbrace> CleanQ_RB_enq_y_Q K \<acute> RingCRB b \<rbrace>"
  by(vcg, auto)

paragraph \<open>Incrementing the Head Pointer\<close>

text \<open>
  We show the Hoare triple with \verb+{Q) incr_head {R}+.
\<close>

lemma  CleanQ_RB_incr_head_x_hoare:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_x_Q K \<acute>RingCRB b \<rbrace>
       \<acute>RingCRB :== (CleanQ_RB_incr_head_x b \<acute>RingCRB)
    \<lbrace> CleanQ_RB_enq_x_R K \<acute> RingCRB b \<rbrace>"
  apply(vcg, auto simp:CleanQ_RB_enq_x_inv_all)
  by (simp add: CleanQ_RB_enq_x_result)

lemma  CleanQ_RB_incr_head_y_hoare:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_y_Q K \<acute>RingCRB b \<rbrace>
       \<acute>RingCRB :== (CleanQ_RB_incr_head_y b \<acute>RingCRB)
    \<lbrace> CleanQ_RB_enq_y_R K \<acute> RingCRB b \<rbrace>"
  apply(vcg, auto simp:CleanQ_RB_enq_y_inv_all)
  by (simp add: CleanQ_RB_enq_y_result)

paragraph \<open>Full Enqueue Operation\<close>

text \<open>
  We show the Hoare triple with \verb+{P) enq {R}+.
\<close>

lemma CleanQ_RB_enq_x_hoare :
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_x_P K \<acute>RingCRB b \<rbrace>
       \<acute>RingCRB :== (CleanQ_RB_write_head_x b \<acute>RingCRB) ;;
       \<acute>RingCRB :== (CleanQ_RB_incr_head_x b \<acute>RingCRB)
    \<lbrace> CleanQ_RB_enq_x_R K \<acute>RingCRB b \<rbrace>"
  apply(vcg, auto simp:CleanQ_RB_enq_x_inv_all)
  using CleanQ_RB_enq_x_result by fastforce

lemma CleanQ_RB_enq_y_hoare :
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_y_P K \<acute>RingCRB b \<rbrace>
       \<acute>RingCRB :== (CleanQ_RB_write_head_y b \<acute>RingCRB) ;;
       \<acute>RingCRB :== (CleanQ_RB_incr_head_y b \<acute>RingCRB)
    \<lbrace> CleanQ_RB_enq_y_R K \<acute>RingCRB b \<rbrace>"
  apply(vcg, auto simp:CleanQ_RB_enq_y_inv_all)
  using CleanQ_RB_enq_y_result by fastforce

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Hoare Triples for the Dequeue Operation\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
  We now show that the \verb+dequeue+ operation satisfies the pre and post conditions
  for the predicates P, Q and R.
\<close>

paragraph \<open>Reading the Tail Element\<close>

text \<open>
  We show the Hoare triple with \verb+{P) read_tail {Q}+.
\<close>

lemma  CleanQ_RB_read_tail_x_hoare:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_x_P K \<acute>RingCRB \<acute>b \<rbrace>
       \<acute>b :== (CleanQ_RB_read_tail_x \<acute>RingCRB)
    \<lbrace> CleanQ_RB_deq_x_Q K \<acute>RingCRB \<acute>b \<rbrace>"
  by(vcg)

lemma  CleanQ_RB_read_tail_y_hoare:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_y_P K \<acute>RingCRB \<acute>b \<rbrace>
       \<acute>b :== (CleanQ_RB_read_tail_y \<acute>RingCRB)
    \<lbrace> CleanQ_RB_deq_y_Q K \<acute>RingCRB \<acute>b \<rbrace>"
  by(vcg)

paragraph \<open>Incrementing the Tail Pointer\<close>

text \<open>
  We show the Hoare triple with \verb+{Q) incr_tail {R}+.
\<close>

lemma  CleanQ_RB_incr_tail_x_hoare:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_x_Q K \<acute>RingCRB b \<rbrace>
       \<acute>RingCRB :== (CleanQ_RB_incr_tail_x b \<acute>RingCRB)
    \<lbrace> CleanQ_RB_deq_x_R K \<acute> RingCRB b \<rbrace>"
  by(vcg, auto simp:CleanQ_RB_deq_x_all_inv)

lemma  CleanQ_RB_incr_tail_y_hoare:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_y_Q K \<acute>RingCRB b \<rbrace>
       \<acute>RingCRB :== (CleanQ_RB_incr_tail_y b \<acute>RingCRB)
    \<lbrace> CleanQ_RB_deq_y_R K \<acute> RingCRB b \<rbrace>"
  by(vcg, auto simp:CleanQ_RB_deq_y_all_inv)

paragraph \<open>Full Dequeue Operation\<close>

text \<open>
  We show the Hoare triple with \verb+{P) deq {R}+.
\<close>

lemma CleanQ_RB_deq_x_hoare :
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_x_P K \<acute>RingCRB \<acute>b \<rbrace>
       \<acute>b :== (CleanQ_RB_read_tail_x \<acute>RingCRB) ;;
       \<acute>RingCRB :== (CleanQ_RB_incr_tail_x \<acute>b \<acute>RingCRB)
    \<lbrace> CleanQ_RB_deq_x_R K \<acute>RingCRB \<acute>b \<rbrace>"
  by(vcg, auto simp:CleanQ_RB_deq_x_all_inv)

lemma CleanQ_RB_deq_y_hoare :
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_y_P K \<acute>RingCRB \<acute>b \<rbrace>
       \<acute>b :== (CleanQ_RB_read_tail_y \<acute>RingCRB) ;;
       \<acute>RingCRB :== (CleanQ_RB_incr_tail_y \<acute>b \<acute>RingCRB)
     \<lbrace> CleanQ_RB_deq_y_R K \<acute>RingCRB \<acute>b \<rbrace>"
  by(vcg, auto simp:CleanQ_RB_deq_y_all_inv)

(* ==================================================================================== *)
subsection \<open>Interference pairs\<close>
(* ==================================================================================== *)

text \<open>
  We are now showing the interference proofs for the different step. There are two threads
  in the system, each of which can execute the enqueue and dequeue operations independently.

  The system looks like this:

    \verb+ (enq_x | deq_x)  ||  (enq_y | deq_y)+

  While each of the four operations consists of two steps. reading/writing the buffer slot
  and updating the head/tail pointer respectively.

  We fix one side (X) and show that the other side cannot interfere with each of the
  possible interference pairs. The correctness of the other side follows by symmetry.
\<close>

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Enqueue X, Enqueue Y\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
  The Enqueue operation has the form: \verb+{P} write_head {Q} increment_head {R}+.
  We show, that the predicates of the Hoare triples remain valid, regardless of the
  operation of the other side.
\<close>

paragraph \<open>Y writes the descriptor ring\<close>

lemma CleanQ_CRB_Enqueue_X_P_write_head:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_x_P K \<acute>RingCRB bx \<rbrace>
      \<acute>RingCRB :== CleanQ_RB_write_head_y b \<acute>RingCRB
    \<lbrace> CleanQ_RB_enq_x_P K \<acute>RingCRB bx \<rbrace>"
  by(vcg, auto)

lemma CleanQ_CRB_Enqueue_X_Q_write_head:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_x_Q K \<acute>RingCRB bx \<rbrace>
      \<acute>RingCRB :== CleanQ_RB_write_head_y b \<acute>RingCRB
    \<lbrace> CleanQ_RB_enq_x_Q K \<acute>RingCRB bx \<rbrace>"
  by(vcg, auto)

lemma CleanQ_CRB_Enqueue_X_R_write_head:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_x_R K \<acute>RingCRB bx \<rbrace>
      \<acute>RingCRB :== CleanQ_RB_write_head_y b \<acute>RingCRB
    \<lbrace> CleanQ_RB_enq_x_R K \<acute>RingCRB bx \<rbrace>"
  by(vcg, auto)

paragraph \<open>Y increments the head\<close>

lemma CleanQ_CRB_Enqueue_X_P_incr_head:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_y_Q K \<acute>RingCRB b \<and>  CleanQ_RB_enq_x_P K \<acute>RingCRB bx \<rbrace>
     \<acute>RingCRB :== CleanQ_RB_incr_head_y b \<acute>RingCRB
    \<lbrace> CleanQ_RB_enq_x_P K \<acute>RingCRB bx  \<rbrace>"
  by(vcg, auto simp:CleanQ_RB_enq_y_enq_x_possible CleanQ_RB_enq_y_inv_all)

lemma CleanQ_CRB_Enqueue_X_Q_incr_head:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_y_Q K \<acute>RingCRB b \<and>  CleanQ_RB_enq_x_Q K \<acute>RingCRB bx \<rbrace>
     \<acute>RingCRB :== CleanQ_RB_incr_head_y b \<acute>RingCRB
    \<lbrace> CleanQ_RB_enq_x_Q K \<acute>RingCRB bx \<rbrace>"
  by(vcg, auto simp: CleanQ_RB_enq_y_inv_all CleanQ_RB_enq_y_enq_x_possible)

lemma CleanQ_CRB_Enqueue_X_R_incr_head:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_y_Q K \<acute>RingCRB b \<and>  CleanQ_RB_enq_x_R K \<acute>RingCRB bx \<rbrace>
     \<acute>RingCRB :== CleanQ_RB_incr_head_y b \<acute>RingCRB
    \<lbrace> CleanQ_RB_enq_x_R K \<acute>RingCRB bx \<rbrace>"
  by(vcg, auto simp: CleanQ_RB_enq_y_inv_all CleanQ_RB_enq_y_def)

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Enqueue X, Dequeue X\<close>
(* ------------------------------------------------------------------------------------ *)

paragraph \<open>Y reads the descriptor ring\<close>

lemma CleanQ_CRB_Enqueue_X_P_read_tail:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_x_P K \<acute>RingCRB bx  \<rbrace>
       \<acute>b :== CleanQ_RB_read_tail_y \<acute>RingCRB
    \<lbrace> CleanQ_RB_enq_x_P K \<acute>RingCRB bx  \<rbrace>"
  by(vcg)

lemma CleanQ_CRB_Enqueue_X_Q_read_tail:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_x_Q K \<acute>RingCRB bx \<rbrace>
       \<acute>b :== CleanQ_RB_read_tail_y \<acute>RingCRB
    \<lbrace> CleanQ_RB_enq_x_Q K \<acute>RingCRB bx \<rbrace>"
  by(vcg)

lemma CleanQ_CRB_Enqueue_X_R_read_tail:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_x_R K \<acute>RingCRB bx \<rbrace>
       \<acute>b :== CleanQ_RB_read_tail_y \<acute>RingCRB
    \<lbrace> CleanQ_RB_enq_x_R K \<acute>RingCRB bx \<rbrace>"
   by(vcg)

paragraph \<open>Y increments the tail pointer\<close>

lemma CleanQ_CRB_Enqueue_X_P_incr_tail:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_y_Q K \<acute>RingCRB b \<and> CleanQ_RB_enq_x_P K \<acute>RingCRB bx \<rbrace>
       \<acute>RingCRB  :== CleanQ_RB_incr_tail_y b  \<acute>RingCRB
    \<lbrace> CleanQ_RB_enq_x_P K \<acute>RingCRB bx \<rbrace>"
  by(vcg, auto simp:CleanQ_RB_deq_y_all_inv CleanQ_RB_deq_y_enq_x_possible )

lemma CleanQ_CRB_Enqueue_X_Q_incr_tail:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_y_Q K \<acute>RingCRB b \<and> CleanQ_RB_enq_x_Q K \<acute>RingCRB bx \<rbrace>
       \<acute>RingCRB  :== CleanQ_RB_incr_tail_y b  \<acute>RingCRB
    \<lbrace> CleanQ_RB_enq_x_Q K \<acute>RingCRB bx \<rbrace>"
  by(vcg, auto simp:CleanQ_RB_deq_y_all_inv CleanQ_RB_deq_y_enq_x_possible)

lemma CleanQ_CRB_Enqueue_X_R_incr_tail:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_y_Q K \<acute>RingCRB b \<and> CleanQ_RB_enq_x_R K \<acute>RingCRB bx  \<rbrace>
       \<acute>RingCRB  :== CleanQ_RB_incr_tail_y b  \<acute>RingCRB
    \<lbrace> CleanQ_RB_enq_x_R K \<acute>RingCRB bx \<rbrace>"
  by(vcg, auto simp:CleanQ_RB_deq_y_all_inv CleanQ_RB_deq_y_enq_x_possible )

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Dequeue X, Enqueue Y\<close>
(* ------------------------------------------------------------------------------------ *)

paragraph \<open>Y writes the descriptor ring\<close>

lemma CleanQ_CRB_Dequeue_X_P_write_head:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_x_P K \<acute>RingCRB bx \<rbrace>
     \<acute>RingCRB :== CleanQ_RB_write_head_y b \<acute>RingCRB
    \<lbrace> CleanQ_RB_deq_x_P K \<acute>RingCRB bx \<rbrace>"
  by(vcg, auto)

lemma CleanQ_CRB_Dequeue_X_Q_write_head:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_x_Q K \<acute>RingCRB bx \<rbrace>
       \<acute>RingCRB :== CleanQ_RB_write_head_y b \<acute>RingCRB
    \<lbrace> CleanQ_RB_deq_x_Q K \<acute>RingCRB bx \<rbrace>"
  by(vcg, auto)

lemma CleanQ_CRB_Dequeue_X_R_write_head:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_x_R K \<acute>RingCRB bx \<rbrace>
       \<acute>RingCRB :== CleanQ_RB_write_head_y b \<acute>RingCRB
    \<lbrace> CleanQ_RB_deq_x_R K \<acute>RingCRB bx \<rbrace>"
  by(vcg, auto)

paragraph \<open>Y increments the head pointer\<close>

lemma CleanQ_CRB_Dequeue_X_P_incr_head:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_y_Q K \<acute>RingCRB b \<and> CleanQ_RB_deq_x_P K \<acute>RingCRB b \<rbrace>
       \<acute>RingCRB :== CleanQ_RB_incr_head_y b \<acute>RingCRB
    \<lbrace> CleanQ_RB_deq_x_P K \<acute>RingCRB b \<rbrace>"
  by(vcg, auto simp:CleanQ_RB_enq_y_inv_all CleanQ_RB_enq_y_deq_x_possible)

lemma CleanQ_CRB_Dequeue_X_Q_incr_head:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_y_Q K \<acute>RingCRB b \<and> CleanQ_RB_deq_x_Q K \<acute>RingCRB bx \<rbrace>
       \<acute>RingCRB :== CleanQ_RB_incr_head_y b \<acute>RingCRB
    \<lbrace> CleanQ_RB_deq_x_Q K \<acute>RingCRB bx \<rbrace>"
  by(vcg, auto simp:CleanQ_RB_enq_y_inv_all CleanQ_RB_enq_y_deq_x_possible)

lemma CleanQ_CRB_Dequeue_X_R_incr_head:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_enq_y_Q K \<acute>RingCRB b \<and> CleanQ_RB_deq_x_R K \<acute>RingCRB bx \<rbrace>
       \<acute>RingCRB :== CleanQ_RB_incr_head_y b \<acute>RingCRB
    \<lbrace> CleanQ_RB_deq_x_R K \<acute>RingCRB bx \<rbrace>"
  by(vcg, auto simp:CleanQ_RB_enq_y_inv_all)

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Dequeue X, Dequeue X\<close>
(* ------------------------------------------------------------------------------------ *)

paragraph \<open>Y reads the descriptor ring\<close>

lemma CleanQ_CRB_Dequeue_X_P_read_tail:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_x_P K \<acute>RingCRB bx \<rbrace>
       \<acute>b :== CleanQ_RB_read_tail_y \<acute>RingCRB
    \<lbrace> CleanQ_RB_deq_x_P K \<acute>RingCRB bx \<rbrace>"
  by(vcg)

lemma CleanQ_CRB_Dequeue_X_Q_read_tail:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_x_Q K \<acute>RingCRB bx \<rbrace>
       \<acute>b :== CleanQ_RB_read_tail_y \<acute>RingCRB
    \<lbrace> CleanQ_RB_deq_x_Q K \<acute>RingCRB bx \<rbrace>"
  by(vcg)

lemma CleanQ_CRB_Dequeue_X_R_read_tail:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_x_R K \<acute>RingCRB bx \<rbrace>
       \<acute>b :== CleanQ_RB_read_tail_y \<acute>RingCRB
    \<lbrace> CleanQ_RB_deq_x_R K \<acute>RingCRB bx \<rbrace>"
  by(vcg)

paragraph \<open>Y increments the tail pointer\<close>

lemma CleanQ_CRB_Dequeue_X_P_incr_tail:
"\<Gamma>\<turnstile>\<lbrace> CleanQ_RB_deq_y_Q K \<acute>RingCRB by \<and> CleanQ_RB_deq_x_P K \<acute>RingCRB bx \<rbrace>
      \<acute>RingCRB :== CleanQ_RB_incr_tail_y by \<acute>RingCRB
   \<lbrace> CleanQ_RB_deq_x_P K \<acute>RingCRB bx  \<rbrace>"
  by(vcg, auto simp: CleanQ_RB_deq_y_deq_x_possible CleanQ_RB_deq_y_all_inv)

lemma CleanQ_CRB_Dequeue_X_Q_incr_tail:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_y_Q K \<acute>RingCRB by \<and> CleanQ_RB_deq_x_Q K \<acute>RingCRB bx \<rbrace>
       \<acute>RingCRB :== CleanQ_RB_incr_tail_y by \<acute>RingCRB
    \<lbrace> CleanQ_RB_deq_x_Q K \<acute>RingCRB bx \<rbrace>"
  by(vcg, auto simp:CleanQ_RB_deq_y_all_inv CleanQ_RB_deq_y_deq_x_possible)

lemma CleanQ_CRB_Dequeue_X_R_incr_tail:
"\<Gamma>\<turnstile> \<lbrace> CleanQ_RB_deq_y_Q K \<acute>RingCRB by \<and> CleanQ_RB_deq_x_R K \<acute>RingCRB bx \<rbrace>
       \<acute>RingCRB :== CleanQ_RB_incr_tail_y by \<acute>RingCRB
    \<lbrace> CleanQ_RB_deq_x_R K \<acute>RingCRB bx \<rbrace>"
  by(vcg, auto simp:CleanQ_RB_deq_y_all_inv)

end


(*  Title:       Mutually recursive procedures
    Author:      Tobias Nipkow, 2001/2006
    Maintainer:  Tobias Nipkow
*)

section "Hoare Logics for Mutually Recursive Procedure"

theory PsLang imports Main begin

subsection\<open>The language\<close>

typedecl state
typedecl pname

type_synonym bexp = "state \<Rightarrow> bool"

datatype
  com = Do "state \<Rightarrow> state set"
      | Semi  com com          ("_; _"  [60, 60] 10)
      | Cond  bexp com com     ("IF _ THEN _ ELSE _"  60)
      | While bexp com         ("WHILE _ DO _"  60)
      | CALL pname
      | Local "(state \<Rightarrow> state)" com "(state \<Rightarrow> state \<Rightarrow> state)"
               ("LOCAL _; _; _" [0,0,60] 60)

consts body :: "pname \<Rightarrow> com"

text\<open>We generalize from a single procedure to a whole set of
procedures following the ideas of von Oheimb~\<^cite>\<open>"Oheimb-FSTTCS99"\<close>.
The basic setup is modified only in a few places:
\begin{itemize}
\item We introduce a new basic type @{typ pname} of procedure names.
\item Constant @{term body} is now of type @{typ"pname \<Rightarrow> com"}.
\item The @{term CALL} command now has an argument of type @{typ pname},
the name of the procedure that is to be called.
\end{itemize}
\<close>

inductive
  exec :: "state \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool"   ("_/ -_\<rightarrow>/ _" [50,0,50] 50)
where
    Do:     "t \<in> f s \<Longrightarrow> s -Do f\<rightarrow> t"

  | Semi:   "\<lbrakk> s0 -c1\<rightarrow> s1; s1 -c2\<rightarrow> s2 \<rbrakk> \<Longrightarrow> s0 -c1;c2\<rightarrow> s2"

  | IfTrue:  "\<lbrakk> b s;  s -c1\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c1 ELSE c2\<rightarrow> t"
  | IfFalse: "\<lbrakk> \<not>b s; s -c2\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c1 ELSE c2\<rightarrow> t"

  | WhileFalse: "\<not>b s \<Longrightarrow> s -WHILE b DO c\<rightarrow> s"
  | WhileTrue:  "\<lbrakk> b s; s -c\<rightarrow> t; t -WHILE b DO c\<rightarrow> u \<rbrakk>
                \<Longrightarrow> s -WHILE b DO c\<rightarrow> u"

  | Call: "s -body p\<rightarrow> t \<Longrightarrow> s -CALL p\<rightarrow> t"

  | Local: "f s -c\<rightarrow> t \<Longrightarrow> s -LOCAL f; c; g\<rightarrow> g s t"

lemma [iff]: "(s -c;d\<rightarrow> u) = (\<exists>t. s -c\<rightarrow> t \<and> t -d\<rightarrow> u)"
by(auto elim: exec.cases intro:exec.intros)

lemma [iff]: "(s -IF b THEN c ELSE d\<rightarrow> t) =
              (s -if b s then c else d\<rightarrow> t)"
apply(rule iffI)
 apply(auto elim: exec.cases intro:exec.intros)
apply(auto intro:exec.intros split:if_split_asm)
done

lemma [iff]: "(s -CALL p\<rightarrow> t) = (s -body p\<rightarrow> t)"
by(blast elim: exec.cases intro:exec.intros)

lemma [iff]: "(s -LOCAL f; c; g\<rightarrow> u) = (\<exists>t. f s -c\<rightarrow> t \<and> u = g s t)"
by(fastforce elim: exec.cases intro:exec.intros)

inductive
  execn :: "state \<Rightarrow> com \<Rightarrow> nat \<Rightarrow> state \<Rightarrow> bool"   ("_/ -_-_\<rightarrow>/ _" [50,0,0,50] 50)
where
    Do:     "t \<in> f s \<Longrightarrow> s -Do f-n\<rightarrow> t"

  | Semi:   "\<lbrakk> s0 -c0-n\<rightarrow> s1; s1 -c1-n\<rightarrow> s2 \<rbrakk> \<Longrightarrow> s0 -c0;c1-n\<rightarrow> s2"

  | IfTrue: "\<lbrakk> b s; s -c0-n\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c0 ELSE c1-n\<rightarrow> t"

  | IfFalse: "\<lbrakk> \<not>b s; s -c1-n\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c0 ELSE c1-n\<rightarrow> t"

  | WhileFalse: "\<not>b s \<Longrightarrow> s -WHILE b DO c-n\<rightarrow> s"

  | WhileTrue:  "\<lbrakk> b s; s -c-n\<rightarrow> t; t -WHILE b DO c-n\<rightarrow> u \<rbrakk>
                \<Longrightarrow> s -WHILE b DO c-n\<rightarrow> u"

  | Call:  "s -body p-n\<rightarrow> t \<Longrightarrow> s -CALL p-Suc n\<rightarrow> t"

  | Local: "f s -c-n\<rightarrow> t \<Longrightarrow> s -LOCAL f; c; g-n\<rightarrow> g s t"

lemma [iff]: "(s -Do f-n\<rightarrow> t) = (t \<in> f s)"
by(auto elim: execn.cases intro:execn.intros)

lemma [iff]: "(s -c1;c2-n\<rightarrow> u) = (\<exists>t. s -c1-n\<rightarrow> t \<and> t -c2-n\<rightarrow> u)"
by(best elim: execn.cases intro:execn.intros)

lemma [iff]: "(s -IF b THEN c ELSE d-n\<rightarrow> t) =
              (s -if b s then c else d-n\<rightarrow> t)"
apply auto
apply(blast elim: execn.cases intro:execn.intros)+
done

lemma [iff]: "(s -CALL p- 0\<rightarrow> t) = False"
by(blast elim: execn.cases intro:execn.intros)

lemma [iff]: "(s -CALL p-Suc n\<rightarrow> t) = (s -body p-n\<rightarrow> t)"
by(blast elim: execn.cases intro:execn.intros)

lemma [iff]: "(s -LOCAL f; c; g-n\<rightarrow> u) = (\<exists>t. f s -c-n\<rightarrow> t \<and> u = g s t)"
by(auto elim: execn.cases intro:execn.intros)

lemma exec_mono[rule_format]: "s -c-m\<rightarrow> t \<Longrightarrow> \<forall>n. m \<le> n \<longrightarrow> s -c-n\<rightarrow> t"
apply(erule execn.induct)
       apply(blast)
      apply(blast)
     apply(simp)
    apply(simp)
   apply(simp add:execn.intros)
  apply(blast intro:execn.intros)
 apply(clarify)
 apply(rename_tac m)
 apply(case_tac m)
  apply simp
 apply simp
apply blast
done

lemma exec_iff_execn: "(s -c\<rightarrow> t) = (\<exists>n. s -c-n\<rightarrow> t)"
apply(rule iffI)
 apply(erule exec.induct)
        apply blast
       apply clarify
       apply(rename_tac m n)
       apply(rule_tac x = "max m n" in exI)
       apply(fastforce intro:exec.intros exec_mono simp add:max_def)
      apply fastforce
     apply fastforce
    apply(blast intro:execn.intros)
   apply clarify
   apply(rename_tac m n)
   apply(rule_tac x = "max m n" in exI)
   apply(fastforce elim:execn.WhileTrue exec_mono simp add:max_def)
  apply blast
 apply blast
apply(erule exE, erule execn.induct)
       apply blast
      apply blast
     apply fastforce
    apply fastforce
   apply(erule exec.WhileFalse)
  apply(blast intro: exec.intros)
 apply blast
apply blast
done

lemma while_lemma[rule_format]:
"s -w-n\<rightarrow> t \<Longrightarrow> \<forall>b c. w = WHILE b DO c \<and> P s \<and>
                    (\<forall>s s'. P s \<and> b s \<and> s -c-n\<rightarrow> s' \<longrightarrow> P s') \<longrightarrow> P t \<and> \<not>b t"
apply(erule execn.induct)
apply clarify+
defer
apply clarify+
apply(subgoal_tac "P t")
apply blast
apply blast
done

lemma while_rule:
 "\<lbrakk>s -WHILE b DO c-n\<rightarrow> t; P s; \<And>s s'. \<lbrakk>P s; b s; s -c-n\<rightarrow> s' \<rbrakk> \<Longrightarrow> P s'\<rbrakk>
  \<Longrightarrow> P t \<and> \<not>b t"
apply(drule while_lemma)
prefer 2 apply assumption
apply blast
done

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      Generalise.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2005-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

theory Generalise imports "~~/src/HOL/Statespace/DistinctTreeProver"
begin

lemma protectRefl: "PROP Pure.prop (PROP C) \<Longrightarrow> PROP Pure.prop (PROP C)"
  by (simp add: prop_def)

lemma protectImp:
 assumes i: "PROP Pure.prop (PROP P \<Longrightarrow> PROP Q)"
 shows "PROP Pure.prop (PROP Pure.prop P \<Longrightarrow> PROP Pure.prop Q)"
proof -
  {
    assume P: "PROP Pure.prop P"
    from i [unfolded prop_def, OF P [unfolded prop_def]]
    have "PROP Pure.prop Q"
      by (simp add: prop_def)
  }
  note i' = this
  show "PROP ?thesis"
    apply (rule protectI)
    apply (rule i')
    apply assumption
    done
qed

lemma generaliseConj:
  assumes i1: "PROP Pure.prop (PROP Pure.prop (Trueprop P) \<Longrightarrow> PROP Pure.prop (Trueprop Q))"
  assumes i2: "PROP Pure.prop (PROP Pure.prop (Trueprop P') \<Longrightarrow> PROP Pure.prop (Trueprop Q'))"
  shows "PROP Pure.prop (PROP Pure.prop (Trueprop (P \<and> P')) \<Longrightarrow> (PROP Pure.prop (Trueprop (Q \<and> Q'))))"
  using i1 i2
  by (auto simp add: prop_def)

lemma generaliseAll:
 assumes i: "PROP Pure.prop (\<And>s. PROP Pure.prop (Trueprop (P s)) \<Longrightarrow> PROP Pure.prop (Trueprop (Q s)))"
 shows "PROP Pure.prop (PROP Pure.prop (Trueprop (\<forall>s. P s)) \<Longrightarrow> PROP Pure.prop (Trueprop (\<forall>s. Q s)))"
  using i
  by (auto simp add: prop_def)

lemma generalise_all:
 assumes i: "PROP Pure.prop (\<And>s. PROP Pure.prop (PROP P s) \<Longrightarrow> PROP Pure.prop (PROP Q s))"
 shows "PROP Pure.prop ((PROP Pure.prop (\<And>s. PROP P s)) \<Longrightarrow> (PROP Pure.prop (\<And>s. PROP Q s)))"
  using i
  proof (unfold prop_def)
    assume i1: "\<And>s. (PROP P s) \<Longrightarrow> (PROP Q s)"
    assume i2: "\<And>s. PROP P s"
    show "\<And>s. PROP Q s"
      by (rule i1) (rule i2)
  qed

lemma generaliseTrans:
  assumes i1: "PROP Pure.prop (PROP P \<Longrightarrow> PROP Q)"
  assumes i2: "PROP Pure.prop (PROP Q \<Longrightarrow> PROP R)"
  shows "PROP Pure.prop (PROP P \<Longrightarrow> PROP R)"
  using i1 i2
  proof (unfold prop_def)
    assume P_Q: "PROP P \<Longrightarrow> PROP Q"
    assume Q_R: "PROP Q \<Longrightarrow> PROP R"
    assume P: "PROP P"
    show "PROP R"
      by (rule Q_R [OF P_Q [OF P]])
  qed

lemma meta_spec:
  assumes "\<And>x. PROP P x"
  shows "PROP P x" by fact

lemma meta_spec_protect:
  assumes g: "\<And>x. PROP P x"
  shows "PROP Pure.prop (PROP P x)"
using g
by (auto simp add: prop_def)

lemma generaliseImp:
  assumes i: "PROP Pure.prop (PROP Pure.prop (Trueprop P) \<Longrightarrow> PROP Pure.prop (Trueprop Q))"
  shows "PROP Pure.prop (PROP Pure.prop (Trueprop (X \<longrightarrow> P)) \<Longrightarrow> PROP Pure.prop (Trueprop (X \<longrightarrow> Q)))"
  using i
  by (auto simp add: prop_def)

lemma generaliseEx:
 assumes i: "PROP Pure.prop (\<And>s. PROP Pure.prop (Trueprop (P s)) \<Longrightarrow> PROP Pure.prop (Trueprop (Q s)))"
 shows "PROP Pure.prop (PROP Pure.prop (Trueprop (\<exists>s. P s)) \<Longrightarrow> PROP Pure.prop (Trueprop (\<exists>s. Q s)))"
  using i
  by (auto simp add: prop_def)

lemma generaliseRefl: "PROP Pure.prop (PROP Pure.prop (Trueprop P) \<Longrightarrow> PROP Pure.prop (Trueprop P))"
  by (auto simp add: prop_def)

lemma generaliseRefl': "PROP Pure.prop (PROP P \<Longrightarrow> PROP P)"
  by (auto simp add: prop_def)

lemma generaliseAllShift:
  assumes i: "PROP Pure.prop (\<And>s. P \<Longrightarrow> Q s)"
  shows "PROP Pure.prop (PROP Pure.prop (Trueprop P) \<Longrightarrow> PROP Pure.prop (Trueprop (\<forall>s. Q s)))"
  using i
  by (auto simp add: prop_def)

lemma generalise_allShift:
  assumes i: "PROP Pure.prop (\<And>s. PROP P \<Longrightarrow> PROP Q s)"
  shows "PROP Pure.prop (PROP Pure.prop (PROP P) \<Longrightarrow> PROP Pure.prop (\<And>s. PROP Q s))"
  using i
  proof (unfold prop_def)
    assume P_Q: "\<And>s. PROP P \<Longrightarrow> PROP Q s"
    assume P: "PROP P"
    show "\<And>s. PROP Q s"
      by (rule P_Q [OF P])
  qed

lemma generaliseImpl:
  assumes i: "PROP Pure.prop (PROP Pure.prop P \<Longrightarrow> PROP Pure.prop Q)"
  shows "PROP Pure.prop ((PROP Pure.prop (PROP X \<Longrightarrow> PROP P)) \<Longrightarrow> (PROP Pure.prop (PROP X \<Longrightarrow> PROP Q)))"
  using i
  proof (unfold prop_def)
    assume i1: "PROP P \<Longrightarrow> PROP Q"
    assume i2: "PROP X \<Longrightarrow> PROP P"
    assume X: "PROP X"
    show "PROP Q"
      by (rule i1 [OF i2 [OF X]])
  qed

ML_file "generalise_state.ML"

end