theory HardL
imports MediumL
        "../Nat-prfs/ProofN"

begin

fun sorted :: "Nat List \<Rightarrow> bool" where
  "sorted Nil                   = True"
| "sorted (Cons _ Nil)          = True"
| "sorted (Cons r (Cons t ts))  = (leq r t \<and> sorted (Cons t ts))"

fun insert :: "Nat \<Rightarrow> Nat List \<Rightarrow> Nat List" where
  "insert r Nil         = Cons r Nil"
| "insert r (Cons t ts) = (if leq r t then Cons r (Cons t ts) else (Cons t (insert r ts)))"

fun isort :: "Nat List \<Rightarrow> Nat List" where
  "isort Nil = Nil"
| "isort (Cons t ts) = insert t (isort ts)"

fun qsort :: "Nat list \<Rightarrow> Nat list" where
  "qsort [] = []"
| "qsort (t # ts) = [r . r <- ts, leq r t] @ (t # [r . r <- ts, \<not> (leq r t)])"

fun sorted' :: "Nat list \<Rightarrow> bool" where
  "sorted' []                   = True"
| "sorted' [x]         = True"
| "sorted' (r # (t # ts))  = (leq r t \<and>  sorted' (t # ts))"

fun count' :: "'a \<Rightarrow> 'a List \<Rightarrow> Nat" where
  "count' n Nil = Z"
| "count' n (Cons t ts) = (if n = t then S (count' n ts) else count' n ts)"

fun elem' :: "'a \<Rightarrow> 'a List \<Rightarrow> bool" where
  "elem' n Nil = False"
| "elem' n (Cons t ts) = (n = t \<or> elem' n ts)"

lemma elemIns0: "elem t (insert t ts)"
by hipster_induct_simp_metis

lemma elemIns : "\<not> eqN r t \<Longrightarrow> elem r (insert t ts) = elem r ts"
by hipster_induct_simp_metis

lemma elemCount: "elem t ts \<Longrightarrow> lt Z (count t ts)"
by hipster_induct_simp_metis

lemma countIns: "S (count t ts) = count t (insert t ts)"
by hipster_induct_simp_metis

lemma eqEq: "eqN r t = (r = t)"
by hipster_induct_schemes

lemma countIns0: "\<not> eqN r t \<Longrightarrow> count t ts = count t (insert r ts)"
by hipster_induct_schemes

lemma setCountSort: "count t ts = count t (isort ts)"
by (hipster_induct_schemes eqEq countIns0 countIns)  (* XXX: something weird with regular induct: shouldn't *)

lemma subLCount : "leq (count t ts) (len ts)"
by (hipster_induct_simp_metis succIncreasesL)
(* apply(induction t ts rule: count.induct)
apply(simp_all add: succIncreasesL)*)

(*lemma count2 : "leq (add (count t ts) (count r ts)) (len ts)"
apply (hipster_induct_schemes count03 subLCount)*)

lemma symList  : "ts = rev ts \<Longrightarrow> app (rev (drop n ts)) (rev (take n ts)) = ts"
(*apply (hipster_induct_schemes dropTake)*)
oops

lemma insLen : "len (insert t ts) = S (len ts)"
by hipster_induct_simp_metis (*
apply(induction ts)
apply(simp_all)
oops*)

lemma lenIsort : "len (isort ts) = len ts"
by (hipster_induct_simp_metis insLen)

(* XXX: DO NOT RUN with hipster_induct_schemes *)
lemma appZips  : "len a = len b \<Longrightarrow> app (zip a b) (zip c d) = zip (app a c) (app b d)"
(*apply(hipster_induct_schemes app.simps len.simps List.exhaust Nat.distinct)*)
(*apply hipster_induct_schemes*)
apply (hipster_induct_schemes app.simps len.simps List.exhaust Nat.exhaust)
done
(*by (tactic {* let
      val lemmas = [] (* (ThyExpl_Data.proved_of_ctxt @{context}) @ (Hipster_Rules.get @{context})*)
      val facts = @{thms app.simps  len.simps List.exhaust Nat.distinct} in
        ALLGOALS(Ind_Tacs.induct_simp_or_metis (facts,lemmas) @{context} (SOME @{thms "zip.induct"}) (SOME ["a","b"]))
      end*})*)
(*apply(induction a b rule: zip.induct)
apply(simp_all)
by (metis app.simps len.simps List.exhaust Nat.distinct)*)

lemma auxRev : "rev (rev (Cons a Nil)) = Cons a Nil"
by (tactic \<open>Tactic_Data.routine_tac @{context}\<close>)

lemma revA : "rev (app xs (Cons x Nil)) = app (rev (Cons x Nil)) (rev xs)"
by hipster_induct_simp_metis

declare [[ML_print_depth = 100]]

lemma revA' : "rev (app xs (Cons x Nil)) = Cons x (rev xs)"
by hipster_induct_simp_metis

(* FIXME: there is something wrong going on with the simplifying part: the following is resolved
    without any issues, however it won't do so with
      by (hipster_induct_schemes revA) nor by (hipster_induct_simp_metis revA) *)
lemma revRev  : "rev (rev xs) = xs"
by (hipster_induct_simp_metis revA') (*revA'*)
(*apply(induction xs rule: rev.induct)
apply(simp_all)
apply(metis rev.simps revA')
*)

(*hipster rev app*)
lemma lemma_ab : "app (app x y) x = app x (app y x)"
by hipster_induct_simp_metis

lemma lemma_ad : "app (app x y) y = app x (app y y)"
by hipster_induct_simp_metis

lemma lemma_ae : "app (app x x) y = app x (app x y)"
by hipster_induct_simp_metis

lemma appAssoc : "app (app x y) z = app x (app y z)"
by hipster_induct_simp_metis

lemma appNil: "app ts Nil = ts" (* borrowed from BasicL *)
by hipster_induct_simp_metis

lemma appRevAntiDistr [thy_expl] : "app (rev x) (rev y) = rev (app y x)"
by (hipster_induct_simp_metis appNil appAssoc)

lemma revApp: "rev (app xs ts) = app (rev ts) (rev xs)"
by (hipster_induct_simp_metis appAssoc app.simps)

(* immediately follows *)
lemma s : "t = rev t \<Longrightarrow> rev (app t t) = app t t"
(*apply(hipster_induct_schemes revA appNil appAssoc)*)
by (tactic \<open>Tactic_Data.routine_tac @{context}\<close>)

lemma revCons: "rev (Cons t ts) = app (rev ts) (Cons t Nil)"
by simp

(* XXX: DO NOT RUN with hipster_induct_schemes *)
lemma revZip: "len rs = len ts \<Longrightarrow> rev (zip rs ts) = zip (rev rs) (rev ts)"
apply(induction rs ts rule: zip.induct)
apply(simp_all (*add: appZips*))
oops

end


section \<open> Relational Universe \<close>

theory Relation_Extra
  imports "HOL-Library.FuncSet" "HOL-Library.AList" List_Extra Overriding
begin

text \<open> This theory develops a universe for a Z-like relational language, including the core
  operators of the ISO Z metalanguage. Much of this already exists in @{theory HOL.Relation},
  but we need to add some additional functions and sets. It characterises relations, partial
  functions, total functions, and finite functions. \<close>

subsection \<open> Type Syntax\<close>

text \<open> We set up some nice syntax for heterogeneous relations at the type level \<close>

syntax
  "_rel_type" :: "type \<Rightarrow> type \<Rightarrow> type" (infixr "\<leftrightarrow>" 0)

translations
  (type) "'a \<leftrightarrow> 'b" == (type) "('a \<times> 'b) set"

text \<open> Setup pretty printing for homogeneous relations. \<close>

print_translation \<open>
let fun tr' ctx [ Const (@{type_syntax "prod"},_) $ a $ b ] =
      if a = b then Syntax.const @{type_syntax "rel"} $ a else raise Match;
in [(@{type_syntax "set"},tr')]
end
\<close>

subsection \<open> Notation for types as sets \<close>

definition "TUNIV (a::'a itself) = (UNIV :: 'a set)"

syntax "_tvar" :: "type \<Rightarrow> logic" ("[_]\<^sub>T")
translations "['a]\<^sub>T" == "CONST TUNIV TYPE('a)"

lemma TUNIV_mem [simp]: "x \<in> ['a]\<^sub>T"
  by (simp add: TUNIV_def)

subsection \<open> Relational Function Operations \<close>

text \<open> These functions are all adapted from their ISO Z counterparts. \<close>

definition rel_apply :: "('a \<leftrightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ("_'(_')\<^sub>r" [999,0] 999) where
"rel_apply R x = (if (\<exists>! y. (x, y) \<in> R) then THE y. (x, y) \<in> R else undefined)"

text \<open> If there exists a unique @{term "e\<^sub>3"} such that @{term "(e\<^sub>2, e\<^sub>3)"} is in @{term "e\<^sub>1"}, then
  the value of @{term "e\<^sub>1(e\<^sub>2)\<^sub>r"} is @{term e\<^sub>3}, otherwise each @{term "e\<^sub>1(e\<^sub>2)\<^sub>r"} has a fixed but
  unknown value (i.e. @{const undefined}). \<close>

definition rel_domres :: "'a set \<Rightarrow> ('a \<leftrightarrow> 'b) \<Rightarrow> 'a \<leftrightarrow> 'b" (infixr "\<lhd>\<^sub>r" 85) where
"rel_domres A R = {p \<in> R. fst p \<in> A}"

lemma rel_domres_math_def: "A \<lhd>\<^sub>r R = {(k, v) \<in> R. k \<in> A}"
  by (auto simp add: rel_domres_def)

text \<open> Domain restriction (@{term "A \<lhd>\<^sub>r R"} contains the set of pairs in @{term R}, such that the
  first element of every such pair in in @{term A}. \<close>

definition rel_ranres :: "('a \<leftrightarrow> 'b) \<Rightarrow> 'b set \<Rightarrow> 'a \<leftrightarrow> 'b" (infixl "\<rhd>\<^sub>r" 85) where
"rel_ranres R A = {p \<in> R. snd p \<in> A}"

text \<open> We employ some type class trickery to enable a polymorphic operator for override that can
  instantiate @{typ "'a set"}, which is needed for relational overriding. The following class's
  sole purpose is to allow pairs to be the only valid instantiation element for the set type. \<close>

class pre_restrict =
  fixes cmpt :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"
  and res :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set"

instantiation prod :: (type, type) pre_restrict
begin

text \<open> Relations are compatible is they agree on the values for maplets they both possess. \<close>

definition cmpt_prod :: "('a \<leftrightarrow> 'b) \<Rightarrow> ('a \<leftrightarrow> 'b) \<Rightarrow> bool"
  where [simp]: "cmpt_prod R S = ((Domain R) \<lhd>\<^sub>r S = (Domain S) \<lhd>\<^sub>r R)"
definition res_prod :: "('a \<leftrightarrow> 'b) \<Rightarrow> ('a \<leftrightarrow> 'b) \<Rightarrow> 'a \<leftrightarrow> 'b"
  where [simp]: "res_prod R S = ((- Domain S) \<lhd>\<^sub>r R) \<union> S"
instance ..
end

instantiation set :: (pre_restrict) oplus
begin

definition oplus_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where
"oplus_set = res"

instance ..

end

definition rel_update :: "('a \<leftrightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'a \<leftrightarrow> 'b" where
"rel_update R k v = R \<oplus> {(k, v)}"

text \<open> Relational update adds a new pair to a relation. \<close>

definition rel_disjoint :: "('a \<leftrightarrow> 'b set) \<Rightarrow> bool" where
"rel_disjoint f = (\<forall> p \<in> f. \<forall> q \<in> f. p \<noteq> q \<longrightarrow> snd p \<inter> snd q = {})"

definition rel_partitions :: "('a \<leftrightarrow> 'b set) \<Rightarrow> 'b set \<Rightarrow> bool" where
"rel_partitions f a = (rel_disjoint f \<and> \<Union> (Range f) = a)"

subsection \<open> Domain laws \<close>

declare Domain_Un_eq [simp]

lemma Domain_Preimage: "Domain P = P\<inverse> `` UNIV"
  by (simp add: Image_def Domain_unfold)

lemma Domain_relcomp [simp]: "Domain (P O Q) = Domain (P \<rhd>\<^sub>r Domain Q)"
  by (force simp add: Domain_iff rel_ranres_def)

lemma Domain_relcomp_conv: "Domain (P O Q) = (P\<inverse> `` Domain(Q))"
  by (simp add: Domain_Preimage converse_relcomp relcomp_Image)

lemma Domain_set: "Domain (set xs) = set (map fst xs)"
  by (simp add: Domain_fst)

subsection \<open> Range laws \<close>

lemma Range_Image: "Range P = P `` UNIV"
  by (simp add: Image_def Range_iff set_eq_iff)

lemma Range_relcomp: "Range (P O Q) = (Q `` Range(P))"
  by (simp add: Range_Image relcomp_Image)

subsection \<open> Domain Restriction \<close>

lemma Domain_rel_domres [simp]: "Domain (A \<lhd>\<^sub>r R) = A \<inter> Domain(R)"
  by (auto simp add: rel_domres_def)

lemma rel_domres_empty [simp]: "{} \<lhd>\<^sub>r R = {}"
  by (simp add: rel_domres_def)

lemma rel_domres_UNIV [simp]: "UNIV \<lhd>\<^sub>r R = R"
  by (simp add: rel_domres_def)

lemma rel_domres_nil [simp]: "A \<lhd>\<^sub>r {} = {}"
  by (simp add: rel_domres_def)

lemma rel_domres_inter [simp]: "A \<lhd>\<^sub>r B \<lhd>\<^sub>r R = (A \<inter> B) \<lhd>\<^sub>r R"
  by (auto simp add: rel_domres_def)

lemma rel_domres_compl_disj: "A \<inter> Domain P = {} \<Longrightarrow> (- A) \<lhd>\<^sub>r P = P"
  by (auto simp add: rel_domres_def)

lemma rel_domres_notin_Dom: "k \<notin> Domain(f) \<Longrightarrow> (- {k}) \<lhd>\<^sub>r f = f"
  by (simp add: rel_domres_compl_disj)

lemma rel_domres_Id_on: "A \<lhd>\<^sub>r R = Id_on A O R"
  by (auto simp add: rel_domres_def Id_on_def relcomp_unfold)

lemma rel_domres_insert [simp]:
 "A \<lhd>\<^sub>r insert (k, v) R = (if (k \<in> A) then insert (k, v) (A \<lhd>\<^sub>r R) else A \<lhd>\<^sub>r R)"
  by (auto simp add: rel_domres_def)

lemma rel_domres_insert_set [simp]: "x \<notin> Domain P \<Longrightarrow> (insert x A) \<lhd>\<^sub>r P = A \<lhd>\<^sub>r P"
  by (auto simp add: rel_domres_def)

lemma Image_as_rel_domres: "R `` A = Range (A \<lhd>\<^sub>r R)"
  by (auto simp add: rel_domres_def)

lemma rel_domres_Un [simp]: "A \<lhd>\<^sub>r (S \<union> R) = (A \<lhd>\<^sub>r S) \<union> (A \<lhd>\<^sub>r R)"
  by (auto simp add: rel_domres_def)

subsection \<open> Range Restriction \<close>

lemma rel_ranres_UNIV [simp]: "P \<rhd>\<^sub>r UNIV = P"
  by (auto simp add: rel_ranres_def)

lemma rel_ranres_Un [simp]: "(P \<union> Q) \<rhd>\<^sub>r A = (P \<rhd>\<^sub>r A \<union> Q \<rhd>\<^sub>r A)"
  by (auto simp add: rel_ranres_def)

lemma rel_ranres_relcomp [simp]: "(P O Q) \<rhd>\<^sub>r A = P O (Q \<rhd>\<^sub>r A)"
  by (auto simp add: rel_ranres_def relcomp_unfold prod.case_eq_if)

lemma conv_rel_domres [simp]: "(P \<rhd>\<^sub>r A)\<inverse> = A \<lhd>\<^sub>r P\<inverse>"
  by (auto simp add: rel_domres_def rel_ranres_def)

lemma rel_ranres_le: "A \<subseteq> B \<Longrightarrow> f \<rhd>\<^sub>r A \<le> f \<rhd>\<^sub>r B"
  by (simp add: Collect_mono_iff in_mono rel_ranres_def)

subsection \<open> Relational Override \<close>

class restrict = pre_restrict +
  assumes cmpt_sym: "cmpt P Q \<Longrightarrow> cmpt Q P"
  and cmpt_empty: "cmpt {} P"
  assumes res_idem: "res P P = P"
  and res_assoc: "res P (res Q R) = res (res P Q) R"
  and res_lzero: "res {} P = P"
  and res_comm: "cmpt P Q \<Longrightarrow> res P Q = res Q P"
  and res_cmpt: "\<lbrakk> cmpt P Q; cmpt (res P Q) R \<rbrakk> \<Longrightarrow> cmpt P R"
  and res_cmptI: "\<lbrakk> cmpt P Q; cmpt P R; cmpt Q R \<rbrakk> \<Longrightarrow> cmpt (res P Q) R"

lemma res_cmpt_rel: "cmpt (P :: 'a \<leftrightarrow> 'b) Q \<Longrightarrow> cmpt (res P Q) R \<Longrightarrow> cmpt P R"
  by (fastforce simp add: rel_domres_def Domain_iff)

instance prod :: (type, type) restrict
  by (intro_classes, simp_all only: res_cmpt_rel, auto simp add: rel_domres_def Domain_unfold)

instantiation set :: (restrict) override
begin
definition compatible_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
"compatible_set = cmpt"

instance
  apply (intro_classes, simp_all add: oplus_set_def compatible_set_def res_idem res_assoc res_lzero cmpt_sym cmpt_empty res_comm res_cmptI)
  using res_cmpt apply blast
  done
end

lemma override_eq: "R \<oplus> S = ((- Domain S) \<lhd>\<^sub>r R) \<union> S"
  by (simp add: oplus_set_def)

lemma Domain_rel_override [simp]: "Domain (R \<oplus> S) = Domain(R) \<union> Domain(S)"
  by (auto simp add: oplus_set_def Domain_Un_eq)

lemma Range_rel_override: "Range(R \<oplus> S) \<subseteq> Range(R) \<union> Range(S)"
  by (auto simp add: oplus_set_def rel_domres_def)

lemma compatible_rel: "R ## S = (Domain R \<lhd>\<^sub>r S = Domain S \<lhd>\<^sub>r R)"
  by (simp add: compatible_set_def)

lemma compatible_relI: "Domain R \<lhd>\<^sub>r S = Domain S \<lhd>\<^sub>r R \<Longrightarrow> R ## S"
  by (simp add: compatible_rel)

subsection \<open> Functional Relations \<close>

abbreviation functional :: "('a \<leftrightarrow> 'b) \<Rightarrow> bool" where
"functional R \<equiv> single_valued R"

lemma functional_def: "functional R \<longleftrightarrow> inj_on fst R"
  by (force simp add: single_valued_def inj_on_def)

lemma functional_algebraic: "functional R \<longleftrightarrow> R\<inverse> O R \<subseteq> Id"
  apply (auto simp add: functional_def subset_iff relcomp_unfold)
  using inj_on_eq_iff apply fastforce
  apply (metis inj_onI surjective_pairing)
  done

lemma functional_apply:
  assumes "functional R" "(x, y) \<in> R"
  shows "R(x)\<^sub>r = y"
  by (metis (no_types, lifting) Domain.intros DomainE assms(1) assms(2) single_valuedD rel_apply_def theI_unique)

lemma functional_apply_iff: "functional R \<Longrightarrow> (x, y) \<in> R \<longleftrightarrow> (x \<in> Domain R \<and> R(x)\<^sub>r = y)"
  by (auto simp add: functional_apply)

lemma functional_elem:
  assumes "functional R" "x \<in> Domain(R)"
  shows "(x, R(x)\<^sub>r) \<in> R"
  using assms(1) assms(2) functional_apply by fastforce

lemma functional_override [intro!]: "\<lbrakk> functional R; functional S \<rbrakk> \<Longrightarrow> functional (R \<oplus> S)"
  by (auto simp add: functional_algebraic oplus_set_def rel_domres_def)

lemma functional_union [intro!]: "\<lbrakk> functional R; functional S; R ## S \<rbrakk> \<Longrightarrow> functional (R \<union> S)"
  by (metis functional_override le_sup_iff override_comm override_eq single_valued_subset subsetI)

definition functional_list :: "('a \<times> 'b) list \<Rightarrow> bool" where
"functional_list xs = (\<forall> x y z. ListMem (x,y) xs \<and> ListMem (x,z) xs \<longrightarrow> y = z)"

lemma functional_insert [simp]: "functional (insert (x,y) g) \<longleftrightarrow> (g``{x} \<subseteq> {y} \<and> functional g)"
  by (auto simp add:functional_def inj_on_def image_def)

lemma functional_list_nil[simp]: "functional_list []"
  by (simp add:functional_list_def ListMem_iff)

lemma functional_list: "functional_list xs \<longleftrightarrow> functional (set xs)"
  apply (induct xs)
   apply (simp add:functional_def)
  apply (simp add:functional_def functional_list_def ListMem_iff)
  apply (safe)
         apply (force)
        apply (force)
       apply (force)
      apply (force)
     apply (force)
    apply (force)
   apply (force)
  apply (force)
  done

definition fun_rel :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<leftrightarrow> 'b)" where
"fun_rel f = {(x, y). y = f x}"

lemma functional_fun_rel: "functional (fun_rel f)"
  by (simp add: fun_rel_def functional_def)
     (metis (mono_tags, lifting) Product_Type.Collect_case_prodD inj_onI prod.expand)

lemma rel_apply_fun [simp]: "(fun_rel f)(x)\<^sub>r = f x"
  by (simp add: fun_rel_def rel_apply_def)

text \<open> Make a relation functional by removing any pairs that have duplicate distinct values. \<close>

definition mk_functional :: "('a \<leftrightarrow> 'b) \<Rightarrow> ('a \<leftrightarrow> 'b)" where
"mk_functional R = {(x, y) \<in> R. \<forall> y'. (x, y') \<in> R \<longrightarrow> y = y'}"

lemma mk_functional [simp]: "functional (mk_functional R)"
  by (auto simp add: mk_functional_def single_valued_def)

lemma mk_functional_fp: "functional R \<Longrightarrow> mk_functional R = R"
  by (auto simp add: mk_functional_def single_valued_def)

lemma mk_functional_idem: "mk_functional (mk_functional R) = mk_functional R"
  using mk_functional mk_functional_fp by blast

lemma mk_functional_subset [simp]: "mk_functional R \<subseteq> R"
  by (auto simp add: mk_functional_def)

lemma Domain_mk_functional: "Domain (mk_functional R) \<subseteq> Domain R"
  by (auto simp add: mk_functional_def)

definition single_valued_dom :: "('a \<times> 'b) set \<Rightarrow> 'a set" where
"single_valued_dom R = {x \<in> Domain(R). \<exists> y. R `` {x} = {y}}"

lemma mk_functional_single_valued_dom: "mk_functional R = single_valued_dom R \<lhd>\<^sub>r R"
  by (auto simp add: mk_functional_def single_valued_dom_def rel_domres_math_def Domain_unfold)
     (metis Image_singleton_iff singletonD)

subsection \<open> Left-Total Relations\<close>

definition left_totalr_on :: "'a set \<Rightarrow> ('a \<leftrightarrow> 'b) \<Rightarrow> bool" where
"left_totalr_on A R \<longleftrightarrow> (\<forall>x\<in>A. \<exists>y. (x, y) \<in> R)"

abbreviation "left_totalr R \<equiv> left_totalr_on UNIV R"

lemma left_totalr_algebraic: "left_totalr R \<longleftrightarrow> Id \<subseteq> R O R\<inverse>"
  by (auto simp add: left_totalr_on_def)

lemma left_totalr_fun_rel: "left_totalr (fun_rel f)"
  by (simp add: left_totalr_on_def fun_rel_def)

subsection \<open> Injective Relations \<close>

definition injective :: "('a \<leftrightarrow> 'b) \<Rightarrow> bool" where
"injective R = (functional R \<and> R O R\<inverse> \<subseteq> Id)"

lemma injectiveI:
  assumes "functional R" "\<And> x y. \<lbrakk> x \<in> Domain R; y \<in> Domain R; R(x)\<^sub>r = R(y)\<^sub>r \<rbrakk> \<Longrightarrow> x = y"
  shows "injective R"
  using assms by (auto simp add: injective_def functional_apply_iff)

subsection \<open> Relation Sets \<close>

definition rel_typed :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<leftrightarrow> 'b) set" (infixr "\<leftrightarrow>" 55) where
"rel_typed A B = {R. Domain(R) \<subseteq> A \<and> Range(R) \<subseteq> B}" \<comment> \<open> Relations \<close>

lemma rel_typed_intro: "\<lbrakk> Domain(R) \<subseteq> A; Range(R) \<subseteq> B \<rbrakk> \<Longrightarrow> R \<in> A \<leftrightarrow> B"
  by (simp add: rel_typed_def)

definition rel_pfun :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<leftrightarrow> 'b) set" (infixr "\<rightarrow>\<^sub>p" 55) where
"rel_pfun A B = {R. R \<in> A \<leftrightarrow> B \<and> functional R}" \<comment> \<open> Partial Functions \<close>

lemma rel_pfun_intro: "\<lbrakk> R \<in> A \<leftrightarrow> B; functional R \<rbrakk> \<Longrightarrow> R \<in> A \<rightarrow>\<^sub>p B"
  by (simp add: rel_pfun_def)

definition rel_tfun :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<leftrightarrow> 'b) set" (infixr "\<rightarrow>\<^sub>t" 55) where
"rel_tfun A B = {R. R \<in> A \<rightarrow>\<^sub>p B \<and> left_totalr R}" \<comment> \<open> Total Functions \<close>

definition rel_ffun :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<leftrightarrow> 'b) set" (infixr "\<rightarrow>\<^sub>f" 55) where
"rel_ffun A B = {R. R \<in> A \<rightarrow>\<^sub>p B \<and> finite(Domain R)}" \<comment> \<open> Finite Functions \<close>

subsection \<open> Closure Properties \<close>

text \<open> These can be seen as typing rules for relational functions \<close>

named_theorems rclos

lemma rel_ffun_is_pfun [rclos]: "R \<in> rel_ffun A B \<Longrightarrow> R \<in> A \<rightarrow>\<^sub>p B"
  by (simp add: rel_ffun_def)

lemma rel_tfun_is_pfun [rclos]: "R \<in> A \<rightarrow>\<^sub>t B \<Longrightarrow> R \<in> A \<rightarrow>\<^sub>p B"
  by (simp add: rel_tfun_def)

lemma rel_pfun_is_typed [rclos]: "R \<in> A \<rightarrow>\<^sub>p B \<Longrightarrow> R \<in> A \<leftrightarrow> B"
  by (simp add: rel_pfun_def)

lemma rel_ffun_empty [rclos]: "{} \<in> rel_ffun A B"
  by (simp add: rel_ffun_def rel_pfun_def rel_typed_def)

lemma rel_pfun_apply [rclos]: "\<lbrakk> x \<in> Domain(R); R \<in> A \<rightarrow>\<^sub>p B \<rbrakk> \<Longrightarrow> R(x)\<^sub>r \<in> B"
  using functional_apply by (fastforce simp add: rel_pfun_def rel_typed_def)

lemma rel_tfun_apply [rclos]: "\<lbrakk> x \<in> A; R \<in> A \<rightarrow>\<^sub>t B \<rbrakk> \<Longrightarrow> R(x)\<^sub>r \<in> B"
  by (metis (no_types, lifting) Domain_iff iso_tuple_UNIV_I left_totalr_on_def mem_Collect_eq rel_pfun_apply rel_tfun_def)

lemma rel_typed_insert [rclos]: "\<lbrakk> R \<in> A \<leftrightarrow> B; x \<in> A; y \<in> B \<rbrakk> \<Longrightarrow> insert (x, y) R \<in> A \<leftrightarrow> B"
  by (simp add: rel_typed_def)

lemma rel_pfun_insert [rclos]: "\<lbrakk> R \<in> A \<rightarrow>\<^sub>p B; x \<in> A; y \<in> B; x \<notin> Domain(R) \<rbrakk> \<Longrightarrow> insert (x, y) R \<in> A \<rightarrow>\<^sub>p B"
  by (auto intro: rclos simp add: rel_pfun_def)

lemma rel_pfun_override [rclos]: "\<lbrakk> R \<in> A \<rightarrow>\<^sub>p B; S \<in> A \<rightarrow>\<^sub>p B \<rbrakk> \<Longrightarrow> (R \<oplus> S) \<in> A \<rightarrow>\<^sub>p B"
  apply (rule rel_pfun_intro)
   apply (rule rel_typed_intro)
  apply (auto simp add: rel_pfun_def rel_typed_def)
  apply (metis (no_types, opaque_lifting) Range.simps Range_Un_eq Range_rel_override Un_iff rev_subsetD)
  done

subsection \<open> Code Generation \<close>

lemma rel_conv_alist [code]: "(set xs)\<inverse> = set (map (\<lambda>(x, y). (y, x)) xs)"
  by (induct xs, auto)

lemma rel_domres_alist [code]: "A \<lhd>\<^sub>r set xs = set (AList.restrict A xs)"
  by (induct xs, simp_all, safe, simp_all)

lemma Image_alist [code]: "set xs `` A = set (map snd (AList.restrict A xs))"
  by (simp add: Image_as_rel_domres rel_domres_alist Range_snd)

lemma Collect_set: "{x \<in> set xs. P x} = set (filter P xs)"
  by auto

lemma single_valued_dom_alist [code]:
  "single_valued_dom (set xs) = set (filter (\<lambda>x. length (remdups (map snd (AList.restrict {x} xs))) = 1) (map fst xs))"
  by (simp only: single_valued_dom_def set_map[THEN sym] Image_alist Domain_set set_singleton_iff list_singleton_iff Collect_set)

lemma AList_restrict_in_dom: "AList.restrict (set (filter P (map fst xs))) xs = filter (\<lambda> (x, y). P x) xs"
  by (auto intro: filter_cong simp add: Domain.intros fst_eq_Domain AList.restrict_eq)

lemma mk_functional_alist [code]:
  "mk_functional (set xs) = set (filter (\<lambda> (x,y). length (remdups (map snd (AList.restrict {x} xs))) = 1) xs)"
  by (simp only: mk_functional_single_valued_dom rel_domres_alist single_valued_dom_alist AList_restrict_in_dom)

lemma rel_apply_set [code]:
  "rel_apply (set xs) k =
  (let ys = filter (\<lambda> (k', v). k = k') xs in
   if (length ys > 0 \<and> ys = replicate (length ys) (hd ys)) then snd (hd ys) else undefined)"
proof (simp add: Let_unfold, safe)
  let ?ys = "filter (\<lambda>(k', v). k = k') xs"
  assume ys: "?ys \<noteq> []" "?ys = replicate (length ?ys) (hd ?ys)"
  have kmem: "\<And> y. (k, y) \<in> set xs \<longleftrightarrow> (k, y) \<in> set ?ys"
    by simp
  from ys obtain v where v: "(k, v) \<in> set xs"
    using hd_in_set by fastforce
  hence ys':"?ys = replicate (length ?ys) (k, v)"
    by (metis (mono_tags) case_prodI filter_set in_set_replicate member_filter ys(2))
  hence "snd (hd ?ys) = v"
    by (metis hd_replicate replicate_0 snd_conv ys(1))
  moreover have "(THE y. (k, y) \<in> set xs) = v"
    by (metis (no_types, lifting) v in_set_replicate kmem snd_conv the_equality ys')
  moreover have "(\<exists>!y. (k, y) \<in> set xs)"
    by (metis Pair_inject v in_set_replicate kmem ys')
  ultimately show "set xs(k)\<^sub>r = snd (hd ?ys)"
    by (simp add: rel_apply_def)
next
  assume "filter (\<lambda>(k', v). k = k') xs = []"
  hence "\<nexists>v. (k, v) \<in> set xs"
    by (metis (mono_tags, lifting) case_prodI filter_empty_conv)
  thus "set xs(k)\<^sub>r = undefined"
    by (auto simp add: rel_apply_def)
next
  let ?ys = "filter (\<lambda>(k', v). k = k') xs"
  assume ys: "?ys \<noteq> replicate (length ?ys) (hd ?ys)"
  have keys: "\<forall> (k', v') \<in> set ?ys. k' = k"
    by auto
  show "set xs(k)\<^sub>r = undefined"
  proof (cases "length ?ys = 0")
    case True
    then show ?thesis
      using ys by fastforce
  next
    case False
    hence "length ?ys > 1"
      by (metis hd_in_set in_set_conv_nth length_0_conv less_one linorder_neqE_nat replicate_length_same ys)
    have "fst (hd ?ys) = k"
      using False hd_in_set by force
    have "\<not>(\<forall> (k, v) \<in> set ?ys. v = snd (hd ?ys))"
    proof
      assume "(\<forall> (k, v) \<in> set ?ys. v = snd (hd ?ys))"
      hence "(\<forall> p \<in> set ?ys. p = (k, snd (hd ?ys)))"
        by fastforce
      hence "?ys = replicate (length ?ys) (hd ?ys)"
        by (metis False length_0_conv list.set_sel(1) replicate_length_same)
      thus False
        using ys by blast
    qed
    then obtain v where "(k, v) \<in> set ?ys" "v \<noteq> snd (hd ?ys)"
      by fastforce
    hence "(\<not> (\<exists>!y. (k, y) \<in> set xs))"
      using False list.set_sel(1) by fastforce
    then show ?thesis
      by (simp add: rel_apply_def)
  qed
qed

end


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

section\<open>Relations: Their General Properties and Transitive Closure\<close>

theory Trancl imports Fixedpt Perm begin

definition
  refl     :: "[i,i]=>o"  where
    "refl(A,r) == (\<forall>x\<in>A. <x,x> \<in> r)"

definition
  irrefl   :: "[i,i]=>o"  where
    "irrefl(A,r) == \<forall>x\<in>A. <x,x> \<notin> r"

definition
  sym      :: "i=>o"  where
    "sym(r) == \<forall>x y. <x,y>: r \<longrightarrow> <y,x>: r"

definition
  asym     :: "i=>o"  where
    "asym(r) == \<forall>x y. <x,y>:r \<longrightarrow> ~ <y,x>:r"

definition
  antisym  :: "i=>o"  where
    "antisym(r) == \<forall>x y.<x,y>:r \<longrightarrow> <y,x>:r \<longrightarrow> x=y"

definition
  trans    :: "i=>o"  where
    "trans(r) == \<forall>x y z. <x,y>: r \<longrightarrow> <y,z>: r \<longrightarrow> <x,z>: r"

definition
  trans_on :: "[i,i]=>o"  ("trans[_]'(_')")  where
    "trans[A](r) == \<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A.
                          <x,y>: r \<longrightarrow> <y,z>: r \<longrightarrow> <x,z>: r"

definition
  rtrancl :: "i=>i"  ("(_^*)" [100] 100)  (*refl/transitive closure*)  where
    "r^* == lfp(field(r)*field(r), %s. id(field(r)) \<union> (r O s))"

definition
  trancl  :: "i=>i"  ("(_^+)" [100] 100)  (*transitive closure*)  where
    "r^+ == r O r^*"

definition
  equiv    :: "[i,i]=>o"  where
    "equiv(A,r) == r \<subseteq> A*A & refl(A,r) & sym(r) & trans(r)"

subsection\<open>General properties of relations\<close>

subsubsection\<open>irreflexivity\<close>

lemma irreflI:
    "[| !!x. x \<in> A ==> <x,x> \<notin> r |] ==> irrefl(A,r)"
by (simp add: irrefl_def)

lemma irreflE: "[| irrefl(A,r);  x \<in> A |] ==>  <x,x> \<notin> r"
by (simp add: irrefl_def)

subsubsection\<open>symmetry\<close>

lemma symI:
     "[| !!x y.<x,y>: r ==> <y,x>: r |] ==> sym(r)"
by (unfold sym_def, blast)

lemma symE: "[| sym(r); <x,y>: r |]  ==>  <y,x>: r"
by (unfold sym_def, blast)

subsubsection\<open>antisymmetry\<close>

lemma antisymI:
     "[| !!x y.[| <x,y>: r;  <y,x>: r |] ==> x=y |] ==> antisym(r)"
by (simp add: antisym_def, blast)

lemma antisymE: "[| antisym(r); <x,y>: r;  <y,x>: r |]  ==>  x=y"
by (simp add: antisym_def, blast)

subsubsection\<open>transitivity\<close>

lemma transD: "[| trans(r);  <a,b>:r;  <b,c>:r |] ==> <a,c>:r"
by (unfold trans_def, blast)

lemma trans_onD:
    "[| trans[A](r);  <a,b>:r;  <b,c>:r;  a \<in> A;  b \<in> A;  c \<in> A |] ==> <a,c>:r"
by (unfold trans_on_def, blast)

lemma trans_imp_trans_on: "trans(r) ==> trans[A](r)"
by (unfold trans_def trans_on_def, blast)

lemma trans_on_imp_trans: "[|trans[A](r); r \<subseteq> A*A|] ==> trans(r)"
by (simp add: trans_on_def trans_def, blast)

subsection\<open>Transitive closure of a relation\<close>

lemma rtrancl_bnd_mono:
     "bnd_mono(field(r)*field(r), %s. id(field(r)) \<union> (r O s))"
by (rule bnd_monoI, blast+)

lemma rtrancl_mono: "r<=s ==> r^* \<subseteq> s^*"
apply (unfold rtrancl_def)
apply (rule lfp_mono)
apply (rule rtrancl_bnd_mono)+
apply blast
done

(* @{term"r^* = id(field(r)) \<union> ( r O r^* )"}    *)
lemmas rtrancl_unfold =
     rtrancl_bnd_mono [THEN rtrancl_def [THEN def_lfp_unfold]]

(** The relation rtrancl **)

(*  @{term"r^* \<subseteq> field(r) * field(r)"}  *)
lemmas rtrancl_type = rtrancl_def [THEN def_lfp_subset]

lemma relation_rtrancl: "relation(r^*)"
apply (simp add: relation_def)
apply (blast dest: rtrancl_type [THEN subsetD])
done

(*Reflexivity of rtrancl*)
lemma rtrancl_refl: "[| a \<in> field(r) |] ==> <a,a> \<in> r^*"
apply (rule rtrancl_unfold [THEN ssubst])
apply (erule idI [THEN UnI1])
done

(*Closure under composition with r  *)
lemma rtrancl_into_rtrancl: "[| <a,b> \<in> r^*;  <b,c> \<in> r |] ==> <a,c> \<in> r^*"
apply (rule rtrancl_unfold [THEN ssubst])
apply (rule compI [THEN UnI2], assumption, assumption)
done

(*rtrancl of r contains all pairs in r  *)
lemma r_into_rtrancl: "<a,b> \<in> r ==> <a,b> \<in> r^*"
by (rule rtrancl_refl [THEN rtrancl_into_rtrancl], blast+)

(*The premise ensures that r consists entirely of pairs*)
lemma r_subset_rtrancl: "relation(r) ==> r \<subseteq> r^*"
by (simp add: relation_def, blast intro: r_into_rtrancl)

lemma rtrancl_field: "field(r^*) = field(r)"
by (blast intro: r_into_rtrancl dest!: rtrancl_type [THEN subsetD])

(** standard induction rule **)

lemma rtrancl_full_induct [case_names initial step, consumes 1]:
  "[| <a,b> \<in> r^*;
      !!x. x \<in> field(r) ==> P(<x,x>);
      !!x y z.[| P(<x,y>); <x,y>: r^*; <y,z>: r |]  ==>  P(<x,z>) |]
   ==>  P(<a,b>)"
by (erule def_induct [OF rtrancl_def rtrancl_bnd_mono], blast)

(*nice induction rule.
  Tried adding the typing hypotheses y,z \<in> field(r), but these
  caused expensive case splits!*)
lemma rtrancl_induct [case_names initial step, induct set: rtrancl]:
  "[| <a,b> \<in> r^*;
      P(a);
      !!y z.[| <a,y> \<in> r^*;  <y,z> \<in> r;  P(y) |] ==> P(z)
   |] ==> P(b)"
(*by induction on this formula*)
apply (subgoal_tac "\<forall>y. <a,b> = <a,y> \<longrightarrow> P (y) ")
(*now solve first subgoal: this formula is sufficient*)
apply (erule spec [THEN mp], rule refl)
(*now do the induction*)
apply (erule rtrancl_full_induct, blast+)
done

(*transitivity of transitive closure!! -- by induction.*)
lemma trans_rtrancl: "trans(r^*)"
apply (unfold trans_def)
apply (intro allI impI)
apply (erule_tac b = z in rtrancl_induct, assumption)
apply (blast intro: rtrancl_into_rtrancl)
done

lemmas rtrancl_trans = trans_rtrancl [THEN transD]

(*elimination of rtrancl -- by induction on a special formula*)
lemma rtranclE:
    "[| <a,b> \<in> r^*;  (a=b) ==> P;
        !!y.[| <a,y> \<in> r^*;   <y,b> \<in> r |] ==> P |]
     ==> P"
apply (subgoal_tac "a = b | (\<exists>y. <a,y> \<in> r^* & <y,b> \<in> r) ")
(*see HOL/trancl*)
apply blast
apply (erule rtrancl_induct, blast+)
done

(**** The relation trancl ****)

(*Transitivity of r^+ is proved by transitivity of r^*  *)
lemma trans_trancl: "trans(r^+)"
apply (unfold trans_def trancl_def)
apply (blast intro: rtrancl_into_rtrancl
                    trans_rtrancl [THEN transD, THEN compI])
done

lemmas trans_on_trancl = trans_trancl [THEN trans_imp_trans_on]

lemmas trancl_trans = trans_trancl [THEN transD]

(** Conversions between trancl and rtrancl **)

lemma trancl_into_rtrancl: "<a,b> \<in> r^+ ==> <a,b> \<in> r^*"
apply (unfold trancl_def)
apply (blast intro: rtrancl_into_rtrancl)
done

(*r^+ contains all pairs in r  *)
lemma r_into_trancl: "<a,b> \<in> r ==> <a,b> \<in> r^+"
apply (unfold trancl_def)
apply (blast intro!: rtrancl_refl)
done

(*The premise ensures that r consists entirely of pairs*)
lemma r_subset_trancl: "relation(r) ==> r \<subseteq> r^+"
by (simp add: relation_def, blast intro: r_into_trancl)

(*intro rule by definition: from r^* and r  *)
lemma rtrancl_into_trancl1: "[| <a,b> \<in> r^*;  <b,c> \<in> r |]   ==>  <a,c> \<in> r^+"
by (unfold trancl_def, blast)

(*intro rule from r and r^*  *)
lemma rtrancl_into_trancl2:
    "[| <a,b> \<in> r;  <b,c> \<in> r^* |]   ==>  <a,c> \<in> r^+"
apply (erule rtrancl_induct)
 apply (erule r_into_trancl)
apply (blast intro: r_into_trancl trancl_trans)
done

(*Nice induction rule for trancl*)
lemma trancl_induct [case_names initial step, induct set: trancl]:
  "[| <a,b> \<in> r^+;
      !!y.  [| <a,y> \<in> r |] ==> P(y);
      !!y z.[| <a,y> \<in> r^+;  <y,z> \<in> r;  P(y) |] ==> P(z)
   |] ==> P(b)"
apply (rule compEpair)
apply (unfold trancl_def, assumption)
(*by induction on this formula*)
apply (subgoal_tac "\<forall>z. <y,z> \<in> r \<longrightarrow> P (z) ")
(*now solve first subgoal: this formula is sufficient*)
 apply blast
apply (erule rtrancl_induct)
apply (blast intro: rtrancl_into_trancl1)+
done

(*elimination of r^+ -- NOT an induction rule*)
lemma tranclE:
    "[| <a,b> \<in> r^+;
        <a,b> \<in> r ==> P;
        !!y.[| <a,y> \<in> r^+; <y,b> \<in> r |] ==> P
     |] ==> P"
apply (subgoal_tac "<a,b> \<in> r | (\<exists>y. <a,y> \<in> r^+ & <y,b> \<in> r) ")
apply blast
apply (rule compEpair)
apply (unfold trancl_def, assumption)
apply (erule rtranclE)
apply (blast intro: rtrancl_into_trancl1)+
done

lemma trancl_type: "r^+ \<subseteq> field(r)*field(r)"
apply (unfold trancl_def)
apply (blast elim: rtrancl_type [THEN subsetD, THEN SigmaE2])
done

lemma relation_trancl: "relation(r^+)"
apply (simp add: relation_def)
apply (blast dest: trancl_type [THEN subsetD])
done

lemma trancl_subset_times: "r \<subseteq> A * A ==> r^+ \<subseteq> A * A"
by (insert trancl_type [of r], blast)

lemma trancl_mono: "r<=s ==> r^+ \<subseteq> s^+"
by (unfold trancl_def, intro comp_mono rtrancl_mono)

lemma trancl_eq_r: "[|relation(r); trans(r)|] ==> r^+ = r"
apply (rule equalityI)
 prefer 2 apply (erule r_subset_trancl, clarify)
apply (frule trancl_type [THEN subsetD], clarify)
apply (erule trancl_induct, assumption)
apply (blast dest: transD)
done

(** Suggested by Sidi Ould Ehmety **)

lemma rtrancl_idemp [simp]: "(r^*)^* = r^*"
apply (rule equalityI, auto)
 prefer 2
 apply (frule rtrancl_type [THEN subsetD])
 apply (blast intro: r_into_rtrancl )
txt\<open>converse direction\<close>
apply (frule rtrancl_type [THEN subsetD], clarify)
apply (erule rtrancl_induct)
apply (simp add: rtrancl_refl rtrancl_field)
apply (blast intro: rtrancl_trans)
done

lemma rtrancl_subset: "[| R \<subseteq> S; S \<subseteq> R^* |] ==> S^* = R^*"
apply (drule rtrancl_mono)
apply (drule rtrancl_mono, simp_all, blast)
done

lemma rtrancl_Un_rtrancl:
     "[| relation(r); relation(s) |] ==> (r^* \<union> s^*)^* = (r \<union> s)^*"
apply (rule rtrancl_subset)
apply (blast dest: r_subset_rtrancl)
apply (blast intro: rtrancl_mono [THEN subsetD])
done

(*** "converse" laws by Sidi Ould Ehmety ***)

(** rtrancl **)

lemma rtrancl_converseD: "<x,y>:converse(r)^* ==> <x,y>:converse(r^*)"
apply (rule converseI)
apply (frule rtrancl_type [THEN subsetD])
apply (erule rtrancl_induct)
apply (blast intro: rtrancl_refl)
apply (blast intro: r_into_rtrancl rtrancl_trans)
done

lemma rtrancl_converseI: "<x,y>:converse(r^*) ==> <x,y>:converse(r)^*"
apply (drule converseD)
apply (frule rtrancl_type [THEN subsetD])
apply (erule rtrancl_induct)
apply (blast intro: rtrancl_refl)
apply (blast intro: r_into_rtrancl rtrancl_trans)
done

lemma rtrancl_converse: "converse(r)^* = converse(r^*)"
apply (safe intro!: equalityI)
apply (frule rtrancl_type [THEN subsetD])
apply (safe dest!: rtrancl_converseD intro!: rtrancl_converseI)
done

(** trancl **)

lemma trancl_converseD: "<a, b>:converse(r)^+ ==> <a, b>:converse(r^+)"
apply (erule trancl_induct)
apply (auto intro: r_into_trancl trancl_trans)
done

lemma trancl_converseI: "<x,y>:converse(r^+) ==> <x,y>:converse(r)^+"
apply (drule converseD)
apply (erule trancl_induct)
apply (auto intro: r_into_trancl trancl_trans)
done

lemma trancl_converse: "converse(r)^+ = converse(r^+)"
apply (safe intro!: equalityI)
apply (frule trancl_type [THEN subsetD])
apply (safe dest!: trancl_converseD intro!: trancl_converseI)
done

lemma converse_trancl_induct [case_names initial step, consumes 1]:
"[| <a, b>:r^+; !!y. <y, b> :r ==> P(y);
      !!y z. [| <y, z> \<in> r; <z, b> \<in> r^+; P(z) |] ==> P(y) |]
       ==> P(a)"
apply (drule converseI)
apply (simp (no_asm_use) add: trancl_converse [symmetric])
apply (erule trancl_induct)
apply (auto simp add: trancl_converse)
done

end


header {* General purpose definitions and lemmas *}

theory JHelper imports
  Main
begin

lemma Collect_iff:
  "a \<in> {x . P x} \<equiv> P a"
by auto

lemma diff_diff_eq:
  assumes "C \<subseteq> B"
  shows "(A - C) - (B - C) = A - B"
using assms by auto

lemma nth_in_set:
  "\<lbrakk> i < length xs ; xs ! i = x \<rbrakk> \<Longrightarrow> x \<in> set xs" by auto

lemma disjI [intro]:
  assumes "\<not> P \<Longrightarrow> Q"
  shows "P \<or> Q"
using assms by auto

lemma empty_eq_Plus_conv:
  "({} = A <+> B) = (A = {} \<and> B = {})"
by auto

subsection {* Projection functions on triples *}

definition fst3 :: "'a \<times> 'b \<times> 'c \<Rightarrow> 'a"
where "fst3 \<equiv> fst"

definition snd3 :: "'a \<times> 'b \<times> 'c \<Rightarrow> 'b"
where "snd3 \<equiv> fst \<circ> snd"

definition thd3 :: "'a \<times> 'b \<times> 'c \<Rightarrow> 'c"
where "thd3 \<equiv> snd \<circ> snd"

lemma fst3_simp:
  "\<And>a b c. fst3 (a,b,c) = a"
by (auto simp add: fst3_def)

lemma snd3_simp:
  "\<And>a b c. snd3 (a,b,c) = b"
by (auto simp add: snd3_def)

lemma thd3_simp:
  "\<And>a b c. thd3 (a,b,c) = c"
by (auto simp add: thd3_def)

lemma tripleI:
  fixes T U
  assumes "fst3 T = fst3 U"
      and "snd3 T = snd3 U"
      and "thd3 T = thd3 U"
  shows "T = U"
by (metis assms fst3_def snd3_def thd3_def o_def surjective_pairing)

end


(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section \<open>The Category of Measurable Spaces is not Cartesian Closed\<close>

theory Measure_Not_CCC
  imports "~~/src/HOL/Probability/Probability"
begin

text \<open>
  We show that the category of measurable spaces with measurable functions as morphisms is not a
  Cartesian closed category. While the category has products and terminal objects, the exponential
  does not exist for each pair of measurable spaces.

  We show that the exponential $\mathbb{B}^\mathbb{C}$ does not exist, where $\mathbb{B}$ is the
  discrete measurable space on boolean values, and $\mathbb{C}$ is the $\sigma$-algebra consisting
  of all countable and co-countable real sets. We also define $\mathbb{R}$ to be the discrete
  measurable space on the reals.

  Now, the diagonal predicate @{term "\<lambda>x y. x = y"} is $\mathbb{R}$-$\mathbb{B}^\mathbb{C}$-measurable,
  but @{term "\<lambda>(x, y). x = y"} is not $(\mathbb{R} \times \mathbb{C})$-$\mathbb{B}$-measurable.
\<close>

definition COCOUNT :: "real measure" where
  "COCOUNT = sigma UNIV {{x} | x. True}"

abbreviation POW :: "real measure" where
  "POW \<equiv> count_space UNIV"

abbreviation BOOL :: "bool measure" where
  "BOOL \<equiv> count_space UNIV"

lemma measurable_const_iff: "(\<lambda>x. c) \<in> measurable A B \<longleftrightarrow> (space A = {} \<or> c \<in> space B)"
  by (auto simp: measurable_def)

lemma measurable_eq[measurable]: "(op = x) \<in> measurable COCOUNT BOOL"
  unfolding pred_def by (auto simp: COCOUNT_def)

lemma COCOUNT_eq: "A \<in> COCOUNT \<longleftrightarrow> countable A \<or> countable (UNIV - A)"
proof
  fix A assume "A \<in> COCOUNT"
  then have "A \<in> sigma_sets UNIV {{x} | x. True}"
    by (auto simp: COCOUNT_def)
  then show "countable A \<or> countable (UNIV - A)"
  proof induction
    case (Union F)
    moreover
    { fix i assume "countable (UNIV - F i)"
      then have "countable (UNIV - (\<Union>i. F i))"
        by (rule countable_subset[rotated]) auto }
    ultimately show "countable (\<Union>i. F i) \<or> countable (UNIV - (\<Union>i. F i))"
      by blast
  qed (auto simp: Diff_Diff_Int)
next
  assume "countable A \<or> countable (UNIV - A)"
  moreover
  { fix A :: "real set" assume A: "countable A"
    have "A = (\<Union>a\<in>A. {a})"
      by auto
    also have "\<dots> \<in> COCOUNT"
      by (intro sets.countable_UN' A) (auto simp: COCOUNT_def)
    finally have "A \<in> COCOUNT" . }
  note A = this
  note A[of A]
  moreover
  { assume "countable (UNIV - A)"
    with A have "space COCOUNT - (UNIV - A) \<in> COCOUNT" by simp
    then have "A \<in> COCOUNT"
      by (auto simp: COCOUNT_def Diff_Diff_Int) }
  ultimately show "A \<in> COCOUNT"
    by blast
qed

lemma pair_COCOUNT:
  assumes A: "A \<in> sets (COCOUNT \<Otimes>\<^sub>M M)"
  shows "\<exists>J F X. X \<in> sets M \<and> F \<in> J \<rightarrow> sets M \<and> countable J \<and> A = (UNIV - J) \<times> X \<union> (SIGMA j:J. F j)"
  using A unfolding sets_pair_measure
proof induction
  case (Basic X)
  then obtain a b where X: "X = a \<times> b" and b: "b \<in> sets M" and a: "countable a \<or> countable (UNIV - a)"
    by (auto simp: COCOUNT_eq)
  from a show ?case
  proof
    assume "countable a" with X b show ?thesis
      by (intro exI[of _ a] exI[of _ "\<lambda>_. b"] exI[of _ "{}"]) auto
  next
    assume "countable (UNIV - a)" with X b show ?thesis
      by (intro exI[of _ "UNIV - a"] exI[of _ "\<lambda>_. {}"] exI[of _ "b"]) auto
  qed
next
  case Empty then show ?case
    by (intro exI[of _ "{}"] exI[of _ "\<lambda>_. {}"] exI[of _ "{}"]) auto
next
  case (Compl A)
  then obtain J F X where XFJ: "X \<in> sets M" "F \<in> J \<rightarrow> sets M" "countable J"
    and A: "A = (UNIV - J) \<times> X \<union> Sigma J F"
    by auto
  have *: "space COCOUNT \<times> space M - A = (UNIV - J) \<times> (space M - X) \<union> (SIGMA j:J. space M - F j)"
    unfolding A by (auto simp: COCOUNT_def)
  show ?case
    using XFJ unfolding *
    by (intro exI[of _ J] exI[of _ "space M - X"] exI[of _ "\<lambda>j. space M - F j"]) auto
next
  case (Union A)
  obtain J F X where XFJ: "\<And>i. X i \<in> sets M" "\<And>i. F i \<in> J i \<rightarrow> sets M" "\<And>i. countable (J i)"
    and A_eq: "A = (\<lambda>i. (UNIV - J i) \<times> X i \<union> Sigma (J i) (F i))"
    unfolding fun_eq_iff using Union.IH by metis
  show ?case
  proof (intro exI conjI)
    define G where "G j = (\<Union>i. if j \<in> J i then F i j else X i)" for j
    show "(\<Union>i. X i) \<in> sets M" "countable (\<Union>i. J i)" "G \<in> (\<Union>i. J i) \<rightarrow> sets M"
      using XFJ by (auto simp: G_def Pi_iff)
    show "UNION UNIV A = (UNIV - (\<Union>i. J i)) \<times> (\<Union>i. X i) \<union> (SIGMA j:\<Union>i. J i. \<Union>i. if j \<in> J i then F i j else X i)"
      unfolding A_eq by (auto split: if_split_asm)
  qed
qed

context
  fixes EXP :: "(real \<Rightarrow> bool) measure"
  assumes eq: "\<And>P. case_prod P \<in> measurable (POW \<Otimes>\<^sub>M COCOUNT) BOOL \<longleftrightarrow> P \<in> measurable POW EXP"
begin

lemma space_EXP: "space EXP = measurable COCOUNT BOOL"
proof -
  { fix f
    have "f \<in> space EXP \<longleftrightarrow> (\<lambda>(a, b). f b) \<in> measurable (POW \<Otimes>\<^sub>M COCOUNT) BOOL"
      using eq[of "\<lambda>x. f"] by (simp add: measurable_const_iff)
    also have "\<dots> \<longleftrightarrow> f \<in> measurable COCOUNT BOOL"
      by auto
    finally have "f \<in> space EXP \<longleftrightarrow> f \<in> measurable COCOUNT BOOL" . }
  then show ?thesis by auto
qed

lemma measurable_eq_EXP: "(\<lambda>x y. x = y) \<in> measurable POW EXP"
  unfolding measurable_def by (auto simp: space_EXP)

lemma measurable_eq_pair: "(\<lambda>(y, x). x = y) \<in> measurable (COCOUNT \<Otimes>\<^sub>M POW) BOOL"
  using measurable_eq_EXP unfolding eq[symmetric]
  by (subst measurable_pair_swap_iff) simp

lemma ce: False
proof -
  have "{(y, x) \<in> space (COCOUNT \<Otimes>\<^sub>M POW). x = y} \<in> sets (COCOUNT \<Otimes>\<^sub>M POW)"
    using measurable_eq_pair unfolding pred_def by (simp add: split_beta')
  also have "{(y, x) \<in> space (COCOUNT \<Otimes>\<^sub>M POW). x = y} = (SIGMA j:UNIV. {j})"
    by (auto simp: space_pair_measure COCOUNT_def)
  finally obtain X F J where "countable (J::real set)"
    and eq: "(SIGMA j:UNIV. {j}) = (UNIV - J) \<times> X \<union> (SIGMA j:J. F j)"
    using pair_COCOUNT[of "SIGMA j:UNIV. {j}" POW] by auto
  have X_single: "\<And>x. x \<notin> J \<Longrightarrow> X = {x}"
    using eq[unfolded set_eq_iff] by force

  have "uncountable (UNIV - J)"
    using \<open>countable J\<close> uncountable_UNIV_real uncountable_minus_countable by blast
  then have "infinite (UNIV - J)"
    by (auto intro: countable_finite)
  then have "\<exists>A. finite A \<and> card A = 2 \<and> A \<subseteq> UNIV - J"
    by (rule infinite_arbitrarily_large)
  then obtain i j where ij: "i \<in> UNIV - J" "j \<in> UNIV - J" "i \<noteq> j"
    by (auto simp add: card_Suc_eq numeral_2_eq_2)
  have "{(i, i), (j, j)} \<subseteq> (SIGMA j:UNIV. {j})" by auto
  with ij X_single[of i] X_single[of j] show False
    by auto
qed

end

corollary "\<not> (\<exists>EXP. \<forall>P. case_prod P \<in> measurable (POW \<Otimes>\<^sub>M COCOUNT) BOOL \<longleftrightarrow> P \<in> measurable POW EXP)"
  using ce by blast

end


theory pochhammer_monomials
  imports "~~/src/HOL/Computational_Algebra/Formal_Power_Series"
          "~~/src/HOL/Computational_Algebra/Polynomial"
          "~~/src/HOL/Computational_Algebra/Polynomial_FPS"
begin

(************************************Leading term function*****************************************)

abbreviation "X \<equiv> [:0,1:]"

definition leading_term:: "'a::zero poly \<Rightarrow> 'a poly" where
"leading_term p \<equiv> monom (lead_coeff p) (degree p)"

lemma leading_term_idem:
"leading_term (leading_term p) = leading_term p"
  by (metis (no_types, lifting)
      degree_monom_eq lead_coeff_monom
      leading_term_def monom_eq_iff')

lemma leading_term_degree:
"degree p = degree (leading_term p)"
  by (metis degree_monom_eq lead_coeff_monom leading_coeff_0_iff leading_term_def)

lemma leading_term_lead_coeff:
"lead_coeff p = lead_coeff (leading_term p)"
  by (metis lead_coeff_monom leading_term_def)

lemma minus_leading_term:
  assumes "degree p >0"
  shows "degree (p - (leading_term p))< degree p"
proof-
  let ?n = "degree p"
  let ?q = "p - (leading_term p)"
  show "degree ?q < ?n"
  proof-
    have M: "max (degree p) (degree (leading_term p)) = ?n"
      using leading_term_degree by (metis max.idem)
    then have  "degree ?q \<le> max (degree p) (degree (leading_term p))" using degree_diff_le_max
    proof -
    { assume "0 \<noteq> p \<and> p - leading_term p \<noteq> 0"
      moreover
      { assume "0 - coeff (leading_term p) (degree (p - leading_term p)) = 0 \<and> p - leading_term p \<noteq> 0"
        then have "degree (p - leading_term p) \<le> degree p"
          by (metis le_degree leading_coeff_0_iff minus_poly.rep_eq) }
      ultimately have "degree (p - leading_term p) \<le> degree p"
      by (metis (no_types) cancel_comm_monoid_add_class.diff_cancel le_degree leading_term_degree) }
  then show ?thesis
    by (metis (no_types) assms degree_0 leading_term_degree linear max.idem not_le)
    qed
    then have le:  "degree ?q \<le> ?n"
      using M  by simp
    have "coeff ?q ?n = 0"
      by (simp add: leading_term_def)
    then have "degree ?q \<noteq> ?n"
      by (metis assms degree_0 le leading_coeff_neq_0 not_le)
    then show ?thesis using le by simp
  qed
qed

lemma leading_term_eq_deg_less:
  assumes "degree p1 > 0"
  assumes "leading_term p1 = leading_term p2"
  shows "degree (p1 - p2) < degree p1"
proof-
  let ?q = "p1 - p2"
  let ?n = "degree p1"
  have "degree p2 = ?n"
    using assms(2) leading_term_degree by metis
  then have "coeff ?q ?n = 0"
    by (metis assms(2) cancel_comm_monoid_add_class.diff_cancel coeff_diff leading_term_lead_coeff)
  then show "degree ?q < ?n"
    by (smt One_nat_def Suc_le_eq Suc_pred
        \<open>degree p2 = degree p1\<close> assms(1)
        coeff_0_degree_minus_1 coeff_diff
        degree_0 le_degree leading_coeff_0_iff not_le)
qed

lemma leading_term_decomp:
  assumes "degree (p::('a::comm_ring_1) poly) >0"
  obtains q where "p = q + (leading_term p)" and "degree q < degree p"
proof-
  let ?q = "p - (leading_term p)"
  let ?n = "degree p"
  have 0:"degree ?q < ?n"
    using minus_leading_term assms by blast
  have 1:"p = ?q + (leading_term p)" by simp
  then show ?thesis
    using 0 1 that by blast
qed

lemma leading_term_mult:
  assumes "(a ::'a::comm_ring_1)*b \<noteq>0"
  assumes "a = lead_coeff p"
  assumes "b = lead_coeff q"
  assumes "degree p > 0"
  assumes "degree q >0"
  shows "leading_term (p*q) = (leading_term p)*(leading_term q)"
proof-
  obtain p1 where "p = leading_term p + p1" and "degree p1 < degree p"
    using leading_term_decomp  by (metis add.commute assms(4))
  obtain q1 where "q = leading_term q + q1" and "degree q1 < degree q"
    using leading_term_decomp  by (metis add.commute assms(5))
  then have "p*q = (leading_term p)*(leading_term q) + p1*(leading_term q) + q1*(leading_term p) + p1*q1"
    by (metis \<open>p = leading_term p + p1\<close> add.assoc mult.commute ring_class.ring_distribs(1))
  then have "p*q = (monom a (degree p))*(monom b (degree q)) + p1*(leading_term q) + q1*(leading_term p) + p1*q1"
    by (simp add: assms(2) assms(3) leading_term_def)
  then have "p*q = (monom (a*b) ((degree p)+(degree q))) + p1*(leading_term q) + q1*(leading_term p) + p1*q1"
    by (simp add: mult_monom)
  then show ?thesis
    by (metis (no_types, lifting) assms(1)
        assms(2) assms(3) coeff_mult_degree_sum
        degree_mult_le le_degree leading_term_def
        mult_monom order_antisym)
qed

lemma times_X_degree:
  assumes "(p::('a::comm_ring_1) poly) \<noteq>0"
  shows "degree (X*p) = (Suc (degree p))"
  by (simp add: assms)

lemma leading_term_mult_X:
  assumes "degree (p::('a::comm_ring_1) poly) \<noteq>0"
  shows "leading_term (X*p) = X*(leading_term p)"
proof-
  have "leading_term (X*p) = leading_term (X*(leading_term p))"
  proof -
    have "\<forall>p. degree p = degree (monom (lead_coeff p::'a) (degree p))"
      by (metis leading_term_def leading_term_degree)
    then show ?thesis
      by (simp add: leading_term_def)
  qed
  have "leading_term(X*(leading_term p)) = X*leading_term p"
    by (metis (no_types, lifting) assms coeff_pCons_Suc
      degree_0 leading_term_def leading_term_degree
      leading_term_lead_coeff monom_Suc mult.commute
      mult.right_neutral mult_pCons_left one_pCons smult_0_left times_X_degree)
  then show ?thesis
    using \<open>leading_term (X * p) = leading_term (X * leading_term p)\<close> by auto
qed

lemma leading_term_sum:
  assumes "degree p0 = degree p1"
  assumes "degree q < degree p0"
  assumes "p0 = p1 + q"
  shows "leading_term p0 = leading_term p1"
  by (metis add.commute assms(1) assms(2)
      assms(3) lead_coeff_add_le leading_term_def)

lemma monom_leading_term_monic_lin_comp0:
  assumes "b \<noteq>0"
  assumes A: "degree a = 0"
  shows "leading_term ((monom b n) \<circ>\<^sub>p (X + a)) = leading_term ((monom b n)::('a::comm_ring_1) poly)"
proof(induction n)
  case 0
  then show ?case by (simp add: monom_0)
next
  case (Suc n)
  fix n
  assume IH: "leading_term (monom b n \<circ>\<^sub>p (X + a)) = leading_term (monom b n)"
  show "leading_term (monom b (Suc n) \<circ>\<^sub>p (X + a)) = leading_term (monom b (Suc n)) "
  proof-
    have 0: "(monom b (Suc n)) =(monom b n)* (monom 1 1)"
       by (simp add: mult_monom)
    then have "(monom b (Suc n))\<circ>\<^sub>p(X + a) =(monom b n) \<circ>\<^sub>p(X + a)* (monom 1 1) \<circ>\<^sub>p(X+ a)"
      by (simp add: pcompose_mult)
    then have "(monom b (Suc n))\<circ>\<^sub>p(X + a) = (monom b n) \<circ>\<^sub>p(X+ a)*(X + a)"
      by (simp add: monom_Suc mult.commute pcompose_pCons)
    then have Q: "(monom b (Suc n))\<circ>\<^sub>p(X + a) = X*(monom b n) \<circ>\<^sub>p(X+ a) + a*(monom b n) \<circ>\<^sub>p(X+ a)"
      by (simp add: mult.commute mult_poly_add_left)
    have "((monom b n) \<circ>\<^sub>p(X+ a)) \<noteq>0"
      by (metis IH assms(1) lead_coeff_monom leading_coeff_0_iff leading_term_def)
    then have R: "degree (X*(monom b n) \<circ>\<^sub>p(X+ a)) = 1+  degree  ((monom b n) \<circ>\<^sub>p(X+ a))"
      by simp
    then have S: " degree ((monom b (Suc n))\<circ>\<^sub>p(X + a)) =  degree (X*(monom b n) \<circ>\<^sub>p(X+ a))"
      using Q by (smt A One_nat_def add.commute add_Suc comm_monoid_mult_class.mult_1
        degree_add_eq_left degree_mult_le degree_of_nat leading_term_degree
        leading_term_sum linorder_neqE_nat linorder_not_le not_less_eq_eq
        of_nat_1 one_poly_eq_simps(2) plus_1_eq_Suc)
    have "degree  ((monom b n) \<circ>\<^sub>p(X+ a)) \<ge> degree  (a*(monom b n) \<circ>\<^sub>p(X+ a))"
      using A degree_mult_le by (metis One_nat_def add_Suc
                        not_less_eq_eq plus_1_eq_Suc)
    then have T: "degree (X*(monom b n) \<circ>\<^sub>p(X+ a)) >  degree  (a*(monom b n) \<circ>\<^sub>p(X+ a))"
      using R by linarith
    let ?p0 = "(monom b (Suc n))\<circ>\<^sub>p(X + a) "
    let ?p1 = "(X*(monom b n) \<circ>\<^sub>p(X+ a))"
    let ?q = "(a*(monom b n) \<circ>\<^sub>p(X+ a))"
    have P0: "degree ?p0 = degree ?p1" using S by auto
    have P1: "degree ?q < degree ?p1" using T by auto
    have P2: "?p0 = ?p1 + ?q" using Q by auto
    have "leading_term ?p0 = leading_term ?p1"
      using P0 P1 P2 leading_term_sum by (simp add: leading_term_sum)
    then show ?thesis
      using IH by (metis (no_types, lifting) One_nat_def R 0 assms(1)
          coeff_mult_degree_sum degree_monom_eq lead_coeff_monom
          leading_term_def monom_Suc monom_eq_1 mult.commute
          one_neq_zero one_pCons plus_1_eq_Suc)
  qed
qed

lemma monom_leading_term_monic_lin_comp:
  assumes "b \<noteq>0"
  assumes A: "degree a = 0"
  shows "leading_term ((monom b n) \<circ>\<^sub>p (X + a)) = ((monom b n)::('a::comm_ring_1) poly)"
  using monom_leading_term_monic_lin_comp0
  by (metis A assms(1) degree_monom_eq lead_coeff_monom leading_term_def)

lemma comp_lin_degree:
  assumes A: "degree (a::('a::comm_ring_1) poly) = 0"
  shows "degree (p \<circ>\<^sub>p (X + a)) = degree p"
proof(cases "degree p = 0")
  case True
  then show ?thesis
    by (metis degree_eq_zeroE pcompose_const)
next
  case False
  let ?q = "p - (leading_term p)"
  have "degree ?q < degree p"
    using False minus_leading_term by auto
  have LE:"degree (?q \<circ>\<^sub>p (X+a)) \<le>degree ?q"
    using A by (metis (mono_tags, lifting)
        One_nat_def degree_add_eq_left degree_pCons_eq_if
        degree_pcompose_le mult.right_neutral
        one_neq_zero one_pCons zero_less_one)
  obtain b where I:"leading_term p = monom b (degree p)"
     by (simp add: leading_term_def)
  have N: "b \<noteq>0"
     using False by (metis I degree_0
         leading_term_degree monom_eq_0_iff)
  let ?m = "(monom b (degree p))"
  have B: "leading_term (?m \<circ>\<^sub>p(X + a)) = ?m"
    using A N monom_leading_term_monic_lin_comp by auto
  have "leading_term p = ?m"
    by (simp add: I)
  have P0: "degree ?m = degree (?m \<circ>\<^sub>p (X + a))"
    by (metis B leading_term_degree)
  have "p \<circ>\<^sub>p (X + a) = (?m \<circ>\<^sub>p (X + a)) + (?q \<circ>\<^sub>p (X + a))"
    by (simp add: I pcompose_diff)
  then have "degree (p \<circ>\<^sub>p (X + a)) = degree ?m"
    using P0 LE by (metis (no_types, lifting) I
      \<open>degree (p - leading_term p) < degree p\<close>
      add_lessD1 degree_add_eq_left le_add_diff_inverse
      leading_term_degree)
  then show ?thesis by (simp add: N degree_monom_eq)
qed

lemma leading_term_monic_lin_comp:
  assumes "degree a = 0"
  shows "leading_term (p \<circ>\<^sub>p (X + a)) = leading_term (p::('a::comm_ring_1) poly)"
proof(cases "degree p = 0")
  case True
  then show ?thesis
    by (metis degree_eq_zeroE pcompose_const)
next
  case False
  obtain q where E: "p = q + (leading_term p)" and D: "degree q < degree p"
    using leading_term_decomp False by blast
  then have P0: "leading_term ((leading_term p) \<circ>\<^sub>p (X + a)) = (leading_term p)"
    using monom_leading_term_monic_lin_comp by (metis (no_types, lifting)
        False assms degree_0 leading_coeff_0_iff leading_term_def)
  have "p \<circ>\<^sub>p (X + a) = q \<circ>\<^sub>p (X + a) + (leading_term p) \<circ>\<^sub>p (X + a)"
    using E by (metis pcompose_add)
  have P1: "degree (q \<circ>\<^sub>p (X + a)) < degree (p \<circ>\<^sub>p (X + a))"
    using D by (simp add: assms comp_lin_degree)
  have "degree (p \<circ>\<^sub>p (X + a)) = degree p"
     by (simp add: assms comp_lin_degree)
  then have "leading_term (p \<circ>\<^sub>p (X + a)) = leading_term ((leading_term p) \<circ>\<^sub>p (X + a))"
    by (smt D \<open>p \<circ>\<^sub>p (X + a) = q \<circ>\<^sub>p (X + a) + leading_term p \<circ>\<^sub>p (X + a)\<close>
        add.commute assms comp_lin_degree leading_term_degree
        leading_term_sum)
  then show ?thesis using P0 by auto
qed

(**************************************Pochhammer monomial constructor*****************************)

fun pochhammer_monom:: "'a::comm_ring_1 \<Rightarrow> nat  \<Rightarrow> 'a::comm_ring_1 poly" ("PM _ _")  where
"pochhammer_monom a 0 = monom a 0"|
"pochhammer_monom a (Suc n) = (X - (of_nat n))*(pochhammer_monom a n)"

lemma pochhammer_monom_alt_def:
"pochhammer_monom a n = smult a (pochhammer (X - (of_nat n) + 1) n)"
proof(induction n)
  case 0
  then show ?case  by (simp add: monom_0)
next
  case (Suc n)
  fix n
  assume IH : " (PM a n) = smult a (pochhammer (X - of_nat n + 1) n)"
  show "(PM a (Suc n)) = smult a (pochhammer (X - (of_nat (Suc n)) + 1) (Suc n))"
  proof-
    have "(PM a (Suc n)) = (X - (of_nat n))*(PM a n)"
      by simp
    then have "(PM a (Suc n)) = (X - (of_nat n))* (smult a (pochhammer (X - of_nat n + 1) n))"
      by (simp add: IH)
    then show ?thesis by (simp add: pochhammer_rec)
  qed
qed

lemma pochhammer_zero_root:
  shows "poly (PM (a::('a::comm_ring_1)) (Suc n)) 0 = 0"
proof-
  let ?n = "Suc n"
  have "(pochhammer  ((X::'a poly) - (of_nat ?n) + 1) ?n) = (( (X - (of_nat ?n) + 1) + (of_nat n))* (pochhammer  (X - (of_nat ?n) + 1) n))"
    using pochhammer_rec'  by blast
  then have "(pochhammer  ((X::'a poly) - (of_nat ?n) + 1) ?n) = X* (pochhammer  (X - (of_nat ?n) + 1) n)"
    by simp
  then have  "(PM (a::('a::comm_ring_1)) (Suc n)) = smult a ( X* (pochhammer  (X - (of_nat ?n) + 1) n))"
    by (simp add: pochhammer_monom_alt_def)
  then show ?thesis by simp
qed

lemma pochhammer_roots:
"k < n \<Longrightarrow> poly (PM (a::('a::comm_ring_1)) n) (of_nat k) = 0"
proof(induction n)
  case 0
  then show ?case
    by simp
next
  case (Suc n)
  fix n
  assume IH0: "(k < n) \<Longrightarrow> poly (PM a n) (of_nat k) = 0"
  assume IH1: "k < Suc n"
  have "(PM a (Suc n)) = (X - (of_nat n))*(PM a n)"
    by simp
  then show "poly (PM a (Suc n)) (of_nat k) = 0"
    using IH0 IH1 by (metis (no_types, lifting) diff_0
        diff_pCons diff_zero dvdI less_SucE mult_not_zero
        of_nat_poly poly_eq_0_iff_dvd poly_mult)
qed

lemma pochhammer_eval_nat:
  assumes "(a::('a::{idom, ring_char_0})) \<noteq>0"
  shows "k \<ge> d \<Longrightarrow> poly (PM a d) (of_nat k) = a * (of_nat (k choose d))*(pochhammer 1 d)"
proof(induction d)
  case 0
  have "(PM a 0)= smult a 1"
    by (simp add: monom_0)
  then show ?case
    by simp
next
  case (Suc n)
  fix n
  assume IH0: "k \<ge> n\<Longrightarrow>poly (PM a n) (of_nat k) = a * (of_nat (k choose n))*(pochhammer 1 n)"
  assume IH1: "k \<ge> Suc n"
  have "(PM a (Suc n)) = (X - of_nat n)*(PM a n)"
    by simp
  then have "poly (PM a (Suc n)) (of_nat k) = (poly (X - of_nat n) (of_nat k))* a * (of_nat (k choose n))*(pochhammer 1 n)"
    using IH0 IH1 by simp
  then have "poly (PM a (Suc n)) (of_nat k) = ((of_nat k) - of_nat n)* a * (of_nat (k choose n))*(pochhammer 1 n)"
    by (simp add: of_nat_poly)
  then have "poly (PM a (Suc n)) (of_nat k) =  a * ((of_nat k) - of_nat n)*(of_nat (k choose n))*(pochhammer 1 n)"
    by simp
  then have "poly (PM a (Suc n)) (of_nat k) =  a * (of_nat (k - n))*(of_nat (k choose n))*(pochhammer 1 n)"
    by (metis add_diff_cancel_left' binomial_eq_0
        le_add_diff_inverse linorder_not_le
        mult_cancel_right of_nat_add of_nat_eq_0_iff)
  then have "poly (PM a (Suc n)) (of_nat k) =  a * (of_nat ((k - n)*(k choose n)*(pochhammer 1 n)))"
    by (metis (no_types, lifting) mult.assoc
        of_nat_1 of_nat_mult pochhammer_of_nat)
  then have "poly (PM a (Suc n)) (of_nat k) =  a *(of_nat (k choose (Suc n))*(pochhammer 1 (Suc n)))"
    by (smt binomial_absorb_comp binomial_absorption mult.assoc
        mult.left_commute of_nat_1 of_nat_add of_nat_mult
        plus_1_eq_Suc pochhammer_of_nat pochhammer_rec')
  then show "poly (PM a (Suc n)) (of_nat k) = a * (of_nat (k choose Suc n)) *( pochhammer 1 (Suc n))"
    by simp
qed

lemma pochhammer_monom_pcompose:
"pcompose (pochhammer_monom a n) p =  smult a (pochhammer (p - (of_nat n) + 1) n)"
proof(induction n)
  case 0
  then show ?case by (simp add: pochhammer_monom_alt_def)
next
  case (Suc n)
  fix n
  assume IH: " (PM a n) \<circ>\<^sub>p p = smult a (pochhammer (p - of_nat n + 1) n)"
  show "(PM a (Suc n)) \<circ>\<^sub>p p = smult a (pochhammer (p - of_nat (Suc n) + 1) (Suc n))"
  proof-
    have  "(PM a (Suc n)) \<circ>\<^sub>p p = (X - (of_nat n)) \<circ>\<^sub>p p *(PM a n) \<circ>\<^sub>p p "
      by (simp add: pcompose_mult)
    then have "(PM a (Suc n)) \<circ>\<^sub>p p = (p - (of_nat n)) *(PM a n) \<circ>\<^sub>p p "
      using pcompose_pCons by (metis (no_types, lifting) add_cancel_left_left
        mult.commute mult.left_neutral of_nat_poly
        pCons_0_0 pCons_one pcompose_const pcompose_diff)
    then show ?thesis
      using IH pochhammer_monom_alt_def by (simp add: pochhammer_rec)
  qed
qed

(*******************************Pochhammer monomials have the correct degree***********************)

lemma pochhammer_leading_term:
  assumes "a \<noteq>0"
  shows "leading_term (pochhammer_monom a n) = monom a n"
proof(induction n)
  case 0
  then show ?case
    by (simp add: leading_term_def monom_0)
next
  case (Suc n)
  fix n
  assume IH: "leading_term (pochhammer_monom a n) = monom a n"
  show "leading_term (pochhammer_monom a (Suc n)) = monom a (Suc n)"
  proof-
    have P0:"pochhammer_monom a (Suc n)
            = (X - (of_nat n))*(pochhammer_monom a n)" by simp
    then have P1: "pochhammer_monom a (Suc n)
            = X*(pochhammer_monom a n) - (of_nat n)*(pochhammer_monom a n)"
      by (simp add: left_diff_distrib')
    have "(pochhammer_monom a n) \<noteq>0"
      by (metis IH assms coeff_diff degree_0
          degree_monom_eq diff_numeral_special(9)
          lead_coeff_monom leading_term_lead_coeff
          monom_eq_1 one_neq_zero)
    then have "degree (X*(monom a n)) > degree ((of_nat n)*(monom a n))"
      using degree_of_nat  by (metis add.left_neutral assms degree_mult_le
              degree_pCons_eq linorder_not_le monom_eq_0_iff
              mult.left_neutral mult_pCons_left not_less_eq_eq one_pCons smult_0_left)
    then have P2: "degree (X*(pochhammer_monom a n)) > degree ((of_nat n)*(pochhammer_monom a n))"
      using IH by (metis (no_types, lifting) add.left_neutral
                    degree_mult_le degree_of_nat degree_pCons_eq
                    lead_coeff_monom  leading_term_def  linorder_not_le
                    monom_eq_0_iff mult.left_neutral mult_pCons_left
                    not_less_eq_eq  one_pCons smult_0_left)
    then have "degree (pochhammer_monom a (Suc n))  = degree (X*(pochhammer_monom a n))"
      using P1 P2  by (smt IH P0 assms coeff_mult_degree_sum
                    degree_mult_le degree_pCons_eq diff_pCons
                    diff_zero le_degree lead_coeff_1 lead_coeff_monom
                    lead_coeff_pCons(1) leading_term_def mult.left_neutral
                    of_nat_poly one_neq_zero one_pCons order_antisym)
    then show ?thesis
      by (smt IH P1 P2 add.left_neutral
        assms coeff_diff degree_monom_eq
        degree_pCons_eq_if diff_zero le_degree
        lead_coeff_monom lead_coeff_pCons(1)
        leading_term_def linorder_not_le
        mult.left_neutral mult_not_zero
        mult_pCons_left one_pCons smult_0_left)
  qed
qed

lemma pochhammer_monom_degree:
  assumes "a \<noteq>0"
  shows "degree (pochhammer_monom a n) = n"
  using pochhammer_leading_term leading_term_degree by (metis assms degree_monom_eq)

(*****************************Pochhammer leading term function*************************************)

definition pochhammer_lt::"'a::comm_ring_1 poly \<Rightarrow> 'a poly" where
"pochhammer_lt p \<equiv> pochhammer_monom (lead_coeff p) (degree p)"

lemma pochhammer_lt_degree:
"degree (pochhammer_lt p) = degree p"
  by (metis  coeff_0_reflect_poly coeff_0_reflect_poly_0_iff
      degree_0 monom_eq_0 pochhammer_lt_def
      pochhammer_monom.simps(1) pochhammer_monom_degree)

lemma minus_pochhammer_leading_term:
  assumes "degree p >0"
  shows "degree (p - (pochhammer_lt p))< degree p"
proof-
  let ?n = "degree p"
  let ?q = "p - (pochhammer_lt p)"
  show "degree ?q < ?n"
  proof-
    have "leading_term p = leading_term ((pochhammer_lt p))"
      by (metis assms degree_0 leading_coeff_0_iff
        leading_term_def neq0_conv pochhammer_leading_term
        pochhammer_lt_def)
    then show ?thesis by (simp add: assms leading_term_eq_deg_less)
  qed
qed

lemma pochhammer_leading_term_decomp:
  assumes "degree (p::('a::comm_ring_1) poly) >0"
  obtains q where "p = q + (pochhammer_lt p)" and "degree q < degree p"
proof-
  let ?q = "p - (pochhammer_lt p)"
  let ?n = "degree p"
  have 0:"degree ?q < ?n"
    using minus_pochhammer_leading_term assms by blast
  then show ?thesis
    using that by force
qed

lemma pochhammer_monom_id:
  shows "(X - (of_nat n) + 1)*((PM a n) \<circ>\<^sub>p (X + 1)) = (X+1)*(PM a n)"
proof(induction n)
  case 0
  then show ?case by (simp add: monom_0)
next
  case (Suc n)
  fix n
  assume IH: "(X - (of_nat n) + 1)*((PM a n) \<circ>\<^sub>p (X + 1)) = (X+1)*(PM a n)"
  show "(X - (of_nat (Suc n)) + 1)*((PM a (Suc n)) \<circ>\<^sub>p (X + 1)) = (X+1)*(PM a (Suc n))"
    using pochhammer_monom_alt_def by (smt IH add.commute add_diff_cancel_left
        diff_add_eq mult.assoc mult.commute mult_smult_right
        of_nat_Suc pochhammer_monom_pcompose pochhammer_rec)
qed

(*******************Difference operator diff: p(x) \<Longrightarrow> p(x+1) - p(x)*******************************)

definition diff:: "('a::comm_ring_1) poly \<Rightarrow> ('a::comm_ring_1) poly" where
"diff p = pcompose  p [:1, 1:] - p"

(*difference operator is linear*)

lemma diff_additive:
"diff (p + q) = diff p + diff q"
  by (simp add: pcompose_add diff_def)

lemma diff_smult:
"diff (smult a q) = smult a (diff q)"
  by (simp add: diff_def pcompose_smult smult_diff_right)

lemma diff_mult_deg0:
  assumes "degree q = 0"
  shows "diff (q*p) = q* (diff p)"
  by (metis (no_types, lifting) assms degree_eq_zeroE
      diff_def left_diff_distrib' mult.commute pcompose_const pcompose_mult)

(**************************the difference operator evaluates as it should**************************)

lemma(in comm_ring_1)  diff_poly:
  shows "(poly (diff p)) x = ((poly p) (x+1)) - ((poly p) x)"
    by (simp add: diff_def poly_pcompose Groups.add_ac(2))

(******************************iterates of the difference operator*********************************)

fun diff_pow:: "nat \<Rightarrow> ('a::comm_ring_1) poly \<Rightarrow> 'a poly" ("\<Delta>[_]_ ") where
diff_pow_0: "diff_pow 0 p = p"|
diff_pow_suc: "diff_pow (Suc n) p = diff (diff_pow n p)"

lemma diff_pow_compose: "diff_pow (n+m) p = diff_pow n (diff_pow m p)"
proof(induction n arbitrary: m)
  case 0
  then show ?case
    by simp
next
  case (Suc n)
  then show ?case
    by simp
qed

lemma diff_pow_additive: "diff_pow n (p+q) = (diff_pow n p) + (diff_pow n q)"
 proof(induction n)
  case 0
  then show ?case
    using diff_pow_0 by simp
next
  case (Suc n)
  then show ?case
    by (simp add: diff_additive)
qed

(********************characterization of degree in terms of the difference operator****************)

lemma diff_const:
assumes "degree p = 0"
shows "diff p = 0"
proof-
  have "pcompose  p [:1, 1:] = p"
    using assms by (metis degree_eq_zeroE pcompose_const)
  then show ?thesis by (simp add: diff_def)
qed

lemma diff_pow_const:
assumes "degree p = 0"
shows "diff_pow (Suc n) p = 0"
proof(induction n)
  case 0
  then show ?case
    by (simp add: diff_const assms)
next
  case (Suc n)
  then show ?case
    by (simp add: diff_const)
qed

lemma one_not_zero:
"([:1:]:: ('a::comm_ring_1) poly) \<noteq> [:0:]"
  by simp

lemma diff_degree:
  assumes "degree (p::('a::{comm_ring_1}) poly) > 0"
  shows "degree p > (degree (diff p))"
proof-
  have 0:"lead_coeff [:1, 1:] = 1"
    by simp
  have "degree [:(1::'a), 1:] =  (Suc (degree [:1:]))" using  degree_pCons_eq one_not_zero
    by simp
  then have 1: "degree [:(1::'a), 1:] = 1"
    by simp
  then have "degree ([:(1::'a), 1:]) > 0"
    by simp
  then have 2: "leading_term (pcompose  p [:1, 1:]) = leading_term p"
    by (metis (no_types, lifting) add.left_neutral
        add.right_neutral add_pCons degree_1
          leading_term_monic_lin_comp one_pCons)
  from 1 have "degree (pcompose p [:1,1:]) = degree p"
     by (metis "2" leading_term_degree)
  then show ?thesis
    using 2 assms(1) diff_def leading_term_eq_deg_less by metis
qed

(*remove SMT!*)
lemma diff_pow_degree0:
  assumes "degree (p::('a::{comm_ring_1}) poly) > 0"
  shows "n <degree p \<Longrightarrow>(degree p) - n \<ge> degree ((diff_pow n) p)"
proof(induction n)
  case 0
  then show ?case
   by (simp add: assms(1))
next
  case (Suc n)
  fix n
  assume IH: "n < degree p \<Longrightarrow> degree (diff_pow n p) \<le> degree p - n"
  show "Suc n < degree p \<Longrightarrow> degree (diff_pow (Suc n) p) \<le> degree p - (Suc n)"
  proof-
    assume "Suc n < degree p"
    consider "degree (diff_pow n p) = 0" | "degree (diff_pow n p) >0"
      by blast
    have "degree (diff_pow n p) = 0 \<or> degree (diff_pow (Suc n) p) < degree (diff_pow n p)"
        using diff_pow_suc diff_degree  by auto
    then show ?thesis
      using IH by (smt Suc_diff_Suc \<open>Suc n < degree p\<close>
          degree_0 diff_const le_Suc_eq less_Suc_eq_le
          less_eq_nat.simps(1) less_le_trans not_le
          pochhammer_monomials.diff_pow_suc)
  qed
qed

(********The nth iterate of the difference operator sends degree m<n polynomials to 0*************)

lemma diff_pow_zero:
  shows "degree (p::('a::{comm_ring_1}) poly) <n \<Longrightarrow> diff_pow n p = 0"
proof(cases "degree p = 0")
  case True
  assume  "degree p <n"
  then have "n >0" by auto
  then show "diff_pow n p = 0" using diff_pow_const
    by (metis Suc_pred True)
next
  case False
  assume A: "degree p <n"
  then have B: "degree p > 0" using False by simp
  let ?n = "(degree p) - 1"
  have "?n < degree p" using B by auto
  then have "1 \<ge> degree (diff_pow ?n  p)" using B diff_pow_degree0
    by (metis One_nat_def Suc_diff_Suc
        cancel_comm_monoid_add_class.diff_cancel
        diff_zero)
  then have "degree (diff_pow (?n + 1) p) < 1"
    by (metis One_nat_def add.commute
        degree_0 diff_const diff_degree diff_pow.simps(2)
        le_Suc_eq le_zero_eq less_one plus_1_eq_Suc)
  then have "degree (diff_pow (?n + 1) p) = 0" by auto
  then have "degree (diff_pow (?n + 1 + (n - (?n + 2))) p) = 0"
    using diff_pow_compose diff_pow_const  by (metis (no_types, lifting) Suc_diff_Suc
                                          add.commute add_cancel_left_right
                                          degree_0 neq0_conv zero_less_diff)
  then have "degree (diff_pow (n-1) p) = 0"
    by (simp add: A B Suc_leI)
  then show ?thesis
    by (metis A B diff_Suc_1
        diff_const diff_pow.elims
        dual_order.strict_trans less_irrefl)
qed

(************************Power rule for diff and pochhammer monomials****************************)

lemma diff_pochhammer_monom:
  "diff (PM a (Suc n)) = (of_nat (Suc n))*(PM a n)"
proof(induction n)
  case 0
  have P0: "(pochhammer_monom a (Suc 0)) = (monom a 1)"
    by (simp add: monom_altdef)
  then have P1: "diff (pochhammer_monom a (Suc 0)) = pcompose  (monom a 1) [:1, 1:] - (monom a 1)"
    by (simp add: diff_def)
  then have "diff (pochhammer_monom a (Suc 0)) = monom a 0"
    by (simp add: monom_0 monom_Suc pcompose_pCons)
  then show ?case by simp
next
  case (Suc n)
  fix n
  let ?n = "Suc n"
  assume IH: "diff (PM a ?n) = of_nat (?n) * (PM a n) "
  then show  "diff (PM a (Suc ?n)) = of_nat (Suc ?n) * PM a ?n"
  proof-
    have "(PM a (Suc ?n)) = (X - of_nat ?n)*(PM a ?n)"
      by simp
    then have P: "diff (PM a (Suc ?n)) = (X  - of_nat ?n)\<circ>\<^sub>p (X + 1) *((PM a ?n) \<circ>\<^sub>p (X + 1)) - (X - of_nat ?n)*(PM a ?n)"
      by (simp add: diff_def one_pCons pcompose_mult)
    have Q:"(X  - of_nat ?n)\<circ>\<^sub>p (X + 1) =  (X   - (of_nat ?n) + 1)"
      by (simp add: of_nat_poly one_pCons pcompose_pCons)
    then have "diff (PM a (Suc ?n)) = (X + 1  - (of_nat ?n)) *((PM a ?n) \<circ>\<^sub>p (X + 1)) - (X - of_nat ?n)*(PM a ?n)"
      using  P by (smt diff_add_eq)
    then have "diff (PM a (Suc ?n)) = (X+1)*(PM a ?n) - (X - of_nat ?n)*(PM a ?n)"
      by (metis P Q pochhammer_monom_id)
    then have "diff (PM a (Suc ?n)) = (1 +  of_nat ?n)*(PM a ?n)"
      by (metis (no_types, lifting)
          add_diff_cancel_left'
          diff_add_cancel diff_add_eq
          left_diff_distrib')
    then show ?thesis by simp
  qed
qed

(***********************************Generalized power rule*****************************************)

lemma diff_pow_pochhammer_monom0:
 shows "n \<ge> k \<Longrightarrow> (\<Delta>[k] (PM a (n+1))) = (pochhammer (of_nat (n + 2 - k)) k)*(PM a (n + 1 - k))"
proof(induction k)
  case 0
  then show ?case by simp
next
  case (Suc k)
  show "\<And>k. (n \<ge> k \<Longrightarrow> (\<Delta>[k] (PM a (n + 1)))  = (pochhammer (of_nat  (n + 2 - k)) k) *( PM a  (n + 1 - k))) \<Longrightarrow>
            n \<ge>(Suc k) \<Longrightarrow> (\<Delta>[Suc k](PM a (n + 1)))  = (pochhammer (of_nat  (n + 2 - (Suc k))) (Suc k)) * (PM a (n + 1 - (Suc k)))"
  proof-
    fix k::nat
    show "(n \<ge>k \<Longrightarrow> (\<Delta>[k] (PM a (n + 1))) = (pochhammer (of_nat  (n + 2 - k)) k) *( PM a  (n + 1 - k))) \<Longrightarrow>
           n \<ge>(Suc k) \<Longrightarrow>   (\<Delta>[Suc k](PM a (n + 1)))  = (pochhammer (of_nat  (n + 2 - (Suc k))) (Suc k)) * (PM a (n + 1 - (Suc k)))"
    proof-
      assume IH0: "(n \<ge>k \<Longrightarrow> (\<Delta>[k] (PM a (n + 1)))  = (pochhammer (of_nat  (n + 2 - k)) k) *( PM a  (n + 1 - k)))"
      show "n \<ge>(Suc k) \<Longrightarrow> (\<Delta>[Suc k](PM a (n + 1))) = (pochhammer (of_nat  (n + 2 - (Suc k))) (Suc k)) * (PM a (n + 1 - (Suc k)))"
      proof-
        assume A: "n \<ge>(Suc k)"
        show " (\<Delta>[Suc k](PM a (n + 1)))  =  (pochhammer (of_nat  (n + 2 - (Suc k))) (Suc k)) * (PM a (n + 1 - (Suc k)))"
        proof-
          have IH: "(\<Delta>[k] (PM a (n + 1))) = (pochhammer (of_nat  (n + 2 - k)) k) *( PM a  (n + 1 - k))"
            using IH0 Suc_lessD A Suc_leD by blast
          let ?p = "(\<Delta>[k] (PM a (n+1)))"
          let ?q = " (pochhammer (of_nat  (n + 2 - k)) k) *( PM a  (n + 1 - k))"
          have  "?p = ?q" using IH by blast
          then have I: "diff ?p = diff ?q" by simp
          have  "(\<Delta>[Suc k] (PM a (n+1))) = diff ?p"  by simp
          then have P: "(\<Delta>[Suc k] (PM a (n+1))) = diff ?q" using I by auto
          have Q: "diff ?q = (pochhammer (of_nat (n + 2 - k)) k)*(diff (PM a (n + 1 - k)))"
            using diff_mult_deg0 by (metis degree_of_nat pochhammer_of_nat)
          then have R: "diff ?q = (pochhammer (of_nat (n + 2 - k)) k)
                            *(of_nat (n + 1 - k))*(PM a (n - k))"
            using diff_pochhammer_monom  by (metis (no_types, lifting)
                    A Suc_diff_le Suc_leD add.commute mult.assoc plus_1_eq_Suc)
          have  "(pochhammer (of_nat (n + 2 - k)) k)*(of_nat (n + 1 - k))
               =  (pochhammer (of_nat (n +  1 - k)) (Suc k))"
            by (simp add: A Suc_diff_le Suc_leD
                add.commute mult.commute pochhammer_rec)
          then have S: "diff ?q = (pochhammer (of_nat (n + 1 - k)) (Suc k))*(PM a (n - k))"
            using R  by metis
          then have T: "(\<Delta>[Suc k] (PM a (n+1)))
               = (pochhammer (of_nat (n + 1 - k)) (Suc k))*(PM a (n - k))"
            using P by simp
          have "n + 2 - (Suc k) =  n + 1 - k"
            using A by linarith
          then have "(\<Delta>[Suc k] (PM a (n+1)))
                 = (pochhammer (of_nat (n + 2 - (Suc k) )) (Suc k))*(PM a (n + 1 - (Suc k)))"
            using T by auto
          then show ?thesis by auto
        qed
      qed
    qed
  qed
qed

lemma diff_pow_pochhammer_monom1:
"(\<Delta>[n] (PM a (n))) = (pochhammer (of_nat (1)) n)* (PM a (0))"
proof(cases "n = 0")
  case True
  then show ?thesis by simp
next
  case False
  let ?n = "n-1"
  have P: "(\<Delta>[?n] (PM a (?n+1))) = (pochhammer (of_nat (2)) ?n)*(PM a 1)"
     using diff_pow_pochhammer_monom0 by (metis (no_types, lifting) add.right_neutral
                                     add_diff_cancel_left' le_numeral_extra(3)
                                      nat_add_left_cancel_le of_nat_1 of_nat_add one_add_one)
  then have "(\<Delta>[n] (PM a (n))) = diff (\<Delta>[?n] (PM a (?n+1)))"
     using False by (metis One_nat_def Suc_diff_Suc
         add.commute diff_zero neq0_conv
         plus_1_eq_Suc pochhammer_monomials.diff_pow_suc)
  then have "(\<Delta>[n] (PM a (n))) = diff ((pochhammer (of_nat (2)) ?n)*(PM a 1))" using P
     by auto
  then have Q:  "(\<Delta>[n] (PM a (n))) = (pochhammer (of_nat 2) ?n)*(diff (PM a 1))"
     using diff_mult_deg0 by (metis degree_of_nat pochhammer_of_nat)
  have "(diff (PM a 1)) =((of_nat 1)*((PM a 0)))"
    using diff_pochhammer_monom  by (metis One_nat_def)
  then have  "(\<Delta>[n] (PM a (n))) = (pochhammer (of_nat 2) ?n)*((of_nat 1)*(PM a 0))"
    using Q by simp
  then show ?thesis  by (simp add: pochhammer_rec_if)
qed

lemma diff_pow_pochhammer_monom:
 assumes "a \<noteq>0"
 shows "(\<Delta>[k] (PM (a::('a::comm_ring_1)) (n+1)))
                = (pochhammer (of_nat (n + 2 - k)) k)*(PM a (n + 1 - k))"
proof(cases "n + 1 \<ge>k")
  case True
  then show ?thesis
  proof(cases "n \<ge>k")
    case True
    then show ?thesis
      using diff_pow_pochhammer_monom0 by blast
  next
    case F: False
    then show ?thesis
      using True F diff_pow_pochhammer_monom1  by (metis One_nat_def Suc_diff_le
          add.commute add_2_eq_Suc' diff_diff_cancel
          diff_is_0_eq diff_zero not_less_eq_eq plus_1_eq_Suc)
  qed
  next
   case F: False
   have IE: "k > n+1" using F by auto
   let ?p = "PM (a::('a::comm_ring_1)) (n+1)"
   have "degree ?p = n+1"
     using assms pochhammer_monom_degree by blast
   then have "degree ?p < k"
     using IE by auto
   then have A: "(\<Delta>[k] ?p) = 0" using diff_pow_zero
     by blast
   have "(pochhammer (of_nat (n + 2 - k)) k) = 0"
      by (metis F Suc_eq_plus1 add_2_eq_Suc'
       diff_is_0_eq' eq_imp_le le_trans linorder_not_le
       not_less_eq_eq of_nat_0 pochhammer_0_left  zero_less_Suc)
   then have  "(pochhammer (of_nat (n + 2 - k)) k)*(PM a (n + 1 - k)) = 0"
     using mult_not_zero by blast
   then have " ((pochhammer (of_nat (n + 2 - k)) k)*(PM a (n + 1 - k))) = 0"
     by blast
   then show "(\<Delta>[k] (PM (a::('a::comm_ring_1)) (n+1))) = (pochhammer (of_nat (n + 2 - k)) k)*(PM a (n + 1 - k))"
     using A by auto
qed

lemma diff_pow_greater_deg:
  assumes "a \<noteq>0"
  assumes "k>n"
  shows "(\<Delta>[k](PM (a::('a::comm_ring_1)) n)) = 0"
proof-
  let ?n = "k - n"
  have "(\<Delta>[k](PM (a::('a::comm_ring_1)) n)) = \<Delta>[?n](\<Delta>[n](PM (a::('a::comm_ring_1)) n))"
    by (metis add.commute assms(2)
        diff_pow_compose le_add_diff_inverse
        linorder_not_le nat_le_linear)
  then have "(\<Delta>[k](PM (a::('a::comm_ring_1)) n)) = \<Delta>[?n]((pochhammer 2 n))"
    by (metis assms(1) assms(2) degree_of_nat
        diff_pow_zero of_nat_numeral
        pochhammer_monom_degree pochhammer_of_nat
        zero_less_diff)
  then show "(\<Delta>[k](PM (a::('a::comm_ring_1)) n)) = 0"
    by (simp add: assms(1) assms(2) diff_pow_zero pochhammer_monom_degree)
qed

end


(*  Title:      CCL/ex/Nat.thy
    Author:     Martin Coen, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section {* Programs defined over the natural numbers *}

theory Nat
imports "../Wfd"
begin

definition not :: "i\<Rightarrow>i"
  where "not(b) == if b then false else true"

definition add :: "[i,i]\<Rightarrow>i"  (infixr "#+" 60)
  where "a #+ b == nrec(a, b, \<lambda>x g. succ(g))"

definition mult :: "[i,i]\<Rightarrow>i"  (infixr "#*" 60)
  where "a #* b == nrec(a, zero, \<lambda>x g. b #+ g)"

definition sub :: "[i,i]\<Rightarrow>i"  (infixr "#-" 60)
  where
    "a #- b ==
      letrec sub x y be ncase(y, x, \<lambda>yy. ncase(x, zero, \<lambda>xx. sub(xx,yy)))
      in sub(a,b)"

definition le :: "[i,i]\<Rightarrow>i"  (infixr "#<=" 60)
  where
    "a #<= b ==
      letrec le x y be ncase(x, true, \<lambda>xx. ncase(y, false, \<lambda>yy. le(xx,yy)))
      in le(a,b)"

definition lt :: "[i,i]\<Rightarrow>i"  (infixr "#<" 60)
  where "a #< b == not(b #<= a)"

definition div :: "[i,i]\<Rightarrow>i"  (infixr "##" 60)
  where
    "a ## b ==
      letrec div x y be if x #< y then zero else succ(div(x#-y,y))
      in div(a,b)"

definition ackermann :: "[i,i]\<Rightarrow>i"
  where
    "ackermann(a,b) ==
      letrec ack n m be ncase(n, succ(m), \<lambda>x.
        ncase(m,ack(x,succ(zero)), \<lambda>y. ack(x,ack(succ(x),y))))
      in ack(a,b)"

lemmas nat_defs = not_def add_def mult_def sub_def le_def lt_def ackermann_def napply_def

lemma natBs [simp]:
  "not(true) = false"
  "not(false) = true"
  "zero #+ n = n"
  "succ(n) #+ m = succ(n #+ m)"
  "zero #* n = zero"
  "succ(n) #* m = m #+ (n #* m)"
  "f^zero`a = a"
  "f^succ(n)`a = f(f^n`a)"
  by (simp_all add: nat_defs)

lemma napply_f: "n:Nat \<Longrightarrow> f^n`f(a) = f^succ(n)`a"
  apply (erule Nat_ind)
   apply simp_all
  done

lemma addT: "\<lbrakk>a:Nat; b:Nat\<rbrakk> \<Longrightarrow> a #+ b : Nat"
  apply (unfold add_def)
  apply typechk
  done

lemma multT: "\<lbrakk>a:Nat; b:Nat\<rbrakk> \<Longrightarrow> a #* b : Nat"
  apply (unfold add_def mult_def)
  apply typechk
  done

(* Defined to return zero if a<b *)
lemma subT: "\<lbrakk>a:Nat; b:Nat\<rbrakk> \<Longrightarrow> a #- b : Nat"
  apply (unfold sub_def)
  apply typechk
  apply clean_ccs
  apply (erule NatPRI [THEN wfstI, THEN NatPR_wf [THEN wmap_wf, THEN wfI]])
  done

lemma leT: "\<lbrakk>a:Nat; b:Nat\<rbrakk> \<Longrightarrow> a #<= b : Bool"
  apply (unfold le_def)
  apply typechk
  apply clean_ccs
  apply (erule NatPRI [THEN wfstI, THEN NatPR_wf [THEN wmap_wf, THEN wfI]])
  done

lemma ltT: "\<lbrakk>a:Nat; b:Nat\<rbrakk> \<Longrightarrow> a #< b : Bool"
  apply (unfold not_def lt_def)
  apply (typechk leT)
  done

subsection {* Termination Conditions for Ackermann's Function *}

lemmas relI = NatPR_wf [THEN NatPR_wf [THEN lex_wf, THEN wfI]]

lemma "\<lbrakk>a:Nat; b:Nat\<rbrakk> \<Longrightarrow> ackermann(a,b) : Nat"
  apply (unfold ackermann_def)
  apply gen_ccs
  apply (erule NatPRI [THEN lexI1 [THEN relI]] NatPRI [THEN lexI2 [THEN relI]])+
  done

end


subsection \<open>Permutability and Isomorphical Uniqueness\<close>

theory StructuralPropertiesTheorems
  imports IsomorphicalUniqueness Permutability CollapsibleParticulars
begin

context ufo_particular_theory
begin

text \<^marker>\<open>tag bodyonly\<close> \<open>It turns out that the set of isomorphically unique particulars of a particular
  structure is identical to the set of non-permutable particulars, as shown in the
  following theorem and lemmas:\<close>

lemma im_unique_particulars_are_non_permutable_particulars:
    \<open>\<P>\<^sub>\<simeq>\<^sub>! \<subseteq> \<P>\<^sub>1\<^sub>!\<close>
proof (intro subsetI ballI ; clarsimp simp: isomorphically_unique_particulars_def)
  fix x \<phi> y
  assume as1: \<open>particular_struct_endomorphism \<Gamma> \<phi>\<close> \<open>x \<in> \<E>\<close>
      \<open>\<forall>\<phi>\<in>BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>. \<forall>\<sigma>\<in>Morphs\<^bsub>\<Gamma>,MorphImg \<phi> \<Gamma>\<^esub>.\<forall>y\<in>\<E>. (\<sigma> y = \<phi> x) = (y = x)\<close>
      \<open>y \<in> \<E>\<close>
  interpret I: particular_struct_endomorphism \<open>\<Gamma>\<close> \<open>\<phi>\<close> using as1(1) by blast
  have A: \<open>\<sigma> y = \<phi> x \<longleftrightarrow> y = x\<close> if \<open>\<phi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close> \<open>\<sigma> \<in> Morphs\<^bsub>\<Gamma>,MorphImg \<phi> \<Gamma>\<^esub>\<close> \<open>y \<in> \<E>\<close> for \<phi> \<sigma> y
    using that as1(3) by metis
  obtain \<pi> :: \<open>'p \<Rightarrow> ZF\<close> where \<open>inj \<pi>\<close>
    using injection_to_ZF_exist by blast
  have pi_isomorph: \<open>\<pi> \<in> BijMorphs1\<^bsub>\<Gamma>,TYPE(ZF)\<^esub>\<close>
    using  \<open>inj \<pi>\<close> by (meson UNIV_I inj_morph_img_BijMorphs inj_on_id inj_on_subset subsetI)
  have pi_sigma_morph: \<open>\<pi> \<circ> \<phi> \<in> Morphs\<^bsub>\<Gamma>,MorphImg \<pi> \<Gamma>\<^esub>\<close>
    by (meson I.particular_struct_morphism_axioms bijections1_are_morphisms morphisms_are_closed_under_comp morphs_I pi_isomorph)
  have \<open>\<pi> x = \<pi> (\<phi> x)\<close>
    using A[of \<open>\<pi>\<close> \<open>\<pi> \<circ> \<phi>\<close>, OF pi_isomorph pi_sigma_morph \<open>x \<in> \<E>\<close>,simplified]
    by simp
  then have \<open>x = \<phi> x\<close>
    by (rule \<open>inj \<pi>\<close>[THEN inj_onD]; simp)
  then show \<open>\<phi> y = x \<longleftrightarrow> y = x\<close>
    apply (intro iffI ; simp)
    by (rule A[where y=y and \<phi> = \<pi> and \<sigma> = \<open>\<pi> \<circ> \<phi>\<close>,OF _ _ \<open>y \<in> \<E>\<close>,simplified o_apply
          , THEN iffD1] ; (intro pi_sigma_morph pi_isomorph)? ; simp)
qed

lemma non_permutable_particulars_are_im_unique_particulars:
  \<open>\<P>\<^sub>1\<^sub>! \<subseteq> \<P>\<^sub>\<simeq>\<^sub>!\<close>
proof (intro subsetI ballI ; clarsimp simp: isomorphically_unique_particulars_def)
  fix x y :: \<open>'p\<close> and \<phi> \<sigma> :: \<open>'p \<Rightarrow> 'p\<^sub>1\<close> and f :: \<open>'p\<^sub>1 \<Rightarrow> ZF\<close>
  assume as:
      \<open>particular_struct_morphism \<Gamma> (MorphImg \<phi> \<Gamma>) \<sigma>\<close>
      \<open>\<forall>\<phi>\<in>EndoMorphs\<^bsub>\<Gamma>\<^esub>. \<forall>y\<in>\<E>. \<phi> y = x \<longleftrightarrow> y = x\<close>
      \<open>inj_on \<phi> \<E>\<close>
      \<open>inj f\<close>
      \<open>x \<in> \<E>\<close>
      \<open>y \<in> \<E>\<close>
  have A: \<open>\<phi> y = x \<longleftrightarrow> y = x\<close> if \<open>\<phi> \<in> EndoMorphs\<^bsub>\<Gamma>\<^esub>\<close> \<open>y \<in> \<E>\<close> for \<phi> y using as(2) that by blast
  interpret I1: particular_struct_morphism \<open>\<Gamma>\<close> \<open>MorphImg \<phi> \<Gamma>\<close> \<open>\<sigma>\<close> using as(1) by simp
  interpret I: particular_struct_bijection_1 \<open>\<Gamma>\<close> \<open>\<phi>\<close>
    using as(3,4) inj_morph_img_isomorphism[of \<open>\<phi>\<close>] by blast
  interpret Inv: particular_struct_bijection_1 \<open>MorphImg \<phi> \<Gamma>\<close> \<open>I.inv_morph\<close>
    using particular_struct_bijection_iff_particular_struct_bijection_1 by blast

  have B: \<open>particular_struct_morphism \<Gamma> \<Gamma> (I.inv_morph \<circ> \<sigma>)\<close>
    apply (intro particular_struct_morphism_comp[of _ \<open>MorphImg \<phi> \<Gamma>\<close>])
    subgoal using I1.particular_struct_morphism_axioms by blast
    by (simp add: particular_struct_bijection.axioms(1) particular_struct_injection.axioms(1))

  have C: \<open>I.inv_morph \<circ> \<sigma> \<in> EndoMorphs\<^bsub>\<Gamma>\<^esub>\<close>
    apply (simp)
    apply (intro_locales)
   using B particular_struct_morphism_def
      pre_particular_struct_morphism_def by blast+

  have D: \<open>I.inv_morph (\<sigma> x) = x\<close> using A[OF C \<open>x \<in> \<E>\<close>,simplified] .
  have E: \<open>I.inv_morph (\<phi> x) = x\<close> using \<open>x \<in> \<E>\<close> by simp
  have F: \<open>I.inv_morph (\<sigma> x) = I.inv_morph (\<phi> x)\<close> using D E by simp
  show \<open>\<sigma> y = \<phi> x \<longleftrightarrow> y = x\<close>
    apply (intro iffI ; simp?)
    subgoal
      apply (rule A[where y=y and \<phi> = \<open>I.inv_morph \<circ> \<sigma>\<close>,OF C \<open>y \<in> \<E>\<close>,THEN iffD1])
      by (simp add: E)
    subgoal
      apply (rule F inj_onD[OF Inv.morph_is_injective,simplified,OF F])
      subgoal using \<open>x \<in> \<E>\<close> by (simp add: I1.morph_preserves_particulars)
      using \<open>x \<in> \<E>\<close> by (simp add: I.morph_preserves_particulars)
    done
qed

theorem non_permutable_particulars_are_the_unique_particulars:
    \<open>\<P>\<^sub>1\<^sub>! = \<P>\<^sub>\<simeq>\<^sub>!\<close>
  using im_unique_particulars_are_non_permutable_particulars
     non_permutable_particulars_are_im_unique_particulars by simp

text \<^marker>\<open>tag bodyonly\<close> \<open>
  The set of non-permutable particulars is a subset of the set of
  non-collapsible particulars, although the converse does not
  hold, in general:
\<close>

theorem  non_permutables_are_non_collapsible: \<open>\<P>\<^sub>1\<^sub>! \<subseteq> \<P>\<^sub>n\<^sub>c\<close>
proof (intro subsetI ; elim non_permutables_E ;
        intro nonCollapsibleParticularsI notI ;
        (elim collapsibleE)? ; assumption?
        ; rename_tac x\<^sub>1 \<phi> x\<^sub>2)
  fix x\<^sub>1 x\<^sub>2 \<phi>
  assume A: \<open>x\<^sub>1 \<in> \<E>\<close> \<open>x\<^sub>2 \<in> \<E>\<close> \<open>x\<^sub>1 \<noteq> x\<^sub>2\<close> \<open>\<phi> x\<^sub>1 = \<phi> x\<^sub>2\<close>
    and B: \<open>non_permutable x\<^sub>1\<close> \<open>\<phi> \<in> EndoMorphs\<^bsub>\<Gamma>\<^esub>\<close>
  note A(1,2)[simp,intro!]
  note A1[simp] = A(3)[simplified A(4)] A(4)
  interpret phi: particular_struct_endomorphism \<Gamma> \<phi> using B(2) by simp
  note C1 = B(1)[THEN non_permutable_E,OF B(2) \<open>x\<^sub>2 \<in> \<E>\<close>] and
       C2 = B(1)[THEN non_permutable_E,OF B(2) \<open>x\<^sub>1 \<in> \<E>\<close>]
  have D[simp]: \<open>\<phi> x\<^sub>1 = x\<^sub>1\<close> using C2 by simp
  show False
    using A1(1) A1(2) C1 D by presburger
qed

end

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_bin_distrib
imports "../../Test_Base"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

fun times :: "Bin => Bin => Bin" where
"times (One) y = y"
| "times (ZeroAnd xs1) y = ZeroAnd (times xs1 y)"
| "times (OneAnd xs12) y = plus (ZeroAnd (times xs12 y)) y"

theorem property0 :
  "((times x (plus y z)) = (plus (times x y) (times x z)))"
  oops

end