theory Term
  imports Main Unification
begin

section \<open>Assignment 5\<close>

subsection \<open>(a)\<close>

datatype msg =
  is_Variable : Variable string
| Constant string
| Hash msg
| Pair msg msg
| SymEncrypt msg msg
| PubKeyEncrypt msg msg
| Sig msg msg

subsection \<open>(b)\<close>

datatype symbol =
  Constant_Symbol string
| Hash_Symbol
| Pair_Symbol
| SymEncrypt_Symbol
| PubKeyEncrypt_Symbol
| Sig_Symbol

fun arity :: "symbol \<Rightarrow> nat" where
  "arity (Constant_Symbol _) = 0"
| "arity Hash_Symbol = 1"
| "arity Pair_Symbol = 2"
| "arity SymEncrypt_Symbol = 2"
| "arity PubKeyEncrypt_Symbol = 2"
| "arity Sig_Symbol = 2"

subsection \<open>(c)\<close>

fun embed :: "msg \<Rightarrow> (symbol, string) term" where
  "embed (Variable x) = Var x"
| "embed (Constant c) = Fun (Constant_Symbol c) []"
| "embed (Hash m) = Fun Hash_Symbol [embed m]"
| "embed (Pair m1 m2) = Fun Pair_Symbol [embed m1, embed m2]"
| "embed (SymEncrypt m1 m2) = Fun SymEncrypt_Symbol [embed m1, embed m2]"
| "embed (PubKeyEncrypt m1 m2) = Fun PubKeyEncrypt_Symbol [embed m1, embed m2]"
| "embed (Sig m1 m2) = Fun Sig_Symbol [embed m1, embed m2]"

fun msg_of_term :: "(symbol, string) term \<Rightarrow> msg" where
  "msg_of_term (Var x) = Variable x"
| "msg_of_term (Fun (Constant_Symbol c) []) = Constant c"
| "msg_of_term (Fun Hash_Symbol [m]) = Hash (msg_of_term m)"
| "msg_of_term (Fun Pair_Symbol [m1, m2]) = Pair (msg_of_term m1) (msg_of_term m2)"
| "msg_of_term (Fun SymEncrypt_Symbol [k, m]) = SymEncrypt (msg_of_term k) (msg_of_term m)"
| "msg_of_term (Fun PubKeyEncrypt_Symbol [k, m]) = PubKeyEncrypt (msg_of_term k) (msg_of_term m)"
| "msg_of_term (Fun Sig_Symbol [k, m]) = Sig (msg_of_term k) (msg_of_term m)"
| "msg_of_term _ = undefined"

lemma wf_term_embed [simp]: "wf_term arity (embed m)"
  by (induction m) simp_all

lemma msg_of_term_embed [simp]: "msg_of_term (embed m) = m"
  by (induction m) simp_all

lemma arity_upper_bound: "arity s = Suc (Suc (Suc x)) \<longleftrightarrow> False"
  by (cases s) simp_all

lemma embed_msg_of_term [simp]: "wf_term arity t \<Longrightarrow> embed (msg_of_term t) = t"
  apply(induction t rule: msg_of_term.induct)
                      apply(simp_all add: arity_upper_bound)
  by(metis arity_upper_bound)

lemma wf_subst_embed [simp]: "wf_subst arity (embed \<circ> \<sigma>)"
  by (simp add: wf_subst_def)

lemma msg_of_term_inject:
"\<lbrakk> wf_term arity t1; wf_term arity t2 \<rbrakk>
\<Longrightarrow> msg_of_term t1 = msg_of_term t2 \<longleftrightarrow> t1 = t2"
  using embed_msg_of_term by fastforce

subsection \<open>(d)\<close>

type_synonym msg_equation = "msg \<times> msg"
type_synonym msg_equations = "msg_equation list"
type_synonym symbol_subst = "string \<Rightarrow> (symbol, string) term"
type_synonym msg_subst = "string \<Rightarrow> msg"

definition msg_fv :: "msg \<Rightarrow> string set" where
  "msg_fv m = fv (embed m)"

definition msg_sapply :: "msg_subst \<Rightarrow> msg \<Rightarrow> msg" (infixr "\<cdot>m" 67) where
  "msg_sapply \<sigma> m = msg_of_term ((embed \<circ> \<sigma>) \<cdot> (embed m))"

definition msg_scomp :: "msg_subst \<Rightarrow> msg_subst \<Rightarrow> msg_subst" (infixl "\<circ>m" 55) where
  "msg_scomp \<sigma> \<tau> = msg_of_term \<circ> ((embed \<circ> \<sigma>) \<circ>s (embed \<circ> \<tau>))"

definition msg_fv_eq :: "msg_equation \<Rightarrow> string set" where
  "msg_fv_eq eq = (msg_fv (fst eq) \<union> msg_fv (snd eq))"

definition msg_fv_list :: "msg list \<Rightarrow> string set" where
  "msg_fv_list mlist = \<Union>(set (map msg_fv mlist))"

definition msg_fv_eqs :: "msg_equations \<Rightarrow> string set" where
  "msg_fv_eqs eqs = \<Union>(set (map msg_fv_eq eqs))"

lemma fv_sapply: "msg_fv (\<sigma> \<cdot>m t) = fv ((embed \<circ> \<sigma>) \<cdot> (embed t))"
  by (simp add: msg_fv_def msg_sapply_def wf_term_sapply)

definition msg_sdom :: "msg_subst \<Rightarrow> string set" where
  "msg_sdom \<sigma> = sdom (embed \<circ> \<sigma>)"

definition msg_svran :: "msg_subst \<Rightarrow> string set" where
  "msg_svran \<sigma> = svran (embed \<circ> \<sigma>)"

lemma msg_sdom_var [simp]: "msg_sdom Variable = {}"
  by (simp add: msg_sdom_def sdom_def)

lemma msg_svran_var [simp]: "msg_svran Variable = {}"
  by (simp add: msg_svran_def svran_def sdom_def)

lemma msg_not_var: "t \<noteq> Variable x \<Longrightarrow> embed t \<noteq> Var x"
  using msg_of_term_embed[of t] by force

lemma msg_sdom_single_non_trivial [simp]: "t \<noteq> Variable x \<Longrightarrow> msg_sdom (Variable(x:=t)) = {x}"
  by (simp add: msg_sdom_def sdom_def msg_not_var)

lemma msg_svran_single_non_trivial [simp]: "t \<noteq> Variable x \<Longrightarrow> msg_svran (Variable(x:=t)) = msg_fv t"
  by (auto simp add: msg_svran_def svran_def sdom_def msg_not_var msg_fv_def)

lemma msg_sdomI: "\<sigma> x \<noteq> Variable x \<Longrightarrow> x \<in> msg_sdom \<sigma>"
  by (simp add: msg_sdom_def sdom_def msg_not_var)

lemma msg_fv_sapply_sdom_svran: "msg_fv (\<sigma> \<cdot>m t) \<subseteq> (msg_fv t - msg_sdom \<sigma>) \<union> msg_svran \<sigma>"
  using svapply_svdom_svran msg_fv_def msg_sapply_def fv_sapply
  unfolding msg_sdom_def msg_svran_def
  by (simp) fastforce

lemma msg_sdom_scomp: "msg_sdom (\<sigma> \<circ>m \<tau>) \<subseteq> msg_sdom \<sigma> \<union> msg_sdom \<tau>"
  unfolding msg_sdom_def
  by (auto simp add: sdom_scomp msg_scomp_def sdom_def scomp_sapply)

lemma embed_msg_of_term_comp: "Term.embed \<circ> (msg_of_term \<circ> (Term.embed \<circ> \<sigma>) \<circ>s (Term.embed \<circ> \<tau>)) = (Term.embed \<circ> \<sigma>) \<circ>s (Term.embed \<circ> \<tau>)"
  unfolding comp_def scomp_def
  by (simp add: wf_subst_def wf_term_sapply)

lemma msg_svran_scomp: "msg_svran (\<sigma> \<circ>m \<tau>) \<subseteq> msg_svran \<sigma> \<union> msg_svran \<tau>"
  using svran_scomp[of "(embed \<circ> \<sigma>)" "(embed \<circ> \<tau>)"]
  unfolding msg_svran_def msg_scomp_def
  by (simp add: embed_msg_of_term_comp)

lemma msg_scomp_distrib: "(\<sigma> \<circ>m \<tau>) \<cdot>m t = \<sigma> \<cdot>m (\<tau> \<cdot>m t)"
  using sapply_scomp_distrib[of "(embed \<circ> \<sigma>)" "(embed \<circ> \<tau>)" "(embed t)"]
  unfolding msg_scomp_def msg_sapply_def
  by (simp add: embed_msg_of_term_comp wf_term_sapply)

lemma msg_scomp_assoc:
  "(\<sigma> \<circ>m \<tau>) \<circ>m \<upsilon> = \<sigma> \<circ>m (\<tau> \<circ>m \<upsilon>)"
  using msg_scomp_distrib
  unfolding msg_scomp_def scomp_def msg_sapply_def
  by fastforce

lemma msg_var_sapply [simp]: "Variable \<cdot>m t = t"
  using sapply_Var[of "embed t"]
  unfolding msg_sapply_def
  by (simp add: sapply_cong)

lemma msg_var_sig: "Variable \<cdot>m (\<sigma> \<cdot>m x) = \<sigma> \<cdot>m x"
  using msg_var_sapply by simp

lemma msg_var_scomp [simp]: "\<sigma> \<circ>m Variable = \<sigma>"
  using scomp_Var[of "embed \<circ> \<sigma>"]
  unfolding msg_scomp_def comp_def
  by auto

definition msg_unifies_eq :: "msg_subst \<Rightarrow> msg_equation \<Rightarrow> bool" where
  "msg_unifies_eq \<sigma> eq = unifies_eq (embed \<circ> \<sigma>) (embed (fst eq), embed (snd eq))"

lemma msg_unifies_eq_alt: "msg_unifies_eq \<sigma> eq = (\<sigma> \<cdot>m fst(eq) = \<sigma> \<cdot>m snd(eq))"
  unfolding msg_unifies_eq_def unifies_eq_def
  by (simp add: wf_term_sapply msg_sapply_def msg_of_term_inject)

definition msg_unifies :: "msg_subst \<Rightarrow> msg_equations \<Rightarrow> bool" where
  "msg_unifies \<sigma> eqs = unifies (embed \<circ> \<sigma>) (map (map_prod embed embed) eqs)"

lemma msg_unifies_alt: "msg_unifies \<sigma> eqs = (\<forall>eq \<in> set eqs. msg_unifies_eq \<sigma> eq)"
  by (auto simp add: msg_unifies_def unifies_forall msg_unifies_eq_def)

definition msg_unify :: "msg_equations \<Rightarrow> msg_subst option" where
  "msg_unify eqs = map_option ((\<circ>) msg_of_term) (unify (map (map_prod embed embed) eqs))"

subsection \<open>(e)\<close>

lemma embed_eqs_wf:
    "wf_eqs arity (map (map_prod embed embed) eqs)"
    by(simp add: wf_eqs_def wf_eq_terms_wf)

lemma unify_z_wf: "unify (map (map_prod embed embed) eqs) = Some z \<Longrightarrow> z = embed \<circ> (msg_of_term \<circ> z)"
proof-
  assume "unify (map (map_prod embed embed) eqs) = Some z"
  from this embed_eqs_wf have
    "wf_subst arity z"
    by (simp only: wf_subst_unify)
  then show ?thesis by(simp add: fun_eq_iff wf_subst_def)
qed

lemma msg_unify_unifies:
  "msg_unify eqs = Some \<sigma> \<Longrightarrow> msg_unifies \<sigma> eqs"
proof-
  assume "msg_unify eqs = Some \<sigma>"
  then obtain z where unify:
    "unify (map (map_prod embed embed) eqs) = Some z" and z_def:
        "msg_of_term \<circ> z = \<sigma>"
    using msg_unify_def by auto
  hence
    "z = embed \<circ> (msg_of_term \<circ> z)"
    using unify_z_wf by blast
  moreover from unify have
    "unifies z (map (map_prod embed embed) eqs)"
    by (simp only: unify_soundness_i)
  ultimately show ?thesis using z_def
    by (simp add: msg_unifies_def)
qed

subsection \<open>(f)\<close>

lemma msg_fv_eqs_bind: "fv_eqs (map (map_prod embed embed) eqs) = msg_fv_eqs eqs"
proof-
  have
    "fv_eqs (map (map_prod embed embed) eqs) = \<Union>(fv_eq ` set (map (map_prod embed embed) eqs))"
    by (simp only: fv_eqs_U)
  moreover have
    "... =  \<Union>((\<lambda> eq .(fv (embed (fst eq))) \<union> (fv (embed (snd eq)))) ` set eqs)"
    using fv_eq_def by fastforce
  moreover have
    "... = msg_fv_eqs eqs"
    using msg_fv_def msg_fv_eq_def msg_fv_eqs_def by auto
  ultimately show ?thesis by simp
qed

lemma msg_unify_svran_fv: "msg_unify eqs = Some \<sigma> \<Longrightarrow> msg_svran \<sigma> \<subseteq> msg_fv_eqs eqs"
proof-
  assume "msg_unify eqs = Some \<sigma>"
  then obtain z where unify:
    "unify (map (map_prod embed embed) eqs) = Some z" and z_def:
        "msg_of_term \<circ> z = \<sigma>"
    using msg_unify_def by auto
  hence
    "svran z \<subseteq> fv_eqs (map (map_prod embed embed) eqs)"
    by (simp only: unify_svran_fv)
  moreover from unify z_def unify_z_wf have
    "svran z = svran (embed \<circ> \<sigma>)"
    by auto
  ultimately show ?thesis by (simp add: msg_svran_def msg_fv_eqs_bind)
qed

lemma msg_unify_sdom_fv: "msg_unify eqs = Some \<sigma> \<Longrightarrow> msg_sdom \<sigma> \<subseteq> msg_fv_eqs eqs"
  proof-
  assume "msg_unify eqs = Some \<sigma>"
  then obtain z where unify:
    "unify (map (map_prod embed embed) eqs) = Some z" and z_def:
        "msg_of_term \<circ> z = \<sigma>"
    using msg_unify_def by auto
  hence
    "sdom z \<subseteq> fv_eqs (map (map_prod embed embed) eqs)"
    by (simp only: unify_sdom_fv)
  moreover from unify z_def unify_z_wf have
    "sdom z = sdom (embed \<circ> \<sigma>)"
    by auto
  ultimately show ?thesis by (simp add: msg_sdom_def msg_fv_eqs_bind)
qed

lemma msg_unify_sdom_svran: "msg_unify eqs = Some \<sigma> \<Longrightarrow> msg_sdom \<sigma> \<inter> msg_svran \<sigma> = {}"
proof-
  assume "msg_unify eqs = Some \<sigma>"
  then obtain z where unify:
    "unify (map (map_prod embed embed) eqs) = Some z" and z_def:
        "msg_of_term \<circ> z = \<sigma>"
    using msg_unify_def by auto
  hence
    "sdom z \<inter> svran z = {}"
    by (simp only: unify_sdom_svran)
  moreover from unify z_def unify_z_wf have
    "sdom z = sdom (embed \<circ> \<sigma>)"
    by auto
  ultimately show ?thesis
    by (metis msg_sdom_def msg_svran_def unify unify_z_wf z_def)
qed

end


(*  Title:      HOL/Library/While_Combinator.thy
    Author:     Tobias Nipkow
    Author:     Alexander Krauss
*)

section \<open>A general ``while'' combinator\<close>

theory While_Combinator
imports Main
begin

subsection \<open>Partial version\<close>

definition while_option :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a option" where
"while_option b c s = (if (\<exists>k. \<not> b ((c ^^ k) s))
   then Some ((c ^^ (LEAST k. \<not> b ((c ^^ k) s))) s)
   else None)"

theorem while_option_unfold[code]:
"while_option b c s = (if b s then while_option b c (c s) else Some s)"
proof cases
  assume "b s"
  show ?thesis
  proof (cases "\<exists>k. \<not> b ((c ^^ k) s)")
    case True
    then obtain k where 1: "\<not> b ((c ^^ k) s)" ..
    with \<open>b s\<close> obtain l where "k = Suc l" by (cases k) auto
    with 1 have "\<not> b ((c ^^ l) (c s))" by (auto simp: funpow_swap1)
    then have 2: "\<exists>l. \<not> b ((c ^^ l) (c s))" ..
    from 1
    have "(LEAST k. \<not> b ((c ^^ k) s)) = Suc (LEAST l. \<not> b ((c ^^ Suc l) s))"
      by (rule Least_Suc) (simp add: \<open>b s\<close>)
    also have "... = Suc (LEAST l. \<not> b ((c ^^ l) (c s)))"
      by (simp add: funpow_swap1)
    finally
    show ?thesis
      using True 2 \<open>b s\<close> by (simp add: funpow_swap1 while_option_def)
  next
    case False
    then have "\<not> (\<exists>l. \<not> b ((c ^^ Suc l) s))" by blast
    then have "\<not> (\<exists>l. \<not> b ((c ^^ l) (c s)))"
      by (simp add: funpow_swap1)
    with False  \<open>b s\<close> show ?thesis by (simp add: while_option_def)
  qed
next
  assume [simp]: "\<not> b s"
  have least: "(LEAST k. \<not> b ((c ^^ k) s)) = 0"
    by (rule Least_equality) auto
  moreover
  have "\<exists>k. \<not> b ((c ^^ k) s)" by (rule exI[of _ "0::nat"]) auto
  ultimately show ?thesis unfolding while_option_def by auto
qed

lemma while_option_stop2:
 "while_option b c s = Some t \<Longrightarrow> \<exists>k. t = (c^^k) s \<and> \<not> b t"
apply(simp add: while_option_def split: if_splits)
by (metis (lifting) LeastI_ex)

lemma while_option_stop: "while_option b c s = Some t \<Longrightarrow> \<not> b t"
by(metis while_option_stop2)

theorem while_option_rule:
  assumes step: "!!s. P s ==> b s ==> P (c s)"
    and result: "while_option b c s = Some t"
    and init: "P s"
  shows "P t"
proof -
  define k where "k = (LEAST k. \<not> b ((c ^^ k) s))"
  from assms have t: "t = (c ^^ k) s"
    by (simp add: while_option_def k_def split: if_splits)
  have 1: "\<forall>i<k. b ((c ^^ i) s)"
    by (auto simp: k_def dest: not_less_Least)

  { fix i assume "i \<le> k" then have "P ((c ^^ i) s)"
      by (induct i) (auto simp: init step 1) }
  thus "P t" by (auto simp: t)
qed

lemma funpow_commute:
  "\<lbrakk>\<forall>k' < k. f (c ((c^^k') s)) = c' (f ((c^^k') s))\<rbrakk> \<Longrightarrow> f ((c^^k) s) = (c'^^k) (f s)"
by (induct k arbitrary: s) auto

lemma while_option_commute_invariant:
assumes Invariant: "\<And>s. P s \<Longrightarrow> b s \<Longrightarrow> P (c s)"
assumes TestCommute: "\<And>s. P s \<Longrightarrow> b s = b' (f s)"
assumes BodyCommute: "\<And>s. P s \<Longrightarrow> b s \<Longrightarrow> f (c s) = c' (f s)"
assumes Initial: "P s"
shows "map_option f (while_option b c s) = while_option b' c' (f s)"
unfolding while_option_def
proof (rule trans[OF if_distrib if_cong], safe, unfold option.inject)
  fix k
  assume "\<not> b ((c ^^ k) s)"
  with Initial show "\<exists>k. \<not> b' ((c' ^^ k) (f s))"
  proof (induction k arbitrary: s)
    case 0 thus ?case by (auto simp: TestCommute intro: exI[of _ 0])
  next
    case (Suc k) thus ?case
    proof (cases "b s")
      assume "b s"
      with Suc.IH[of "c s"] Suc.prems show ?thesis
        by (metis BodyCommute Invariant comp_apply funpow.simps(2) funpow_swap1)
    next
      assume "\<not> b s"
      with Suc show ?thesis by (auto simp: TestCommute intro: exI [of _ 0])
    qed
  qed
next
  fix k
  assume "\<not> b' ((c' ^^ k) (f s))"
  with Initial show "\<exists>k. \<not> b ((c ^^ k) s)"
  proof (induction k arbitrary: s)
    case 0 thus ?case by (auto simp: TestCommute intro: exI[of _ 0])
  next
    case (Suc k) thus ?case
    proof (cases "b s")
       assume "b s"
      with Suc.IH[of "c s"] Suc.prems show ?thesis
        by (metis BodyCommute Invariant comp_apply funpow.simps(2) funpow_swap1)
    next
      assume "\<not> b s"
      with Suc show ?thesis by (auto simp: TestCommute intro: exI [of _ 0])
    qed
  qed
next
  fix k
  assume k: "\<not> b' ((c' ^^ k) (f s))"
  have *: "(LEAST k. \<not> b' ((c' ^^ k) (f s))) = (LEAST k. \<not> b ((c ^^ k) s))"
          (is "?k' = ?k")
  proof (cases ?k')
    case 0
    have "\<not> b' ((c' ^^ 0) (f s))"
      unfolding 0[symmetric] by (rule LeastI[of _ k]) (rule k)
    hence "\<not> b s" by (auto simp: TestCommute Initial)
    hence "?k = 0" by (intro Least_equality) auto
    with 0 show ?thesis by auto
  next
    case (Suc k')
    have "\<not> b' ((c' ^^ Suc k') (f s))"
      unfolding Suc[symmetric] by (rule LeastI) (rule k)
    moreover
    { fix k assume "k \<le> k'"
      hence "k < ?k'" unfolding Suc by simp
      hence "b' ((c' ^^ k) (f s))" by (rule iffD1[OF not_not, OF not_less_Least])
    }
    note b' = this
    { fix k assume "k \<le> k'"
      hence "f ((c ^^ k) s) = (c' ^^ k) (f s)"
      and "b ((c ^^ k) s) = b' ((c' ^^ k) (f s))"
      and "P ((c ^^ k) s)"
        by (induct k) (auto simp: b' assms)
      with \<open>k \<le> k'\<close>
      have "b ((c ^^ k) s)"
      and "f ((c ^^ k) s) = (c' ^^ k) (f s)"
      and "P ((c ^^ k) s)"
        by (auto simp: b')
    }
    note b = this(1) and body = this(2) and inv = this(3)
    hence k': "f ((c ^^ k') s) = (c' ^^ k') (f s)" by auto
    ultimately show ?thesis unfolding Suc using b
    proof (intro Least_equality[symmetric], goal_cases)
      case 1
      hence Test: "\<not> b' (f ((c ^^ Suc k') s))"
        by (auto simp: BodyCommute inv b)
      have "P ((c ^^ Suc k') s)" by (auto simp: Invariant inv b)
      with Test show ?case by (auto simp: TestCommute)
    next
      case 2
      thus ?case by (metis not_less_eq_eq)
    qed
  qed
  have "f ((c ^^ ?k) s) = (c' ^^ ?k') (f s)" unfolding *
  proof (rule funpow_commute, clarify)
    fix k assume "k < ?k"
    hence TestTrue: "b ((c ^^ k) s)" by (auto dest: not_less_Least)
    from \<open>k < ?k\<close> have "P ((c ^^ k) s)"
    proof (induct k)
      case 0 thus ?case by (auto simp: assms)
    next
      case (Suc h)
      hence "P ((c ^^ h) s)" by auto
      with Suc show ?case
        by (auto, metis (lifting, no_types) Invariant Suc_lessD not_less_Least)
    qed
    with TestTrue show "f (c ((c ^^ k) s)) = c' (f ((c ^^ k) s))"
      by (metis BodyCommute)
  qed
  thus "\<exists>z. (c ^^ ?k) s = z \<and> f z = (c' ^^ ?k') (f s)" by blast
qed

lemma while_option_commute:
  assumes "\<And>s. b s = b' (f s)" "\<And>s. \<lbrakk>b s\<rbrakk> \<Longrightarrow> f (c s) = c' (f s)"
  shows "map_option f (while_option b c s) = while_option b' c' (f s)"
by(rule while_option_commute_invariant[where P = "\<lambda>_. True"])
  (auto simp add: assms)

subsection \<open>Total version\<close>

definition while :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a"
where "while b c s = the (while_option b c s)"

lemma while_unfold [code]:
  "while b c s = (if b s then while b c (c s) else s)"
unfolding while_def by (subst while_option_unfold) simp

lemma def_while_unfold:
  assumes fdef: "f == while test do"
  shows "f x = (if test x then f(do x) else x)"
unfolding fdef by (fact while_unfold)

text \<open>
 The proof rule for \<^term>\<open>while\<close>, where \<^term>\<open>P\<close> is the invariant.
\<close>

theorem while_rule_lemma:
  assumes invariant: "!!s. P s ==> b s ==> P (c s)"
    and terminate: "!!s. P s ==> \<not> b s ==> Q s"
    and wf: "wf {(t, s). P s \<and> b s \<and> t = c s}"
  shows "P s \<Longrightarrow> Q (while b c s)"
  using wf
  apply (induct s)
  apply simp
  apply (subst while_unfold)
  apply (simp add: invariant terminate)
  done

theorem while_rule:
  "[| P s;
      !!s. [| P s; b s  |] ==> P (c s);
      !!s. [| P s; \<not> b s  |] ==> Q s;
      wf r;
      !!s. [| P s; b s  |] ==> (c s, s) \<in> r |] ==>
   Q (while b c s)"
  apply (rule while_rule_lemma)
     prefer 4 apply assumption
    apply blast
   apply blast
  apply (erule wf_subset)
  apply blast
  done

text \<open>Combine invariant preservation and variant decrease in one goal:\<close>
theorem while_rule2:
  "[| P s;
      !!s. [| P s; b s  |] ==> P (c s) \<and> (c s, s) \<in> r;
      !!s. [| P s; \<not> b s  |] ==> Q s;
      wf r |] ==>
   Q (while b c s)"
using while_rule[of P] by metis

text\<open>Proving termination:\<close>

theorem wf_while_option_Some:
  assumes "wf {(t, s). (P s \<and> b s) \<and> t = c s}"
  and "\<And>s. P s \<Longrightarrow> b s \<Longrightarrow> P(c s)" and "P s"
  shows "\<exists>t. while_option b c s = Some t"
using assms(1,3)
proof (induction s)
  case less thus ?case using assms(2)
    by (subst while_option_unfold) simp
qed

lemma wf_rel_while_option_Some:
assumes wf: "wf R"
assumes smaller: "\<And>s. P s \<and> b s \<Longrightarrow> (c s, s) \<in> R"
assumes inv: "\<And>s. P s \<and> b s \<Longrightarrow> P(c s)"
assumes init: "P s"
shows "\<exists>t. while_option b c s = Some t"
proof -
 from smaller have "{(t,s). P s \<and> b s \<and> t = c s} \<subseteq> R" by auto
 with wf have "wf {(t,s). P s \<and> b s \<and> t = c s}" by (auto simp: wf_subset)
 with inv init show ?thesis by (auto simp: wf_while_option_Some)
qed

theorem measure_while_option_Some: fixes f :: "'s \<Rightarrow> nat"
shows "(\<And>s. P s \<Longrightarrow> b s \<Longrightarrow> P(c s) \<and> f(c s) < f s)
  \<Longrightarrow> P s \<Longrightarrow> \<exists>t. while_option b c s = Some t"
by(blast intro: wf_while_option_Some[OF wf_if_measure, of P b f])

text\<open>Kleene iteration starting from the empty set and assuming some finite
bounding set:\<close>

lemma while_option_finite_subset_Some: fixes C :: "'a set"
  assumes "mono f" and "!!X. X \<subseteq> C \<Longrightarrow> f X \<subseteq> C" and "finite C"
  shows "\<exists>P. while_option (\<lambda>A. f A \<noteq> A) f {} = Some P"
proof(rule measure_while_option_Some[where
    f= "%A::'a set. card C - card A" and P= "%A. A \<subseteq> C \<and> A \<subseteq> f A" and s= "{}"])
  fix A assume A: "A \<subseteq> C \<and> A \<subseteq> f A" "f A \<noteq> A"
  show "(f A \<subseteq> C \<and> f A \<subseteq> f (f A)) \<and> card C - card (f A) < card C - card A"
    (is "?L \<and> ?R")
  proof
    show ?L by(metis A(1) assms(2) monoD[OF \<open>mono f\<close>])
    show ?R by (metis A assms(2,3) card_seteq diff_less_mono2 equalityI linorder_le_less_linear rev_finite_subset)
  qed
qed simp

lemma lfp_the_while_option:
  assumes "mono f" and "!!X. X \<subseteq> C \<Longrightarrow> f X \<subseteq> C" and "finite C"
  shows "lfp f = the(while_option (\<lambda>A. f A \<noteq> A) f {})"
proof-
  obtain P where "while_option (\<lambda>A. f A \<noteq> A) f {} = Some P"
    using while_option_finite_subset_Some[OF assms] by blast
  with while_option_stop2[OF this] lfp_Kleene_iter[OF assms(1)]
  show ?thesis by auto
qed

lemma lfp_while:
  assumes "mono f" and "!!X. X \<subseteq> C \<Longrightarrow> f X \<subseteq> C" and "finite C"
  shows "lfp f = while (\<lambda>A. f A \<noteq> A) f {}"
unfolding while_def using assms by (rule lfp_the_while_option) blast

lemma wf_finite_less:
  assumes "finite (C :: 'a::order set)"
  shows "wf {(x, y). {x, y} \<subseteq> C \<and> x < y}"
by (rule wf_measure[where f="\<lambda>b. card {a. a \<in> C \<and> a < b}", THEN wf_subset])
   (fastforce simp: less_eq assms intro: psubset_card_mono)

lemma wf_finite_greater:
  assumes "finite (C :: 'a::order set)"
  shows "wf {(x, y). {x, y} \<subseteq> C \<and> y < x}"
by (rule wf_measure[where f="\<lambda>b. card {a. a \<in> C \<and> b < a}", THEN wf_subset])
   (fastforce simp: less_eq assms intro: psubset_card_mono)

lemma while_option_finite_increasing_Some:
  fixes f :: "'a::order \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)" and "s \<le> f s"
  shows "\<exists>P. while_option (\<lambda>A. f A \<noteq> A) f s = Some P"
by (rule wf_rel_while_option_Some[where R="{(x, y). y < x}" and P="\<lambda>A. A \<le> f A" and s="s"])
   (auto simp: assms monoD intro: wf_finite_greater[where C="UNIV::'a set", simplified])

lemma lfp_the_while_option_lattice:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)"
  shows "lfp f = the (while_option (\<lambda>A. f A \<noteq> A) f bot)"
proof -
  obtain P where "while_option (\<lambda>A. f A \<noteq> A) f bot = Some P"
    using while_option_finite_increasing_Some[OF assms, where s=bot] by simp blast
  with while_option_stop2[OF this] lfp_Kleene_iter[OF assms(1)]
  show ?thesis by auto
qed

lemma lfp_while_lattice:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)"
  shows "lfp f = while (\<lambda>A. f A \<noteq> A) f bot"
unfolding while_def using assms by (rule lfp_the_while_option_lattice)

lemma while_option_finite_decreasing_Some:
  fixes f :: "'a::order \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)" and "f s \<le> s"
  shows "\<exists>P. while_option (\<lambda>A. f A \<noteq> A) f s = Some P"
by (rule wf_rel_while_option_Some[where R="{(x, y). x < y}" and P="\<lambda>A. f A \<le> A" and s="s"])
   (auto simp add: assms monoD intro: wf_finite_less[where C="UNIV::'a set", simplified])

lemma gfp_the_while_option_lattice:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)"
  shows "gfp f = the(while_option (\<lambda>A. f A \<noteq> A) f top)"
proof -
  obtain P where "while_option (\<lambda>A. f A \<noteq> A) f top = Some P"
    using while_option_finite_decreasing_Some[OF assms, where s=top] by simp blast
  with while_option_stop2[OF this] gfp_Kleene_iter[OF assms(1)]
  show ?thesis by auto
qed

lemma gfp_while_lattice:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f" and "finite (UNIV :: 'a set)"
  shows "gfp f = while (\<lambda>A. f A \<noteq> A) f top"
unfolding while_def using assms by (rule gfp_the_while_option_lattice)

text\<open>Computing the reflexive, transitive closure by iterating a successor
function. Stops when an element is found that dos not satisfy the test.

More refined (and hence more efficient) versions can be found in ITP 2011 paper
by Nipkow (the theories are in the AFP entry Flyspeck by Nipkow)
and the AFP article Executable Transitive Closures by René Thiemann.\<close>

context
fixes p :: "'a \<Rightarrow> bool"
and f :: "'a \<Rightarrow> 'a list"
and x :: 'a
begin

qualified fun rtrancl_while_test :: "'a list \<times> 'a set \<Rightarrow> bool"
where "rtrancl_while_test (ws,_) = (ws \<noteq> [] \<and> p(hd ws))"

qualified fun rtrancl_while_step :: "'a list \<times> 'a set \<Rightarrow> 'a list \<times> 'a set"
where "rtrancl_while_step (ws, Z) =
  (let x = hd ws; new = remdups (filter (\<lambda>y. y \<notin> Z) (f x))
  in (new @ tl ws, set new \<union> Z))"

definition rtrancl_while :: "('a list * 'a set) option"
where "rtrancl_while = while_option rtrancl_while_test rtrancl_while_step ([x],{x})"

qualified fun rtrancl_while_invariant :: "'a list \<times> 'a set \<Rightarrow> bool"
where "rtrancl_while_invariant (ws, Z) =
   (x \<in> Z \<and> set ws \<subseteq> Z \<and> distinct ws \<and> {(x,y). y \<in> set(f x)} `` (Z - set ws) \<subseteq> Z \<and>
    Z \<subseteq> {(x,y). y \<in> set(f x)}\<^sup>* `` {x} \<and> (\<forall>z\<in>Z - set ws. p z))"

qualified lemma rtrancl_while_invariant:
  assumes inv: "rtrancl_while_invariant st" and test: "rtrancl_while_test st"
  shows   "rtrancl_while_invariant (rtrancl_while_step st)"
proof (cases st)
  fix ws Z assume st: "st = (ws, Z)"
  with test obtain h t where "ws = h # t" "p h" by (cases ws) auto
  with inv st show ?thesis by (auto intro: rtrancl.rtrancl_into_rtrancl)
qed

lemma rtrancl_while_Some: assumes "rtrancl_while = Some(ws,Z)"
shows "if ws = []
       then Z = {(x,y). y \<in> set(f x)}\<^sup>* `` {x} \<and> (\<forall>z\<in>Z. p z)
       else \<not>p(hd ws) \<and> hd ws \<in> {(x,y). y \<in> set(f x)}\<^sup>* `` {x}"
proof -
  have "rtrancl_while_invariant ([x],{x})" by simp
  with rtrancl_while_invariant have I: "rtrancl_while_invariant (ws,Z)"
    by (rule while_option_rule[OF _ assms[unfolded rtrancl_while_def]])
  { assume "ws = []"
    hence ?thesis using I
      by (auto simp del:Image_Collect_case_prod dest: Image_closed_trancl)
  } moreover
  { assume "ws \<noteq> []"
    hence ?thesis using I while_option_stop[OF assms[unfolded rtrancl_while_def]]
      by (simp add: subset_iff)
  }
  ultimately show ?thesis by simp
qed

lemma rtrancl_while_finite_Some:
  assumes "finite ({(x, y). y \<in> set (f x)}\<^sup>* `` {x})" (is "finite ?Cl")
  shows "\<exists>y. rtrancl_while = Some y"
proof -
  let ?R = "(\<lambda>(_, Z). card (?Cl - Z)) <*mlex*> (\<lambda>(ws, _). length ws) <*mlex*> {}"
  have "wf ?R" by (blast intro: wf_mlex)
  then show ?thesis unfolding rtrancl_while_def
  proof (rule wf_rel_while_option_Some[of ?R rtrancl_while_invariant])
    fix st assume *: "rtrancl_while_invariant st \<and> rtrancl_while_test st"
    hence I: "rtrancl_while_invariant (rtrancl_while_step st)"
      by (blast intro: rtrancl_while_invariant)
    show "(rtrancl_while_step st, st) \<in> ?R"
    proof (cases st)
      fix ws Z let ?ws = "fst (rtrancl_while_step st)" and ?Z = "snd (rtrancl_while_step st)"
      assume st: "st = (ws, Z)"
      with * obtain h t where ws: "ws = h # t" "p h" by (cases ws) auto
      { assume "remdups (filter (\<lambda>y. y \<notin> Z) (f h)) \<noteq> []"
        then obtain z where "z \<in> set (remdups (filter (\<lambda>y. y \<notin> Z) (f h)))" by fastforce
        with st ws I have "Z \<subset> ?Z" "Z \<subseteq> ?Cl" "?Z \<subseteq> ?Cl" by auto
        with assms have "card (?Cl - ?Z) < card (?Cl - Z)" by (blast intro: psubset_card_mono)
        with st ws have ?thesis unfolding mlex_prod_def by simp
      }
      moreover
      { assume "remdups (filter (\<lambda>y. y \<notin> Z) (f h)) = []"
        with st ws have "?Z = Z" "?ws = t"  by (auto simp: filter_empty_conv)
        with st ws have ?thesis unfolding mlex_prod_def by simp
      }
      ultimately show ?thesis by blast
    qed
  qed (simp_all add: rtrancl_while_invariant)
qed

end

end


(*
  File:     More_Algebraic_Numbers_HLW.thy
  Author:   Manuel Eberl, TU München
*)
section \<open>More facts about algebraic numbers\<close>
theory More_Algebraic_Numbers_HLW
  imports "Algebraic_Numbers.Algebraic_Numbers"
begin

subsection \<open>Miscellaneous\<close>

(* TODO: Move! All of this belongs in Algebraic_Numbers *)

lemma in_Ints_imp_algebraic [simp, intro]: "x \<in> \<int> \<Longrightarrow> algebraic x"
  by (intro algebraic_int_imp_algebraic int_imp_algebraic_int)

lemma in_Rats_imp_algebraic [simp, intro]: "x \<in> \<rat> \<Longrightarrow> algebraic x"
  by (auto elim!: Rats_cases' intro: algebraic_div)

lemma algebraic_uminus_iff [simp]: "algebraic (-x) \<longleftrightarrow> algebraic x"
  using algebraic_uminus[of x] algebraic_uminus[of "-x"] by auto

lemma algebraic_0 [simp]: "algebraic (0 :: 'a :: field_char_0)"
  and algebraic_1 [simp]: "algebraic (1 :: 'a :: field_char_0)"
  by auto

lemma algebraic_sum [intro]:
  "(\<And>x. x \<in> A \<Longrightarrow> algebraic (f x)) \<Longrightarrow> algebraic (sum f A)"
  by (induction A rule: infinite_finite_induct) (auto intro!: algebraic_plus)

lemma algebraic_prod [intro]:
  "(\<And>x. x \<in> A \<Longrightarrow> algebraic (f x)) \<Longrightarrow> algebraic (prod f A)"
  by (induction A rule: infinite_finite_induct) (auto intro!: algebraic_times)

lemma algebraic_sum_list [intro]:
  "(\<And>x. x \<in> set xs \<Longrightarrow> algebraic x) \<Longrightarrow> algebraic (sum_list xs)"
  by (induction xs) (auto intro!: algebraic_plus)

lemma algebraic_prod_list [intro]:
  "(\<And>x. x \<in> set xs \<Longrightarrow> algebraic x) \<Longrightarrow> algebraic (prod_list xs)"
  by (induction xs) (auto intro!: algebraic_times)

lemma algebraic_sum_mset [intro]:
  "(\<And>x. x \<in># A \<Longrightarrow> algebraic x) \<Longrightarrow> algebraic (sum_mset A)"
  by (induction A) (auto intro!: algebraic_plus)

lemma algebraic_prod_mset [intro]:
  "(\<And>x. x \<in># A \<Longrightarrow> algebraic x) \<Longrightarrow> algebraic (prod_mset A)"
  by (induction A) (auto intro!: algebraic_times)

lemma algebraic_power [intro]: "algebraic x \<Longrightarrow> algebraic (x ^ n)"
  by (induction n) (auto intro: algebraic_times)

lemma algebraic_csqrt [intro]: "algebraic x \<Longrightarrow> algebraic (csqrt x)"
  by (rule algebraic_nth_root[of 2 x]) auto

lemma algebraic_csqrt_iff [simp]: "algebraic (csqrt x) \<longleftrightarrow> algebraic x"
proof
  assume "algebraic (csqrt x)"
  hence "algebraic (csqrt x ^ 2)"
    by (rule algebraic_power)
  also have "csqrt x ^ 2 = x"
    by simp
  finally show "algebraic x" .
qed auto

lemmas [intro] = algebraic_plus algebraic_times algebraic_uminus algebraic_div

lemma algebraic_power_iff [simp]:
  assumes "n > 0"
  shows   "algebraic (x ^ n) \<longleftrightarrow> algebraic x"
  using algebraic_nth_root[of n "x ^ n" x] assms by auto

lemma algebraic_ii [simp]: "algebraic \<i>"
  by (intro algebraic_int_imp_algebraic) auto

lemma algebraic_int_fact [simp, intro]: "algebraic_int (fact n)"
  by (intro int_imp_algebraic_int fact_in_Ints)

lemma algebraic_minus [intro]: "algebraic x \<Longrightarrow> algebraic y \<Longrightarrow> algebraic (x - y)"
  using algebraic_plus[of x "-y"] by simp

lemma algebraic_add_cancel_left [simp]:
  assumes "algebraic x"
  shows   "algebraic (x + y) \<longleftrightarrow> algebraic y"
proof
  assume "algebraic (x + y)"
  hence "algebraic (x + y - x)"
    using assms by (intro algebraic_minus) auto
  thus "algebraic y" by simp
qed (auto intro: algebraic_plus assms)

lemma algebraic_add_cancel_right [simp]:
  assumes "algebraic y"
  shows   "algebraic (x + y) \<longleftrightarrow> algebraic x"
  using algebraic_add_cancel_left[of y x] assms
  by (simp add: add.commute del: algebraic_add_cancel_left)

lemma algebraic_diff_cancel_left [simp]:
  assumes "algebraic x"
  shows   "algebraic (x - y) \<longleftrightarrow> algebraic y"
  using algebraic_add_cancel_left[of x "-y"] assms by (simp del: algebraic_add_cancel_left)

lemma algebraic_diff_cancel_right [simp]:
  assumes "algebraic y"
  shows   "algebraic (x - y) \<longleftrightarrow> algebraic x"
  using algebraic_add_cancel_right[of "-y" x] assms by (simp del: algebraic_add_cancel_right)

lemma algebraic_mult_cancel_left [simp]:
  assumes "algebraic x" "x \<noteq> 0"
  shows   "algebraic (x * y) \<longleftrightarrow> algebraic y"
proof
  assume "algebraic (x * y)"
  hence "algebraic (x * y / x)"
    using assms by (intro algebraic_div) auto
  also have "x * y / x = y"
    using assms by auto
  finally show "algebraic y" .
qed (auto intro: algebraic_times assms)

lemma algebraic_mult_cancel_right [simp]:
  assumes "algebraic y" "y \<noteq> 0"
  shows   "algebraic (x * y) \<longleftrightarrow> algebraic x"
  using algebraic_mult_cancel_left[of y x] assms
  by (simp add: mult.commute del: algebraic_mult_cancel_left)

lemma algebraic_inverse_iff [simp]: "algebraic (inverse y) \<longleftrightarrow> algebraic y"
proof
  assume "algebraic (inverse y)"
  hence "algebraic (inverse (inverse y))"
    by (rule algebraic_inverse)
  thus "algebraic y" by simp
qed (auto intro: algebraic_inverse)

lemma algebraic_divide_cancel_left [simp]:
  assumes "algebraic x" "x \<noteq> 0"
  shows   "algebraic (x / y) \<longleftrightarrow> algebraic y"
proof -
  have "algebraic (x * inverse y) \<longleftrightarrow> algebraic (inverse y)"
    by (intro algebraic_mult_cancel_left assms)
  also have "\<dots> \<longleftrightarrow> algebraic y"
    by (intro algebraic_inverse_iff)
  finally show ?thesis by (simp add: field_simps)
qed

lemma algebraic_divide_cancel_right [simp]:
  assumes "algebraic y" "y \<noteq> 0"
  shows   "algebraic (x / y) \<longleftrightarrow> algebraic x"
proof -
  have "algebraic (x * inverse y) \<longleftrightarrow> algebraic x"
    using assms by (intro algebraic_mult_cancel_right) auto
  thus ?thesis by (simp add: field_simps)
qed

subsection \<open>Turning an algebraic number into an algebraic integer\<close>

subsection \<open>
  Multiplying an algebraic number with a suitable integer turns it into an algebraic integer.
\<close>

lemma algebraic_imp_algebraic_int:
  fixes x :: "'a :: field_char_0"
  assumes "ipoly p x = 0" "p \<noteq> 0"
  defines "c \<equiv> Polynomial.lead_coeff p"
  shows   "algebraic_int (of_int c * x)"
proof -
  define n where "n = Polynomial.degree p"
  define p' where "p' = Abs_poly (\<lambda>i. if i = n then 1 else c ^ (n - i - 1) * poly.coeff p i)"
  have "n > 0"
    using assms unfolding n_def by (intro Nat.gr0I) (auto elim!: degree_eq_zeroE)

  have coeff_p': "poly.coeff p' i =
                    (if i = n then 1 else c ^ (n - i - 1) * poly.coeff p i)"
    (is "_ = ?f i") for i unfolding p'_def
  proof (subst poly.Abs_poly_inverse)
    have "eventually (\<lambda>i. poly.coeff p i = 0) cofinite"
      using MOST_coeff_eq_0 by blast
    hence "eventually (\<lambda>i. ?f i = 0) cofinite"
      by eventually_elim (use assms in \<open>auto simp: n_def\<close>)
    thus "?f \<in> {f. eventually (\<lambda>i. f i = 0) cofinite}" by simp
  qed auto

  have deg_p': "Polynomial.degree p' = n"
  proof -
    from assms have "(\<lambda>n. \<forall>i>n. poly.coeff p' i = 0) = (\<lambda>n. \<forall>i>n. poly.coeff p i = 0)"
      by (auto simp: coeff_p' fun_eq_iff n_def)
    thus ?thesis
      by (simp add: Polynomial.degree_def n_def)
  qed

  have lead_coeff_p': "Polynomial.lead_coeff p' = 1"
    by (simp add: coeff_p' deg_p')

  have "0 = of_int (c ^ (n - 1)) * (\<Sum>i\<le>n. of_int (poly.coeff p i) * x ^ i)"
    using assms unfolding n_def poly_altdef by simp
  also have "\<dots> = (\<Sum>i\<le>n. of_int (c ^ (n - 1) * poly.coeff p i) * x ^ i)"
    by (simp add: sum_distrib_left sum_distrib_right mult_ac)
  also have "\<dots> = (\<Sum>i\<le>n. of_int (poly.coeff p' i) * (of_int c * x) ^ i)"
  proof (intro sum.cong, goal_cases)
    case (2 i)
    have "of_int (poly.coeff p' i) * (of_int c * x) ^ i =
          of_int (c ^ i * poly.coeff p' i) * x ^ i"
      by (simp add: algebra_simps)
    also have "c ^ i * poly.coeff p' i = c ^ (n - 1) * poly.coeff p i"
    proof (cases "i = n")
      case True
      hence "c ^ i * poly.coeff p' i = c ^ n"
        by (auto simp: coeff_p' simp flip: power_Suc)
      also have "n = Suc (n - 1)"
        using \<open>n > 0\<close> by simp
      also have "c ^ \<dots> = c * c ^ (n - 1)"
        by simp
      finally show ?thesis
        using True by (simp add: c_def n_def)
    next
      case False
      thus ?thesis using 2
        by (auto simp: coeff_p' simp flip: power_add)
    qed
    finally show ?case ..
  qed auto
  also have "\<dots> = ipoly p' (of_int c * x)"
    by (simp add: poly_altdef n_def deg_p')
  finally have "ipoly p' (of_int c * x) = 0" ..

  with lead_coeff_p' show ?thesis
    unfolding algebraic_int_altdef_ipoly by blast
qed

lemma algebraic_imp_algebraic_int':
  fixes x :: "'a :: field_char_0"
  assumes "ipoly p x = 0" "p \<noteq> 0" "Polynomial.lead_coeff p dvd c"
  shows   "algebraic_int (of_int c * x)"
proof -
  from assms(3) obtain c' where c_eq: "c = Polynomial.lead_coeff p * c'"
    by auto
  have "algebraic_int (of_int c' * (of_int (Polynomial.lead_coeff p) * x))"
    by (rule algebraic_int_times[OF _ algebraic_imp_algebraic_int]) (use assms in auto)
  also have "of_int c' * (of_int (Polynomial.lead_coeff p) * x) = of_int c * x"
    by (simp add: c_eq mult_ac)
  finally show ?thesis .
qed

end


section \<open>Load Balancing\<close>

theory Approx_LB_Hoare
  imports Complex_Main "HOL-Hoare.Hoare_Logic"
begin

text \<open>This is formalization of the load balancing algorithms and proofs
in the book by Kleinberg and Tardos \cite{KleinbergT06}.\<close>

hide_const (open) sorted

(* TODO: mv *)

lemma sum_le_card_Max: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> sum f A \<le> card A * Max (f ` A)"
proof(induction A rule: finite_ne_induct)
  case (singleton x)
  then show ?case by simp
next
  case (insert x F)
  then show ?case by (auto simp: max_def order.trans[of "sum f F" "card F * Max (f ` F)"])
qed

lemma Max_const[simp]: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> Max ((\<lambda>_. c) ` A) = c"
using Max_in image_is_empty by blast

abbreviation Max\<^sub>0 :: "nat set \<Rightarrow> nat" where
"Max\<^sub>0 N \<equiv> (if N={} then 0 else Max N)"

fun f_Max\<^sub>0 :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat" where
  "f_Max\<^sub>0 f 0 = 0"
| "f_Max\<^sub>0 f (Suc x) = max (f (Suc x)) (f_Max\<^sub>0 f x)"

lemma f_Max\<^sub>0_equiv: "f_Max\<^sub>0 f n = Max\<^sub>0 (f ` {1..n})"
  by (induction n) (auto simp: not_le atLeastAtMostSuc_conv)

lemma f_Max\<^sub>0_correct:
  "\<forall>x \<in> {1..m}. T x \<le> f_Max\<^sub>0 T m"
  "m > 0 \<Longrightarrow> \<exists>x \<in> {1..m}. T x = f_Max\<^sub>0 T m"
   apply (induction m)
     apply simp_all
   apply (metis atLeastAtMost_iff le_Suc_eq max.cobounded1 max.coboundedI2)
  subgoal for m by (cases \<open>m = 0\<close>) (auto simp: max_def)
  done

lemma f_Max\<^sub>0_mono:
  "y \<le> T x \<Longrightarrow> f_Max\<^sub>0 (T (x := y)) m \<le> f_Max\<^sub>0 T m"
  "T x \<le> y \<Longrightarrow> f_Max\<^sub>0 T m \<le> f_Max\<^sub>0 (T (x := y)) m"
  by (induction m) auto

lemma f_Max\<^sub>0_out_of_range [simp]:
  "x \<notin> {1..k} \<Longrightarrow> f_Max\<^sub>0 (T (x := y)) k = f_Max\<^sub>0 T k"
  by (induction k) auto

lemma fun_upd_f_Max\<^sub>0:
  assumes "x \<in> {1..m}" "T x \<le> y"
  shows "f_Max\<^sub>0 (T (x := y)) m = max y (f_Max\<^sub>0 T m)"
  using assms by (induction m) auto

locale LoadBalancing = (* Load Balancing *)
  fixes t :: "nat \<Rightarrow> nat"
    and m :: nat
    and n :: nat
  assumes m_gt_0: "m > 0"
begin

subsection \<open>Formalization of a Correct Load Balancing\<close>

subsubsection \<open>Definition\<close>

definition lb :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat set) \<Rightarrow> nat \<Rightarrow> bool" where
  "lb T A j = ((\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> A x \<inter> A y = {}) \<comment> \<open>No job is assigned to more than one machine\<close>
             \<and> (\<Union>x \<in> {1..m}. A x) = {1..j} \<comment> \<open>Every job is assigned\<close>
             \<and> (\<forall>x \<in> {1..m}. (\<Sum>j \<in> A x. t j) = T x) \<comment> \<open>The processing times sum up to the correct load\<close>)"

abbreviation makespan :: "(nat \<Rightarrow> nat) \<Rightarrow> nat" where
  "makespan T \<equiv> f_Max\<^sub>0 T m"

lemma makespan_def': "makespan T = Max (T ` {1..m})"
  using m_gt_0 by (simp add: f_Max\<^sub>0_equiv)
(*
lemma makespan_correct:
  "\<forall>x \<in> {1..m}. T x \<le> makespan T m"
  "m > 0 \<Longrightarrow> \<exists>x \<in> {1..m}. T x = makespan T m"
   apply (induction m)
     apply simp_all
   apply (metis atLeastAtMost_iff le_Suc_eq max.cobounded1 max.coboundedI2)
  subgoal for m by (cases \<open>m = 0\<close>) (auto simp: max_def)
  done

lemma no_machines_lb_iff_no_jobs: "lb T A j 0 \<longleftrightarrow> j = 0"
  unfolding lb_def by auto

lemma machines_if_jobs: "\<lbrakk> lb T A j m; j > 0 \<rbrakk> \<Longrightarrow> m > 0"
  using no_machines_lb_iff_no_jobs by (cases m) auto
*)

lemma makespan_correct:
  "\<forall>x \<in> {1..m}. T x \<le> makespan T"
  "\<exists>x \<in> {1..m}. T x = makespan T"
  using f_Max\<^sub>0_correct m_gt_0 by auto

lemma lbE:
  assumes "lb T A j"
  shows "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> A x \<inter> A y = {}"
        "(\<Union>x \<in> {1..m}. A x) = {1..j}"
        "\<forall>x \<in> {1..m}. (\<Sum>y \<in> A x. t y) = T x"
  using assms unfolding lb_def by blast+

lemma lbI:
  assumes "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> A x \<inter> A y = {}"
          "(\<Union>x \<in> {1..m}. A x) = {1..j}"
          "\<forall>x \<in> {1..m}. (\<Sum>y \<in> A x. t y) = T x"
  shows "lb T A j" using assms unfolding lb_def by blast

lemma A_lb_finite [simp]:
  assumes "lb T A j" "x \<in> {1..m}"
  shows "finite (A x)"
  by (metis lbE(2) assms finite_UN finite_atLeastAtMost)

text \<open>If \<open>A x\<close> is pairwise disjoint for all \<open>x \<in> {1..m}\<close>, then the the sum over the sums of the
      individual \<open>A x\<close> is equal to the sum over the union of all \<open>A x\<close>.\<close>
lemma sum_sum_eq_sum_Un:
  fixes A :: "nat \<Rightarrow> nat set"
  assumes "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> A x \<inter> A y = {}"
      and "\<forall>x \<in> {1..m}. finite (A x)"
  shows "(\<Sum>x \<in> {1..m}. (\<Sum>y \<in> A x. t y)) = (\<Sum>x \<in> (\<Union>y \<in> {1..m}. A y). t x)"
  using assms
proof (induction m)
  case (Suc m)
  have FINITE: "finite (\<Union>x \<in> {1..m}. A x)" "finite (A (Suc m))"
    using Suc.prems(2) by auto
  have "\<forall>x \<in> {1..m}. A x \<inter> A (Suc m) = {}"
    using Suc.prems(1) by simp
  then have DISJNT: "(\<Union>x \<in> {1..m}. A x) \<inter> (A (Suc m)) = {}" using Union_disjoint by blast
  have "(\<Sum>x \<in> (\<Union>y \<in> {1..m}. A y). t x) + (\<Sum>x \<in> A (Suc m). t x)
      = (\<Sum>x \<in> ((\<Union>y \<in> {1..m}. A y) \<union> A (Suc m)). t x)"
    using sum.union_disjoint[OF FINITE DISJNT, symmetric] .
  also have "... = (\<Sum>x \<in> (\<Union>y \<in> {1..Suc m}. A y). t x)"
    by (metis UN_insert image_Suc_lessThan image_insert inf_sup_aci(5) lessThan_Suc)
  finally show ?case using Suc by auto
qed simp

text \<open>If \<open>T\<close> and \<open>A\<close> are a correct load balancing for \<open>j\<close> jobs and \<open>m\<close> machines,
      then the sum of the loads has to be equal to the sum of the processing times of the jobs\<close>
lemma lb_impl_job_sum:
  assumes "lb T A j"
  shows "(\<Sum>x \<in> {1..m}. T x) = (\<Sum>x \<in> {1..j}. t x)"
proof -
  note lbrules = lbE[OF assms]
  from assms have FINITE: "\<forall>x \<in> {1..m}. finite (A x)" by simp
  have "(\<Sum>x \<in> {1..m}. T x) = (\<Sum>x \<in> {1..m}. (\<Sum>y \<in> A x. t y))"
    using lbrules(3) by simp
  also have "... = (\<Sum>x \<in> {1..j}. t x)"
    using sum_sum_eq_sum_Un[OF lbrules(1) FINITE]
    unfolding lbrules(2) .
  finally show ?thesis .
qed

subsubsection \<open>Lower Bounds for the Makespan\<close>

text \<open>If \<open>T\<close> and \<open>A\<close> are a correct load balancing for \<open>j\<close> jobs and \<open>m\<close> machines, then the processing time
      of any job \<open>x \<in> {1..j}\<close> is a lower bound for the load of some machine \<open>y \<in> {1..m}\<close>\<close>
lemma job_lower_bound_machine:
  assumes "lb T A j" "x \<in> {1..j}"
  shows "\<exists>y \<in> {1..m}. t x \<le> T y"
proof -
  note lbrules = lbE[OF assms(1)]
  have "\<exists>y \<in> {1..m}. x \<in> A y" using lbrules(2) assms(2) by blast
  then obtain y where y_def: "y \<in> {1..m}" "x \<in> A y" ..
  moreover have "finite (A y)" using assms(1) y_def(1) by simp
  ultimately have "t x \<le> (\<Sum>x \<in> A y. t x)" using lbrules(1) member_le_sum by fast
  also have "... = T y" using lbrules(3) y_def(1) by blast
  finally show ?thesis using y_def(1) by blast
qed

text \<open>As the load of any machine is a lower bound for the makespan, the processing time
      of any job \<open>x \<in> {1..j}\<close> has to also be a lower bound for the makespan.
      Follows from @{thm [source] job_lower_bound_machine} and @{thm [source] makespan_correct}.\<close>
lemma job_lower_bound_makespan:
  assumes "lb T A j" "x \<in> {1..j}"
  shows "t x \<le> makespan T"
  by (meson job_lower_bound_machine[OF assms] makespan_correct(1) le_trans)

text \<open>The makespan over \<open>j\<close> jobs is a lower bound for the makespan of any correct load balancing for \<open>j\<close> jobs.\<close>
lemma max_job_lower_bound_makespan:
  assumes "lb T A j"
  shows "Max\<^sub>0 (t ` {1..j}) \<le> makespan T"
  using job_lower_bound_makespan[OF assms] by fastforce

lemma job_dist_lower_bound_makespan:
  assumes "lb T A j"
  shows "(\<Sum>x \<in> {1..j}. t x) / m \<le> makespan T"
proof -
  have "(\<Sum>x \<in> {1..j}. t x) \<le> m * makespan T"
    using assms lb_impl_job_sum[symmetric]
      and sum_le_card_Max[of "{1..m}"] m_gt_0 by (simp add: makespan_def')
  then have "real (\<Sum>x \<in> {1..j}. t x) \<le> real m * real (makespan T)"
    using of_nat_mono by fastforce
  then show ?thesis by (simp add: field_simps m_gt_0)
qed

subsection \<open>The Greedy Approximation Algorithm\<close>

text \<open>This function will perform a linear scan from \<open>k \<in> {1..m}\<close> and return the index of the machine with minimum load assuming \<open>m > 0\<close>\<close>
fun min\<^sub>k :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat" where
  "min\<^sub>k T 0 = 1"
| "min\<^sub>k T (Suc x) =
   (let k = min\<^sub>k T x
    in if T (Suc x) < T k then (Suc x) else k)"

lemma min_correct:
  "\<forall>x \<in> {1..m}. T (min\<^sub>k T m) \<le> T x"
  by (induction m) (auto simp: Let_def le_Suc_eq, force)

lemma min_in_range:
  "k > 0 \<Longrightarrow> (min\<^sub>k T k) \<in> {1..k}"
  by (induction k) (auto simp: Let_def, force+)

lemma add_job:
  assumes "lb T A j" "x \<in> {1..m}"
  shows "lb (T (x := T x + t (Suc j))) (A (x := A x \<union> {Suc j})) (Suc j)"
    (is \<open>lb ?T ?A _\<close>)
proof -
  note lbrules = lbE[OF assms(1)]

  \<comment> \<open>Rule 1: @{term ?A} pairwise disjoint\<close>
  have NOTIN: "\<forall>i \<in> {1..m}. Suc j \<notin> A i" using lbrules(2) assms(2) by force
  with lbrules(1) have "\<forall>i \<in> {1..m}. i \<noteq> x \<longrightarrow> A i \<inter> (A x \<union> {Suc j}) = {}"
    using assms(2) by blast
  then have 1: "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> ?A x \<inter> ?A y = {}"
    using lbrules(1) by simp

  \<comment> \<open>Rule 2: @{term ?A} contains all jobs\<close>
  have "(\<Union>y \<in> {1..m}. ?A y) = (\<Union>y \<in> {1..m}. A y) \<union> {Suc j}"
    using UNION_fun_upd assms(2) by auto
  also have "... = {1..Suc j}" unfolding lbrules(2) by auto
  finally have 2: "(\<Union>y \<in> {1..m}. ?A y) = {1..Suc j}" .

  \<comment> \<open>Rule 3: @{term ?A} sums to @{term ?T}\<close>
  have "(\<Sum>i \<in> ?A x. t i) = (\<Sum>i \<in> A x \<union> {Suc j}. t i)" by simp
  moreover have "A x \<inter> {Suc j} = {}" using NOTIN assms(2) by blast
  moreover have "finite (A x)" "finite {Suc j}" using assms by simp+
  ultimately have "(\<Sum>i \<in> ?A x. t i) = (\<Sum>i \<in> A x. t i) + (\<Sum>i \<in> {Suc j}. t i)"
    using sum.union_disjoint by simp
  also have "... = T x + t (Suc j)" using lbrules(3) assms(2) by simp
  finally have "(\<Sum>i \<in> ?A x. t i) = ?T x" by simp
  then have 3: "\<forall>i \<in> {1..m}. (\<Sum>j \<in> ?A i. t j) = ?T i"
    using lbrules(3) assms(2) by simp

  from lbI[OF 1 2 3] show ?thesis .
qed

lemma makespan_mono:
  "y \<le> T x \<Longrightarrow> makespan (T (x := y)) \<le> makespan T"
  "T x \<le> y \<Longrightarrow> makespan T \<le> makespan (T (x := y))"
  using f_Max\<^sub>0_mono by auto

lemma smaller_optimum:
  assumes "lb T A (Suc j)"
  shows "\<exists>T' A'. lb T' A' j \<and> makespan T' \<le> makespan T"
proof -
  note lbrules = lbE[OF assms]
  have "\<exists>x \<in> {1..m}. Suc j \<in> A x" using lbrules(2) by auto
  then obtain x where x_def: "x \<in> {1..m}" "Suc j \<in> A x" ..
  let ?T = "T (x := T x - t (Suc j))"
  let ?A = "A (x := A x - {Suc j})"

  \<comment> \<open>Rule 1: @{term ?A} pairwise disjoint\<close>
  from lbrules(1) have "\<forall>i \<in> {1..m}. i \<noteq> x \<longrightarrow> A i \<inter> (A x - {Suc j}) = {}"
    using x_def(1) by blast
  then have 1: "\<forall>x \<in> {1..m}. \<forall>y \<in> {1..m}. x \<noteq> y \<longrightarrow> ?A x \<inter> ?A y = {}"
    using lbrules(1) by auto

  \<comment> \<open>Rule 2: @{term ?A} contains all jobs\<close>
  have NOTIN: "\<forall>i \<in> {1..m}. i \<noteq> x \<longrightarrow> Suc j \<notin> A i" using lbrules(1) x_def by blast
  then have "(\<Union>y \<in> {1..m}. ?A y) = (\<Union>y \<in> {1..m}. A y) - {Suc j}"
    using UNION_fun_upd x_def by auto
  also have "... = {1..j}" unfolding lbrules(2) by auto
  finally have 2: "(\<Union>y \<in> {1..m}. ?A y) = {1..j}" .

  \<comment> \<open>Rule 3: @{term ?A} sums to @{term ?T}\<close>
  have "(\<Sum>i \<in> A x - {Suc j}. t i) = (\<Sum>i \<in> A x. t i) - t (Suc j)"
    by (simp add: sum_diff1_nat x_def(2))
  also have "... = T x - t (Suc j)" using lbrules(3) x_def(1) by simp
  finally have "(\<Sum>i \<in> ?A x. t i) = ?T x" by simp
  then have 3: "\<forall>i \<in> {1..m}. (\<Sum>j \<in> ?A i. t j) = ?T i"
    using lbrules(3) x_def(1) by simp

  \<comment> \<open>@{term makespan} is not larger\<close>
  have "lb ?T ?A j \<and> makespan ?T \<le> makespan T"
    using lbI[OF 1 2 3] makespan_mono(1) by force
  then show ?thesis by blast
qed

text \<open>If the processing time \<open>y\<close> does not contribute to the makespan, we can ignore it.\<close>
lemma remove_small_job:
  assumes "makespan (T (x := T x + y)) \<noteq> T x + y"
  shows   "makespan (T (x := T x + y)) = makespan T"
proof -
  let ?T = "T (x := T x + y)"
  have NOT_X: "makespan ?T \<noteq> ?T x" using assms(1) by simp
  then have "\<exists>i \<in> {1..m}. makespan ?T = ?T i \<and> i \<noteq> x"
    using makespan_correct(2) by metis
  then obtain i where i_def: "i \<in> {1..m}" "makespan ?T = ?T i" "i \<noteq> x" by blast
  then have "?T i = T i" using NOT_X by simp
  moreover from this have "makespan T = T i"
    by (metis i_def(1,2) antisym_conv le_add1 makespan_mono(2) makespan_correct(1))
  ultimately show ?thesis using i_def(2) by simp
qed

lemma greedy_makespan_no_jobs [simp]:
  "makespan (\<lambda>_. 0) = 0"
  using m_gt_0 by (simp add: makespan_def')

lemma min_avg: "m * T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..m}. T i)"
           (is \<open>_ * ?T \<le> ?S\<close>)
proof -
  have "(\<Sum>_ \<in> {1..m}. ?T) \<le> ?S"
    using sum_mono[of \<open>{1..m}\<close> \<open>\<lambda>_. ?T\<close> T]
      and min_correct by blast
  then show ?thesis by simp
qed

definition inv\<^sub>1 :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat set) \<Rightarrow> nat \<Rightarrow> bool" where
  "inv\<^sub>1 T A j = (lb T A j \<and> j \<le> n \<and> (\<forall>T' A'. lb T' A' j \<longrightarrow> makespan T \<le> 2 * makespan T'))"

lemma inv\<^sub>1E:
  assumes "inv\<^sub>1 T A j"
  shows "lb T A j" "j \<le> n"
        "lb T' A' j \<Longrightarrow> makespan T \<le> 2 * makespan T'"
  using assms unfolding inv\<^sub>1_def by blast+

lemma inv\<^sub>1I:
  assumes "lb T A j" "j \<le> n" "\<forall>T' A'. lb T' A' j \<longrightarrow> makespan T \<le> 2 * makespan T'"
  shows "inv\<^sub>1 T A j" using assms unfolding inv\<^sub>1_def by blast

lemma inv\<^sub>1_step:
  assumes "inv\<^sub>1 T A j" "j < n"
  shows "inv\<^sub>1 (T ((min\<^sub>k T m) := T (min\<^sub>k T m) + t (Suc j)))
              (A ((min\<^sub>k T m) := A (min\<^sub>k T m) \<union> {Suc j})) (Suc j)"
    (is \<open>inv\<^sub>1 ?T ?A _\<close>)
proof -
  note invrules = inv\<^sub>1E[OF assms(1)]
  \<comment> \<open>Greedy is correct\<close>
  have LB: "lb ?T ?A (Suc j)"
    using add_job[OF invrules(1) min_in_range[OF m_gt_0]] by blast
  \<comment> \<open>Greedy maintains approximation factor\<close>
  have MK: "\<forall>T' A'. lb T' A' (Suc j) \<longrightarrow> makespan ?T \<le> 2 * makespan T'"
  proof rule+
    fix T\<^sub>1 A\<^sub>1 assume "lb T\<^sub>1 A\<^sub>1 (Suc j)"
    from smaller_optimum[OF this]
    obtain T\<^sub>0 A\<^sub>0 where "lb T\<^sub>0 A\<^sub>0 j" "makespan T\<^sub>0 \<le> makespan T\<^sub>1" by blast
    then have IH: "makespan T \<le> 2 * makespan T\<^sub>1"
      using invrules(3) by force
    show "makespan ?T \<le> 2 * makespan T\<^sub>1"
    proof (cases \<open>makespan ?T = T (min\<^sub>k T m) + t (Suc j)\<close>)
      case True
      have "m * T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..m}. T i)" by (rule min_avg)
      also have "... = (\<Sum>i \<in> {1..j}. t i)" by (rule lb_impl_job_sum[OF invrules(1)])
      finally have "real m * T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..j}. t i)"
        by (auto dest: of_nat_mono)
      with m_gt_0 have "T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..j}. t i) / m"
        by (simp add: field_simps)
      then have "T (min\<^sub>k T m) \<le> makespan T\<^sub>1"
        using job_dist_lower_bound_makespan[OF \<open>lb T\<^sub>0 A\<^sub>0 j\<close>]
          and \<open>makespan T\<^sub>0 \<le> makespan T\<^sub>1\<close> by linarith
      moreover have "t (Suc j) \<le> makespan T\<^sub>1"
        using job_lower_bound_makespan[OF \<open>lb T\<^sub>1 A\<^sub>1 (Suc j)\<close>] by simp
      ultimately show ?thesis unfolding True by simp
    next
      case False show ?thesis using remove_small_job[OF False] IH by simp
    qed
  qed
  from inv\<^sub>1I[OF LB _ MK] show ?thesis using assms(2) by simp
qed

definition sorted :: "nat \<Rightarrow> bool" where
  "sorted j = (\<forall>x \<in> {1..j}. \<forall>y \<in> {1..x}. t x \<le> t y)"

lemma sorted_smaller [simp]: "\<lbrakk> sorted j; j \<ge> j' \<rbrakk> \<Longrightarrow> sorted j'"
  unfolding sorted_def by simp

lemma j_gt_m_pigeonhole:
  assumes "lb T A j" "j > m"
  shows "\<exists>x \<in> {1..j}. \<exists>y \<in> {1..j}. \<exists>z \<in> {1..m}. x \<noteq> y \<and> x \<in> A z \<and> y \<in> A z"
proof -
  have "\<forall>x \<in> {1..j}. \<exists>y \<in> {1..m}. x \<in> A y"
    using lbE(2)[OF assms(1)] by blast
  then have "\<exists>f. \<forall>x \<in> {1..j}. x \<in> A (f x) \<and> f x \<in> {1..m}" by metis
  then obtain f where f_def: "\<forall>x \<in> {1..j}. x \<in> A (f x) \<and> f x \<in> {1..m}" ..
  then have "card (f ` {1..j}) \<le> card {1..m}"
    by (meson card_mono finite_atLeastAtMost image_subset_iff)
  also have "... < card {1..j}" using assms(2) by simp
  finally have "card (f ` {1..j}) < card {1..j}" .
  then have "\<not> inj_on f {1..j}" using pigeonhole by blast
  then have "\<exists>x \<in> {1..j}. \<exists>y \<in> {1..j}. x \<noteq> y \<and> f x = f y"
    unfolding inj_on_def by blast
  then show ?thesis using f_def by metis
qed

text \<open>If \<open>T\<close> and \<open>A\<close> are a correct load balancing for \<open>j\<close> jobs and \<open>m\<close> machines with \<open>j > m\<close>,
      and the jobs are sorted in descending order, then there exists a machine \<open>x \<in> {1..m}\<close>
      whose load is at least twice as large as the processing time of job \<open>j\<close>.\<close>
lemma sorted_job_lower_bound_machine:
  assumes "lb T A j" "j > m" "sorted j"
  shows "\<exists>x \<in> {1..m}. 2 * t j \<le> T x"
proof -
  \<comment> \<open>Step 1: Obtaining the jobs\<close>
  note lbrules = lbE[OF assms(1)]
  obtain j\<^sub>1 j\<^sub>2 x where *:
    "j\<^sub>1 \<in> {1..j}" "j\<^sub>2 \<in> {1..j}" "x \<in> {1..m}" "j\<^sub>1 \<noteq> j\<^sub>2" "j\<^sub>1 \<in> A x" "j\<^sub>2 \<in> A x"
    using j_gt_m_pigeonhole[OF assms(1,2)] by blast

  \<comment> \<open>Step 2: Jobs contained in sum\<close>
  have "finite (A x)" using assms(1) *(3) by simp
  then have SUM: "(\<Sum>i \<in> A x. t i) = t j\<^sub>1 + t j\<^sub>2 + (\<Sum>i \<in> A x - {j\<^sub>1} - {j\<^sub>2}. t i)"
    using *(4-6) by (simp add: sum.remove)

  \<comment> \<open>Step 3: Proof of lower bound\<close>
  have "t j \<le> t j\<^sub>1" "t j \<le> t j\<^sub>2"
    using assms(3) *(1-2) unfolding sorted_def by auto
  then have "2 * t j \<le> t j\<^sub>1 + t j\<^sub>2" by simp
  also have "... \<le> (\<Sum>i \<in> A x. t i)" unfolding SUM by simp
  finally have "2 * t j \<le> T x" using lbrules(3) *(3) by simp
  then show ?thesis using *(3) by blast
qed

text \<open>Reasoning analogous to @{thm [source] job_lower_bound_makespan}.\<close>
lemma sorted_job_lower_bound_makespan:
  assumes "lb T A j" "j > m" "sorted j"
  shows "2 * t j \<le> makespan T"
proof -
  obtain x where x_def: "x \<in> {1..m}" "2 * t j \<le> T x"
    using sorted_job_lower_bound_machine[OF assms] ..
  with makespan_correct(1) have "T x \<le> makespan T" by blast
  with x_def(2) show ?thesis by simp
qed

lemma min_zero:
  assumes "x \<in> {1..k}" "T x = 0"
  shows "T (min\<^sub>k T k) = 0"
  using assms(1)
proof (induction k)
  case (Suc k)
  show ?case proof (cases \<open>x = Suc k\<close>)
    case True
    then show ?thesis using assms(2) by (simp add: Let_def)
  next
    case False
    with Suc have "T (min\<^sub>k T k) = 0" by simp
    then show ?thesis by simp
  qed
qed simp

lemma min_zero_index:
  assumes "x \<in> {1..k}" "T x = 0"
  shows "min\<^sub>k T k \<le> x"
  using assms(1)
proof (induction k)
  case (Suc k)
  show ?case proof (cases \<open>x = Suc k\<close>)
    case True
    then show ?thesis using min_in_range[of "Suc k"] by simp
  next
    case False
    with Suc.prems have "x \<in> {1..k}" by simp
    from min_zero[OF this, of T] assms(2) Suc.IH[OF this]
    show ?thesis by simp
  qed
qed simp

definition inv\<^sub>2 :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat set) \<Rightarrow> nat \<Rightarrow> bool" where
  "inv\<^sub>2 T A j = (lb T A j \<and> j \<le> n
                \<and> (\<forall>T' A'. lb T' A' j \<longrightarrow> makespan T \<le> 3 / 2 * makespan T')
                \<and> (\<forall>x > j. T x = 0)
                \<and> (j \<le> m \<longrightarrow> makespan T = Max\<^sub>0 (t ` {1..j})))"

lemma inv\<^sub>2E:
  assumes "inv\<^sub>2 T A j"
  shows "lb T A j" "j \<le> n"
        "lb T' A' j \<Longrightarrow> makespan T \<le> 3 / 2 * makespan T'"
        "\<forall>x > j. T x = 0" "j \<le> m \<Longrightarrow> makespan T = Max\<^sub>0 (t ` {1..j})"
  using assms unfolding inv\<^sub>2_def by blast+

lemma inv\<^sub>2I:
  assumes "lb T A j" "j \<le> n"
          "\<forall>T' A'. lb T' A' j \<longrightarrow> makespan T \<le> 3 / 2 * makespan T'"
          "\<forall>x > j. T x = 0"
          "j \<le> m \<Longrightarrow> makespan T = Max\<^sub>0 (t ` {1..j})"
  shows "inv\<^sub>2 T A j"
  unfolding inv\<^sub>2_def using assms by blast

lemma inv\<^sub>2_step:
  assumes "sorted n" "inv\<^sub>2 T A j" "j < n"
  shows "inv\<^sub>2 (T (min\<^sub>k T m := T(min\<^sub>k T m) + t(Suc j)))
              (A (min\<^sub>k T m := A(min\<^sub>k T m) \<union> {Suc j})) (Suc j)"
    (is \<open>inv\<^sub>2 ?T ?A _\<close>)
proof (cases \<open>Suc j > m\<close>)
  case True note invrules = inv\<^sub>2E[OF assms(2)]
  \<comment> \<open>Greedy is correct\<close>
  have LB: "lb ?T ?A (Suc j)"
    using add_job[OF invrules(1) min_in_range[OF m_gt_0]] by blast
  \<comment> \<open>Greedy maintains approximation factor\<close>
  have MK: "\<forall>T' A'. lb T' A' (Suc j) \<longrightarrow> makespan ?T \<le> 3 / 2 * makespan T'"
  proof rule+
    fix T\<^sub>1 A\<^sub>1 assume "lb T\<^sub>1 A\<^sub>1 (Suc j)"
    from smaller_optimum[OF this]
    obtain T\<^sub>0 A\<^sub>0 where "lb T\<^sub>0 A\<^sub>0 j" "makespan T\<^sub>0 \<le> makespan T\<^sub>1" by blast
    then have IH: "makespan T \<le> 3 / 2 * makespan T\<^sub>1"
      using invrules(3) by force
    show "makespan ?T \<le> 3 / 2 * makespan T\<^sub>1"
    proof (cases \<open>makespan ?T = T (min\<^sub>k T m) + t (Suc j)\<close>)
      case True
      have "m * T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..m}. T i)" by (rule min_avg)
      also have "... = (\<Sum>i \<in> {1..j}. t i)" by (rule lb_impl_job_sum[OF invrules(1)])
      finally have "real m * T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..j}. t i)"
        by (auto dest: of_nat_mono)
      with m_gt_0 have "T (min\<^sub>k T m) \<le> (\<Sum>i \<in> {1..j}. t i) / m"
        by (simp add: field_simps)
      then have "T (min\<^sub>k T m) \<le> makespan T\<^sub>1"
        using job_dist_lower_bound_makespan[OF \<open>lb T\<^sub>0 A\<^sub>0 j\<close>]
          and \<open>makespan T\<^sub>0 \<le> makespan T\<^sub>1\<close> by linarith
      moreover have "2 * t (Suc j) \<le> makespan T\<^sub>1"
        using sorted_job_lower_bound_makespan[OF \<open>lb T\<^sub>1 A\<^sub>1 (Suc j)\<close> \<open>Suc j > m\<close>]
          and assms(1,3) by simp
      ultimately show ?thesis unfolding True by simp
    next
      case False show ?thesis using remove_small_job[OF False] IH by simp
    qed
  qed
  have "\<forall>x > Suc j. ?T x = 0"
    using invrules(4) min_in_range[OF m_gt_0, of T] True by simp
  with inv\<^sub>2I[OF LB _ MK] show ?thesis using assms(3) True by simp
next
  case False
  then have IN_RANGE: "Suc j \<in> {1..m}" by simp
  note invrules = inv\<^sub>2E[OF assms(2)]
  then have "T (Suc j) = 0" by blast

  \<comment> \<open>Greedy is correct\<close>
  have LB: "lb ?T ?A (Suc j)"
    using add_job[OF invrules(1) min_in_range[OF m_gt_0]] by blast

  \<comment> \<open>Greedy is trivially optimal\<close>
  from IN_RANGE \<open>T (Suc j) = 0\<close> have "min\<^sub>k T m \<le> Suc j"
    using min_zero_index by blast
  with invrules(4) have EMPTY: "\<forall>x > Suc j. ?T x = 0" by simp
  from IN_RANGE \<open>T (Suc j) = 0\<close> have "T (min\<^sub>k T m) = 0"
    using min_zero by blast
  with fun_upd_f_Max\<^sub>0[OF min_in_range[OF m_gt_0]] invrules(5) False
  have TRIV: "makespan ?T = Max\<^sub>0 (t ` {1..Suc j})" unfolding f_Max\<^sub>0_equiv[symmetric] by simp
  have MK: "\<forall>T' A'. lb T' A' (Suc j) \<longrightarrow> makespan ?T \<le> 3 / 2 * makespan T'"
    by (auto simp: TRIV[folded f_Max\<^sub>0_equiv]
            dest!: max_job_lower_bound_makespan[folded f_Max\<^sub>0_equiv])

  from inv\<^sub>2I[OF LB _ MK EMPTY TRIV] show ?thesis using assms(3) by simp
qed

lemma sorted_greedy_approximation:
"sorted n \<Longrightarrow> VARS T A i j
{True}
T := (\<lambda>_. 0);
A := (\<lambda>_. {});
j := 0;
WHILE j < n INV {inv\<^sub>2 T A j} DO
  i := min\<^sub>k T m;
  j := (Suc j);
  A := A (i := A(i) \<union> {j});
  T := T (i := T(i) + t j)
OD
{lb T A n \<and> (\<forall>T' A'. lb T' A' n \<longrightarrow> makespan T \<le> 3 / 2 * makespan T')}"
proof (vcg, goal_cases)
  case (1 T A i j)
  then show ?case by (simp add: lb_def inv\<^sub>2_def)
next
  case (2 T A i j)
  then show ?case using inv\<^sub>2_step by simp
next
  case (3 T A i j)
  then show ?case unfolding inv\<^sub>2_def by force
qed

end (* LoadBalancing *)

end (* Theory *)


section "Big Step Semantics with Time"
theory Big_StepT imports Big_Step begin

subsection "Big-Step with Time Semantics of Commands"

inductive
  big_step_t :: "com \<times> state \<Rightarrow> nat \<Rightarrow> state \<Rightarrow> bool"  ("_ \<Rightarrow> _ \<Down> _" 55)
where
Skip: "(SKIP,s) \<Rightarrow> Suc 0 \<Down> s" |
Assign: "(x ::= a,s) \<Rightarrow> Suc 0 \<Down> s(x := aval a s)" |
Seq: "\<lbrakk> (c1,s1) \<Rightarrow> x \<Down> s2;  (c2,s2) \<Rightarrow> y \<Down> s3 ; z=x+y \<rbrakk> \<Longrightarrow> (c1;;c2, s1) \<Rightarrow> z \<Down> s3" |
IfTrue: "\<lbrakk> bval b s;  (c1,s) \<Rightarrow> x \<Down> t; y=x+1 \<rbrakk> \<Longrightarrow> (IF b THEN c1 ELSE c2, s) \<Rightarrow> y \<Down> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c2,s) \<Rightarrow> x \<Down> t; y=x+1  \<rbrakk> \<Longrightarrow> (IF b THEN c1 ELSE c2, s) \<Rightarrow> y \<Down> t" |
WhileFalse: "\<lbrakk> \<not>bval b s \<rbrakk> \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> Suc 0 \<Down> s" |
WhileTrue: "\<lbrakk> bval b s1;  (c,s1) \<Rightarrow> x \<Down> s2;  (WHILE b DO c, s2) \<Rightarrow> y \<Down> s3; 1+x+y=z  \<rbrakk>
    \<Longrightarrow> (WHILE b DO c, s1) \<Rightarrow> z \<Down> s3"

text\<open>We want to execute the big-step rules:\<close>

code_pred big_step_t .

text\<open>For inductive definitions we need command
       \texttt{values} instead of \texttt{value}.\<close>

values "{(t, x). (SKIP, \<lambda>_. 0) \<Rightarrow> x \<Down> t}"

text\<open>We need to translate the result state into a list
to display it.\<close>

values "{map t [''x''] |t x. (SKIP, <''x'' := 42>) \<Rightarrow> x \<Down> t}"

values "{map t [''x''] |t x. (''x'' ::= N 2, <''x'' := 42>) \<Rightarrow> x \<Down> t}"

values "{map t [''x'',''y''] |t x.
  (WHILE Less (V ''x'') (V ''y'') DO (''x'' ::= Plus (V ''x'') (N 5)),
   <''x'' := 0, ''y'' := 13>) \<Rightarrow> x \<Down> t}"

text\<open>Proof automation:\<close>

declare big_step_t.intros [intro]

lemmas big_step_t_induct = big_step_t.induct[split_format(complete)]

subsection "Rule inversion"

text\<open>What can we deduce from @{prop "(SKIP,s) \<Rightarrow> x \<Down> t"} ?
That @{prop "s = t"}. This is how we can automatically prove it:\<close>

inductive_cases Skip_tE[elim!]: "(SKIP,s) \<Rightarrow> x \<Down> t"
thm Skip_tE

text\<open>This is an \emph{elimination rule}. The [elim] attribute tells auto,
blast and friends (but not simp!) to use it automatically; [elim!] means that
it is applied eagerly.

Similarly for the other commands:\<close>

inductive_cases Assign_tE[elim!]: "(x ::= a,s) \<Rightarrow> p \<Down> t"
thm Assign_tE
inductive_cases Seq_tE[elim!]: "(c1;;c2,s1) \<Rightarrow> p \<Down> s3"
thm Seq_tE
inductive_cases If_tE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> x \<Down> t"
thm If_tE

inductive_cases While_tE[elim]: "(WHILE b DO c,s) \<Rightarrow> x \<Down> t"
thm While_tE
text\<open>Only [elim]: [elim!] would not terminate.\<close>

text\<open>An automatic example:\<close>

lemma "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> x \<Down> t \<Longrightarrow> t = s"
by blast

text\<open>Rule inversion by hand via the ``cases'' method:\<close>

lemma assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> x \<Down> t"
shows "t = s"
proof-
  from assms show ?thesis
  proof cases  \<comment> \<open>inverting assms\<close>
    case IfTrue
    thus ?thesis by blast
  next
    case IfFalse thus ?thesis by blast
  qed
qed

(* Using rule inversion to prove simplification rules: *)

text \<open>An example combining rule inversion and derivations\<close>
lemma Seq_t_assoc:
  "((c1;; c2;; c3, s) \<Rightarrow> p \<Down>  s') \<longleftrightarrow> ((c1;; (c2;; c3), s) \<Rightarrow> p \<Down> s')"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> p \<Down> s'"
  then obtain s1 s2 p1 p2 p3 where
    c1: "(c1, s) \<Rightarrow> p1 \<Down> s1" and
    c2: "(c2, s1) \<Rightarrow> p2 \<Down> s2" and
    c3: "(c3, s2) \<Rightarrow> p3 \<Down> s'" and
    p: "p = p1 + (p2 + p3)" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> p2 + p3 \<Down>  s'" apply (rule Seq) by simp
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> p \<Down> s'" unfolding p apply (rule Seq) by simp
next
  \<comment> \<open>The other direction is analogous\<close>
  assume "(c1;; (c2;; c3), s) \<Rightarrow> p \<Down> s'"
  then obtain s1 s2 p1 p2 p3 where
    c1: "(c1, s) \<Rightarrow> p1 \<Down> s1" and
    c2: "(c2, s1) \<Rightarrow> p2 \<Down> s2" and
    c3: "(c3, s2) \<Rightarrow> p3 \<Down> s'" and
    p: "p = (p1 + p2) + p3" by auto
  from c1 c2
  have "(c1;; c2, s) \<Rightarrow> p1 + p2 \<Down>  s2" apply (rule Seq) by simp
  from this c3
  show "(c1;; c2;; c3, s) \<Rightarrow> p \<Down> s'" unfolding p apply (rule Seq) by simp
qed

subsection "Relation to Big-Step Semantics"

lemma "(\<exists>p. ((c, s) \<Rightarrow> p \<Down>  s')) = ((c, s) \<Rightarrow> s')"
proof
    assume "\<exists>p. (c, s) \<Rightarrow> p \<Down> s'"
    then obtain p where "(c, s) \<Rightarrow> p \<Down> s'"
by blast
    then show "((c, s) \<Rightarrow> s')"
      apply(induct c s p s' rule: big_step_t_induct)
        prefer 2 apply(rule Big_Step.Assign)
        apply(auto) done
next
  assume "((c, s) \<Rightarrow> s')"
  then show "(\<exists>p. ((c, s) \<Rightarrow> p \<Down>  s'))"
    apply(induct c s s' rule: big_step_induct)
      by blast+
qed

subsection "Execution is deterministic"

text \<open>This proof is automatic.\<close>

theorem big_step_t_determ: "\<lbrakk> (c,s) \<Rightarrow> p \<Down> t; (c,s) \<Rightarrow> q \<Down> u \<rbrakk> \<Longrightarrow> u = t"
  apply (induction arbitrary: u q rule: big_step_t.induct)
  apply blast+ done

theorem big_step_t_determ2: "\<lbrakk> (c,s) \<Rightarrow> p \<Down> t; (c,s) \<Rightarrow> q \<Down> u \<rbrakk> \<Longrightarrow> (u = t \<and> p=q)"
  apply  (induction arbitrary: u q rule: big_step_t_induct)
    apply(elim Skip_tE) apply(simp)
    apply(elim Assign_tE) apply(simp)
  apply blast
    apply(elim If_tE) apply(simp) apply blast
    apply(elim If_tE)  apply blast apply(simp)
    apply(erule While_tE) apply(simp) apply blast
    proof (goal_cases)
      case 1
      from 1(7) show ?case apply(safe)
        apply(erule While_tE)
          using 1(1-6) apply fast
          using 1(1-6) apply (simp)
        apply(erule While_tE)
          using 1(1-6) apply fast
          using 1(1-6) by (simp)
     qed

lemma bigstep_det: "(c1, s) \<Rightarrow> p1 \<Down> t1 \<Longrightarrow> (c1, s) \<Rightarrow> p \<Down> t \<Longrightarrow> p1=p \<and> t1=t"
  using big_step_t_determ2 by simp

lemma bigstep_progress: "(c, s) \<Rightarrow> p \<Down> t \<Longrightarrow> p > 0"
apply(induct rule: big_step_t.induct, auto) done

abbreviation terminates ("\<down>") where "terminates cs \<equiv> (\<exists>n a. (cs \<Rightarrow> n \<Down> a))"
abbreviation thestate ("\<down>\<^sub>s") where "thestate cs \<equiv> (THE a. \<exists>n. (cs \<Rightarrow> n \<Down> a))"
abbreviation thetime ("\<down>\<^sub>t") where "thetime cs \<equiv> (THE n. \<exists>a. (cs \<Rightarrow> n \<Down> a))"

lemma bigstepT_the_cost: "(c, s) \<Rightarrow> t \<Down> s' \<Longrightarrow> \<down>\<^sub>t(c, s) = t"
  using bigstep_det by blast

lemma bigstepT_the_state: "(c, s) \<Rightarrow> t \<Down> s' \<Longrightarrow> \<down>\<^sub>s(c, s) = s'"
  using bigstep_det by blast

lemma SKIPnot: "(\<not> (SKIP, s) \<Rightarrow> p \<Down> t) = (s\<noteq>t \<or> p\<noteq>Suc 0)" by blast

lemma SKIPp: "\<down>\<^sub>t(SKIP,s) = Suc 0"
  apply(rule the_equality)
  apply fast
  apply auto done

lemma SKIPt: "\<down>\<^sub>s(SKIP,s) = s"
  apply(rule the_equality)
  apply fast
  apply auto done

lemma ASSp: "(THE p. Ex (big_step_t (x ::= e, s) p)) = Suc 0"
  apply(rule the_equality)
  apply fast
  apply auto done

lemma ASSt: "(THE t. \<exists>p. (x ::= e, s) \<Rightarrow> p \<Down> t) = s(x := aval e s)"
  apply(rule the_equality)
  apply fast
  apply auto done

lemma ASSnot: "( \<not> (x ::= e, s) \<Rightarrow> p \<Down> t ) = (p\<noteq>Suc 0 \<or> t\<noteq>s(x := aval e s))"
  apply auto done

lemma If_THE_True: "Suc (THE n. \<exists>a. (c1, s) \<Rightarrow> n \<Down> a) =  (THE n. \<exists>a. (IF b THEN c1 ELSE c2, s) \<Rightarrow> n \<Down> a)"
     if T: "bval b s" and c1_t: "terminates (c1,s)" for s l
proof -
  from c1_t obtain p t where a: "(c1, s) \<Rightarrow> p \<Down> t" by blast
  with T have b: "(IF b THEN c1 ELSE c2, s) \<Rightarrow> p+1 \<Down> t"  using IfTrue by simp
  from a bigstepT_the_cost have "(THE n. \<exists>a. (c1, s) \<Rightarrow> n \<Down> a) = p" by simp
moreover
  from b bigstepT_the_cost have "(THE n. \<exists>a. (IF b THEN c1 ELSE c2, s) \<Rightarrow> n \<Down> a) = p+1" by simp
ultimately
  show ?thesis by simp
qed

lemma If_THE_False: "Suc (THE n. \<exists>a. (c2, s) \<Rightarrow> n \<Down> a) =  (THE n. \<exists>a. (IF b THEN c1 ELSE c2, s) \<Rightarrow> n \<Down> a)"
     if T: "\<not>bval b s" and c2_t: "\<down> (c2,s)" for s l
proof -
  from c2_t obtain p t where a: "(c2, s) \<Rightarrow> p \<Down> t"  by blast
  with T have b: "(IF b THEN c1 ELSE c2, s) \<Rightarrow> p+1 \<Down> t"  using IfFalse by simp
  from a bigstepT_the_cost have "(THE n. \<exists>a. (c2, s) \<Rightarrow> n \<Down> a) = p" by simp
moreover
  from b bigstepT_the_cost have "(THE n. \<exists>a. (IF b THEN c1 ELSE c2, s) \<Rightarrow> n \<Down> a) = p+1" by simp
ultimately
  show ?thesis by simp
qed

end