chapter \<open>Converting between \<open>term\<close>s and \<open>nterm\<close>s\<close>

theory Term_to_Nterm
imports
  Fresh_Class
  Find_First
  Term
  Nterm
begin

section \<open>\<open>\<alpha>\<close>-equivalence\<close>

inductive alpha_equiv :: "(name, name) fmap \<Rightarrow> nterm \<Rightarrow> nterm \<Rightarrow> bool" where
const: "alpha_equiv env (Nconst x) (Nconst x)" |
var1: "x |\<notin>| fmdom env \<Longrightarrow> x |\<notin>| fmran env \<Longrightarrow> alpha_equiv env (Nvar x) (Nvar x)" |
var2: "fmlookup env x = Some y \<Longrightarrow> alpha_equiv env (Nvar x) (Nvar y)" |
abs: "alpha_equiv (fmupd x y env) n1 n2 \<Longrightarrow> alpha_equiv env (\<Lambda>\<^sub>n x. n1) (\<Lambda>\<^sub>n y. n2)" |
app: "alpha_equiv env n1 n2 \<Longrightarrow> alpha_equiv env m1 m2 \<Longrightarrow> alpha_equiv env (n1 $\<^sub>n m1) (n2 $\<^sub>n m2)"

code_pred alpha_equiv .

abbreviation alpha_eq :: "nterm \<Rightarrow> nterm \<Rightarrow> bool" (infixl "\<approx>\<^sub>\<alpha>" 50) where
"alpha_eq n1 n2 \<equiv> alpha_equiv fmempty n1 n2"

lemma alpha_equiv_refl[intro?]:
  assumes "fmpred (=) \<Gamma>"
  shows "alpha_equiv \<Gamma> t t"
using assms proof (induction t arbitrary: \<Gamma>)
  case Napp
  show ?case
    apply (rule alpha_equiv.app; rule Napp)
    using Napp.prems unfolding fdisjnt_alt_def by auto
qed (auto simp: fdisjnt_alt_def intro: alpha_equiv.intros)

corollary alpha_eq_refl: "alpha_eq t t"
by (auto intro: alpha_equiv_refl)

section \<open>From @{typ term} to @{typ nterm}\<close>

fun term_to_nterm :: "name list \<Rightarrow> term \<Rightarrow> (name, nterm) state" where
"term_to_nterm _ (Const name) = State_Monad.return (Nconst name)" |
"term_to_nterm _ (Free name) = State_Monad.return (Nvar name)" |
"term_to_nterm \<Gamma> (Bound n) = State_Monad.return (Nvar (\<Gamma> ! n))" |
"term_to_nterm \<Gamma> (\<Lambda> t) = do {
  n \<leftarrow> fresh_create;
  e \<leftarrow> term_to_nterm (n # \<Gamma>) t;
  State_Monad.return (\<Lambda>\<^sub>n n. e)
}" |
"term_to_nterm \<Gamma> (t\<^sub>1 $ t\<^sub>2) = do {
  e\<^sub>1 \<leftarrow> term_to_nterm \<Gamma> t\<^sub>1;
  e\<^sub>2 \<leftarrow> term_to_nterm \<Gamma> t\<^sub>2;
  State_Monad.return (e\<^sub>1 $\<^sub>n e\<^sub>2)
}"

lemmas term_to_nterm_induct = term_to_nterm.induct[case_names const free bound abs app]

definition term_to_nterm' :: "term \<Rightarrow> nterm" where
"term_to_nterm' t = frun_fresh (term_to_nterm [] t) (frees t)"

lemma term_to_nterm_mono: "mono_state (term_to_nterm \<Gamma> x)"
by (induction \<Gamma> x rule: term_to_nterm.induct) (auto intro: bind_mono_strong)

lemma term_to_nterm_vars0:
  assumes "wellformed' (length \<Gamma>) t"
  shows "frees (fst (run_state (term_to_nterm \<Gamma> t) s)) |\<subseteq>| frees t |\<union>| fset_of_list \<Gamma>"
using assms proof (induction \<Gamma> t arbitrary: s rule: term_to_nterm_induct)
  case (bound \<Gamma> i)
  hence "\<Gamma> ! i |\<in>| fset_of_list \<Gamma>"
    including fset.lifting by transfer auto
  thus ?case
    by (auto simp: State_Monad.return_def)
next
  case (abs \<Gamma> t)
  let ?x = "next s"

  from abs have "frees (fst (run_state (term_to_nterm (?x # \<Gamma>) t) ?x)) |\<subseteq>| frees t |\<union>| {|?x|} |\<union>| fset_of_list \<Gamma>"
    by simp
  thus ?case
    by (auto simp: create_alt_def split_beta)
qed (auto simp: split_beta)

corollary term_to_nterm_vars:
  assumes "wellformed t"
  shows "frees (fresh_frun (term_to_nterm [] t) F) |\<subseteq>| frees t"
proof -
  let ?\<Gamma> = "[]"
  from assms have "wellformed' (length ?\<Gamma>) t"
    by simp
  hence "frees (fst (run_state (term_to_nterm ?\<Gamma> t) (fNext F))) |\<subseteq>| (frees t |\<union>| fset_of_list ?\<Gamma>)"
    by (rule term_to_nterm_vars0)
  thus ?thesis
    by (simp add: fresh_fNext_def fresh_frun_def)
qed

corollary term_to_nterm_closed: "closed t \<Longrightarrow> wellformed t \<Longrightarrow> closed (term_to_nterm' t)"
using term_to_nterm_vars[where F = "frees t" and t = t, simplified]
unfolding closed_except_def term_to_nterm'_def
by (simp add: fresh_frun_def)

lemma term_to_nterm_consts: "pred_state (\<lambda>t'. consts t' = consts t) (term_to_nterm \<Gamma> t)"
apply (rule pred_stateI)
apply (induction t arbitrary: \<Gamma>)
apply (auto split: prod.splits)
done

section \<open>From @{typ nterm} to @{typ term}\<close>

fun nterm_to_term :: "name list \<Rightarrow> nterm \<Rightarrow> term" where
"nterm_to_term \<Gamma> (Nconst name) = Const name" |
"nterm_to_term \<Gamma> (Nvar name) = (case find_first name \<Gamma> of Some n \<Rightarrow> Bound n | None \<Rightarrow> Free name)" |
"nterm_to_term \<Gamma> (t $\<^sub>n u) = nterm_to_term \<Gamma> t $ nterm_to_term \<Gamma> u" |
"nterm_to_term \<Gamma> (\<Lambda>\<^sub>n x. t) = \<Lambda> nterm_to_term (x # \<Gamma>) t"

lemma nterm_to_term:
  assumes "no_abs t" "fdisjnt (fset_of_list \<Gamma>) (frees t)"
  shows "nterm_to_term \<Gamma> t = convert_term t"
using assms proof (induction arbitrary: \<Gamma>)
  case (free name)
  then show ?case
    apply simp
    apply (auto simp: free_nterm_def free_term_def fdisjnt_alt_def split: option.splits)
    apply (rule find_first_none)
    by (metis fset_of_list_elem)
next
  case (const name)
  show ?case
    apply simp
    by (simp add: const_nterm_def const_term_def)
next
  case (app t\<^sub>1 t\<^sub>2)
  then have "nterm_to_term \<Gamma> t\<^sub>1 = convert_term t\<^sub>1" "nterm_to_term \<Gamma> t\<^sub>2 = convert_term t\<^sub>2"
    by (auto simp: fdisjnt_alt_def finter_funion_distrib)
  then show ?case
    apply simp
    by (simp add: app_nterm_def app_term_def)
qed

abbreviation "nterm_to_term' \<equiv> nterm_to_term []"

lemma nterm_to_term': "no_abs t \<Longrightarrow> nterm_to_term' t = convert_term t"
by (auto simp: fdisjnt_alt_def nterm_to_term)

lemma nterm_to_term_frees[simp]: "frees (nterm_to_term \<Gamma> t) = frees t - fset_of_list \<Gamma>"
proof (induction t arbitrary: \<Gamma>)
  case (Nvar name)
  show ?case
    proof (cases "find_first name \<Gamma>")
      case None
      hence "name |\<notin>| fset_of_list \<Gamma>"
        including fset.lifting
        by transfer (metis find_first_some option.distinct(1))
      with None show ?thesis
        by auto
    next
      case (Some u)
      hence "name |\<in>| fset_of_list \<Gamma>"
        including fset.lifting
        by transfer (metis find_first_none option.distinct(1))
      with Some show ?thesis
        by auto
    qed
  qed (auto split: option.splits)

section \<open>Correctness\<close>

text \<open>Some proofs in this section have been contributed by Yu Zhang.\<close>

lemma term_to_nterm_nterm_to_term0:
  assumes "wellformed' (length \<Gamma>) t" "fdisjnt (fset_of_list \<Gamma>) (frees t)" "distinct \<Gamma>"
  assumes "fBall (frees t |\<union>| fset_of_list \<Gamma>) (\<lambda>x. x \<le> s)"
  shows "nterm_to_term \<Gamma> (fst (run_state (term_to_nterm \<Gamma> t) s)) = t"
using assms proof (induction \<Gamma> t arbitrary: s rule: term_to_nterm_induct)
  case (free \<Gamma> name)
  hence "fdisjnt (fset_of_list \<Gamma>) {|name|}"
    by simp
  hence "name \<notin> set \<Gamma>"
    including fset.lifting by transfer' (simp add: disjnt_def)
  hence "find_first name \<Gamma> = None"
    by (rule find_first_none)
  thus ?case
    by (simp add: State_Monad.return_def)
next
  case (bound \<Gamma> i)
  thus ?case
    by (simp add: State_Monad.return_def find_first_some_index)
next
  case (app \<Gamma> t\<^sub>1 t\<^sub>2)
  have "fdisjnt (fset_of_list \<Gamma>) (frees t\<^sub>1)"
    apply (rule fdisjnt_subset_right[where N = "frees t\<^sub>1 |\<union>| frees t\<^sub>2"])
    using app by auto
  have "fdisjnt (fset_of_list \<Gamma>) (frees t\<^sub>2)"
    apply (rule fdisjnt_subset_right[where N = "frees t\<^sub>1 |\<union>| frees t\<^sub>2"])
    using app by auto

  have s: "s \<le> snd (run_state (term_to_nterm \<Gamma> t\<^sub>1) s)"
    apply (rule state_io_relD[OF term_to_nterm_mono])
    apply (rule surjective_pairing)
    done

  show ?case
    apply (auto simp: split_beta)
    subgoal
      apply (rule app)
      subgoal using app by simp
      subgoal by fact
      subgoal by fact
      using app by auto
    subgoal
      apply (rule app)
      subgoal using app by simp
      subgoal by fact
      subgoal by fact
      using app s by force+
    done
next
  case (abs \<Gamma> t)

  have "next s |\<notin>| frees t |\<union>| fset_of_list \<Gamma>"
    using abs(5)[simplified]
    by (rule next_ge_fall)

  have "nterm_to_term (next s # \<Gamma>) (fst (run_state (term_to_nterm (next s # \<Gamma>) t) (next s))) = t"
    proof (subst abs)
      show "wellformed' (length (next s # \<Gamma>)) t"
        using abs by auto
      show "fdisjnt (fset_of_list (next s # \<Gamma>)) (frees t)"
        apply simp
        apply (rule fdisjnt_insert)
        using \<open>next s |\<notin>| frees t |\<union>| fset_of_list \<Gamma>\<close> abs by auto
      show "distinct (next s # \<Gamma>)"
        apply simp
        apply rule
        using \<open>next s |\<notin>| frees t |\<union>| fset_of_list \<Gamma>\<close> apply (simp add: fset_of_list_elem)
        apply fact
        done
      show "fBall (frees t |\<union>| fset_of_list (next s # \<Gamma>)) (\<lambda>x. x \<le> next s)"
        using abs(5) apply simp
        apply (rule fBall_pred_weaken[where P = "\<lambda>x. x \<le> s"])
        subgoal
          apply simp
          by (meson dual_order.strict_implies_order dual_order.strict_trans2 fresh_class.next_ge)
        subgoal by assumption
        done
    qed auto

  thus ?case
    by (auto simp: split_beta create_alt_def)
qed (auto simp: State_Monad.return_def)

lemma term_to_nterm_nterm_to_term:
  assumes "wellformed t" "frees t |\<subseteq>| S"
  shows "nterm_to_term' (frun_fresh (term_to_nterm [] t) (S |\<union>| Q)) = t"
proof (rule term_to_nterm_nterm_to_term0)
  show "wellformed' (length []) t"
    using assms by simp
next
  show "fdisjnt (fset_of_list []) (frees t)"
    unfolding fdisjnt_alt_def by simp
next
  have "fBall (S |\<union>| Q) (\<lambda>x. x < fresh.fNext next default (S |\<union>| Q))"
    by (metis fNext_geq_not_member fresh_fNext_def le_less_linear fBallI)
  hence "fBall (S |\<union>| Q) (\<lambda>x. x \<le> fresh.fNext next default (S |\<union>| Q))"
    by (meson fBall_pred_weaken less_eq_name_def)
  thus "fBall (frees t |\<union>| fset_of_list []) (\<lambda>x. x \<le> fresh.fNext next default (S |\<union>| Q))"
    using \<open>frees t |\<subseteq>| S\<close>
    by auto
qed simp

corollary term_to_nterm_nterm_to_term_simple:
  assumes "wellformed t"
  shows "nterm_to_term' (term_to_nterm' t) = t"
unfolding term_to_nterm'_def using assms
by (metis order_refl sup.idem term_to_nterm_nterm_to_term)

lemma nterm_to_term_eq:
  assumes "frees u |\<subseteq>| fset_of_list (common_prefix \<Gamma> \<Gamma>')"
  shows "nterm_to_term \<Gamma> u = nterm_to_term \<Gamma>' u"
using assms
proof (induction u arbitrary: \<Gamma> \<Gamma>')
  case (Nvar name)
  hence "name \<in> set (common_prefix \<Gamma> \<Gamma>')"
    unfolding frees_nterm.simps
    including fset.lifting
    by transfer' simp
  thus ?case
    by (auto simp: common_prefix_find)
next
  case (Nabs x t)
  hence *: "frees t - {|x|} |\<subseteq>| fset_of_list (common_prefix \<Gamma> \<Gamma>')"
    by simp

  show ?case
    apply simp
    apply (rule Nabs)
    using * Nabs by auto
qed auto

corollary nterm_to_term_eq_closed: "closed t \<Longrightarrow> nterm_to_term \<Gamma> t = nterm_to_term \<Gamma>' t"
by (rule nterm_to_term_eq) (auto simp: closed_except_def)

lemma nterm_to_term_wellformed: "wellformed' (length \<Gamma>) (nterm_to_term \<Gamma> t)"
proof (induction t arbitrary: \<Gamma>)
  case (Nabs x t)
  hence "wellformed' (Suc (length \<Gamma>)) (nterm_to_term (x # \<Gamma>) t)"
    by (metis length_Cons)
  thus ?case
    by auto
qed (auto simp: find_first_correct split: option.splits)

corollary nterm_to_term_closed_wellformed: "closed t \<Longrightarrow> wellformed (nterm_to_term \<Gamma> t)"
by (metis Ex_list_of_length nterm_to_term_eq_closed nterm_to_term_wellformed)

lemma nterm_to_term_term_to_nterm:
  assumes "frees t |\<subseteq>| fset_of_list \<Gamma>" "length \<Gamma> = length \<Gamma>'"
  shows "alpha_equiv (fmap_of_list (zip \<Gamma> \<Gamma>')) t (fst (run_state (term_to_nterm \<Gamma>' (nterm_to_term \<Gamma> t)) s))"
using assms proof (induction \<Gamma> t arbitrary: s \<Gamma>' rule:nterm_to_term.induct)
  case (4 \<Gamma> x t)
  show ?case
    apply (simp add: split_beta)
    apply (rule alpha_equiv.abs)
    using "4.IH"[where \<Gamma>' = "next s # \<Gamma>'"] "4.prems"
    by (fastforce simp: create_alt_def intro: alpha_equiv.intros)
qed
  (force split: option.splits intro: find_first_some intro!: alpha_equiv.intros
         simp: fset_of_list_elem find_first_in_map split_beta fdisjnt_alt_def)+

corollary nterm_to_term_term_to_nterm': "closed t \<Longrightarrow> t \<approx>\<^sub>\<alpha> term_to_nterm' (nterm_to_term' t)"
unfolding term_to_nterm'_def closed_except_def
apply (rule nterm_to_term_term_to_nterm[where \<Gamma> = "[]" and \<Gamma>' = "[]", simplified])
by auto

context begin

private lemma term_to_nterm_alpha_equiv0:
  "length \<Gamma>1 = length \<Gamma>2 \<Longrightarrow> distinct \<Gamma>1 \<Longrightarrow> distinct \<Gamma>2 \<Longrightarrow> wellformed' (length \<Gamma>1) t1 \<Longrightarrow>
   fresh_fin (frees t1 |\<union>| fset_of_list \<Gamma>1) s1 \<Longrightarrow> fdisjnt (fset_of_list \<Gamma>1) (frees t1) \<Longrightarrow>
   fresh_fin (frees t1 |\<union>| fset_of_list \<Gamma>2) s2 \<Longrightarrow> fdisjnt (fset_of_list \<Gamma>2) (frees t1) \<Longrightarrow>
   alpha_equiv (fmap_of_list (zip \<Gamma>1 \<Gamma>2)) (fst( run_state (term_to_nterm \<Gamma>1 t1) s1)) (fst ( run_state (term_to_nterm \<Gamma>2 t1) s2))"
proof (induction \<Gamma>1 t1 arbitrary: \<Gamma>2 s1 s2 rule:term_to_nterm_induct)
  case (free \<Gamma>1 name)
  then have "name |\<notin>| fmdom (fmap_of_list (zip \<Gamma>1 \<Gamma>2))"
    unfolding fdisjnt_alt_def
    by force
  moreover have "name |\<notin>| fmran (fmap_of_list (zip \<Gamma>1 \<Gamma>2))"
    apply rule
    apply (subst (asm) fmran_of_list)
    apply (subst (asm) fset_of_list_map[symmetric])
    apply (subst (asm) distinct_clearjunk_id)
    subgoal
      apply (subst map_fst_zip)
      apply fact
      apply fact
      done
    apply (subst (asm) map_snd_zip)
    apply fact
    using free unfolding fdisjnt_alt_def
    by fastforce
  ultimately show ?case
    by (force intro:alpha_equiv.intros)
next
  case (abs \<Gamma> t)
  have *: "next s1 > s1" "next s2 > s2"
    using next_ge by force+
  with abs have "next s1 \<notin> set \<Gamma>" "next s2 \<notin> set \<Gamma>2"
    by (metis fBall_funion fset_of_list_elem next_ge_fall)+
  have "fresh_fin (frees t |\<union>| fset_of_list \<Gamma>) (next s1)"
       "fresh_fin (frees t |\<union>| fset_of_list \<Gamma>2) (next s2)"
    using * abs
    by (smt dual_order.trans fBall_pred_weaken frees_term.simps(3) less_imp_le)+
  have "fdisjnt (finsert (next s1) (fset_of_list \<Gamma>)) (frees t)"
       "fdisjnt (finsert (next s2) (fset_of_list \<Gamma>2)) (frees t)"
    unfolding fdisjnt_alt_def using abs frees_term.simps
    by (metis fdisjnt_alt_def finter_finsert_right funionCI inf_commute next_ge_fall)+
  have "wellformed' (Suc (length \<Gamma>2)) t"
    using wellformed'.simps abs
    by (metis Suc_eq_plus1)
  show ?case
    apply (auto simp: split_beta create_alt_def)
    apply rule
    apply (rule abs.IH[of _ "next s2 # \<Gamma>2", simplified])
    by (fact | rule)+
next
  case (app \<Gamma>1 t\<^sub>1 t\<^sub>2)
  hence "wellformed' (length \<Gamma>1) t\<^sub>1" "wellformed' (length \<Gamma>1) t\<^sub>2"
  and "fresh_fin (frees t\<^sub>1 |\<union>| fset_of_list \<Gamma>1) s1" "fresh_fin (frees t\<^sub>1 |\<union>| fset_of_list \<Gamma>2) s2"
  and "fdisjnt (fset_of_list \<Gamma>1) (frees t\<^sub>1)" "fdisjnt (fset_of_list \<Gamma>2) (frees t\<^sub>1)"
  and "fdisjnt (fset_of_list \<Gamma>1) (frees t\<^sub>2)" "fdisjnt (fset_of_list \<Gamma>2) (frees t\<^sub>2)"
    using app
    unfolding fdisjnt_alt_def
    by (auto simp: inf_sup_distrib1)
  have "s1 \<le> snd (run_state (term_to_nterm \<Gamma>1 t\<^sub>1) s1)" "s2 \<le> snd (run_state (term_to_nterm \<Gamma>2 t\<^sub>1) s2)"
    using term_to_nterm_mono
    by (simp add: state_io_rel_def)+
  hence "fresh_fin (frees t\<^sub>2 |\<union>| fset_of_list \<Gamma>1) (snd (run_state (term_to_nterm \<Gamma>1 t\<^sub>1) s1))"
    using \<open>fresh_fin (frees (t\<^sub>1 $ t\<^sub>2) |\<union>| fset_of_list \<Gamma>1) s1\<close>
    by force

  have "fresh_fin (frees t\<^sub>2 |\<union>| fset_of_list \<Gamma>2) (snd (run_state (term_to_nterm \<Gamma>2 t\<^sub>1) s2))"
    apply rule
    using app frees_term.simps \<open>s2 \<le> _\<close> dual_order.trans
    by (metis fbspec funion_iff)

  show ?case
    apply (auto simp: split_beta create_alt_def)
    apply (rule alpha_equiv.app)
    subgoal
      apply (rule app)
      apply (simp | fact)+
      done
    subgoal
      apply (rule app)
      apply (simp | fact)+
      done
    done
qed (force intro: alpha_equiv.intros simp: fmlookup_of_list in_set_zip)+

lemma term_to_nterm_alpha_equiv:
  assumes "length \<Gamma>1 = length \<Gamma>2" "distinct \<Gamma>1" "distinct \<Gamma>2" "closed t"
  assumes "wellformed' (length \<Gamma>1) t"
  assumes "fresh_fin (fset_of_list \<Gamma>1) s1" "fresh_fin (fset_of_list \<Gamma>2) s2"
  shows "alpha_equiv (fmap_of_list (zip \<Gamma>1 \<Gamma>2)) (fst (run_state (term_to_nterm \<Gamma>1 t) s1)) (fst (run_state (term_to_nterm \<Gamma>2 t) s2))"
  \<comment> \<open>An instantiated version of this lemma with @{prop \<open>\<Gamma>1 = []\<close>} and @{prop \<open>\<Gamma>2 = []\<close>}
      would not make sense because then it would just be a special case of
      @{thm [source=true] alpha_eq_refl}.\<close>
using assms
by (simp add: fdisjnt_alt_def closed_except_def term_to_nterm_alpha_equiv0)

end

global_interpretation nrelated: term_struct_rel_strong "(\<lambda>t n. t = nterm_to_term \<Gamma> n)" for \<Gamma>
proof (standard, goal_cases)
  case (5 name t)
  then show ?case by (cases t) (auto simp: const_term_def const_nterm_def split: option.splits)
next
  case (6 u\<^sub>1 u\<^sub>2 t)
  then show ?case by (cases t) (auto simp: app_term_def app_nterm_def split: option.splits)
qed (auto simp: const_term_def const_nterm_def app_term_def app_nterm_def)

lemma env_nrelated_closed:
  assumes "nrelated.P_env \<Gamma> env nenv" "closed_env nenv"
  shows "nrelated.P_env \<Gamma>' env nenv"
proof
  fix x
  from assms have "rel_option (\<lambda>t n. t = nterm_to_term \<Gamma> n) (fmlookup env x) (fmlookup nenv x)"
    by auto
  thus "rel_option (\<lambda>t n. t = nterm_to_term \<Gamma>' n) (fmlookup env x) (fmlookup nenv x)"
    using assms
    by (cases rule: option.rel_cases) (auto dest: fmdomI simp: nterm_to_term_eq_closed)
qed

lemma nrelated_subst:
  assumes "nrelated.P_env \<Gamma> env nenv" "closed_env nenv" "fdisjnt (fset_of_list \<Gamma>) (fmdom nenv)"
  shows "subst (nterm_to_term \<Gamma> t) env = nterm_to_term \<Gamma> (subst t nenv)"
using assms
proof (induction t arbitrary: \<Gamma> env nenv)
  case (Nvar name)
  thus ?case
    proof (cases rule: fmrel_cases[where x = name])
      case (some t\<^sub>1 t\<^sub>2)
      with Nvar have "name |\<notin>| fset_of_list \<Gamma>"
        unfolding fdisjnt_alt_def by (auto dest: fmdomI)
      hence "find_first name \<Gamma> = None"
        including fset.lifting by transfer' (simp add: find_first_none)
      with some show ?thesis
        by auto
    qed (auto split: option.splits)
next
  case (Nabs x t)
  show ?case
    apply simp
    apply (subst subst_drop[symmetric, where x = x])
    subgoal by simp
    apply (rule Nabs)
    using Nabs unfolding fdisjnt_alt_def
    by (auto intro: env_nrelated_closed)
qed auto

lemma nterm_to_term_insert_dupl:
  assumes "y \<in> set (take n \<Gamma>)" "n \<le> length \<Gamma>"
  shows "nterm_to_term \<Gamma> t = incr_bounds (- 1) (Suc n) (nterm_to_term (insert_nth n y \<Gamma>) t)"
using assms
proof (induction t arbitrary: n \<Gamma>)
  case (Nvar name)
  show ?case
    proof (cases "y = name")
      case True
      with Nvar obtain i where "find_first name \<Gamma> = Some i" "i < n"
        by (auto elim: find_first_some_strong)

      hence "find_first name (take n \<Gamma>) = Some i"
        by (rule find_first_prefix)

      show ?thesis
        apply simp
        apply (subst \<open>find_first name \<Gamma> = Some i\<close>)
        apply simp
        apply (subst find_first_append)
        apply (subst \<open>find_first name (take n \<Gamma>) = Some i\<close>)
        apply simp
        using \<open>i < n\<close> by simp
    next
      case False
      show ?thesis
        apply (simp del: insert_nth_take_drop)
        apply (subst find_first_insert_nth_neq)
        subgoal using False by simp
        by (cases "find_first name \<Gamma>") auto
    qed
next
  case (Nabs x t)
  show ?case
    apply simp
    apply (subst Nabs(1)[where n = "Suc n"])
    using Nabs by auto
qed auto

lemma nterm_to_term_bounds_dupl:
  assumes "i < length \<Gamma>" "j < length \<Gamma>" "i < j"
  assumes "\<Gamma> ! i = \<Gamma> ! j"
  shows "j |\<notin>| bounds (nterm_to_term \<Gamma> t)"
using assms
proof (induction t arbitrary: \<Gamma> i j)
  case (Nvar name)
  show ?case
    proof (cases "find_first name \<Gamma>")
      case (Some k)
      show ?thesis
        proof
          assume "j |\<in>| bounds (nterm_to_term \<Gamma> (Nvar name))"
          with Some have "find_first name \<Gamma> = Some j"
            by simp

          moreover have "find_first name \<Gamma> \<noteq> Some j"
            proof (rule find_first_later)
              show "i < length \<Gamma>" "j < length \<Gamma>" "i < j"
                by fact+
            next
              show "\<Gamma> ! j = name"
                by (rule find_first_correct) fact
              thus "\<Gamma> ! i = name"
                using Nvar by simp
            qed

          ultimately show False
            by blast
        qed
    qed simp
next
  case (Nabs x t)
  show ?case
    proof
      assume "j |\<in>| bounds (nterm_to_term \<Gamma> (\<Lambda>\<^sub>n x. t))"
      then obtain j' where "j' |\<in>| bounds (nterm_to_term (x # \<Gamma>) t)" "j' > 0" "j = j' - 1"
        by auto
      hence "Suc j |\<in>| bounds (nterm_to_term (x # \<Gamma>) t)"
        by simp

      moreover have "Suc j |\<notin>| bounds (nterm_to_term (x # \<Gamma>) t)"
        proof (rule Nabs)
          show "Suc i < length (x # \<Gamma>)" "Suc j < length (x # \<Gamma>)" "Suc i < Suc j" "(x # \<Gamma>) ! Suc i = (x # \<Gamma>) ! Suc j"
            using Nabs by simp+
        qed

      ultimately show False
        by blast
    qed
  qed auto

fun subst_single :: "nterm \<Rightarrow> name \<Rightarrow> nterm \<Rightarrow> nterm" where
"subst_single (Nvar s) s' t' = (if s = s' then t' else Nvar s)" |
"subst_single (t\<^sub>1 $\<^sub>n t\<^sub>2) s' t' = subst_single t\<^sub>1 s' t' $\<^sub>n subst_single t\<^sub>2 s' t'" |
"subst_single (\<Lambda>\<^sub>n x. t) s' t' = (\<Lambda>\<^sub>n x. (if x = s' then t else subst_single t s' t'))" |
"subst_single t _ _ = t"

lemma subst_single_eq: "subst_single t s t' = subst t (fmap_of_list [(s, t')])"
proof (induction t)
  case (Nabs x t)
  then show ?case
    by (cases "x = s") (simp add: fmfilter_alt_defs)+
qed auto

lemma nterm_to_term_subst_replace_bound:
  assumes "closed u'" "n \<le> length \<Gamma>" "x \<notin> set (take n \<Gamma>)"
  shows "nterm_to_term \<Gamma> (subst_single u x u') = replace_bound n (nterm_to_term (insert_nth n x \<Gamma>) u) (nterm_to_term \<Gamma> u')"
using assms
proof (induction u arbitrary: n \<Gamma>)
  case (Nvar name)
  note insert_nth_take_drop[simp del]
  show ?case
    proof (cases "name = x")
      case True
      thus ?thesis
        using Nvar
        apply (simp add: find_first_insert_nth_eq)
        apply (subst incr_bounds_eq[where k = 0])
        subgoal by simp
        apply (rule nterm_to_term_closed_wellformed)
        by auto
    next
      case False
      thus ?thesis
        apply auto
        apply (subst find_first_insert_nth_neq)
        subgoal by simp
        by (cases "find_first name \<Gamma>") auto
    qed
next
  case (Nabs y t)
  note insert_nth_take_drop[simp del]
  show ?case
    proof (cases "x = y")
      case True
      have "nterm_to_term (y # \<Gamma>) t = replace_bound (Suc n) (nterm_to_term (y # insert_nth n y \<Gamma>) t) (nterm_to_term \<Gamma> u')"
        proof (subst replace_bound_eq)
          show "Suc n |\<notin>| bounds (nterm_to_term (y # insert_nth n y \<Gamma>) t)"
            apply (rule nterm_to_term_bounds_dupl[where i = 0])
            subgoal by simp
            subgoal using Nabs(3) by (simp add: insert_nth_take_drop)
            subgoal by simp
            apply simp
            apply (subst nth_insert_nth_index_eq)
            using Nabs by auto
          show "nterm_to_term (y # \<Gamma>) t = incr_bounds (- 1) (Suc n + 1) (nterm_to_term (y # insert_nth n y \<Gamma>) t)"
            apply (subst nterm_to_term_insert_dupl[where \<Gamma> = "y # \<Gamma>" and y = y and n = "Suc n"])
            using Nabs by auto
        qed
      with True show ?thesis
        by auto
    next
      case False
      have "nterm_to_term (y # \<Gamma>) (subst_single t x u') = replace_bound (Suc n) (nterm_to_term (y # insert_nth n x \<Gamma>) t) (nterm_to_term \<Gamma> u')"
        apply (subst Nabs(1)[of "Suc n"])
        subgoal by fact
        subgoal using Nabs by simp
        subgoal using False Nabs by simp
        apply (subst nterm_to_term_eq_closed[where t = u'])
        using Nabs by auto
      with False show ?thesis
        by auto
    qed
qed auto

corollary nterm_to_term_subst_\<beta>:
  assumes "closed u'"
  shows "nterm_to_term \<Gamma> (subst u (fmap_of_list [(x, u')])) = nterm_to_term (x # \<Gamma>) u [nterm_to_term \<Gamma> u']\<^sub>\<beta>"
using assms
by (rule nterm_to_term_subst_replace_bound[where n = 0, simplified, unfolded subst_single_eq])

end


(* D. Fuenmayor and A. Steen, August 2021 *)
(* This file contains the verification of meta-theoretical connections of labelling-based semanticss.
   Auxiliary references:
 [BCG 2011] Baroni, P., M. Caminada and M. Giacomin, An introduction to argumentation semantics,
            Knowledge Engineering Review (2011)
*)
theory "lab-simpl-relationships"
  imports "labellings-simpl"  "lab-simpl-properties"
begin

(************************************************************************)
(* Inclusion relations as summary: Figure 12 of [BCG2011]
   NOT YET All verified. The non-inclusion of the inverse directions has been checked
   with Nitpick in every case.  *)
(************************************************************************)

lemma stage_implies_cf: \<open>stageLab AF Lab \<Longrightarrow> conflictfreeLab AF Lab\<close>
  by (simp add: stageLab_def minimal_def)

lemma admissible_implies_cf: \<open>admissibleLab AF Lab \<Longrightarrow> conflictfreeLab AF Lab\<close>
  by (simp add: admissibleLab_def conflictfreeLab_def inset_def legallyIn_def legallyOut_def outset_def)

lemma complete_implies_admissible: \<open>completeLab AF Lab \<Longrightarrow> admissibleLab AF Lab\<close>
  by (simp add: admissibleLab_def completeLab_def)

lemma grounded_implies_complete: \<open>groundedLab AF Lab \<Longrightarrow> completeLab AF Lab\<close>
  by (simp add: groundedLab_def minimal_def)

lemma preferred_implies_complete: \<open>preferredLab AF Lab \<Longrightarrow> completeLab AF Lab\<close>
  by (simp add: preferredLab_def maximal_def)

lemma \<open>idealLab AF Lab \<Longrightarrow> completeLab AF Lab\<close>
  unfolding idealLab_def qidealLab_def unfolding
  preferredMaxCompleteLabEq
  unfolding completeLab2_def complete_defEq
  using DungFundLemma1Lab oops (* TODO: still not working...*)
  (* by (smt (z3) DungFundLemma1Lab admissible_EL admissible_LE admissible_def complete2_def complete_defEq defends_def inset_def legallyIn_def legallyOut_def lessOrEquallyCommittedLab_def outset_def plusset_def) *)

lemma \<open>stableLab AF Lab \<Longrightarrow> stageLab AF Lab\<close>
  by (simp add: admissible_implies_cf leastMin least_def stableLab_def stageLab_def complete_implies_admissible undecset_def)

lemma \<open>semistableLab AF Lab \<Longrightarrow> preferredLab AF Lab \<close> unfolding semistableLab_def preferredLab_def minimal_def maximal_def
  by (smt (verit, ccfv_SIG) Label.exhaust completeLab2_def complete_defEq inset_def legallyOut_def outset_def undecset_def)

lemma \<open>stableLab AF Lab \<Longrightarrow> semistableLab AF Lab\<close>
  by (simp add: semistableLab_def stableLab_def undecset_def minimal_def)

end


section \<open>Directed Graphs\<close>
(* Author: Peter Lammich *)
theory Digraph
  imports
  CAVA_Base.CAVA_Base
  Digraph_Basic
begin

subsection "Directed Graphs with Explicit Node Set and Set of Initial Nodes"

record 'v graph_rec =
  g_V :: "'v set"
  g_E :: "'v digraph"
  g_V0 :: "'v set"

definition graph_restrict :: "('v, 'more) graph_rec_scheme \<Rightarrow> 'v set \<Rightarrow> ('v, 'more) graph_rec_scheme"
  where "graph_restrict G R \<equiv>
  \<lparr>
    g_V = g_V G,
    g_E = rel_restrict (g_E G) R,
    g_V0 = g_V0 G - R,
    \<dots> = graph_rec.more G
  \<rparr>"

lemma graph_restrict_simps[simp]:
  "g_V (graph_restrict G R) = g_V G"
  "g_E (graph_restrict G R) = rel_restrict (g_E G) R"
  "g_V0 (graph_restrict G R) = g_V0 G - R"
  "graph_rec.more (graph_restrict G R) = graph_rec.more G"
  unfolding graph_restrict_def by auto

lemma graph_restrict_trivial[simp]: "graph_restrict G {} = G" by simp

locale graph_defs =
  fixes G :: "('v, 'more) graph_rec_scheme"
begin

  abbreviation "V \<equiv> g_V G"
  abbreviation "E \<equiv> g_E G"
  abbreviation "V0 \<equiv> g_V0 G"

  abbreviation "reachable \<equiv> E\<^sup>* `` V0"
  abbreviation "succ v \<equiv> E `` {v}"

  lemma finite_V0: "finite reachable \<Longrightarrow> finite V0" by (auto intro: finite_subset)

  definition is_run
    \<comment> \<open>Infinite run, i.e., a rooted infinite path\<close>
    where "is_run r \<equiv> r 0 \<in> V0 \<and> ipath E r"

  lemma run_reachable: "is_run r \<Longrightarrow> range r \<subseteq> reachable"
    unfolding is_run_def using ipath_to_rtrancl by blast

end

locale graph =
  graph_defs G
  for G :: "('v, 'more) graph_rec_scheme"
  +
  assumes V0_ss: "V0 \<subseteq> V"
  assumes E_ss: "E \<subseteq> V \<times> V"
begin

  lemma reachable_V: "reachable \<subseteq> V" using V0_ss E_ss by (auto elim: rtrancl_induct)

  lemma finite_E: "finite V \<Longrightarrow> finite E" using finite_subset E_ss by auto

end

(* TODO: finite reachability is handled using loose assumptions, while finitely branching
  graphs are captured using a locale. it may be advantageous to unify this. *)
locale fb_graph =
  graph G
  for G :: "('v, 'more) graph_rec_scheme"
  +
  assumes finite_V0[simp, intro!]: "finite V0"
  assumes finitely_branching[simp, intro]: "v \<in> reachable \<Longrightarrow> finite (succ v)"
begin

  lemma fb_graph_subset:
    assumes "g_V G' = V"
    assumes "g_E G' \<subseteq> E"
    assumes "finite (g_V0 G')"
    assumes "g_V0 G' \<subseteq> reachable"
    shows "fb_graph G'"
  proof
    show "g_V0 G' \<subseteq> g_V G'" using reachable_V assms(1, 4) by simp
    show "g_E G' \<subseteq> g_V G' \<times> g_V G'" using E_ss assms(1, 2) by simp
    show "finite (g_V0 G')" using assms(3) by this
  next
    fix v
    assume 1: "v \<in> (g_E G')\<^sup>* `` g_V0 G'"
    obtain u where 2: "u \<in> g_V0 G'" "(u, v) \<in> (g_E G')\<^sup>*" using 1 by rule
    have 3: "u \<in> reachable" "(u, v) \<in> E\<^sup>*" using rtrancl_mono assms(2, 4) 2 by auto
    have 4: "v \<in> reachable" using rtrancl_image_advance_rtrancl 3 by metis
    have 5: "finite (E `` {v})" using 4 by rule
    have 6: "g_E G' `` {v} \<subseteq> E `` {v}" using assms(2) by auto
    show "finite (g_E G' `` {v})" using finite_subset 5 6 by auto
  qed

  lemma fb_graph_restrict: "fb_graph (graph_restrict G R)"
    by (rule fb_graph_subset, auto simp: rel_restrict_sub)

end

lemma (in graph) fb_graphI_fr:
  assumes "finite reachable"
  shows "fb_graph G"
proof
  from assms show "finite V0" by (rule finite_subset[rotated]) auto
  fix v
  assume "v \<in> reachable"
  hence "succ v \<subseteq> reachable" by (metis Image_singleton_iff rtrancl_image_advance subsetI)
  thus "finite (succ v)" using assms by (rule finite_subset)
qed

abbreviation "rename_E f E \<equiv> (\<lambda>(u,v). (f u, f v))`E"

definition "fr_rename_ext ecnv f G \<equiv> \<lparr>
    g_V = f`(g_V G),
    g_E = rename_E f (g_E G),
    g_V0 = (f`g_V0 G),
    \<dots> = ecnv G
  \<rparr>"

locale g_rename_precond =
  graph G
  for G :: "('u,'more) graph_rec_scheme"
  +
  fixes f :: "'u \<Rightarrow> 'v"
  fixes ecnv :: "('u, 'more) graph_rec_scheme \<Rightarrow> 'more'"
  assumes INJ: "inj_on f V"
begin

  abbreviation "G' \<equiv> fr_rename_ext ecnv f G"

  lemma G'_fields:
    "g_V G' = f`V"
    "g_V0 G' = f`V0"
    "g_E G' = rename_E f E"
    unfolding fr_rename_ext_def by simp_all

  definition "fi \<equiv> the_inv_into V f"

  lemma
    fi_f: "x\<in>V \<Longrightarrow> fi (f x) = x" and
    f_fi: "y\<in>f`V \<Longrightarrow> f (fi y) = y" and
    fi_f_eq: "\<lbrakk>f x = y; x\<in>V\<rbrakk> \<Longrightarrow> fi y = x"
    unfolding fi_def
    by (auto
      simp: the_inv_into_f_f f_the_inv_into_f the_inv_into_f_eq INJ)

  lemma E'_to_E: "(u,v) \<in> g_E G' \<Longrightarrow> (fi u, fi v)\<in>E"
    using E_ss
    by (auto simp: fi_f G'_fields)

  lemma V0'_to_V0: "v\<in>g_V0 G' \<Longrightarrow> fi v \<in> V0"
    using V0_ss
    by (auto simp: fi_f G'_fields)

  lemma rtrancl_E'_sim:
    assumes "(f u,v')\<in>(g_E G')\<^sup>*"
    assumes "u\<in>V"
    shows "\<exists>v. v' = f v \<and> v\<in>V \<and> (u,v)\<in>E\<^sup>*"
    using assms
  proof (induction "f u" v' arbitrary: u)
    case (rtrancl_into_rtrancl v' w' u)
    then obtain v w where "v' = f v" "w' = f w" "(v,w)\<in>E"
      by (auto simp: G'_fields)
    hence "v\<in>V" "w\<in>V" using E_ss by auto
    from rtrancl_into_rtrancl obtain vv where "v' = f vv" "vv\<in>V" "(u,vv)\<in>E\<^sup>*"
      by blast
    from \<open>v' = f v\<close> \<open>v\<in>V\<close> \<open>v' = f vv\<close> \<open>vv\<in>V\<close> have [simp]: "vv = v"
      using INJ by (metis inj_on_contraD)

    note \<open>(u,vv)\<in>E\<^sup>*\<close>[simplified]
    also note \<open>(v,w)\<in>E\<close>
    finally show ?case using \<open>w' = f w\<close> \<open>w\<in>V\<close> by blast
  qed auto

  lemma rtrancl_E'_to_E: assumes "(u,v)\<in>(g_E G')\<^sup>*" shows "(fi u, fi v)\<in>E\<^sup>*"
    using assms apply induction
    by (fastforce intro: E'_to_E rtrancl_into_rtrancl)+

  lemma G'_invar: "graph G'"
    apply unfold_locales
  proof -
    show "g_V0 G' \<subseteq> g_V G'"
      using V0_ss by (auto simp: G'_fields) []

    show "g_E G' \<subseteq> g_V G' \<times> g_V G'"
      using E_ss by (auto simp: G'_fields) []
  qed

  sublocale G': graph G' using G'_invar .

  lemma G'_finite_reachable:
    assumes "finite ((g_E G)\<^sup>* `` g_V0 G)"
    shows "finite ((g_E G')\<^sup>* `` g_V0 G')"
  proof -
    have "(g_E G')\<^sup>* `` g_V0 G' \<subseteq> f ` (E\<^sup>*``V0)"
      apply (clarsimp_all simp: G'_fields(2))
      apply (drule rtrancl_E'_sim)
      using V0_ss apply auto []
      apply auto
      done
    thus ?thesis using finite_subset assms by blast
  qed

  lemma V'_to_V: "v \<in> G'.V \<Longrightarrow> fi v \<in> V"
    by (auto simp: fi_f G'_fields)

  lemma ipath_sim1: "ipath E r \<Longrightarrow> ipath G'.E (f o r)"
    unfolding ipath_def by (auto simp: G'_fields)

  lemma ipath_sim2: "ipath G'.E r \<Longrightarrow> ipath E (fi o r)"
    unfolding ipath_def
    apply (clarsimp simp: G'_fields)
    apply (drule_tac x=i in spec)
    using E_ss
    by (auto simp: fi_f)

  lemma run_sim1: "is_run r \<Longrightarrow> G'.is_run (f o r)"
    unfolding is_run_def G'.is_run_def
    apply (intro conjI)
    apply (auto simp: G'_fields) []
    apply (auto simp: ipath_sim1)
    done

  lemma run_sim2: "G'.is_run r \<Longrightarrow> is_run (fi o r)"
    unfolding is_run_def G'.is_run_def
    by (auto simp: ipath_sim2 V0'_to_V0)

end

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

section "Enumeration extensions and alternative definition"

theory Enumeration
imports "~~/src/HOL/Main"
begin

abbreviation
  "enum \<equiv> enum_class.enum"
abbreviation
  "enum_all \<equiv> enum_class.enum_all"
abbreviation
  "enum_ex \<equiv> enum_class.enum_ex"

primrec (nonexhaustive)
  the_index :: "'a list \<Rightarrow> 'a \<Rightarrow> nat"
where
  "the_index (x # xs) y = (if x = y then 0 else Suc (the_index xs y))"

lemma the_index_bounded:
  "x \<in> set xs \<Longrightarrow> the_index xs x < length xs"
  by (induct xs, clarsimp+)

lemma nth_the_index:
  "x \<in> set xs \<Longrightarrow> xs ! the_index xs x = x"
  by (induct xs, clarsimp+)

lemma distinct_the_index_is_index[simp]:
  "\<lbrakk> distinct xs ; n < length xs \<rbrakk> \<Longrightarrow> the_index xs (xs ! n) = n"
  by (meson nth_eq_iff_index_eq nth_mem nth_the_index the_index_bounded)

lemma the_index_last_distinct:
  "distinct xs \<and> xs \<noteq> [] \<Longrightarrow> the_index xs (last xs) = length xs - 1"
  apply safe
  apply (subgoal_tac "xs ! (length xs - 1) = last xs")
   apply (subgoal_tac "xs ! the_index xs (last xs) = last xs")
    apply (subst nth_eq_iff_index_eq[symmetric])
       apply assumption
      apply (rule the_index_bounded)
      apply simp_all
   apply (rule nth_the_index)
   apply simp
  apply (induct xs, auto)
  done

context enum begin

(* These two are added for historical reasons. *)
lemmas enum_surj[simp] = enum_UNIV
declare enum_distinct[simp]

lemma enum_nonempty[simp]: "(enum :: 'a list) \<noteq> []"
  using enum_surj by fastforce

definition
  maxBound :: 'a where
  "maxBound \<equiv> last enum"

definition
  minBound :: 'a where
  "minBound \<equiv> hd enum"

definition
  toEnum :: "nat \<Rightarrow> 'a" where
  "toEnum n \<equiv> if n < length (enum :: 'a list) then enum ! n else the None"

definition
  fromEnum :: "'a \<Rightarrow> nat" where
  "fromEnum x \<equiv> the_index enum x"

lemma maxBound_is_length:
  "fromEnum maxBound = length (enum :: 'a list) - 1"
  by (simp add: maxBound_def fromEnum_def the_index_last_distinct)

lemma maxBound_less_length:
  "(x \<le> fromEnum maxBound) = (x < length (enum :: 'a list))"
  unfolding maxBound_is_length by (cases "length enum") auto

lemma maxBound_is_bound [simp]:
  "fromEnum x \<le> fromEnum maxBound"
  unfolding maxBound_less_length
  by (fastforce simp: fromEnum_def intro: the_index_bounded)

lemma to_from_enum [simp]:
  fixes x :: 'a
  shows "toEnum (fromEnum x) = x"
proof -
  have "x \<in> set enum" by simp
  then show ?thesis by (simp add: toEnum_def fromEnum_def nth_the_index the_index_bounded)
qed

lemma from_to_enum [simp]:
  "x \<le> fromEnum maxBound \<Longrightarrow> fromEnum (toEnum x) = x"
  unfolding maxBound_less_length by (simp add: toEnum_def fromEnum_def)

lemma map_enum:
  fixes x :: 'a
  shows "map f enum ! fromEnum x = f x"
proof -
  have "fromEnum x \<le> fromEnum (maxBound :: 'a)"
    by (rule maxBound_is_bound)
  then have "fromEnum x < length (enum::'a list)"
    by (simp add: maxBound_less_length)
  then have "map f enum ! fromEnum x = f (enum ! fromEnum x)" by simp
  also
  have "x \<in> set enum" by simp
  then have "enum ! fromEnum x = x"
    by (simp add: fromEnum_def nth_the_index)
  finally
  show ?thesis .
qed

definition
  assocs :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'b) list" where
 "assocs f \<equiv> map (\<lambda>x. (x, f x)) enum"

end

(* For historical naming reasons. *)
lemmas enum_bool = enum_bool_def

lemma fromEnumTrue [simp]: "fromEnum True = 1"
  by (simp add: fromEnum_def enum_bool)

lemma fromEnumFalse [simp]: "fromEnum False = 0"
  by (simp add: fromEnum_def enum_bool)

class enum_alt =
  fixes enum_alt :: "nat \<Rightarrow> 'a option"

class enumeration_alt = enum_alt +
  assumes enum_alt_one_bound:
    "enum_alt x = (None :: 'a option) \<Longrightarrow> enum_alt (Suc x) = (None :: 'a option)"
  assumes enum_alt_surj:
    "range enum_alt \<union> {None} = UNIV"
  assumes enum_alt_inj:
    "(enum_alt x :: 'a option) = enum_alt y \<Longrightarrow> (x = y) \<or> (enum_alt x = (None :: 'a option))"
begin

lemma enum_alt_inj_2:
  assumes "enum_alt x = (enum_alt y :: 'a option)"
          "enum_alt x \<noteq> (None :: 'a option)"
  shows "x = y"
proof -
  from assms
  have "(x = y) \<or> (enum_alt x = (None :: 'a option))" by (fastforce intro!: enum_alt_inj)
  with assms show ?thesis by clarsimp
qed

lemma enum_alt_surj_2:
  "\<exists>x. enum_alt x = Some y"
proof -
  have "Some y \<in> range enum_alt \<union> {None}" by (subst enum_alt_surj) simp
  then have "Some y \<in> range enum_alt" by simp
  then show ?thesis by auto
qed

end

definition
  alt_from_ord :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option"
where
  "alt_from_ord L \<equiv> \<lambda>n. if (n < length L) then Some (L ! n) else None"

lemma handy_if_lemma: "((if P then Some A else None) = Some B) = (P \<and> (A = B))"
  by simp

class enumeration_both = enum_alt + enum +
  assumes enum_alt_rel: "enum_alt = alt_from_ord enum"

instance enumeration_both < enumeration_alt
  apply (intro_classes; simp add: enum_alt_rel alt_from_ord_def)
    apply auto[1]
   apply (safe; simp)[1]
   apply (rule rev_image_eqI; simp)
    apply (rule the_index_bounded; simp)
   apply (subst nth_the_index; simp)
  apply (clarsimp simp: handy_if_lemma)
  apply (subst nth_eq_iff_index_eq[symmetric]; simp)
  done

instantiation bool :: enumeration_both
begin
  definition enum_alt_bool: "enum_alt \<equiv> alt_from_ord [False, True]"
  instance by (intro_classes, simp add: enum_bool_def enum_alt_bool)
end

definition
  toEnumAlt :: "nat \<Rightarrow> ('a :: enum_alt)" where
 "toEnumAlt n \<equiv> the (enum_alt n)"

definition
  fromEnumAlt :: "('a :: enum_alt) \<Rightarrow> nat" where
 "fromEnumAlt x \<equiv> THE n. enum_alt n = Some x"

definition
  upto_enum :: "('a :: enumeration_alt) \<Rightarrow> 'a \<Rightarrow> 'a list" ("(1[_.e._])") where
 "upto_enum n m \<equiv> map toEnumAlt [fromEnumAlt n ..< Suc (fromEnumAlt m)]"

lemma fromEnum_alt_red[simp]:
  "fromEnumAlt = (fromEnum :: ('a :: enumeration_both) \<Rightarrow> nat)"
  apply (rule ext)
  apply (simp add: fromEnumAlt_def fromEnum_def enum_alt_rel alt_from_ord_def)
  apply (rule theI2)
    apply (rule conjI)
     apply (clarify, rule nth_the_index, simp)
    apply (rule the_index_bounded, simp)
   apply auto
  done

lemma toEnum_alt_red[simp]:
  "toEnumAlt = (toEnum :: nat \<Rightarrow> 'a :: enumeration_both)"
  by (rule ext) (simp add: enum_alt_rel alt_from_ord_def toEnum_def toEnumAlt_def)

lemma upto_enum_red:
  "[(n :: ('a :: enumeration_both)) .e. m] = map toEnum [fromEnum n ..< Suc (fromEnum m)]"
  unfolding upto_enum_def by simp

instantiation nat :: enumeration_alt
begin
  definition enum_alt_nat: "enum_alt \<equiv> Some"
  instance by (intro_classes; simp add: enum_alt_nat UNIV_option_conv)
end

lemma toEnumAlt_nat[simp]: "toEnumAlt = id"
  by (rule ext) (simp add: toEnumAlt_def enum_alt_nat)

lemma fromEnumAlt_nat[simp]: "fromEnumAlt = id"
  by (rule ext) (simp add: fromEnumAlt_def enum_alt_nat)

lemma upto_enum_nat[simp]: "[n .e. m] = [n ..< Suc m]"
  by (subst upto_enum_def) simp

definition
  zipE1 :: "'a :: enum_alt \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list"
where
  "zipE1 x L \<equiv> zip (map toEnumAlt [fromEnumAlt x ..< fromEnumAlt x + length L]) L"

definition
  zipE2 :: "'a :: enum_alt \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list"
where
  "zipE2 x xn L \<equiv> zip (map (\<lambda>n. toEnumAlt (fromEnumAlt x + (fromEnumAlt xn - fromEnumAlt x) * n))
                      [0 ..< length L]) L"

definition
  zipE3 :: "'a list \<Rightarrow> 'b :: enum_alt \<Rightarrow> ('a \<times> 'b) list"
where
  "zipE3 L x \<equiv> zip L (map toEnumAlt [fromEnumAlt x ..< fromEnumAlt x + length L])"

definition
  zipE4 :: "'a list \<Rightarrow> 'b :: enum_alt \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'b) list"
where
  "zipE4 L x xn \<equiv> zip L (map (\<lambda>n. toEnumAlt (fromEnumAlt x + (fromEnumAlt xn - fromEnumAlt x) * n))
                         [0 ..< length L])"

lemma to_from_enum_alt[simp]:
  "toEnumAlt (fromEnumAlt x) = (x :: 'a :: enumeration_alt)"
proof -
  have rl: "\<And>a b. a = Some b \<Longrightarrow> the a = b" by simp
  show ?thesis
    unfolding fromEnumAlt_def toEnumAlt_def
    by (rule rl, rule theI') (metis enum_alt_inj enum_alt_surj_2 not_None_eq)
qed

lemma upto_enum_triv [simp]: "[x .e. x] = [x]"
  unfolding upto_enum_def by simp

lemma toEnum_eq_to_fromEnum_eq:
  fixes v :: "'a :: enum"
  shows "n \<le> fromEnum (maxBound :: 'a) \<Longrightarrow> (toEnum n = v) = (n = fromEnum v)"
  by auto

end


(*  Title:      ZF/Induct/Rmap.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>An operator to ``map'' a relation over a list\<close>

theory Rmap imports ZF begin

consts
  rmap :: "i=>i"

inductive
  domains "rmap(r)" \<subseteq> "list(domain(r)) \<times> list(range(r))"
  intros
    NilI:  "<Nil,Nil> \<in> rmap(r)"

    ConsI: "[| <x,y>: r;  <xs,ys> \<in> rmap(r) |]
            ==> <Cons(x,xs), Cons(y,ys)> \<in> rmap(r)"

  type_intros domainI rangeI list.intros

lemma rmap_mono: "r \<subseteq> s ==> rmap(r) \<subseteq> rmap(s)"
  apply (unfold rmap.defs)
  apply (rule lfp_mono)
    apply (rule rmap.bnd_mono)+
  apply (assumption | rule Sigma_mono list_mono domain_mono range_mono basic_monos)+
  done

inductive_cases
      Nil_rmap_case [elim!]: "<Nil,zs> \<in> rmap(r)"
  and Cons_rmap_case [elim!]: "<Cons(x,xs),zs> \<in> rmap(r)"

declare rmap.intros [intro]

lemma rmap_rel_type: "r \<subseteq> A \<times> B ==> rmap(r) \<subseteq> list(A) \<times> list(B)"
  apply (rule rmap.dom_subset [THEN subset_trans])
  apply (assumption |
    rule domain_rel_subset range_rel_subset Sigma_mono list_mono)+
  done

lemma rmap_total: "A \<subseteq> domain(r) ==> list(A) \<subseteq> domain(rmap(r))"
  apply (rule subsetI)
  apply (erule list.induct)
   apply blast+
  done

lemma rmap_functional: "function(r) ==> function(rmap(r))"
  apply (unfold function_def)
  apply (rule impI [THEN allI, THEN allI])
  apply (erule rmap.induct)
   apply blast+
  done

text \<open>
  \medskip If \<open>f\<close> is a function then \<open>rmap(f)\<close> behaves
  as expected.
\<close>

lemma rmap_fun_type: "f \<in> A->B ==> rmap(f): list(A)->list(B)"
  by (simp add: Pi_iff rmap_rel_type rmap_functional rmap_total)

lemma rmap_Nil: "rmap(f)`Nil = Nil"
  by (unfold apply_def) blast

lemma rmap_Cons: "[| f \<in> A->B;  x \<in> A;  xs: list(A) |]
      ==> rmap(f) ` Cons(x,xs) = Cons(f`x, rmap(f)`xs)"
  by (blast intro: apply_equality apply_Pair rmap_fun_type rmap.intros)

end


theory Horn_Fset
  imports Horn_Inference FSet_Utils
begin

locale horn_fset_impl = horn +
  fixes infer0_impl :: "'a list" and infer1_impl :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'a list"
begin

lemma saturate_fold_simp [simp]:
  "fold (\<lambda>xa. case_option None (f xa)) xs None = None"
  by (induct xs) auto

lemma saturate_fold_mono [partial_function_mono]:
  "option.mono_body (\<lambda>f. fold (\<lambda>x. case_option None (\<lambda>y. f (x, y))) xs b)"
  unfolding monotone_def fun_ord_def flat_ord_def
proof (intro allI impI, induct xs arbitrary: b)
  case (Cons a xs)
  show ?case
    using Cons(1)[OF Cons(2), of "x (a, the b)"] Cons(2)[rule_format, of "(a, the b)"]
    by (cases b) auto
qed auto

partial_function (option) saturate_rec :: "'a \<Rightarrow> 'a fset \<Rightarrow> ('a fset) option" where
  "saturate_rec x bs = (if x |\<in>| bs then Some bs else
     fold (\<lambda>x. case_option None (saturate_rec x)) (infer1_impl x bs) (Some (finsert x bs)))"

definition saturate_impl where
  "saturate_impl = fold (\<lambda>x. case_option None (saturate_rec x)) infer0_impl (Some {||})"

end

locale horn_fset = horn_fset_impl +
  assumes infer0: "infer0 = set infer0_impl"
    and infer1: "\<And>x bs. infer1 x (fset bs) = set (infer1_impl x bs)"
begin

lemma saturate_rec_sound:
  "saturate_rec x bs = Some bs' \<Longrightarrow> ({x}, fset bs) \<turnstile> ({}, fset bs')"
proof (induct arbitrary: x bs bs' rule: saturate_rec.fixp_induct)
  case 1 show ?case using option_admissible[of "\<lambda>(x, y) z. _ x y z"]
    by fastforce
next
  case (3 rec)
  have [dest!]: "(set xs, fset ys) \<turnstile> ({}, fset bs')"
    if "fold (\<lambda>x a. case a of None \<Rightarrow> None | Some a \<Rightarrow> rec x a) xs (Some ys) = Some bs'"
    for xs ys using that
  proof (induct xs arbitrary: ys)
    case (Cons a xs)
    show ?case using trans[OF step_mono[OF 3(1)], of a ys _ "set xs" "{}" "fset bs'"] Cons
      by (cases "rec a ys") auto
  qed (auto intro: refl)
  show ?case using propagate[of x "{}" "fset bs", unfolded infer1 Un_empty_left] 3(2)
    by (auto simp: delete fmember_iff_member_fset split: if_splits intro: trans delete)
qed auto

lemma saturate_impl_sound:
  assumes "saturate_impl = Some B'"
  shows "fset B' = saturate"
proof -
  have "(set xs, fset ys) \<turnstile> ({}, fset bs')"
    if "fold (\<lambda>x a. case a of None \<Rightarrow> None | Some a \<Rightarrow> saturate_rec x a) xs (Some ys) = Some bs'"
    for xs ys bs' using that
  proof (induct xs arbitrary: ys)
    case (Cons a xs)
    show ?case
      using trans[OF step_mono[OF saturate_rec_sound], of a ys _ "set xs" "{}" "fset bs'"] Cons
      by (cases "saturate_rec a ys") auto
  qed (auto intro: refl)
  from this[of infer0_impl "{||}" B'] assms step_sound show ?thesis
    by (auto simp: saturate_impl_def infer0)
qed

lemma saturate_impl_complete:
  assumes "finite saturate"
  shows "saturate_impl \<noteq> None"
proof -
  have *: "fold (\<lambda>x. case_option None (saturate_rec x)) ds (Some bs) \<noteq> None"
    if "fset bs \<subseteq> saturate" "set ds \<subseteq> saturate" for bs ds
    using that
  proof (induct "card (saturate - fset bs)" arbitrary: bs ds rule: less_induct)
    case less
    show ?case using less(3)
    proof (induct ds)
      case (Cons d ds)
      have "infer1 d (fset bs) \<subseteq> saturate" using less(2) Cons(2)
        unfolding infer1_def by (auto intro: saturate.infer)
      moreover have "card (saturate - fset (finsert d bs)) < card (saturate - fset bs)" if "d \<notin> fset bs"
        using Cons(2) assms that
        by (metis DiffI Diff_insert card_Diff1_less finite_Diff finsert.rep_eq in_mono insertCI list.simps(15))
      ultimately show ?case using less(1)[of "finsert d bs" "infer1_impl d bs @ ds"] less(2) Cons assms
        unfolding fold.simps comp_def option.simps
        apply (subst saturate_rec.simps)
        apply (auto simp flip: saturate_rec.simps split!: if_splits simp: infer1)
        apply (simp add: notin_fset saturate_rec.simps)
        done
    qed simp
  qed
  show ?thesis using *[of "{||}" "infer0_impl"] inv_start by (simp add: saturate_impl_def infer0)
qed

end

lemmas [code] = horn_fset_impl.saturate_rec.simps horn_fset_impl.saturate_impl_def

end


(*
 * Copyright 2016, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory FunBucket
imports
  TypBucket
  L4vBucket
begin

definition count :: "'a list \<Rightarrow> ('b::len) word"
 where
"count xs \<equiv> of_nat (length xs) :: 'b word"

definition is_pow_of_2 :: "U32 \<Rightarrow> bool"
where
 "is_pow_of_2 x \<equiv> \<exists>k. x = 1 << k \<and> k < 32"

declare fun_app_def [iff]

text {* slice: Return a slice of a list, frm and to are offset from the
beginning of the list *}
definition
  slice :: "nat \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
 "slice frm to xs  \<equiv> List.drop frm $ take to xs"

lemma length_slice:
 "length (slice f t xs) = min (length xs) t - f"
 by (simp add: slice_def)

lemma slice_n_n:
 "slice n n xs = []"
 by (simp add: slice_def)

lemma slice_append: "slice f t (xs @ ys) = slice f t xs @ slice (f - min (length xs) t) (t - length xs) ys"
 by  (simp add: slice_def)

lemmas slice_simps = length_slice slice_n_n slice_append slice_def

lemma sub_mod_mask:
  "\<lbrakk>k < 32 \<rbrakk> \<Longrightarrow> (x::32 word) - x mod 2^k = x && ~~ mask k"
  apply (simp add: word_mod_2p_is_mask p2_gt_0 mask_out_sub_mask)
  done

lemma alignUp_not_aligned_eq2:
  " \<not> is_aligned a n \<Longrightarrow> Word_Lib.alignUp a n = ((a >> n) + 1) << n"
  apply (cases "n < size a")
   apply (subst alignUp_not_aligned_eq, assumption)
    apply (simp add: word_size)
   apply (simp add: shiftr_div_2n_w shiftl_t2n)
  apply (simp add: Word_Lib.alignUp_def power_overflow
        word_size complement_def shiftl_zero_size)
 done

lemma alignUp_not_aligned_eq3:
  "\<not> is_aligned a n \<Longrightarrow> Word_Lib.alignUp a n = (a && ~~ mask n) + (1 << n)"
  by (simp add: alignUp_not_aligned_eq2 word_shiftl_add_distrib and_not_mask)

lemma alignUp_def2:
  "alignUp a sz = a + 2 ^ sz - 1 && ~~ mask sz"
  unfolding alignUp_def[unfolded complement_def]
  by (simp add: mask_def[symmetric,unfolded shiftl_t2n,simplified])

lemma align32_alignUp:
  "\<lbrakk>y = 1 << k; k < 32\<rbrakk> \<Longrightarrow> align32(x,y) = alignUp x k"
  apply (clarsimp simp: align32_def)
  apply (fold mask_def[simplified])
  apply (subst mask_def, simp)
  apply (subst add_diff_eq)
  apply (subst alignUp_def2[symmetric])
  by simp

lemma align32_eq:
  "\<lbrakk>y=1<<k; k < 32\<rbrakk> \<Longrightarrow> align32(x,y) = (if y udvd x then x else x + y - (x mod y))"
  apply (simp add: align32_alignUp)
  apply safe
   apply (simp add: udvd_iff_dvd)
   apply (simp add: and_mask_dvd_nat)
   apply (simp only: is_aligned_mask[symmetric])
   apply (simp add: alignUp_idem)
  apply (subst diff_add_eq[symmetric])
  apply (subst sub_mod_mask, assumption)
  apply (subst alignUp_not_aligned_eq3)
   apply (clarsimp simp: is_aligned_def udvd_iff_dvd)
  apply clarsimp
  done

lemma align32_unchanged:
  "\<lbrakk>is_pow_of_2 a; a udvd x\<rbrakk> \<Longrightarrow> align32 (x,a) = x"
  by (clarsimp simp: is_pow_of_2_def align32_eq)

lemma alignUp_not_aligned_eq': "\<not> is_aligned x k
    \<Longrightarrow> alignUp x k = x + (2 ^ k - (x && mask k))"
  apply (subst alignUp_not_aligned_eq3, assumption)
  apply (subst mask_out_sub_mask)
  apply simp
  done

lemma al_dvd_align32:
  "\<lbrakk>is_pow_of_2 al; v < v + al\<rbrakk> \<Longrightarrow> al udvd align32 (v, al)"
  by (clarsimp simp: is_pow_of_2_def align32_alignUp
                        udvd_iff_dvd is_aligned_def[symmetric])

lemma align32_le:
  "\<lbrakk>is_pow_of_2 al; v < v + al\<rbrakk> \<Longrightarrow> v \<le> align32 (v, al)"
  apply (case_tac "v=0", clarsimp simp: align32_alignUp)
  apply (clarsimp simp: align32_alignUp is_pow_of_2_def)
  apply (case_tac "is_aligned v k")
   apply (rule alignUp_ge, simp)
   apply (rule_tac x=v in alignUp_is_aligned_nz)
      apply simp
     apply simp
    apply simp
   apply simp
  apply (simp add: alignUp_not_aligned_eq')
  apply (drule word_less_sub_1)
  apply (rule word_plus_mono_right2)
   apply (subst(asm) field_simps[symmetric], assumption)
  apply (rule word_le_minus_mono_right)
    apply (clarsimp simp: lt1_neq0 is_aligned_mask)
   apply (rule order_trans, rule word_and_le1)
   apply (rule order_less_imp_le)
   apply (simp add: mask_lt_2pn)
  apply (simp add: word_1_le_power)
  done

lemma align32_ge:
  "\<lbrakk>is_pow_of_2 al; v < v + al\<rbrakk> \<Longrightarrow> align32 (v, al) \<ge> v"
   by (auto simp:align32_le)

lemma alignUp_greater:
  "\<lbrakk>(v::32 word) < 2^n; v \<noteq> 0\<rbrakk> \<Longrightarrow> alignUp v n = 2^n"
  apply (subst alignUp_not_aligned_eq')
   apply (clarsimp simp: aligned_small_is_0)
  apply (simp add: less_mask_eq)
  done

lemma mask_out_add_aligned:
  assumes al: "is_aligned p n"
  shows "p + (q && ~~ mask n) = (p + q) && ~~ mask n"
  using mask_add_aligned [OF al]
  by (simp add: mask_out_sub_mask)

lemma is_aligned_triv2:
  "is_aligned (2^a) a"
   apply (case_tac "word_bits\<le> a")
   apply (simp add:is_aligned_triv)+
   done

lemma alignUp_def3:
  "alignUp a sz = 2^ sz + (a - 1 && ~~ mask sz)" (is "?lhs = ?rhs")
   apply (simp add:alignUp_def2)
   apply (subgoal_tac "2 ^ sz + a - 1 && ~~ mask sz = ?rhs")
    apply (clarsimp simp:field_simps)
   apply (subst mask_out_add_aligned)
   apply (rule is_aligned_triv2)
   apply (simp add:field_simps)
   done

lemma mask_lower_twice:
  "n \<le> m \<Longrightarrow> (x && ~~ mask n) && ~~ mask m = x && ~~ mask m"
  apply (rule word_eqI)
  apply (simp add: word_size word_ops_nth_size)
  apply safe
  apply simp
  done

lemma alignUp_distance:
  "(alignUp (q :: 'a :: len word) sz) - q \<le> mask sz"
  apply (case_tac "len_of TYPE('a) \<le> sz")
   apply (simp add:alignUp_def2 mask_def power_overflow)
  apply (case_tac "is_aligned q sz")
  apply (clarsimp simp:alignUp_def2 p_assoc_help)
   apply (subst mask_out_add_aligned[symmetric],simp)+
   apply (simp add:mask_lower_twice word_and_le2)
   apply (simp add:and_not_mask)
   apply (subst le_mask_iff[THEN iffD1])
    apply (simp add:mask_def)
   apply simp
  apply (clarsimp simp:alignUp_def3)
  apply (subgoal_tac "2 ^ sz - (q - (q - 1 && ~~ mask sz)) \<le> 2 ^ sz - 1")
   apply (simp add:field_simps mask_def)
  apply (rule word_sub_mono)
   apply simp
   apply (rule ccontr)
   apply (clarsimp simp:not_le)
   apply (drule eq_refl)
   apply (drule order_trans[OF _ word_and_le2])
   apply (subgoal_tac "q \<noteq>  0")
    apply (drule minus_one_helper[rotated])
     apply simp
    apply simp
   apply (fastforce)
  apply (simp add: word_sub_le_iff)
  apply (subgoal_tac "q - 1 && ~~ mask sz = (q - 1) - (q - 1 && mask sz)")
   apply simp
   apply (rule order_trans)
    apply (rule word_add_le_mono2)
     apply (rule word_and_le1)
    apply (subst unat_plus_simple[THEN iffD1,symmetric])
     apply (simp add:not_le mask_def)
     apply (rule word_sub_1_le)
     apply simp
    apply (rule unat_lt2p)
   apply (simp add:mask_def)
  apply (simp add:mask_out_sub_mask)
  apply (rule word_sub_1_le)
  apply simp
  done

lemma alignUp_nz:
  "\<lbrakk>(v :: 32 word) \<noteq> 0; v < v + 2^k; k < 32\<rbrakk> \<Longrightarrow> alignUp v k \<noteq> 0"
  apply (cut_tac v=v and al="2^k" in align32_le, simp add: is_pow_of_2_def)
    apply (rule_tac x=k in exI, simp+)
  apply (subst (asm) align32_alignUp[simplified], simp+)
  apply auto
  done

lemma aligned_neq_into_ineq:
  fixes x :: "'a::len word"
  assumes neq: "x \<noteq> y"
  and alx: "is_aligned x sz"
  and aly: "is_aligned y sz"
  shows "x + 2 ^ sz - 1 < y \<or> y + 2 ^ sz - 1 < x"
proof -
  note no_ov = aligned_neq_into_no_overlap [OF neq alx aly]
  note x = eqset_imp_iff[OF no_ov, where x=x]
  note y = eqset_imp_iff[OF no_ov, where x=y]
  from x y show ?thesis
   apply (simp add: is_aligned_no_overflow' alx aly)
   apply (auto simp: field_simps)
   done
qed

lemma align32_upper_bound:
 "\<lbrakk>v \<le> bound; is_pow_of_2 al; al udvd bound; v < v + al\<rbrakk> \<Longrightarrow>
  align32 (v, al) \<le> bound"
  apply (case_tac "v=0")
   apply (clarsimp simp: align32_alignUp is_pow_of_2_def alignUp_def2 mask_def)
  apply (clarsimp simp: is_pow_of_2_def)
  apply (subst (asm) udvd_iff_dvd)
  apply simp
  apply (fold is_aligned_def)
  apply (subst align32_alignUp, simp+)
  apply (case_tac "is_aligned v k")
   apply (simp add: alignUp_idem)
  apply (case_tac "al > v")
   apply (subst alignUp_greater, simp+)
   apply (drule_tac a=bound in is_aligned_less_sz)
    apply clarsimp
   apply (simp add: le_def[symmetric])
  apply (simp add: le_def[symmetric])
  apply (cut_tac p=v and n=k in is_aligned_alignUp)
  apply (cut_tac q=v and sz=k in alignUp_distance)
  apply (drule word_diff_ls'(3))
   apply (drule word_less_sub_1)
   apply (simp add: mask_def word_less_sub_1)
   apply (subst diff_add_eq)
   apply (simp add: add.commute)
  apply (case_tac "v + 2^k \<le> bound")
   apply (simp add: mask_def)
   apply (cut_tac v=v and k=k in alignUp_nz, simp+)
   apply (metis (erased, hide_lams) add.commute add_diff_eq
                not_less order_trans word_le_less_eq word_less_1 word_sub_le)
  apply (subst (asm) word_not_le)
  apply (case_tac "bound = alignUp v k")
   apply simp
  apply (frule_tac x=bound and y="alignUp v k" and sz=k
                      in aligned_neq_into_ineq, assumption+)
  apply (simp add: mask_def)
  apply safe
   apply (simp add: L4vBucket.alignUp_le_greater_al)
  apply (simp add: L4vBucket.alignUp_le_greater_al)
  done

lemma align32_idempotence:
 "is_pow_of_2 y \<Longrightarrow> x < x + y \<Longrightarrow>
 align32 (align32 (x, y), y) = align32 (x, y)"
 apply (frule (1) al_dvd_align32)
 apply (erule (1) align32_unchanged)
done

end


theory SeedRefinement
imports "lib/CogentMonad"
        "lib/CogentCorres"
        "build/Random_seed_AllRefine"
begin

section\<open> The shallow Cogent code refines a non-deterministic monad representing the set of all values \<close>

text \<open>This is trivial to prove as any program refines the set of all values but the set up should
      allow for verifying a more interesting example involving for instance specifying the output of
      a deterministic function that calls a non-deterministic one.\<close>

abbreviation "rand_with_seed_spec \<equiv> UNIV:: 64 word cogent_monad"
abbreviation "sum_spec \<equiv> UNIV:: 64 word cogent_monad"

abbreviation "val_rel_monadic_shallow \<equiv> (\<lambda>(v:: 'b) sv:: ('a, 'b) SeedValue. v =  value\<^sub>f sv)"

(*NOTE that this is trivial*)
lemma all_functions_refine_UNIV :
  "\<And>s. cogent_corres val_rel_monadic_shallow UNIV (func s)"
by(simp add:cogent_corres_def)

(*NOTE that this is trivial -- any function would satisfy this spec *)
lemma rand_with_seed_corres_monad_shallow :
  "\<And>s. cogent_corres val_rel_monadic_shallow rand_with_seed_spec (rand_with_seed s)"
by(simp add:cogent_corres_def)

(*NOTE that this is trivial -- any function would satisfy this spec *)
lemma sum_corres_monad_shallow :
  "\<And>s. cogent_corres val_rel_monadic_shallow sum_spec (Random_seed_Shallow_Desugar.sum s)"
  by(simp add:cogent_corres_def)


theory UvProof
imports UvDefs "../Reduction"
begin

subsection {* Preliminary Lemmas *}

text {*
  At any round, given two processes @{text p} and @{text q}, there is always
  some process which is heard by both of them, and from which @{text p} and
  @{text q} have received the same message.
*}
lemma some_common_msg:
  assumes "HOcommPerRd UV_M (HOs r)"
  shows "\<exists>pq. pq \<in> msgRcvd (HOrcvdMsgs UV_M r p (HOs r p) (rho r))
            \<and> pq \<in> msgRcvd (HOrcvdMsgs UV_M r q (HOs r q) (rho r))
            \<and> (HOrcvdMsgs UV_M r p (HOs r p) (rho r)) pq
              = (HOrcvdMsgs UV_M r q (HOs r q) (rho r)) pq"
  using assms
  by (auto simp: UV_HOMachine_def UV_commPerRd_def HOrcvdMsgs_def
                 UV_sendMsg_def send0_def send1_def msgRcvd_def)

text {*
  When executing step 0, the minimum received value is always well defined.
*}

lemma minval_step0:
  assumes com: "HOcommPerRd UV_M (HOs r)" and s0: "step r = 0"
  shows "smallestValRcvd (HOrcvdMsgs UV_M r q (HOs r q) (rho r))
         \<in> {v. \<exists>p. (HOrcvdMsgs UV_M r q (HOs r q) (rho r)) p = Some (Val v)}"
         (is "smallestValRcvd ?msgs \<in> ?vals")
unfolding smallestValRcvd_def proof (rule Min_in)
  have "?vals \<subseteq> getval ` ((the \<circ> ?msgs) ` (HOs r q))"
    by (auto simp: HOrcvdMsgs_def image_def)
  thus "finite ?vals" by (auto simp: finite_subset)
next
  from some_common_msg[of HOs, OF com]
  obtain p where "p \<in> msgRcvd ?msgs" by blast
  with s0 show "?vals \<noteq> {}"
    by (auto simp: msgRcvd_def HOrcvdMsgs_def UV_HOMachine_def
                   UV_sendMsg_def send0_def)
qed

text {*
  When executing step 1 and no vote has been received, the minimum among values received
  in messages carrying no vote is well defined.
*}

lemma minval_step1:
  assumes  com: "HOcommPerRd UV_M (HOs r)" and s1: "step r \<noteq> 0"
  and nov: "someVoteRcvd (HOrcvdMsgs UV_M r q (HOs r q) (rho r)) = {}"
  shows "smallestValNoVoteRcvd (HOrcvdMsgs UV_M r q (HOs r q) (rho r))
          \<in> {v . \<exists>p. (HOrcvdMsgs UV_M r q (HOs r q) (rho r)) p
                     = Some (ValVote v None)}"
        (is "smallestValNoVoteRcvd ?msgs \<in> ?vals")
unfolding smallestValNoVoteRcvd_def proof (rule Min_in)
  have "?vals \<subseteq> getval ` ((the \<circ> ?msgs) ` (HOs r q))"
    by (auto simp: HOrcvdMsgs_def image_def)
  thus "finite ?vals" by (auto simp: finite_subset)
next
  from some_common_msg[of HOs, OF com]
  obtain p where "p \<in> msgRcvd ?msgs" by blast
  with s1 nov show "?vals \<noteq> {}"
    by (auto simp: msgRcvd_def HOrcvdMsgs_def someVoteRcvd_def isValVote_def
                   UV_HOMachine_def UV_sendMsg_def send1_def)
qed

text {*
  The @{text vote} field is reset every time a new phase begins.
*}

lemma reset_vote:
  assumes run: "HORun UV_M rho HOs" and s0: "step r' = 0"
  shows "vote (rho r' p) = None"
proof (cases r')
  assume "r' = 0"
  with run show ?thesis
    by (auto simp: UV_HOMachine_def HORun_eq HOinitConfig_eq
                   initState_def UV_initState_def)
next
  fix r
  assume sucr: "r' = Suc r"
  from run
  have nxt: "nextState UV_M r p (rho r p)
                                (HOrcvdMsgs UV_M r p (HOs r p) (rho r))
                                (rho (Suc r) p)"
    by (auto simp: UV_HOMachine_def HORun_eq HOnextConfig_eq nextState_def)
  from s0 sucr have "step r = 1" by (auto simp: step_def mod_Suc)
  with nxt sucr show ?thesis
    by (auto simp: UV_HOMachine_def nextState_def UV_nextState_def next1_def)
qed

text {*
  Processes only vote for the value they hold in their @{text x} field.
*}
(* The proof relies on previous lemmas @{text reset_vote} and @{text some_common_msg}. *)

lemma x_vote_eq:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and vote: "vote (rho r p) = Some v"
  shows "v = x (rho r p)"
proof (cases r)
  case 0
  with run vote show ?thesis  -- {* no vote in initial state *}
    by (auto simp: UV_HOMachine_def HORun_eq HOinitConfig_eq
                   initState_def UV_initState_def)
next
  fix r'
  assume r: "r = Suc r'"
  let ?msgs = "HOrcvdMsgs UV_M r' p (HOs r' p) (rho r')"
  from run have "nextState UV_M r' p (rho r' p) ?msgs (rho (Suc r') p)"
    by (auto simp: HORun_eq HOnextConfig_eq nextState_def)
  with vote r
  have nxt0: "next0 r' p (rho r' p) ?msgs (rho r p)" and s0: "step r' = 0"
    by (auto simp:  nextState_def UV_HOMachine_def UV_nextState_def next1_def)
  from run s0 have "vote (rho r' p) = None" by (rule reset_vote)
  with vote nxt0
  have idv: "\<forall>q \<in> msgRcvd ?msgs. ?msgs q = Some (Val v)"
    and x: "x (rho r p) = smallestValRcvd ?msgs"
    by (auto simp: next0_def)
  moreover
  from com obtain q where "q \<in> msgRcvd ?msgs"
    by (force dest: some_common_msg)
  with idv have "{x . \<exists>qq. ?msgs qq = Some (Val x)} = {v}"
    by (auto simp: msgRcvd_def)
  hence "smallestValRcvd ?msgs = v"
    by (auto simp: smallestValRcvd_def)
  ultimately
  show ?thesis by simp
qed

subsection {* Proof of Irrevocability, Agreement and Integrity *}

text {* A decision can only be taken in the second round of a phase. *}

lemma decide_step:
  assumes run: "HORun UV_M rho HOs"
      and decide: "decide (rho (Suc r) p) \<noteq> decide (rho r p)"
  shows "step r = 1"
proof -
  let ?msgs = "HOrcvdMsgs UV_M r p (HOs r p) (rho r)"
  from run have "nextState UV_M r p (rho r p) ?msgs (rho (Suc r) p)"
    by (auto simp: HORun_eq HOnextConfig_eq nextState_def)
  with decide show ?thesis
    by (auto simp: nextState_def UV_HOMachine_def UV_nextState_def
                   next0_def step_def)
qed

text {* No process ever decides @{text None}. *}
lemma decide_nonnull:
  assumes run: "HORun UV_M rho HOs"
      and decide: "decide (rho (Suc r) p) \<noteq> decide (rho r p)"
  shows "decide (rho (Suc r) p) \<noteq> None"
proof -
  let ?msgs = "HOrcvdMsgs UV_M r p (HOs r p) (rho r)"
  from assms have s1: "step r = 1" by (rule decide_step)
  with run have "next1 r p (rho r p) ?msgs (rho (Suc r) p)"
    by (auto simp: UV_HOMachine_def HORun_eq HOnextConfig_eq
                   nextState_def UV_nextState_def)
  with decide show ?thesis
    by (auto simp: next1_def dec_update_def)
qed

text {*
  If some process @{text p} votes for @{text v} at some round @{text r}, then any message
  that @{text p} received in @{text r} was holding @{text v} as a value.
*}

lemma msgs_unanimity:
  assumes run: "HORun UV_M rho HOs"
      and vote: "vote (rho (Suc r) p) = Some v"
      and q: "q \<in> msgRcvd (HOrcvdMsgs UV_M r p (HOs r p) (rho r))"
             (is "_ \<in> msgRcvd ?msgs")
  shows "getval (the (?msgs q)) = v"
proof -
  have s0: "step r = 0"
  proof (rule ccontr)
    assume "step r \<noteq> 0"
    hence "step (Suc r) = 0" by (simp add: step_def mod_Suc)
    with run vote show False by (auto simp: reset_vote)
  qed
  with run have novote: "vote (rho r p) = None" by (auto simp: reset_vote)
  from run have "nextState UV_M r p (rho r p) ?msgs (rho (Suc r) p)"
    by (auto simp: HORun_eq HOnextConfig_eq nextState_def)
  with s0 have nxt: "next0 r p (rho r p) ?msgs (rho (Suc r) p)"
    by (auto simp: UV_HOMachine_def nextState_def UV_nextState_def)
  with novote vote q show ?thesis by (auto simp: next0_def)
qed

text {*
  Any two processes can only vote for the same value.
*}
(* The proof relies on previous lemmas @{text some_common_msg} and @{text msgs_unanimity}. *)

lemma vote_agreement:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and p: "vote (rho r p) = Some v"
      and q: "vote (rho r q) = Some w"
  shows "v = w"
proof (cases r)
  case 0
  with run p show ?thesis  -- {* no votes in initial state *}
    by (auto simp: UV_HOMachine_def HORun_eq HOinitConfig_eq
                   initState_def UV_initState_def)
next
  fix r'
  assume r: "r = Suc r'"
  let "?msgs p" = "HOrcvdMsgs UV_M r' p (HOs r' p) (rho r')"
  from com obtain pq
    where "?msgs p pq = ?msgs q pq"
      and smp: "pq \<in> msgRcvd (?msgs p)" and smq: "pq \<in> msgRcvd (?msgs q)"
    by (force dest: some_common_msg)
  moreover
  from run p smp r have "getval (the (?msgs p pq)) = v"
    by (simp add: msgs_unanimity)
  moreover
  from run q smq r have "getval (the (?msgs q pq)) = w"
    by (simp add: msgs_unanimity)
  ultimately
  show ?thesis by simp
qed

text {*
  If a process decides value @{text v} then all processes must have @{text v}
  in their @{text x} fields.
*}
(* The proof relies on previous lemmas @{text decide_step}, @{text some_common_msg},
   @{text vote_agreement}. *)

lemma decide_equals_x:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and decide: "decide (rho (Suc r) p) \<noteq> decide (rho r p)"
      and decval: "decide (rho (Suc r) p) = Some v"
  shows "x (rho (Suc r) q) = v"
proof -
  let "?msgs p'" = "HOrcvdMsgs UV_M r p' (HOs r p') (rho r)"
  from run decide have s1: "step r = 1" by (rule decide_step)
  from run have "nextState UV_M r p (rho r p) (?msgs p) (rho (Suc r) p)"
    by (auto simp: HORun_eq HOnextConfig_eq nextState_def)
  with s1 have nxtp: "next1 r p (rho r p) (?msgs p) (rho (Suc r) p)"
    by (auto simp: UV_HOMachine_def nextState_def UV_nextState_def)
  from run have "nextState UV_M r q (rho r q) (?msgs q) (rho (Suc r) q)"
    by (auto simp: HORun_eq HOnextConfig_eq nextState_def)
  with s1 have nxtq: "next1 r q (rho r q) (?msgs q) (rho (Suc r) q)"
    by (auto simp: UV_HOMachine_def nextState_def UV_nextState_def)

  from com obtain pq where
    pq: "pq \<in> msgRcvd (?msgs p)" "pq \<in> msgRcvd (?msgs q)"
        "(?msgs p) pq = (?msgs q) pq"
    by (force dest: some_common_msg)
  with decide decval nxtp
  have vote: "isValVote (the (?msgs p pq))"
             "getvote (the (?msgs p pq)) = Some v"
    by (auto simp: next1_def dec_update_def identicalVoteRcvd_def)
  with nxtq pq obtain q' where
    q': "q' \<in> someVoteRcvd (?msgs q)"
        "x (rho (Suc r) q) = the (getvote (the (?msgs q q')))"
    by (auto simp: next1_def x_update_def someVoteRcvd_def)
  with s1 pq vote show ?thesis
    by (auto simp: HOrcvdMsgs_def UV_HOMachine_def UV_sendMsg_def send1_def
                   someVoteRcvd_def msgRcvd_def vote_agreement[OF run com])
qed

text {*
  If at some point all processes hold value @{text v} in their @{text x}
  fields, then this will still be the case at the next step.
*}
(* The proof relies on the previous lemma @{text x_vote_eq}. *)

lemma same_x_stable:
  assumes run: "HORun UV_M rho HOs"
      and comm: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and x: "\<forall>p. x (rho r p) = v"
  shows "x (rho (Suc r) q) = v"
proof -
  let ?msgs = "HOrcvdMsgs UV_M r q (HOs r q) (rho r)"
  from comm obtain p where p: "p \<in> msgRcvd ?msgs"
    by (force dest: some_common_msg)
  from run have "nextState UV_M r q (rho r q) ?msgs (rho (Suc r) q)"
    by (auto simp: HORun_eq HOnextConfig_eq nextState_def)
  hence "next0 r q (rho r q) ?msgs (rho (Suc r) q) \<and> step r = 0
         \<or> next1 r q (rho r q) ?msgs (rho (Suc r) q) \<and> step r \<noteq> 0"
    (is "?nxt0 \<or> ?nxt1")
    by (auto simp: UV_HOMachine_def nextState_def UV_nextState_def)
  thus ?thesis
  proof
    assume nxt0: "?nxt0"
    hence "x (rho (Suc r) q) = smallestValRcvd ?msgs"
      by (auto simp: next0_def)
    moreover
    from nxt0 x have "\<forall>p \<in> msgRcvd ?msgs. ?msgs p = Some (Val v)"
      by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                     msgRcvd_def send0_def)
    from this p have "{x . \<exists>p. ?msgs p = Some (Val x)} = {v}"
      by (auto simp: msgRcvd_def)
    hence "smallestValRcvd ?msgs = v"
      by (auto simp: smallestValRcvd_def)
    ultimately
    show ?thesis by simp
  next
    assume nxt1: "?nxt1"
    show ?thesis
    proof (cases "someVoteRcvd ?msgs = {}")
      case True
      with nxt1 have "x (rho (Suc r) q) = smallestValNoVoteRcvd ?msgs"
        by (auto simp: next1_def x_update_def)
      moreover
      from nxt1 x True
      have "\<forall>p \<in> msgRcvd ?msgs. ?msgs p = Some (ValVote v None)"
        by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                       msgRcvd_def send1_def someVoteRcvd_def isValVote_def)
      from this p have "{x . \<exists>p. ?msgs p = Some (ValVote x None)} = {v}"
        by (auto simp: msgRcvd_def)
      hence "smallestValNoVoteRcvd ?msgs = v"
        by (auto simp: smallestValNoVoteRcvd_def)
      ultimately show ?thesis by simp
    next
      case False
      with nxt1 obtain p' v' where
        p': "p' \<in> msgRcvd ?msgs" "isValVote (the (?msgs p'))"
            "getvote (the (?msgs p')) = Some v'""x (rho (Suc r) q) = v'"
        by (auto simp: someVoteRcvd_def next1_def x_update_def)
      with nxt1 have "x (rho (Suc r) q) = x (rho r p')"
        by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                       msgRcvd_def send1_def isValVote_def
                       x_vote_eq[OF run comm])
      with x show ?thesis by auto
    qed
  qed
qed

text {*
  Combining the last two lemmas, it follows that as soon as some process
  decides value @{text v}, all processes hold @{text v} in their @{text x} fields.
*}

lemma safety_argument:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and decide: "decide (rho (Suc r) p) \<noteq> decide (rho r p)"
      and decval: "decide (rho (Suc r) p) = Some v"
  shows "x (rho (Suc r+k) q) = v"
proof (induct k arbitrary: q)
  fix q
  from decide_equals_x[OF assms] show "x (rho (Suc r + 0) q) = v" by simp
next
  fix k q
  assume "\<And>q. x (rho (Suc r+k) q) = v"
  with run com show "x (rho (Suc r + Suc k) q) = v"
    by (auto dest: same_x_stable)
qed

text {*
  Any process that holds a non-null decision value has made a decision
  sometime in the past.
*}

lemma decided_then_past_decision:
  assumes run: "HORun UV_M rho HOs"
      and dec: "decide (rho n p) = Some v"
  shows "\<exists>m<n. decide (rho (Suc m) p) \<noteq> decide (rho m p)
             \<and> decide (rho (Suc m) p) = Some v"
proof -
  let "?dec k" = "decide (rho k p)"
  have "(\<forall>m<n. ?dec (Suc m) \<noteq> ?dec m \<longrightarrow> ?dec (Suc m) \<noteq> Some v)
        \<longrightarrow> ?dec n \<noteq> Some v"
    (is "?P n" is "?A n \<longrightarrow> _")
  proof (induct n)
    from run show "?P 0"
      by (auto simp: HORun_eq UV_HOMachine_def HOinitConfig_eq
                     initState_def UV_initState_def)
  next
    fix n
    assume ih: "?P n" thus "?P (Suc n)" by force
  qed
  with dec show ?thesis by auto
qed

text {*
  We can now prove the safety properties of the algorithm, and start with
  proving Integrity.
*}

lemma x_values_initial:
  assumes run:"HORun UV_M rho HOs"
      and com:"\<forall>r. HOcommPerRd UV_M (HOs r)"
  shows "\<exists>q. x (rho r p) = x (rho 0 q)"
proof (induct r arbitrary: p)
  fix p
  show "\<exists>q. x (rho 0 p) = x (rho 0 q)" by auto
next
  fix r p
  assume ih: "\<And>p'. \<exists>q. x (rho r p') = x (rho 0 q)"
  let ?msgs = "HOrcvdMsgs UV_M r p (HOs r p) (rho r)"
  from run have "nextState UV_M r p (rho r p) ?msgs (rho (Suc r) p)"
    by (auto simp: HORun_eq HOnextConfig_eq nextState_def)
  hence "next0 r p (rho r p) ?msgs (rho (Suc r) p) \<and> step r = 0
         \<or> next1 r p (rho r p) ?msgs (rho (Suc r) p) \<and> step r \<noteq> 0"
    (is "?nxt0 \<or> ?nxt1")
    by (auto simp: UV_HOMachine_def nextState_def UV_nextState_def)
  thus "\<exists>q. x (rho (Suc r) p) = x (rho 0 q)"
  proof
    assume nxt0: "?nxt0"
    hence "x (rho (Suc r) p) = smallestValRcvd ?msgs"
      by (auto simp: next0_def)
    also with com nxt0 have "\<dots> \<in> {v . \<exists>q. ?msgs q = Some (Val v)}"
      by (intro minval_step0) auto
    also with nxt0 have "\<dots> = { x (rho r q) | q . q \<in> msgRcvd ?msgs }"
      by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                     msgRcvd_def send0_def)
    finally obtain q where "x (rho (Suc r) p) = x (rho r q)" by auto
    with ih show ?thesis by auto
  next
    assume nxt1: "?nxt1"
    show ?thesis
    proof (cases "someVoteRcvd ?msgs = {}")
      case True
      with nxt1 have "x (rho (Suc r) p) = smallestValNoVoteRcvd ?msgs"
        by (auto simp: next1_def x_update_def)
      also with com nxt1 True
      have "\<dots> \<in> {v . \<exists>q. ?msgs q = Some (ValVote v None)}"
        by (intro minval_step1) auto
      also with nxt1 True
      have "\<dots> = { x (rho r q) | q . q \<in> msgRcvd ?msgs }"
        by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                       someVoteRcvd_def isValVote_def msgRcvd_def send1_def)
      finally obtain q where "x (rho (Suc r) p) = x (rho r q)" by auto
      with ih show ?thesis by auto
    next
      case False
      with nxt1 obtain q where
        "q \<in> someVoteRcvd ?msgs"
        "x (rho (Suc r) p) = the (getvote (the (?msgs q)))"
        by (auto simp: next1_def x_update_def)
      with nxt1 have "vote (rho r q) = Some (x (rho (Suc r) p))"
        by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                       someVoteRcvd_def isValVote_def msgRcvd_def send1_def)
      with run com have "x (rho (Suc r) p) = x (rho r q)"
        by (rule x_vote_eq)
      with ih show ?thesis by auto
    qed
  qed
qed

theorem uv_integrity:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and dec: "decide (rho r p) = Some v"
  shows "\<exists>q. v = x (rho 0 q)"
proof -
  from run dec obtain k where
    "decide (rho (Suc k) p) \<noteq> decide (rho k p)"
    "decide (rho (Suc k) p) = Some v"
    by (auto dest: decided_then_past_decision)
  with run com have "x (rho (Suc k) p) = v"
    by (rule decide_equals_x)
  with run com show ?thesis
    by (auto dest: x_values_initial)
qed

text {*
  We now turn to Agreement.
*}

lemma two_decisions_agree:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and decidep: "decide (rho (Suc r) p) \<noteq> decide (rho r p)"
      and decvalp: "decide (rho (Suc r) p) = Some v"
      and decideq: "decide (rho (Suc (r+k)) q) \<noteq> decide (rho (r+k) q)"
      and decvalq: "decide (rho (Suc (r+k)) q) = Some w"
  shows "v = w"
proof -
  from run com decidep decvalp have "x (rho (Suc r+k) q) = v"
    by (rule safety_argument)
  moreover
  from run com decideq decvalq have "x (rho (Suc (r+k)) q) = w"
    by (rule decide_equals_x)
  ultimately
  show ?thesis by simp
qed

theorem uv_agreement:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and p: "decide (rho m p) = Some v"
      and q: "decide (rho n q) = Some w"
  shows "v = w"
proof -
  from run p obtain k where
    k: "decide (rho (Suc k) p) \<noteq> decide (rho k p)"
       "decide (rho (Suc k) p) = Some v"
    by (auto dest: decided_then_past_decision)
  from run q obtain l where
    l: "decide (rho (Suc l) q) \<noteq> decide (rho l q)"
       "decide (rho (Suc l) q) = Some w"
    by (auto dest: decided_then_past_decision)
  show ?thesis
  proof (cases "k \<le> l")
    case True
    then obtain m where m: "l = k+m" by (auto simp: le_iff_add)
    from run com k l m show ?thesis by (blast dest: two_decisions_agree)
  next
    case False
    hence "l \<le> k" by simp
    then obtain m where m: "k = l+m" by (auto simp: le_iff_add)
    from run com k l m show ?thesis by (blast dest: two_decisions_agree)
  qed
qed

text {*
  Irrevocability is a consequence of Agreement and the fact that no process
  can decide @{text None}.
*}

theorem uv_irrevocability:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and p: "decide (rho m p) = Some v"
  shows "decide (rho (m+n) p) = Some v"
proof (induct n)
  from p show "decide (rho (m+0) p) = Some v" by simp
next
  fix n
  assume ih: "decide (rho (m+n) p) = Some v"
  show "decide (rho (m + Suc n) p) = Some v"
  proof (rule classical)
    assume "\<not> ?thesis"
    with run ih obtain w where w: "decide (rho (m + Suc n) p) = Some w"
      by (auto dest!: decide_nonnull)
    with p have "w = v" by (auto simp: uv_agreement[OF run com])
    with w show ?thesis by simp
  qed
qed

subsection {* Proof of Termination *}

text {*
  Two processes having the same \emph{Heard-Of} set at some round will
  hold the same value in their @{text x} variable at the next round.
*}
(* The proof relies on the previous lemma @{text vote_agreement}. *)

lemma hoeq_xeq:
  assumes run: "HORun UV_M rho HOs"
      and com: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and hoeq: "HOs r p = HOs r q"
  shows "x (rho (Suc r) p) = x (rho (Suc r) q)"
proof -
  let "?msgs p" = "HOrcvdMsgs UV_M r p (HOs r p) (rho r)"
  from hoeq have msgeq: "?msgs p = ?msgs q"
    by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                   send0_def send1_def)

  show ?thesis
  proof (cases "step r = 0")
    case True
    with run
    have "\<forall>p. next0 r p (rho r p) (?msgs p) (rho (Suc r) p)" (is "\<forall>p. ?nxt0 p")
      by (force simp: UV_HOMachine_def HORun_eq HOnextConfig_eq
                      nextState_def UV_nextState_def)
    hence "?nxt0 p" "?nxt0 q" by auto
    with msgeq show ?thesis by (auto simp: next0_def)
  next
    assume stp: "step r \<noteq> 0"
    with run
    have "\<forall>p. next1 r p (rho r p) (?msgs p) (rho (Suc r) p)" (is "\<forall>p. ?nxt1 p")
      by (force simp: UV_HOMachine_def HORun_eq HOnextConfig_eq
                      nextState_def UV_nextState_def)
    hence "x_update (rho r p) (?msgs p) (rho (Suc r) p)"
          "x_update (rho r q) (?msgs q) (rho (Suc r) q)"
      by (auto simp: next1_def)
    with msgeq have
      x': "x_update (rho r p) (?msgs p) (rho (Suc r) p)"
          "x_update (rho r q) (?msgs p) (rho (Suc r) q)"
      by auto
    show ?thesis
    proof (cases "someVoteRcvd (?msgs p) = {}")
      case True
      with x' show ?thesis
        by (auto simp: x_update_def)
    next
      case False
      with x' stp obtain qp qq where
        "vote (rho r qp) = Some (x (rho (Suc r) p))" and
        "vote (rho r qq) = Some (x (rho (Suc r) q))"
        by (force simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                        x_update_def someVoteRcvd_def isValVote_def
                        msgRcvd_def send1_def)
      with run com show ?thesis by (rule vote_agreement)
    qed
  qed
qed

text {*
  We now prove that \emph{UniformVoting} terminates.
*}

  txt {* Now obtain a round where all votes agree. *}
  def r' \<equiv> "if step (Suc r0) = 0 then Suc r0 else Suc (Suc r0)"
  have stp': "step r' = 0"
    by (simp add: r'_def step_def mod_Suc)
  have x': "\<forall>q. x (rho r' q) = ?v"
  proof (auto simp: r'_def)
    fix q
    from xs show "x (rho (Suc r0) q) = ?v" ..
  next
    fix q
    from run commR xs show "x (rho (Suc (Suc r0)) q) = ?v"
      by (rule same_x_stable)
  qed
  have vote': "\<forall>q. vote (rho (Suc r') q) = Some ?v"
  proof
    fix q
    let ?msgs = "HOrcvdMsgs UV_M r' q (HOs r' q) (rho r')"
    from run stp' have "next0 r' q (rho r' q) ?msgs (rho (Suc r') q)"
      by (force simp: UV_HOMachine_def HORun_eq HOnextConfig_eq
                      nextState_def UV_nextState_def)
    moreover
    from stp' x' have "\<forall>q' \<in> msgRcvd ?msgs. ?msgs q' = Some (Val ?v)"
      by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                     send0_def msgRcvd_def)
    moreover
    from commR have "msgRcvd ?msgs \<noteq> {}"
      by (force dest: some_common_msg)
    ultimately
    show "vote (rho (Suc r') q) = Some ?v"
      by (auto simp: next0_def)
  qed

  txt {* At the subsequent round, process @{text p} will decide. *}
  let ?r'' = "Suc r'"
  let ?msgs' = "HOrcvdMsgs UV_M ?r'' p (HOs ?r'' p) (rho ?r'')"
  from stp' have stp'': "step ?r'' = 1"
    by (simp add: step_def mod_Suc)
  with run have "next1 ?r'' p (rho ?r'' p) ?msgs' (rho (Suc ?r'') p)"
    by (auto simp: UV_HOMachine_def HORun_eq HOnextConfig_eq
                   nextState_def UV_nextState_def)
  moreover
  from stp'' vote' have "identicalVoteRcvd ?msgs' ?v"
    by (auto simp: UV_HOMachine_def HOrcvdMsgs_def UV_sendMsg_def
                   send1_def identicalVoteRcvd_def isValVote_def msgRcvd_def)
  moreover
  from commR have "msgRcvd ?msgs' \<noteq> {}"
    by (force dest: some_common_msg)
  ultimately
  have "decide (rho (Suc ?r'') p) = Some ?v"
    by (force simp: next1_def dec_update_def identicalVoteRcvd_def
                    msgRcvd_def isValVote_def)
  (* subtle point: there can't be two different identical votes received,
     proving this requires "force" and takes a while *)

  thus ?thesis by blast
qed

subsection {* \emph{UniformVoting} Solves Consensus *}

text {*
  Summing up, all (coarse-grained) runs of \emph{UniformVoting} for
  HO collections that satisfy the communication predicate satisfy
  the Consensus property.
*}

theorem uv_consensus:
  assumes run: "HORun UV_M rho HOs"
      and commR: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and commG: "HOcommGlobal UV_M HOs"
  shows "consensus (x \<circ> (rho 0)) decide rho"
  using assms unfolding consensus_def image_def
  by (auto elim: uv_integrity uv_agreement uv_termination)

text {*
  By the reduction theorem, the correctness of the algorithm carries over
  to the fine-grained model of runs.
*}

theorem uv_consensus_fg:
  assumes run: "fg_run UV_M rho HOs HOs (\<lambda>r q. undefined)"
      and commR: "\<forall>r. HOcommPerRd UV_M (HOs r)"
      and commG: "HOcommGlobal UV_M HOs"
  shows "consensus (\<lambda>p. x (state (rho 0) p)) decide (state \<circ> rho)"
    (is "consensus ?inits _ _")
proof (rule local_property_reduction[OF run consensus_is_local])
  fix crun
  assume crun: "CSHORun UV_M crun HOs HOs (\<lambda>r q. undefined)"
     and init: "crun 0 = state (rho 0)"
  from crun have "HORun UV_M crun HOs"
    by (unfold HORun_def SHORun_def)
  from this commR commG have "consensus (x \<circ> (crun 0)) decide crun"
    by (rule uv_consensus)
  with init show "consensus ?inits decide crun"
    by (simp add: o_def)
qed

end


section \<open>Euclidean Space: Explicit Representation\<close>
theory Euclidean_Space_Explicit
imports
  "~~/src/HOL/Analysis/Analysis"
begin

subsection \<open>Explicit Sum for Composition of Components\<close>

definition (in plus) plusE :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "+\<^sub>E" 65) where "plusE = plus"

definition (in comm_monoid_add) sumE where "sumE = sum"

lemmas sumE_insert = sum.insert[simplified plusE_def[symmetric] sumE_def[symmetric]]
lemma sumE_singleton: "sumE f {a} = f a" by (simp add: sumE_def)

lemmas euclidean_representationE =
  euclidean_representation[simplified sumE_def[symmetric], symmetric]

subsection \<open>Conversion for Explicit Representation\<close>

lemma scaleR_real_1: "scaleR x 1 = x" by simp

named_theorems euclidean_Basis
  "simplification rules for Basis of Euclidean Space"
named_theorems euclidean_Outer
  "simplification rules for rewriting of Euclidean Space as return value"
named_theorems euclidean_Inner
  "simplification rules for rewriting of Euclidean Space as argument"

declare simp_thms[euclidean_Basis, euclidean_Inner, euclidean_Outer]
lemmas [euclidean_Basis] =
  image_insert image_empty Un_insert_left Un_empty_left Un_insert_right Un_empty_right
  Basis_prod_def
  zero_prod_def
  Basis_real_def
  sumE_insert sumE_singleton
  sum.insert sum.empty
  finite_insert finite.emptyI
  prod.inject
  empty_iff insert_iff
  refl
  one_neq_zero

lemmas idem_simps =
  fst_conv snd_conv
  add_0_left
  add_0_right
  add_0_left
  add_0_right
  mult_zero_right
  mult_1_right

lemmas [euclidean_Outer] = inner_prod_def inner_real_def idem_simps
lemmas [euclidean_Inner] = plus_prod_def scaleR_prod_def idem_simps
  scaleR_zero_left
  scaleR_zero_right
  scaleR_real_1

ML \<open>

fun Basis_simps ctxt =
  (put_simpset (HOL_basic_ss) ctxt)
    addsimps (Named_Theorems.get ctxt @{named_theorems euclidean_Basis})
fun Outer_simps ctxt =
  (put_simpset (HOL_basic_ss) ctxt)
    addsimps (Named_Theorems.get ctxt @{named_theorems euclidean_Outer})
fun Inner_simps ctxt =
  (put_simpset (HOL_basic_ss) ctxt)
    addsimps (Named_Theorems.get ctxt @{named_theorems euclidean_Inner})

fun rewrite_outer_eucl ctxt =
  Conv.top_sweep_conv
    (fn ctxt => Conv.rewr_conv (@{thm euclidean_representationE[THEN eq_reflection]})
      then_conv Simplifier.rewrite (Basis_simps ctxt)
      then_conv Simplifier.rewrite (Outer_simps ctxt)
    ) ctxt;

fun rewrite_split_beta ctxt =
  Simplifier.rewrite (clear_simpset ctxt addsimps (@{thms split_beta' split_beta}));

fun represent_euclidean ct1 ct2 =
  if ct1 aconvc ct2
  then Conv.rewr_conv @{thm euclidean_representation[symmetric, THEN eq_reflection]} ct2
  else Conv.no_conv ct2

fun rewrite_inner_eucl vs cv ctxt =
  Conv.abs_conv (fn (v, ctxt) => rewrite_inner_eucl (v::vs) cv ctxt else_conv cv (v::vs) ctxt) ctxt

fun component_conv conv ct =
  (case Thm.term_of ct of
    Const (@{const_name scaleR}, _) $ _ $ _ => Conv.arg1_conv conv ct
  | _ => raise CTERM ("scaleR_conv", [ct]));

fun euclidify ctxt = rewrite_outer_eucl ctxt
  then_conv rewrite_split_beta ctxt
  then_conv rewrite_inner_eucl []
    (fn vs => fn ctxt =>
      Conv.every_conv (map (fn v => Conv.top_sweep_conv (fn _ => represent_euclidean v) ctxt) vs))
    ctxt
  then_conv Conv.top_sweep_conv (fn ctxt => component_conv (
    Simplifier.rewrite (Basis_simps ctxt)
    then_conv Simplifier.rewrite (Inner_simps ctxt))) ctxt
  ;

\<close>

lemma
  "(\<lambda>(x1::real, x2::real) (y1::real, y2::real) (z1::real, z2::real, z3::real).
       (x1 + x2, x2 * x1 + 1, y1, y2 + z1 * z2 * z3)) =
  (\<lambda>x xa xb.
       (xa \<bullet> (0, 1) + xb \<bullet> (1, 0, 0) * (xb \<bullet> (0, 1, 0)) * (xb \<bullet> (0, 0, 1))) *\<^sub>R (0, 0, 0, 1) +\<^sub>E
       (xa \<bullet> (1, 0)) *\<^sub>R (0, 0, 1, 0) +\<^sub>E
       (x \<bullet> (0, 1) * (x \<bullet> (1, 0)) + 1) *\<^sub>R (0, 1, 0, 0) +\<^sub>E
       (x \<bullet> (1, 0) + x \<bullet> (0, 1)) *\<^sub>R (1, 0, 0, 0))"
  by (tactic \<open>
    CONVERSION (HOLogic.Trueprop_conv (HOLogic.eq_conv (euclidify @{context}) Conv.all_conv)) 1
\<close>) (rule refl)

lemma "(\<lambda>(x1, x2) (y1, y2). (x1 + x2, x2 * x1 + 1, y1, y2)::real*real*real*real) =
    (\<lambda>x xa.
       (xa \<bullet> (0, 1)) *\<^sub>R (0, 0, 0, 1) +\<^sub>E
       (xa \<bullet> (1, 0)) *\<^sub>R (0, 0, 1, 0) +\<^sub>E
       (x \<bullet> (0, 1) * (x \<bullet> (1, 0)) + 1) *\<^sub>R (0, 1, 0, 0) +\<^sub>E
       (x \<bullet> (1, 0) + x \<bullet> (0, 1)) *\<^sub>R (1, 0, 0, 0))"
  by (tactic \<open>
    CONVERSION (HOLogic.Trueprop_conv (HOLogic.eq_conv (euclidify @{context}) Conv.all_conv)) 1
\<close>) (rule refl)

lemma "(\<lambda>x y. x + y::real) = (\<lambda>x y. (x \<bullet> 1 + y \<bullet> 1) *\<^sub>R 1)"
  by (tactic \<open>
    CONVERSION (HOLogic.Trueprop_conv (HOLogic.eq_conv (euclidify @{context}) Conv.all_conv)) 1
\<close>) (rule refl)

lemma
  "(\<lambda>x y. (x \<bullet> (1, 0, 0) + y \<bullet> (0, 0, 1)) *\<^sub>R (1, 0) + (x \<bullet> (1, 0, 0) + y \<bullet> (0, 0, 1)) *\<^sub>R (1, 0)) =
  (\<lambda>(x::real*real*real) (y::real*real*real). 0 *\<^sub>R (0, 1) +\<^sub>E
    (x \<bullet> (1, 0, 0) + y \<bullet> (0, 0, 1) + (x \<bullet> (1, 0, 0) + y \<bullet> (0, 0, 1))) *\<^sub>R (1, 0)::real*real)"
  by (tactic \<open>
    CONVERSION (HOLogic.Trueprop_conv (HOLogic.eq_conv (euclidify @{context}) Conv.all_conv)) 1
\<close>) (rule refl)

end