\<^marker>\<open>creator "Josh Chen"\<close>
\<^marker>\<open>creator "Kevin Kappelmann"\<close>
theory TSFunctions_Base
  imports
    HOTG.SFunctions
    TSBinary_Relations
begin

subsection \<open>Set-Function Type\<close>

text \<open>Functions might also contain elements outside their domain.\<close>
definition [typedef]: "Dep_Function (A :: set type) (B :: set \<Rightarrow> set type) \<equiv>
  type (\<lambda>f. \<forall>x : A. f`x : B x \<and> (\<exists>!y. \<langle>x, y\<rangle> \<in> f))"

abbreviation "Function A B \<equiv> Dep_Function A (\<lambda>_. B)"

translations
  "(x y \<in> A) \<rightarrow>s B" \<rightharpoonup> "(x \<in> A)(y \<in> A) \<rightarrow>s B"
  "(x \<in> A) args \<rightarrow>s B" \<rightharpoonup> "(x \<in> A) \<rightarrow>s args \<rightarrow>s B"
  "(x \<in> A) \<rightarrow>s B" \<rightleftharpoons> "CONST dep_functions A (\<lambda>x. B)"

  "(x y : A) \<rightarrow>s B" \<rightharpoonup> "(x : A)(y : A) \<rightarrow>s B"
  "(x : A) args \<rightarrow>s B" \<rightharpoonup> "(x : A) \<rightarrow>s args \<rightarrow>s B"
  "(x : A) \<rightarrow>s B" \<rightleftharpoons> "CONST Dep_Function A (\<lambda>x. B)"
  (*TODO: explicity type annotation necessary; could be fixed with additional
    type-checking phase*)
  "(A :: set) \<rightarrow>s B" \<rightleftharpoons> "CONST functions A B"
  "A \<rightarrow>s B" \<rightleftharpoons> "CONST Function A B"

lemma Dep_FunctionI:
  assumes "set_left_total_on A f"
  and "set_right_unique_on A f"
  and "\<And>x. x : A \<Longrightarrow> f`x : B x"
  shows "f : (x : A) \<rightarrow>s B x"
  by unfold_types (insert assms, auto dest: set_right_unique_onD)

lemma Dep_Function_set_left_total_on:
  assumes "f : (x : A) \<rightarrow>s B x"
  shows "set_left_total_on A f"
  (*TODO: somehow, unfold_types would loop here*)
  using assms unfolding Dep_Function_def meaning_of_type
  by (auto intro!: set_left_total_onI)

lemma Dep_Function_set_right_unique_on:
  assumes "f : (x : A) \<rightarrow>s B x"
  shows "set_right_unique_on A f"
  (*TODO: somehow, unfold_types would loop here*)
  using assms unfolding Dep_Function_def meaning_of_type
  by auto

lemma Dep_FunctionE [elim]:
  assumes "f : (x : A) \<rightarrow>s B x" "x : A"
  obtains "f`x : B x" and "\<langle>x, f`x\<rangle> \<in> f"
proof
  from \<open>f : _\<close> show "f`x : B x" unfolding Dep_Function_def by unfold_types
  from assms have "\<exists>!y. \<langle>x, y\<rangle> \<in> f" unfolding Dep_Function_def by unfold_types
  with pair_eval_mem_if_ex1_pair_mem show "\<langle>x, f`x\<rangle> \<in> f" by auto
qed

lemma eval_type [type]: "eval : (f : (x : A) \<rightarrow>s B x) \<Rightarrow> (x : A) \<Rightarrow> B x" by auto

lemma Dep_Function_ex1_pairI: "f : ((x : A) \<rightarrow>s B x) \<Longrightarrow> x : A \<Longrightarrow> \<exists>!y. \<langle>x, y\<rangle> \<in> f"
  unfolding Dep_Function_def meaning_of_type by auto

lemma Dep_Function_eq_if_pair_mem_if_pair_mem:
  assumes "f : (x : A) \<rightarrow>s B x" "x : A"
  and "\<langle>x, y\<rangle> \<in> f" "\<langle>x, y'\<rangle> \<in> f"
  shows "y = y'"
  using assms by (auto dest: Dep_Function_set_right_unique_on set_right_unique_onD)

lemma Dep_Function_eval_eq_if_pair_mem [simp]:
  assumes "f : (x : A) \<rightarrow>s B x" "x : A"
  and "\<langle>x, y\<rangle> \<in> f"
  shows "f`x = y"
  using assms by (auto dest: Dep_Function_eq_if_pair_mem_if_pair_mem[OF assms])

lemma Dep_Function_contravariant_dom:
  "\<lbrakk>f : (x : A) \<rightarrow>s B x; \<And>x. x : A' \<Longrightarrow> x : A\<rbrakk> \<Longrightarrow> f : (x : A') \<rightarrow>s B x"
  unfolding Dep_Function_def by unfold_types auto

lemma Dep_Function_covariant_codom:
  assumes "f : (x : A) \<rightarrow>s B x"
  and "\<And>x. x : A \<Longrightarrow> f`x : B x \<Longrightarrow> f`x : B' x"
  shows "f : (x : A) \<rightarrow>s B' x"
  using assms unfolding Dep_Function_def meaning_of_type by auto

lemma Dep_Function_pair_mem_iff_eval_eq:
  assumes "f : (x : A) \<rightarrow>s B x" "x : A"
  shows "\<langle>x, y\<rangle> \<in> f \<longleftrightarrow> f`x = y"
  using assms by auto

lemma Dep_Function_cong [cong]:
  assumes "\<And>x. x : A \<longleftrightarrow> x : A'"
  and "\<And>x y. x : A \<Longrightarrow> y : B x \<longleftrightarrow> y : B' x"
  shows "f : (x : A) \<rightarrow>s B x \<longleftrightarrow> f : (x : A') \<rightarrow>s B' x"
  using assms by (auto intro!: Dep_FunctionI
    dest: Dep_Function_set_right_unique_on Dep_Function_set_left_total_on)

lemma Dep_Function_mem_dom [simp]:
  assumes "f : (x : A) \<rightarrow>s B x" "x : A"
  shows "x \<in> dom f"
  using assms by auto

lemma Dep_Function_pair_memE [elim]:
  assumes "f : (x : A) \<rightarrow>s B x" "p : \<Sum>x : A. (B x)"
  and "p \<in> f"
  obtains x y where "x : A" "y : B x" "f`x = y" "p = \<langle>x, y\<rangle>"
  using assms by auto

lemma Dep_Function_pair_memE':
  assumes "f : (x : A) \<rightarrow>s B x"
  and "\<langle>x, y\<rangle> \<in> f"
  obtains "x : A" "y : B x" "f`x = y" | "\<not>(x : A)"
  using assms by (cases "x : A") auto

lemma Dep_Function_repl_eval_subset [simp]:
  assumes "f : (x : Element A) \<rightarrow>s B x"
  shows "{\<langle>x, f`x\<rangle> | x \<in> A} \<subseteq> f"
  using assms by auto

lemma Dep_Function_eval_eqI:
  assumes "f : (x : A) \<rightarrow>s B x" "g : (x : A') \<rightarrow>s B' x" "x : A & A'"
  and "f \<subseteq> g"
  shows "f`x = g`x"
proof -
  from assms have "x : A" "x : A'" by (auto elim: Int_typeE)
  with assms have "f`x : B x" "\<langle>x, f`x\<rangle> \<in> g" by auto
  then show "f`x = g`x" by auto
qed

text \<open>Clean functions only contain elements in their domain.\<close>
definition [typedef]: "CDep_Function A B \<equiv> Dep_Function A B & Dep_Bin_Rel A B"

abbreviation "CFunction A B \<equiv> CDep_Function A (\<lambda>_. B)"

bundle isa_set_clean_set_functions_syntax
begin
syntax
  "_clean_set_functions_telescope" :: "logic \<Rightarrow> logic \<Rightarrow> logic"  (infixr "\<rightarrow>cs" 55)
end
bundle no_isa_set_clean_set_functions_syntax
begin
syntax
  "_clean_set_functions_telescope" :: "logic \<Rightarrow> logic \<Rightarrow> logic"  (infixr "\<rightarrow>cs" 55)
end
unbundle isa_set_clean_set_functions_syntax

translations
  "(x y : A) \<rightarrow>cs B" \<rightharpoonup> "(x : A)(y : A) \<rightarrow>cs B"
  "(x : A) args \<rightarrow>cs B" \<rightharpoonup> "(x : A) \<rightarrow>cs args \<rightarrow>cs B"
  "(x : A) \<rightarrow>cs B" \<rightleftharpoons> "CONST CDep_Function A (\<lambda>x. B)"
  "A \<rightarrow>cs B" \<rightleftharpoons> "CONST CFunction A B"

lemma mem_dep_functions_iff_CDep_Function:
  "(f \<in> (x \<in> A) \<rightarrow>s (B x)) \<longleftrightarrow> (f : (x : Element A) \<rightarrow>cs Element (B x))"
  by unfold_types (auto intro!: mem_dep_functionsI set_left_total_onI)

soft_type_translation
  "f \<in> (x \<in> A) \<rightarrow>s (B x)" \<rightleftharpoons> "f : (x : Element A) \<rightarrow>cs Element (B x)"
  using mem_dep_functions_iff_CDep_Function by auto

lemma CDep_FunctionI:
  assumes "f : (x : A) \<rightarrow>s B x"
  and "f : Dep_Bin_Rel A B"
  shows "f : (x : A) \<rightarrow>cs B x"
  unfolding CDep_Function_def using assms by auto

lemma Dep_Function_if_CDep_Function [derive]:
  "f : (x : A) \<rightarrow>cs B x \<Longrightarrow> f : (x : A) \<rightarrow>s B x"
  unfolding CDep_Function_def by (drule Int_typeD1)

lemma Dep_Bin_Rel_if_CDep_Function [derive]:
  "f : (x : A) \<rightarrow>cs (B x) \<Longrightarrow> f : Dep_Bin_Rel A B"
  unfolding CDep_Function_def by (drule Int_typeD2)

lemma CDep_Function_pair_memE [elim]:
  assumes "f : (x : A) \<rightarrow>cs B x"
  and "p \<in> f"
  obtains x y where "x : A" "y : B x" "f`x = y" "p = \<langle>x, y\<rangle>"
proof (rule Dep_Function_pair_memE)
  from assms have "f : Dep_Bin_Rel A B" by discharge_types
  with assms show "p : \<Sum>x : A. (B x)" by blast
qed auto

lemma CDep_Function_covariant_codom:
  assumes "f : (x : A) \<rightarrow>cs B x"
  and "\<And>x. x : A \<Longrightarrow> f`x : B x \<Longrightarrow> f`x : B' x"
  shows "f : (x : A) \<rightarrow>cs B' x"
proof -
  from assms have "f : (x : A) \<rightarrow>s B x" by discharge_types
  with assms have "f : (x : A) \<rightarrow>s B' x" by (elim Dep_Function_covariant_codom)
  from assms have "f : Dep_Bin_Rel A B" by discharge_types
  with assms have "f : Dep_Bin_Rel A B'"
    by (elim Dep_Bin_Rel_covariant_rng) auto
  then show ?thesis by (intro CDep_FunctionI) discharge_types
qed

lemma empty_CFunction [type]: "{} : Element {} \<rightarrow>cs X"
  by (intro CDep_FunctionI Dep_FunctionI Dep_Bin_RelI) (auto dest: ElementD)

lemma singleton_CFunctionI [intro]: "y : B \<Longrightarrow> {\<langle>x, y\<rangle>} : Element {x} \<rightarrow>cs B"
  by (intro CDep_FunctionI Dep_FunctionI Dep_Bin_RelI)
    (auto dest: ElementD intro: ElementI)

end


section\<open>Some enhanced theorems on recursion\<close>

theory Recursion_Thms imports ZF.Epsilon begin

text\<open>We prove results concerning definitions by well-founded
recursion on some relation \<^term>\<open>R\<close> and its transitive closure
\<^term>\<open>R^*\<close>\<close>
  (* Restrict the relation r to the field A*A *)

lemma fld_restrict_eq : "a \<in> A \<Longrightarrow> (r \<inter> A\<times>A)-``{a} = (r-``{a} \<inter> A)"
  by(force)

lemma fld_restrict_mono : "relation(r) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> r \<inter> A\<times>A \<subseteq> r \<inter> B\<times>B"
  by(auto)

lemma fld_restrict_dom :
  assumes "relation(r)" "domain(r) \<subseteq> A" "range(r)\<subseteq> A"
  shows "r\<inter> A\<times>A = r"
proof (rule equalityI,blast,rule subsetI)
  { fix x
    assume xr: "x \<in> r"
    from xr assms have "\<exists> a b . x = \<langle>a,b\<rangle>" by (simp add: relation_def)
    then obtain a b where "\<langle>a,b\<rangle> \<in> r" "\<langle>a,b\<rangle> \<in> r\<inter>A\<times>A" "x \<in> r\<inter>A\<times>A"
      using assms xr
      by force
    then have "x\<in> r \<inter> A\<times>A" by simp
  }
  then show "x \<in> r \<Longrightarrow> x\<in> r\<inter>A\<times>A" for x .
qed

definition tr_down :: "[i,i] \<Rightarrow> i"
  where "tr_down(r,a) = (r^+)-``{a}"

lemma tr_downD : "x \<in> tr_down(r,a) \<Longrightarrow> \<langle>x,a\<rangle> \<in> r^+"
  by (simp add: tr_down_def vimage_singleton_iff)

lemma pred_down : "relation(r) \<Longrightarrow> r-``{a} \<subseteq> tr_down(r,a)"
  by(simp add: tr_down_def vimage_mono r_subset_trancl)

lemma tr_down_mono : "relation(r) \<Longrightarrow> x \<in> r-``{a} \<Longrightarrow> tr_down(r,x) \<subseteq> tr_down(r,a)"
  by(rule subsetI,simp add:tr_down_def,auto dest: underD,force simp add: underI r_into_trancl trancl_trans)

lemma rest_eq :
  assumes "relation(r)" and "r-``{a} \<subseteq> B" and "a \<in> B"
  shows "r-``{a} = (r\<inter>B\<times>B)-``{a}"
proof (intro equalityI subsetI)
  fix x
  assume "x \<in> r-``{a}"
  then
  have "x \<in> B" using assms by (simp add: subsetD)
  from \<open>x\<in> r-``{a}\<close>
  have "\<langle>x,a\<rangle> \<in> r" using underD by simp
  then
  show "x \<in> (r\<inter>B\<times>B)-``{a}" using \<open>x\<in>B\<close> \<open>a\<in>B\<close> underI by simp
next
  from assms
  show "x \<in> r -`` {a}" if  "x \<in> (r \<inter> B\<times>B) -`` {a}" for x
    using vimage_mono that by auto
qed

lemma wfrec_restr_eq : "r' = r \<inter> A\<times>A \<Longrightarrow> wfrec[A](r,a,H) = wfrec(r',a,H)"
  by(simp add:wfrec_on_def)

lemma wfrec_restr :
  assumes rr: "relation(r)" and wfr:"wf(r)"
  shows  "a \<in> A \<Longrightarrow> tr_down(r,a) \<subseteq> A \<Longrightarrow> wfrec(r,a,H) = wfrec[A](r,a,H)"
proof (induct a arbitrary:A rule:wf_induct_raw[OF wfr] )
  case (1 a)
  have wfRa : "wf[A](r)"
    using wf_subset wfr wf_on_def Int_lower1 by simp
  from pred_down rr
  have "r -`` {a} \<subseteq> tr_down(r, a)" .
  with 1
  have "r-``{a} \<subseteq> A" by (force simp add: subset_trans)
  {
    fix x
    assume x_a : "x \<in> r-``{a}"
    with \<open>r-``{a} \<subseteq> A\<close>
    have "x \<in> A" ..
    from pred_down rr
    have b : "r -``{x} \<subseteq> tr_down(r,x)" .
    then
    have "tr_down(r,x) \<subseteq> tr_down(r,a)"
      using tr_down_mono x_a rr by simp
    with 1
    have "tr_down(r,x) \<subseteq> A" using subset_trans by force
    have "\<langle>x,a\<rangle> \<in> r" using x_a  underD by simp
    with 1 \<open>tr_down(r,x) \<subseteq> A\<close> \<open>x \<in> A\<close>
    have "wfrec(r,x,H) = wfrec[A](r,x,H)" by simp
  }
  then
  have "x\<in> r-``{a} \<Longrightarrow> wfrec(r,x,H) =  wfrec[A](r,x,H)" for x  .
  then
  have Eq1 :"(\<lambda> x \<in> r-``{a} . wfrec(r,x,H)) = (\<lambda> x \<in> r-``{a} . wfrec[A](r,x,H))"
    using lam_cong by simp

  from assms
  have "wfrec(r,a,H) = H(a,\<lambda> x \<in> r-``{a} . wfrec(r,x,H))" by (simp add:wfrec)
  also
  have "... = H(a,\<lambda> x \<in> r-``{a} . wfrec[A](r,x,H))"
    using assms Eq1 by simp
  also from 1 \<open>r-``{a} \<subseteq> A\<close>
  have "... = H(a,\<lambda> x \<in> (r\<inter>A\<times>A)-``{a} . wfrec[A](r,x,H))"
    using assms rest_eq  by simp
  also from \<open>a\<in>A\<close>
  have "... = H(a,\<lambda> x \<in> (r-``{a})\<inter>A . wfrec[A](r,x,H))"
    using fld_restrict_eq by simp
  also from \<open>a\<in>A\<close> \<open>wf[A](r)\<close>
  have "... = wfrec[A](r,a,H)" using wfrec_on by simp
  finally show ?case .
qed

lemmas wfrec_tr_down = wfrec_restr[OF _ _ _ subset_refl]

lemma wfrec_trans_restr : "relation(r) \<Longrightarrow> wf(r) \<Longrightarrow> trans(r) \<Longrightarrow> r-``{a}\<subseteq>A \<Longrightarrow> a \<in> A \<Longrightarrow>
  wfrec(r, a, H) = wfrec[A](r, a, H)"
  by(subgoal_tac "tr_down(r,a) \<subseteq> A",auto simp add : wfrec_restr tr_down_def trancl_eq_r)

lemma field_trancl : "field(r^+) = field(r)"
  by (blast intro: r_into_trancl dest!: trancl_type [THEN subsetD])

definition
  Rrel :: "[i\<Rightarrow>i\<Rightarrow>o,i] \<Rightarrow> i" where
  "Rrel(R,A) \<equiv> {z\<in>A\<times>A. \<exists>x y. z = \<langle>x, y\<rangle> \<and> R(x,y)}"

lemma RrelI : "x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> R(x,y) \<Longrightarrow> \<langle>x,y\<rangle> \<in> Rrel(R,A)"
  unfolding Rrel_def by simp

lemma Rrel_mem: "Rrel(mem,x) = Memrel(x)"
  unfolding Rrel_def Memrel_def ..

lemma relation_Rrel: "relation(Rrel(R,d))"
  unfolding Rrel_def relation_def by simp

lemma field_Rrel: "field(Rrel(R,d)) \<subseteq>  d"
  unfolding Rrel_def by auto

lemma Rrel_mono : "A \<subseteq> B \<Longrightarrow> Rrel(R,A) \<subseteq> Rrel(R,B)"
  unfolding Rrel_def by blast

lemma Rrel_restr_eq : "Rrel(R,A) \<inter> B\<times>B = Rrel(R,A\<inter>B)"
  unfolding Rrel_def by blast

(* now a consequence of the previous lemmas *)
lemma field_Memrel : "field(Memrel(A)) \<subseteq> A"
  (* unfolding field_def using Ordinal.Memrel_type by blast *)
  using Rrel_mem field_Rrel by blast

lemma restrict_trancl_Rrel:
  assumes "R(w,y)"
  shows "restrict(f,Rrel(R,d)-``{y})`w
       = restrict(f,(Rrel(R,d)^+)-``{y})`w"
proof (cases "y\<in>d")
  let ?r="Rrel(R,d)" and ?s="(Rrel(R,d))^+"
  case True
  show ?thesis
  proof (cases "w\<in>d")
    case True
    with \<open>y\<in>d\<close> assms
    have "\<langle>w,y\<rangle>\<in>?r"
      unfolding Rrel_def by blast
    then
    have "\<langle>w,y\<rangle>\<in>?s"
      using r_subset_trancl[of ?r] relation_Rrel[of R d] by blast
    with \<open>\<langle>w,y\<rangle>\<in>?r\<close>
    have "w\<in>?r-``{y}" "w\<in>?s-``{y}"
      using vimage_singleton_iff by simp_all
    then
    show ?thesis by simp
  next
    case False
    then
    have "w\<notin>domain(restrict(f,?r-``{y}))"
      using subsetD[OF field_Rrel[of R d]] by auto
    moreover from \<open>w\<notin>d\<close>
    have "w\<notin>domain(restrict(f,?s-``{y}))"
      using subsetD[OF field_Rrel[of R d], of w] field_trancl[of ?r]
        fieldI1[of w y ?s] by auto
    ultimately
    have "restrict(f,?r-``{y})`w = 0" "restrict(f,?s-``{y})`w = 0"
      unfolding apply_def by auto
    then show ?thesis by simp
  qed
next
  let ?r="Rrel(R,d)"
  let ?s="?r^+"
  case False
  then
  have "?r-``{y}=0"
    unfolding Rrel_def by blast
  then
  have "w\<notin>?r-``{y}" by simp
  with \<open>y\<notin>d\<close> assms
  have "y\<notin>field(?s)"
    using field_trancl subsetD[OF field_Rrel[of R d]] by force
  then
  have "w\<notin>?s-``{y}"
    using vimage_singleton_iff by blast
  with \<open>w\<notin>?r-``{y}\<close>
  show ?thesis by simp
qed

lemma restrict_trans_eq:
  assumes "w \<in> y"
  shows "restrict(f,Memrel(eclose({x}))-``{y})`w
       = restrict(f,(Memrel(eclose({x}))^+)-``{y})`w"
  using assms restrict_trancl_Rrel[of mem ] Rrel_mem by (simp)

lemma wf_eq_trancl:
  assumes "\<And> f y . H(y,restrict(f,R-``{y})) = H(y,restrict(f,R^+-``{y}))"
  shows  "wfrec(R, x, H) = wfrec(R^+, x, H)" (is "wfrec(?r,_,_) = wfrec(?r',_,_)")
proof -
  have "wfrec(R, x, H) = wftrec(?r^+, x, \<lambda>y f. H(y, restrict(f,?r-``{y})))"
    unfolding wfrec_def ..
  also
  have " ... = wftrec(?r^+, x, \<lambda>y f. H(y, restrict(f,(?r^+)-``{y})))"
    using assms by simp
  also
  have " ... =  wfrec(?r^+, x, H)"
    unfolding wfrec_def using trancl_eq_r[OF relation_trancl trans_trancl] by simp
  finally
  show ?thesis .
qed

end


(*  Title:      HOL/HOLCF/IMP/HoareEx.thy
    Author:     Tobias Nipkow, TUM
    Copyright   1997 TUM
*)

section "Correctness of Hoare by Fixpoint Reasoning"

theory HoareEx imports Denotational begin

text {*
  An example from the HOLCF paper by Mueller, Nipkow, Oheimb, Slotosch
  @{cite MuellerNvOS99}.  It demonstrates fixpoint reasoning by showing
  the correctness of the Hoare rule for while-loops.
*}

type_synonym assn = "state => bool"

definition
  hoare_valid :: "[assn, com, assn] => bool"  ("|= {(1_)}/ (_)/ {(1_)}" 50) where
  "|= {P} c {Q} = (\<forall>s t. P s \<and> D c $(Discr s) = Def t --> Q t)"

lemma WHILE_rule_sound:
    "|= {A} c {A} ==> |= {A} WHILE b DO c {\<lambda>s. A s \<and> \<not> bval b s}"
  apply (unfold hoare_valid_def)
  apply (simp (no_asm))
  apply (rule fix_ind)
    apply (simp (no_asm)) -- "simplifier with enhanced @{text adm}-tactic"
   apply (simp (no_asm))
  apply (simp (no_asm))
  apply blast
  done

end


(*  Title:       A Definitional Encoding of TLA in Isabelle/HOL
    Authors:     Gudmund Grov <ggrov at inf.ed.ac.uk>
                 Stephan Merz <Stephan.Merz at loria.fr>
    Year:        2011
    Maintainer:  Gudmund Grov <ggrov at inf.ed.ac.uk>
*)

section \<open>A simple illustrative example\<close>

theory Even
imports State
begin

text\<open>
  A trivial example illustrating invariant proofs in the logic, and how
  Isabelle/HOL can help with specification. It proves that \<open>x\<close> is
  always even in a program where \<open>x\<close> is initialized as 0 and
  always incremented by 2.
\<close>

inductive_set
  Even :: "nat set"
where
  even_zero: "0 \<in> Even"
| even_step: "n \<in> Even \<Longrightarrow> Suc (Suc n) \<in> Even"

locale Program =
  fixes x :: "state \<Rightarrow> nat"
  and init :: "temporal"
  and act :: "temporal"
  and phi :: "temporal"
  defines "init \<equiv> TEMP $x = # 0"
  and "act \<equiv> TEMP x` = Suc<Suc<$x>>"
  and "phi \<equiv> TEMP init \<and> \<box>[act]_x"

lemma (in Program) stutinvprog: "STUTINV phi"
  by (auto simp: phi_def init_def act_def stutinvs nstutinvs)

lemma  (in Program) inveven: "\<turnstile> phi \<longrightarrow> \<box>($x \<in> # Even)"
  unfolding phi_def
proof (rule invmono)
  show "\<turnstile> init \<longrightarrow> $x \<in> #Even"
    by (auto simp: init_def even_zero)
next
  show "|~ $x \<in> #Even \<and> [act]_x \<longrightarrow> \<circle>($x \<in> #Even)"
    by (auto simp: act_def even_step tla_defs)
qed

end


section \<open>Separation of Roots: Sturm\<close>

text \<open>We adapt the existing theory on Sturm's theorem to work on rational numbers instead of real
  numbers. The reason is that we want to implement real numbers as real algebraic numbers with the
  help of Sturm's theorem to separate the roots. To this end, we just copy the definitions of
  of the algorithms w.r.t. Sturm and let them be executed on rational numbers. We then
  prove that corresponds to a homomorphism and therefore can transfer the existing soundness results.\<close>

theory Sturm_Rat
imports
  Sturm_Sequences.Sturm_Theorem
  Algebraic_Numbers_Prelim
  Berlekamp_Zassenhaus.Square_Free_Int_To_Square_Free_GFp
begin

hide_const (open) UnivPoly.coeff

(* TODO: Move *)
lemma root_primitive_part [simp]:
  fixes p :: "'a :: {semiring_gcd, semiring_no_zero_divisors} poly"
  shows  "poly (primitive_part p) x = 0 \<longleftrightarrow> poly p x = 0"
proof(cases "p = 0")
  case True
  then show ?thesis by auto
next
  case False
  have "poly p x = content p * poly (primitive_part p) x"
    by (metis content_times_primitive_part poly_smult)
  also have "\<dots> = 0 \<longleftrightarrow> poly (primitive_part p) x = 0" by (simp add: False)
  finally show ?thesis by auto
qed

(*TODO: Move*)
lemma irreducible_primitive_part:
  assumes "irreducible p" and "degree p > 0"
  shows "primitive_part p = p"
  using irreducible_content[OF assms(1), unfolded primitive_iff_content_eq_1] assms(2)
  by (auto simp: primitive_part_def abs_poly_def)

subsection \<open>Interface for Separating Roots\<close>

text \<open>For a given rational polynomial, we need to know how many real roots are in a given closed interval,
  and how many real roots are in an interval $(-\infty,r]$.\<close>

datatype root_info = Root_Info (l_r: "rat \<Rightarrow> rat \<Rightarrow> nat") (number_root: "rat \<Rightarrow> nat")
hide_const (open) l_r
hide_const (open) number_root

definition count_roots_interval_sf :: "real poly \<Rightarrow> (real \<Rightarrow> real \<Rightarrow> nat) \<times> (real \<Rightarrow> nat)" where
  "count_roots_interval_sf p = (let ps = sturm_squarefree p
    in ((\<lambda> a b. sign_changes ps a - sign_changes ps b + (if poly p a = 0 then 1 else 0)),
       (\<lambda> a. sign_changes_neg_inf ps - sign_changes ps a)))"

definition count_roots_interval :: "real poly \<Rightarrow> (real \<Rightarrow> real \<Rightarrow> nat) \<times> (real \<Rightarrow> nat)" where
  "count_roots_interval p = (let ps = sturm p
    in ((\<lambda> a b. sign_changes ps a - sign_changes ps b + (if poly p a = 0 then 1 else 0)),
       (\<lambda> a. sign_changes_neg_inf ps - sign_changes ps a)))"

lemma count_roots_interval_iff: "square_free p \<Longrightarrow> count_roots_interval p = count_roots_interval_sf p"
  unfolding count_roots_interval_def count_roots_interval_sf_def sturm_squarefree_def
    square_free_iff_separable separable_def by (cases "p = 0", auto)

lemma count_roots_interval_sf: assumes p: "p \<noteq> 0"
  and cr: "count_roots_interval_sf p = (cr,nr)"
  shows "a \<le> b \<Longrightarrow> cr a b = (card {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0})"
    "nr a = card {x. x \<le> a \<and> poly p x = 0}"
proof -
  have id: "a \<le> b \<Longrightarrow> { x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
    { x. a < x \<and> x \<le> b \<and> poly p x = 0} \<union> (if poly p a = 0 then {a} else {})"
    (is "_ \<Longrightarrow> _ = ?R \<union> ?S") using not_less by force
  have RS: "finite ?R" "finite ?S" "?R \<inter> ?S = {}"  using p by (auto simp: poly_roots_finite)
  show "a \<le> b \<Longrightarrow> cr a b = (card {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0})"
    "nr a = card {x. x \<le> a \<and> poly p x = 0}" using cr unfolding arg_cong[OF id, of card] card_Un_disjoint[OF RS]
    count_roots_interval_sf_def count_roots_between_correct[symmetric]
    count_roots_below_correct[symmetric] count_roots_below_def
    count_roots_between_def Let_def using p by auto
qed

lemma count_roots_interval: assumes cr: "count_roots_interval p = (cr,nr)"
  and sf: "square_free p"
  shows "a \<le> b \<Longrightarrow> cr a b = (card {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0})"
    "nr a = card {x. x \<le> a \<and> poly p x = 0}"
  using count_roots_interval_sf[OF _ cr[unfolded count_roots_interval_iff[OF sf]]]
    sf[unfolded square_free_def] by blast+

definition root_cond :: "int poly \<times> rat \<times> rat \<Rightarrow> real \<Rightarrow> bool" where
  "root_cond plr x = (case plr of (p,l,r) \<Rightarrow> of_rat l \<le> x \<and> x \<le> of_rat r \<and> ipoly p x = 0)"

definition root_info_cond :: "root_info \<Rightarrow> int poly \<Rightarrow> bool" where
  "root_info_cond ri p \<equiv> (\<forall> a b. a \<le> b \<longrightarrow> root_info.l_r ri a b = card {x. root_cond (p,a,b) x})
    \<and> (\<forall> a. root_info.number_root ri a = card {x. x \<le> real_of_rat a \<and> ipoly p x = 0})"

lemma root_info_condD: "root_info_cond ri p \<Longrightarrow> a \<le> b \<Longrightarrow> root_info.l_r ri a b = card {x. root_cond (p,a,b) x}"
  "root_info_cond ri p \<Longrightarrow> root_info.number_root ri a = card {x. x \<le> real_of_rat a \<and> ipoly p x = 0}"
  unfolding root_info_cond_def by auto

definition count_roots_interval_sf_rat :: "int poly \<Rightarrow> root_info" where
  "count_roots_interval_sf_rat  p = (let pp = real_of_int_poly p;
    (cr,nr) = count_roots_interval_sf pp
  in Root_Info (\<lambda> a b. cr (of_rat a) (of_rat b)) (\<lambda> a. nr (of_rat a)))"

definition count_roots_interval_rat :: "int poly \<Rightarrow> root_info" where
  [code del]: "count_roots_interval_rat  p = (let pp = real_of_int_poly p;
    (cr,nr) = count_roots_interval pp
  in Root_Info (\<lambda> a b. cr (of_rat a) (of_rat b)) (\<lambda> a. nr (of_rat a)))"

definition count_roots_rat :: "int poly \<Rightarrow> nat" where
  [code del]: "count_roots_rat  p = (count_roots (real_of_int_poly p))"

lemma count_roots_interval_sf_rat: assumes p: "p \<noteq> 0"
  shows "root_info_cond (count_roots_interval_sf_rat p) p"
proof -
  let ?p = "real_of_int_poly p"
  let ?r = real_of_rat
  let ?ri = "count_roots_interval_sf_rat p"
  from p have p: "?p \<noteq> 0" by auto
  obtain cr nr where cr: "count_roots_interval_sf ?p = (cr,nr)" by force
  have "?ri = Root_Info (\<lambda>a b. cr (?r a) (?r b)) (\<lambda>a. nr (?r a))"
    unfolding count_roots_interval_sf_rat_def Let_def cr by auto
  hence id: "root_info.l_r ?ri = (\<lambda>a b. cr (?r a) (?r b))" "root_info.number_root ?ri = (\<lambda>a. nr (?r a))"
    by auto
  note cr = count_roots_interval_sf[OF p cr]
  show ?thesis unfolding root_info_cond_def id
  proof (intro conjI impI allI)
    fix a
    show "nr (?r a) = card {x. x \<le> (?r a) \<and> ipoly p x = 0}"
      using cr(2)[of "?r a"] by simp
  next
    fix a b :: rat
    assume ab: "a \<le> b"
    from ab have ab: "?r a \<le> ?r b" by (simp add: of_rat_less_eq)
    from cr(1)[OF this] show "cr (?r a) (?r b) = card (Collect (root_cond (p, a, b)))"
      unfolding root_cond_def[abs_def] split by simp
  qed
qed

lemma of_rat_of_int_poly: "map_poly of_rat (of_int_poly p) = of_int_poly p"
  by (subst map_poly_map_poly, auto simp: o_def)

lemma square_free_of_int_poly: assumes "square_free p"
  shows "square_free (of_int_poly p :: 'a :: {field_gcd, field_char_0} poly)"
proof -
  have "square_free (map_poly of_rat (of_int_poly p) :: 'a poly)"
    unfolding of_rat_hom.square_free_map_poly by (rule square_free_int_rat[OF assms])
  thus ?thesis unfolding of_rat_of_int_poly .
qed

lemma count_roots_interval_rat: assumes sf: "square_free p"
  shows "root_info_cond (count_roots_interval_rat p) p"
proof -
  from sf have sf: "square_free (real_of_int_poly p)" by (rule square_free_of_int_poly)
  from sf have p: "p \<noteq> 0" unfolding square_free_def by auto
  show ?thesis
  using count_roots_interval_sf_rat[OF p]
  unfolding count_roots_interval_rat_def count_roots_interval_sf_rat_def
    Let_def count_roots_interval_iff[OF sf] .
qed

lemma count_roots_rat: "count_roots_rat p = card {x. ipoly p x = (0 :: real)}"
  unfolding count_roots_rat_def count_roots_correct ..

subsection \<open>Implementing Sturm on Rational Polynomials\<close>

function sturm_aux_rat where
"sturm_aux_rat (p :: rat poly) q =
    (if degree q = 0 then [p,q] else p # sturm_aux_rat q (-(p mod q)))"
  by (pat_completeness, simp_all)
termination by (relation "measure (degree \<circ> snd)",
                simp_all add: o_def degree_mod_less')

lemma sturm_aux_rat: "sturm_aux (real_of_rat_poly p) (real_of_rat_poly q) =
  map real_of_rat_poly (sturm_aux_rat p q)"
proof (induct p q rule: sturm_aux_rat.induct)
  case (1 p q)
  interpret map_poly_inj_idom_hom of_rat..
  note deg = of_int_hom.degree_map_poly_hom
  show ?case
    unfolding sturm_aux.simps[of "real_of_rat_poly p"] sturm_aux_rat.simps[of p]
    using 1 by (cases "degree q = 0"; simp add: hom_distribs)
qed

definition sturm_rat where "sturm_rat p = sturm_aux_rat p (pderiv p)"

lemma sturm_rat: "sturm (real_of_rat_poly p) = map real_of_rat_poly (sturm_rat p)"
  unfolding sturm_rat_def sturm_def
  apply (fold of_rat_hom.map_poly_pderiv)
  unfolding sturm_aux_rat..

definition poly_number_rootat :: "rat poly \<Rightarrow> rat" where
  "poly_number_rootat p \<equiv> sgn (coeff p (degree p))"

definition poly_neg_number_rootat :: "rat poly \<Rightarrow> rat" where
  "poly_neg_number_rootat p \<equiv> if even (degree p) then sgn (coeff p (degree p))
                                       else -sgn (coeff p (degree p))"

lemma poly_number_rootat: "poly_inf (real_of_rat_poly p) = real_of_rat (poly_number_rootat p)"
  unfolding poly_inf_def poly_number_rootat_def of_int_hom.degree_map_poly_hom of_rat_hom.coeff_map_poly_hom
    real_of_rat_sgn by simp

lemma poly_neg_number_rootat: "poly_neg_inf (real_of_rat_poly p) = real_of_rat (poly_neg_number_rootat p)"
  unfolding poly_neg_inf_def poly_neg_number_rootat_def of_int_hom.degree_map_poly_hom of_rat_hom.coeff_map_poly_hom
    real_of_rat_sgn by (simp add:hom_distribs)

definition sign_changes_rat where
"sign_changes_rat ps (x::rat) =
    length (remdups_adj (filter (\<lambda>x. x \<noteq> 0) (map (\<lambda>p. sgn (poly p x)) ps))) - 1"

definition sign_changes_number_rootat where
  "sign_changes_number_rootat ps =
    length (remdups_adj (filter (\<lambda>x. x \<noteq> 0) (map poly_number_rootat ps))) - 1"

definition sign_changes_neg_number_rootat where
  "sign_changes_neg_number_rootat ps =
      length (remdups_adj (filter (\<lambda>x. x \<noteq> 0) (map poly_neg_number_rootat ps))) - 1"

lemma real_of_rat_list_neq: "list_neq (map real_of_rat xs) 0
  = map real_of_rat (list_neq xs 0)"
  by (induct xs, auto)

lemma real_of_rat_remdups_adj: "remdups_adj (map real_of_rat xs) = map real_of_rat (remdups_adj xs)"
  by (induct xs rule: remdups_adj.induct, auto)

lemma sign_changes_rat: "sign_changes (map real_of_rat_poly ps) (real_of_rat x)
  = sign_changes_rat ps x" (is "?l = ?r")
proof -
  define xs where "xs = list_neq (map (\<lambda>p. sgn (poly p x)) ps) 0"
  have "?l = length (remdups_adj (list_neq (map real_of_rat (map (\<lambda>xa.  (sgn (poly xa x))) ps)) 0)) - 1"
    by (simp add: sign_changes_def real_of_rat_sgn o_def)
  also have "\<dots> = ?r" unfolding sign_changes_rat_def real_of_rat_list_neq
    unfolding real_of_rat_remdups_adj by simp
  finally show ?thesis .
qed

lemma sign_changes_neg_number_rootat: "sign_changes_neg_inf (map real_of_rat_poly ps)
  =  sign_changes_neg_number_rootat ps" (is "?l = ?r")
proof -
  have "?l = length (remdups_adj (list_neq (map real_of_rat (map poly_neg_number_rootat ps)) 0)) - 1"
    by (simp add: sign_changes_neg_inf_def o_def real_of_rat_sgn poly_neg_number_rootat)
  also have "\<dots> = ?r" unfolding sign_changes_neg_number_rootat_def real_of_rat_list_neq
    unfolding real_of_rat_remdups_adj by simp
  finally show ?thesis .
qed

lemma sign_changes_number_rootat: "sign_changes_inf (map real_of_rat_poly ps)
  =  sign_changes_number_rootat ps" (is "?l = ?r")
proof -
  have "?l = length (remdups_adj (list_neq (map real_of_rat (map poly_number_rootat ps)) 0)) - 1"
    unfolding sign_changes_inf_def
    unfolding map_map o_def real_of_rat_sgn poly_number_rootat ..
  also have "\<dots> = ?r" unfolding sign_changes_number_rootat_def real_of_rat_list_neq
    unfolding real_of_rat_remdups_adj by simp
  finally show ?thesis .
qed

lemma count_roots_interval_rat_code[code]:
  "count_roots_interval_rat p = (let rp = map_poly rat_of_int p; ps = sturm_rat rp
    in Root_Info
      (\<lambda> a b. sign_changes_rat ps a - sign_changes_rat ps b + (if poly rp a = 0 then 1 else 0))
      (\<lambda> a. sign_changes_neg_number_rootat ps - sign_changes_rat ps a))"
  unfolding count_roots_interval_rat_def Let_def count_roots_interval_def split of_rat_of_int_poly[symmetric, where 'a = real]
    sturm_rat sign_changes_rat
    by (simp add: sign_changes_neg_number_rootat)

lemma count_roots_rat_code[code]:
  "count_roots_rat p = (let rp = map_poly rat_of_int p in if p = 0 then 0 else let ps = sturm_rat rp
    in sign_changes_neg_number_rootat ps - sign_changes_number_rootat ps)"
  unfolding count_roots_rat_def Let_def sturm_rat count_roots_code of_rat_of_int_poly[symmetric, where 'a = real]
    sign_changes_neg_number_rootat sign_changes_number_rootat
  by simp

hide_const (open) count_roots_interval_sf_rat

text \<open>Finally we provide an even more efficient implementation which
  avoids the "poly p x = 0" test, but it is restricted to irreducible polynomials.\<close>

definition root_info :: "int poly \<Rightarrow> root_info" where
  "root_info p = (if degree p = 1 then
    (let x = Rat.Fract (- coeff p 0) (coeff p 1)
     in Root_Info (\<lambda> l r. if l \<le> x \<and> x \<le> r then 1 else 0)  (\<lambda> b. if x \<le> b then 1 else 0)) else
    (let rp = map_poly rat_of_int p; ps = sturm_rat rp in
   Root_Info (\<lambda> a b. sign_changes_rat ps a - sign_changes_rat ps b)
      (\<lambda> a. sign_changes_neg_number_rootat ps - sign_changes_rat ps a)))"

lemma root_info:
  assumes irr: "irreducible p" and deg: "degree p > 0"
  shows "root_info_cond (root_info p) p"
proof (cases "degree p = 1")
  case deg: True
  from degree1_coeffs[OF this] obtain a b where p: "p = [:b,a:]" and "a \<noteq> 0" by auto
  from deg have "degree (real_of_int_poly p) = 1" by simp
  from roots1[OF this, unfolded roots1_def] p
  have id: "(ipoly p x = 0) = ((x :: real) = - b / a)" for x by auto
  have idd: "{x. real_of_rat aa \<le> x \<and>
                 x \<le> real_of_rat ba \<and> x = real_of_int (- b) / real_of_int a}
   = (if real_of_rat aa \<le> real_of_int (- b) / real_of_int a \<and>
                 real_of_int (- b) / real_of_int a \<le> real_of_rat ba then {real_of_int (- b) / real_of_int a} else {})"
    for aa ba by auto
  have iddd: "{x. x \<le> real_of_rat aa \<and> x = real_of_int (- b) / real_of_int a}
    = (if real_of_int (- b) / real_of_int a \<le> real_of_rat aa then {real_of_int (- b) / real_of_int a} else {})" for aa
    by auto
  have id4: "real_of_int x = real_of_rat (rat_of_int x)" for x by simp
  show ?thesis unfolding root_info_def deg unfolding root_info_cond_def id root_cond_def split
    unfolding p Fract_of_int_quotient Let_def idd iddd
    unfolding id4 of_rat_divide[symmetric] of_rat_less_eq by auto
next
  case False
  have irr_d: "irreducible\<^sub>d p" by (simp add: deg irr irreducible_connect_rev)
  from irreducible\<^sub>d_int_rat[OF this]
  have "irreducible (of_int_poly p :: rat poly)" by auto
  from irreducible_root_free[OF this]
  have idd: "(poly (of_int_poly p) a = 0) = False" for a :: rat
    unfolding root_free_def using False by auto
  have id: "root_info p = count_roots_interval_rat p"
    unfolding root_info_def if_False count_roots_interval_rat_code Let_def idd using False by auto
  show ?thesis unfolding id
    by (rule count_roots_interval_rat[OF irreducible\<^sub>d_square_free[OF irr_d]])
qed

end


(*  Title:      HOL/Proofs/Extraction/Higman.thy
    Author:     Stefan Berghofer, TU Muenchen
    Author:     Monika Seisenberger, LMU Muenchen
*)

section \<open>Higman's lemma\<close>

theory Higman
imports Main
begin

text \<open>
  Formalization by Stefan Berghofer and Monika Seisenberger,
  based on Coquand and Fridlender @{cite Coquand93}.
\<close>

datatype letter = A | B

inductive emb :: "letter list \<Rightarrow> letter list \<Rightarrow> bool"
where
  emb0 [Pure.intro]: "emb [] bs"
| emb1 [Pure.intro]: "emb as bs \<Longrightarrow> emb as (b # bs)"
| emb2 [Pure.intro]: "emb as bs \<Longrightarrow> emb (a # as) (a # bs)"

inductive L :: "letter list \<Rightarrow> letter list list \<Rightarrow> bool"
  for v :: "letter list"
where
  L0 [Pure.intro]: "emb w v \<Longrightarrow> L v (w # ws)"
| L1 [Pure.intro]: "L v ws \<Longrightarrow> L v (w # ws)"

inductive good :: "letter list list \<Rightarrow> bool"
where
  good0 [Pure.intro]: "L w ws \<Longrightarrow> good (w # ws)"
| good1 [Pure.intro]: "good ws \<Longrightarrow> good (w # ws)"

inductive R :: "letter \<Rightarrow> letter list list \<Rightarrow> letter list list \<Rightarrow> bool"
  for a :: letter
where
  R0 [Pure.intro]: "R a [] []"
| R1 [Pure.intro]: "R a vs ws \<Longrightarrow> R a (w # vs) ((a # w) # ws)"

inductive T :: "letter \<Rightarrow> letter list list \<Rightarrow> letter list list \<Rightarrow> bool"
  for a :: letter
where
  T0 [Pure.intro]: "a \<noteq> b \<Longrightarrow> R b ws zs \<Longrightarrow> T a (w # zs) ((a # w) # zs)"
| T1 [Pure.intro]: "T a ws zs \<Longrightarrow> T a (w # ws) ((a # w) # zs)"
| T2 [Pure.intro]: "a \<noteq> b \<Longrightarrow> T a ws zs \<Longrightarrow> T a ws ((b # w) # zs)"

inductive bar :: "letter list list \<Rightarrow> bool"
where
  bar1 [Pure.intro]: "good ws \<Longrightarrow> bar ws"
| bar2 [Pure.intro]: "(\<And>w. bar (w # ws)) \<Longrightarrow> bar ws"

theorem prop1: "bar ([] # ws)"
  by iprover

theorem lemma1: "L as ws \<Longrightarrow> L (a # as) ws"
  by (erule L.induct) iprover+

lemma lemma2': "R a vs ws \<Longrightarrow> L as vs \<Longrightarrow> L (a # as) ws"
  supply [[simproc del: defined_all]]
  apply (induct set: R)
  apply (erule L.cases)
  apply simp+
  apply (erule L.cases)
  apply simp_all
  apply (rule L0)
  apply (erule emb2)
  apply (erule L1)
  done

lemma lemma2: "R a vs ws \<Longrightarrow> good vs \<Longrightarrow> good ws"
  supply [[simproc del: defined_all]]
  apply (induct set: R)
  apply iprover
  apply (erule good.cases)
  apply simp_all
  apply (rule good0)
  apply (erule lemma2')
   apply assumption
  apply (erule good1)
  done

lemma lemma3': "T a vs ws \<Longrightarrow> L as vs \<Longrightarrow> L (a # as) ws"
  supply [[simproc del: defined_all]]
  apply (induct set: T)
  apply (erule L.cases)
  apply simp_all
  apply (rule L0)
  apply (erule emb2)
  apply (rule L1)
  apply (erule lemma1)
  apply (erule L.cases)
  apply simp_all
  apply iprover+
  done

lemma lemma3: "T a ws zs \<Longrightarrow> good ws \<Longrightarrow> good zs"
  supply [[simproc del: defined_all]]
  apply (induct set: T)
  apply (erule good.cases)
  apply simp_all
  apply (rule good0)
  apply (erule lemma1)
  apply (erule good1)
  apply (erule good.cases)
  apply simp_all
  apply (rule good0)
  apply (erule lemma3')
  apply iprover+
  done

lemma lemma4: "R a ws zs \<Longrightarrow> ws \<noteq> [] \<Longrightarrow> T a ws zs"
  supply [[simproc del: defined_all]]
  apply (induct set: R)
  apply iprover
  apply (case_tac vs)
  apply (erule R.cases)
  apply simp
  apply (case_tac a)
  apply (rule_tac b=B in T0)
  apply simp
  apply (rule R0)
  apply (rule_tac b=A in T0)
  apply simp
  apply (rule R0)
  apply simp
  apply (rule T1)
  apply simp
  done

lemma letter_neq: "a \<noteq> b \<Longrightarrow> c \<noteq> a \<Longrightarrow> c = b" for a b c :: letter
  apply (case_tac a)
  apply (case_tac b)
  apply (case_tac c, simp, simp)
  apply (case_tac c, simp, simp)
  apply (case_tac b)
  apply (case_tac c, simp, simp)
  apply (case_tac c, simp, simp)
  done

lemma letter_eq_dec: "a = b \<or> a \<noteq> b" for a b :: letter
  apply (case_tac a)
  apply (case_tac b)
  apply simp
  apply simp
  apply (case_tac b)
  apply simp
  apply simp
  done

theorem prop2:
  assumes ab: "a \<noteq> b" and bar: "bar xs"
  shows "\<And>ys zs. bar ys \<Longrightarrow> T a xs zs \<Longrightarrow> T b ys zs \<Longrightarrow> bar zs"
  using bar
proof induct
  fix xs zs
  assume "T a xs zs" and "good xs"
  then have "good zs" by (rule lemma3)
  then show "bar zs" by (rule bar1)
next
  fix xs ys
  assume I: "\<And>w ys zs. bar ys \<Longrightarrow> T a (w # xs) zs \<Longrightarrow> T b ys zs \<Longrightarrow> bar zs"
  assume "bar ys"
  then show "\<And>zs. T a xs zs \<Longrightarrow> T b ys zs \<Longrightarrow> bar zs"
  proof induct
    fix ys zs
    assume "T b ys zs" and "good ys"
    then have "good zs" by (rule lemma3)
    then show "bar zs" by (rule bar1)
  next
    fix ys zs
    assume I': "\<And>w zs. T a xs zs \<Longrightarrow> T b (w # ys) zs \<Longrightarrow> bar zs"
      and ys: "\<And>w. bar (w # ys)" and Ta: "T a xs zs" and Tb: "T b ys zs"
    show "bar zs"
    proof (rule bar2)
      fix w
      show "bar (w # zs)"
      proof (cases w)
        case Nil
        then show ?thesis by simp (rule prop1)
      next
        case (Cons c cs)
        from letter_eq_dec show ?thesis
        proof
          assume ca: "c = a"
          from ab have "bar ((a # cs) # zs)" by (iprover intro: I ys Ta Tb)
          then show ?thesis by (simp add: Cons ca)
        next
          assume "c \<noteq> a"
          with ab have cb: "c = b" by (rule letter_neq)
          from ab have "bar ((b # cs) # zs)" by (iprover intro: I' Ta Tb)
          then show ?thesis by (simp add: Cons cb)
        qed
      qed
    qed
  qed
qed

theorem prop3:
  assumes bar: "bar xs"
  shows "\<And>zs. xs \<noteq> [] \<Longrightarrow> R a xs zs \<Longrightarrow> bar zs"
  using bar
proof induct
  fix xs zs
  assume "R a xs zs" and "good xs"
  then have "good zs" by (rule lemma2)
  then show "bar zs" by (rule bar1)
next
  fix xs zs
  assume I: "\<And>w zs. w # xs \<noteq> [] \<Longrightarrow> R a (w # xs) zs \<Longrightarrow> bar zs"
    and xsb: "\<And>w. bar (w # xs)" and xsn: "xs \<noteq> []" and R: "R a xs zs"
  show "bar zs"
  proof (rule bar2)
    fix w
    show "bar (w # zs)"
    proof (induct w)
      case Nil
      show ?case by (rule prop1)
    next
      case (Cons c cs)
      from letter_eq_dec show ?case
      proof
        assume "c = a"
        then show ?thesis by (iprover intro: I [simplified] R)
      next
        from R xsn have T: "T a xs zs" by (rule lemma4)
        assume "c \<noteq> a"
        then show ?thesis by (iprover intro: prop2 Cons xsb xsn R T)
      qed
    qed
  qed
qed

theorem higman: "bar []"
proof (rule bar2)
  fix w
  show "bar [w]"
  proof (induct w)
    show "bar [[]]" by (rule prop1)
  next
    fix c cs assume "bar [cs]"
    then show "bar [c # cs]" by (rule prop3) (simp, iprover)
  qed
qed

primrec is_prefix :: "'a list \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool"
where
  "is_prefix [] f = True"
| "is_prefix (x # xs) f = (x = f (length xs) \<and> is_prefix xs f)"

theorem L_idx:
  assumes L: "L w ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>i. emb (f i) w \<and> i < length ws"
  using L
proof induct
  case (L0 v ws)
  then have "emb (f (length ws)) w" by simp
  moreover have "length ws < length (v # ws)" by simp
  ultimately show ?case by iprover
next
  case (L1 ws v)
  then obtain i where emb: "emb (f i) w" and "i < length ws"
    by simp iprover
  then have "i < length (v # ws)" by simp
  with emb show ?case by iprover
qed

theorem good_idx:
  assumes good: "good ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>i j. emb (f i) (f j) \<and> i < j"
  using good
proof induct
  case (good0 w ws)
  then have "w = f (length ws)" and "is_prefix ws f" by simp_all
  with good0 show ?case by (iprover dest: L_idx)
next
  case (good1 ws w)
  then show ?case by simp
qed

theorem bar_idx:
  assumes bar: "bar ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>i j. emb (f i) (f j) \<and> i < j"
  using bar
proof induct
  case (bar1 ws)
  then show ?case by (rule good_idx)
next
  case (bar2 ws)
  then have "is_prefix (f (length ws) # ws) f" by simp
  then show ?case by (rule bar2)
qed

text \<open>
  Strong version: yields indices of words that can be embedded into each other.
\<close>

theorem higman_idx: "\<exists>(i::nat) j. emb (f i) (f j) \<and> i < j"
proof (rule bar_idx)
  show "bar []" by (rule higman)
  show "is_prefix [] f" by simp
qed

text \<open>
  Weak version: only yield sequence containing words
  that can be embedded into each other.
\<close>

theorem good_prefix_lemma:
  assumes bar: "bar ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>vs. is_prefix vs f \<and> good vs"
  using bar
proof induct
  case bar1
  then show ?case by iprover
next
  case (bar2 ws)
  from bar2.prems have "is_prefix (f (length ws) # ws) f" by simp
  then show ?case by (iprover intro: bar2)
qed

theorem good_prefix: "\<exists>vs. is_prefix vs f \<and> good vs"
  using higman
  by (rule good_prefix_lemma) simp+

end