(* Title:     MiniML/Type.thy
   Author:    Wolfgang Naraschewski and Tobias Nipkow
   Copyright  1996 TU Muenchen
*)

section "MiniML-types and type substitutions"

theory Type
imports Maybe
begin

\<comment> \<open>type expressions\<close>
datatype "typ" = TVar nat | Fun "typ" "typ" (infixr "->" 70)

\<comment> \<open>type schemata\<close>
datatype type_scheme = FVar nat | BVar nat | SFun type_scheme type_scheme (infixr "=->" 70)

\<comment> \<open>embedding types into type schemata\<close>
fun mk_scheme :: "typ => type_scheme" where
  "mk_scheme (TVar n) = (FVar n)"
| "mk_scheme (t1 -> t2) = ((mk_scheme t1) =-> (mk_scheme t2))"

\<comment> \<open>type variable substitution\<close>
type_synonym subst = "nat => typ"

class type_struct =
  fixes free_tv :: "'a => nat set"
    \<comment> \<open>@{text "free_tv s"}: the type variables occurring freely in the type structure s\<close>
  fixes free_tv_ML :: "'a => nat list"
    \<comment> \<open>executable version of @{text free_tv}: Implementation with lists\<close>
  fixes bound_tv :: "'a => nat set"
    \<comment> \<open>@{text "bound_tv s"}: the type variables occurring bound in the type structure s\<close>
  fixes min_new_bound_tv :: "'a => nat"
    \<comment> \<open>minimal new free / bound variable\<close>
  fixes app_subst :: "subst => 'a => 'a" ("$")
    \<comment> \<open>extension of substitution to type structures\<close>

instantiation "typ" :: type_struct
begin

fun free_tv_typ where
  free_tv_TVar:    "free_tv (TVar m) = {m}"
| free_tv_Fun:     "free_tv (t1 -> t2) = (free_tv t1) Un (free_tv t2)"

fun app_subst_typ where
  app_subst_TVar: "$ S (TVar n) = S n"
| app_subst_Fun:  "$ S (t1 -> t2) = ($ S t1) -> ($ S t2)"

instance ..

end

instantiation type_scheme :: type_struct
begin

fun free_tv_type_scheme where
  "free_tv (FVar m) = {m}"
| "free_tv (BVar m) = {}"
| "free_tv (S1 =-> S2) = (free_tv S1) Un (free_tv S2)"

fun free_tv_ML_type_scheme where
  "free_tv_ML (FVar m) = [m]"
| "free_tv_ML (BVar m) = []"
| "free_tv_ML (S1 =-> S2) = (free_tv_ML S1) @ (free_tv_ML S2)"

fun bound_tv_type_scheme where
  "bound_tv (FVar m) = {}"
| "bound_tv (BVar m) = {m}"
| "bound_tv (S1 =-> S2) = (bound_tv S1) Un (bound_tv S2)"

fun min_new_bound_tv_type_scheme where
  "min_new_bound_tv (FVar n) = 0"
| "min_new_bound_tv (BVar n) = Suc n"
| "min_new_bound_tv (sch1 =-> sch2) = max (min_new_bound_tv sch1) (min_new_bound_tv sch2)"

fun app_subst_type_scheme where
  "$ S (FVar n) = mk_scheme (S n)"
| "$ S (BVar n) = (BVar n)"
| "$ S (sch1 =-> sch2) = ($ S sch1) =-> ($ S sch2)"

instance ..

end

instantiation list :: (type_struct) type_struct
begin

fun free_tv_list where
  "free_tv [] = {}"
| "free_tv (x#l) = (free_tv x) Un (free_tv l)"

fun free_tv_ML_list where
  "free_tv_ML [] = []"
| "free_tv_ML (x#l) = (free_tv_ML x) @ (free_tv_ML l)"

fun bound_tv_list where
  "bound_tv [] = {}"
| "bound_tv (x#l) = (bound_tv x) Un (bound_tv l)"

definition app_subst_list where
  app_subst_list: "$ S = map ($ S)"

instance ..

end

text
\<open>\<open>new_tv s n\<close> computes whether n is a new type variable w.r.t. a type
   structure s, i.e. whether n is greater than any type variable
   occurring in the type structure\<close>
definition
  new_tv :: "[nat,'a::type_struct] => bool" where
  "new_tv n ts = (\<forall>m. m:(free_tv ts) \<longrightarrow> m<n)"

\<comment> \<open>identity\<close>
definition
  id_subst :: subst where
  "id_subst = (\<lambda>n. TVar n)"

\<comment> \<open>domain of a substitution\<close>
definition
  dom :: "subst => nat set" where
  "dom S = {n. S n \<noteq> TVar n}"

\<comment> \<open>codomain of a substitution: the introduced variables\<close>
definition
  cod :: "subst => nat set" where
  "cod S = (UN m:dom S. (free_tv (S m)))"

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

instantiation nat :: of_nat
begin

definition
  "of_nat n = n"

instance ..

end

class typ_of =
  fixes typ_of :: "'a \<Rightarrow> typ"

instantiation "typ" :: typ_of
begin

definition
  "typ_of T = T"

instance ..

end

instantiation "fun" :: (of_nat, typ_of) type_struct
begin

definition free_tv_fun where
  "free_tv f = (let S = \<lambda>n. typ_of (f (of_nat n)) in (dom S) Un (cod S))"

instance ..

end

lemma free_tv_subst:
  "free_tv S = (dom S) Un (cod S)"
by (simp add: free_tv_fun_def of_nat_nat_def typ_of_typ_def )

\<comment> \<open>unification algorithm mgu\<close>
axiomatization mgu :: "typ \<Rightarrow> typ \<Rightarrow> subst option" where
  mgu_eq:   "mgu t1 t2 = Some U \<Longrightarrow> $U t1 = $U t2"
  and mgu_mg:   "[| (mgu t1 t2) = Some U; $S t1 = $S t2 |] ==> \<exists>R. S = $R \<circ> U"
  and mgu_Some: "$S t1 = $S t2 \<Longrightarrow> \<exists>U. mgu t1 t2 = Some U"
  and mgu_free: "mgu t1 t2 = Some U \<Longrightarrow> free_tv U \<subseteq> free_tv t1 \<union> free_tv t2"

lemma mk_scheme_Fun:
  "mk_scheme t = sch1 =-> sch2 \<Longrightarrow> (\<exists>t1 t2. sch1 = mk_scheme t1 \<and> sch2 = mk_scheme t2)"
proof (induction t)
  case TVar thus ?case by auto
next
  case Fun thus ?case by auto
qed

lemma mk_scheme_injective: "(mk_scheme t = mk_scheme t') \<Longrightarrow> t = t'"
proof (induction t arbitrary: t')
  case TVar thus ?case by(cases t') auto
next
  case Fun thus ?case by(cases t') auto
qed

lemma free_tv_mk_scheme[simp]: "free_tv (mk_scheme t) = free_tv t"
by (induction t) auto

lemma subst_mk_scheme[simp]: "$ S (mk_scheme t) = mk_scheme ($ S t)"
by (induction t) auto

\<comment> \<open>constructor laws for @{text app_subst}\<close>

lemma app_subst_Nil[simp]:
  "$ S [] = []"
by (simp add: app_subst_list)

lemma app_subst_Cons[simp]:
  "$ S (x#l) = ($ S x)#($ S l)"
by (simp add: app_subst_list)

\<comment> \<open>constructor laws for @{text new_tv}\<close>

lemma new_tv_TVar[simp]:
  "new_tv n (TVar m) = (m<n)"
by (simp add: new_tv_def)

lemma new_tv_FVar[simp]:
  "new_tv n (FVar m) = (m<n)"
by (simp add: new_tv_def)

lemma new_tv_BVar[simp]:
  "new_tv n (BVar m) = True"
by (simp add: new_tv_def)

lemma new_tv_Fun[simp]:
  "new_tv n (t1 -> t2) = (new_tv n t1 \<and> new_tv n t2)"
by (auto simp: new_tv_def)

lemma new_tv_Fun2[simp]:
  "new_tv n (t1 =-> t2) = (new_tv n t1 \<and> new_tv n t2)"
by (auto simp: new_tv_def)

lemma new_tv_Nil[simp]:
  "new_tv n []"
by (simp add: new_tv_def)

lemma new_tv_Cons[simp]:
  "new_tv n (x#l) = (new_tv n x \<and> new_tv n l)"
by (auto simp: new_tv_def)

lemma new_tv_TVar_subst[simp]: "new_tv n TVar"
by (simp add: new_tv_def free_tv_subst dom_def cod_def)

lemma new_tv_id_subst [simp]: "new_tv n id_subst"
by (simp add: id_subst_def new_tv_def free_tv_subst dom_def cod_def)

lemma new_if_subst_type_scheme: "new_tv n (sch::type_scheme) \<Longrightarrow>
    $(\<lambda>k. if k<n then S k else S' k) sch = $S sch"
by (induction sch) simp_all

lemma new_if_subst_type_scheme_list: "new_tv n (A::type_scheme list) \<Longrightarrow>
    $(\<lambda>k. if k<n then S k else S' k) A = $S A"
by (induction A) (simp_all add: new_if_subst_type_scheme)

\<comment> \<open>constructor laws for @{text dom} and @{text cod}\<close>

lemma dom_id_subst [simp]: "dom id_subst = {}"
  unfolding dom_def id_subst_def empty_def by simp

lemma cod_id_subst [simp]: "cod id_subst = {}"
  unfolding cod_def by simp

lemma free_tv_id_subst [simp]: "free_tv id_subst = {}"
  unfolding free_tv_subst by simp

lemma free_tv_nth_A_impl_free_tv_A:
  "\<lbrakk> n < length A;  x : free_tv (A!n) \<rbrakk> \<Longrightarrow> x : free_tv A"
proof (induction A arbitrary: n)
  case Nil thus ?case by simp
next
  case (Cons a A)
  then show ?case by (fastforce simp add:nth_Cons' split: if_splits)
qed

text
\<open>if two substitutions yield the same result if applied to a type
   structure the substitutions coincide on the free type variables
   occurring in the type structure\<close>

lemma typ_substitutions_only_on_free_variables:
  "(\<forall>x\<in>free_tv t. (S x) = (S' x)) \<Longrightarrow> $ S (t::typ) = $ S' t"
  by (induct t) simp_all

lemma eq_free_eq_subst_te: "(\<forall>n. n\<in>(free_tv t) \<longrightarrow> S1 n = S2 n) \<Longrightarrow> $ S1 (t::typ) = $ S2 t"
apply (rule typ_substitutions_only_on_free_variables)
apply simp
done

lemma scheme_substitutions_only_on_free_variables:
  "(\<forall>x\<in>free_tv sch. (S x) = (S' x)) \<Longrightarrow> $ S (sch::type_scheme) = $ S' sch"
  by (induct sch) simp_all

lemma eq_free_eq_subst_type_scheme:
  "(\<forall>n. n\<in>(free_tv sch) \<longrightarrow> S1 n = S2 n) \<Longrightarrow> $ S1 (sch::type_scheme) = $ S2 sch"
apply (rule scheme_substitutions_only_on_free_variables)
apply simp
done

lemma weaken_asm_Un: "((\<forall>x\<in>A. (P x)) \<longrightarrow> Q) \<Longrightarrow> ((\<forall>x\<in>A \<union> B. (P x)) \<longrightarrow> Q)"
  by fast

lemma scheme_list_substitutions_only_on_free_variables:
  "(\<forall>x\<in>free_tv A. (S x) = (S' x)) \<Longrightarrow> $ S (A::type_scheme list) = $ S' A"
by (induction A) (auto simp add: eq_free_eq_subst_type_scheme)

lemma eq_subst_te_eq_free:
  "$ S1 (t::typ) = $ S2 t \<Longrightarrow> n:(free_tv t) \<Longrightarrow> S1 n = S2 n"
  by (induct t) auto

lemma eq_subst_type_scheme_eq_free:
  "\<lbrakk> $ S1 (sch::type_scheme) = $ S2 sch; n:(free_tv sch) \<rbrakk> \<Longrightarrow> S1 n = S2 n"
by (induction "sch") (auto dest: mk_scheme_injective)

lemma eq_subst_scheme_list_eq_free:
  "\<lbrakk> $S1 (A::type_scheme list) = $S2 A;  n:(free_tv A) \<rbrakk> \<Longrightarrow> S1 n = S2 n"
proof (induct A)
  case Nil
  then show ?case by fastforce
next
  case Cons
  then show ?case by (fastforce intro: eq_subst_type_scheme_eq_free)
qed

lemma codD: "v : cod S \<Longrightarrow> v : free_tv S"
  unfolding free_tv_subst by blast

lemma not_free_impl_id: "x \<notin> free_tv S \<Longrightarrow> S x = TVar x"
  unfolding free_tv_subst dom_def by blast

lemma free_tv_le_new_tv: "[| new_tv n t; m:free_tv t |] ==> m<n"
  unfolding new_tv_def by blast

lemma cod_app_subst:
  "[| v : free_tv(S n); v\<noteq>n |] ==> v : cod S"
by (force simp add: dom_def cod_def UNION_eq Bex_def)

lemma free_tv_subst_var: "free_tv (S (v::nat)) \<subseteq> insert v (cod S)"
apply (cases "v:dom S")
apply (fastforce simp add: cod_def)
apply (fastforce simp add: dom_def)
done

lemma free_tv_app_subst_te: "free_tv ($ S (t::typ)) \<subseteq> cod S \<union> free_tv t"
proof (induct t)
  case (TVar n) then show ?case by (simp add: free_tv_subst_var)
next
  case (Fun t1 t2) then show ?case by fastforce
qed

lemma free_tv_app_subst_type_scheme:
    "free_tv ($ S (sch::type_scheme)) \<subseteq> cod S \<union> free_tv sch"
proof (induct sch)
  case (FVar n)
  then show ?case by (simp add: free_tv_subst_var)
next
  case (BVar n)
  then show ?case by simp
next
  case (SFun t1 t2)
  then show ?case by fastforce
qed

lemma free_tv_app_subst_scheme_list: "free_tv ($ S (A::type_scheme list)) \<subseteq> cod S \<union> free_tv A"
proof (induct A)
  case Nil then show ?case by simp
next
  case (Cons a al)
  with free_tv_app_subst_type_scheme
  show ?case by fastforce
qed

lemma free_tv_comp_subst:
  "free_tv (\<lambda>u::nat. $ s1 (s2 u) :: typ) \<subseteq>
    free_tv s1 Un free_tv s2"
unfolding free_tv_subst dom_def
by (force simp add: cod_def dom_def dest!:free_tv_app_subst_te [THEN subsetD])

lemma free_tv_o_subst:
  "free_tv ($ S1 \<circ> S2) \<subseteq> free_tv S1 \<union> free_tv (S2 :: nat => typ)"
unfolding o_def by (rule free_tv_comp_subst)

lemma free_tv_of_substitutions_extend_to_types:
  "n : free_tv t \<Longrightarrow> free_tv (S n) \<subseteq> free_tv ($ S t::typ)"
by (induct t) auto

lemma free_tv_of_substitutions_extend_to_schemes:
  "n : free_tv sch \<Longrightarrow> free_tv (S n) \<subseteq> free_tv ($ S sch::type_scheme)"
by (induct sch) auto

lemma free_tv_of_substitutions_extend_to_scheme_lists [simp]:
  "n : free_tv A \<Longrightarrow> free_tv (S n) \<subseteq> free_tv ($ S A::type_scheme list)"
by (induct A) (auto dest: free_tv_of_substitutions_extend_to_schemes)

lemma free_tv_ML_scheme:
  fixes sch :: type_scheme
  shows "(n : free_tv sch) = (n: set (free_tv_ML sch))"
by (induct sch) simp_all

lemma free_tv_ML_scheme_list:
  fixes A :: "type_scheme list"
  shows "(n : free_tv A) = (n: set (free_tv_ML A))"
by (induct_tac A) (simp_all add: free_tv_ML_scheme)

\<comment> \<open>lemmata for @{text bound_tv}\<close>

lemma bound_tv_mk_scheme [simp]: "bound_tv (mk_scheme t) = {}"
by (induct t) simp_all

lemma bound_tv_subst_scheme [simp]:
  fixes sch :: type_scheme
  shows "bound_tv ($ S sch) = bound_tv sch"
by (induct sch) simp_all

lemma bound_tv_subst_scheme_list [simp]:
  fixes A :: "type_scheme list"
  shows "bound_tv ($ S A) = bound_tv A"
by (induct A) simp_all

\<comment> \<open>Lemmata for @{text new_tv}\<close>

lemma new_tv_subst:
  "new_tv n S = ((\<forall>m. n \<le> m \<longrightarrow> (S m = TVar m)) \<and>
                 (\<forall>l. l < n \<longrightarrow> new_tv n (S l) ))"
unfolding new_tv_def  free_tv_subst cod_def dom_def
apply rule
 apply force
by simp (meson not_le)

lemma new_tv_list: "new_tv n x = (\<forall>y\<in>set x. new_tv n y)"
by (induction x) simp_all

\<comment> \<open>substitution affects only variables occurring freely\<close>
lemma subst_te_new_tv:
  "new_tv n (t::typ) \<Longrightarrow> $(\<lambda>x. if x=n then t' else S x) t = $S t"
by (induct t) simp_all

lemma subst_te_new_type_scheme:
  "new_tv n (sch::type_scheme) \<Longrightarrow> $(\<lambda>x. if x=n then sch' else S x) sch = $S sch"
by (induct sch) simp_all

lemma subst_tel_new_scheme_list [simp]:
  "new_tv n (A::type_scheme list) \<Longrightarrow> $(\<lambda>x. if x=n then t else S x) A = $S A"
by (induct A) (simp_all add: subst_te_new_type_scheme)

\<comment> \<open>all greater variables are also new\<close>
lemma new_tv_le:
  "n\<le>m \<Longrightarrow> new_tv n t \<Longrightarrow> new_tv m t"
by (meson less_le_trans new_tv_def)

lemma new_tv_Suc[simp]: "new_tv n t \<Longrightarrow> new_tv (Suc n) t"
by (rule lessI [THEN less_imp_le [THEN new_tv_le]])

\<comment> \<open>@{text new_tv} property remains if a substitution is applied\<close>
lemma new_tv_subst_var:
  "[| n<m; new_tv m (S::subst) |] ==> new_tv m (S n)"
by (simp add: new_tv_subst)

lemma new_tv_subst_te [simp]:
  "new_tv n S \<Longrightarrow> new_tv n (t::typ) \<Longrightarrow> new_tv n ($ S t)"
by (induction t) (auto simp add: new_tv_subst)

lemma new_tv_subst_scheme_list:
  "new_tv n S \<Longrightarrow> new_tv n (A::type_scheme list) \<Longrightarrow> new_tv n ($ S A)"
by (meson UnE codD free_tv_app_subst_scheme_list in_mono new_tv_def)

lemma new_tv_only_depends_on_free_tv_type_scheme:
  fixes sch :: type_scheme
  shows "free_tv sch = free_tv sch' \<Longrightarrow> new_tv n sch \<Longrightarrow> new_tv n sch'"
  unfolding new_tv_def by simp

lemma new_tv_only_depends_on_free_tv_scheme_list:
  fixes A :: "type_scheme list"
  shows "free_tv A = free_tv A' \<Longrightarrow> new_tv n A \<Longrightarrow> new_tv n A'"
  unfolding new_tv_def by simp

lemma new_tv_nth_nat_A:
  "m < length A \<Longrightarrow> new_tv n A \<Longrightarrow> new_tv n (A!m)"
unfolding new_tv_def using free_tv_nth_A_impl_free_tv_A by blast

\<comment> \<open>composition of substitutions preserves @{text new_tv} proposition\<close>
lemma new_tv_subst_comp_1:
  "[| new_tv n (S::subst); new_tv n R |] ==> new_tv n (($ R) \<circ> S)"
by (simp add: new_tv_subst)

lemma new_tv_subst_comp_2 :
  "[| new_tv n (S::subst); new_tv n R |] ==> new_tv n (\<lambda>v.$ R (S v))"
by (simp add: new_tv_subst)

\<comment> \<open>new type variables do not occur freely in a type structure\<close>
lemma new_tv_not_free_tv:
  "new_tv n A \<Longrightarrow> n \<notin> free_tv A"
by (auto simp add: new_tv_def)

lemma fresh_variable_types: "\<exists>n. new_tv n (t::typ)"
apply (unfold new_tv_def)
apply (induction t)
 apply auto[1]
by (metis less_trans linorder_cases new_tv_Fun new_tv_def)

lemma fresh_variable_type_schemes:
  "\<exists>n. new_tv n (sch::type_scheme)"
apply (unfold new_tv_def)
apply (induct_tac sch)
  apply (auto)[1]
 apply simp
by (metis less_trans linorder_cases new_tv_Fun2 new_tv_def)

lemma fresh_variable_type_scheme_lists:
  "\<exists>n. new_tv n (A::type_scheme list)"
apply (induction A)
 apply (simp)
by (metis fresh_variable_type_schemes le_cases new_tv_Cons new_tv_le)

lemma make_one_new_out_of_two:
  "[| \<exists>n1. (new_tv n1 x); \<exists>n2. (new_tv n2 y)|] ==> \<exists>n. (new_tv n x) \<and> (new_tv n y)"
by (meson new_tv_le nle_le)

lemma ex_fresh_variable:
  "\<And>(A::type_scheme list) (A'::type_scheme list) (t::typ) (t'::typ).
          \<exists>n. (new_tv n A) \<and> (new_tv n A') \<and> (new_tv n t) \<and> (new_tv n t')"
by (meson fresh_variable_type_scheme_lists fresh_variable_types max.cobounded1 max.cobounded2 new_tv_le)

\<comment> \<open>mgu does not introduce new type variables\<close>
lemma mgu_new:
  "[|mgu t1 t2 = Some u; new_tv n t1; new_tv n t2|] ==> new_tv n u"
by (meson UnE mgu_free new_tv_def subsetD)

(* lemmata for substitutions *)

lemma length_app_subst_list [simp]:
  "\<And>A:: ('a::type_struct) list. length ($ S A) = length A"
unfolding app_subst_list by simp

lemma subst_TVar_scheme [simp]:
  fixes sch :: type_scheme
  shows "$ TVar sch = sch"
by (induct sch) simp_all

lemma subst_TVar_scheme_list [simp]:
  fixes A :: "type_scheme list"
  shows "$ TVar A = A"
by (induct A) (simp_all add: app_subst_list)

\<comment> \<open>application of @{text id_subst} does not change type expression\<close>
lemma app_subst_id_te [simp]: "$ id_subst = (\<lambda>t::typ. t)"
by (metis id_subst_def mk_scheme_injective subst_TVar_scheme subst_mk_scheme)

lemma app_subst_id_type_scheme [simp]:
  "$ id_subst = (\<lambda>sch::type_scheme. sch)"
using id_subst_def subst_TVar_scheme by auto

\<comment> \<open>application of @{text id_subst} does not change list of type expressions\<close>
lemma app_subst_id_tel [simp]:
  "$ id_subst = (\<lambda>A::type_scheme list. A)"
using id_subst_def subst_TVar_scheme_list by auto

\<comment> \<open>composition of substitutions\<close>
lemma o_id_subst [simp]: "$S \<circ> id_subst = S"
unfolding id_subst_def o_def by simp

lemma subst_comp_te: "$ R ($ S t::typ) = $ (\<lambda>x. $ R (S x) ) t"
by (induct t) simp_all

lemma subst_comp_type_scheme:
  "$ R ($ S sch::type_scheme) = $ (\<lambda>x. $ R (S x) ) sch"
by (induct sch) simp_all

lemma subst_comp_scheme_list:
  "$ R ($ S A::type_scheme list) = $ (\<lambda>x. $ R (S x)) A"
unfolding app_subst_list
proof (induct A)
  case Nil thus ?case by simp
next
  case Cons thus ?case by (simp add: subst_comp_type_scheme)
qed

lemma nth_subst:
  "n < length A \<Longrightarrow> ($ S A)!n = $S (A!n)"
by (simp add: app_subst_list)

end


 (*  Title:      AuxiliaryFunctions.thy
    Author:     Ludovic Henrio and Florian Kammuller
                2014
    Note:       Functions on Maps for Multi-active object formalisation
                Plus generic lemmas (not related to MAO)
*)

header {* Auxiliary functions for Multi-ASP *}

theory AuxiliaryFunctions imports Main begin

definition
  remove_from_map :: "('a ~=> 'b) => 'a  => ('a ~=> 'b)"  (infixl "|``"  110) where
  "m|``x = m|`(dom m - {x})"

definition listunionMap:: "('a \<Rightarrow> 'b set) \<Rightarrow> ('a list) \<Rightarrow> 'b set"
where
  "listunionMap f l \<equiv> (foldr (op  \<union>) (map f l) {})"

lemma listunionMap_Empty[simp]: "listunionMap f [] = {}"
by (auto simp: listunionMap_def)

(*
lemma listunionMap_Empty_fun[simp]: "listunionMap (\<lambda>x.{}) (L::'a list) = {}"
apply (induct_tac L)
apply (auto simp: listunionMap_def)
done
*)

lemma listunionMap_Empty_fun[simp]: "listunionMap (\<lambda>x.{}) (L::'a list) = {}"
by (induct L, auto simp: listunionMap_def)
lemma listunionMap_Single[simp]: "listunionMap f [x] = f x"
by ( auto simp: listunionMap_def)

lemma listunionMap_Cons[simp]: "listunionMap f (x#L) = (f x) \<union> (listunionMap f L)"
by ( auto simp: listunionMap_def)

section{*several lemmas*}
lemma map_of_zip_empty[rule_format,simp]: "ran (map_of (zip [] Y)) = {}"
by auto
lemma map_of_zip_replicate[rule_format,intro]: "x\<in>set vl \<longrightarrow>map_of (zip vl (replicate (length vl) Y)) x = Some Y"
by (induct_tac vl, auto)

lemma map_of_zip_outside_dom[rule_format,intro]: "x\<notin>set vl \<longrightarrow>map_of (zip vl (replicate (length vl) Y)) x = None"
by (induct_tac vl, auto)

lemma map_of_zip_replicate_simp[rule_format,simp]:
    "map_of (zip vl (replicate (length vl) Y)) x = (if (x\<in>set vl) then Some Y else None)"
by (case_tac "(x\<in>set vl)",  auto simp: map_of_zip_replicate map_of_zip_outside_dom)

lemma map_of_zip_replicate_map_simp[rule_format,simp]:
    "map_of (zip (map f vl) (replicate (length vl) Y)) x = (if (x\<in>set (map f vl)) then Some Y else None)"
apply (subgoal_tac "length vl = length (map f vl)")
apply (erule ssubst)
apply (simp only: map_of_zip_replicate_simp)
apply simp
done

lemma ran_map_of_zip_repl: "ran (map_of (zip (v#vl) (replicate (length (v#vl)) Y))) = {Y}"
by (auto simp: ran_def)
lemma ran_map_of_zip_2: "N=length L\<Longrightarrow>if (N=0) then ran (map_of (zip L (replicate N Y))) = {} else ran (map_of (zip L (replicate N Y))) = {Y}"
by (cases, auto simp: ran_def)

lemma ran_update: "ran (M(x\<mapsto>V)) \<subseteq> ran M \<union> {V}"
by (auto simp: ran_def)

lemma map_of_zip: "length xs=length ys \<Longrightarrow>(x \<in> set xs) = (\<exists>y\<in>set ys. map_of (zip xs ys) x = Some y)"
apply (induct rule: list_induct2)
apply (auto)
apply (drule Map.map_of_zip_is_None,auto)
done

lemma ran_map_of_zip: "map_of (zip xs ys) x = Some y \<Longrightarrow>length xs=length ys \<Longrightarrow>y\<in>set ys"
by (frule map_of_zip_is_Some, drule map_of_zip, auto)

primrec allTrue_list
where
  "allTrue_list Nil = True" |
  "allTrue_list (a#L) = (a\<and>allTrue_list L)"

lemma allTrue_list_nth: "allTrue_list L =(\<forall>n<length L. L!n)"
apply (induct_tac L)
apply auto
apply (case_tac n, auto)
done
(* abbreviation allTrue_list
where
"allTrue_list L \<equiv>\<forall>n<length L. L!n" *)

lemma allTrue_list_set: "allTrue_list L \<Longrightarrow>a\<in>set L \<Longrightarrow> a"
by (induct L,auto)
lemma allTrue_list_set_map: "allTrue_list (map f L) \<Longrightarrow>a\<in>set L \<Longrightarrow> f a"
by (induct L,auto)

lemma foldr_Un_larger: "x\<in> foldr (op \<union>) L (L') \<Longrightarrow> x \<in> foldr (op \<union>) L (a \<union> L')"
by (induct L, auto)
lemma foldr_Un_mapI[intro]: " {N} \<in> f ` set L \<Longrightarrow> N \<in> foldr op \<union> (map f L) S"
by (induct L, auto)

lemma foldr_Un_other: "x\<in> a \<Longrightarrow> x \<in> foldr (op \<union>) L (a \<union> L')"
by (induct L, auto)

lemma foldr_Un_init[rule_format]: "\<forall> L . x\<in>L \<longrightarrow>x\<in> fold (\<lambda>x S. S \<union> F x S) list L"
by (induct list, auto)

lemma foldr_Un_mapD :
"x \<in> foldr op \<union> (map f L) {} \<Longrightarrow> \<exists>y\<in>set L. x\<in>f y"
by (induct L, auto)

lemma foldr_Un_Union[simp] :
"foldr op \<union> (map f L) {} = \<Union>(set (map f L))"
by (induct L, auto)
(*SIMPLIFY ? ? ?  *)

lemma Map_restrict_Some: "(m|`A) x = Some y \<Longrightarrow> x\<in>A"
apply (erule contrapos_pp)
apply force
done

lemma ran_and_dom: "ran f = the`f`dom f  "
apply (auto simp: ran_def dom_def)
apply (subgoal_tac "x=the (f a) ")
apply blast
apply force
done

lemma sorted_list_of_set_card_length: " finite S \<Longrightarrow> card S = length (sorted_list_of_set S)"
apply (erule Finite_Set.finite_induct)
apply auto
done

lemma insortI_x: "x\<in>set (insort x L)"
apply (induct_tac L)
apply auto
done

lemma insortI_L[rule_format]: "x\<in>set L \<longrightarrow>x\<in>set (insort y L)"
apply (induct_tac L)
apply auto
done

lemma insortD[rule_format]: "y\<in>set (insort x L)\<longrightarrow>(y=x\<or>y\<in>set L)"
apply (induct_tac L)
apply auto
done

lemma sorted_list_of_set_nthI[rule_format]: " finite S \<Longrightarrow>x\<in>S \<longrightarrow>(\<exists> n<card S . (sorted_list_of_set S)!n = x) "
apply (erule Finite_Set.finite_induct)
apply (force)
apply (case_tac "x=xa",simp)
apply (insert insortI_x [of x])
apply (drule_tac x="(sorted_list_of_set F)" in meta_spec)
apply (drule sorted_list_of_set_card_length)
apply ( clarsimp simp: set_conv_nth)
apply force
apply clarsimp
apply (insert insortI_L)
apply (drule_tac x=x in meta_spec)+
apply (drule_tac x="(sorted_list_of_set F)" in meta_spec)+
apply (drule_tac x=xa in meta_spec)+
apply (erule meta_impE)
apply (clarsimp simp: set_conv_nth)
apply (rule_tac x=n in exI,simp)
apply (drule sorted_list_of_set_card_length,simp)
apply (clarsimp simp: set_conv_nth)
apply (rule_tac x=ia in exI,simp)
apply (drule sorted_list_of_set_card_length,simp)
done

lemma sorted_list_of_set_nthD[rule_format]: " finite S \<Longrightarrow> n<card S \<longrightarrow>(sorted_list_of_set S)!n = x \<longrightarrow>x\<in>S "
apply (erule Finite_Set.finite_induct)
apply clarsimp
apply clarsimp
apply (case_tac "x=xa")
apply simp
apply simp
apply (subgoal_tac "x \<in> set (insort xa (sorted_list_of_set F) )")
apply (drule insortD)
apply force
apply (clarsimp simp: set_conv_nth)
apply (rule_tac x=n in exI,simp)
apply (drule sorted_list_of_set_card_length,simp)
done

lemma UNION_eqI: " \<forall>x\<in>A.  \<exists>z\<in>C. B x = D z \<Longrightarrow> \<forall>z\<in>C. \<exists>x\<in>A.  B x = D z \<Longrightarrow>(\<Union>x\<in>A. B x) = (\<Union>z\<in>C. D z)"
apply auto
apply (drule_tac x=xa in bspec)
apply auto
apply (drule_tac x=z in bspec)
apply auto
done

lemma UNION_UNION_eqI: " \<forall>x\<in>A. \<forall> y\<in>F x. \<exists>z\<in>C. B y = D z \<Longrightarrow> \<forall>z\<in>C. \<exists>x\<in>A. \<exists> y\<in> F x. B y = D z \<Longrightarrow>(\<Union>x\<in>A.\<Union>y\<in>F x. B y) = (\<Union>z\<in>C. D z)"
apply auto
apply (drule_tac x=xa in bspec)
apply simp
apply (drule_tac x=y in bspec)
apply auto
apply (drule_tac x=z in bspec)
apply auto
apply blast
done
end


(*  Title:      HOL/UNITY/Comp/Progress.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2003  University of Cambridge

David Meier's thesis
*)

section\<open>Progress Set Examples\<close>

theory Progress imports "../UNITY_Main" begin

subsection \<open>The Composition of Two Single-Assignment Programs\<close>
text\<open>Thesis Section 4.4.2\<close>

definition FF :: "int program" where
    "FF = mk_total_program (UNIV, {range (\<lambda>x. (x, x+1))}, UNIV)"

definition GG :: "int program" where
    "GG = mk_total_program (UNIV, {range (\<lambda>x. (x, 2*x))}, UNIV)"

subsubsection \<open>Calculating \<^term>\<open>wens_set FF (atLeast k)\<close>\<close>

lemma Domain_actFF: "Domain (range (\<lambda>x::int. (x, x + 1))) = UNIV"
by force

lemma FF_eq:
      "FF = mk_program (UNIV, {range (\<lambda>x. (x, x+1))}, UNIV)"
by (simp add: FF_def mk_total_program_def totalize_def totalize_act_def
              program_equalityI Domain_actFF)

lemma wp_actFF:
     "wp (range (\<lambda>x::int. (x, x + 1))) (atLeast k) = atLeast (k - 1)"
by (force simp add: wp_def)

lemma wens_FF: "wens FF (range (\<lambda>x. (x, x+1))) (atLeast k) = atLeast (k - 1)"
by (force simp add: FF_eq wens_single_eq wp_actFF)

lemma single_valued_actFF: "single_valued (range (\<lambda>x::int. (x, x + 1)))"
by (force simp add: single_valued_def)

lemma wens_single_finite_FF:
     "wens_single_finite (range (\<lambda>x. (x, x+1))) (atLeast k) n =
      atLeast (k - int n)"
apply (induct n, simp)
apply (force simp add: wens_FF
            def_wens_single_finite_Suc_eq_wens [OF FF_eq single_valued_actFF])
done

lemma wens_single_FF_eq_UNIV:
     "wens_single (range (\<lambda>x::int. (x, x + 1))) (atLeast k) = UNIV"
apply (auto simp add: wens_single_eq_Union)
apply (rule_tac x="nat (k-x)" in exI)
apply (simp add: wens_single_finite_FF)
done

lemma wens_set_FF:
     "wens_set FF (atLeast k) = insert UNIV (atLeast ` atMost k)"
apply (auto simp add: wens_set_single_eq [OF FF_eq single_valued_actFF]
                      wens_single_FF_eq_UNIV wens_single_finite_FF)
apply (erule notE)
apply (rule_tac x="nat (k-xa)" in range_eqI)
apply (simp add: wens_single_finite_FF)
done

subsubsection \<open>Proving \<^term>\<open>FF \<in> UNIV leadsTo atLeast (k::int)\<close>\<close>

lemma atLeast_ensures: "FF \<in> atLeast (k - 1) ensures atLeast (k::int)"
apply (simp add: Progress.wens_FF [symmetric] wens_ensures)
apply (simp add: wens_ensures FF_eq)
done

lemma atLeast_leadsTo: "FF \<in> atLeast (k - int n) leadsTo atLeast (k::int)"
apply (induct n)
 apply (simp_all add: leadsTo_refl)
apply (rule_tac A = "atLeast (k - int n - 1)" in leadsTo_weaken_L)
 apply (blast intro: leadsTo_Trans atLeast_ensures, force)
done

lemma UN_atLeast_UNIV: "(\<Union>n. atLeast (k - int n)) = UNIV"
apply auto
apply (rule_tac x = "nat (k - x)" in exI, simp)
done

lemma FF_leadsTo: "FF \<in> UNIV leadsTo atLeast (k::int)"
apply (subst UN_atLeast_UNIV [symmetric])
apply (rule leadsTo_UN [OF atLeast_leadsTo])
done

text\<open>Result (4.39): Applying the leadsTo-Join Theorem\<close>
theorem "FF\<squnion>GG \<in> atLeast 0 leadsTo atLeast (k::int)"
apply (subgoal_tac "FF\<squnion>GG \<in> (atLeast 0 \<inter> atLeast 0) leadsTo atLeast k")
 apply simp
apply (rule_tac T = "atLeast 0" in leadsTo_Join)
  apply (rule leadsTo_weaken_L [OF FF_leadsTo], simp)
 apply (simp add: awp_iff_constrains FF_def, safety)
apply (simp add: awp_iff_constrains GG_def wens_set_FF, safety)
done

end


theory Cake
imports "$HIPSTER_HOME/IsaHipster"

begin

datatype Slice = Chocolate | Marzipan | Berries

(* A "Swedish piece" is the last slice of cake that any Swedish person will
   feel greedy and impolite if taking. It will typically be cut smaller and smaller,
   as everybody desperately tries to avoid taking the very last tiny bit. *)
datatype Cake = Eaten | SwedishPiece Slice | BigPiece Slice Cake Slice

fun like :: "Slice \<Rightarrow> bool"
where
   "like Chocolate = False"
 | "like Marzipan = True"
 | "like Berries = True"

fun isTasty :: "Cake \<Rightarrow> bool"
where
    "isTasty Eaten = True"
  | "isTasty (SwedishPiece slice) = like slice"
  | "isTasty (BigPiece leftSlice cake rightSlice) =
  (like leftSlice \<and> like rightSlice \<and> isTasty cake)"

fun merge :: "Cake \<Rightarrow> Cake \<Rightarrow> Cake"
where
    "merge Eaten cake = cake"
  | "merge cake Eaten = cake"
  | "merge (SwedishPiece slice1) (SwedishPiece slice2) =
      BigPiece slice1 Eaten slice2"
  | "merge (SwedishPiece slice) (BigPiece sl cake sr)=
      BigPiece slice (merge (SwedishPiece sl) cake) sr"
  | "merge (BigPiece sl cake sr) (SwedishPiece slice) =
      BigPiece sl (merge cake (SwedishPiece sr)) slice"
  | "merge (BigPiece sl1 cake1 sr1) (BigPiece sl2 cake2 sr2) =
      BigPiece sl1 (merge cake1 (merge (SwedishPiece sr1) cake2)) sr2"

fun cutLeft :: "Cake \<Rightarrow> (Slice * Cake)"
where
   "cutLeft (SwedishPiece slice) = (slice, Eaten)"
  |"cutLeft (BigPiece l cake r) = (l, merge cake (SwedishPiece r))"

fun cutRight :: "Cake \<Rightarrow> (Slice * Cake)"
where
   "cutRight (SwedishPiece slice) = (slice, Eaten)"
  |"cutRight (BigPiece l cake r) = (r, merge (SwedishPiece l) cake)"

hipster cutLeft cutRight

hipster merge isTasty
(*
lemma lemma_a [thy_expl,simp]: "merge x2 Eaten = x2"
by (hipster_induct_simp_metis Cake.merge.simps Cake.isTasty.simps)

lemma lemma_aa [thy_expl]: "merge (merge x2 y2) z2 = merge x2 (merge y2 z2)"
by (hipster_induct_simp_metis Cake.merge.simps Cake.isTasty.simps)

lemma unknown [thy_expl]: "\<lbrakk>isTasty x \<and> isTasty y\<rbrakk> \<Longrightarrow> isTasty (merge x y) = isTasty (merge y x)"
apply (induct x)
apply simp
apply simp

lemma unknown2 [thy_expl]: "isTasty (merge x x) = isTasty x"
by simp
*)

end


(*  Author:     Gertrud Bauer, Tobias Nipkow
*)

header {* Graph *}

theory Graph
imports Rotation
begin

syntax (xsymbols)
  "_UNION1"     :: "pttrns => 'b set => 'b set"           ("(3\<Union>(00\<^bsub>_\<^esub>)/ _)" [0, 10] 10)
  "_INTER1"     :: "pttrns => 'b set => 'b set"           ("(3\<Inter>(00\<^bsub>_\<^esub>)/ _)" [0, 10] 10)
  "_UNION"      :: "pttrn => 'a set => 'b set => 'b set"  ("(3\<Union>(00\<^bsub>_\<in>_\<^esub>)/ _)" [0, 0, 10] 10)
  "_INTER"      :: "pttrn => 'a set => 'b set => 'b set"  ("(3\<Inter>(00\<^bsub>_\<in>_\<^esub>)/ _)" [0, 0, 10] 10)

subsection{* Notation *}

type_synonym vertex = "nat"

consts
  vertices :: "'a \<Rightarrow> vertex list"
  edges :: "'a \<Rightarrow> (vertex \<times> vertex) set" ("\<E>")

abbreviation vertices_set :: "'a \<Rightarrow> vertex set" ("\<V>") where
  "\<V> f \<equiv> set (vertices f)"

subsection {* Faces *}

text {*
We represent faces by (distinct) lists of vertices and a face type.
*}

datatype facetype = Final | Nonfinal

datatype face = Face "(vertex list)"  facetype

consts final :: "'a \<Rightarrow> bool"
consts type :: "'a \<Rightarrow> facetype"

overloading
  final_face \<equiv> "final :: face \<Rightarrow> bool"
  type_face \<equiv> "type :: face \<Rightarrow> facetype"
  vertices_face \<equiv> "vertices :: face \<Rightarrow> vertex list"
begin

primrec final_face where
  "final (Face vs f) = (case f of Final \<Rightarrow> True | Nonfinal \<Rightarrow> False)"

primrec type_face where
  "type (Face vs f) = f"

primrec vertices_face where
  "vertices (Face vs f) = vs"

end

defs (overloaded) cong_face_def:
 "f\<^sub>1 \<cong> (f\<^sub>2::face) \<equiv> vertices f\<^sub>1 \<cong> vertices f\<^sub>2"

text {* The following operation makes a face final. *}

definition setFinal :: "face \<Rightarrow> face" where
  "setFinal f \<equiv> Face (vertices f) Final"

text {* The function @{text nextVertex} (written @{text "f \<bullet> v"}) is based on
@{text nextElem}, that returns the successor of an element in a list.  *}

primrec nextElem :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
 "nextElem [] b x = b"
|"nextElem (a#as) b x =
    (if x=a then (case as of [] \<Rightarrow> b | (a'#as') \<Rightarrow> a') else nextElem as b x)"

definition nextVertex :: "face \<Rightarrow> vertex \<Rightarrow> vertex" (*<*)("_ \<bullet>" [999]) (*>*)where (* *)
 "f \<bullet> \<equiv> let vs = vertices f in nextElem vs (hd vs)"

text {* @{text nextVertices} is $n$-fold application of
@{text nextvertex}. *}

definition nextVertices :: "face \<Rightarrow> nat \<Rightarrow> vertex \<Rightarrow> vertex" (*<*)("_\<^bsup>_\<^esup> \<bullet> _" [100, 0, 100]) (*>*)where (* *)
  "f\<^bsup>n\<^esup> \<bullet> v \<equiv> (f \<bullet> ^^ n) v"

lemma nextV2: "f\<^bsup>2\<^esup>\<bullet>v = f\<bullet> (f\<bullet> v)"
by (simp add: nextVertices_def eval_nat_numeral)

(*<*) defs (overloaded) edges_face_def: (*>*)
  "edges (f::face) \<equiv> {(a, f \<bullet> a)|a. a \<in> \<V> f}"

(*<*)consts op :: "'a \<Rightarrow> 'a" ("_\<^bsup>op\<^esup>" [1000] 999)  (*>*) (* *)
defs (*<*) (overloaded) op_vertices_def:(*>*) "(vs::vertex list)\<^bsup>op\<^esup> \<equiv> rev vs"
overloading
  op_graph \<equiv> "Graph.op :: face \<Rightarrow> face"
begin

primrec op_graph where "(Face vs f)\<^bsup>op\<^esup> = Face (rev vs) f"  (*<*)

end

definition prevVertex :: "face \<Rightarrow> vertex \<Rightarrow> vertex" (*<*)("_\<^bsup>-1\<^esup> \<bullet>" [100]) (*>*)where (* *)
  "f\<^bsup>-1\<^esup> \<bullet> v \<equiv> (let vs = vertices f in nextElem (rev vs) (last vs) v)"

abbreviation
  triangle :: "face \<Rightarrow> bool" where
  "triangle f == |vertices f| = 3"

subsection {* Graphs *}

datatype graph = Graph "(face list)" "nat" "face list list" "nat list"

primrec faces :: "graph \<Rightarrow> face list" where
  "faces (Graph fs n f h) = fs"

abbreviation
  Faces :: "graph \<Rightarrow> face set" ("\<F>") where
  "\<F> g == set(faces g)"

primrec countVertices :: "graph \<Rightarrow> nat" where
  "countVertices (Graph fs n f h) = n"

overloading
  vertices_graph \<equiv> "vertices :: graph \<Rightarrow> vertex list"
begin

primrec vertices_graph where "vertices (Graph fs n f h) = [0 ..< n]"

end

lemma vertices_graph: "vertices g = [0 ..< countVertices g]"
by (induct g) simp

lemma in_vertices_graph:
  "v \<in> set (vertices g) = (v < countVertices g)"
by (simp add:vertices_graph)

lemma len_vertices_graph:
  "|vertices g| = countVertices g"
by (simp add:vertices_graph)

primrec faceListAt :: "graph \<Rightarrow> face list list" where
  "faceListAt (Graph fs n f h) = f"

definition facesAt :: "graph \<Rightarrow> vertex \<Rightarrow> face list" where
 "facesAt g v \<equiv> (*if v \<in> set(vertices g) then*) faceListAt g ! v (*else []*)"

primrec heights :: "graph \<Rightarrow> nat list" where
  "heights (Graph fs n f h) = h"

definition height :: "graph \<Rightarrow> vertex \<Rightarrow> nat" where
  "height g v \<equiv> heights g ! v"

definition graph :: "nat \<Rightarrow> graph" where
  "graph n \<equiv>
    (let vs = [0 ..< n];
     fs = [ Face vs Final, Face (rev vs) Nonfinal]
     in (Graph fs n (replicate n fs) (replicate n 0)))"

subsection{* Operations on graphs *}

text {* final graph, final / nonfinal faces *}

definition finals :: "graph \<Rightarrow> face list" where
  "finals g \<equiv> [f \<leftarrow> faces g. final f]"

definition nonFinals :: "graph \<Rightarrow> face list" where
  "nonFinals g \<equiv> [f \<leftarrow> faces g. \<not> final f]"

definition countNonFinals :: "graph \<Rightarrow> nat" where
  "countNonFinals g \<equiv> |nonFinals g|"

defs (overloaded) finalGraph_def: "final g \<equiv> (nonFinals g = [])"

lemma finalGraph_faces[simp]: "final g \<Longrightarrow> finals g = faces g"
 by (simp add: finalGraph_def finals_def nonFinals_def filter_compl1)

lemma finalGraph_face: "final g \<Longrightarrow> f \<in> set (faces g) \<Longrightarrow> final f"
  by (simp only: finalGraph_faces[symmetric]) (simp add: finals_def)

definition finalVertex :: "graph \<Rightarrow> vertex \<Rightarrow> bool" where
  "finalVertex g v \<equiv> \<forall>f \<in> set(facesAt g v). final f"

lemma finalVertex_final_face[dest]:
  "finalVertex g v \<Longrightarrow> f \<in> set (facesAt g v) \<Longrightarrow> final f"
  by (auto simp add: finalVertex_def)

text {* counting faces *}

definition degree :: "graph \<Rightarrow> vertex \<Rightarrow> nat" where
  "degree g v \<equiv> |facesAt g v|"

definition tri :: "graph \<Rightarrow> vertex \<Rightarrow> nat" where
 "tri g v \<equiv> |[f \<leftarrow> facesAt g v. final f \<and> |vertices f| = 3]|"

definition quad :: "graph \<Rightarrow> vertex \<Rightarrow> nat" where
 "quad g v \<equiv> |[f \<leftarrow> facesAt g v. final f \<and> |vertices f| = 4]|"

definition except :: "graph \<Rightarrow> vertex \<Rightarrow> nat" where
 "except g v \<equiv> |[f \<leftarrow> facesAt g v. final f \<and> 5 \<le> |vertices f| ]|"

definition vertextype :: "graph \<Rightarrow> vertex \<Rightarrow> nat \<times> nat \<times> nat" where
  "vertextype g v \<equiv> (tri g v, quad g v, except g v)"

lemma[simp]: "0 \<le> quad g v" by (simp add: quad_def)

lemma[simp]: "0 \<le> except g v" by (simp add: except_def)

definition exceptionalVertex :: "graph \<Rightarrow> vertex \<Rightarrow> bool" where
  "exceptionalVertex g v \<equiv> except g v \<noteq> 0"

definition noExceptionals :: "graph \<Rightarrow> vertex set \<Rightarrow> bool" where
  "noExceptionals g V \<equiv> (\<forall>v \<in> V. \<not> exceptionalVertex g v)"

text {* An edge $(a,b)$ is contained in face f,
  $b$ is the successor of $a$ in $f$. *}

defs (overloaded) edges_graph_def: (*>*)
 "edges (g::graph) \<equiv> \<Union>\<^bsub>f \<in> \<F> g\<^esub> edges f"

definition neighbors :: "graph \<Rightarrow> vertex \<Rightarrow> vertex list" where
 "neighbors g v \<equiv> [f\<bullet>v. f \<leftarrow> facesAt g v]"

subsection {* Navigation in graphs *}

text {*
The function $s'$ permutating the faces at a vertex,
is implemeted by the function @{text nextFace}
*}

definition nextFace :: "graph \<times> vertex \<Rightarrow> face \<Rightarrow> face" (*<*)("_ \<bullet>") (*>*)where
(*<*) nextFace_def_aux: "p \<bullet> \<equiv> \<lambda>f. (let (g,v) = p; fs = (facesAt g v) in
   (case fs of [] \<Rightarrow> f
           | g#gs \<Rightarrow> nextElem fs (hd fs) f))"  (*>*)

(* precondition a b in f *)
definition directedLength :: "face \<Rightarrow> vertex \<Rightarrow> vertex \<Rightarrow> nat" where
  "directedLength f a b \<equiv>
  if a = b then 0 else |(between (vertices f) a b)| + 1"

subsection {* Code generator setup *}

definition final_face :: "face \<Rightarrow> bool" where
  final_face_code_def: "final_face = final"
declare final_face_code_def [symmetric, code_unfold]

lemma final_face_code [code]:
  "final_face (Face vs Final) \<longleftrightarrow> True"
  "final_face (Face vs Nonfinal) \<longleftrightarrow> False"
  by (simp_all add: final_face_code_def)

definition final_graph :: "graph \<Rightarrow> bool" where
  final_graph_code_def: "final_graph = final"
declare final_graph_code_def [symmetric, code_unfold]

lemma final_graph_code [code]: "final_graph g = List.null (nonFinals g)"
  unfolding final_graph_code_def finalGraph_def null_def ..

definition vertices_face :: "face \<Rightarrow> vertex list" where
  vertices_face_code_def: "vertices_face = vertices"
declare vertices_face_code_def [symmetric, code_unfold]

lemma vertices_face_code [code]: "vertices_face (Face vs f) = vs"
  unfolding vertices_face_code_def by simp

definition vertices_graph :: "graph \<Rightarrow> vertex list" where
  vertices_graph_code_def: "vertices_graph = vertices"
declare vertices_graph_code_def [symmetric, code_unfold]

lemma vertices_graph_code [code]:
  "vertices_graph (Graph fs n f h) = [0 ..< n]"
  unfolding vertices_graph_code_def by simp

end


section \<open>Bump Functions\<close>
theory Bump_Function
  imports Smooth
    "HOL-Analysis.Weierstrass_Theorems"
begin

subsection \<open>Construction\<close>

context begin

qualified definition f :: "real \<Rightarrow> real" where
  "f t = (if t > 0 then exp(-inverse t) else 0)"

lemma f_nonpos[simp]: "x \<le> 0 \<Longrightarrow> f x = 0"
  by (auto simp: f_def)

lemma exp_inv_limit_0_right:
  "((\<lambda>(t::real). exp(-inverse t)) \<longlongrightarrow> 0) (at_right 0)"
  apply (rule filterlim_compose[where g = exp])
   apply (rule exp_at_bot)
  apply (rule filterlim_compose[where g = uminus])
   apply (rule filterlim_uminus_at_bot_at_top)
  by (rule filterlim_inverse_at_top_right)

lemma "\<forall>\<^sub>F t in at_right 0. ((\<lambda>x. inverse (x ^ Suc k)) has_real_derivative
  - (inverse (t ^ Suc k) * ((1 + real k) * t ^ k) * inverse (t ^ Suc k))) (at t)"
  unfolding eventually_at_filter
  by (auto simp del: power_Suc intro!: derivative_eq_intros eventuallyI)

lemma exp_inv_limit_0_right_gen':
  "((\<lambda>(t::real). inverse (t ^ k) / exp(inverse t)) \<longlongrightarrow> 0) (at_right 0)"
proof (induct k)
  case 0
  then show ?case
    using exp_inv_limit_0_right
    by (auto simp: exp_minus inverse_eq_divide)
next
  case (Suc k)
  have df: "\<forall>\<^sub>F t in at_right 0. ((\<lambda>x. inverse (x ^ Suc k)) has_real_derivative
    - (inverse (t ^ k) * ((1 + real k)) * (inverse t ^ 2))) (at t)"
    unfolding eventually_at_filter
    apply (auto simp del: power_Suc intro!: derivative_eq_intros eventuallyI)
    by (auto simp: power2_eq_square)
  have dg: "\<forall>\<^sub>F t in at_right 0. ((\<lambda>x. exp (inverse x)) has_real_derivative
    - (exp (inverse t) * (inverse t ^ 2))) (at t)"
    unfolding eventually_at_filter
    by (auto simp del: power_Suc intro!: derivative_eq_intros eventuallyI simp: power2_eq_square)
  show ?case
    apply (rule lhopital_right_0_at_top [OF _ _ df dg])
      apply (rule filterlim_compose[where g = exp])
       apply (rule exp_at_top)
      apply (rule filterlim_inverse_at_top_right)
    subgoal by (auto simp: eventually_at_filter)
    subgoal
      apply (rule Lim_transform_eventually[where f = "\<lambda>x. (1 + real k) * (inverse (x ^ k) / exp (inverse x))"])
      using Suc.hyps tendsto_mult_right_zero apply blast
      by (auto simp: eventually_at_filter)
    done
qed

lemma exp_inv_limit_0_right_gen:
  "((\<lambda>(t::real). exp(-inverse t) / t ^ k) \<longlongrightarrow> 0) (at_right 0)"
  using exp_inv_limit_0_right_gen'[of k]
  by (metis (no_types, lifting) Groups.mult_ac(2) Lim_cong_within divide_inverse exp_minus)

lemma f_limit_0_right: "(f \<longlongrightarrow> 0) (at_right 0)"
proof -
  have "\<forall>\<^sub>F t in at_right 0. (t::real) > 0"
    by (rule eventually_at_right_less)
  then have "\<forall>\<^sub>F t in at_right 0. exp(-inverse t) = f t"
    by (eventually_elim) (auto simp: f_def)
  moreover have "((\<lambda>(t::real). exp(-inverse t)) \<longlongrightarrow> 0) (at_right 0)"
    by (rule exp_inv_limit_0_right)
  ultimately show ?thesis
    by (blast intro: Lim_transform_eventually)
qed

lemma f_limit_0: "(f \<longlongrightarrow> 0) (at 0)"
  using _ f_limit_0_right
proof (rule filterlim_split_at_real)
  have "\<forall>\<^sub>F t in at_left 0. 0 = f t"
    by (auto simp: f_def eventually_at_filter)
  then show "(f \<longlongrightarrow> 0) (at_left 0)"
    by (blast intro: Lim_transform_eventually)
qed

lemma f_tendsto: "(f \<longlongrightarrow> f x) (at x)"
proof -
  consider "x = 0" | "x < 0" | "x > 0" by arith
  then show ?thesis
  proof cases
    case 1
    then show ?thesis by (auto simp: f_limit_0 f_def)
  next
    case 2
    have "\<forall>\<^sub>F t in at x. t < 0"
      apply (rule order_tendstoD)
      by (rule tendsto_intros) fact
    then have "\<forall>\<^sub>F t in at x. 0 = f t"
      by (eventually_elim) (auto simp: f_def)
    then show ?thesis
      using \<open>x < 0\<close> by (auto simp: f_def intro: Lim_transform_eventually)
  next
    case 3
    have "\<forall>\<^sub>F t in at x. t > 0"
      apply (rule order_tendstoD)
      by (rule tendsto_intros) fact
    then have "\<forall>\<^sub>F t in at x. exp(-inverse t) = f t"
      by (eventually_elim) (auto simp: f_def)
    moreover have "(\<lambda>t. exp (- inverse t)) \<midarrow>x\<rightarrow> f x"
      using \<open>x > 0\<close> by (auto simp: f_def tendsto_intros )
    ultimately show ?thesis
      by (blast intro: Lim_transform_eventually)
  qed
qed

lemma f_continuous: "continuous_on S f"
  using f_tendsto continuous_on continuous_on_subset subset_UNIV by metis

lemma continuous_on_real_polynomial_function:
  "continuous_on S p" if "real_polynomial_function p"
  using that
  by induction (auto intro: continuous_intros linear_continuous_on)

lemma f_nth_derivative_is_poly:
  "higher_differentiable_on {0<..} f k \<and>
   (\<exists>p. real_polynomial_function p \<and> (\<forall>t>0. nth_derivative k f t 1 = p t / (t ^ (2 * k)) * exp(-inverse t)))"
proof (induction k)
  case 0
  then show ?case
    apply (auto simp: higher_differentiable_on.simps f_continuous)
    by (auto simp: f_def)
next
  case (Suc k)
  obtain p where fk: "higher_differentiable_on {0<..} f k"
    and p1: "real_polynomial_function p"
    and p2: "\<forall>t>0. nth_derivative k f t 1 = p t / t ^ (2 * k) * exp (- inverse t)"
    using Suc by auto
  obtain p' where p'1: "real_polynomial_function p'"
    and p'2: "\<forall>t. (p has_real_derivative (p' t)) (at t)"
    using has_real_derivative_polynomial_function[of p] p1 by auto

  define rp where "rp t = (t\<^sup>2 * p' t - 2 * real k * t * p t + p t)" for t
  have rp: "real_polynomial_function rp"
    unfolding rp_def
    by (auto intro!: real_polynomial_function.intros(2-) real_polynomial_function_diff
        p1 p'1 simp: power2_eq_square)
  moreover
  have fk': "(\<lambda>x. nth_derivative k f x 1) differentiable at t" (is ?a)
    "frechet_derivative (\<lambda>x. nth_derivative k f x 1) (at t) 1 =
        rp t * (exp (-inverse t) / t^(2*k+2))" (is ?b)
    if "0 < t" for t
  proof -
    from p'2 that have dp: "(p has_derivative ((*) (p' t))) (at t within {0<..})"
      by (auto simp: at_within_open[of _ "{0<..}"] has_field_derivative_def ac_simps)
    have "((\<lambda>t. p t / t ^ (2 * k) * exp (- inverse t)) has_derivative
      (\<lambda>v. v * rp t * (exp (-inverse t) / t^(2*k+2)))) (at t within {0<..})"
      using that
      apply (auto intro!: derivative_eq_intros dp ext)
      apply (simp add: divide_simps algebra_simps rp_def power2_eq_square)
      by (metis Suc_pred mult_is_0 neq0_conv power_Suc zero_neq_numeral)
    then have "((\<lambda>x. nth_derivative k f x 1) has_derivative
      (\<lambda>v. v * rp t * (exp (-inverse t) / t^(2*k+2)))) (at t within {0<..})"
      apply (rule has_derivative_transform_within[OF _ zero_less_one])
      using that p2 by (auto simp: )
    then have "((\<lambda>x. nth_derivative k f x 1) has_derivative
      (\<lambda>v. v * rp t * (exp (-inverse t) / t^(2*k+2)))) (at t)"
      using that
      by (auto simp: at_within_open[of _ "{0<..}"])
    from frechet_derivative_at'[OF this] this
    show ?a ?b
      by (auto simp: differentiable_def)
  qed
  have hdS: "higher_differentiable_on {0<..} f (Suc k)"
    apply (subst higher_differentiable_on_real_Suc')
     apply (auto simp: fk fk' frechet_derivative_nth_derivative_commute[symmetric])
    apply (subst continuous_on_cong[OF refl])
     apply (rule fk')
    by (auto intro!: continuous_intros p'1 p1 rp
        intro: continuous_on_real_polynomial_function)
  moreover
  have "nth_derivative (Suc k) f t 1 = rp t / t ^ (2 * (Suc k)) * exp (- inverse t)"
    if "t > 0" for t
  proof -
    have "nth_derivative (Suc k) f t 1 = frechet_derivative (\<lambda>x. nth_derivative k f x 1) (at t) 1"
      by (simp add: frechet_derivative_nth_derivative_commute)

    also have "\<dots> = rp t / t^(2*k+2) * (exp (-inverse t))"
      using fk'[OF \<open>t > 0\<close>] by simp
    finally  show ?thesis by simp
  qed
  ultimately show ?case by blast
qed

lemma f_has_derivative_at_neg:
  " x < 0 \<Longrightarrow> (f has_derivative (\<lambda>x. 0)) (at x)"
  by (rule has_derivative_transform_within_open[where f="\<lambda>x. 0" and s="{..<0}"])
    (auto simp: f_def)

lemma f_differentiable_at_neg:
  "x < 0 \<Longrightarrow> f differentiable at x"
  using f_has_derivative_at_neg
  by (auto simp: differentiable_def)

lemma frechet_derivative_f_at_neg:
  "x \<in> {..<0} \<Longrightarrow> frechet_derivative f (at x) = (\<lambda>x. 0)"
  by (rule frechet_derivative_at') (rule f_has_derivative_at_neg, simp)

lemma f_nth_derivative_lt_0:
  "higher_differentiable_on {..<0} f k \<and> (\<forall>t<0. nth_derivative k f t 1 = 0)"
proof (induction k)
  case 0
  have rewr: "a \<in> {..<0} \<Longrightarrow> \<not>0 < a" for a::real by simp
  show ?case
    by (auto simp: higher_differentiable_on.simps f_def rewr
        simp del: lessThan_iff
        cong: continuous_on_cong)
next
  case (Suc k)
  have "t < 0 \<Longrightarrow> (\<lambda>x. nth_derivative k f x 1) differentiable at t" for t
    by (rule differentiable_eqI[where g=0 and X="{..<0}"])
      (auto simp: zero_fun_def frechet_derivative_const Suc.IH)
  then have "frechet_derivative (\<lambda>x. nth_derivative k f x 1) (at t) 1 = 0" if "t < 0" for t
    using that Suc.IH
    by (subst frechet_derivative_transform_within_open[where X="{..<0}" and g =0])
      (auto simp: frechet_derivative_zero_fun)
  with Suc show ?case
    by (auto simp: higher_differentiable_on.simps f_differentiable_at_neg
        frechet_derivative_f_at_neg zero_fun_def
        simp flip: frechet_derivative_nth_derivative_commute
        simp del: lessThan_iff
        intro!: higher_differentiable_on_const
        cong: higher_differentiable_on_cong)
qed

lemma netlimit_at_left: "netlimit (at_left x) = x" for x::real
  by (rule Lim_ident_at) simp

lemma netlimit_at_right: "netlimit (at_right x) = x" for x::real
  by (rule Lim_ident_at) simp

lemma has_derivative_split_at:
  "(g has_derivative g') (at x)"
  if
    "(g has_derivative g') (at_left x)"
    "(g has_derivative g') (at_right x)"
  for x::real
  using that
  unfolding has_derivative_def netlimit_at netlimit_at_right netlimit_at_left
  by (auto intro: filterlim_split_at)

lemma has_derivative_at_left_at_right':
  "(g has_derivative g') (at x)"
  if
    "(g has_derivative g') (at x within {..x})"
    "(g has_derivative g') (at x within {x..})"
  for x::real
  apply (rule has_derivative_split_at)
  subgoal by (rule has_derivative_within_subset) (fact, auto)
  subgoal by (rule has_derivative_within_subset) (fact, auto)
  done

lemma real_polynomial_function_tendsto:
  "(p \<longlongrightarrow> p x) (at x within X)" if "real_polynomial_function p"
  using that
  by (induction p) (auto intro!: tendsto_eq_intros intro: bounded_linear.tendsto)

lemma f_nth_derivative_cases:
  "higher_differentiable_on UNIV f k \<and>
   (\<forall>t\<le>0. nth_derivative k f t 1 = 0) \<and>
   (\<exists>p. real_polynomial_function p \<and>
      (\<forall>t>0. nth_derivative k f t 1 = p t / (t ^ (2 * k)) * exp(-inverse t)))"
proof (induction k)
  case 0
  then show ?case
    apply (auto simp: higher_differentiable_on.simps f_continuous)
    by (auto simp: f_def)
next
  case (Suc k)
  from Suc.IH obtain pk where IH:
    "higher_differentiable_on UNIV f k"
    "\<And>t. t \<le> 0 \<Longrightarrow> nth_derivative k f t 1 = 0"
    "real_polynomial_function pk"
    "\<And>t. t > 0 \<Longrightarrow> nth_derivative k f t 1 = pk t / t ^ (2 * k) * exp (- inverse t)"
    by auto
  from f_nth_derivative_lt_0[of "Suc k"]
    local.f_nth_derivative_is_poly[of "Suc k"]
  obtain p where neg: "higher_differentiable_on {..<0} f (Suc k)"
    and neg0: "(\<forall>t<0. nth_derivative (Suc k) f t 1 = 0)"
    and pos: "higher_differentiable_on {0<..} f (Suc k)"
    and p: "real_polynomial_function p"
    "\<And>t. t > 0 \<Longrightarrow> nth_derivative (Suc k) f t 1 = p t / t ^ (2 * Suc k) * exp (- inverse t)"
    by auto
  moreover
  have at_within_eq_at_right: "(at 0 within {0..}) = at_right (0::real)"
    apply (auto simp: filter_eq_iff eventually_at_filter )
     apply (simp add: eventually_mono)
    apply (simp add: eventually_mono)
    done
  have [simp]: "{0..} - {0} = {0::real<..}" by auto
  have [simp]: "(at (0::real) within {0..}) \<noteq> bot"
    by (auto simp: at_within_eq_bot_iff)
  have k_th_has_derivative_at_left:
    "((\<lambda>x. nth_derivative k f x 1) has_derivative (\<lambda>x. 0)) (at 0 within {..0})"
    apply (rule has_derivative_transform_within[OF _ zero_less_one])
      prefer 2
      apply force
     prefer 2
     apply (simp add: IH)
    by (rule derivative_intros)
  have k_th_has_derivative_at_right:
    "((\<lambda>x. nth_derivative k f x 1) has_derivative (\<lambda>x. 0)) (at 0 within {0..})"
    apply (rule has_derivative_transform_within[where
          f="\<lambda>x'. if x' = 0 then 0 else pk x' / x' ^ (2 * k) * exp (- inverse x')", OF _ zero_less_one])
    subgoal
      unfolding has_derivative_def
      apply (auto simp: Lim_ident_at)
      apply (rule Lim_transform_eventually[where f="\<lambda>x. (pk x * (exp (- inverse x) / x ^ (2 * k + 1)))"])
       apply (rule tendsto_eq_intros)
         apply (rule real_polynomial_function_tendsto[THEN tendsto_eq_rhs])
          apply fact
         apply (rule refl)
        apply (subst at_within_eq_at_right)
        apply (rule exp_inv_limit_0_right_gen)
      apply (auto simp add: eventually_at_filter divide_simps)
      done
    subgoal by force
    subgoal by (auto simp: IH(2) IH(4))
    done
  have k_th_has_derivative: "((\<lambda>x. nth_derivative k f x 1) has_derivative (\<lambda>x. 0)) (at 0)"
    apply (rule has_derivative_at_left_at_right')
     apply (rule k_th_has_derivative_at_left)
    apply (rule k_th_has_derivative_at_right)
    done
  have nth_Suc_zero: "nth_derivative (Suc k) f 0 1 = 0"
    apply (auto simp: frechet_derivative_nth_derivative_commute[symmetric])
    apply (subst frechet_derivative_at')
     apply (rule k_th_has_derivative)
    by simp
  moreover have "higher_differentiable_on UNIV f (Suc k)"
  proof -
    have "continuous_on UNIV (\<lambda>x. nth_derivative (Suc k) f x 1)"
      unfolding continuous_on_eq_continuous_within
    proof
      fix x::real
      consider "x < 0" | "x > 0" | "x = 0" by arith
      then show "isCont (\<lambda>x. nth_derivative (Suc k) f x 1) x"
      proof cases
        case 1
        then have at_eq: "at x = at x within {..<0}"
          using at_within_open[of x "{..<0}"] by auto
        show ?thesis
          unfolding at_eq
          apply (rule continuous_transform_within[OF _ zero_less_one])
          using neg0 1 by (auto simp: at_eq)
      next
        case 2
        then have at_eq: "at x = at x within {0<..}"
          using at_within_open[of x "{0<..}"] by auto
        show ?thesis
          unfolding at_eq
          apply (rule continuous_transform_within[OF _ zero_less_one])
          using p 2 by (auto intro!: continuous_intros
              intro: continuous_real_polymonial_function continuous_at_imp_continuous_within)
      next
        case 3
        have "((\<lambda>x. nth_derivative (Suc k) f x 1) \<longlongrightarrow> 0) (at_left 0)"
        proof -
          have "\<forall>\<^sub>F x in at_left 0. 0 = nth_derivative (Suc k) f x 1"
            using neg0
            by (auto simp: eventually_at_filter)
          then show ?thesis
            by (blast intro: Lim_transform_eventually)
        qed
        moreover have "((\<lambda>x. nth_derivative (Suc k) f x 1) \<longlongrightarrow> 0) (at_right 0)"
        proof -
          have "((\<lambda>x. p x * (exp (- inverse x) / x ^ (2 * Suc k))) \<longlongrightarrow> 0) (at_right 0)"
            apply (rule tendsto_eq_intros)
              apply (rule real_polynomial_function_tendsto)
              apply fact
             apply (rule exp_inv_limit_0_right_gen)
            by simp
          moreover
          have "\<forall>\<^sub>F x in at_right 0. p x * (exp (- inverse x) / x ^ (2 * Suc k)) =
            nth_derivative (Suc k) f x 1"
            using p
            by (auto simp: eventually_at_filter)
          ultimately show ?thesis
            by (rule Lim_transform_eventually)
        qed
        ultimately show ?thesis
          by (auto simp: continuous_def nth_Suc_zero 3 filterlim_split_at
              simp del: nth_derivative.simps)
      qed
    qed
    moreover have "(\<lambda>x. nth_derivative k f x 1) differentiable at x" for x
    proof -
      consider  "x = 0" | "x < 0" | "x > 0"by arith
      then show ?thesis
      proof cases
        case 1
        then show ?thesis
          using k_th_has_derivative by (auto simp: differentiable_def)
      next
        case 2
        with neg show ?thesis
          by (subst (asm) higher_differentiable_on_real_Suc') (auto simp: )
      next
        case 3
        with pos show ?thesis
          by (subst (asm) higher_differentiable_on_real_Suc') (auto simp: )
      qed
    qed
    moreover have "higher_differentiable_on UNIV f k" by fact
    ultimately
    show ?thesis
      by (subst higher_differentiable_on_real_Suc'[OF open_UNIV]) auto
  qed
  ultimately
  show ?case
    by (auto simp: less_eq_real_def)
qed

lemma f_smooth_on: "k-smooth_on S f"
  and f_higher_differentiable_on: "higher_differentiable_on S f n"
  using f_nth_derivative_cases
  by (auto simp: smooth_on_def higher_differentiable_on_subset[OF _ subset_UNIV])

lemma f_compose_smooth_on: "k-smooth_on S (\<lambda>x. f (g x))"
  if "k-smooth_on S g" "open S"
  using smooth_on_compose[OF f_smooth_on that open_UNIV subset_UNIV]
  by (auto simp: o_def)

lemma f_nonneg: "f x \<ge> 0"
  by (auto simp: f_def)

lemma f_pos_iff: "f x > 0 \<longleftrightarrow> x > 0"
  by (auto simp: f_def)

lemma f_eq_zero_iff: "f x = 0 \<longleftrightarrow> x \<le> 0"
  by (auto simp: f_def)

subsection \<open>Cutoff function\<close>

definition "h t = f (2 - t) / (f (2 - t) + f (t - 1))"

lemma denominator_pos: "f (2 - t) + f (t - 1) > 0"
  by (auto simp: f_def add_pos_pos)

lemma denominator_nonzero: "f (2 - t) + f (t - 1) = 0 \<longleftrightarrow> False"
  using denominator_pos[of t] by auto

lemma h_range: "0 \<le> h t" "h t \<le> 1"
  by (auto simp: h_def f_nonneg denominator_pos)

lemma h_pos: "t < 2 \<Longrightarrow> 0 < h t"
  and h_less_one: "1 < t \<Longrightarrow> h t < 1"
  by (auto simp: h_def f_pos_iff denominator_pos)

lemma h_eq_0: "h t = 0" if "t \<ge> 2"
  using that
  by (auto simp: h_def)

lemma h_eq_1: "h t = 1" if "t \<le> 1"
  using that
  by (auto simp: h_def f_eq_zero_iff)

lemma h_compose_smooth_on: "k-smooth_on S (\<lambda>x. h (g x))"
  if "k-smooth_on S g" "open S"
  by (auto simp: h_def[abs_def] denominator_nonzero
      intro!: smooth_on_divide f_compose_smooth_on smooth_on_minus smooth_on_add
      that)

subsection \<open>Bump function\<close>

definition H::"_::real_inner \<Rightarrow> real" where "H x = h (norm x)"

lemma H_range: "0 \<le> H x" "H x \<le> 1"
  by (auto simp: H_def h_range)

lemma H_eq_one: "H x = 1" if "x \<in> cball 0 1"
  using that
  by (auto simp: H_def h_eq_1)

lemma H_pos: "H x > 0" if "x \<in> ball 0 2"
  using that
  by (auto simp: H_def h_pos)

lemma H_eq_zero: "H x = 0" if "x \<notin> ball 0 2"
  using that
  by (auto simp: H_def h_eq_0)

lemma H_neq_zeroD: "H x \<noteq> 0 \<Longrightarrow> x \<in> ball 0 2"
  using H_eq_zero by blast

lemma H_smooth_on: "k-smooth_on UNIV H"
proof -
  have 1: "k-smooth_on (ball 0 1) H"
    by (rule smooth_on_cong[where g="\<lambda>x. 1"]) (auto simp: H_eq_one)
  have 2: "k-smooth_on (UNIV - cball 0 (1/2)) H"
    by (auto simp: H_def[abs_def]
        intro!: h_compose_smooth_on smooth_on_norm)
  have O: "open (ball 0 1)" "open (UNIV - cball 0 (1 / 2))"
    by auto
  have *: "ball 0 1 \<union> (UNIV - cball 0 (1 / 2)) = UNIV" by (auto simp: mem_ball)
  from smooth_on_open_Un[OF 1 2 O, unfolded *]
  show ?thesis
    by (rule smooth_on_subset) auto
qed

lemma H_compose_smooth_on: "k-smooth_on S (\<lambda>x. H (g x))" if "k-smooth_on S g" "open S"
  for g :: "_ \<Rightarrow> _::euclidean_space"
  using smooth_on_compose[OF H_smooth_on that]
  by (auto simp: o_def)

end

end


(* Title:    HOL/Partial_Function.thy
   Author:   Alexander Krauss, TU Muenchen
*)

section \<open>Partial Function Definitions\<close>

theory Partial_Function
  imports Complete_Partial_Order Option
  keywords "partial_function" :: thy_defn
begin

named_theorems partial_function_mono "monotonicity rules for partial function definitions"
ML_file \<open>Tools/Function/partial_function.ML\<close>

lemma (in ccpo) in_chain_finite:
  assumes "Complete_Partial_Order.chain (\<le>) A" "finite A" "A \<noteq> {}"
  shows "\<Squnion>A \<in> A"
using assms(2,1,3)
proof induction
  case empty thus ?case by simp
next
  case (insert x A)
  note chain = \<open>Complete_Partial_Order.chain (\<le>) (insert x A)\<close>
  show ?case
  proof(cases "A = {}")
    case True thus ?thesis by simp
  next
    case False
    from chain have chain': "Complete_Partial_Order.chain (\<le>) A"
      by(rule chain_subset) blast
    hence "\<Squnion>A \<in> A" using False by(rule insert.IH)
    show ?thesis
    proof(cases "x \<le> \<Squnion>A")
      case True
      have "\<Squnion>(insert x A) \<le> \<Squnion>A" using chain
        by(rule ccpo_Sup_least)(auto simp add: True intro: ccpo_Sup_upper[OF chain'])
      hence "\<Squnion>(insert x A) = \<Squnion>A"
        by(rule order.antisym)(blast intro: ccpo_Sup_upper[OF chain] ccpo_Sup_least[OF chain'])
      with \<open>\<Squnion>A \<in> A\<close> show ?thesis by simp
    next
      case False
      with chainD[OF chain, of x "\<Squnion>A"] \<open>\<Squnion>A \<in> A\<close>
      have "\<Squnion>(insert x A) = x"
        by(auto intro: order.antisym ccpo_Sup_least[OF chain] order_trans[OF ccpo_Sup_upper[OF chain']] ccpo_Sup_upper[OF chain])
      thus ?thesis by simp
    qed
  qed
qed

lemma (in ccpo) admissible_chfin:
  "(\<forall>S. Complete_Partial_Order.chain (\<le>) S \<longrightarrow> finite S)
  \<Longrightarrow> ccpo.admissible Sup (\<le>) P"
using in_chain_finite by (blast intro: ccpo.admissibleI)

subsection \<open>Axiomatic setup\<close>

text \<open>This techical locale constains the requirements for function
  definitions with ccpo fixed points.\<close>

definition "fun_ord ord f g \<longleftrightarrow> (\<forall>x. ord (f x) (g x))"
definition "fun_lub L A = (\<lambda>x. L {y. \<exists>f\<in>A. y = f x})"
definition "img_ord f ord = (\<lambda>x y. ord (f x) (f y))"
definition "img_lub f g Lub = (\<lambda>A. g (Lub (f ` A)))"

lemma chain_fun:
  assumes A: "chain (fun_ord ord) A"
  shows "chain ord {y. \<exists>f\<in>A. y = f a}" (is "chain ord ?C")
proof (rule chainI)
  fix x y assume "x \<in> ?C" "y \<in> ?C"
  then obtain f g where fg: "f \<in> A" "g \<in> A"
    and [simp]: "x = f a" "y = g a" by blast
  from chainD[OF A fg]
  show "ord x y \<or> ord y x" unfolding fun_ord_def by auto
qed

lemma call_mono[partial_function_mono]: "monotone (fun_ord ord) ord (\<lambda>f. f t)"
by (rule monotoneI) (auto simp: fun_ord_def)

lemma let_mono[partial_function_mono]:
  "(\<And>x. monotone orda ordb (\<lambda>f. b f x))
  \<Longrightarrow> monotone orda ordb (\<lambda>f. Let t (b f))"
by (simp add: Let_def)

lemma if_mono[partial_function_mono]: "monotone orda ordb F
\<Longrightarrow> monotone orda ordb G
\<Longrightarrow> monotone orda ordb (\<lambda>f. if c then F f else G f)"
unfolding monotone_def by simp

definition "mk_less R = (\<lambda>x y. R x y \<and> \<not> R y x)"

locale partial_function_definitions =
  fixes leq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  fixes lub :: "'a set \<Rightarrow> 'a"
  assumes leq_refl: "leq x x"
  assumes leq_trans: "leq x y \<Longrightarrow> leq y z \<Longrightarrow> leq x z"
  assumes leq_antisym: "leq x y \<Longrightarrow> leq y x \<Longrightarrow> x = y"
  assumes lub_upper: "chain leq A \<Longrightarrow> x \<in> A \<Longrightarrow> leq x (lub A)"
  assumes lub_least: "chain leq A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> leq x z) \<Longrightarrow> leq (lub A) z"

lemma partial_function_lift:
  assumes "partial_function_definitions ord lb"
  shows "partial_function_definitions (fun_ord ord) (fun_lub lb)" (is "partial_function_definitions ?ordf ?lubf")
proof -
  interpret partial_function_definitions ord lb by fact

  show ?thesis
  proof
    fix x show "?ordf x x"
      unfolding fun_ord_def by (auto simp: leq_refl)
  next
    fix x y z assume "?ordf x y" "?ordf y z"
    thus "?ordf x z" unfolding fun_ord_def
      by (force dest: leq_trans)
  next
    fix x y assume "?ordf x y" "?ordf y x"
    thus "x = y" unfolding fun_ord_def
      by (force intro!: dest: leq_antisym)
  next
    fix A f assume f: "f \<in> A" and A: "chain ?ordf A"
    thus "?ordf f (?lubf A)"
      unfolding fun_lub_def fun_ord_def
      by (blast intro: lub_upper chain_fun[OF A] f)
  next
    fix A :: "('b \<Rightarrow> 'a) set" and g :: "'b \<Rightarrow> 'a"
    assume A: "chain ?ordf A" and g: "\<And>f. f \<in> A \<Longrightarrow> ?ordf f g"
    show "?ordf (?lubf A) g" unfolding fun_lub_def fun_ord_def
      by (blast intro: lub_least chain_fun[OF A] dest: g[unfolded fun_ord_def])
   qed
qed

lemma ccpo: assumes "partial_function_definitions ord lb"
  shows "class.ccpo lb ord (mk_less ord)"
using assms unfolding partial_function_definitions_def mk_less_def
by unfold_locales blast+

lemma partial_function_image:
  assumes "partial_function_definitions ord Lub"
  assumes inj: "\<And>x y. f x = f y \<Longrightarrow> x = y"
  assumes inv: "\<And>x. f (g x) = x"
  shows "partial_function_definitions (img_ord f ord) (img_lub f g Lub)"
proof -
  let ?iord = "img_ord f ord"
  let ?ilub = "img_lub f g Lub"

  interpret partial_function_definitions ord Lub by fact
  show ?thesis
  proof
    fix A x assume "chain ?iord A" "x \<in> A"
    then have "chain ord (f ` A)" "f x \<in> f ` A"
      by (auto simp: img_ord_def intro: chainI dest: chainD)
    thus "?iord x (?ilub A)"
      unfolding inv img_lub_def img_ord_def by (rule lub_upper)
  next
    fix A x assume "chain ?iord A"
      and 1: "\<And>z. z \<in> A \<Longrightarrow> ?iord z x"
    then have "chain ord (f ` A)"
      by (auto simp: img_ord_def intro: chainI dest: chainD)
    thus "?iord (?ilub A) x"
      unfolding inv img_lub_def img_ord_def
      by (rule lub_least) (auto dest: 1[unfolded img_ord_def])
  qed (auto simp: img_ord_def intro: leq_refl dest: leq_trans leq_antisym inj)
qed

context partial_function_definitions
begin

abbreviation "le_fun \<equiv> fun_ord leq"
abbreviation "lub_fun \<equiv> fun_lub lub"
abbreviation "fixp_fun \<equiv> ccpo.fixp lub_fun le_fun"
abbreviation "mono_body \<equiv> monotone le_fun leq"
abbreviation "admissible \<equiv> ccpo.admissible lub_fun le_fun"

text \<open>Interpret manually, to avoid flooding everything with facts about
  orders\<close>

lemma ccpo: "class.ccpo lub_fun le_fun (mk_less le_fun)"
apply (rule ccpo)
apply (rule partial_function_lift)
apply (rule partial_function_definitions_axioms)
done

text \<open>The crucial fixed-point theorem\<close>

lemma mono_body_fixp:
  "(\<And>x. mono_body (\<lambda>f. F f x)) \<Longrightarrow> fixp_fun F = F (fixp_fun F)"
by (rule ccpo.fixp_unfold[OF ccpo]) (auto simp: monotone_def fun_ord_def)

text \<open>Version with curry/uncurry combinators, to be used by package\<close>

lemma fixp_rule_uc:
  fixes F :: "'c \<Rightarrow> 'c" and
    U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a" and
    C :: "('b \<Rightarrow> 'a) \<Rightarrow> 'c"
  assumes mono: "\<And>x. mono_body (\<lambda>f. U (F (C f)) x)"
  assumes eq: "f \<equiv> C (fixp_fun (\<lambda>f. U (F (C f))))"
  assumes inverse: "\<And>f. C (U f) = f"
  shows "f = F f"
proof -
  have "f = C (fixp_fun (\<lambda>f. U (F (C f))))" by (simp add: eq)
  also have "... = C (U (F (C (fixp_fun (\<lambda>f. U (F (C f)))))))"
    by (subst mono_body_fixp[of "%f. U (F (C f))", OF mono]) (rule refl)
  also have "... = F (C (fixp_fun (\<lambda>f. U (F (C f)))))" by (rule inverse)
  also have "... = F f" by (simp add: eq)
  finally show "f = F f" .
qed

text \<open>Fixpoint induction rule\<close>

lemma fixp_induct_uc:
  fixes F :: "'c \<Rightarrow> 'c"
    and U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a"
    and C :: "('b \<Rightarrow> 'a) \<Rightarrow> 'c"
    and P :: "('b \<Rightarrow> 'a) \<Rightarrow> bool"
  assumes mono: "\<And>x. mono_body (\<lambda>f. U (F (C f)) x)"
    and eq: "f \<equiv> C (fixp_fun (\<lambda>f. U (F (C f))))"
    and inverse: "\<And>f. U (C f) = f"
    and adm: "ccpo.admissible lub_fun le_fun P"
    and bot: "P (\<lambda>_. lub {})"
    and step: "\<And>f. P (U f) \<Longrightarrow> P (U (F f))"
  shows "P (U f)"
unfolding eq inverse
proof (rule ccpo.fixp_induct[OF ccpo adm])
  show "monotone le_fun le_fun (\<lambda>f. U (F (C f)))"
    using mono by (auto simp: monotone_def fun_ord_def)
next
  show "P (lub_fun {})"
    by (auto simp: bot fun_lub_def)
next
  fix x
  assume "P x"
  then show "P (U (F (C x)))"
    using step[of "C x"] by (simp add: inverse)
qed

text \<open>Rules for \<^term>\<open>mono_body\<close>:\<close>

lemma const_mono[partial_function_mono]: "monotone ord leq (\<lambda>f. c)"
by (rule monotoneI) (rule leq_refl)

end

subsection \<open>Flat interpretation: tailrec and option\<close>

definition
  "flat_ord b x y \<longleftrightarrow> x = b \<or> x = y"

definition
  "flat_lub b A = (if A \<subseteq> {b} then b else (THE x. x \<in> A - {b}))"

lemma flat_interpretation:
  "partial_function_definitions (flat_ord b) (flat_lub b)"
proof
  fix A x assume 1: "chain (flat_ord b) A" "x \<in> A"
  show "flat_ord b x (flat_lub b A)"
  proof cases
    assume "x = b"
    thus ?thesis by (simp add: flat_ord_def)
  next
    assume "x \<noteq> b"
    with 1 have "A - {b} = {x}"
      by (auto elim: chainE simp: flat_ord_def)
    then have "flat_lub b A = x"
      by (auto simp: flat_lub_def)
    thus ?thesis by (auto simp: flat_ord_def)
  qed
next
  fix A z assume A: "chain (flat_ord b) A"
    and z: "\<And>x. x \<in> A \<Longrightarrow> flat_ord b x z"
  show "flat_ord b (flat_lub b A) z"
  proof cases
    assume "A \<subseteq> {b}"
    thus ?thesis
      by (auto simp: flat_lub_def flat_ord_def)
  next
    assume nb: "\<not> A \<subseteq> {b}"
    then obtain y where y: "y \<in> A" "y \<noteq> b" by auto
    with A have "A - {b} = {y}"
      by (auto elim: chainE simp: flat_ord_def)
    with nb have "flat_lub b A = y"
      by (auto simp: flat_lub_def)
    with z y show ?thesis by auto
  qed
qed (auto simp: flat_ord_def)

lemma flat_ordI: "(x \<noteq> a \<Longrightarrow> x = y) \<Longrightarrow> flat_ord a x y"
by(auto simp add: flat_ord_def)

lemma flat_ord_antisym: "\<lbrakk> flat_ord a x y; flat_ord a y x \<rbrakk> \<Longrightarrow> x = y"
by(auto simp add: flat_ord_def)

lemma antisymp_flat_ord: "antisymp (flat_ord a)"
by(rule antisympI)(auto dest: flat_ord_antisym)

interpretation tailrec:
  partial_function_definitions "flat_ord undefined" "flat_lub undefined"
  rewrites "flat_lub undefined {} \<equiv> undefined"
by (rule flat_interpretation)(simp add: flat_lub_def)

interpretation option:
  partial_function_definitions "flat_ord None" "flat_lub None"
  rewrites "flat_lub None {} \<equiv> None"
by (rule flat_interpretation)(simp add: flat_lub_def)

abbreviation "tailrec_ord \<equiv> flat_ord undefined"
abbreviation "mono_tailrec \<equiv> monotone (fun_ord tailrec_ord) tailrec_ord"

lemma tailrec_admissible:
  "ccpo.admissible (fun_lub (flat_lub c)) (fun_ord (flat_ord c))
     (\<lambda>a. \<forall>x. a x \<noteq> c \<longrightarrow> P x (a x))"
proof(intro ccpo.admissibleI strip)
  fix A x
  assume chain: "Complete_Partial_Order.chain (fun_ord (flat_ord c)) A"
    and P [rule_format]: "\<forall>f\<in>A. \<forall>x. f x \<noteq> c \<longrightarrow> P x (f x)"
    and defined: "fun_lub (flat_lub c) A x \<noteq> c"
  from defined obtain f where f: "f \<in> A" "f x \<noteq> c"
    by(auto simp add: fun_lub_def flat_lub_def split: if_split_asm)
  hence "P x (f x)" by(rule P)
  moreover from chain f have "\<forall>f' \<in> A. f' x = c \<or> f' x = f x"
    by(auto 4 4 simp add: Complete_Partial_Order.chain_def flat_ord_def fun_ord_def)
  hence "fun_lub (flat_lub c) A x = f x"
    using f by(auto simp add: fun_lub_def flat_lub_def)
  ultimately show "P x (fun_lub (flat_lub c) A x)" by simp
qed

lemma fixp_induct_tailrec:
  fixes F :: "'c \<Rightarrow> 'c" and
    U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a" and
    C :: "('b \<Rightarrow> 'a) \<Rightarrow> 'c" and
    P :: "'b \<Rightarrow> 'a \<Rightarrow> bool" and
    x :: "'b"
  assumes mono: "\<And>x. monotone (fun_ord (flat_ord c)) (flat_ord c) (\<lambda>f. U (F (C f)) x)"
  assumes eq: "f \<equiv> C (ccpo.fixp (fun_lub (flat_lub c)) (fun_ord (flat_ord c)) (\<lambda>f. U (F (C f))))"
  assumes inverse2: "\<And>f. U (C f) = f"
  assumes step: "\<And>f x y. (\<And>x y. U f x = y \<Longrightarrow> y \<noteq> c \<Longrightarrow> P x y) \<Longrightarrow> U (F f) x = y \<Longrightarrow> y \<noteq> c \<Longrightarrow> P x y"
  assumes result: "U f x = y"
  assumes defined: "y \<noteq> c"
  shows "P x y"
proof -
  have "\<forall>x y. U f x = y \<longrightarrow> y \<noteq> c \<longrightarrow> P x y"
    by(rule partial_function_definitions.fixp_induct_uc[OF flat_interpretation, of _ U F C, OF mono eq inverse2])
      (auto intro: step tailrec_admissible simp add: fun_lub_def flat_lub_def)
  thus ?thesis using result defined by blast
qed

lemma admissible_image:
  assumes pfun: "partial_function_definitions le lub"
  assumes adm: "ccpo.admissible lub le (P \<circ> g)"
  assumes inj: "\<And>x y. f x = f y \<Longrightarrow> x = y"
  assumes inv: "\<And>x. f (g x) = x"
  shows "ccpo.admissible (img_lub f g lub) (img_ord f le) P"
proof (rule ccpo.admissibleI)
  fix A assume "chain (img_ord f le) A"
  then have ch': "chain le (f ` A)"
    by (auto simp: img_ord_def intro: chainI dest: chainD)
  assume "A \<noteq> {}"
  assume P_A: "\<forall>x\<in>A. P x"
  have "(P \<circ> g) (lub (f ` A))" using adm ch'
  proof (rule ccpo.admissibleD)
    fix x assume "x \<in> f ` A"
    with P_A show "(P \<circ> g) x" by (auto simp: inj[OF inv])
  qed(simp add: \<open>A \<noteq> {}\<close>)
  thus "P (img_lub f g lub A)" unfolding img_lub_def by simp
qed

lemma admissible_fun:
  assumes pfun: "partial_function_definitions le lub"
  assumes adm: "\<And>x. ccpo.admissible lub le (Q x)"
  shows "ccpo.admissible  (fun_lub lub) (fun_ord le) (\<lambda>f. \<forall>x. Q x (f x))"
proof (rule ccpo.admissibleI)
  fix A :: "('b \<Rightarrow> 'a) set"
  assume Q: "\<forall>f\<in>A. \<forall>x. Q x (f x)"
  assume ch: "chain (fun_ord le) A"
  assume "A \<noteq> {}"
  hence non_empty: "\<And>a. {y. \<exists>f\<in>A. y = f a} \<noteq> {}" by auto
  show "\<forall>x. Q x (fun_lub lub A x)"
    unfolding fun_lub_def
    by (rule allI, rule ccpo.admissibleD[OF adm chain_fun[OF ch] non_empty])
      (auto simp: Q)
qed

abbreviation "option_ord \<equiv> flat_ord None"
abbreviation "mono_option \<equiv> monotone (fun_ord option_ord) option_ord"

lemma bind_mono[partial_function_mono]:
assumes mf: "mono_option B" and mg: "\<And>y. mono_option (\<lambda>f. C y f)"
shows "mono_option (\<lambda>f. Option.bind (B f) (\<lambda>y. C y f))"
proof (rule monotoneI)
  fix f g :: "'a \<Rightarrow> 'b option" assume fg: "fun_ord option_ord f g"
  with mf
  have "option_ord (B f) (B g)" by (rule monotoneD[of _ _ _ f g])
  then have "option_ord (Option.bind (B f) (\<lambda>y. C y f)) (Option.bind (B g) (\<lambda>y. C y f))"
    unfolding flat_ord_def by auto
  also from mg
  have "\<And>y'. option_ord (C y' f) (C y' g)"
    by (rule monotoneD) (rule fg)
  then have "option_ord (Option.bind (B g) (\<lambda>y'. C y' f)) (Option.bind (B g) (\<lambda>y'. C y' g))"
    unfolding flat_ord_def by (cases "B g") auto
  finally (option.leq_trans)
  show "option_ord (Option.bind (B f) (\<lambda>y. C y f)) (Option.bind (B g) (\<lambda>y'. C y' g))" .
qed

lemma flat_lub_in_chain:
  assumes ch: "chain (flat_ord b) A "
  assumes lub: "flat_lub b A = a"
  shows "a = b \<or> a \<in> A"
proof (cases "A \<subseteq> {b}")
  case True
  then have "flat_lub b A = b" unfolding flat_lub_def by simp
  with lub show ?thesis by simp
next
  case False
  then obtain c where "c \<in> A" and "c \<noteq> b" by auto
  { fix z assume "z \<in> A"
    from chainD[OF ch \<open>c \<in> A\<close> this] have "z = c \<or> z = b"
      unfolding flat_ord_def using \<open>c \<noteq> b\<close> by auto }
  with False have "A - {b} = {c}" by auto
  with False have "flat_lub b A = c" by (auto simp: flat_lub_def)
  with \<open>c \<in> A\<close> lub show ?thesis by simp
qed

lemma option_admissible: "option.admissible (%(f::'a \<Rightarrow> 'b option).
  (\<forall>x y. f x = Some y \<longrightarrow> P x y))"
proof (rule ccpo.admissibleI)
  fix A :: "('a \<Rightarrow> 'b option) set"
  assume ch: "chain option.le_fun A"
    and IH: "\<forall>f\<in>A. \<forall>x y. f x = Some y \<longrightarrow> P x y"
  from ch have ch': "\<And>x. chain option_ord {y. \<exists>f\<in>A. y = f x}" by (rule chain_fun)
  show "\<forall>x y. option.lub_fun A x = Some y \<longrightarrow> P x y"
  proof (intro allI impI)
    fix x y assume "option.lub_fun A x = Some y"
    from flat_lub_in_chain[OF ch' this[unfolded fun_lub_def]]
    have "Some y \<in> {y. \<exists>f\<in>A. y = f x}" by simp
    then have "\<exists>f\<in>A. f x = Some y" by auto
    with IH show "P x y" by auto
  qed
qed

lemma fixp_induct_option:
  fixes F :: "'c \<Rightarrow> 'c" and
    U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a option" and
    C :: "('b \<Rightarrow> 'a option) \<Rightarrow> 'c" and
    P :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
  assumes mono: "\<And>x. mono_option (\<lambda>f. U (F (C f)) x)"
  assumes eq: "f \<equiv> C (ccpo.fixp (fun_lub (flat_lub None)) (fun_ord option_ord) (\<lambda>f. U (F (C f))))"
  assumes inverse2: "\<And>f. U (C f) = f"
  assumes step: "\<And>f x y. (\<And>x y. U f x = Some y \<Longrightarrow> P x y) \<Longrightarrow> U (F f) x = Some y \<Longrightarrow> P x y"
  assumes defined: "U f x = Some y"
  shows "P x y"
  using step defined option.fixp_induct_uc[of U F C, OF mono eq inverse2 option_admissible]
  unfolding fun_lub_def flat_lub_def by(auto 9 2)

declaration \<open>Partial_Function.init "tailrec" \<^term>\<open>tailrec.fixp_fun\<close>
  \<^term>\<open>tailrec.mono_body\<close> @{thm tailrec.fixp_rule_uc} @{thm tailrec.fixp_induct_uc}
  (SOME @{thm fixp_induct_tailrec[where c = undefined]})\<close>

declaration \<open>Partial_Function.init "option" \<^term>\<open>option.fixp_fun\<close>
  \<^term>\<open>option.mono_body\<close> @{thm option.fixp_rule_uc} @{thm option.fixp_induct_uc}
  (SOME @{thm fixp_induct_option})\<close>

hide_const (open) chain

end