section \<open>Subterms and Contexts\<close>

text \<open>
  We define the (proper) sub- and superterm relations on first order terms,
  as well as contexts (you can think of contexts as terms with exactly one hole,
  where we can plug-in another term).
  Moreover, we establish several connections between these concepts as well as
  to other concepts such as substitutions.
\<close>

theory Subterm_and_Context
  imports
    First_Order_Terms.Term
    "Abstract-Rewriting.Abstract_Rewriting"
begin

subsection \<open>Subterms\<close>

text \<open>The \<^emph>\<open>superterm\<close> relation.\<close>
inductive_set
  supteq :: "(('f, 'v) term \<times> ('f, 'v) term) set"
  where
    refl [simp, intro]: "(t, t) \<in> supteq" |
    subt [intro]: "u \<in> set ss \<Longrightarrow> (u, t) \<in> supteq \<Longrightarrow> (Fun f ss, t) \<in> supteq"

text \<open>The \<^emph>\<open>proper superterm\<close> relation.\<close>
inductive_set
  supt :: "(('f, 'v) term \<times> ('f, 'v) term) set"
  where
    arg [simp, intro]: "s \<in> set ss \<Longrightarrow> (Fun f ss, s) \<in> supt" |
    subt [intro]: "s \<in> set ss \<Longrightarrow> (s, t) \<in> supt \<Longrightarrow> (Fun f ss, t) \<in> supt"

hide_const suptp supteqp
hide_fact
  suptp.arg suptp.cases suptp.induct suptp.intros suptp.subt suptp_supt_eq
hide_fact
  supteqp.cases supteqp.induct supteqp.intros supteqp.refl supteqp.subt supteqp_supteq_eq

hide_fact (open) supt.arg supt.subt supteq.refl supteq.subt

subsubsection \<open>Syntactic Sugar\<close>

text \<open>Infix syntax.\<close>
abbreviation "supt_pred s t \<equiv> (s, t) \<in> supt"
abbreviation "supteq_pred s t \<equiv> (s, t) \<in> supteq"
abbreviation (input) "subt_pred s t \<equiv> supt_pred t s"
abbreviation (input) "subteq_pred s t \<equiv> supteq_pred t s"

notation
  supt ("{\<rhd>}") and
  supt_pred ("(_/ \<rhd> _)" [56, 56] 55) and
  subt_pred (infix "\<lhd>" 55) and
  supteq ("{\<unrhd>}") and
  supteq_pred ("(_/ \<unrhd> _)" [56, 56] 55) and
  subteq_pred (infix "\<unlhd>" 55)

abbreviation subt ("{\<lhd>}") where "{\<lhd>} \<equiv> {\<rhd>}\<inverse>"
abbreviation subteq ("{\<unlhd>}") where "{\<unlhd>} \<equiv> {\<unrhd>}\<inverse>"

text \<open>Quantifier syntax.\<close>

syntax
  "_All_supteq" :: "[idt, 'a, bool] \<Rightarrow> bool" ("(3\<forall>_\<unrhd>_./ _)" [0, 0, 10] 10)
  "_Ex_supteq" :: "[idt, 'a, bool] \<Rightarrow> bool" ("(3\<exists>_\<unrhd>_./ _)" [0, 0, 10] 10)
  "_All_supt" :: "[idt, 'a, bool] \<Rightarrow> bool" ("(3\<forall>_\<rhd>_./ _)" [0, 0, 10] 10)
  "_Ex_supt" :: "[idt, 'a, bool] \<Rightarrow> bool" ("(3\<exists>_\<rhd>_./ _)" [0, 0, 10] 10)

"_All_subteq" :: "[idt, 'a, bool] \<Rightarrow> bool" ("(3\<forall>_\<unlhd>_./ _)" [0, 0, 10] 10)
"_Ex_subteq" :: "[idt, 'a, bool] \<Rightarrow> bool" ("(3\<exists>_\<unlhd>_./ _)" [0, 0, 10] 10)
"_All_subt" :: "[idt, 'a, bool] \<Rightarrow> bool" ("(3\<forall>_\<lhd>_./ _)" [0, 0, 10] 10)
"_Ex_subt" :: "[idt, 'a, bool] \<Rightarrow> bool" ("(3\<exists>_\<lhd>_./ _)" [0, 0, 10] 10)

(* for parsing *)
translations
  "\<forall>x\<unrhd>y. P" \<rightharpoonup> "\<forall>x. x \<unrhd> y \<longrightarrow> P"
  "\<exists>x\<unrhd>y. P" \<rightharpoonup> "\<exists>x. x \<unrhd> y \<and> P"
  "\<forall>x\<rhd>y. P" \<rightharpoonup> "\<forall>x. x \<rhd> y \<longrightarrow> P"
  "\<exists>x\<rhd>y. P" \<rightharpoonup> "\<exists>x. x \<rhd> y \<and> P"

"\<forall>x\<unlhd>y. P" \<rightharpoonup> "\<forall>x. x \<unlhd> y \<longrightarrow> P"
"\<exists>x\<unlhd>y. P" \<rightharpoonup> "\<exists>x. x \<unlhd> y \<and> P"
"\<forall>x\<lhd>y. P" \<rightharpoonup> "\<forall>x. x \<lhd> y \<longrightarrow> P"
"\<exists>x\<lhd>y. P" \<rightharpoonup> "\<exists>x. x \<lhd> y \<and> P"

(* for printing *)
print_translation \<open>
let
  val All_binder = Mixfix.binder_name @{const_syntax All};
  val Ex_binder = Mixfix.binder_name @{const_syntax Ex};
  val impl = @{const_syntax "implies"};
  val conj = @{const_syntax "conj"};
  val supt = @{const_syntax "supt_pred"};
  val supteq = @{const_syntax "supteq_pred"};

  val trans =
   [((All_binder, impl, supt), ("_All_supt", "_All_subt")),
    ((All_binder, impl, supteq), ("_All_supteq", "_All_subteq")),
    ((Ex_binder, conj, supt), ("_Ex_supt", "_Ex_subt")),
    ((Ex_binder, conj, supteq), ("_Ex_supteq", "_Ex_subteq"))];

  fun matches_bound v t =
     case t of (Const ("_bound", _) $ Free (v', _)) => (v = v')
              | _ => false
  fun contains_var v = Term.exists_subterm (fn Free (x, _) => x = v | _ => false)
  fun mk x c n P = Syntax.const c $ Syntax_Trans.mark_bound_body x $ n $ P

  fun tr' q = (q,
    K (fn [Const ("_bound", _) $ Free (v, T), Const (c, _) $ (Const (d, _) $ t $ u) $ P] =>
      (case AList.lookup (=) trans (q, c, d) of
        NONE => raise Match
      | SOME (l, g) =>
          if matches_bound v t andalso not (contains_var v u) then mk (v, T) l u P
          else if matches_bound v u andalso not (contains_var v t) then mk (v, T) g t P
          else raise Match)
     | _ => raise Match));
in [tr' All_binder, tr' Ex_binder] end
\<close>

subsubsection \<open>Transitivity Reasoning for Subterms\<close>

lemma supt_trans [trans]:
  "s \<rhd> t \<Longrightarrow> t \<rhd> u \<Longrightarrow> s \<rhd> u"
  by (induct s t rule: supt.induct) auto

lemma trans_supt: "trans {\<rhd>}" by (auto simp: trans_def dest: supt_trans)

lemma supteq_trans [trans]:
  "s \<unrhd> t \<Longrightarrow> t \<unrhd> u \<Longrightarrow> s \<unrhd> u"
  by (induct s t rule: supteq.induct) (auto)

text \<open>Auxiliary lemmas about term size.\<close>
lemma size_simp5:
  "s \<in> set ss \<Longrightarrow> s \<rhd> t \<Longrightarrow> size t < size s \<Longrightarrow> size t < Suc (size_list size ss)"
  by (induct ss) auto

lemma size_simp1:
  "t \<in> set ts \<Longrightarrow> size t < Suc (size_list size ts)"
  by (induct ts) auto

lemma size_simp2:
  "t \<in> set ts \<Longrightarrow> size t < Suc (Suc (size s + size_list size ts))"
  by (induct ts) auto

lemma size_simp3:
  assumes "(x, y) \<in> set (zip xs ys)"
  shows "size x < Suc (size_list size xs)"
  using set_zip_leftD [OF assms]  size_simp1 by auto

lemma size_simp4:
  assumes "(x, y) \<in> set (zip xs ys)"
  shows "size y < Suc (size_list size ys)"
  using set_zip_rightD [OF assms] using size_simp1 by auto

lemmas size_simps =
  size_simp1 size_simp2 size_simp3 size_simp4 size_simp5 size_simp6

declare size_simps [termination_simp]

lemma supt_size:
  "s \<rhd> t \<Longrightarrow> size s > size t"
  by (induct rule: supt.induct) (auto simp: size_simps)

lemma supteq_size:
  "s \<unrhd> t \<Longrightarrow> size s \<ge> size t"
  by (induct rule: supteq.induct) (auto simp: size_simps)

text \<open>Reflexivity and Asymmetry.\<close>

lemma reflcl_supteq [simp]:
  "supteq\<^sup>= = supteq" by auto

lemma trancl_supteq [simp]:
  "supteq\<^sup>+ = supteq"
  by (rule trancl_id) (auto simp: trans_def intro: supteq_trans)

lemma rtrancl_supteq [simp]:
  "supteq\<^sup>* = supteq"
  unfolding trancl_reflcl[symmetric] by auto

lemma eq_supteq: "s = t \<Longrightarrow> s \<unrhd> t" by auto

lemma supt_neqD: "s \<rhd> t \<Longrightarrow> s \<noteq> t" using supt_size by auto

lemma supteq_Var [simp]:
  "x \<in> vars_term t \<Longrightarrow> t \<unrhd> Var x"
proof (induct t)
  case (Var y) then show ?case by (cases "x = y") auto
next
  case (Fun f ss) then show ?case by (auto)
qed

lemmas vars_term_supteq = supteq_Var

lemma term_not_arg [iff]:
  "Fun f ss \<notin> set ss" (is "?t \<notin> set ss")
proof
  assume "?t \<in> set ss"
  then have "?t \<rhd> ?t" by (auto)
  then have "?t \<noteq> ?t" by (auto dest: supt_neqD)
  then show False by simp
qed

lemma supt_Fun [simp]:
  assumes "s \<rhd> Fun f ss" (is "s \<rhd> ?t") and "s \<in> set ss"
  shows "False"
proof -
  from \<open>s \<in> set ss\<close> have "?t \<rhd> s" by (auto)
  then have "size ?t > size s" by (rule supt_size)
  from \<open>s \<rhd> ?t\<close> have "size s > size ?t" by (rule supt_size)
  with \<open>size ?t > size s\<close> show False by simp
qed

lemma supt_supteq_conv: "s \<rhd> t = (s \<unrhd> t \<and> s \<noteq> t)"
proof
  assume "s \<rhd> t" then show "s \<unrhd> t \<and> s \<noteq> t"
  proof (induct rule: supt.induct)
    case (subt s ss t f)
    have "s \<unrhd> s" ..
    from \<open>s \<in> set ss\<close> have "Fun f ss \<unrhd> s" by (auto)
    from \<open>s \<unrhd> t \<and> s \<noteq> t\<close> have "s \<unrhd> t" ..
    with \<open>Fun f ss \<unrhd> s\<close> have first: "Fun f ss \<unrhd> t" by (rule supteq_trans)
    from \<open>s \<in> set ss\<close> and \<open>s \<rhd> t\<close> have "Fun f ss \<rhd> t" ..
    then have second: "Fun f ss \<noteq> t" by (auto dest: supt_neqD)
    from first and second show "Fun f ss \<unrhd> t \<and> Fun f ss \<noteq> t" by auto
  qed (auto simp: size_simps)
next
  assume "s \<unrhd> t \<and> s \<noteq> t"
  then have "s \<unrhd> t" and "s \<noteq> t" by auto
  then show "s \<rhd> t" by (induct) (auto)
qed

lemma supt_not_sym: "s \<rhd> t \<Longrightarrow> \<not> (t \<rhd> s)"
proof
  assume "s \<rhd> t" and "t \<rhd> s" then have "s \<rhd> s" by (rule supt_trans)
  then show False unfolding supt_supteq_conv by simp
qed

lemma supt_irrefl[iff]: "\<not> t \<rhd> t"
  using supt_not_sym[of t t] by auto

lemma irrefl_subt: "irrefl {\<lhd>}" by (auto simp: irrefl_def)

lemma supt_imp_supteq: "s \<rhd> t \<Longrightarrow> s \<unrhd> t"
  unfolding supt_supteq_conv by auto

lemma supt_supteq_not_supteq: "s \<rhd> t = (s \<unrhd> t \<and> \<not> (t \<unrhd> s))"
  using supt_not_sym unfolding supt_supteq_conv by auto

lemma supteq_supt_conv: "(s \<unrhd> t) = (s \<rhd> t \<or> s = t)" by (auto simp: supt_supteq_conv)

lemma supteq_antisym:
  assumes "s \<unrhd> t" and "t \<unrhd> s" shows "s = t"
  using assms unfolding supteq_supt_conv by (auto simp: supt_not_sym)

text \<open>The subterm relation is an order on terms.\<close>
interpretation subterm: order "(\<unlhd>)" "(\<lhd>)"
  by (unfold_locales)
    (rule supt_supteq_not_supteq, auto intro: supteq_trans supteq_antisym supt_supteq_not_supteq)

text \<open>More transitivity rules.\<close>
lemma supt_supteq_trans[trans]:
  "s \<rhd> t \<Longrightarrow> t \<unrhd> u \<Longrightarrow> s \<rhd> u"
  by (metis subterm.le_less_trans)

lemma supteq_supt_trans[trans]:
  "s \<unrhd> t \<Longrightarrow> t \<rhd> u \<Longrightarrow> s \<rhd> u"
  by (metis subterm.less_le_trans)

declare subterm.le_less_trans[trans]
declare subterm.less_le_trans[trans]

lemma suptE [elim]: "s \<rhd> t \<Longrightarrow> (s \<unrhd> t \<Longrightarrow> P) \<Longrightarrow> (s \<noteq> t \<Longrightarrow> P) \<Longrightarrow> P"
  by (auto simp: supt_supteq_conv)

lemmas suptI [intro] =
  subterm.dual_order.not_eq_order_implies_strict

lemma supteq_supt_set_conv:
  "{\<unrhd>} = {\<rhd>}\<^sup>="
  by (auto simp: supt_supteq_conv)

lemma supteq_imp_vars_term_subset:
  "s \<unrhd> t \<Longrightarrow> vars_term t \<subseteq> vars_term s"
  by (induct rule: supteq.induct) auto

lemma set_supteq_into_supt [simp]:
  assumes "t \<in> set ts" and "t \<unrhd> s"
  shows "Fun f ts \<rhd> s"
proof -
  from \<open>t \<unrhd> s\<close> have "t = s \<or> t \<rhd> s" by auto
  then show ?thesis
  proof
    assume "t = s"
    with \<open>t \<in> set ts\<close> show ?thesis by auto
  next
    assume "t \<rhd> s"
    from supt.subt[OF \<open>t \<in> set ts\<close> this] show ?thesis .
  qed
qed

text \<open>The superterm relation is strongly normalizing.\<close>
lemma SN_supt:
  "SN {\<rhd>}"
  unfolding SN_iff_wf by (rule wf_subset) (auto intro: supt_size)

lemma supt_not_refl[elim!]:
  assumes "t \<rhd> t" shows False
proof -
  from assms have "t \<noteq> t" by auto
  then show False by simp
qed

lemma supteq_not_supt [elim]:
  assumes "s \<unrhd> t" and "\<not> (s \<rhd> t)"
  shows "s = t"
  using assms by (induct) auto

lemma supteq_not_supt_conv [simp]:
  "{\<unrhd>} - {\<rhd>} = Id" by auto

lemma supteq_subst [simp, intro]:
  assumes "s \<unrhd> t" shows "s \<cdot> \<sigma> \<unrhd> t \<cdot> \<sigma>"
  using assms
proof (induct rule: supteq.induct)
  case (subt u ss t f)
  from \<open>u \<in> set ss\<close> have "u \<cdot> \<sigma> \<in> set (map (\<lambda>t. t \<cdot> \<sigma>) ss)" "u \<cdot> \<sigma> \<unrhd> u \<cdot> \<sigma>" by auto
  then have "Fun f ss \<cdot> \<sigma> \<unrhd> u \<cdot> \<sigma>" unfolding subst_apply_term.simps by blast
  from this and \<open>u \<cdot> \<sigma> \<unrhd> t \<cdot> \<sigma>\<close> show ?case by (rule supteq_trans)
qed auto

lemma supt_subst [simp, intro]:
  assumes "s \<rhd> t" shows "s \<cdot> \<sigma> \<rhd> t \<cdot> \<sigma>"
  using assms
proof (induct rule: supt.induct)
  case (arg s ss f)
  then have "s \<cdot> \<sigma> \<in> set (map (\<lambda>t. t \<cdot> \<sigma>) ss)" by simp
  then show ?case unfolding subst_apply_term.simps by (rule supt.arg)
next
  case (subt u ss t f)
  from \<open>u \<in> set ss\<close> have "u \<cdot> \<sigma> \<in> set (map (\<lambda>t. t \<cdot> \<sigma>) ss)" by simp
  then have "Fun f ss \<cdot> \<sigma> \<rhd> u \<cdot> \<sigma>" unfolding subst_apply_term.simps by (rule supt.arg)
  with \<open>u \<cdot> \<sigma> \<rhd> t \<cdot> \<sigma>\<close> show ?case by (metis supt_trans)
qed

lemma subterm_induct:
  assumes "\<And>t. \<forall>s\<lhd>t. P s \<Longrightarrow> P t"
  shows [case_names subterm]: "P t"
  by (rule wf_induct[OF wf_measure[of size], of P t], rule assms, insert supt_size, auto)

subsection \<open>Contexts\<close>

text \<open>A \<^emph>\<open>context\<close> is a term containing exactly one \<^emph>\<open>hole\<close>.\<close>
datatype (funs_ctxt: 'f, vars_ctxt: 'v) ctxt =
  Hole ("\<box>") |
  More 'f "('f, 'v) term list" "('f, 'v) ctxt" "('f, 'v) term list"

text \<open>
  We also say that we apply a context~@{term C} to a term~@{term t} when we
  replace the hole in a @{term C} by @{term t}.
\<close>
fun ctxt_apply_term :: "('f, 'v) ctxt \<Rightarrow> ('f, 'v) term \<Rightarrow> ('f, 'v) term" ("_\<langle>_\<rangle>" [1000, 0] 1000)
  where
    "\<box>\<langle>s\<rangle> = s" |
    "(More f ss1 C ss2)\<langle>s\<rangle> = Fun f (ss1 @ C\<langle>s\<rangle> # ss2)"

lemma ctxt_eq [simp]:
  "(C\<langle>s\<rangle> = C\<langle>t\<rangle>) = (s = t)" by (induct C) auto

fun ctxt_compose :: "('f, 'v) ctxt \<Rightarrow> ('f, 'v) ctxt \<Rightarrow> ('f, 'v) ctxt" (infixl "\<circ>\<^sub>c" 75)
  where
    "\<box> \<circ>\<^sub>c D = D" |
    "(More f ss1 C ss2) \<circ>\<^sub>c D = More f ss1 (C \<circ>\<^sub>c D) ss2"

interpretation ctxt_monoid_mult: monoid_mult "\<box>" "(\<circ>\<^sub>c)"
proof
  fix C D E :: "('f, 'v) ctxt"
  show "C \<circ>\<^sub>c D \<circ>\<^sub>c E = C \<circ>\<^sub>c (D \<circ>\<^sub>c E)" by (induct C) simp_all
  show "\<box> \<circ>\<^sub>c C = C" by simp
  show "C \<circ>\<^sub>c \<box> = C" by (induct C) simp_all
qed

instantiation ctxt :: (type, type) monoid_mult
begin
definition [simp]: "1 = \<box>"
definition [simp]: "(*) = (\<circ>\<^sub>c)"
instance by (intro_classes) (simp_all add: ac_simps)
end

lemma ctxt_ctxt_compose [simp]: "(C \<circ>\<^sub>c D)\<langle>t\<rangle> = C\<langle>D\<langle>t\<rangle>\<rangle>" by (induct C) simp_all

lemmas ctxt_ctxt = ctxt_ctxt_compose [symmetric]

text \<open>Applying substitutions to contexts.\<close>
fun subst_apply_ctxt :: "('f, 'v) ctxt \<Rightarrow> ('f, 'v, 'w) gsubst \<Rightarrow> ('f, 'w) ctxt" (infixl "\<cdot>\<^sub>c" 67)
  where
    "\<box> \<cdot>\<^sub>c \<sigma> = \<box>" |
    "(More f ss1 D ss2) \<cdot>\<^sub>c \<sigma> = More f (map (\<lambda>t. t \<cdot> \<sigma>) ss1) (D \<cdot>\<^sub>c \<sigma>) (map (\<lambda>t. t \<cdot> \<sigma>) ss2)"

lemma subst_apply_term_ctxt_apply_distrib [simp]:
  "C\<langle>t\<rangle> \<cdot> \<mu> = (C \<cdot>\<^sub>c \<mu>)\<langle>t \<cdot> \<mu>\<rangle>"
  by (induct C) auto

lemma subst_compose_ctxt_compose_distrib [simp]:
  "(C \<circ>\<^sub>c D) \<cdot>\<^sub>c \<sigma> = (C \<cdot>\<^sub>c \<sigma>) \<circ>\<^sub>c (D \<cdot>\<^sub>c \<sigma>)"
  by (induct C) auto

lemma ctxt_compose_subst_compose_distrib [simp]:
  "C \<cdot>\<^sub>c (\<sigma> \<circ>\<^sub>s \<tau>) = (C \<cdot>\<^sub>c \<sigma>) \<cdot>\<^sub>c \<tau>"
  by (induct C) (auto)

subsection \<open>The Connection between Contexts and the Superterm Relation\<close>

lemma ctxt_imp_supteq [simp]:
  shows "C\<langle>t\<rangle> \<unrhd> t" by (induct C) auto

lemma supteq_ctxtE[elim]:
  assumes "s \<unrhd> t" obtains C where "s = C\<langle>t\<rangle>"
  using assms proof (induct arbitrary: thesis)
  case (refl s)
  have "s = \<box>\<langle>s\<rangle>" by simp
  from refl[OF this] show ?case .
next
  case (subt u ss t f)
  then obtain C where "u = C\<langle>t\<rangle>" by auto
  from split_list[OF \<open>u \<in> set ss\<close>] obtain ss1 and ss2 where "ss = ss1 @ u # ss2" by auto
  then have "Fun f ss = (More f ss1 C ss2)\<langle>t\<rangle>" using \<open>u = C\<langle>t\<rangle>\<close> by simp
  with subt show ?case by best
qed

lemma ctxt_supteq[intro]:
  assumes "s = C\<langle>t\<rangle>" shows "s \<unrhd> t"
proof (cases C)
  case Hole then show ?thesis using assms by auto
next
  case (More f ss1 D ss2)
  with assms have s: "s = Fun f (ss1 @ D\<langle>t\<rangle> # ss2)" (is "_ = Fun _ ?ss") by simp
  have "D\<langle>t\<rangle> \<in> set ?ss" by simp
  moreover have "D\<langle>t\<rangle> \<unrhd> t" by (induct D) auto
  ultimately show ?thesis unfolding s ..
qed

lemma supteq_ctxt_conv: "(s \<unrhd> t) = (\<exists>C. s = C\<langle>t\<rangle>)" by auto

lemma supt_ctxtE[elim]:
  assumes "s \<rhd> t" obtains C where "C \<noteq> \<box>" and "s = C\<langle>t\<rangle>"
  using assms
proof (induct arbitrary: thesis)
  case (arg s ss f)
  from split_list[OF \<open>s \<in> set ss\<close>] obtain ss1 and ss2 where ss: "ss = ss1 @ s # ss2" by auto
  let ?C = "More f ss1 \<box> ss2"
  have "?C \<noteq> \<box>" by simp
  moreover have "Fun f ss = ?C\<langle>s\<rangle>" by (simp add: ss)
  ultimately show ?case using arg by best
next
  case (subt s ss t f)
  then obtain C where "C \<noteq> \<box>" and "s = C\<langle>t\<rangle>" by auto
  from split_list[OF \<open>s \<in> set ss\<close>] obtain ss1 and ss2 where ss: "ss = ss1 @ s # ss2" by auto
  have "More f ss1 C ss2 \<noteq> \<box>" by simp
  moreover have "Fun f ss = (More f ss1 C ss2)\<langle>t\<rangle>" using \<open>s = C\<langle>t\<rangle>\<close> by (simp add: ss)
  ultimately show ?case using subt(4) by best
qed

lemma ctxt_supt[intro 2]:
  assumes "C \<noteq> \<box>" and "s = C\<langle>t\<rangle>" shows "s \<rhd> t"
proof (cases C)
  case Hole with assms show ?thesis by simp
next
  case (More f ss1 D ss2)
  with assms have s: "s = Fun f (ss1 @ D\<langle>t\<rangle> # ss2)" by simp
  have "D\<langle>t\<rangle> \<in> set (ss1 @ D\<langle>t\<rangle> # ss2)" by simp
  then have "s \<rhd> D\<langle>t\<rangle>" unfolding s ..
  also have "D\<langle>t\<rangle> \<unrhd> t" by (induct D) auto
  finally show "s \<rhd> t" .
qed

lemma supt_ctxt_conv: "(s \<rhd> t) = (\<exists>C. C \<noteq> \<box> \<and> s = C\<langle>t\<rangle>)" (is "_ = ?rhs")
proof
  assume "s \<rhd> t"
  then have "s \<unrhd> t" and "s \<noteq> t" by auto
  from \<open>s \<unrhd> t\<close> obtain C where "s = C\<langle>t\<rangle>" by auto
  with \<open>s \<noteq> t\<close> have "C \<noteq> \<box>" by auto
  with \<open>s = C\<langle>t\<rangle>\<close> show "?rhs" by auto
next
  assume "?rhs" then show "s \<rhd> t" by auto
qed

lemma nectxt_imp_supt_ctxt: "C \<noteq> \<box> \<Longrightarrow> C\<langle>t\<rangle> \<rhd> t" by auto

lemma supt_var: "\<not> (Var x \<rhd> u)"
proof
  assume "Var x \<rhd> u"
  then obtain C where "C \<noteq> \<box>" and "Var x = C\<langle>u\<rangle>" ..
  then show False by (cases C) auto
qed

lemma supt_const: "\<not> (Fun f [] \<rhd> u)"
proof
  assume "Fun f [] \<rhd> u"
  then obtain C where "C \<noteq> \<box>" and "Fun f [] = C\<langle>u\<rangle>" ..
  then show False by (cases C) auto
qed

lemma supteq_var_imp_eq:
  "(Var x \<unrhd> t) = (t = Var x)" (is "_ = (_ = ?x)")
proof
  assume "t = Var x" then show "Var x \<unrhd> t" by auto
next
  assume st: "?x \<unrhd> t"
  from st obtain C where "?x = C\<langle>t\<rangle>" by best
  then show "t = ?x" by (cases C) auto
qed

lemma Var_supt [elim!]:
  assumes "Var x \<rhd> t" shows P
  using assms supt_var[of x t] by simp

lemma Fun_supt [elim]:
  assumes "Fun f ts \<rhd> s" obtains t where "t \<in> set ts" and "t \<unrhd> s"
  using assms by (cases) (auto simp: supt_supteq_conv)

lemma inj_ctxt_apply_term: "inj (ctxt_apply_term C)"
  by (auto simp: inj_on_def)

lemma ctxt_subst_eq: "(\<And>x. x \<in> vars_ctxt C \<Longrightarrow> \<sigma> x = \<tau> x) \<Longrightarrow> C \<cdot>\<^sub>c \<sigma> = C \<cdot>\<^sub>c \<tau>"
proof (induct C)
  case (More f bef C aft)
  { fix t
    assume t:"t \<in> set bef"
    have "t \<cdot> \<sigma> = t \<cdot> \<tau>" using t More(2) by (auto intro: term_subst_eq)
  }
  moreover
  { fix t
    assume t:"t \<in> set aft"
    have "t \<cdot> \<sigma> = t \<cdot> \<tau>" using t More(2) by (auto intro: term_subst_eq)
  }
  moreover have "C \<cdot>\<^sub>c \<sigma> = C \<cdot>\<^sub>c \<tau>" using More by auto
  ultimately show ?case by auto
qed auto

end


theory Ordered_Abelian_Group
imports  Main "~~/src/HOL/Algebra/Ring"  "~~/src/HOL/Algebra/Order"
begin

(*an ordered monoid record*)

record 'a ordered_monoid = "'a monoid" +
  le :: "['a, 'a] => bool" (infixl  "\<preceq>\<index>" 50)

(*a locale for an ordered monoid, that is: an instance of 'a ordered_monoid where the
  carrier is a monoid, and the le relation is an order relation which respects the operation. *)

(*forgetful functor to get the underlying order of an ordered monoid*)
abbreviation
  underlying_order :: "('a, 'm) ordered_monoid_scheme \<Rightarrow> ('a, 'm) gorder_scheme"
  where "underlying_order G \<equiv> \<lparr>carrier = carrier G, eq = (=), gorder.le = le G
, \<dots> = (undefined:: 'm) \<rparr>"

locale has_order =
  fixes G (structure)
  assumes an_order:
    "total_order (underlying_order G)"

lemma has_orderI:
  fixes G (structure)
  assumes "total_order (underlying_order G)"
  shows "has_order G"
  by (simp add: has_order.intro assms)

(*an ordered monoid is a monoid with a total order which respects the operation*)

locale le_resp_mult =
  fixes G (structure)
  assumes "\<lbrakk> a \<in> carrier G; b \<in> carrier G;le G a b;c \<in> carrier G \<rbrakk> \<Longrightarrow>((le G)(a\<otimes>\<^bsub>G\<^esub>c) (b\<otimes>\<^bsub>G\<^esub>c))"

locale ordered_monoid =
  fixes G (structure)
  assumes a_monoid:
    "monoid G"
  assumes an_order:
   "has_order G"
  assumes "le_resp_mult G"

locale ordered_abelian_group = ordered_monoid +
  assumes ab:
    "comm_group  G"

lemma oagI:
  fixes G (structure)
  assumes "comm_group G"
  assumes "has_order G"
  assumes "le_resp_mult G"
  shows "ordered_abelian_group G"
proof-
  have "ordered_monoid G"
  proof-
    have "monoid G"
      by (simp add: assms(1) comm_group.axioms(2) group.is_monoid)
    then show ?thesis
      using assms(2) assms(3) ordered_monoid_def
      by (simp add: ordered_monoid_def)
  qed
  then show ?thesis
    by (simp add: assms(1) ordered_abelian_group.intro ordered_abelian_group_axioms.intro)
qed

lemma (in ordered_abelian_group) le_resp_mult1:
    "\<lbrakk> a \<in> carrier G; b \<in> carrier G;le G a b;c \<in> carrier G \<rbrakk> \<Longrightarrow>((le G) (c\<otimes>\<^bsub>G\<^esub>a)  (c\<otimes>\<^bsub>G\<^esub>b) )"
  using ab comm_groupE(4) le_resp_mult_def ordered_monoid_axioms ordered_monoid_def by fastforce

lemma (in ordered_abelian_group) inv_0:
  assumes D:"x \<in> carrier G"
  assumes P: "\<one>\<^bsub>G\<^esub> \<preceq>\<^bsub>G\<^esub> x"
  shows "(inv x) \<preceq>\<^bsub>G\<^esub>  \<one>\<^bsub>G\<^esub>"
proof-
  have  "((inv x) \<otimes>\<^bsub>G\<^esub> \<one>\<^bsub>G\<^esub>) \<preceq>\<^bsub>G\<^esub> ( (inv x) \<otimes>\<^bsub>G\<^esub> x)"
    by (simp add: D P ab comm_group.axioms(2) comm_groupE(2) le_resp_mult1)
  from this show  "(inv x) \<preceq>\<^bsub>G\<^esub> \<one>\<^bsub>G\<^esub>"
    by (simp add: D a_monoid ab comm_group.axioms(2) group.l_inv)
qed

lemma (in ordered_abelian_group) inv_1:
  assumes D:"x \<in> carrier G"
  assumes P: "x  \<preceq>\<^bsub>G\<^esub> \<one>\<^bsub>G\<^esub>"
  shows "\<one>\<^bsub>G\<^esub> \<preceq>\<^bsub>G\<^esub>(inv x)"
proof-
  have  " ( (inv x) \<otimes>\<^bsub>G\<^esub> x)\<preceq>\<^bsub>G\<^esub> ((inv x) \<otimes>\<^bsub>G\<^esub> \<one>\<^bsub>G\<^esub>)"
    by (simp add: D P ab comm_group.axioms(2) comm_groupE(2) le_resp_mult1)
  from this show " \<one>\<^bsub>G\<^esub>  \<preceq>\<^bsub>G\<^esub> (inv x)"
    by (simp add: D a_monoid ab comm_group.axioms(2) group.l_inv)
qed

lemma (in ordered_abelian_group) inv_or:
  assumes D:"x \<in> carrier G"
  shows "\<one>\<^bsub>G\<^esub> \<preceq>\<^bsub>G\<^esub>(inv x) \<or>(inv x) \<preceq>\<^bsub>G\<^esub> \<one>\<^bsub>G\<^esub>"
  using inv_1 and inv_0 and  a_monoid an_order assms has_order.an_order
    monoid.one_closed total_order.total_order_total by fastforce

lemma (in ordered_abelian_group) one_in:
"\<one> \<in> carrier G"
  by (simp add: a_monoid)

lemma (in ordered_abelian_group) no_idempotents0:
  fixes x
  assumes "x \<in> carrier G"
  assumes "inv x = x"
  shows "x = \<one>" using inv_or  has_order_def assms(1)
  using an_order assms(2) inv_0 inv_1 one_in  partial_order.le_antisym total_order.axioms(1)
  by fastforce

lemma (in ordered_abelian_group) no_idempotents1:
  fixes x
  assumes "x \<in> carrier G"
  assumes "x \<otimes> x = \<one>"
  shows "x = \<one>"
  by (simp add: a_monoid assms(1) assms(2) monoid.inv_char ordered_abelian_group.no_idempotents0 ordered_abelian_group_axioms)

end


(*<*)
theory Bossiness
imports
  COP
begin

(*>*)
section\<open> \citet{Kojima:2010}: The non-existence of a stable and non-bossy mechanism \label{sec:bossiness} \<close>

text (in Contracts) \<open>

\citet{Kojima:2010} says that ``a mechanism is @{emph \<open>nonbossy\<close>} if an
agent cannot change [the] allocation of other agents unless doing so
also changes her own allocation.'' He shows that no mechanism can be
both @{const "stable_on"} and @{emph \<open>nonbossy\<close>} in a one-to-one marriage
market. We establish this result in our matching-with-contracts
setting here.

There are two complications. Firstly, as not all agent preferences
yield stable matches (unlike the marriage market), we constrain
hospital choice functions to satisfy @{const
"ContractsWithBilateralSubstitutesAndIRC"}, which is the weakest
condition formalized here that ensures that @{const "fp_cop_F"} yields
stable matches. (We note that it is not the weakest condition
guaranteeing the existence of stable matches.)

Secondly, non-bossiness needs to separately treat the preferences of
the doctors and the choice functions of the hospitals.

We work in the @{const "Contracts"} locale for its types and the
constants @{term "Xd"} and @{term "Xh"}. To account for the
quantification over preferences, we directly use some raw constants
from the @{const "Contracts"} locale.

\<close>

context Contracts
begin

abbreviation (input) mechanism_domain :: "('d \<Rightarrow> 'x rel) \<Rightarrow> ('h \<Rightarrow> 'x cfun) \<Rightarrow> bool" where
  "mechanism_domain \<equiv> ContractsWithBilateralSubstitutesAndIRC Xd Xh"

definition nonbossy :: "'d set \<Rightarrow> ('d, 'h, 'x) mechanism \<Rightarrow> bool" where
  "nonbossy ds \<phi> \<longleftrightarrow>
    (\<forall>Pd Pd' Ch. \<forall>d\<in>ds. mechanism_domain Pd Ch \<and> mechanism_domain (Pd(d:=Pd')) Ch \<longrightarrow>
      dX (\<phi> Pd Ch ds) d = dX (\<phi> (Pd(d:=Pd')) Ch ds) d \<longrightarrow> \<phi> Pd Ch ds = \<phi> (Pd(d:=Pd')) Ch ds)
  \<and> (\<forall>Pd Ch Ch' h. mechanism_domain Pd Ch \<and> mechanism_domain Pd (Ch(h:=Ch')) \<longrightarrow>
      hX (\<phi> Pd Ch ds) h = hX (\<phi> Pd (Ch(h:=Ch')) ds) h \<longrightarrow> \<phi> Pd Ch ds = \<phi> Pd (Ch(h:=Ch')) ds)"

definition mechanism_stable :: "'d set \<Rightarrow> ('d, 'h, 'x) mechanism \<Rightarrow> bool" where
  "mechanism_stable ds \<phi>
     \<longleftrightarrow> (\<forall>Pd Ch. mechanism_domain Pd Ch \<longrightarrow> Contracts.stable_on Pd Ch ds (\<phi> Pd Ch ds))"

(*<*)

lemma nonbossy_Pd:
  assumes "nonbossy ds \<phi>"
  assumes "mechanism_domain Pd' Ch'"
  assumes "mechanism_domain (Pd'(d:=Pd'')) Ch'"
  assumes "dX (\<phi> Pd' Ch' ds) d = dX (\<phi> (Pd'(d:=Pd'')) Ch' ds) d"
  assumes "d \<in> ds"
  shows "\<phi> Pd' Ch' ds = \<phi> (Pd'(d:=Pd'')) Ch' ds"
using assms unfolding nonbossy_def by blast

lemma nonbossy_Ch:
  assumes "nonbossy ds \<phi>"
  assumes "mechanism_domain Pd' Ch'"
  assumes "mechanism_domain Pd' (Ch'(h:=Ch''))"
  assumes "hX (\<phi> Pd' Ch' ds) h = hX (\<phi> Pd' (Ch'(h:=Ch'')) ds) h"
  shows "\<phi> Pd' Ch' ds = \<phi> Pd' (Ch'(h:=Ch'')) ds"
using assms unfolding nonbossy_def by blast

(*>*)

end

text (in Contracts) \<open>

The proof is somewhat similar to those for Roth's impossibility
results (see, for instance, \citet[Theorem~4.4]{RothSotomayor:1990}).
It relies on the existence of at least three doctors, three hospitals,
and a complete set of contracts between these. The following locale
captures a suitable set of constraints.

\<close>

locale BossyConstants =
  fixes Xd :: "'x \<Rightarrow> 'd"
  fixes Xh :: "'x \<Rightarrow> 'h"
  fixes d1h1 d1h2 d1h3 :: 'x
  fixes d2h1 d2h2 d2h3 :: 'x
  fixes d3h1 d3h2 d3h3 :: 'x
  fixes ds :: "'d set"
  assumes ds: "distinct [Xd d1h1, Xd d2h1, Xd d3h1]"
  assumes hs: "distinct [Xh d1h1, Xh d1h2, Xh d1h3]"
  assumes Xd_xs:
    "Xd ` {d1h2, d1h3} = {Xd d1h1}"
    "Xd ` {d2h2, d2h3} = {Xd d2h1}"
    "Xd ` {d3h2, d3h3} = {Xd d3h1}"
  assumes Xh_xs:
    "Xh ` {d2h1, d3h1} = {Xh d1h1}"
    "Xh ` {d2h2, d3h2} = {Xh d1h2}"
    "Xh ` {d2h3, d3h3} = {Xh d1h3}"
  assumes dset: "{Xd d1h1, Xd d2h1, Xd d3h1} \<subseteq> ds"

locale ContractsWithBossyConstants =
  Contracts + BossyConstants
begin

abbreviation (input) "d1 \<equiv> Xd d1h1"
abbreviation (input) "d2 \<equiv> Xd d2h1"
abbreviation (input) "d3 \<equiv> Xd d3h1"

abbreviation (input) "h1 \<equiv> Xh d1h1"
abbreviation (input) "h2 \<equiv> Xh d1h2"
abbreviation (input) "h3 \<equiv> Xh d1h3"

(*<*)

lemma xs:
  shows "distinct [d1h1, d1h2, d1h3, d2h1, d2h2, d2h3, d3h1, d3h2, d3h3]"
using Xd_xs Xh_xs ds hs by auto

(*>*)

text\<open>

We proceed to show that variations on the following preferences for
doctors and hospitals force a stable mechanism to be bossy. Recall
that @{const "linord_of_list"} constructs a linear order from a list of
elements greatest to least. The hospital choice functions take at most
one contract from those on offer, and are again ordered from most
preferable to least.

\<close>

definition BPd :: "'b \<Rightarrow> 'a rel" where
  "BPd \<equiv> map_of_default {} [ (d1, linord_of_list [d1h3, d1h2, d1h1])
                           , (d2, linord_of_list [d2h3, d2h2, d2h1])
                           , (d3, linord_of_list [d3h1, d3h2, d3h3]) ]"

abbreviation mkhord :: "'d list \<Rightarrow> 'd cfun" where
  "mkhord xs X \<equiv> set_option (List.find (\<lambda>x. x\<in>X) xs)"

definition BCh :: "'c \<Rightarrow> 'a cfun" where
  "BCh \<equiv> map_of_default (\<lambda>_. {}) [ (h1, mkhord [d1h1, d2h1, d3h1])
                                 , (h2, mkhord [])
                                 , (h3, mkhord [d3h3, d2h3, d1h3]) ]"

text\<open>

Interpreting the @{const "Contracts"} locale gives us access to some
useful constants.

\<close>

interpretation Bossy: Contracts Xd Xh BPd BCh
using %invisible Xd_xs Xh_xs xs unfolding BPd_def BCh_def
by unfold_locales (auto simp: linord_of_list_Linear_order)

lemma BPd_BCh_mechanism_domain:
  shows "mechanism_domain BPd BCh"
by %invisible unfold_locales (auto simp: BCh_def bilateral_substitutes_on_def irc_on_def)

(*<*)

lemma BPd_simps:
  "BPd d1 = linord_of_list [d1h3, d1h2, d1h1]"
  "BPd d2 = linord_of_list [d2h3, d2h2, d2h1]"
  "BPd d3 = linord_of_list [d3h1, d3h2, d3h3]"
  "d \<notin> {d1, d2, d3} \<longleftrightarrow> BPd d = {}"
unfolding BPd_def using Xd_xs ds by auto

lemma BCh_simps:
  "BCh h1 = mkhord [d1h1, d2h1, d3h1]"
  "BCh h3 = mkhord [d3h3, d2h3, d1h3]"
  "h \<notin> {h1, h3} \<Longrightarrow> BCh h X = {}"
unfolding BCh_def using Xh_xs hs by auto

lemma Bossy_CD_on_Cd:
  shows "Bossy.CD_on ds X = Bossy.Cd d1 X \<union> Bossy.Cd d2 X \<union> Bossy.Cd d3 X" (is "?lhs = ?rhs")
proof(rule equalityI)
  show "?lhs \<subseteq> ?rhs"
    unfolding Bossy.CD_on_def by clarsimp (metis BPd_simps(4) Bossy.Cd_range' Field_empty Int_iff empty_iff insertE)
  from dset show "?rhs \<subseteq> ?lhs"
    unfolding Bossy.CD_on_def by blast
qed

lemma Bossy_CH_BCh:
  shows "Bossy.CH X = BCh h1 X \<union> BCh h3 X" (is "?lhs = ?rhs")
proof(rule equalityI)
  show "?lhs \<subseteq> ?rhs"
    unfolding Bossy.CH_def by clarsimp (simp add: BCh_def split: if_splits)
  show "?rhs \<subseteq> ?lhs"
    unfolding Bossy.CH_def by blast
qed

(*>*)

lemma Bossy_stable:
  shows "Bossy.stable_on ds X \<longleftrightarrow> X = {d1h1, d3h3}"
(*<*) (is "?lhs = ?rhs")
proof (rule iffI)
  assume ?lhs with Xd_xs ds xs show ?rhs
    apply -
    apply (frule Bossy.stable_on_allocation)
    apply (frule Bossy.stable_on_CH)
    apply (frule Bossy.stable_on_CD_on)

    (* Enumerate all possible contracts *)
    apply (frule Bossy_CH_range[OF Set.equalityD2])
    apply (drule subset_subseqs)

    apply clarsimp
    apply (elim disjE)
    apply (simp_all add: Bossy_CH_BCh BCh_simps insert_eq_iff insert_commute)
    using Bossy.stable_on_blocking_onD[where h="h3" and X''="{d3h3}" and X="X" and ds=ds]
          Bossy.stable_on_blocking_onD[where h="h1" and X''="{d2h1}" and X="X" and ds=ds]
          Bossy.stable_on_blocking_onD[where h="h1" and X''="{d1h1}" and X="X" and ds=ds]
    apply (simp_all add: Bossy_CH_BCh BCh_simps Bossy_CD_on_Cd BPd_simps)
    done
next
  assume ?rhs show ?lhs
  proof(rule Bossy.stable_onI)
    show "Bossy.individually_rational_on ds X"
    proof(rule Bossy.individually_rational_onI)
      from xs \<open>?rhs\<close> show "Bossy.CD_on ds X = X" by clarsimp (force simp: Bossy_CD_on_Cd BPd_simps)
      from \<open>?rhs\<close> show "Bossy.CH X = X" by (simp add: Bossy_CH_BCh BCh_simps insert_commute)
    qed
    show "Bossy.stable_no_blocking_on ds X"
    proof(rule Bossy.stable_no_blocking_onI)
      fix h X'' assume XXX: "X'' = BCh h (X \<union> X'')" "X'' \<noteq> BCh h X" "X'' \<subseteq> Bossy.CD_on ds (X \<union> X'')"
      from \<open>?rhs\<close> XXX(1,2) have h: "h \<in> {h1, h3}" using BCh_simps by auto
      from XXX(1) have X'': "X'' \<subseteq> set [d1h1, d1h3, d2h1, d2h3, d3h1, d3h3]"
        using Bossy_CH_range[unfolded Bossy.CH_def] by blast
      from \<open>?rhs\<close> XXX h X'' Xh_xs hs xs show False
        apply -
        apply (drule subset_subseqs)
        apply clarsimp
        apply (elim disjE)
        apply (simp_all add: BCh_simps)
        done
    qed
  qed
qed

(*>*)
text\<open>

The second preference order has doctor @{const "d2"} reject all
contracts and is otherwise the same as the first.

\<close>

definition BPd' :: "'b \<Rightarrow> 'a rel" where
  "BPd' = BPd(d2 := {})"

interpretation Bossy': Contracts Xd Xh BPd' BCh
using %invisible Xd_xs Xh_xs xs unfolding BPd_def BPd'_def BCh_def
by unfold_locales (auto simp: linord_of_list_Linear_order)

lemma BPd'_BCh_mechanism_domain:
  shows "mechanism_domain BPd' BCh"
by %invisible unfold_locales (auto simp: BCh_def bilateral_substitutes_on_def irc_on_def)

(*<*)

lemma BPd'_simps:
  "BPd' d1 = linord_of_list [d1h3, d1h2, d1h1]"
  "BPd' d3 = linord_of_list [d3h1, d3h2, d3h3]"
  "d \<notin> {d1, d3} \<longleftrightarrow> BPd' d = {}"
unfolding BPd_def BPd'_def using Xd_xs ds by auto

lemma Bossy'_CD_on_Cd:
  "Bossy'.CD_on ds X = Bossy'.Cd d1 X \<union> Bossy'.Cd d3 X" (is "?lhs = ?rhs")
proof(rule equalityI)
  show "?lhs \<subseteq> ?rhs"
    unfolding Bossy'.CD_on_def by clarsimp (metis BPd'_simps(3) Bossy'.Cd_range' Field_empty Int_iff empty_iff insertE)
  from dset show "?rhs \<subseteq> ?lhs"
    unfolding Bossy'.CD_on_def by blast
qed

(*>*)

lemma Bossy'_stable:
  shows "Bossy'.stable_on ds X \<longleftrightarrow> X = {d1h3, d3h1} \<or> X = {d1h1, d3h3}"
(*<*) (is "?lhs = ?rhs")
proof (rule iffI)
  assume ?lhs
  with dset \<open>?lhs\<close> Xd_xs ds xs show ?rhs
    apply -
    apply (frule Bossy'.stable_on_allocation)
    apply (frule Bossy'.stable_on_CH)
    apply (frule Bossy'.stable_on_CD_on)

    (* Enumerate all possible contracts *)
    apply (frule Bossy_CH_range[OF Set.equalityD2])
    apply (drule subset_subseqs)

    apply clarsimp
    apply (elim disjE)
    apply (simp_all add: Bossy_CH_BCh BCh_simps insert_eq_iff insert_commute)
    using Bossy'.stable_on_blocking_onD[where h="h3" and X''="{d3h3}" and X="X" and ds=ds]
          Bossy'.stable_on_blocking_onD[where h="h1" and X''="{d1h1}" and X="X" and ds=ds]
    apply (simp_all add: Bossy_CH_BCh BCh_simps Bossy'_CD_on_Cd BPd'_simps)
    done
next
  assume ?rhs show ?lhs
  proof(rule Bossy'.stable_onI)
    show "Bossy'.individually_rational_on ds X"
    proof(rule Bossy'.individually_rational_onI)
      from ds xs \<open>?rhs\<close> show "Bossy'.CD_on ds X = X" by (force simp: Bossy'_CD_on_Cd BPd'_simps)
      from xs \<open>?rhs\<close> show "Bossy.CH X = X" by (force simp: Bossy_CH_BCh BCh_simps)
    qed
    show "Bossy'.stable_no_blocking_on ds X"
    proof(rule Bossy'.stable_no_blocking_onI)
      fix h X'' assume XXX: "X'' = BCh h (X \<union> X'')" "X'' \<noteq> BCh h X" "X'' \<subseteq> Bossy'.CD_on ds (X \<union> X'')"
      from \<open>?rhs\<close> XXX(1,2) have h: "h \<in> {h1, h2, h3}" using BCh_simps by auto
      from XXX(1) have X'': "X'' \<subseteq> set [d1h1, d1h3, d2h1, d2h3, d3h1, d3h3]"
        using Bossy_CH_range[unfolded Bossy.CH_def] by blast
      from \<open>?rhs\<close> XXX h X'' Xh_xs ds hs xs show False
        apply -
        apply (drule subset_subseqs)
        apply clarsimp
        apply (elim disjE)
        apply (simp_all add: BCh_simps)
        apply (simp_all add: Bossy'_CD_on_Cd Bossy'.maxR_def linord_of_list_linord_of_listP BPd'_simps)
        done
    qed
  qed
qed

(*>*)
text\<open>

The third preference order adjusts the choice function of hospital
@{const "h2"} and is otherwise the same as the second.

\<close>

definition BCh' :: "'c \<Rightarrow> 'a cfun" where
  "BCh' \<equiv> BCh(h2 := mkhord [d1h2, d2h2, d3h2])"

interpretation Bossy'': Contracts Xd Xh BPd' BCh'
using %invisible Xd_xs Xh_xs xs unfolding BPd_def BPd'_def BCh_def BCh'_def
by unfold_locales (auto simp: linord_of_list_Linear_order)

lemma BPd'_BCh'_mechanism_domain:
  shows "mechanism_domain BPd' BCh'"
by %invisible unfold_locales (auto simp: BCh_def BCh'_def bilateral_substitutes_on_def irc_on_def)

(*<*)

lemma BCh'_simps:
  "BCh' h1 = mkhord [d1h1, d2h1, d3h1]"
  "BCh' h2 = mkhord [d1h2, d2h2, d3h2]"
  "BCh' h3 = mkhord [d3h3, d2h3, d1h3]"
  "h \<notin> {h1, h2, h3} \<Longrightarrow> BCh' h X = {}"
unfolding BCh_def BCh'_def using Xh_xs hs by auto

lemma Bossy''_CH_BCh':
  "Bossy''.CH X = BCh' h1 X \<union> BCh' h2 X \<union> BCh' h3 X" (is "?lhs = ?rhs")
proof(rule equalityI)
  show "?lhs \<subseteq> ?rhs"
    unfolding Bossy''.CH_def by clarsimp (simp add: BCh_def BCh'_def split: if_splits)
  show "?rhs \<subseteq> ?lhs"
    unfolding Bossy''.CH_def by blast
qed

lemma Bossy''_CD_on_range:
  assumes "X \<subseteq> Bossy''.CD_on ds X'"
  shows "X \<subseteq> set [d1h1, d1h2, d1h3, d3h1, d3h2, d3h3]"
using assms by (auto simp: Bossy'_CD_on_Cd BPd'_simps dest!: Bossy''.Cd_range')

(*>*)

lemma Bossy''_stable:
  shows "Bossy''.stable_on ds X \<longleftrightarrow> X = {d3h1, d1h3}"
(*<*) (is "?lhs = ?rhs")
proof(rule iffI)
  assume ?lhs with Xd_xs ds xs show ?rhs
    apply -
    apply (frule Bossy''.stable_on_allocation)
    apply (frule Bossy''.stable_on_CH)
    apply (frule Bossy''.stable_on_CD_on)

    (* Enumerate all possible contracts *)
    apply (frule Bossy''_CD_on_range[OF Set.equalityD2])
    apply (drule subset_subseqs)

    apply clarsimp
    apply (elim disjE)
    apply (simp_all add: Bossy''_CH_BCh' BCh'_simps insert_eq_iff insert_commute)
    using Bossy''.stable_on_blocking_onD[where h="h1" and X''="{d3h1}" and X="X" and ds=ds]
          Bossy''.stable_on_blocking_onD[where h="h2" and X''="{d1h2}" and X="X" and ds=ds]
          Bossy''.stable_on_blocking_onD[where h="h3" and X''="{d1h3}" and X="X" and ds=ds]
    apply (simp_all add: BCh'_simps Bossy'_CD_on_Cd BPd'_simps)
    apply (simp_all add: Bossy''.maxR_def linord_of_list_linord_of_listP BPd'_simps)
    done
next
  assume ?rhs show ?lhs
  proof(rule Bossy''.stable_onI)
    show "Bossy''.individually_rational_on ds X"
    proof(rule Bossy''.individually_rational_onI)
      from ds xs \<open>?rhs\<close> show "Bossy''.CD_on ds X = X" by (force simp: Bossy'_CD_on_Cd BPd'_simps)
      from xs \<open>?rhs\<close> show "Bossy''.CH X = X" by (force simp: Bossy''_CH_BCh' BCh'_simps)
    qed
    show "Bossy''.stable_no_blocking_on ds X"
    proof(rule Bossy''.stable_no_blocking_onI)
      fix h X'' assume XXX: "X'' = BCh' h (X \<union> X'')" "X'' \<noteq> BCh' h X" "X'' \<subseteq> Bossy''.CD_on ds (X \<union> X'')"
      from \<open>?rhs\<close> XXX(1,2) have h: "h \<in> {h1, h2, h3}" using BCh'_simps by auto
      from XXX(3) have X'': "X'' \<subseteq> set [d1h1, d1h2, d1h3, d3h1, d3h2, d3h3]"
        using Bossy''_CD_on_range by blast
      from \<open>?rhs\<close> XXX h X'' Xh_xs ds hs xs show False
        apply -
        apply (drule subset_subseqs)
        apply clarsimp
        apply (elim disjE)
        apply (simp_all add: BCh'_simps)
        apply (simp_all add: Bossy'_CD_on_Cd BPd'_simps Bossy'.maxR_def linord_of_list_linord_of_listP)
        done
    qed
  qed
qed

(*>*)
text\<open>\<close>

theorem Theorem_1:
  shows "\<not>(mechanism_stable ds \<phi> \<and> nonbossy ds \<phi>)"
proof(rule notI, erule conjE)
  assume S: "Bossy.mechanism_stable ds \<phi>"
  assume NB: "Bossy.nonbossy ds \<phi>"
  from S Bossy'_stable BPd'_BCh_mechanism_domain
  consider (A) "\<phi> BPd' BCh ds = {d1h3, d3h1}" | (B) "\<phi> BPd' BCh ds = {d1h1, d3h3}"
    unfolding mechanism_stable_def by blast
  then show False
  proof cases
    case A
    from S BPd_BCh_mechanism_domain Bossy_stable have "\<phi> BPd BCh ds = {d1h1, d3h3}"
      unfolding mechanism_stable_def by blast
    with Xd_xs ds xs dset A show False
      using nonbossy_Pd[OF NB BPd_BCh_mechanism_domain BPd'_BCh_mechanism_domain[unfolded BPd'_def]]
      unfolding BPd'_def[symmetric] dX_def by fastforce
  next
    case B
    from S BPd'_BCh'_mechanism_domain Bossy''_stable have "\<phi> BPd' BCh' ds = {d3h1, d1h3}"
      unfolding mechanism_stable_def by blast
    with Xh_xs hs xs dset B show False
      using nonbossy_Ch[OF NB BPd'_BCh_mechanism_domain BPd'_BCh'_mechanism_domain[unfolded BCh'_def]]
      unfolding BCh'_def[symmetric] hX_def by fastforce
  qed
qed

text\<open>

In particular, the COP (see \S\ref{sec:cop}) is bossy as it always
yields stable matches under @{const "mechanism_stable"}.

\<close>

theorem Theorem_1_COP:
  "\<not>nonbossy ds Contracts.cop"
using ContractsWithBilateralSubstitutesAndIRC.Theorem_1 Theorem_1 mechanism_stable_def by blast

end

text\<open>

Therefore doctors can interfere with other doctors' allocations under
the COP without necessarily disadvantaging themselves, which has
implications for the notion of @{emph \<open>group strategy-proof\<close>}
\citep{HatfieldKojima:2009}; see \S\ref{sec:strategic-gsp}.

\<close>
(*<*)

end
(*>*)


(*<*)
theory Ex11
imports "~~/src/HOL/IMP/Hoare_Sound_Complete" "~~/src/HOL/IMP/VCG"
begin
(*>*)
text {* \ExerciseSheet{11}{13.~1.~2015} *}

text {*
  \Exercise{Forward Assignment Rule}

  Think up and prove a forward assignment rule, i.e., a rule of the
  form @{text "\<turnstile> {P} x::=a {\<dots>}"}, where @{text "\<dots>"} is some suitable
  postcondition. Hint: To prove this rule, use the completeness
  property, and prove the rule semantically.
*}
lemma fwd_Assign: "\<turnstile> {P} x::=a { \<lambda>s' . EX s. P s \<and> s' = s[a/x] }" (* s' = s(x:= aval a s) *)
  apply (rule hoare_complete)
  unfolding hoare_valid_def
  by auto

lemmas fwd_Assign' = weaken_post[OF fwd_Assign]

text {* Redo the proofs for @{text "MAX"} and @{text "MUL"} from the previous
  exercise sheet, this time using your forward assignment rule.
*}
definition MAX :: com where
  "MAX \<equiv>
  IF (Less (V ''a'') (V ''b'')) THEN
    ''c''::=V ''b''
  ELSE
    ''c''::=V ''a''"

lemma "\<turnstile> {\<lambda>s. True} MAX {\<lambda>s. s ''c'' = max (s ''a'') (s ''b'')}"
  unfolding MAX_def
  apply (rule hoare.If)
  apply (rule fwd_Assign')
(*  apply (simp) *)
  apply (auto)
  apply (rule fwd_Assign')
(*  apply (simp) *)
  apply (auto)
done

definition MUL :: com where
  "MUL \<equiv>
  ''z''::=N 0;;
  ''c''::=N 0;;
  WHILE (Less (V ''c'') (V ''y'')) DO (
    ''z''::=Plus (V ''z'') (V ''x'');;
    ''c''::=Plus (V ''c'') (N 1))"

lemma "\<turnstile> {\<lambda>s. 0 \<le> s ''y''} MUL {\<lambda>s. s ''z'' = s ''x'' * s ''y''}"
  unfolding MUL_def
  apply (rule hoare.Seq)
  apply (rule hoare.Seq)
  apply (rule fwd_Assign)
  apply (auto)
  apply (rule fwd_Assign)
  apply (auto)
  apply (rule strengthen_pre)
  prefer 2
  apply (rule While'[where P="\<lambda>s. s ''z'' = s ''x'' * s ''c''\<and> s ''c'' \<le> s ''y''"])
  apply (rule hoare.Seq)
  apply (rule fwd_Assign)
  apply (rule fwd_Assign')
  apply (auto simp: algebra_simps)
done

text {*
  \Exercise{Using the VCG}

  For each of the three programs given here, you must prove partial
  correctness. You should first write an annotated program, and then use
  the verification condition generator from @{text "VCG.thy"}.
*}

text{* \paragraph{Preliminaries.}  *}

text {* Some abbreviations, freeing us from having to write double quotes
for concrete variable names: *}

abbreviation "aa \<equiv> ''a''"  abbreviation "bb \<equiv> ''b''" abbreviation "cc \<equiv> ''c''"
abbreviation "dd \<equiv> ''d''"  abbreviation "ee \<equiv> ''e''" abbreviation "ff \<equiv> ''f''"
abbreviation "pp \<equiv> ''p''"  abbreviation "qq \<equiv> ''q''" abbreviation "rr \<equiv> ''r''"

text {* Some useful simplification rules: *}
declare algebra_simps[simp]  declare power2_eq_square[simp]

text {* A convenient loop construct: *}

abbreviation For :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> com \<Rightarrow> com"
  ("(FOR _/ FROM _/ TO _/ DO _)"  [0, 0, 0, 61] 61) where
  "FOR v FROM a1 TO a2 DO c \<equiv>
     v ::= a1 ;;  WHILE (Less (V v) a2) DO (c ;; v ::= Plus (V v) (N 1))"

abbreviation Afor :: "assn \<Rightarrow> vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> acom \<Rightarrow> acom"
  ("({_}/ FOR _/ FROM _/ TO _/ DO _)"  [0, 0, 0, 0, 61] 61) where
  "{b} FOR v FROM a1 TO a2 DO c \<equiv>
     v ::= a1 ;;  {b} WHILE (Less (V v) a2) DO (c ;; v ::= Plus (V v) (N 1))"

text {* \paragraph{Multiplication.} Consider the following program
@{text "MULT"} for performing multiplication and the following assertions
@{text "P_MULT"} and @{text "Q_MULT"}: *}

definition MULT :: com where  "MULT \<equiv>
  cc ::= N 0 ;;
  FOR dd FROM (N 0) TO (V aa) DO
    cc ::= Plus (V cc) (V bb)"

definition P_MULT :: "int \<Rightarrow> int \<Rightarrow> assn" where
"P_MULT i j \<equiv> \<lambda>s. s aa = i \<and> s bb = j \<and> 0 \<le> i"

definition Q_MULT :: "int \<Rightarrow> int \<Rightarrow> assn" where
"Q_MULT i j \<equiv> \<lambda>s. s cc = i * j \<and> s aa = i \<and> s bb = j"

text {* Define an annotated program
@{text "AMULT i j"}, so that when the annotations are stripped away, it
yields @{text "MULT"}. (The parameters @{text "i"} and @{text "j"}
will appear only in the loop annotations.) *}

text{* Hint: The program @{text "AMULT i j"} will be essentially @{text "MULT"}
with an invariant annotation @{text "iMULT i j"} at the FOR loop, which you have to
define: *}
definition iMULT :: "int \<Rightarrow> int \<Rightarrow> assn" where
  "iMULT i j \<equiv> \<lambda>s. s aa = i \<and> s bb = j \<and> s cc = s dd * j \<and> s dd \<le> i"

definition AMULT :: "int \<Rightarrow> int \<Rightarrow> acom" where
  "AMULT i j \<equiv>
  (cc ::= N 0) ;;
  {iMULT i j} FOR dd FROM (N 0) TO (V aa) DO
    cc ::= Plus (V cc) (V bb)"

lemmas MULT_defs = MULT_def P_MULT_def Q_MULT_def iMULT_def AMULT_def

lemma strip_AMULT: "strip (AMULT i j) = MULT"
  unfolding MULT_defs
  by simp

text {* Once you have the correct loop annotations, then the partial
correctness proof can be done in two steps, with the help of lemma
@{text "vc_sound'"}. *}

lemma MULT_correct: "\<turnstile> {P_MULT i j} MULT {Q_MULT i j}"
  unfolding strip_AMULT[of i j, symmetric]
  apply(rule vc_sound')
  unfolding MULT_defs
  by auto
(* Si obtenemos algo que creemos que es incorrecto tenemos que revisar las premisas para ver porque
   probablemente hay algo contradictorio ahi. Es buena idea intentar generalizar la postcondicion *)

text {* \paragraph{Division.} Define an annotated version of this
division program, which yields the quotient and remainder of @{text "aa/bb"}
in variables @{text "''q''"} and @{text "''r''"},
respectively. *}

definition DIV :: com where "DIV \<equiv>
  qq ::= N 0 ;;
  rr ::= N 0 ;;
  FOR cc FROM (N 0) TO (V aa) DO (
    rr ::= Plus (V rr) (N 1) ;;
    IF Less (V rr) (V bb) THEN
      Com.SKIP
    ELSE (
      rr ::= N 0 ;;
      qq ::= Plus (V qq) (N 1))
  )"

definition P_DIV :: "int \<Rightarrow> int \<Rightarrow> assn" where
"P_DIV i j \<equiv> \<lambda>s. s aa = i \<and> s bb = j \<and> 0 \<le> i \<and> 0 < j"
definition Q_DIV :: "int \<Rightarrow> int \<Rightarrow> assn" where
"Q_DIV i j \<equiv>
  \<lambda> s. i = s qq * j + s rr \<and> 0 \<le> s rr \<and> s rr < j \<and> s aa = i \<and> s bb = j"

definition iDIV :: "int \<Rightarrow> int \<Rightarrow> assn" where
"iDIV i j \<equiv>
  \<lambda> s. s aa = i \<and> s bb = j \<and> s rr \<ge> 0 \<and> s rr < j \<and> s cc = s qq * j + s rr \<and> s cc \<le> i"

text{* *}
definition ADIV :: "int \<Rightarrow> int \<Rightarrow> acom" where "ADIV i j \<equiv>
  qq ::= N 0 ;;
  rr ::= N 0 ;;
  {iDIV i j} FOR cc FROM (N 0) TO (V aa) DO (
    rr ::= Plus (V rr) (N 1) ;;
    IF Less (V rr) (V bb) THEN
      SKIP
    ELSE (
      rr ::= N 0 ;;
      qq ::= Plus (V qq) (N 1)
    )
  )"

lemma strip_ADIV: "strip (ADIV i j) = DIV"
  unfolding DIV_def
  unfolding ADIV_def
  unfolding P_DIV_def
  unfolding Q_DIV_def
  unfolding iDIV_def
  by auto

lemma DIV_correct: "\<turnstile> {P_DIV i j} DIV {Q_DIV i j}"
  unfolding strip_ADIV[of i j, symmetric]
  apply(rule vc_sound')
  unfolding DIV_def
  unfolding ADIV_def
  unfolding P_DIV_def
  unfolding Q_DIV_def
  unfolding iDIV_def
  by (auto)

text {* \paragraph{Square roots.} Define an annotated version of this
square root program, which yields the square root of input @{text "aa"}
(rounded down to the next integer) in output @{text "bb"}.
*}

definition SQR :: com where "SQR \<equiv>
  bb ::= N 0 ;;
  cc ::= N 1 ;;
  WHILE (Not (Less (V aa) (V cc))) DO (
    bb ::= Plus (V bb) (N 1);;
    cc ::= Plus (V cc) (Plus (V bb) (Plus (V bb) (N 1)))
  )"

definition P_SQR :: "int \<Rightarrow> assn" where
"P_SQR i \<equiv> \<lambda>s. s aa = i \<and> 0 \<le> i"
definition Q_SQR :: "int \<Rightarrow> assn" where
"Q_SQR i \<equiv> \<lambda>s. s aa = i \<and> (s bb)^2 \<le> i \<and> i < (s bb + 1)^2"

definition iSQR :: "int \<Rightarrow> assn" where
  "iSQR i \<equiv> \<lambda>s. s aa = i \<and> (s bb)^2 \<le> i \<and> (s bb + 1)^2 = s cc"

definition ASQR :: "int \<Rightarrow> acom" where "ASQR i \<equiv>
  bb ::= N 0 ;;
  cc ::= N 1 ;;
  {iSQR i} WHILE (Not (Less (V aa) (V cc))) DO (
    bb ::= Plus (V bb) (N 1);;
    cc ::= Plus (V cc) (Plus (V bb) (Plus (V bb) (N 1)))
  )"

lemma strip_ASQR: "strip (ASQR i) = SQR"
  unfolding SQR_def P_SQR_def Q_SQR_def iSQR_def ASQR_def
  by auto

lemma SQR_correct: "\<turnstile> {P_SQR i} SQR {Q_SQR i}"
  unfolding strip_ASQR[of i, symmetric]
  apply(rule vc_sound')
  unfolding SQR_def P_SQR_def Q_SQR_def iSQR_def ASQR_def
  by (auto)

end


(*  Title:      HOL/Matrix_LP/ComputeFloat.thy
    Author:     Steven Obua
*)

section \<open>Floating Point Representation of the Reals\<close>

theory ComputeFloat
imports Complex_Main "HOL-Library.Lattice_Algebras"
begin

ML_file \<open>~~/src/Tools/float.ML\<close>

(*FIXME surely floor should be used? This file is full of redundant material.*)

definition int_of_real :: "real \<Rightarrow> int"
  where "int_of_real x = (SOME y. real_of_int y = x)"

definition real_is_int :: "real \<Rightarrow> bool"
  where "real_is_int x = (\<exists>(u::int). x = real_of_int u)"

lemma real_is_int_def2: "real_is_int x = (x = real_of_int (int_of_real x))"
  by (auto simp add: real_is_int_def int_of_real_def)

lemma real_is_int_real[simp]: "real_is_int (real_of_int (x::int))"
by (auto simp add: real_is_int_def int_of_real_def)

lemma int_of_real_real[simp]: "int_of_real (real_of_int x) = x"
by (simp add: int_of_real_def)

lemma real_int_of_real[simp]: "real_is_int x \<Longrightarrow> real_of_int (int_of_real x) = x"
by (auto simp add: int_of_real_def real_is_int_def)

lemma real_is_int_add_int_of_real: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> (int_of_real (a+b)) = (int_of_real a) + (int_of_real b)"
by (auto simp add: int_of_real_def real_is_int_def)

lemma real_is_int_add[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a+b)"
apply (subst real_is_int_def2)
apply (simp add: real_is_int_add_int_of_real real_int_of_real)
done

lemma int_of_real_sub: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> (int_of_real (a-b)) = (int_of_real a) - (int_of_real b)"
by (auto simp add: int_of_real_def real_is_int_def)

lemma real_is_int_sub[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a-b)"
apply (subst real_is_int_def2)
apply (simp add: int_of_real_sub real_int_of_real)
done

lemma real_is_int_rep: "real_is_int x \<Longrightarrow> \<exists>!(a::int). real_of_int a = x"
by (auto simp add: real_is_int_def)

lemma int_of_real_mult:
  assumes "real_is_int a" "real_is_int b"
  shows "(int_of_real (a*b)) = (int_of_real a) * (int_of_real b)"
  using assms
  by (auto simp add: real_is_int_def of_int_mult[symmetric]
           simp del: of_int_mult)

lemma real_is_int_mult[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a*b)"
apply (subst real_is_int_def2)
apply (simp add: int_of_real_mult)
done

lemma real_is_int_0[simp]: "real_is_int (0::real)"
by (simp add: real_is_int_def int_of_real_def)

lemma real_is_int_1[simp]: "real_is_int (1::real)"
proof -
  have "real_is_int (1::real) = real_is_int(real_of_int (1::int))" by auto
  also have "\<dots> = True" by (simp only: real_is_int_real)
  ultimately show ?thesis by auto
qed

lemma real_is_int_n1: "real_is_int (-1::real)"
proof -
  have "real_is_int (-1::real) = real_is_int(real_of_int (-1::int))" by auto
  also have "\<dots> = True" by (simp only: real_is_int_real)
  ultimately show ?thesis by auto
qed

lemma real_is_int_numeral[simp]: "real_is_int (numeral x)"
  by (auto simp: real_is_int_def intro!: exI[of _ "numeral x"])

lemma real_is_int_neg_numeral[simp]: "real_is_int (- numeral x)"
  by (auto simp: real_is_int_def intro!: exI[of _ "- numeral x"])

lemma int_of_real_0[simp]: "int_of_real (0::real) = (0::int)"
by (simp add: int_of_real_def)

lemma int_of_real_1[simp]: "int_of_real (1::real) = (1::int)"
proof -
  have 1: "(1::real) = real_of_int (1::int)" by auto
  show ?thesis by (simp only: 1 int_of_real_real)
qed

lemma int_of_real_numeral[simp]: "int_of_real (numeral b) = numeral b"
  unfolding int_of_real_def by simp

lemma int_of_real_neg_numeral[simp]: "int_of_real (- numeral b) = - numeral b"
  unfolding int_of_real_def
  by (metis int_of_real_def int_of_real_real of_int_minus of_int_of_nat_eq of_nat_numeral)

lemma int_div_zdiv: "int (a div b) = (int a) div (int b)"
by (rule zdiv_int)

lemma int_mod_zmod: "int (a mod b) = (int a) mod (int b)"
by (rule zmod_int)

lemma abs_div_2_less: "a \<noteq> 0 \<Longrightarrow> a \<noteq> -1 \<Longrightarrow> \<bar>(a::int) div 2\<bar> < \<bar>a\<bar>"
by arith

lemma norm_0_1: "(1::_::numeral) = Numeral1"
  by auto

lemma add_left_zero: "0 + a = (a::'a::comm_monoid_add)"
  by simp

lemma add_right_zero: "a + 0 = (a::'a::comm_monoid_add)"
  by simp

lemma mult_left_one: "1 * a = (a::'a::semiring_1)"
  by simp

lemma mult_right_one: "a * 1 = (a::'a::semiring_1)"
  by simp

lemma int_pow_0: "(a::int)^0 = 1"
  by simp

lemma int_pow_1: "(a::int)^(Numeral1) = a"
  by simp

lemma one_eq_Numeral1_nring: "(1::'a::numeral) = Numeral1"
  by simp

lemma one_eq_Numeral1_nat: "(1::nat) = Numeral1"
  by simp

lemma zpower_Pls: "(z::int)^0 = Numeral1"
  by simp

lemma fst_cong: "a=a' \<Longrightarrow> fst (a,b) = fst (a',b)"
  by simp

lemma snd_cong: "b=b' \<Longrightarrow> snd (a,b) = snd (a,b')"
  by simp

lemma lift_bool: "x \<Longrightarrow> x=True"
  by simp

lemma nlift_bool: "~x \<Longrightarrow> x=False"
  by simp

lemma not_false_eq_true: "(~ False) = True" by simp

lemma not_true_eq_false: "(~ True) = False" by simp

lemmas powerarith = nat_numeral power_numeral_even
  power_numeral_odd zpower_Pls

definition float :: "(int \<times> int) \<Rightarrow> real" where
  "float = (\<lambda>(a, b). real_of_int a * 2 powr real_of_int b)"

lemma float_add_l0: "float (0, e) + x = x"
  by (simp add: float_def)

lemma float_add_r0: "x + float (0, e) = x"
  by (simp add: float_def)

lemma float_add:
  "float (a1, e1) + float (a2, e2) =
  (if e1<=e2 then float (a1+a2*2^(nat(e2-e1)), e1) else float (a1*2^(nat (e1-e2))+a2, e2))"
  by (simp add: float_def algebra_simps powr_realpow[symmetric] powr_diff)

lemma float_mult_l0: "float (0, e) * x = float (0, 0)"
  by (simp add: float_def)

lemma float_mult_r0: "x * float (0, e) = float (0, 0)"
  by (simp add: float_def)

lemma float_mult:
  "float (a1, e1) * float (a2, e2) = (float (a1 * a2, e1 + e2))"
  by (simp add: float_def powr_add)

lemma float_minus:
  "- (float (a,b)) = float (-a, b)"
  by (simp add: float_def)

lemma zero_le_float:
  "(0 <= float (a,b)) = (0 <= a)"
  by (simp add: float_def zero_le_mult_iff)

lemma float_le_zero:
  "(float (a,b) <= 0) = (a <= 0)"
  by (simp add: float_def mult_le_0_iff)

lemma float_abs:
  "\<bar>float (a,b)\<bar> = (if 0 <= a then (float (a,b)) else (float (-a,b)))"
  by (simp add: float_def abs_if mult_less_0_iff not_less)

lemma float_zero:
  "float (0, b) = 0"
  by (simp add: float_def)

lemma float_pprt:
  "pprt (float (a, b)) = (if 0 <= a then (float (a,b)) else (float (0, b)))"
  by (auto simp add: zero_le_float float_le_zero float_zero)

lemma float_nprt:
  "nprt (float (a, b)) = (if 0 <= a then (float (0,b)) else (float (a, b)))"
  by (auto simp add: zero_le_float float_le_zero float_zero)

definition lbound :: "real \<Rightarrow> real"
  where "lbound x = min 0 x"

definition ubound :: "real \<Rightarrow> real"
  where "ubound x = max 0 x"

lemma lbound: "lbound x \<le> x"
  by (simp add: lbound_def)

lemma ubound: "x \<le> ubound x"
  by (simp add: ubound_def)

lemma pprt_lbound: "pprt (lbound x) = float (0, 0)"
  by (auto simp: float_def lbound_def)

lemma nprt_ubound: "nprt (ubound x) = float (0, 0)"
  by (auto simp: float_def ubound_def)

lemmas floatarith[simplified norm_0_1] = float_add float_add_l0 float_add_r0 float_mult float_mult_l0 float_mult_r0
          float_minus float_abs zero_le_float float_pprt float_nprt pprt_lbound nprt_ubound

(* for use with the compute oracle *)
lemmas arith = arith_simps rel_simps diff_nat_numeral nat_0
  nat_neg_numeral powerarith floatarith not_false_eq_true not_true_eq_false

ML_file \<open>float_arith.ML\<close>

end


(*  Title:      ZF/AC/AC_Equiv.thy
    Author:     Krzysztof Grabczewski

Axioms AC1 -- AC19 come from "Equivalents of the Axiom of Choice, II"
by H. Rubin and J.E. Rubin, 1985.

Axiom AC0 comes from "Axiomatic Set Theory" by P. Suppes, 1972.

Some Isabelle proofs of equivalences of these axioms are formalizations of
proofs presented by the Rubins.  The others are based on the Rubins' proofs,
but slightly changed.
*)

theory AC_Equiv
imports Main
begin (*obviously not Main_ZFC*)

(* Well Ordering Theorems *)

definition
    "WO1 == \<forall>A. \<exists>R. well_ord(A,R)"

definition
    "WO2 == \<forall>A. \<exists>a. Ord(a) & A\<approx>a"

definition
    "WO3 == \<forall>A. \<exists>a. Ord(a) & (\<exists>b. b \<subseteq> a & A\<approx>b)"

definition
    "WO4(m) == \<forall>A. \<exists>a f. Ord(a) & domain(f)=a &
                         (\<Union>b<a. f`b) = A & (\<forall>b<a. f`b \<lesssim> m)"

definition
    "WO5 == \<exists>m \<in> nat. 1\<le>m & WO4(m)"

definition
    "WO6 == \<forall>A. \<exists>m \<in> nat. 1\<le>m & (\<exists>a f. Ord(a) & domain(f)=a
                               & (\<Union>b<a. f`b) = A & (\<forall>b<a. f`b \<lesssim> m))"

definition
    "WO7 == \<forall>A. Finite(A) \<longleftrightarrow> (\<forall>R. well_ord(A,R) \<longrightarrow> well_ord(A,converse(R)))"

definition
    "WO8 == \<forall>A. (\<exists>f. f \<in> (\<Pi> X \<in> A. X)) \<longrightarrow> (\<exists>R. well_ord(A,R))"

definition
(* Auxiliary concepts needed below *)
  pairwise_disjoint :: "i => o"  where
    "pairwise_disjoint(A) == \<forall>A1 \<in> A. \<forall>A2 \<in> A. A1 \<inter> A2 \<noteq> 0 \<longrightarrow> A1=A2"

definition
  sets_of_size_between :: "[i, i, i] => o"  where
    "sets_of_size_between(A,m,n) == \<forall>B \<in> A. m \<lesssim> B & B \<lesssim> n"

(* Axioms of Choice *)
definition
    "AC0 == \<forall>A. \<exists>f. f \<in> (\<Pi> X \<in> Pow(A)-{0}. X)"

definition
    "AC1 == \<forall>A. 0\<notin>A \<longrightarrow> (\<exists>f. f \<in> (\<Pi> X \<in> A. X))"

definition
    "AC2 == \<forall>A. 0\<notin>A & pairwise_disjoint(A)
                   \<longrightarrow> (\<exists>C. \<forall>B \<in> A. \<exists>y. B \<inter> C = {y})"
definition
    "AC3 == \<forall>A B. \<forall>f \<in> A->B. \<exists>g. g \<in> (\<Pi> x \<in> {a \<in> A. f`a\<noteq>0}. f`x)"

definition
    "AC4 == \<forall>R A B. (R \<subseteq> A*B \<longrightarrow> (\<exists>f. f \<in> (\<Pi> x \<in> domain(R). R``{x})))"

definition
    "AC5 == \<forall>A B. \<forall>f \<in> A->B. \<exists>g \<in> range(f)->A. \<forall>x \<in> domain(g). f`(g`x) = x"

definition
    "AC6 == \<forall>A. 0\<notin>A \<longrightarrow> (\<Pi> B \<in> A. B)\<noteq>0"

definition
    "AC7 == \<forall>A. 0\<notin>A & (\<forall>B1 \<in> A. \<forall>B2 \<in> A. B1\<approx>B2) \<longrightarrow> (\<Pi> B \<in> A. B) \<noteq> 0"

definition
    "AC8 == \<forall>A. (\<forall>B \<in> A. \<exists>B1 B2. B=<B1,B2> & B1\<approx>B2)
                   \<longrightarrow> (\<exists>f. \<forall>B \<in> A. f`B \<in> bij(fst(B),snd(B)))"

definition
    "AC9 == \<forall>A. (\<forall>B1 \<in> A. \<forall>B2 \<in> A. B1\<approx>B2) \<longrightarrow>
                   (\<exists>f. \<forall>B1 \<in> A. \<forall>B2 \<in> A. f`<B1,B2> \<in> bij(B1,B2))"

definition
    "AC10(n) ==  \<forall>A. (\<forall>B \<in> A. ~Finite(B)) \<longrightarrow>
                   (\<exists>f. \<forall>B \<in> A. (pairwise_disjoint(f`B) &
                   sets_of_size_between(f`B, 2, succ(n)) & \<Union>(f`B)=B))"

definition
    "AC11 == \<exists>n \<in> nat. 1\<le>n & AC10(n)"

definition
    "AC12 == \<forall>A. (\<forall>B \<in> A. ~Finite(B)) \<longrightarrow>
                 (\<exists>n \<in> nat. 1\<le>n & (\<exists>f. \<forall>B \<in> A. (pairwise_disjoint(f`B) &
                      sets_of_size_between(f`B, 2, succ(n)) & \<Union>(f`B)=B)))"

definition
    "AC13(m) == \<forall>A. 0\<notin>A \<longrightarrow> (\<exists>f. \<forall>B \<in> A. f`B\<noteq>0 & f`B \<subseteq> B & f`B \<lesssim> m)"

definition
    "AC14 == \<exists>m \<in> nat. 1\<le>m & AC13(m)"

definition
    "AC15 == \<forall>A. 0\<notin>A \<longrightarrow>
                 (\<exists>m \<in> nat. 1\<le>m & (\<exists>f. \<forall>B \<in> A. f`B\<noteq>0 & f`B \<subseteq> B & f`B \<lesssim> m))"

definition
    "AC16(n, k)  ==
       \<forall>A. ~Finite(A) \<longrightarrow>
           (\<exists>T. T \<subseteq> {X \<in> Pow(A). X\<approx>succ(n)} &
           (\<forall>X \<in> {X \<in> Pow(A). X\<approx>succ(k)}. \<exists>! Y. Y \<in> T & X \<subseteq> Y))"

definition
    "AC17 == \<forall>A. \<forall>g \<in> (Pow(A)-{0} -> A) -> Pow(A)-{0}.
                   \<exists>f \<in> Pow(A)-{0} -> A. f`(g`f) \<in> g`f"

locale AC18 =
  assumes AC18: "A\<noteq>0 & (\<forall>a \<in> A. B(a) \<noteq> 0) \<longrightarrow>
    ((\<Inter>a \<in> A. \<Union>b \<in> B(a). X(a,b)) =
      (\<Union>f \<in> \<Pi> a \<in> A. B(a). \<Inter>a \<in> A. X(a, f`a)))"
  --"AC18 cannot be expressed within the object-logic"

definition
    "AC19 == \<forall>A. A\<noteq>0 & 0\<notin>A \<longrightarrow> ((\<Inter>a \<in> A. \<Union>b \<in> a. b) =
                   (\<Union>f \<in> (\<Pi> B \<in> A. B). \<Inter>a \<in> A. f`a))"

(* ********************************************************************** *)
(*                    Theorems concerning ordinals                        *)
(* ********************************************************************** *)

(* lemma for ordertype_Int *)
lemma rvimage_id: "rvimage(A,id(A),r) = r \<inter> A*A"
apply (unfold rvimage_def)
apply (rule equalityI, safe)
apply (drule_tac P = "%a. <id (A) `xb,a>:r" in id_conv [THEN subst],
       assumption)
apply (drule_tac P = "%a. <a,ya>:r" in id_conv [THEN subst], (assumption+))
apply (fast intro: id_conv [THEN ssubst])
done

(* used only in Hartog.ML *)
lemma ordertype_Int:
     "well_ord(A,r) ==> ordertype(A, r \<inter> A*A) = ordertype(A,r)"
apply (rule_tac P = "%a. ordertype (A,a) =ordertype (A,r) " in rvimage_id [THEN subst])
apply (erule id_bij [THEN bij_ordertype_vimage])
done

lemma lam_sing_bij: "(\<lambda>x \<in> A. {x}) \<in> bij(A, {{x}. x \<in> A})"
apply (rule_tac d = "%z. THE x. z={x}" in lam_bijective)
apply (auto simp add: the_equality)
done

lemma inj_strengthen_type:
     "[| f \<in> inj(A, B);  !!a. a \<in> A ==> f`a \<in> C |] ==> f \<in> inj(A,C)"
by (unfold inj_def, blast intro: Pi_type)

(* ********************************************************************** *)
(* Another elimination rule for \<exists>!                                       *)
(* ********************************************************************** *)

lemma ex1_two_eq: "[| \<exists>! x. P(x); P(x); P(y) |] ==> x=y"
by blast

(* ********************************************************************** *)
(* Lemmas used in the proofs like WO? ==> AC?                             *)
(* ********************************************************************** *)

lemma first_in_B:
     "[| well_ord(\<Union>(A),r); 0 \<notin> A; B \<in> A |] ==> (THE b. first(b,B,r)) \<in> B"
by (blast dest!: well_ord_imp_ex1_first
                    [THEN theI, THEN first_def [THEN def_imp_iff, THEN iffD1]])

lemma ex_choice_fun: "[| well_ord(\<Union>(A), R); 0 \<notin> A |] ==> \<exists>f. f \<in> (\<Pi> X \<in> A. X)"
by (fast elim!: first_in_B intro!: lam_type)

lemma ex_choice_fun_Pow: "well_ord(A, R) ==> \<exists>f. f \<in> (\<Pi> X \<in> Pow(A)-{0}. X)"
by (fast elim!: well_ord_subset [THEN ex_choice_fun])

(* ********************************************************************** *)
(* Lemmas needed to state when a finite relation is a function.           *)
(*     The criteria are cardinalities of the relation and its domain.     *)
(*     Used in WO6WO1.ML                                                  *)
(* ********************************************************************** *)

(*Using AC we could trivially prove, for all u, domain(u) \<lesssim> u*)
lemma lepoll_m_imp_domain_lepoll_m:
     "[| m \<in> nat; u \<lesssim> m |] ==> domain(u) \<lesssim> m"
apply (unfold lepoll_def)
apply (erule exE)
apply (rule_tac x = "\<lambda>x \<in> domain(u). LEAST i. \<exists>y. <x,y> \<in> u & f`<x,y> = i"
       in exI)
apply (rule_tac d = "%y. fst (converse(f) ` y) " in lam_injective)
apply (fast intro: LeastI2 nat_into_Ord [THEN Ord_in_Ord]
                           inj_is_fun [THEN apply_type])
apply (erule domainE)
apply (frule inj_is_fun [THEN apply_type], assumption)
apply (rule LeastI2)
apply (auto elim!: nat_into_Ord [THEN Ord_in_Ord])
done

lemma rel_domain_ex1:
    "[| succ(m) \<lesssim> domain(r); r \<lesssim> succ(m); m \<in> nat |] ==> function(r)"
apply (unfold function_def, safe)
apply (rule ccontr)
apply (fast elim!: lepoll_trans [THEN succ_lepoll_natE]
                   lepoll_m_imp_domain_lepoll_m [OF _ Diff_sing_lepoll]
            elim: domain_Diff_eq [OF _ not_sym, THEN subst])
done

lemma rel_is_fun:
     "[| succ(m) \<lesssim> domain(r);  r \<lesssim> succ(m);  m \<in> nat;
         r \<subseteq> A*B; A=domain(r) |] ==> r \<in> A->B"
by (simp add: Pi_iff rel_domain_ex1)

end