theory ProcSendCase
  imports ResMapValid ReduceWTS ProcDef ProcCVars
begin

lemma cancel_strong_leq_use_env: "\<lbrakk> strong_use_env r_x \<rbrakk> \<Longrightarrow> leq_use_env (diff_use_env r_x r_x) r_s"
  apply (simp add: leq_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (simp add: strong_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
  done

lemma sfl_diff_use_env: "\<lbrakk> strong_use_env r_ex; leq_use_env r_ex r_s; is_own r \<rbrakk> \<Longrightarrow> diff_use_env r_s (diff_use_env (lift_use_env r_s r) r_ex) = r_ex"
  apply (case_tac "\<forall> x. diff_use_env r_s (diff_use_env (lift_use_env r_s r) r_ex) x = r_ex x")
   apply (auto)
  apply (simp add: strong_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (simp add: is_own_def)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_ex x")
    apply (auto)
   apply (case_tac "r_s x")
    apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

    (* the question right now is, how do we make these types line up? *)

lemma safe_val_exp: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp (AppExp (ConstExp SendConst) (VarExp x a)) v)) tau r_s2 rx;
  env (deref_name x a) = Some (ChanTy t SEnd); is_value c; is_value v \<rbrakk> \<Longrightarrow>
  well_typed env (np_dom_use_env env v) v t (np_dom_use_env env v) (np_dom_use_env env v)"
  apply (induct h arbitrary: env r_s1 tau r_s2 rx)
       apply (auto)
    (* base case *)
  apply (case_tac "t \<noteq> t1")
   apply (simp add: pure_fun_def)
  apply (cut_tac env="env" and ?r_s1.0="r_s2a" and e="v" and tau="t" and ?r_s2.0="r_s3" and rx="rx2" in infl_sexp_wp)
    apply (simp)
   apply (rule_tac value_is_sexp)
   apply (auto)
    (* r = rb *)
  apply (case_tac "rb \<noteq> r")
   apply (simp add: pure_fun_def)
    (* the idea is that the infl_sexp_wp requirements are strictly greater than np_dom. since np_dom is strong, there is an exact way of
        subtracting to get to np_dom. (we do cheat a little by lifting rx2). *)
  apply (rule_tac t="np_dom_use_env env v" and s="diff_use_env (comp_use_env (lift_use_env rx2 r) (infl_use_env r_s2a r_s3))
    (diff_use_env (lift_use_env (comp_use_env (lift_use_env rx2 r) (infl_use_env r_s2a r_s3)) rb) (np_dom_use_env env v))" in subst)
   apply (rule_tac sfl_diff_use_env)
     apply (simp add: np_dom_use_env_def)
     apply (rule_tac strong_dom_use_env)
    (* to prove that the infl_sexp_wp reqs are greater than np_dom, we use the fact that any npv must have a permission *)
    apply (simp add: np_dom_use_env_def)
    apply (simp add: dom_use_env_def)
    apply (auto)
   apply (simp add: leq_use_env_def)
   apply (auto)
   apply (case_tac "comp_use_env (lift_use_env rx2 r) (infl_use_env r_s2a r_s3) xa \<noteq> OwnPerm")
    apply (case_tac "comp_use_env rx2 (infl_use_env r_s2a r_s3) xa = NoPerm")
     apply (cut_tac x="xa" and env="env" and e="v" and ?r_s1.0="comp_use_env rx2 (infl_use_env r_s2a r_s3)" in well_typed_no_npv_use)
       apply (auto)
   apply (cut_tac r_sa="lift_use_env rx2 r" and r_sb="infl_use_env r_s2a r_s3" and x="xa" in comp_use_no_own_both)
    apply (auto)
   apply (case_tac "rx2 xa \<noteq> NoPerm")
    apply (simp add: is_own_def)
   apply (auto)
   apply (case_tac "infl_use_env r_s2a r_s3 xa \<noteq> NoPerm")
    apply (simp add: infl_use_env_def)
    apply (case_tac "r_s2a xa = OwnPerm \<and> r_s3 xa = NoPerm")
     apply (auto)
   apply (cut_tac r_sa="rx2" and r_sb="infl_use_env r_s2a r_s3" and x="xa" in comp_use_none)
     apply (auto)
    (* with that in mind, we manipulate until we match the infl sexp lemma *)
  apply (rule_tac well_typed_diff_perms)
   apply (rule_tac rx="comp_use_env rx2 (infl_use_env r_s2a r_s3)" in well_typed_incr_req)
     apply (rule_tac r_s="comp_use_env rx2 (infl_use_env r_s2a r_s3)" in well_typed_incr_simul_perm)
      apply (rule_tac dist_comp_leq_use_env)
       apply (rule_tac comp_leq_use_env1)
       apply (rule_tac self_lift_leq_use_env)
      apply (rule_tac self_comp_leq_use_env2)
     apply (simp)
    apply (rule_tac dist_comp_leq_use_env)
     apply (rule_tac comp_leq_use_env1)
     apply (rule_tac self_lift_leq_use_env)
    apply (rule_tac self_comp_leq_use_env2)
   apply (rule_tac id_leq_use_env)
    (* next, we must show that the differential is actually subtractible, which is true since it removes all non-prim vars *)
  apply (auto)
  apply (case_tac "np_dom_use_env env v xa \<noteq> OwnPerm")
   apply (simp add: np_dom_use_env_def)
   apply (simp add: dom_use_env_def)
   apply (cut_tac r_s="lift_use_env (comp_use_env (lift_use_env rx2 r) (infl_use_env r_s2a r_s3)) r" and
       r_ex="np_dom_use_env env v" and x="xa" in diff_use_none_ex)
    apply (simp)
  apply (simp add: own_env_vars_def)
  done

lemma safe_recv_exp: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp (ConstExp RecvConst) (VarExp x a))) tau r_s2 rx;
  env (deref_name x a) = Some (ChanTy t REnd); well_typed env r_x v t r_x r_x; disj_use_env r_s1 r_x;
  strong_use_env r_x; is_value c; is_value v; is_own r \<rbrakk> \<Longrightarrow>
  well_typed env (comp_use_env r_s1 r_x) (app_hole h v) tau r_s2 rx"
  apply (induct h arbitrary: env r_s1 tau r_s2 rx)
       apply (auto)
    (* base case *)
       apply (cut_tac r_sc="r_s2" and r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 ra)) r_exa)" and
          r_sa="r_s1" in trans_leq_use_env)
         apply (rule_tac diff_leq_use_env)
         apply (rule_tac r_sb="diff_use_env r_s2a (comp_use_env (ereq_use_env x tau_x) r_ex)" in trans_leq_use_env)
          apply (rule_tac diff_leq_use_env)
          apply (auto)
       apply (rule_tac ?r_s2.0="diff_use_env (comp_use_env r_s1 r_x) r_x"
        and rx="diff_use_env r_x r_x" in well_typed_simul_end_perm)
          apply (rule_tac well_typed_diff_end_perm)
           apply (rule_tac well_typed_comp_perms2)
            apply (simp add: pure_fun_def)
           apply (auto)
          apply (rule_tac comm_disj_use_env)
          apply (simp)
         apply (rule_tac self_comp_leq_use_env2)
        apply (rule_tac disj_diff_leq_use_env)
         apply (rule_tac r_s="r_s1" in disj_leq_use_env2)
          apply (rule_tac comm_disj_use_env)
          apply (simp_all)
        apply (rule_tac comp_leq_use_env1)
        apply (simp)
       apply (rule_tac cancel_strong_leq_use_env)
       apply (simp)
    (* lhs pair case. *)
      apply (rule_tac x="t1" in exI)
      apply (rule_tac x="ra" in exI)
      apply (rule_tac x="aa" in exI)
      apply (rule_tac x="r_s2a" in exI)
      apply (rule_tac x="rx1" in exI)
      apply (auto)
      apply (rule_tac x="rx2" in exI)
      apply (rule_tac x="r_s3" in exI)
      apply (auto)
      apply (rule_tac x="r_ex" in exI)
      apply (auto)
      apply (rule_tac comp_leq_use_env1)
      apply (simp)
    (* rhs pair case. *)
     apply (rule_tac x="t1" in exI)
     apply (rule_tac x="ra" in exI)
     apply (rule_tac x="aa" in exI)
     apply (rule_tac x="comp_use_env r_s2a r_x" in exI)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
      apply (rule_tac well_typed_comp_perms)
       apply (simp_all)
     apply (rule_tac x="rx2" in exI)
     apply (rule_tac x="r_s3" in exI)
     apply (auto)
      apply (cut_tac r_x="r_s2a" and r_s="r_s1" and r_ex="r_x" in disj_leq_use_env1)
        apply (simp)
       apply (rule_tac well_typed_perm_leq)
       apply (auto)
     apply (rule_tac x="r_ex" in exI)
     apply (auto)
     apply (rule_tac comp_leq_use_env1)
     apply (simp)
    (* if case. *)
    apply (rule_tac x="rx'" in exI)
    apply (rule_tac x="r_s2a" in exI)
    apply (auto)
    (* lhs pair case. *)
   apply (rule_tac x="r_s2a" in exI)
   apply (rule_tac x="r_s3" in exI)
   apply (rule_tac x="rx1" in exI)
   apply (auto)
   apply (rule_tac x="rx2" in exI)
   apply (auto)
   apply (rule_tac x="r_ex" in exI)
   apply (auto)
   apply (rule_tac comp_leq_use_env1)
   apply (simp)
    (* rhs pair case. *)
  apply (rule_tac x="comp_use_env r_s2a r_x" in exI)
  apply (rule_tac x="r_s3" in exI)
  apply (rule_tac x="rx1" in exI)
   apply (auto)
   apply (rule_tac well_typed_comp_perms)
    apply (simp_all)
  apply (rule_tac x="rx2" in exI)
   apply (auto)
   apply (cut_tac r_x="r_s2a" and r_s="r_s1" and r_ex="r_x" in disj_leq_use_env1)
     apply (simp)
    apply (rule_tac well_typed_perm_leq)
    apply (auto)
  apply (rule_tac x="r_ex" in exI)
  apply (auto)
  apply (rule_tac comp_leq_use_env1)
  apply (simp)
  done

lemma safe_own_npv_use: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp f v)) tau r_s2 rx; is_value f; strong_fun f;
  a \<noteq> NoRef; is_value v; x \<in> non_prim_vars env v \<rbrakk> \<Longrightarrow> r_s1 x = OwnPerm"
  apply (induct h arbitrary: env r_s1 r_s2 tau rx)
       apply (auto)
    (* base case *)
    apply (cut_tac f="f" and r="r" in strong_fun_own)
      apply (auto)
    apply (cut_tac env="env" and ?r_s1.0="r_s2a" and e="v" and ?r_s2.0="r_s3" and rx="rx2" in infl_sexp_wp)
      apply (auto)
     apply (rule_tac value_is_sexp)
     apply (simp)
    apply (case_tac "comp_use_env rx2 (infl_use_env r_s2a r_s3) x = NoPerm")
     apply (cut_tac env="env" and x="x" and e="v" and ?r_s1.0="comp_use_env rx2 (infl_use_env r_s2a r_s3)" in well_typed_no_npv_use)
       apply (auto)
    apply (case_tac "rx2 x \<noteq> NoPerm")
     apply (cut_tac r_x="lift_use_env rx2 r" and r_s="r_s1" and x="x" in leq_use_own)
      apply (simp add: is_own_def)
     apply (rule_tac r_sb="comp_use_env rx1 (lift_use_env rx2 r)" in trans_leq_use_env)
      apply (rule_tac r_sb="r_s3" in trans_leq_use_env)
       apply (rule_tac r_sb="r_s2a" in trans_leq_use_env)
        apply (auto)
       apply (rule_tac well_typed_perm_leq)
       apply (auto)
      apply (rule_tac well_typed_perm_leq)
      apply (auto)
     apply (rule_tac self_comp_leq_use_env2)
    apply (case_tac "infl_use_env r_s2a r_s3 x \<noteq> NoPerm")
     apply (simp add: infl_use_env_def)
     apply (case_tac "r_s2a x = OwnPerm \<and> r_s3 x = NoPerm")
      apply (auto)
     apply (rule_tac r_x="r_s2a" in leq_use_own)
      apply (auto)
     apply (rule_tac well_typed_perm_leq)
     apply (auto)
    apply (cut_tac r_sa="rx2" and r_sb="infl_use_env r_s2a r_s3" and x="x" in comp_use_none)
      apply (auto)
    (* rhs induct *)
   apply (rule_tac r_x="r_s2a" in leq_use_own)
    apply (simp)
   apply (rule_tac well_typed_perm_leq)
   apply (auto)
    (* rhs pair *)
  apply (rule_tac r_x="r_s2a" in leq_use_own)
   apply (simp)
  apply (rule_tac well_typed_perm_leq)
  apply (auto)
  done
  (*
lemma safe_send_own_npv_use: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp (AppExp (ConstExp SendConst) (VarExp c a)) v)) tau r_s2 rx;
  a \<noteq> NoRef; is_value v; x \<in> non_prim_vars env v \<rbrakk> \<Longrightarrow> r_s1 x = OwnPerm"
  apply (induct h arbitrary: env r_s1 r_s2 tau rx)
       apply (auto)
    (* base case *)
    apply (cut_tac r_sc="r_s2a" and r_sb="diff_use_env r_s3a (comp_use_env (comp_use_env rx1a (lift_use_env rx2a ra)) r_exb)" and
      r_sa="r_s1" in trans_leq_use_env)
      apply (rule_tac diff_leq_use_env)
      apply (rule_tac r_sb="diff_use_env r_s2b (comp_use_env (ereq_use_env c tau_x) r_exa)" in trans_leq_use_env)
       apply (rule_tac diff_leq_use_env)
       apply (auto)
    apply (cut_tac env="env" and ?r_s1.0="r_s2a" and e="v" and ?r_s2.0="r_s3" and rx="rx2" in infl_sexp_wp)
      apply (auto)
     apply (rule_tac value_is_sexp)
     apply (simp)
    apply (case_tac "comp_use_env rx2 (infl_use_env r_s2a r_s3) x = NoPerm")
     apply (cut_tac env="env" and x="x" and e="v" and ?r_s1.0="comp_use_env rx2 (infl_use_env r_s2a r_s3)" in well_typed_no_npv_use)
       apply (auto)
    apply (case_tac "rx2 x \<noteq> NoPerm")
     apply (cut_tac r_x="lift_use_env rx2 r" and r_s="r_s1" and x="x" in leq_use_own)
       apply (simp add: pure_fun_def)
       apply (auto)
      apply (simp add: is_own_def)
     apply (rule_tac r_sb="comp_use_env rx1 (lift_use_env rx2 r)" in trans_leq_use_env)
      apply (rule_tac r_sb="r_s3" in trans_leq_use_env)
       apply (rule_tac r_sb="r_s2a" in trans_leq_use_env)
        apply (auto)
      apply (rule_tac well_typed_perm_leq)
      apply (auto)
     apply (rule_tac self_comp_leq_use_env2)
    apply (case_tac "infl_use_env r_s2a r_s3 x \<noteq> NoPerm")
     apply (simp add: infl_use_env_def)
     apply (case_tac "r_s2a x = OwnPerm \<and> r_s3 x = NoPerm")
      apply (auto)
     apply (rule_tac r_x="r_s2a" in leq_use_own)
      apply (auto)
    apply (cut_tac r_sa="rx2" and r_sb="infl_use_env r_s2a r_s3" and x="x" in comp_use_none)
      apply (auto)
    (* rhs induct *)
   apply (rule_tac r_x="r_s2a" in leq_use_own)
    apply (simp)
   apply (rule_tac well_typed_perm_leq)
   apply (auto)
    (* rhs pair *)
  apply (rule_tac r_x="r_s2a" in leq_use_own)
   apply (simp)
  apply (rule_tac well_typed_perm_leq)
  apply (auto)
  done      *)

lemma safe_send_exp_ih: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp (AppExp (ConstExp SendConst) c) v)) tau r_s2 rx; is_value c; is_value v \<rbrakk> \<Longrightarrow>
  well_typed env r_s1 (app_hole h (ConstExp UnitConst)) tau r_s2 rx"
  apply (induct h arbitrary: env r_s1 tau r_s2 rx)
       apply (auto)
    (* base case *)
        apply (simp add: pure_fun_def)
       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 r_sb="r_s2a" in trans_leq_use_env)
         apply (rule_tac r_sb="diff_use_env r_s3a (comp_use_env (comp_use_env rx1a (lift_use_env rx2a ra)) r_exa)" in trans_leq_use_env)
          apply (rule_tac diff_leq_use_env)
          apply (rule_tac r_sb="r_s2b" in trans_leq_use_env)
           apply (simp_all)
        apply (rule_tac well_typed_perm_leq)
        apply (auto)
       apply (rule_tac well_typed_perm_leq)
       apply (auto)
    (* lhs app case *)
      apply (rule_tac x="t1" in exI)
      apply (rule_tac x="r" in exI)
      apply (rule_tac x="a" in exI)
      apply (rule_tac x="r_s2a" in exI)
      apply (rule_tac x="rx1" in exI)
      apply (auto)
    (* rhs app case *)
     apply (rule_tac x="t1" in exI)
     apply (rule_tac x="r" in exI)
     apply (rule_tac x="a" in exI)
     apply (rule_tac x="r_s2a" in exI)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
     apply (rule_tac x="rx2" in exI)
     apply (rule_tac x="r_s3" in exI)
     apply (auto)
    (* if case *)
    apply (rule_tac x="rx'" in exI)
    apply (rule_tac x="r_s2a" in exI)
    apply (auto)
    (* lhs pair case *)
   apply (rule_tac x="r_s2a" in exI)
   apply (rule_tac x="r_s3" in exI)
   apply (rule_tac x="rx1" in exI)
   apply (auto)
    (* rhs pair case *)
  apply (rule_tac x="r_s2a" in exI)
  apply (rule_tac x="r_s3" in exI)
  apply (rule_tac x="rx1" in exI)
  apply (auto)
  apply (rule_tac x="rx2" in exI)
  apply (auto)
  done

lemma safe_send_exp: "\<lbrakk> well_typed env r_s1 (app_hole h (AppExp (AppExp (ConstExp SendConst) (VarExp x a)) v)) tau r_s2 rx;
  valid_nres_map s rs_map; valid_exp_use_env s rs_map r_s1; wf_hole h; is_value v; a \<noteq> NoRef \<rbrakk> \<Longrightarrow>
  well_typed env (diff_use_env r_s1 (full_dom_use_env env rs_map v)) (app_hole h (ConstExp UnitConst)) tau
    (diff_use_env r_s2 (full_dom_use_env env rs_map v)) (diff_use_env rx (full_dom_use_env env rs_map v))"
  apply (rule_tac well_typed_diff_perms)
   apply (rule_tac c="VarExp x a" in safe_send_exp_ih)
     apply (auto)
    (* we want to show that if xa is in the dominator, it is not an np-var in h.
        > if xa is an np-var itself, it cannot be in e by lemma *)
  apply (case_tac "xa \<in> non_prim_vars env v")
   apply (cut_tac h="h" and x="xa" and e="ConstExp UnitConst" in app_hole_free_vars_rev)
    apply (auto)
    apply (simp add: non_prim_vars_def)
   apply (cut_tac h="h" and x="xa" and env="env" and ?r_s1.0="r_s1" and v="VarExp x a" and e="v" in safe_send_hole_npv_use)
        apply (auto)
    (* otherwise, xa is in the completion. we identify its ancestor z. *)
  apply (simp add: own_env_vars_def)
  apply (simp add: full_dom_use_env_def)
  apply (simp add: dom_use_env_def)
  apply (case_tac "\<exists>l z. z \<in> non_prim_vars env v \<and> path_lookup rs_map z l xa")
   apply (auto)
    (* we note that z is a np-var of e therefore r_s1 z = Own *)
  apply (cut_tac x="z" and env="env" and f="AppExp (ConstExp SendConst) (VarExp x a)" in safe_own_npv_use)
        apply (auto)
   apply (simp add: pure_fun_def)
   apply (simp add: is_own_def)
    (* xa then is in the lookup map of some parent y. *)
  apply (cut_tac rs_map="rs_map" and z="z" and x="xa" in path_lookup_parent)
     apply (auto)
    (* with that in mind, by separation, x is disjoint from r_s1. *)
  apply (case_tac "r_s1 xa \<noteq> NoPerm")
   apply (simp add: valid_exp_use_env_def)
   apply (simp add: sep_nres_map_def)
   apply (auto)
   apply (erule_tac x="y" in allE)
   apply (simp add: nres_lookup_def)
   apply (simp add: strong_disj_use_env_def)
   apply (erule_tac x="xa" in allE)
   apply (auto)
    (* by extension, x is not in 'h (send c v)' *)
  apply (cut_tac env="env" and ?r_s1.0="r_s1" and x="xa" in well_typed_no_npv_use)
    apply (auto)
  apply (simp add: non_prim_vars_def)
    (* the very last part is showing that x not in 'h (send c v)' implies x not in 'h ()'. *)
  apply (cut_tac x="xa" and h="h" and e="ConstExp UnitConst" in app_hole_free_vars_rev)
   apply (auto)
  apply (cut_tac x="xa" and h="h" and e="AppExp (AppExp (ConstExp SendConst) (VarExp x a)) v" in app_hole_free_vars2)
   apply (auto)
  done

lemma disj_lift_use_envr_rev: "\<lbrakk> strong_disj_use_env r_s r_x \<rbrakk> \<Longrightarrow> disj_use_env r_s (lift_use_env r_x r)"
  apply (simp add: strong_disj_use_env_def)
  apply (simp add: disj_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  apply (auto)
   apply (erule_tac x="x" in allE)
   apply (auto)
   apply (case_tac r)
     apply (auto)
  apply (erule_tac x="x" in allE)
  apply (auto)
  apply (case_tac r)
    apply (auto)
  done

lemma lift_strong_disj_use_env1: "\<lbrakk> strong_disj_use_env r_x r_s \<rbrakk> \<Longrightarrow> strong_disj_use_env (lift_use_env r_x r) r_s"
  apply (simp add: strong_disj_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (auto)
  apply (case_tac r)
    apply (auto)
  done

lemma send_disj_nres_map: "\<lbrakk> disj_nres_map p_map; p_map u1 = Some r_sa; p_map u2 = Some r_sb; is_own r;
  leq_use_env r_xa (lift_use_env r_sa r); leq_use_env r_xb (comp_use_env (lift_use_env r_sa r) (lift_use_env r_sb r));
  strong_disj_use_env r_xa r_xb \<rbrakk> \<Longrightarrow> disj_nres_map (add_env (add_env p_map u1 r_xa) u2 r_xb)"
  apply (rule_tac disj_add_nres_map)
   apply (rule_tac disj_add_nres_map)
    apply (simp)
    (* proving disjointness for the send thread's material *)
   apply (rule_tac r_s="lift_use_env r_sa r" in leq_sep_nres_map)
    apply (simp)
   apply (simp add: disj_nres_map_def)
   apply (simp add: sep_nres_map_def)
   apply (auto)
   apply (case_tac "x = u1")
    apply (simp add: nres_lookup_def)
    apply (simp add: rem_env_def)
    apply (rule_tac empty_strong_disj_use_env2)
   apply (rule_tac lift_strong_disj_use_env1)
   apply (erule_tac x="u1" in allE)
   apply (erule_tac x="x" in allE)
   apply (simp add: nres_lookup_def)
   apply (simp add: rem_env_def)
    (* proving disjointness for the recv thread *)
  apply (simp add: sep_nres_map_def)
  apply (auto)
  apply (case_tac "u2 = x")
   apply (simp add: nres_lookup_def)
   apply (simp add: rem_env_def)
   apply (rule_tac empty_strong_disj_use_env2)
  apply (case_tac "u1 = x")
   apply (simp add: nres_lookup_def)
   apply (simp add: rem_env_def)
   apply (simp add: add_env_def)
   apply (rule_tac comm_strong_disj_use_env)
   apply (simp)
  apply (simp add: nres_lookup_def)
  apply (simp add: rem_env_def)
  apply (simp add: add_env_def)
  apply (simp add: disj_nres_map_def)
  apply (rule_tac r_s="comp_use_env (lift_use_env r_sa r) (lift_use_env r_sb r)" in strong_disj_leq_use_env1)
   apply (rule_tac strong_disj_comp_use_env2)
    apply (rule_tac lift_strong_disj_use_env1)
    apply (erule_tac x="u1" in allE)
    apply (erule_tac x="x" in allE)
    apply (simp add: nres_lookup_def)
   apply (rule_tac lift_strong_disj_use_env1)
   apply (erule_tac x="u2" in allE)
   apply (erule_tac x="x" in allE)
   apply (simp add: nres_lookup_def)
  apply (simp)
  done

fun proper_hole where
  "proper_hole rs_map ExpHole = True"
| "proper_hole rs_map (AppHole1 h e) = (proper_hole rs_map h \<and> proper_exp rs_map e)"
| "proper_hole rs_map (AppHole2 v h) = (proper_exp rs_map v \<and> proper_hole rs_map h)"
| "proper_hole rs_map (IfHole h e1 e2) = (proper_hole rs_map h \<and> proper_exp rs_map e1 \<and> proper_exp rs_map e2)"
| "proper_hole rs_map (PairHole1 h e) = (proper_hole rs_map h \<and> proper_exp rs_map e)"
| "proper_hole rs_map (PairHole2 v h) = (proper_exp rs_map v \<and> proper_hole rs_map h)"

lemma proper_app_hole_split1: "\<lbrakk> proper_exp rs_map (app_hole h e) \<rbrakk> \<Longrightarrow> proper_hole rs_map h"
  apply (induct h)
       apply (auto)
            apply (simp_all add: proper_exp_def)
  done

lemma proper_app_hole_split2: "\<lbrakk> proper_exp rs_map (app_hole h e) \<rbrakk> \<Longrightarrow> proper_exp rs_map e"
  apply (induct h)
       apply (auto)
      apply (simp_all add: proper_exp_def)
  done

lemma proper_app_hole_recon: "\<lbrakk> proper_hole rs_map h; proper_exp rs_map e \<rbrakk> \<Longrightarrow> proper_exp rs_map (app_hole h e)"
  apply (induct h)
       apply (auto)
      apply (simp_all add: proper_exp_def)
  done

lemma proper_app_hole: "\<lbrakk> proper_exp rs_map (app_hole h e1); proper_exp rs_map e2 \<rbrakk> \<Longrightarrow> proper_exp rs_map (app_hole h e2)"
  apply (cut_tac rs_map="rs_map" and h="h" and e="e1" in proper_app_hole_split1)
   apply (auto)
  apply (rule_tac proper_app_hole_recon)
   apply (auto)
  done

lemma srps_send_case: "\<lbrakk>well_typed_system env rs_map p_map s2 ps1; valid_reduct app_red_exp; r_ax = SendAct;
        ps1 u1 = Some (app_hole h1 (AppExp (AppExp (ConstExp SendConst) (VarExp x_s a_s)) v));
        ps1 u2 = Some (app_hole h2 (AppExp (ConstExp RecvConst) (VarExp x_r a_r))); u1 \<noteq> u2; wf_hole h1;
        wf_hole h2; is_value v; a_s \<noteq> NoRef; a_r \<noteq> NoRef; s2 (deref_name x_s a_s) = Some ChanSValue;
        s2 (deref_name x_r a_r) = Some (ChanRValue (deref_name x_s a_s)); s1 = s2;
        ps2 = add_env (add_env ps1 u1 (app_hole h1 (ConstExp UnitConst))) u2 (app_hole h2 v)\<rbrakk>
       \<Longrightarrow> \<exists>r_s g_ax.
              (\<exists>p_map'. well_typed_system (red_env env g_ax) (red_nres_map rs_map g_ax) p_map' s2
                         (add_env (add_env ps1 u1 (app_hole h1 (ConstExp UnitConst))) u2 (app_hole h2 v))) \<and>
              safe_act s2 r_s g_ax"
      (* send case. no resources are generated in this step *)
  apply (rule_tac x="empty_use_env" in exI)
  apply (rule_tac x="NoResAct" in exI)
  apply (auto)
  apply (simp add: well_typed_system_def)
  apply (auto)
    (* we have to get the well-typedness statement for h1 [send c v] *)
  apply (case_tac "\<not> (case ps1 u1 of None \<Rightarrow> True | Some e \<Rightarrow> (case p_map u1 of None \<Rightarrow> False | Some r_s \<Rightarrow> \<exists>rx r_s2. well_typed env r_s e UnitTy r_s2 rx \<and> proper_exp rs_map e))")
   apply (simp add: well_typed_proc_set_def)
   apply (auto)
   apply (erule_tac x="u1" in allE)
   apply (erule_tac x="u1" in allE)
   apply (auto)
  apply (case_tac "p_map u1")
   apply (auto)
    (* we also get the well-typedness statement for h2 [recv c v] *)
  apply (case_tac "\<not> (case ps1 u2 of None \<Rightarrow> True | Some e \<Rightarrow> (case p_map u2 of None \<Rightarrow> False | Some r_s \<Rightarrow> \<exists>rx r_s2. well_typed env r_s e UnitTy r_s2 rx \<and> proper_exp rs_map e))")
   apply (simp add: well_typed_proc_set_def)
   apply (auto)
   apply (erule_tac x="u2" in allE)
   apply (erule_tac x="u2" in allE)
   apply (auto)
  apply (case_tac "p_map u2")
   apply (auto)
    (* next we get the send channel's type *)
  apply (case_tac "\<not> (\<exists> t. env (deref_name x_s a_s) = Some (ChanTy t SEnd))")
   apply (simp add: well_typed_state_def)
   apply (auto)
   apply (erule_tac x="deref_name x_s a_s" in allE)
   apply (auto)
   apply (case_tac "env (deref_name x_s a_s)")
    apply (auto)
    (* and the recv channel's type *)
  apply (case_tac "\<not> env (deref_name x_r a_r) = Some (ChanTy t REnd)")
   apply (simp add: well_typed_state_def)
   apply (auto)
   apply (erule_tac x="deref_name x_r a_r" in allE)
   apply (auto)
   apply (case_tac "env (deref_name x_r a_r)")
    apply (auto)
    (* prelim: we prove the dominator of v \<le> lift a r (the permission map of u1) *)
  apply (cut_tac eq_own)
  apply (auto)
  apply (cut_tac r_sc="np_dom_use_env env v" and r_sb="np_dom_use_env env (app_hole h1 (AppExp (AppExp (ConstExp SendConst) (VarExp x_s a_s)) v))"
      and r_sa="lift_use_env a r" in trans_leq_use_env)
    apply (rule_tac wt_np_leq_use_env)
     apply (auto)
   apply (simp add: np_dom_use_env_def)
   apply (rule_tac dist_dom_leq_use_env)
   apply (auto)
   apply (simp add: non_prim_vars_def)
   apply (rule_tac app_hole_free_vars)
   apply (auto)
    (* we can generate a type for h1 () *)
  apply (cut_tac env="env" and v="v" and ?r_s1.0="a" and tau="UnitTy" and h="h1" and ?r_s2.0="r_s2" and rx="rx" and s="s2" and rs_map="rs_map" in safe_send_exp)
        apply (auto)
    apply (simp add: well_typed_state_def)
    (* - complete proof that a is still valid *)
   apply (simp add: valid_exp_use_env_def)
   apply (simp add: well_typed_proc_set_def)
   apply (simp add: sub_nres_map_def)
   apply (erule_tac x="u1" in allE)
   apply (erule_tac x="u1" in allE)
   apply (simp add: nres_lookup_def)
    (* we can also generate a type for h2 v, first by getting a type for v, and then by putting it in the hole *)
  apply (cut_tac env="env" and v="v" and h="h1" and x="x_s" and a="a_s" and t="t" in safe_val_exp)
      apply (auto)
  apply (cut_tac env="env" and ?r_s1.0="aa" and h="h2" and r_x="np_dom_use_env env v" in safe_recv_exp)
          apply (auto)
    (* - p_map disjointness proves that the permissions being added are disjoint *)
    apply (rule_tac r_s="lift_use_env a r" in disj_leq_use_env2)
     apply (case_tac "\<forall>x y. x \<noteq> y \<longrightarrow> strong_disj_use_env (nres_lookup p_map x) (nres_lookup p_map y)")
      apply (erule_tac x="u1" in allE)
      apply (erule_tac x="u2" in allE)
      apply (erule_tac x="u1" in allE)
      apply (auto)
     apply (simp add: nres_lookup_def)
     apply (rule_tac disj_lift_use_envr_rev)
     apply (simp)
    apply (simp add: well_typed_proc_set_def)
    apply (simp add: disj_nres_map_def)
    (* - proving the dominator is strong *)
   apply (simp add: np_dom_use_env_def)
   apply (rule_tac strong_dom_use_env)
    (* lastly it remains to prove the new process map is well-formed *)
  apply (rule_tac x="add_env (add_env p_map u1 (diff_use_env a (full_dom_use_env env rs_map v)))
    u2 (comp_use_env aa (np_dom_use_env env v))" in exI)
  apply (simp add: well_typed_proc_set_def)
  apply (auto)
    (* completeness *)
      apply (rule_tac add_full_nres_map)
      apply (rule_tac add_full_nres_map)
      apply (simp)
    (* disjointness, assisted by lemma *)
     apply (rule_tac r_sa="a" and r_sb="aa" in send_disj_nres_map)
           apply (simp_all)
       apply (rule_tac diff_leq_use_env)
       apply (rule_tac self_lift_leq_use_env)
      apply (rule_tac dist_comp_leq_use_env)
       apply (rule_tac comp_leq_use_env2)
       apply (rule_tac self_lift_leq_use_env)
      apply (rule_tac comp_leq_use_env1)
      apply (simp)
     apply (rule_tac strong_disj_comp_use_env1)
      apply (rule_tac r_s="a" in strong_disj_leq_use_env1)
       apply (simp add: disj_nres_map_def)
       apply (erule_tac x="u1" in allE)
       apply (erule_tac x="u1" in allE)
       apply (erule_tac x="u1" in allE)
       apply (erule_tac x="u2" in allE)
       apply (simp add: nres_lookup_def)
      apply (rule_tac self_diff_leq_use_env)
     apply (rule_tac r_s="full_dom_use_env env rs_map v" in strong_disj_leq_use_env2)
      apply (rule_tac diff_strong_disj_use_env)
      apply (simp add: full_dom_use_env_def)
      apply (rule_tac strong_dom_use_env)
     apply (rule_tac full_dom_leq_use_env)
    (* proving that the processes are well-typed *)
    apply (case_tac "u = u1")
     apply (simp add: add_env_def)
     apply (auto)
     apply (rule_tac proper_app_hole)
      apply (simp)
     apply (simp add: proper_exp_def)
    apply (case_tac "u = u2")
     apply (simp add: add_env_def)
     apply (auto)
     apply (rule_tac proper_app_hole)
      apply (simp)
     apply (cut_tac rs_map="rs_map" and h="h1" and e="AppExp (AppExp (ConstExp SendConst) (VarExp x_s a_s)) v" in proper_app_hole_split2)
      apply (simp)
     apply (simp add: proper_exp_def)
    apply (simp add: add_env_def)
    apply (erule_tac x="u" in allE)
    apply (erule_tac x="u" in allE)
    apply (case_tac "ps1 u")
     apply (auto)
    apply (simp add: add_env_def)
    (* proving res_map element containment *)
   apply (rule_tac add_sub_nres_map1)
    apply (rule_tac add_sub_nres_map1)
     apply (simp)
    apply (rule_tac r_s="a" in trans_sub_use_env)
     apply (simp add: sub_nres_map_def)
     apply (erule_tac x="u1" in allE)
     apply (simp add: nres_lookup_def)
    apply (rule_tac self_diff_leq_use_env)
   apply (rule_tac comp_sub_use_env)
    apply (simp add: sub_nres_map_def)
    apply (erule_tac x="u2" in allE)
    apply (simp add: nres_lookup_def)
   apply (rule_tac r_s="lift_use_env a r" in trans_sub_use_env)
    apply (rule_tac lift_sub_use_env)
    apply (simp add: sub_nres_map_def)
    apply (erule_tac x="u1" in allE)
    apply (simp add: nres_lookup_def)
   apply (simp)
    (* poriving the separation of the new maps *)
  apply (case_tac "u = u1")
   apply (simp add: add_env_def)
   apply (rule_tac r_s="a" in leq_sep_nres_map)
    apply (rule_tac self_diff_leq_use_env)
   apply (erule_tac x="u1" in allE)
   apply (auto)
  apply (case_tac "u = u2")
   apply (simp add: add_env_def)
   apply (rule_tac comp_sep_nres_map)
    apply (erule_tac x="u2" in allE)
    apply (auto)
   apply (erule_tac x="u1" in allE)
   apply (auto)
   apply (rule_tac r_s="lift_use_env a r" in leq_sep_nres_map)
    apply (simp)
   apply (simp add: sep_nres_map_def)
    apply (auto)
   apply (rule_tac lift_strong_disj_use_env1)
   apply (simp)
  apply (simp add: add_env_def)
  done

end


section\<open>Simple Firewall Syntax\<close>
theory SimpleFw_Syntax
imports "../IP_Addresses/Hs_Compat"
        Firewall_Common_Decision_State
        "Primitives/Iface"
        "Primitives/L4_Protocol"
        "Simple_Packet"
begin

  text\<open>For for IP addresses of arbitrary length\<close>

  datatype simple_action = Accept | Drop

  text\<open>Simple match expressions do not allow negated expressions.
        However, Most match expressions can still be transformed into simple match expressions.

        A negated IP address range can be represented as a set of non-negated IP ranges.
        For example @{text "!8 = {0..7} \<union> {8 .. ipv4max}"}.
        Using CIDR notation (i.e. the @{text "a.b.c.d/n"} notation), we can represent negated IP
        ranges as a set of non-negated IP ranges with only fair blowup.
        Another handy result is that the conjunction of two IP ranges in CIDR notation is
        either the smaller of the two ranges or the empty set.
        An empty IP range cannot be represented.
        If one wants to represent the empty range, then the complete rule needs to be removed.

        The same holds for layer 4 ports.
        In addition, there exists an empty port range, e.g. @{text "(1,0)"}.
        The conjunction of two port ranges is again just one port range.

        But negation of interfaces is not supported. Since interfaces support a wildcard character,
        transforming a negated interface would either result in an infeasible blowup or requires
        knowledge about the existing interfaces (e.g. there only is eth0, eth1, wlan3, and vbox42)
        An empirical test shows that negated interfaces do not occur in our data sets.
        Negated interfaces can also be considered bad style: What is !eth0? Everything that is
        not eth0, experience shows that interfaces may come up randomly, in particular in combination
        with virtual machines, so !eth0 might not be the desired match.
        At the moment, if an negated interface occurs which prevents translation to a simple match,
        we recommend to abstract the negated interface to unknown and remove it (upper or lower closure
        rule set) before translating to a simple match.
        The same discussion holds for negated protocols.

        Noteworthy, simple match expressions are both expressive and support conjunction:
        @{text "simple-match1 \<and> simple-match2 = simple-match3"}
\<close>
        (*It took very long to design the simple match such that it can represent everything we need
        and that you can calculate with it. Disjunction is easy: just have two consecutive rules with the same action.
        Conjunction was a tough fight! It is needed to translate:
        common_primitive_match_to_simple_match (MatchAny e1 e2) =
          simple_match_and (common_primitive_match_to_simple_match e1) (common_primitive_match_to_simple_match e2)
        This is key to translate common_primitive_match to simple_match

        It may seem a simple enhancement to support iiface :: "iface negation_type", but then you
        can no longer form the conjunction of two simple_matches.
        *)

  record (overloaded) 'i simple_match =
    iiface :: "iface" --"in-interface"
      (*we cannot (and don't want to) express negated interfaces*)
      (*We could also drop interface wildcard support and try negated interfaces again \<dots>*)
    oiface :: "iface" --"out-interface"
    src :: "('i::len word \<times> nat) " --"source IP address"
    dst :: "('i::len word \<times> nat) " --"destination"
    proto :: "protocol"
    sports :: "(16 word \<times> 16 word)" --"source-port first:last"
    dports :: "(16 word \<times> 16 word)" --"destination-port first:last"

  context
    notes [[typedef_overloaded]]
  begin
    datatype 'i simple_rule = SimpleRule (match_sel: "'i simple_match") (action_sel: simple_action)
  end

text\<open>Simple rule destructor. Removes the @{typ "'a simple_rule"} type, returns a tuple with the match and action.\<close>
  definition simple_rule_dtor :: "'a simple_rule \<Rightarrow> 'a simple_match \<times> simple_action" where
    "simple_rule_dtor r \<equiv> (case r of SimpleRule m a \<Rightarrow> (m,a))"

  lemma simple_rule_dtor_ids:
    "uncurry SimpleRule \<circ> simple_rule_dtor = id"
    "simple_rule_dtor \<circ> uncurry SimpleRule = id"
    unfolding simple_rule_dtor_def comp_def fun_eq_iff
    by(simp_all split: simple_rule.splits)

end


(*
 * Copyright 2014, NICTA
 *
 * 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_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory signed_div
imports "CParser.CTranslation"
begin

external_file "signed_div.c"
install_C_file "signed_div.c"

context signed_div
begin

lemma f_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL f(5, -1) \<lbrace> \<acute>ret__int = -5 \<rbrace>"
  apply vcg
  apply (clarsimp simp: sdiv_word_def sdiv_int_def)
  done

lemma f_overflow:
  shows "\<lbrakk> a_' s = of_int (- (2^31)); b_' s = -1 \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> \<langle> Call f_'proc ,Normal s\<rangle> \<Rightarrow> Fault SignedArithmetic"
  apply (rule exec.Call [where \<Gamma>=\<Gamma>, OF f_impl, simplified f_body_def creturn_def])
  apply (rule exec.CatchMiss)
  apply (subst exec.simps, clarsimp simp del: word_neq_0_conv simp: sdiv_word_def sdiv_int_def)+
  apply simp
  done

lemma g_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL g(-5, 10) \<lbrace> \<acute>ret__int = -5 \<rbrace>"
  apply vcg
  apply (clarsimp simp: smod_word_def smod_int_def sdiv_int_def)
  done

lemma h_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL h(5, -1) \<lbrace> \<acute>ret__int = 0 \<rbrace>"
  apply vcg
  apply (simp add: word_div_def uint_word_ariths)
  done

(* FIXME: f! *)
lemma i_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL f(5, -1) \<lbrace> \<acute>ret__int = -5 \<rbrace>"
  apply vcg
  apply (clarsimp simp: sdiv_word_def sdiv_int_def)
  done

end

end


theory Remdups
  imports
    MoreCurrAutomation
 (* "../Refine_Imperative_HOL/Sepref"
    "../Refine_Imperative_HOL/IICF/Impl/IICF_Rbt_Set"
    "../Refine_Imperative_HOL/IICF/Impl/IICF_DArray_List"
    "NREST.RefineMonadicVCG"
    "../Refine_Foreach" *)
(*    "Imperative_HOL_Time.SLTC" *)
  "Automatic_Refinement.Autoref_Tagging"
    "Imperative_HOL_Time.IHT_Red_Black_Tree"
    Monadic_Operations
begin

hide_const R B

term Autoref_Tagging.APP

definition "rd_inv as \<equiv> (\<lambda>(xs,ys,S). (\<exists>zs. as = zs@xs \<and> S = set ys \<and> distinct ys \<and> set zs = set ys))"

datatype RD_curr = RBT_search | RBT_insert | REST

instantiation RD_curr :: enum
begin
definition "enum_RD_curr = [RBT_search, RBT_insert, REST]"
definition "enum_all_RD_curr P = (P RBT_search \<and> P RBT_insert \<and> P REST)"
definition "enum_ex_RD_curr P = (P RBT_search \<or> P RBT_insert \<or> P REST)"
instance apply standard apply (auto simp: enum_RD_curr_def enum_ex_RD_curr_def enum_all_RD_curr_def)
  subgoal for x apply (cases x) by auto
  subgoal for P x apply (cases x) by auto
  subgoal for P x apply (cases x) by auto
  done
end

definition body_time :: "nat \<Rightarrow> (RD_curr \<Rightarrow> nat)" where
  "body_time n = (\<lambda>_.0)(REST := 60, RBT_search := 1+rbt_search_time_logN (n+1), RBT_insert := rbt_insert_logN (n+1))"
definition body_time_abs :: "(RD_curr \<Rightarrow> nat)" where
  "body_time_abs = (\<lambda>_.0)(REST := 60, RBT_search := 1, RBT_insert := 1)"

definition "rd_ta as = (\<lambda>(xs,ys,S). (\<lambda>x. length xs * body_time (length as) x) )"
definition "rd_ta_abs = (\<lambda>(xs,ys,S). (\<lambda>x. length xs * body_time_abs x) )"

definition rd_impl1 :: "('a::{linorder}) list \<Rightarrow> ('a list, _ ) nrest" where
"rd_impl1 as = do {
  ys \<leftarrow> mop_empty_list (\<lambda>_. (\<lambda>_.0)(REST:=enat 12));
  S \<leftarrow> mop_set_empty (\<lambda>_. (\<lambda>_.0)(REST:=1));
  zs \<leftarrow> RETURNT as;
  (zs,ys,S) \<leftarrow> whileIET (rd_inv as) (rd_ta_abs) (\<lambda>(xs,ys,S). length xs > 0) (\<lambda>(xs,ys,S). do {
    ASSERT (length xs > 0);
    ASSERT (length xs + length ys \<le> length as);
    ASSERT (card S \<le> length ys);
    x \<leftarrow> RETURNT (hd xs);
    xs \<leftarrow> RETURNT (tl xs);
    b \<leftarrow> mop_set_member (\<lambda>_. (\<lambda>_.0)(RBT_search:=1) ) x S;
    if b then
      RETURNT (xs,ys,S)
    else do {
      S \<leftarrow> mop_set_insert (\<lambda>_. (\<lambda>_.0)(RBT_insert:=1) ) x S;
      ys \<leftarrow> mop_push_list (\<lambda>_. (\<lambda>_.0)(REST:=  23) ) x ys;
      RETURNT (xs,ys,S)
    }
  }) (zs,ys,S);
  RETURNT ys
  }"

definition "remdups_time (n::nat) = (\<lambda>x. n * body_time n x ) + (\<lambda>_.0)(REST:=20)"
definition "remdups_time_abs (n::nat) = (\<lambda>x. n * body_time_abs x ) + (\<lambda>_.0)(REST:=20)"

definition "remdups_spec_abs as = SPECT (emb (\<lambda>ys. set as = set ys \<and> distinct ys)
                   ( remdups_time_abs (length as) ))"
definition "remdups_spec as = SPECT (emb (\<lambda>ys. set as = set ys \<and> distinct ys)
                   ( remdups_time (length as) ))"

fun RR where
  "RR n REST REST = 1"
| "RR n RBT_search RBT_search = 1+rbt_search_time_logN (n+1)"
| "RR n RBT_insert RBT_insert = rbt_insert_logN (n+1)"
| "RR n _ _  = 0"

lemma timerefine_SPECT_conv:
  "timerefine R (SPECT M) = SPECT (\<lambda>r. case M r of None \<Rightarrow> None |
                  Some cm \<Rightarrow> Some (\<lambda>cc. Sum_any (\<lambda>ac. cm ac * R ac cc)))"
  unfolding timerefine_def  by auto

lemma timerefine_SPECT_emb':
  "timerefine F (SPECT (emb' P TT)) = SPECT (emb' P (\<lambda>r cc. Sum_any (\<lambda>ac. TT r ac * F ac cc)))"
  unfolding timerefine_def  apply auto
  unfolding emb'_def apply(rule ext) by simp

lemma emb'_eqI: "P=P' \<Longrightarrow> X=X' \<Longrightarrow> emb' P X = emb' P' X'" unfolding emb'_def by auto
lemma "remdups_spec as = timerefine (RR (length as)) (remdups_spec_abs as)"
  unfolding remdups_spec_abs_def apply(simp only: timerefine_SPECT_emb')
  unfolding remdups_spec_def apply simp
  apply(rule emb'_eqI) apply simp
  apply(rule ext)+
  apply(auto simp: remdups_time_def remdups_time_abs_def body_time_def body_time_abs_def)
     apply (simp_all add: Sum_any_to_foldr enum_RD_curr_def)
  apply (auto split: RD_curr.splits)
  subgoal for x apply (cases x) by auto
  subgoal for x apply (cases x) by auto
  subgoal for x apply (cases x) by auto
  done

lemma finer: "remdups_spec as = timerefine (RR (length as)) (remdups_spec_abs as)"
  unfolding remdups_spec_def remdups_spec_abs_def timerefine_def
      remdups_time_def remdups_time_abs_def body_time_def body_time_abs_def
  apply auto apply(rule ext)
  unfolding emb'_def apply auto
  apply(rule ext) apply auto
  apply (simp only: Sum_any_to_foldr enum_RD_curr_def) apply simp
  apply (simp only: Sum_any_to_foldr enum_RD_curr_def) apply simp
  apply (simp only: Sum_any_to_foldr enum_RD_curr_def) apply simp
  apply (simp only: Sum_any_to_foldr enum_RD_curr_def) apply auto
  subgoal for r x apply (cases x) by auto
  subgoal for r x apply (cases x) by auto
  subgoal for r x apply (cases x) by auto
  done

lemma enat_neq_Z_iff[simp]: "enat x \<noteq> 0 \<longleftrightarrow> x\<noteq>0"
  by (auto simp: zero_enat_def)

lemma rd_impl1_correct: "rd_impl1 as \<le> remdups_spec_abs as"
  unfolding remdups_spec_abs_def
  unfolding rd_impl1_def mop_empty_list_def mop_set_empty_def
      mop_set_member_def mop_set_insert_def mop_push_list_def
      rd_ta_abs_def rd_inv_def
  apply(rule T_g_specifies_I)
  apply (vcg' \<open>simp\<close> )
    unfolding Some_le_emb'_conv
  supply [simp] = neq_Nil_conv distinct_length_le card_length
        apply (auto simp:
              Some_le_mm3_Some_conv numeral_eq_enat
          body_time_abs_def one_enat_def remdups_time_abs_def plus_enat_simps intro!: le_funI)
    subgoal
      by (meson list.set_cases)
    done

subsection \<open>do the overapproximation in the code, prove it during synthesis\<close>

definition rd_impl2 :: "('a::{linorder}) list \<Rightarrow> ('a list, _ ) nrest" where
"rd_impl2 as = do {
  ys \<leftarrow> mop_empty_list (\<lambda>_. (\<lambda>_.0)(REST:=enat 12));
  S \<leftarrow> mop_set_empty (\<lambda>_. (\<lambda>_.0)(REST:=1));
  zs \<leftarrow> RETURNT as;
  (zs,ys,S) \<leftarrow> whileIET (rd_inv as) (rd_ta_abs) (\<lambda>(xs,ys,S). length xs > 0) (\<lambda>(xs,ys,S). do {
    ASSERT (length xs > 0);
    ASSERT (length xs + length ys \<le> length as);
    ASSERT (card S \<le> length ys);
    x \<leftarrow> RETURNT (hd xs);
    xs \<leftarrow> RETURNT (tl xs);
    b \<leftarrow> mop_set_member (\<lambda>_. (\<lambda>_.0)(RBT_search:=1+rbt_search_time_logN (length as + 1)) ) x S;
    if b then
      RETURNT (xs,ys,S)
    else do {
      S \<leftarrow> mop_set_insert (\<lambda>_. (\<lambda>_.0)(RBT_insert:=rbt_insert_logN (length as + 1)) ) x S;
      ys \<leftarrow> mop_push_list (\<lambda>_. (\<lambda>_.0)(REST:=  23) ) x ys;
      RETURNT (xs,ys,S)
    }
  }) (zs,ys,S);
  RETURNT ys
  }"

lemma timerefine_RETURNT_conv: "timerefine R (RETURNT x) = RETURNT x"
  unfolding timerefine_def RETURNT_def apply auto apply(rule ext) by auto

lemma AA: "rd_impl2 as \<le> \<Down>Id (timerefine (RR (length as)) (rd_impl1 as))"
  unfolding rd_impl2_def rd_impl1_def
  apply(rule bindT_refine_g[where R'=Id])
  subgoal unfolding mop_empty_list_def timerefine_SPECT_conv
    by (auto intro!: le_funI simp: Sum_any_to_foldr enum_RD_curr_def)
  subgoal
    apply(rule bindT_refine_g[where R'=Id])
    subgoal unfolding mop_set_empty_def timerefine_SPECT_conv
      by (auto intro!: le_funI simp: one_enat_def Sum_any_to_foldr enum_RD_curr_def)
    subgoal
      apply(rule bindT_refine_g[where R'=Id])
      subgoal by (simp add: timerefine_RETURNT_conv)
      subgoal
        apply(rule bindT_refine_g[where R'=Id])
        subgoal
          unfolding whileIET_def
          apply(rule WHILET_refine)
          subgoal by simp
          subgoal by simp
          subgoal
            apply(rule Case_prod_refine[of _ _ Id Id]) apply simp
            apply(rule Case_prod_refine[of _ _ Id Id]) apply simp
            apply(rule le_ASSERTI_g2)+
            apply(rule ASSERT_leI2) apply simp
            apply(rule ASSERT_leI2) apply simp
            apply(rule ASSERT_leI2) apply simp
            apply(rule bindT_refine_g[where R'=Id])
            subgoal by (simp add: timerefine_RETURNT_conv)
            subgoal
              apply(rule bindT_refine_g[where R'=Id])
              subgoal by (simp add: timerefine_RETURNT_conv)
              subgoal
                apply(rule bindT_refine_g[where R'=Id])
                subgoal unfolding mop_set_member_def timerefine_SPECT_conv
                  by (auto intro!: le_funI simp: Sum_any_to_foldr enum_RD_curr_def)
                subgoal
                  apply(rule If_refine)
                  subgoal by simp
                  subgoal by (simp add: timerefine_RETURNT_conv)
                  subgoal
                    apply(rule bindT_refine_g[where R'=Id])
                    subgoal  unfolding mop_set_insert_def timerefine_SPECT_conv
                      by (auto intro!: le_funI simp: Sum_any_to_foldr enum_RD_curr_def)
                    subgoal
                      apply(rule bindT_refine_g[where R'=Id])
                      subgoal unfolding mop_push_list_def timerefine_SPECT_conv
                        by (auto intro!: le_funI simp: Sum_any_to_foldr numeral_eq_enat enum_RD_curr_def)
                      subgoal  by (simp add: timerefine_RETURNT_conv)
                      done
                    done
                  done
                done
              done
            done
          done
        subgoal
          apply simp apply(rule case_prod_refine_g)
           apply(rule case_prod_refine_g)
          by (simp add: timerefine_RETURNT_conv)
        done
      done
    done
  done

thm rd_impl1_correct AA finer

lemma "rd_impl2 as \<le> remdups_spec as"
proof -
  have "rd_impl2 as \<le> \<Down>Id (timerefine (RR (length as)) (rd_impl1 as))"
    by (fact AA)
  also have "\<dots> \<le> \<Down>Id (timerefine (RR (length as)) (remdups_spec_abs as))"
    apply(rule nrest_Rel_mono)
    apply(rule timerefine_mono)
    subgoal sorry
    subgoal by(fact rd_impl1_correct)
    done
  also have "\<dots> = remdups_spec as"
    apply(fold finer) apply simp done
  finally show ?thesis .
qed

subsection \<open>dont to the overapproximation in the code, do it in the proof\<close>

definition rd_impl3 :: "('a::{linorder}) list \<Rightarrow> ('a list, _ ) nrest" where
"rd_impl3 as = do {
  ys \<leftarrow> mop_empty_list (\<lambda>_. (\<lambda>_.0)(():=enat 12));
  S \<leftarrow> mop_set_empty (\<lambda>_. (\<lambda>_.0)(():=1));
  zs \<leftarrow> RETURNT as;
  (zs,ys,S) \<leftarrow> whileT (\<lambda>(xs,ys,S). length xs > 0) (\<lambda>(xs,ys,S). do {
    ASSERT (length xs > 0);
    x \<leftarrow> RETURNT (hd xs);
    xs \<leftarrow> RETURNT (tl xs);
    ASSERT (card S \<le> length as);
    b \<leftarrow> mop_set_member (\<lambda>(x,S). (\<lambda>_.0)(():= 1 + rbt_search_time_logN (card S + 1)) ) x S;
    if b then
      RETURNT (xs,ys,S)
    else do {
      ASSERT (card S \<le> length as);
      S \<leftarrow> mop_set_insert (\<lambda>(x,S). (\<lambda>_.0)(() := rbt_insert_logN (card S + 1)) ) x S;
      ys \<leftarrow> mop_push_list (\<lambda>_. (\<lambda>_.0)(():=  23) ) x ys;
      RETURNT (xs,ys,S)
    }
  }) (zs,ys,S);
  RETURNT ys
  }"

fun RR2 where
  "RR2 n REST () = 1"
| "RR2 n RBT_search () = 1+rbt_search_time_logN (n+1)"
| "RR2 n RBT_insert () = rbt_insert_logN (n+1)"

lemma BB: "rd_impl3 as \<le> \<Down>Id (timerefine (RR2 (length as)) (rd_impl1 as))"
  unfolding rd_impl3_def rd_impl1_def
  apply(rule bindT_refine_g[where R'=Id])
  subgoal unfolding mop_empty_list_def timerefine_SPECT_conv
    by (auto intro!: le_funI simp: Sum_any_to_foldr enum_RD_curr_def)
  subgoal
    apply(rule bindT_refine_g[where R'=Id])
    subgoal unfolding mop_set_empty_def timerefine_SPECT_conv
      by (auto intro!: le_funI simp: one_enat_def Sum_any_to_foldr enum_RD_curr_def)
    subgoal
      apply(rule bindT_refine_g[where R'=Id])
      subgoal by (simp add: timerefine_RETURNT_conv)
      subgoal
        apply(rule bindT_refine_g[where R'=Id])
        subgoal
          unfolding whileIET_def
          apply(rule WHILET_refine)
          subgoal by simp
          subgoal by simp
          subgoal
            apply(rule Case_prod_refine[of _ _ Id Id]) apply simp
            apply(rule Case_prod_refine[of _ _ Id Id]) apply simp
            apply(rule le_ASSERTI_g2)+
            apply(rule ASSERT_leI2) apply simp
            apply(rule bindT_refine_g[where R'=Id])
            subgoal by (simp add: timerefine_RETURNT_conv)
            subgoal
              apply(rule bindT_refine_g[where R'=Id])
              subgoal by (simp add: timerefine_RETURNT_conv)
              subgoal
                apply(rule ASSERT_leI2) apply simp
                apply(rule bindT_refine_g[where R'=Id])
                subgoal unfolding mop_set_member_def timerefine_SPECT_conv
                  by (auto intro!: le_funI  rbt_search_time_logN_mono simp:  Sum_any_to_foldr enum_RD_curr_def)
                subgoal
                  apply(rule If_refine)
                  subgoal by simp
                  subgoal by (simp add: timerefine_RETURNT_conv)
                  subgoal
                    apply(rule ASSERT_leI2) apply simp
                    apply(rule bindT_refine_g[where R'=Id])
                    subgoal  unfolding mop_set_insert_def timerefine_SPECT_conv
                      by (auto intro!: le_funI rbt_insert_logN_mono  simp: Sum_any_to_foldr enum_RD_curr_def)
                    subgoal
                      apply(rule bindT_refine_g[where R'=Id])
                      subgoal unfolding mop_push_list_def timerefine_SPECT_conv
                        by (auto intro!: le_funI simp: Sum_any_to_foldr numeral_eq_enat enum_RD_curr_def)
                      subgoal  by (simp add: timerefine_RETURNT_conv)
                      done
                    done
                  done
                done
              done
            done
          done
        subgoal
          apply simp apply(rule case_prod_refine_g)
           apply(rule case_prod_refine_g)
          by (simp add: timerefine_RETURNT_conv)
        done
      done
    done
  done

definition "TT_time n = 61 * n +
               (20 + (n * rbt_insert_logN (Suc (n))
                   + n * rbt_search_time_logN (Suc n)))"

lemma TT: "timerefine (RR2 (length as)) (remdups_spec_abs as) =
    SPECT
     (emb (\<lambda>ys. set as = set ys \<and> distinct ys)
       (\<lambda>cc. enat
              (TT_time (length as))))"
  unfolding remdups_spec_abs_def remdups_time_abs_def body_time_abs_def
  apply(subst timerefine_SPECT_emb')
  by(simp add: TT_time_def Sum_any_to_foldr numeral_eq_enat enum_RD_curr_def)

lemma rd_impl3_correct: "rd_impl3 as \<le> SPECT (emb (\<lambda>ys. set as = set ys \<and> distinct ys)
                   ( \<lambda>_. TT_time (length as) ))" (is "?L \<le> ?R")
proof -
  term ?R
  have "rd_impl3 as \<le> \<Down>Id (timerefine (RR2 (length as)) (rd_impl1 as))"
    by (fact BB)
  also have "\<dots> \<le> \<Down>Id (timerefine (RR2 (length as)) (remdups_spec_abs as))"
    apply(rule nrest_Rel_mono)
    apply(rule timerefine_mono)
    subgoal sorry
    subgoal by(fact rd_impl1_correct)
    done
  also have "\<dots> = SPECT (emb (\<lambda>ys. set as = set ys \<and> distinct ys)
                   ( \<lambda>_. TT_time (length as) ))"
     unfolding TT by simp
  finally show ?thesis .
qed

(*
lemma remdups_time_nln[asym_bound]: "remdups_time \<in> \<Theta>(\<lambda>n. n * ln n)"
  unfolding remdups_time_def body_time_def
  by auto2
*)

(*
section \<open>HNR\<close>

type_synonym IHT_curr = unit

definition hn_refine :: "assn \<Rightarrow> 'a Heap \<Rightarrow> assn \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> assn) \<Rightarrow> ('b, _) nrest \<Rightarrow> bool"
  where  "hn_refine \<Gamma> c \<Gamma>' R m \<equiv> nofailT m \<longrightarrow>
    (\<forall>h as  n   M. pHeap h as n \<Turnstile> \<Gamma>  \<longrightarrow> m = SPECT M \<longrightarrow>
    (\<exists>h' t r. execute c h = Some (r, h', t) \<and>
       (\<exists>ra (Ca::nat). M ra \<ge> Some (\<lambda>_. enat Ca)  \<and> n+Ca\<ge>t
           \<and> pHeap h' (new_addrs h as h') ((n+Ca)-t) \<Turnstile> \<Gamma>' * R ra r * true
          )
       \<and> relH {a . a < Heap.lim h \<and> a \<notin> as} h h' \<and> Heap.lim h \<le> Heap.lim h'))"

lemma extract_cost_ub:
  assumes "hn_refine \<Gamma> c \<Gamma>' R (SPECT M)" "(\<And>c. c\<in>ran M \<Longrightarrow> c () \<le> Cost_ub)"
  shows "<\<Gamma> * timeCredit_assn Cost_ub> c <\<lambda>r. \<Gamma>' * (\<exists>\<^sub>Ara. R ra r * \<up>(ra \<in> dom M)) >\<^sub>t"
  using assms(1)  unfolding hn_refine_def
  unfolding hoare_triple_def
  apply clarify
proof (goal_cases)
  case (1 h as \<sigma> r n t)
  from 1(2) have 2: "pHeap h as (n-Cost_ub) \<Turnstile> \<Gamma>" and  nf: "n\<ge>Cost_ub"
    using mod_timeCredit_dest by auto

  from 1(1) have 3: "\<And>h as n Ma.
       pHeap h as n \<Turnstile> \<Gamma> \<Longrightarrow>
      SPECT M = SPECT Ma \<Longrightarrow> (\<exists>h' t r. execute c h = Some (r, h', t) \<and>
       (\<exists>ra Ca. Ma ra \<ge> Some (\<lambda>_. enat Ca) \<and> t \<le> n + Ca \<and> pHeap h' (new_addrs h as h') ((n + Ca) - t) \<Turnstile> \<Gamma>' * R ra r * true) \<and>
      relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h')"
    by auto

  thm effect_deterministic

  from 3[OF 2 ] obtain h' t' r' where E: "execute c h = Some (r', h', t') " and
    R:  "(\<exists>ra Ca. M ra \<ge> Some (\<lambda>_. enat Ca) \<and>
                    pHeap h' (new_addrs h as h') (n - Cost_ub + Ca - t') \<Turnstile> \<Gamma>' * R ra r' * true \<and> t' \<le> n - Cost_ub + Ca) \<and>
           relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h'" by blast

  have F: "\<sigma> = Some h'" and prime: "r' = r" "t' = t"
    using E 1(3) run.cases apply force
    using E 1(3) run.cases apply force
    using E 1(3) run.cases by force
  then have sig: "the \<sigma> = h'" by auto
  from R  have
    B: "(\<exists>ra Ca. M ra \<ge> Some (\<lambda>_. enat Ca) \<and>
     pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - Cost_ub + Ca - t) \<Turnstile> \<Gamma>' * R ra r * true \<and>
        t \<le> n - Cost_ub + Ca )" and C:
    "relH {a. a < heap.lim h \<and> a \<notin> as} h (the \<sigma>)" "heap.lim h \<le> heap.lim (the \<sigma>) "
    unfolding prime sig by auto

  from B obtain ra Ca where i: "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - Cost_ub + Ca - t) \<Turnstile> \<Gamma>' * R ra r * true"
    and ii:  "t \<le> n - Cost_ub + Ca"  and ineq: "M ra \<ge> Some (\<lambda>_. enat Ca)"
    using B by auto

  from ineq have radom: "ra \<in> dom M" using domIff by fastforce
  then obtain Mra where Mra: "M ra = Some Mra" by blast
  with assms(2) have *: "Mra () \<le> enat Cost_ub" by (meson ranI)
  {
    have " Some (\<lambda>_. enat Ca) \<le> M ra" by (fact ineq)
    also have "\<dots> = Some Mra" using Mra by simp
    also have "\<dots> \<le> Some (\<lambda>_. enat Cost_ub)" apply simp apply(rule le_funI) using * by simp
    finally have "Some (\<lambda>_::unit. enat Ca) \<le> Some (\<lambda>_. enat Cost_ub)" .
    then have "Ca \<le> Cost_ub" by (auto simp: le_fun_def)
  } note ie=this

  have pr: "(n - Cost_ub + Ca - t) = (n - t) - (Cost_ub - Ca)" using ie ii nf by auto
  have pl: "(n - (t + (Cost_ub - Ca)) + (Cost_ub - Ca)) = n-t" using ii nf by auto

  have "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>) \<union> {}) ((n - t) - (Cost_ub - Ca) + (Cost_ub - Ca)) \<Turnstile> \<Gamma>' * R ra r * true * true"
    apply(rule mod_star_convI)  apply simp
     apply(rule i[unfolded pr])  by (simp add: top_assn_rule)

  then have H: "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> \<Gamma>' * R ra r * true * true"
    by (simp add: pl)

  have "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> \<Gamma>' * R ra r * \<up> (ra \<in> dom M) * true"
    apply(rule entailsD[OF _ H]) using radom by auto2
  then have "\<exists>ra. pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> \<Gamma>' * R ra r * \<up> (ra \<in> dom M) * true"
    by blast
  then have H': "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> (\<exists>\<^sub>Ara. \<Gamma>' *  R ra r * \<up> (ra \<in> dom M) * true)"
    using mod_ex_dist by blast
  have H: "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> \<Gamma>' * (\<exists>\<^sub>Ara. R ra r * \<up> (ra \<in> dom M)) * true"
    apply(rule entailsD[OF _ H']) by auto2

  from ii ie nf have T: "t \<le> n " by auto

  show ?case
    apply safe
    subgoal using F by auto
    subgoal using H by simp
    subgoal by fact
     apply fact apply fact done
qed

*)

end


(*  Title:      JinjaThreads/Common/SemiType.thy
    Author:     Tobias Nipkow, Gerwin Klein, Andreas Lochbihler
*)

header {*
  \isaheader{The Jinja Type System as a Semilattice}
*}

theory SemiType
imports
  WellForm
  "../DFA/Semilattices"
begin

inductive_set
  widen1 :: "'a prog \<Rightarrow> (ty \<times> ty) set"
  and widen1_syntax :: "'a prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ <\<^sup>1 _" [71,71,71] 70)
  for P :: "'a prog"
where
  "P \<turnstile> C <\<^sup>1 D \<equiv> (C, D) \<in> widen1 P"

| widen1_Array_Object:
  "P \<turnstile> Array (Class Object) <\<^sup>1 Class Object"

| widen1_Array_Integer:
  "P \<turnstile> Array Integer <\<^sup>1 Class Object"

| widen1_Array_Boolean:
  "P \<turnstile> Array Boolean <\<^sup>1 Class Object"

| widen1_Array_Void:
  "P \<turnstile> Array Void <\<^sup>1 Class Object"

| widen1_Class:
  "P \<turnstile> C \<prec>\<^sup>1 D \<Longrightarrow> P \<turnstile> Class C <\<^sup>1 Class D"

| widen1_Array_Array:
  "\<lbrakk> P \<turnstile> T <\<^sup>1 U; \<not> is_NT_Array T \<rbrakk> \<Longrightarrow> P \<turnstile> Array T <\<^sup>1 Array U"

abbreviation widen1_trancl :: "'a prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ <\<^sup>+ _" [71,71,71] 70) where
  "P \<turnstile> T <\<^sup>+ U \<equiv> (T, U) \<in> trancl (widen1 P)"

abbreviation widen1_rtrancl :: "'a prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ <\<^sup>* _" [71,71,71] 70) where
  "P \<turnstile> T <\<^sup>* U \<equiv> (T, U) \<in> rtrancl (widen1 P)"

inductive_simps widen1_simps1 [simp]:
  "P \<turnstile> Integer <\<^sup>1 T"
  "P \<turnstile> Boolean <\<^sup>1 T"
  "P \<turnstile> Void <\<^sup>1 T"
  "P \<turnstile> Class Object <\<^sup>1 T"
  "P \<turnstile> NT <\<^sup>1 U"

inductive_simps widen1_simps [simp]:
  "P \<turnstile> Array (Class Object) <\<^sup>1 T"
  "P \<turnstile> Array Integer <\<^sup>1 T"
  "P \<turnstile> Array Boolean <\<^sup>1 T"
  "P \<turnstile> Array Void <\<^sup>1 T"
  "P \<turnstile> Class C <\<^sup>1 T"
  "P \<turnstile> T <\<^sup>1 Array U"

lemma is_type_widen1:
  assumes icO: "is_class P Object"
  shows "P \<turnstile> T <\<^sup>1 U \<Longrightarrow> is_type P T"
by(induct rule: widen1.induct)(auto intro: subcls_is_class icO split: ty.split dest: is_type_ground_type)

lemma widen1_NT_Array:
  assumes "is_NT_Array T"
  shows "\<not> P \<turnstile> T\<lfloor>\<rceil> <\<^sup>1 U"
proof
  assume "P \<turnstile> T\<lfloor>\<rceil> <\<^sup>1 U" thus False using assms
    by(induct "T\<lfloor>\<rceil>" U arbitrary: T) auto
qed

lemma widen1_is_type:
  assumes wfP: "wf_prog wfmd P"
  shows "(A, B) \<in> widen1 P \<Longrightarrow> is_type P B"
proof(induct rule: widen1.induct)
  case (widen1_Class C D)
  hence "is_class P C" "is_class P D"
    by(auto intro: subcls_is_class converse_subcls_is_class[OF wfP])
  thus ?case by simp
next
  case (widen1_Array_Array T U)
  thus ?case by(cases U)(auto elim: widen1.cases)
qed(insert wfP, auto)

lemma widen1_trancl_is_type:
  assumes wfP: "wf_prog wfmd P"
  shows "(A, B) \<in> (widen1 P)^+ \<Longrightarrow> is_type P B"
apply(induct rule: trancl_induct)
apply(auto intro: widen1_is_type[OF wfP])
done

lemma single_valued_widen1:
  assumes wf: "wf_prog wf_md P"
  shows "single_valued (widen1 P)"
proof(rule single_valuedI, intro strip)
  fix x y z
  assume "P \<turnstile> x <\<^sup>1 y" "P \<turnstile> x <\<^sup>1 z"
  thus "y = z"
  proof(induct arbitrary: z rule: widen1.induct)
    case widen1_Class
    with single_valued_subcls1[OF wf] show ?case
      by(auto dest: single_valuedD)
  next
    case (widen1_Array_Array T U z)
    from `P \<turnstile> T\<lfloor>\<rceil> <\<^sup>1 z` `P \<turnstile> T <\<^sup>1 U` `\<not> is_NT_Array T`
    obtain z' where z': "z = z'\<lfloor>\<rceil>" and Tz': "P \<turnstile> T <\<^sup>1 z'"
      by(auto elim: widen1.cases)
    with `P \<turnstile> T <\<^sup>1 z' \<Longrightarrow> U = z'` have "U = z'" by blast
    with z' show ?case by simp
  qed simp_all
qed

function inheritance_level :: "'a prog \<Rightarrow> cname \<Rightarrow> nat" where
  "inheritance_level P C =
   (if acyclicP (subcls1 P) \<and> is_class P C \<and> C \<noteq> Object
    then Suc (inheritance_level P (fst (the (class P C))))
    else 0)"
by(pat_completeness, auto)
termination
proof(relation "same_fst (\<lambda>P. acyclicP (subcls1 P)) (\<lambda>P. {(C, C'). (subcls1 P)\<inverse>\<inverse> C C'})")
  show "wf (same_fst (\<lambda>P. acyclicP (subcls1 P)) (\<lambda>P. {(C, C'). (subcls1 P)\<inverse>\<inverse> C C'}))"
    by(rule wf_same_fst)(rule acyclicP_wf_subcls1[unfolded wfP_def])
qed(auto simp add: is_class_def intro: subcls1I)

fun subtype_measure :: "'a prog \<Rightarrow> ty \<Rightarrow> nat" where
  "subtype_measure P (Class C) = inheritance_level P C"
| "subtype_measure P (Array T) = 1 + subtype_measure P T"
| "subtype_measure P T = 0"

lemma subtype_measure_measure:
  assumes acyclic: "acyclicP (subcls1 P)"
  and widen1: "P \<turnstile> x <\<^sup>1 y"
  shows "subtype_measure P y < subtype_measure P x"
using widen1
proof(induct rule: widen1.induct)
  case (widen1_Class C D)
  then obtain rest where "is_class P C" "C \<noteq> Object" "class P C = \<lfloor>(D, rest)\<rfloor>"
    by(auto elim!: subcls1.cases simp: is_class_def)
  thus ?case using acyclic by(simp)
qed(simp_all)

lemma wf_converse_widen1:
  assumes wfP: "wf_prog wfmc P"
  shows "wf ((widen1 P)^-1)"
proof(rule wf_subset)
  from wfP have "acyclicP (subcls1 P)" by(rule acyclic_subcls1)
  thus "(widen1 P)\<inverse> \<subseteq> measure (subtype_measure P)"
    by(auto dest: subtype_measure_measure)
qed simp

fun super :: "'a prog \<Rightarrow> ty \<Rightarrow> ty"
where
  "super P (Array Integer) = Class Object"
| "super P (Array Boolean) = Class Object"
| "super P (Array Void) = Class Object"
| "super P (Array (Class C)) = (if C = Object then Class Object else Array (super P (Class C)))"
| "super P (Array (Array T)) = Array (super P (Array T))"
| "super P (Class C) = Class (fst (the (class P C)))"

lemma superI:
  "P \<turnstile> T <\<^sup>1 U \<Longrightarrow> super P T = U"
proof(induct rule: widen1.induct)
  case (widen1_Array_Array T U)
  thus ?case by(cases T) auto
qed(auto dest: subcls1D)

lemma Class_widen1_super:
  "P \<turnstile> Class C' <\<^sup>1 U' \<longleftrightarrow> is_class P C' \<and> C' \<noteq> Object \<and> U' = super P (Class C')"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof(rule iffI)
  assume ?lhs thus ?rhs
    by(auto intro: subcls_is_class simp add: superI simp del: super.simps)
next
  assume ?rhs thus ?lhs
    by(auto simp add: is_class_def intro: subcls1.intros)
qed

lemma super_widen1:
  assumes icO: "is_class P Object"
  shows "P \<turnstile> T <\<^sup>1 U \<longleftrightarrow> is_type P T \<and> (case T of Class C  \<Rightarrow> (C \<noteq> Object \<and> U = super P T)
                                              | Array T' \<Rightarrow> U = super P T
                                              | _        \<Rightarrow> False)"
proof(induct T arbitrary: U)
  case Class thus ?case using Class_widen1_super by(simp)
next
  case (Array T' U')
  note IH = this
  have "P \<turnstile> T'\<lfloor>\<rceil> <\<^sup>1 U' = (is_type P (T'\<lfloor>\<rceil>) \<and> U' = super P (T'\<lfloor>\<rceil>))"
  proof(rule iffI)
    assume wd: "P \<turnstile> T'\<lfloor>\<rceil> <\<^sup>1 U'"
    with icO have "is_type P (T'\<lfloor>\<rceil>)" by(rule is_type_widen1)
    moreover from wd have "super P (T'\<lfloor>\<rceil>) = U'" by(rule superI)
    ultimately show "is_type P (T'\<lfloor>\<rceil>) \<and> U' = super P (T'\<lfloor>\<rceil>)" by simp
  next
    assume "is_type P (T'\<lfloor>\<rceil>) \<and> U' = super P (T'\<lfloor>\<rceil>)"
    then obtain "is_type P (T'\<lfloor>\<rceil>)" and U': "U' = super P (T'\<lfloor>\<rceil>)" ..
    thus "P \<turnstile> T'\<lfloor>\<rceil> <\<^sup>1 U'"
    proof(cases T')
      case (Class D)
      thus ?thesis using U' icO `is_type P (T'\<lfloor>\<rceil>)`
        by(cases "D = Object")(auto simp add: is_class_def intro: subcls1.intros)
    next
      case Array thus ?thesis
        using IH `is_type P (T'\<lfloor>\<rceil>)` U' by(auto simp add: ty.split_asm)
    qed simp_all
  qed
  thus ?case by(simp)
qed(simp_all)

definition sup :: "'c prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> ty err" where
  "sup P T U \<equiv>
   if is_refT T \<and> is_refT U
   then OK (if U = NT then T
            else if T = NT then U
            else exec_lub (widen1 P) (super P) T U)
   else if (T = U) then OK T else Err"

lemma sup_def':
  "sup P = (\<lambda>T U.
   if is_refT T \<and> is_refT U
   then OK (if U = NT then T
            else if T = NT then U
            else exec_lub (widen1 P) (super P) T U)
   else if (T = U) then OK T else Err)"
  by (simp add: fun_eq_iff sup_def)

definition esl :: "'m prog \<Rightarrow> ty esl"
where
  "esl P = (types P, widen P, sup P)"

lemma order_widen [intro,simp]:
  "wf_prog m P \<Longrightarrow> order (widen P)"
unfolding Semilat.order_def lesub_def
by (auto intro: widen_trans widen_antisym)

lemma subcls1_trancl_widen1_trancl:
  "(subcls1 P)^++ C D \<Longrightarrow> P \<turnstile> Class C <\<^sup>+ Class D"
by(induct rule: tranclp_induct[consumes 1, case_names base step])
  (auto intro: trancl_into_trancl)

lemma subcls_into_widen1_rtrancl:
  "P \<turnstile> C \<preceq>\<^sup>* D \<Longrightarrow> P \<turnstile> Class C <\<^sup>* Class D"
by(induct rule: rtranclp_induct)(auto intro: rtrancl_into_rtrancl)

lemma not_widen1_NT_Array:
  "P \<turnstile> U <\<^sup>1 T \<Longrightarrow> \<not> is_NT_Array T"
by(induct rule: widen1.induct)(auto)

lemma widen1_trancl_into_Array_widen1_trancl:
  "\<lbrakk> P \<turnstile> A <\<^sup>+ B; \<not> is_NT_Array A \<rbrakk> \<Longrightarrow> P \<turnstile> A\<lfloor>\<rceil> <\<^sup>+ B\<lfloor>\<rceil>"
by(induct rule: converse_trancl_induct)
  (auto intro: trancl_into_trancl2 widen1_Array_Array dest: not_widen1_NT_Array)

lemma widen1_rtrancl_into_Array_widen1_rtrancl:
  "\<lbrakk> P \<turnstile> A <\<^sup>* B; \<not> is_NT_Array A \<rbrakk> \<Longrightarrow> P \<turnstile> A\<lfloor>\<rceil> <\<^sup>* B\<lfloor>\<rceil>"
by(blast elim: rtranclE intro: trancl_into_rtrancl widen1_trancl_into_Array_widen1_trancl rtrancl_into_trancl1)

lemma Array_Object_widen1_trancl:
  assumes wf: "wf_prog wmdc P"
  and itA: "is_type P (A\<lfloor>\<rceil>)"
  shows "P \<turnstile> A\<lfloor>\<rceil> <\<^sup>+ Class Object"
using itA
proof(induction A)
  case (Class C)
  hence "is_class P C" by simp
  hence "P \<turnstile> C \<preceq>\<^sup>* Object" by(rule subcls_C_Object[OF _ wf])
  hence "P \<turnstile> Class C <\<^sup>* Class Object" by(rule subcls_into_widen1_rtrancl)
  hence "P \<turnstile> Class C\<lfloor>\<rceil> <\<^sup>* Class Object\<lfloor>\<rceil>"
    by(rule widen1_rtrancl_into_Array_widen1_rtrancl) simp
  thus ?case by(rule rtrancl_into_trancl1) simp
next
  case (Array A)
  from `is_type P (A\<lfloor>\<rceil>\<lfloor>\<rceil>)` have "is_type P (A\<lfloor>\<rceil>)" by(rule is_type_ArrayD)
  hence "P \<turnstile> A\<lfloor>\<rceil> <\<^sup>+ Class Object" by(rule Array.IH)
  moreover from `is_type P (A\<lfloor>\<rceil>\<lfloor>\<rceil>)` have "\<not> is_NT_Array (A\<lfloor>\<rceil>)" by auto
  ultimately have "P \<turnstile> A\<lfloor>\<rceil>\<lfloor>\<rceil> <\<^sup>+ Class Object\<lfloor>\<rceil>"
    by(rule widen1_trancl_into_Array_widen1_trancl)
  thus ?case by(rule trancl_into_trancl) simp
qed auto

lemma widen_into_widen1_trancl:
  assumes wf: "wf_prog wfmd P"
  shows "\<lbrakk> P \<turnstile> A \<le> B; A \<noteq> B; A \<noteq> NT; is_type P A \<rbrakk> \<Longrightarrow> P \<turnstile> A <\<^sup>+ B"
proof(induct rule: widen.induct)
  case (widen_subcls C D)
  from `Class C \<noteq> Class D` `P \<turnstile> C \<preceq>\<^sup>* D` have "(subcls1 P)\<^sup>+\<^sup>+ C D"
    by(auto elim: rtranclp.cases intro: rtranclp_into_tranclp1)
  thus ?case by(rule subcls1_trancl_widen1_trancl)
next
  case widen_array_object thus ?case by(auto intro: Array_Object_widen1_trancl[OF wf])
next
  case (widen_array_array A B)
  hence "P \<turnstile> A <\<^sup>+ B" by(cases A) auto
  with `is_type P (A\<lfloor>\<rceil>)` show ?case by(auto intro: widen1_trancl_into_Array_widen1_trancl)
qed(auto)

lemma wf_prog_impl_acc_widen:
  assumes wfP: "wf_prog wfmd P"
  shows "acc (types P) (widen P)"
proof -
  from wf_converse_widen1[OF wfP]
  have "wf (((widen1 P)^-1)^+)" by(rule wf_trancl)

  hence wfw1t: "\<And>M T. T \<in> M \<Longrightarrow> (\<exists>z\<in>M. \<forall>y. (y, z) \<in> ((widen1 P)\<inverse>)\<^sup>+ \<longrightarrow> y \<notin> M)"
    by(auto simp only: wf_eq_minimal)
  have "wf {(y, x). is_type P x \<and> is_type P y \<and> widen P x y \<and> x \<noteq> y}"
    unfolding wf_eq_minimal
  proof(intro strip)
    fix M and T :: ty
    assume TM: "T \<in> M"
    show "\<exists>z\<in>M. \<forall>y. (y, z) \<in> {(y, T). is_type P T \<and> is_type P y \<and> widen P T y \<and> T \<noteq> y} \<longrightarrow> y \<notin> M"
    proof(cases "(\<exists>C. Class C \<in> M \<and> is_class P C) \<or> (\<exists>U. U\<lfloor>\<rceil> \<in> M \<and> is_type P (U\<lfloor>\<rceil>))")
      case True
      have BNTthesis: "\<And>B. \<lbrakk> B \<in> (M \<inter> types P) - {NT} \<rbrakk> \<Longrightarrow> ?thesis"
      proof -
        fix B
        assume BM: "B \<in> M \<inter> types P - {NT}"
        from wfw1t[OF BM] obtain z
          where zM: "z \<in> M"
          and znnt: "z \<noteq> NT"
          and itz: "is_type P z"
          and y: "\<And>y. (y, z) \<in> ((widen1 P)\<inverse>)\<^sup>+ \<Longrightarrow> y \<notin> M \<inter> types P - {NT}" by blast
        show "?thesis B"
        proof(rule bexI[OF _ zM], rule allI, rule impI)
          fix y
          assume "(y, z) \<in> {(y, T). is_type P T \<and> is_type P y \<and> widen P T y \<and> T \<noteq> y}"
          hence Pzy: "P \<turnstile> z \<le> y" and zy: "z \<noteq> y" and "is_type P y" by auto
          hence "P \<turnstile> z <\<^sup>+ y" using znnt itz
            by -(rule widen_into_widen1_trancl[OF wfP])
          hence ynM: "y \<notin> M \<inter> types P - {NT}"
            by -(rule y, simp add: trancl_converse)
          thus "y \<notin> M" using Pzy znnt `is_type P y` by auto
        qed
      qed
      from True show ?thesis by(fastforce intro: BNTthesis)
    next
      case False

      hence not_is_class: "\<And>C. Class C \<in> M \<Longrightarrow> \<not> is_class P C"
        and not_is_array: "\<And>U. U\<lfloor>\<rceil> \<in> M \<Longrightarrow> \<not> is_type P (U\<lfloor>\<rceil>)" by simp_all

      show ?thesis
      proof(cases "\<exists>C. Class C \<in> M")
        case True
        then obtain C where "Class C \<in> M" ..
        with not_is_class[of C] show ?thesis
          by(blast dest: rtranclpD subcls_is_class Class_widen)
      next
        case False
        show ?thesis
        proof(cases "\<exists>T. Array T \<in> M")
          case True
          then obtain U where U: "Array U \<in> M" ..
          hence "\<not> is_type P (U\<lfloor>\<rceil>)" by(rule not_is_array)
          thus ?thesis using U by(auto simp del: is_type.simps)
        next
          case False
          with `\<not> (\<exists>C. Class C \<in> M)` TM
          have "\<forall>y. P \<turnstile> T \<le> y \<and> T \<noteq> y \<longrightarrow> y \<notin> M"
            by(cases T)(fastforce simp add: NT_widen)+
          thus ?thesis using TM by blast
        qed
      qed
    qed
  qed
  thus ?thesis by(simp add: Semilat.acc_def lesssub_def lesub_def)
qed

lemmas wf_widen_acc = wf_prog_impl_acc_widen
declare wf_widen_acc [intro, simp]

lemma acyclic_widen1:
  "wf_prog wfmc P \<Longrightarrow> acyclic (widen1 P)"
by(auto dest: wf_converse_widen1 wf_acyclic simp add: acyclic_converse)

lemma widen1_into_widen:
  "(A, B) \<in> widen1 P \<Longrightarrow> P \<turnstile> A \<le> B"
by(induct rule: widen1.induct)(auto intro: widen.intros)

lemma widen1_rtrancl_into_widen:
  "P \<turnstile> A <\<^sup>* B \<Longrightarrow> P \<turnstile> A \<le> B"
by(induct rule: rtrancl_induct)(auto dest!: widen1_into_widen elim: widen_trans)

lemma widen_eq_widen1_trancl:
  "\<lbrakk> wf_prog wf_md P; T \<noteq> NT; T \<noteq> U; is_type P T \<rbrakk> \<Longrightarrow> P \<turnstile> T \<le> U \<longleftrightarrow> P \<turnstile> T <\<^sup>+ U"
by(blast intro: widen_into_widen1_trancl widen1_rtrancl_into_widen trancl_into_rtrancl)

lemma sup_is_type:
  assumes wf: "wf_prog wf_md P"
  and itA: "is_type P A"
  and itB: "is_type P B"
  and sup: "sup P A B = OK T"
  shows "is_type P T"
proof -
  { assume ANT: "A \<noteq> NT"
      and BNT: "B \<noteq> NT"
      and AnB: "A \<noteq> B"
      and RTA: "is_refT A"
      and RTB: "is_refT B"
    with itA itB have AObject: "P \<turnstile> A \<le> Class Object"
      and BObject: "P \<turnstile> B \<le> Class Object"
      by(auto intro: is_refType_widen_Object[OF wf])
    have "is_type P (exec_lub (widen1 P) (super P) A B)"
    proof(cases "A = Class Object \<or> B = Class Object")
      case True
      hence "exec_lub (widen1 P) (super P) A B = Class Object"
      proof(rule disjE)
        assume A: "A = Class Object"
        moreover
        from BObject BNT itB have "P \<turnstile> B <\<^sup>* Class Object"
          by(cases "B = Class Object")(auto intro: trancl_into_rtrancl widen_into_widen1_trancl[OF wf])
        hence "is_ub ((widen1 P)\<^sup>*) (Class Object) B (Class Object)"
          by(auto intro: is_ubI)
        hence "is_lub ((widen1 P)\<^sup>*) (Class Object) B (Class Object)"
          by(auto simp add: is_lub_def dest: is_ubD)
        with acyclic_widen1[OF wf]
        have "exec_lub (widen1 P) (super P) (Class Object) B = Class Object"
          by(auto intro: exec_lub_conv superI)
        ultimately show "exec_lub (widen1 P) (super P) A B = Class Object" by simp
      next
        assume B: "B = Class Object"
        moreover
        from AObject ANT itA
        have "(A, Class Object) \<in> (widen1 P)\<^sup>*"
          by(cases "A = Class Object", auto intro: trancl_into_rtrancl widen_into_widen1_trancl[OF wf])
        hence "is_ub ((widen1 P)\<^sup>*) (Class Object) A (Class Object)"
          by(auto intro: is_ubI)
        hence "is_lub ((widen1 P)\<^sup>*) (Class Object) A (Class Object)"
          by(auto simp add: is_lub_def dest: is_ubD)
        with acyclic_widen1[OF wf]
        have "exec_lub (widen1 P) (super P) A (Class Object) = Class Object"
          by(auto intro: exec_lub_conv superI)
        ultimately show "exec_lub (widen1 P) (super P) A B = Class Object" by simp
      qed
      with wf show ?thesis by(simp)
    next
      case False
      hence AnObject: "A \<noteq> Class Object"
        and BnObject: "B \<noteq> Class Object" by auto
      from widen_into_widen1_trancl[OF wf AObject AnObject ANT itA]
      have "P \<turnstile> A <\<^sup>* Class Object" by(rule trancl_into_rtrancl)
      moreover from widen_into_widen1_trancl[OF wf BObject BnObject BNT itB]
      have "P \<turnstile> B <\<^sup>* Class Object" by(rule trancl_into_rtrancl)
      ultimately have "is_lub ((widen1 P)\<^sup>*) A B (exec_lub (widen1 P) (super P) A B)"
        by(rule is_lub_exec_lub[OF single_valued_widen1[OF wf] acyclic_widen1[OF wf]])(auto intro: superI)
      hence Aew1: "P \<turnstile> A <\<^sup>* exec_lub (widen1 P) (super P) A B"
        by(auto simp add: is_lub_def dest!: is_ubD)
      thus ?thesis
      proof(rule rtranclE)
        assume "A = exec_lub (widen1 P) (super P) A B"
        with itA show ?thesis by simp
      next
        fix A'
        assume "P \<turnstile> A' <\<^sup>1 exec_lub (widen1 P) (super P) A B"
        thus ?thesis by(rule widen1_is_type[OF wf])
      qed
    qed }
  with is_class_Object[OF wf] sup itA itB show ?thesis unfolding sup_def
    by(cases "A = B")(auto split: split_if_asm simp add: exec_lub_refl)
qed

lemma closed_err_types:
  assumes wfP: "wf_prog wf_mb P"
  shows "closed (err (types P)) (lift2 (sup P))"
proof -
  { fix A B
    assume it: "is_type P A" "is_type P B"
      and "A \<noteq> NT" "B \<noteq> NT" "A \<noteq> B"
      and "is_refT A" "is_refT B"
    hence "is_type P (exec_lub (widen1 P) (super P) A B)"
      using sup_is_type[OF wfP it] by(simp add: sup_def) }
  with is_class_Object[OF wfP] show ?thesis
    unfolding closed_def plussub_def lift2_def sup_def'
    by(auto split: err.split ty.splits)(auto simp add: exec_lub_refl)
qed

lemma widen_into_widen1_rtrancl:
  "\<lbrakk>wf_prog wfmd P; widen P A B; A \<noteq> NT; is_type P A \<rbrakk> \<Longrightarrow> (A, B) \<in> (widen1 P)\<^sup>*"
by(cases "A = B")(auto intro: trancl_into_rtrancl widen_into_widen1_trancl)

lemma sup_widen_greater:
  assumes wfP: "wf_prog wf_mb P"
  and it1: "is_type P t1"
  and it2: "is_type P t2"
  and sup: "sup P t1 t2 = OK s"
  shows "widen P t1 s \<and> widen P t2 s"
proof -
  { assume t1: "is_refT t1"
      and t2: "is_refT t2"
      and t1NT: "t1 \<noteq> NT"
      and t2NT: "t2 \<noteq> NT"
    with it1 it2 wfP have "P \<turnstile> t1 \<le> Class Object" "P \<turnstile> t2 \<le> Class Object"
      by(auto intro: is_refType_widen_Object)
    with t1NT t2NT it1 it2
    have "P \<turnstile> t1 <\<^sup>* Class Object" "P \<turnstile> t2 <\<^sup>* Class Object"
      by(auto intro: widen_into_widen1_rtrancl[OF wfP])
    with single_valued_widen1[OF wfP]
    obtain u where "is_lub ((widen1 P)^*) t1 t2 u"
      by (blast dest: single_valued_has_lubs)
    hence "P \<turnstile> t1 \<le> exec_lub (widen1 P) (super P) t1 t2 \<and>
           P \<turnstile> t2 \<le> exec_lub (widen1 P) (super P) t1 t2"
      using acyclic_widen1[OF wfP] superI[of _ _ P]
      by(simp add: exec_lub_conv)(blast dest: is_lubD is_ubD intro: widen1_rtrancl_into_widen) }
  with it1 it2 sup show ?thesis
    by (cases s) (auto simp add: sup_def split: split_if_asm elim: refTE)
qed

lemma sup_widen_smallest:
  assumes wfP: "wf_prog wf_mb P"
  and itT: "is_type P T"
  and itU: "is_type P U"
  and TwV: "P \<turnstile> T \<le> V"
  and UwV: "P \<turnstile> U \<le> V"
  and sup: "sup P T U = OK W"
  shows "widen P W V"
proof -
  { assume rT: "is_refT T"
      and rU: "is_refT U"
      and UNT: "U \<noteq> NT"
      and TNT: "T \<noteq> NT"
      and W: "exec_lub (widen1 P) (super P) T U = W"
    from itU itT rT rU UNT TNT have "P \<turnstile> T \<le> Class Object" "P \<turnstile> U \<le> Class Object"
      by(auto intro:is_refType_widen_Object[OF wfP])
    with UNT TNT itT itU
    have "P \<turnstile> T <\<^sup>* Class Object" "P \<turnstile> U <\<^sup>* Class Object"
      by(auto intro: widen_into_widen1_rtrancl[OF wfP])
    with single_valued_widen1[OF wfP]
    obtain X where lub: "is_lub ((widen1 P)^* ) T U X"
      by (blast dest: single_valued_has_lubs)
    with acyclic_widen1[OF wfP]
    have "exec_lub (widen1 P) (super P) T U = X"
      by (blast intro: superI exec_lub_conv)
    also from TwV TNT UwV UNT itT itU have "P \<turnstile> T <\<^sup>* V" "P \<turnstile> U <\<^sup>* V"
      by(auto intro: widen_into_widen1_rtrancl[OF wfP])
    with lub have "P \<turnstile> X <\<^sup>* V"
      by (clarsimp simp add: is_lub_def is_ub_def)
    finally have "P \<turnstile> exec_lub (widen1 P) (super P) T U \<le> V"
      by(rule widen1_rtrancl_into_widen)
    with W have "P \<turnstile> W \<le> V" by simp }
  with sup itT itU TwV UwV show ?thesis
    by(simp add: sup_def split: split_if_asm)
qed

lemma sup_exists:
  "\<lbrakk> widen P a c; widen P b c \<rbrakk> \<Longrightarrow> EX T. sup P a b = OK T"
by(cases b a rule: ty.exhaust[case_product ty.exhaust])(auto simp add: sup_def)

lemma err_semilat_JType_esl:
  assumes wf_prog: "wf_prog wf_mb P"
  shows "err_semilat (esl P)"
proof -
  from wf_prog have "order (widen P)" ..
  moreover from wf_prog
  have "closed (err (types P)) (lift2 (sup P))"
    by (rule closed_err_types)
  moreover
  from wf_prog have
    "(\<forall>x\<in>err (types P). \<forall>y\<in>err (types P). x \<sqsubseteq>\<^bsub>Err.le (widen P)\<^esub> x \<squnion>\<^bsub>lift2 (sup P)\<^esub> y) \<and>
     (\<forall>x\<in>err (types P). \<forall>y\<in>err (types P). y \<sqsubseteq>\<^bsub>Err.le (widen P)\<^esub> x \<squnion>\<^bsub>lift2 (sup P)\<^esub> y)"
    by(auto simp add: lesub_def plussub_def Err.le_def lift2_def sup_widen_greater split: err.split)
  moreover from wf_prog have
    "\<forall>x\<in>err (types P). \<forall>y\<in>err (types P). \<forall>z\<in>err (types P).
    x \<sqsubseteq>\<^bsub>Err.le (widen P)\<^esub> z \<and> y \<sqsubseteq>\<^bsub>Err.le (widen P)\<^esub> z \<longrightarrow> x \<squnion>\<^bsub>lift2 (sup P)\<^esub> y \<sqsubseteq>\<^bsub>Err.le (widen P)\<^esub> z"
    unfolding lift2_def plussub_def lesub_def Err.le_def
    by(auto intro: sup_widen_smallest dest:sup_exists simp add: split: err.split)
  ultimately show ?thesis by (simp add: esl_def semilat_def sl_def Err.sl_def)
qed

subsection {* Relation between @{term "sup P T U = OK V"} and @{term "P \<turnstile> lub(T, U) = V"} *}

lemma sup_is_lubI:
  assumes wf: "wf_prog wf_md P"
  and it: "is_type P T" "is_type P U"
  and sup: "sup P T U = OK V"
  shows "P \<turnstile> lub(T, U) = V"
proof
  from sup_widen_greater[OF wf it sup]
  show "P \<turnstile> T \<le> V" "P \<turnstile> U \<le> V" by blast+
next
  fix T'
  assume "P \<turnstile> T \<le> T'" "P \<turnstile> U \<le> T'"
  thus "P \<turnstile> V \<le> T'" using sup by(rule sup_widen_smallest[OF wf it])
qed

lemma is_lub_subD:
  assumes wf: "wf_prog wf_md P"
  and it: "is_type P T" "is_type P U"
  and lub: "P \<turnstile> lub(T, U) = V"
  shows "sup P T U = OK V"
proof -
  from lub have "P \<turnstile> T \<le> V" "P \<turnstile> U \<le> V" by(blast dest: is_lub_upper)+
  from sup_exists[OF this] obtain W where "sup P T U = OK W" by blast
  moreover
  with wf it have "P \<turnstile> lub(T, U) = W" by(rule sup_is_lubI)
  with lub have "V = W" by(auto dest: is_lub_unique[OF wf])
  ultimately show ?thesis by simp
qed

lemma is_lub_is_type:
  "\<lbrakk> wf_prog wf_md P; is_type P T; is_type P U; P \<turnstile> lub(T, U) = V \<rbrakk> \<Longrightarrow> is_type P V"
by(frule (3) is_lub_subD)(erule (3) sup_is_type)

subsection {* Code generator setup *}

code_pred widen1p .
lemmas [code] = widen1_def

lemma eval_widen1p_i_i_o_conv:
  "Predicate.eval (widen1p_i_i_o P T) = (\<lambda>U. P \<turnstile> T <\<^sup>1 U)"
by(auto elim: widen1p_i_i_oE intro: widen1p_i_i_oI simp add: widen1_def fun_eq_iff)

lemma rtrancl_widen1_code [code_unfold]:
  "(widen1 P)^* = {(a, b). Predicate.holds (rtrancl_tab_FioB_i_i_i (widen1p_i_i_o P) [] a b)}"
by(auto simp add: fun_eq_iff Predicate.holds_eq widen1_def rtrancl_def rtranclp_eq_rtrancl_tab_nil eval_widen1p_i_i_o_conv intro!: rtrancl_tab_FioB_i_i_iI elim!: rtrancl_tab_FioB_i_i_iE)

declare exec_lub_def [code_unfold]

end