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

section\<open>Epsilon Induction and Recursion\<close>

theory Epsilon imports Nat begin

definition
  eclose    :: "i\<Rightarrow>i"  where
    "eclose(A) \<equiv> \<Union>n\<in>nat. nat_rec(n, A, \<lambda>m r. \<Union>(r))"

definition
  transrec  :: "[i, [i,i]\<Rightarrow>i] \<Rightarrow>i"  where
    "transrec(a,H) \<equiv> wfrec(Memrel(eclose({a})), a, H)"

definition
  rank      :: "i\<Rightarrow>i"  where
    "rank(a) \<equiv> transrec(a, \<lambda>x f. \<Union>y\<in>x. succ(f`y))"

definition
  transrec2 :: "[i, i, [i,i]\<Rightarrow>i] \<Rightarrow>i"  where
    "transrec2(k, a, b) \<equiv>
       transrec(k,
                \<lambda>i r. if(i=0, a,
                        if(\<exists>j. i=succ(j),
                           b(THE j. i=succ(j), r`(THE j. i=succ(j))),
                           \<Union>j<i. r`j)))"

definition
  recursor  :: "[i, [i,i]\<Rightarrow>i, i]\<Rightarrow>i"  where
    "recursor(a,b,k) \<equiv>  transrec(k, \<lambda>n f. nat_case(a, \<lambda>m. b(m, f`m), n))"

definition
  rec  :: "[i, i, [i,i]\<Rightarrow>i]\<Rightarrow>i"  where
    "rec(k,a,b) \<equiv> recursor(a,b,k)"

subsection\<open>Basic Closure Properties\<close>

lemma arg_subset_eclose: "A \<subseteq> eclose(A)"
  unfolding eclose_def
apply (rule nat_rec_0 [THEN equalityD2, THEN subset_trans])
apply (rule nat_0I [THEN UN_upper])
done

lemmas arg_into_eclose = arg_subset_eclose [THEN subsetD]

lemma Transset_eclose: "Transset(eclose(A))"
  unfolding eclose_def Transset_def
apply (rule subsetI [THEN ballI])
apply (erule UN_E)
apply (rule nat_succI [THEN UN_I], assumption)
apply (erule nat_rec_succ [THEN ssubst])
apply (erule UnionI, assumption)
done

(* @{term"x \<in> eclose(A) \<Longrightarrow> x \<subseteq> eclose(A)"} *)
lemmas eclose_subset =
       Transset_eclose [unfolded Transset_def, THEN bspec]

(* @{term"\<lbrakk>A \<in> eclose(B); c \<in> A\<rbrakk> \<Longrightarrow> c \<in> eclose(B)"} *)
lemmas ecloseD = eclose_subset [THEN subsetD]

lemmas arg_in_eclose_sing = arg_subset_eclose [THEN singleton_subsetD]
lemmas arg_into_eclose_sing = arg_in_eclose_sing [THEN ecloseD]

(* This is epsilon-induction for eclose(A); see also eclose_induct_down...
   \<lbrakk>a \<in> eclose(A);  \<And>x. \<lbrakk>x \<in> eclose(A); \<forall>y\<in>x. P(y)\<rbrakk> \<Longrightarrow> P(x)
\<rbrakk> \<Longrightarrow> P(a)
*)
lemmas eclose_induct =
     Transset_induct [OF _ Transset_eclose, induct set: eclose]

(*Epsilon induction*)
lemma eps_induct:
    "\<lbrakk>\<And>x. \<forall>y\<in>x. P(y) \<Longrightarrow> P(x)\<rbrakk>  \<Longrightarrow>  P(a)"
by (rule arg_in_eclose_sing [THEN eclose_induct], blast)

subsection\<open>Leastness of \<^term>\<open>eclose\<close>\<close>

(** eclose(A) is the least transitive set including A as a subset. **)

lemma eclose_least_lemma:
    "\<lbrakk>Transset(X);  A<=X;  n \<in> nat\<rbrakk> \<Longrightarrow> nat_rec(n, A, \<lambda>m r. \<Union>(r)) \<subseteq> X"
  unfolding Transset_def
apply (erule nat_induct)
apply (simp add: nat_rec_0)
apply (simp add: nat_rec_succ, blast)
done

lemma eclose_least:
     "\<lbrakk>Transset(X);  A<=X\<rbrakk> \<Longrightarrow> eclose(A) \<subseteq> X"
  unfolding eclose_def
apply (rule eclose_least_lemma [THEN UN_least], assumption+)
done

(*COMPLETELY DIFFERENT induction principle from eclose_induct\<And>*)
lemma eclose_induct_down [consumes 1]:
    "\<lbrakk>a \<in> eclose(b);
        \<And>y.   \<lbrakk>y \<in> b\<rbrakk> \<Longrightarrow> P(y);
        \<And>y z. \<lbrakk>y \<in> eclose(b);  P(y);  z \<in> y\<rbrakk> \<Longrightarrow> P(z)
\<rbrakk> \<Longrightarrow> P(a)"
apply (rule eclose_least [THEN subsetD, THEN CollectD2, of "eclose(b)"])
  prefer 3 apply assumption
   unfolding Transset_def
 apply (blast intro: ecloseD)
apply (blast intro: arg_subset_eclose [THEN subsetD])
done

lemma Transset_eclose_eq_arg: "Transset(X) \<Longrightarrow> eclose(X) = X"
apply (erule equalityI [OF eclose_least arg_subset_eclose])
apply (rule subset_refl)
done

text\<open>A transitive set either is empty or contains the empty set.\<close>
lemma Transset_0_lemma [rule_format]: "Transset(A) \<Longrightarrow> x\<in>A \<longrightarrow> 0\<in>A"
apply (simp add: Transset_def)
apply (rule_tac a=x in eps_induct, clarify)
apply (drule bspec, assumption)
apply (case_tac "x=0", auto)
done

lemma Transset_0_disj: "Transset(A) \<Longrightarrow> A=0 | 0\<in>A"
by (blast dest: Transset_0_lemma)

subsection\<open>Epsilon Recursion\<close>

(*Unused...*)
lemma mem_eclose_trans: "\<lbrakk>A \<in> eclose(B);  B \<in> eclose(C)\<rbrakk> \<Longrightarrow> A \<in> eclose(C)"
by (rule eclose_least [OF Transset_eclose eclose_subset, THEN subsetD],
    assumption+)

(*Variant of the previous lemma in a useable form for the sequel*)
lemma mem_eclose_sing_trans:
     "\<lbrakk>A \<in> eclose({B});  B \<in> eclose({C})\<rbrakk> \<Longrightarrow> A \<in> eclose({C})"
by (rule eclose_least [OF Transset_eclose singleton_subsetI, THEN subsetD],
    assumption+)

lemma under_Memrel: "\<lbrakk>Transset(i);  j \<in> i\<rbrakk> \<Longrightarrow> Memrel(i)-``{j} = j"
by (unfold Transset_def, blast)

lemma lt_Memrel: "j < i \<Longrightarrow> Memrel(i) -`` {j} = j"
by (simp add: lt_def Ord_def under_Memrel)

(* @{term"j \<in> eclose(A) \<Longrightarrow> Memrel(eclose(A)) -`` j = j"} *)
lemmas under_Memrel_eclose = Transset_eclose [THEN under_Memrel]

lemmas wfrec_ssubst = wf_Memrel [THEN wfrec, THEN ssubst]

lemma wfrec_eclose_eq:
    "\<lbrakk>k \<in> eclose({j});  j \<in> eclose({i})\<rbrakk> \<Longrightarrow>
     wfrec(Memrel(eclose({i})), k, H) = wfrec(Memrel(eclose({j})), k, H)"
apply (erule eclose_induct)
apply (rule wfrec_ssubst)
apply (rule wfrec_ssubst)
apply (simp add: under_Memrel_eclose mem_eclose_sing_trans [of _ j i])
done

lemma wfrec_eclose_eq2:
    "k \<in> i \<Longrightarrow> wfrec(Memrel(eclose({i})),k,H) = wfrec(Memrel(eclose({k})),k,H)"
apply (rule arg_in_eclose_sing [THEN wfrec_eclose_eq])
apply (erule arg_into_eclose_sing)
done

lemma transrec: "transrec(a,H) = H(a, \<lambda>x\<in>a. transrec(x,H))"
  unfolding transrec_def
apply (rule wfrec_ssubst)
apply (simp add: wfrec_eclose_eq2 arg_in_eclose_sing under_Memrel_eclose)
done

(*Avoids explosions in proofs; resolve it with a meta-level definition.*)
lemma def_transrec:
    "\<lbrakk>\<And>x. f(x)\<equiv>transrec(x,H)\<rbrakk> \<Longrightarrow> f(a) = H(a, \<lambda>x\<in>a. f(x))"
apply simp
apply (rule transrec)
done

lemma transrec_type:
    "\<lbrakk>\<And>x u. \<lbrakk>x \<in> eclose({a});  u \<in> Pi(x,B)\<rbrakk> \<Longrightarrow> H(x,u) \<in> B(x)\<rbrakk>
     \<Longrightarrow> transrec(a,H) \<in> B(a)"
apply (rule_tac i = a in arg_in_eclose_sing [THEN eclose_induct])
apply (subst transrec)
apply (simp add: lam_type)
done

lemma eclose_sing_Ord: "Ord(i) \<Longrightarrow> eclose({i}) \<subseteq> succ(i)"
apply (erule Ord_is_Transset [THEN Transset_succ, THEN eclose_least])
apply (rule succI1 [THEN singleton_subsetI])
done

lemma succ_subset_eclose_sing: "succ(i) \<subseteq> eclose({i})"
apply (insert arg_subset_eclose [of "{i}"], simp)
apply (frule eclose_subset, blast)
done

lemma eclose_sing_Ord_eq: "Ord(i) \<Longrightarrow> eclose({i}) = succ(i)"
apply (rule equalityI)
apply (erule eclose_sing_Ord)
apply (rule succ_subset_eclose_sing)
done

lemma Ord_transrec_type:
  assumes jini: "j \<in> i"
      and ordi: "Ord(i)"
      and minor: " \<And>x u. \<lbrakk>x \<in> i;  u \<in> Pi(x,B)\<rbrakk> \<Longrightarrow> H(x,u) \<in> B(x)"
  shows "transrec(j,H) \<in> B(j)"
apply (rule transrec_type)
apply (insert jini ordi)
apply (blast intro!: minor
             intro: Ord_trans
             dest: Ord_in_Ord [THEN eclose_sing_Ord, THEN subsetD])
done

subsection\<open>Rank\<close>

(*NOT SUITABLE FOR REWRITING -- RECURSIVE!*)
lemma rank: "rank(a) = (\<Union>y\<in>a. succ(rank(y)))"
by (subst rank_def [THEN def_transrec], simp)

lemma Ord_rank [simp]: "Ord(rank(a))"
apply (rule_tac a=a in eps_induct)
apply (subst rank)
apply (rule Ord_succ [THEN Ord_UN])
apply (erule bspec, assumption)
done

lemma rank_of_Ord: "Ord(i) \<Longrightarrow> rank(i) = i"
apply (erule trans_induct)
apply (subst rank)
apply (simp add: Ord_equality)
done

lemma rank_lt: "a \<in> b \<Longrightarrow> rank(a) < rank(b)"
apply (rule_tac a1 = b in rank [THEN ssubst])
apply (erule UN_I [THEN ltI])
apply (rule_tac [2] Ord_UN, auto)
done

lemma eclose_rank_lt: "a \<in> eclose(b) \<Longrightarrow> rank(a) < rank(b)"
apply (erule eclose_induct_down)
apply (erule rank_lt)
apply (erule rank_lt [THEN lt_trans], assumption)
done

lemma rank_mono: "a<=b \<Longrightarrow> rank(a) \<le> rank(b)"
apply (rule subset_imp_le)
apply (auto simp add: rank [of a] rank [of b])
done

lemma rank_Pow: "rank(Pow(a)) = succ(rank(a))"
apply (rule rank [THEN trans])
apply (rule le_anti_sym)
apply (rule_tac [2] UN_upper_le)
apply (rule UN_least_le)
apply (auto intro: rank_mono simp add: Ord_UN)
done

lemma rank_0 [simp]: "rank(0) = 0"
by (rule rank [THEN trans], blast)

lemma rank_succ [simp]: "rank(succ(x)) = succ(rank(x))"
apply (rule rank [THEN trans])
apply (rule equalityI [OF UN_least succI1 [THEN UN_upper]])
apply (erule succE, blast)
apply (erule rank_lt [THEN leI, THEN succ_leI, THEN le_imp_subset])
done

lemma rank_Union: "rank(\<Union>(A)) = (\<Union>x\<in>A. rank(x))"
apply (rule equalityI)
apply (rule_tac [2] rank_mono [THEN le_imp_subset, THEN UN_least])
apply (erule_tac [2] Union_upper)
apply (subst rank)
apply (rule UN_least)
apply (erule UnionE)
apply (rule subset_trans)
apply (erule_tac [2] RepFunI [THEN Union_upper])
apply (erule rank_lt [THEN succ_leI, THEN le_imp_subset])
done

lemma rank_eclose: "rank(eclose(a)) = rank(a)"
apply (rule le_anti_sym)
apply (rule_tac [2] arg_subset_eclose [THEN rank_mono])
apply (rule_tac a1 = "eclose (a) " in rank [THEN ssubst])
apply (rule Ord_rank [THEN UN_least_le])
apply (erule eclose_rank_lt [THEN succ_leI])
done

lemma rank_pair1: "rank(a) < rank(\<langle>a,b\<rangle>)"
  unfolding Pair_def
apply (rule consI1 [THEN rank_lt, THEN lt_trans])
apply (rule consI1 [THEN consI2, THEN rank_lt])
done

lemma rank_pair2: "rank(b) < rank(\<langle>a,b\<rangle>)"
  unfolding Pair_def
apply (rule consI1 [THEN consI2, THEN rank_lt, THEN lt_trans])
apply (rule consI1 [THEN consI2, THEN rank_lt])
done

(*Not clear how to remove the P(a) condition, since the "then" part
  must refer to "a"*)
lemma the_equality_if:
     "P(a) \<Longrightarrow> (THE x. P(x)) = (if (\<exists>!x. P(x)) then a else 0)"
by (simp add: the_0 the_equality2)

(*The first premise not only fixs i but ensures @{term"f\<noteq>0"}.
  The second premise is now essential.  Consider otherwise the relation
  r = {\<langle>0,0\<rangle>,\<langle>0,1\<rangle>,\<langle>0,2\<rangle>,...}.  Then f`0 = \<Union>(f``{0}) = \<Union>(nat) = nat,
  whose rank equals that of r.*)
lemma rank_apply: "\<lbrakk>i \<in> domain(f); function(f)\<rbrakk> \<Longrightarrow> rank(f`i) < rank(f)"
apply clarify
apply (simp add: function_apply_equality)
apply (blast intro: lt_trans rank_lt rank_pair2)
done

subsection\<open>Corollaries of Leastness\<close>

lemma mem_eclose_subset: "A \<in> B \<Longrightarrow> eclose(A)<=eclose(B)"
apply (rule Transset_eclose [THEN eclose_least])
apply (erule arg_into_eclose [THEN eclose_subset])
done

lemma eclose_mono: "A<=B \<Longrightarrow> eclose(A) \<subseteq> eclose(B)"
apply (rule Transset_eclose [THEN eclose_least])
apply (erule subset_trans)
apply (rule arg_subset_eclose)
done

(** Idempotence of eclose **)

lemma eclose_idem: "eclose(eclose(A)) = eclose(A)"
apply (rule equalityI)
apply (rule eclose_least [OF Transset_eclose subset_refl])
apply (rule arg_subset_eclose)
done

(** Transfinite recursion for definitions based on the
    three cases of ordinals **)

lemma transrec2_0 [simp]: "transrec2(0,a,b) = a"
by (rule transrec2_def [THEN def_transrec, THEN trans], simp)

lemma transrec2_succ [simp]: "transrec2(succ(i),a,b) = b(i, transrec2(i,a,b))"
apply (rule transrec2_def [THEN def_transrec, THEN trans])
apply (simp add: the_equality if_P)
done

lemma transrec2_Limit:
     "Limit(i) \<Longrightarrow> transrec2(i,a,b) = (\<Union>j<i. transrec2(j,a,b))"
apply (rule transrec2_def [THEN def_transrec, THEN trans])
apply (auto simp add: OUnion_def)
done

lemma def_transrec2:
     "(\<And>x. f(x)\<equiv>transrec2(x,a,b))
      \<Longrightarrow> f(0) = a \<and>
          f(succ(i)) = b(i, f(i)) \<and>
          (Limit(K) \<longrightarrow> f(K) = (\<Union>j<K. f(j)))"
by (simp add: transrec2_Limit)

(** recursor -- better than nat_rec; the succ case has no type requirement! **)

(*NOT suitable for rewriting*)
lemmas recursor_lemma = recursor_def [THEN def_transrec, THEN trans]

lemma recursor_0: "recursor(a,b,0) = a"
by (rule nat_case_0 [THEN recursor_lemma])

lemma recursor_succ: "recursor(a,b,succ(m)) = b(m, recursor(a,b,m))"
by (rule recursor_lemma, simp)

(** rec: old version for compatibility **)

lemma rec_0 [simp]: "rec(0,a,b) = a"
  unfolding rec_def
apply (rule recursor_0)
done

lemma rec_succ [simp]: "rec(succ(m),a,b) = b(m, rec(m,a,b))"
  unfolding rec_def
apply (rule recursor_succ)
done

lemma rec_type:
    "\<lbrakk>n \<in> nat;
        a \<in> C(0);
        \<And>m z. \<lbrakk>m \<in> nat;  z \<in> C(m)\<rbrakk> \<Longrightarrow> b(m,z): C(succ(m))\<rbrakk>
     \<Longrightarrow> rec(n,a,b) \<in> C(n)"
by (erule nat_induct, auto)

end


(*
Title: Groupoids
Author: Georg Struth
Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Groupoids\<close>

theory Groupoid
  imports Catoid

begin

subsection \<open>st-Multigroupoids\<close>

text \<open>We define multigroupoids, extending the standard definition. We equip catoids with an operation
of inversion.\<close>

class inv_op = fixes inv :: "'a \<Rightarrow> 'a"

class st_multigroupoid = catoid + inv_op +
  assumes invl: "\<sigma> x \<in> x \<odot> inv x"
  and invr: "\<tau> x \<in> inv x \<odot> x"

sublocale st_multigroupoid \<subseteq> st_mgpd: st_multigroupoid  "\<lambda>x y. y \<odot> x" tgt src inv
  by unfold_locales (simp_all add: local.invr local.invl)

text \<open>Every multigroupoid is local.\<close>

lemma (in st_multigroupoid) st_mgpd_local:
  assumes "\<tau> x = \<sigma> y"
  shows "\<Delta> x y"
proof-
  have "x \<in> x \<odot> \<sigma> y"
    by (metis assms local.t_absorb singletonI)
  hence "x \<in> {x} \<star> (y \<odot> inv y)"
    using local.conv_exp2 local.invl by auto
  hence "x \<in> (x \<odot> y) \<star> {inv y}"
    using local.assoc_var by force
  hence "\<exists>u v. x \<in> u \<odot> v \<and> u \<in> x \<odot> y \<and> v = inv y"
    by (metis multimagma.conv_exp2 singletonD)
  hence "\<exists>u. x \<in> u \<odot> inv y \<and> u \<in> x \<odot> y"
    by presburger
  hence "\<exists>u. u \<in> x \<odot> y"
    by fastforce
  thus ?thesis
    by force
qed

sublocale st_multigroupoid \<subseteq> stmgpd: local_catoid "(\<odot>)" src tgt
  apply unfold_locales
   apply (metis local.Dst local.st_locality_locality local.st_mgpd_local set_eq_subset)
  by (metis local.Dst local.st_locality_locality local.st_mgpd_local subset_refl)

lemma (in st_multigroupoid) tgt_inv [simp]:
  "\<tau> (inv x) = \<sigma> x"
  using local.Dst local.invr by fastforce

lemma (in st_multigroupoid) src_inv:
  "\<sigma> (inv x) = \<tau> x"
  by simp

text \<open>The following lemma is from Theorem 5.2  of Jónsson and Tarski's BAO II article.\<close>

lemma (in st_multigroupoid) bao3:
  assumes "x \<odot> y = {\<sigma> x}"
  shows "inv x = y"
proof -
  have "\<tau> x = \<sigma> y"
    using assms local.Dst by force
  hence "{y} = \<tau> x \<odot> y"
    by simp
  hence "y \<in> {inv x} \<star> {x} \<star> {y}"
    using local.conv_exp2 local.invr by fastforce
  hence "y \<in> inv x \<odot> \<sigma> x"
    by (metis assms local.assoc_var local.conv_atom)
  hence "y \<in> inv x \<odot> \<tau> (inv x)"
    by simp
  thus ?thesis
    by (metis local.t_absorb singletonD)
qed

lemma (in st_multigroupoid) inv_s [simp]:
  "inv (\<sigma> x) = \<sigma> x"
proof-
  have "\<sigma> x \<odot> \<sigma> x = {\<sigma> x}"
    by simp
  thus "inv (\<sigma> x) = \<sigma> x"
    by (simp add: local.st_mgpd.bao3)
qed

lemma (in st_multigroupoid) srcfunct_inv:
   "\<sigma> x \<in> x \<odot> inv x \<Longrightarrow> \<sigma> y \<in> x \<odot> inv x \<Longrightarrow> \<sigma> x = \<sigma> y"
  using local.ts_msg.src_funct by fastforce

lemma (in st_multigroupoid) tgtfunct_inv:
   "\<tau> x \<in> inv x \<odot> x \<Longrightarrow> \<tau> y \<in> inv x \<odot> x \<Longrightarrow> \<tau> x = \<tau> y"
  by (metis local.ts_msg.src_comp_aux local.tt_idem)

text \<open>As for catoids, we prove quantalic properties, lifting to powersets.\<close>

abbreviation (in st_multigroupoid) Inv :: "'a set \<Rightarrow> 'a set" where
  "Inv \<equiv> image inv"

lemma (in st_multigroupoid) Inv_exp:
  "Inv X = {inv x |x. x \<in> X}"
  by blast

lemma (in st_multigroupoid) Inv_un:
  "Inv (X \<union> Y) = Inv X \<union> Inv Y"
  by (simp add: image_Un)

lemma (in st_multigroupoid) Inv_Un:
  "Inv (\<Union>\<X>) = \<Union>{Inv X |X. X \<in> \<X>}"
  unfolding Inv_exp by auto

lemma (in st_multigroupoid) Invl:
  "Src X \<subseteq> X \<star> Inv X"
  unfolding Inv_exp conv_exp using local.invl by fastforce

lemma (in st_multigroupoid) Invr:
  "Tgt X \<subseteq> Inv X \<star> X"
  by (meson imageI image_subsetI local.invr local.stopp.conv_exp2)

lemma (in st_multigroupoid) Inv_strong_gelfand:
  "X \<subseteq> X \<star> Inv X \<star> X"
proof-
  have "X = Src X \<star> X"
    by simp
  also have "\<dots> \<subseteq> X \<star> Inv X \<star> X"
    using local.Invl local.conv_isor by presburger
  finally show ?thesis.
qed

text \<open>At powerset level, we can define domain and codomain operations explicitly as in
relation algebras.\<close>

lemma (in st_multigroupoid) dom_def:
  "Src X = sfix \<inter> (X \<star> Inv X)"
proof-
  {fix a
  have "(a \<in> sfix \<inter> (X \<star> Inv X)) = (\<sigma> a = a \<and> \<sigma> a \<in> X \<star> Inv X)"
    by fastforce
  also have "\<dots> = (\<sigma> a = a \<and> (\<exists>b \<in> X.\<exists>c \<in> Inv X. \<sigma> a \<in> b \<odot> c))"
    using local.conv_exp2 by auto
  also have "\<dots> = (\<sigma> a = a \<and> (\<exists>b \<in> X. \<sigma> a = \<sigma> b))"
    by (metis imageI local.invl local.ts_msg.tgt_comp_aux)
  also have "\<dots> = (a \<in> Src X)"
    by auto
  finally have "(a \<in> sfix \<inter> (X \<star> Inv X)) = (a \<in> Src X)".}
  thus ?thesis
    by blast
qed

lemma (in st_multigroupoid) cod_def:
  "Tgt X = sfix \<inter> (Inv X \<star> X)"
  by (metis local.st_mgpd.dom_def local.stfix_set local.stopp.conv_def multimagma.conv_def)

lemma (in st_multigroupoid) dom_def_var:
  "Src X = sfix \<inter> (X \<star> UNIV)"
proof-
  {fix a
  have "(a \<in> sfix \<inter> (X \<star> UNIV)) = (\<sigma> a = a \<and> \<sigma> a \<in> X \<star> UNIV)"
    by fastforce
  also have "\<dots> = (\<sigma> a = a \<and> (\<exists>b \<in> X.\<exists>c. \<sigma> a \<in> b \<odot> c))"
    using local.conv_exp2 by auto
  also have "\<dots> = (\<sigma> a = a \<and> (\<exists>b \<in> X. \<sigma> a = \<sigma> b))"
    by (metis local.invl local.ts_msg.tgt_comp_aux)
  also have "\<dots> = (a \<in> Src X)"
    by auto
  finally have "(a \<in> sfix \<inter> (X \<star> UNIV)) = (a \<in> Src X)".}
  thus ?thesis
    by blast
qed

lemma (in st_multigroupoid) cod_def_var:
  "Tgt X = sfix \<inter> (UNIV \<star> X)"

  by (metis local.ST_im local.sfix_im local.st_mgpd.dom_def_var local.stopp.conv_def local.tfix_im multimagma.conv_def)

lemma (in st_multigroupoid) dom_univ:
  "X \<star> UNIV = Src X \<star> UNIV"
proof-
  have "X \<star> UNIV = Src X \<star> X \<star> UNIV"
    using local.Src_absorp by presburger
  also have "\<dots> \<subseteq> Src X \<star> UNIV \<star> UNIV"
    by (meson local.conv_isol local.conv_isor subset_UNIV)
  finally have a: "X \<star> UNIV \<subseteq> Src X \<star> UNIV"
    using local.conv_assoc local.conv_isol subset_UNIV by blast
  have "Src X \<star> UNIV \<subseteq> X \<star> Inv X \<star> UNIV"
    using local.Invl local.conv_isor by presburger
  also have "\<dots> \<subseteq> X \<star> UNIV \<star> UNIV"
    by (simp add: local.conv_isol local.conv_isor)
  finally have "Src X \<star> UNIV \<subseteq> X \<star> UNIV"
    by (metis dual_order.trans local.conv_assoc local.conv_isol subset_UNIV)
  thus ?thesis
    using a by force
qed

lemma (in st_multigroupoid) cod_univ:
  "UNIV \<star> X = UNIV \<star> Tgt X"
  by (metis local.st_mgpd.dom_univ local.stopp.conv_def multimagma.conv_def)

subsection \<open>Groupoids\<close>

text \<open>Groupoids are simply functional multigroupoids.\<close>

class groupoid_var = st_multigroupoid + functional_catoid

begin

lemma invl [simp]:
  "x \<odot> inv x = {\<sigma> x}"
  using local.fun_in_sgl local.invl by force

lemma invr [simp]:
  "inv x \<odot> x = {\<tau> x}"
  using local.fun_in_sgl local.invr by force

end

text \<open>We provide a more direct axiomatisation.\<close>

class groupoid = catoid + inv_op +
  assumes invs [simp]: "x \<odot> inv x = {\<sigma> x}"
  and invt [simp]: "inv x \<odot> x = {\<tau> x}"

subclass (in groupoid) st_multigroupoid
  by unfold_locales simp_all

sublocale groupoid \<subseteq> lrgpd: groupoid "\<lambda>x y. y \<odot> x"  tgt src inv
  by unfold_locales simp_all

lemma (in groupoid) bao4 [simp]:
  "inv (inv x) = x"
proof-
  have "inv x \<odot> x = {\<sigma> (inv x)}"
    by simp
  thus ?thesis
    using local.bao3 by blast
qed

lemma (in groupoid) rev1:
  "x \<in> y \<odot> z \<Longrightarrow> y \<in> x \<odot> inv z"
proof-
  assume h: "x \<in> y \<odot> z"
  hence "x \<odot> inv z \<subseteq> y \<odot> z \<star> {inv z}"
    using multimagma.conv_exp2 by fastforce
  hence "x \<odot> inv z \<subseteq> {y} \<star> (z \<odot> inv z)"
    using local.assoc_var by presburger
  hence "x \<odot> inv z \<subseteq> y \<odot> \<sigma> z"
    by simp
  hence "x \<odot> inv z \<subseteq> y \<odot> \<tau> y"
    using h local.src_comp_aux local.src_twisted_aux by auto
  hence a: "x \<odot> inv z \<subseteq> {y}"
    by simp
  have "\<tau> x = \<tau> z"
    using h local.tgt_comp_aux by auto
  hence  "x \<odot> inv z \<noteq> {}"
    by (simp add: local.st_mgpd_local)
  hence "x \<odot> inv z = {y}"
    using a by auto
  thus ?thesis
    by force
qed

lemma (in groupoid) rev2:
  "x \<in> y \<odot> z \<Longrightarrow> z \<in> inv y \<odot> x"
  by (simp add: local.lrgpd.rev1)

lemma (in groupoid) rev1_eq:
  "(y \<in> x \<odot> (inv z)) = (x \<in> y \<odot> z)"
  using local.lrgpd.rev2 by force

lemma (in groupoid) rev2_eq:
  "(z \<in> (inv y) \<odot> x) = (x \<in> y \<odot> z)"
  by (simp add: local.lrgpd.rev1_eq)

text \<open>The following fact show that our axiomatisation captures indeed  groupoids.\<close>

lemma (in groupoid) lr_mgpd_partial:
  assumes "x \<in> y \<odot> z"
  and "x' \<in> y \<odot> z"
  shows "x = x'"
proof-
  have "z \<in> inv y \<odot> x"
    by (simp add: assms(1) rev2)
  hence "x' \<in> {y} \<star> (inv y \<odot> x)"
    using assms(2) local.conv_exp2 by auto
  hence "x'\<in> (y \<odot> inv y) \<star> {x}"
    by (simp add: local.assoc_var)
  hence "x' \<in> \<sigma> y \<odot> x"
    by (simp add: multimagma.conv_atom)
  hence "x' \<in> \<sigma> x \<odot> x"
    using assms(1) local.ts_msg.tgt_comp_aux by auto
  thus ?thesis
    by simp
qed

subclass (in groupoid) single_set_category
  by unfold_locales (simp add: local.lr_mgpd_partial)

text \<open>Hence st-groupoids are indeed single-set variants of categories in which all arrows
are isomorphisms.\<close>

lemma (in groupoid) src_canc1:
  assumes "\<tau> z = \<sigma> x"
  and "\<tau> z = \<sigma> y"
  and "z \<otimes> x = z \<otimes> y"
shows "x = y"
proof-
  have "inv z \<otimes> (z \<otimes> x) = inv z \<otimes> (z \<otimes> y)"
    by (simp add: assms(3))
  hence "(inv z \<otimes> z) \<otimes> x = (inv z \<otimes> z) \<otimes> y"
    using assms(1) assms(2) local.sscatml.comp0_assoc by auto
  hence "\<tau> z \<otimes> x  = \<tau> z \<otimes> y"
    by (simp add: local.pcomp_def)
  thus ?thesis
    by (metis assms(1) assms(2) local.sscatml.l0_absorb)
qed

lemma (in groupoid) tgt_canc1:
  assumes "\<tau> x = \<sigma> z"
  and "\<tau> y = \<sigma> z"
  and "x \<otimes> z = y \<otimes> z"
shows "x = y"
  by (metis assms local.lrgpd.pcomp_def_var local.lrgpd.src_canc1 local.pcomp_def_var local.st_mgpd.st_mgpd_local)

text \<open>The following lemmas are from Theorem 5.2  of Jónsson and Tarski's BAO II article.\<close>

lemma (in groupoid) bao1 [simp]:
  "x \<otimes> (inv x \<otimes> x) = x"
  by (simp add: local.pcomp_def)

lemma (in groupoid) bao2 [simp]:
  "(x \<otimes> inv x) \<otimes> x = x"
  by (simp add: local.st_assoc)

lemma (in groupoid) bao5:
  "\<tau> x = \<sigma> y \<Longrightarrow> inv x \<otimes> x = y \<otimes> inv y"
  using local.invs local.invt local.pcomp_def by auto

lemma (in groupoid) bao6:
  "Inv (x \<odot> y) = inv y \<odot> inv x"
  apply (rule antisym)
  using rev1_eq rev2_eq apply force
  by (clarsimp, metis imageI local.bao4 local.rev1_eq local.rev2_eq)

subsubsection \<open>Axioms of relation algebra\<close>

text \<open>We formalise an old theorem of Jónsson and Tarski, showing that groupoids lift to relation algebras
at powerset level. All axioms not related to converse have already been considered in earlier sections.\<close>

lemma (in groupoid) Inv_invol [simp]:
  "Inv (Inv X) = X"
proof-
  have "Inv (Inv X) = {inv (inv x) |x. x \<in> X}"
    by (simp add: image_image)
  also have "\<dots> = X"
    by simp
  finally show ?thesis.
qed

lemma (in groupoid) Inv_contrav:
  "Inv (X \<star> Y) = Inv Y \<star> Inv X"
proof-
  have "Inv (X \<star> Y) = \<Union>{Inv (x \<odot> y) |x y. x \<in> X \<and> y \<in> Y}"
    unfolding conv_def image_def by blast
  also have "\<dots> = \<Union>{inv y \<odot> inv x |x y. x \<in> X \<and> y \<in> Y}"
    by (simp add: local.bao6)
  also have "\<dots> = Inv Y \<star> Inv X"
    unfolding conv_def image_def by blast
  finally show ?thesis.
qed

lemma (in groupoid) residuation: "Inv X \<star> -(X \<star> Y) \<subseteq> -Y"
  using local.lrgpd.rev1 local.stopp.conv_exp2 by fastforce

lemma (in groupoid) modular_law: "(X \<star> Y) \<inter> Z \<subseteq> (X \<inter> (Z \<star> Inv Y)) \<star> Y"
  using local.lrgpd.rev2 local.stopp.conv_exp2 by fastforce

lemma (in groupoid) dedekind: "(X \<star> Y) \<inter> Z \<subseteq> (X \<inter> (Z \<star> Inv Y)) \<star> (Y \<inter> (Inv X \<star> Z))"
  unfolding Inv_exp conv_exp
  apply clarsimp
  using local.rev1 local.rev2 by blast

text \<open>Hence we have shown that the powerset lifting of a groupoid is a relation algebra,
an old result by Jónsson and Tarski in BAO II. We need to link this formally with relations
in an interpretation statement in the future.\<close>

text \<open>Jónsson and Tarski's axioms are different. It might be interesting to compare them formally with ours.
It might also be interested to use their partiality-by-closure approach in a setting with explicit
carrier sets.\<close>

lemma (in groupoid) Inv_compl: "Inv (-X) = -(Inv X)"
  by (metis UNIV_I bij_def bij_image_Compl_eq equalityI image_eqI inj_def local.bao4 subsetI)

lemma (in groupoid) Inv_inter:
  "Inv (X \<inter> Y) = Inv X \<inter> Inv Y"
  using local.Inv_compl by auto

lemma (in groupoid) Inv_Un:
  "Inv (\<Inter>\<X>) = \<Inter>{Inv X |X. X \<in> \<X>}"
proof-
  have "Inv (\<Inter>\<X>) = Inv (-(\<Union>{-X |X. X \<in> \<X>}))"
    by (simp add: Setcompr_eq_image)
  also have "\<dots> = - (Inv (\<Union>{-X |X. X \<in> \<X>}))"
    using local.Inv_compl by presburger
  also have "\<dots> = -(\<Union>{Inv (-X) |X. X \<in> \<X>})"
    by blast
  also have "\<dots> = -(\<Union>{-(Inv X) |X. X \<in> \<X>})"
    using local.Inv_compl by presburger
  also have "\<dots> = \<Inter>{Inv X |X. X \<in> \<X>}"
    by blast
  finally show "Inv (\<Inter>\<X>) = \<Inter>{Inv X |X. X \<in> \<X>}".
qed

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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_BSortCount
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun sort2 :: "int => int => int list" where
"sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun pairs :: "int list => int list => int list" where
"pairs (nil2) z = z"
| "pairs (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "pairs (cons2 z2 x2) (cons2 x3 x4) =
     x (sort2 z2 x3) (pairs x2 x4)"

fun stitch :: "int list => int list => int list" where
"stitch (nil2) z = z"
| "stitch (cons2 z2 xs) z = cons2 z2 (pairs xs z)"

function evens :: "'a list => 'a list"
         and odds :: "'a list => 'a list" where
"evens (nil2) = nil2"
| "evens (cons2 z xs) = cons2 z (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 z xs) = evens xs"
by pat_completeness auto

fun count :: "'a => 'a list => int" where
"count y (nil2) = 0"
| "count y (cons2 z2 ys) =
     (if (y = z2) then 1 + (count y ys) else count y ys)"

(*fun did not finish the proof*)
function bmerge :: "int list => int list => int list" where
"bmerge (nil2) z = nil2"
| "bmerge (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "bmerge (cons2 z2 x2) (cons2 x3 x4) =
     (let fail :: int list =
       stitch
         (bmerge (evens (cons2 z2 x2)) (evens (cons2 x3 x4)))
         (bmerge (odds (cons2 z2 x2)) (odds (cons2 x3 x4)))
     in (case x2 of
           nil2 =>
             (case x4 of
                nil2 => sort2 z2 x3
                | cons2 x5 x6 => fail)
           | cons2 x7 x8 => fail))"
by pat_completeness auto

(*fun did not finish the proof*)
function bsort :: "int list => int list" where
"bsort (nil2) = nil2"
| "bsort (cons2 z (nil2)) = cons2 z (nil2)"
| "bsort (cons2 z (cons2 x2 x3)) =
     bmerge
       (bsort (evens (cons2 z (cons2 x2 x3))))
       (bsort (odds (cons2 z (cons2 x2 x3))))"
by pat_completeness auto

theorem property0 :
  "((count y (bsort xs)) = (count y xs))"
  oops

end


(* Title: Verification Component Based on KAD
   Author: Victor Gomes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Components Based on Kleene Algebra with Domain\<close>

theory VC_KAD

imports KAD.Modal_Kleene_Algebra_Models "../P2S2R"

begin

subsection\<open>Verification Component for Backward Reasoning\<close>

text \<open>This component supports the verification of simple while programs
in a partial correctness setting.\<close>

no_notation Archimedean_Field.ceiling ("\<lceil>_\<rceil>")
no_notation Archimedean_Field.floor ("\<lfloor>_\<rfloor>")

notation p2r ("\<lceil>_\<rceil>")
notation r2p ("\<lfloor>_\<rfloor>")

context antidomain_kleene_algebra
begin

subsubsection \<open>Additional Facts for KAD\<close>

lemma fbox_shunt: "d p \<cdot> d q \<le> |x] t \<longleftrightarrow> d p \<le> ad q + |x] t"
  by (metis a_6 a_antitone' a_loc add_commute addual.ars_r_def am_d_def da_shunt2 fbox_def)

subsubsection \<open>Syntax for Conditionals and Loops\<close>

definition cond :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("if _ then _ else _ fi" [64,64,64] 63) where
  "if p then x else y fi = d p \<cdot> x + ad p \<cdot> y"

definition while :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ do _ od" [64,64] 63) where
  "while p do x od = (d p \<cdot> x)\<^sup>\<star> \<cdot> ad p"

definition whilei :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ inv _ do _ od" [64,64,64] 63) where
  "while p inv i do x od = while p do x od"

subsubsection \<open>Basic Weakest (Liberal) Precondition Calculus\<close>

text \<open>In the setting of Kleene algebra with domain, the wlp operator is the forward modal box operator
of antidomain Kleene algebra.\<close>

lemma fbox_export1: "ad p + |x] q = |d p \<cdot> x] q"
  using a_d_add_closure addual.ars_r_def fbox_def fbox_mult by auto

lemma fbox_export2: "|x] p \<le> |x \<cdot> ad q] (d p \<cdot> ad q)"
proof -
  {fix t
   have "d t \<cdot> x \<le> x \<cdot> d p \<Longrightarrow> d t \<cdot> x \<cdot> ad q \<le> x \<cdot> ad q \<cdot> d p \<cdot> ad q"
     by (metis (full_types) a_comm_var a_mult_idem ads_d_def am2 ds.ddual.mult_assoc phl_export2)
   hence "d t \<le> |x] p \<Longrightarrow> d t \<le> |x \<cdot> ad q] (d p \<cdot> ad q)"
     by (metis a_closure' addual.ars_r_def ans_d_def dka.dsg3 ds.ddual.mult_assoc fbox_def fbox_demodalisation3)
  }
  thus ?thesis
    by (metis a_closure' addual.ars_r_def ans_d_def fbox_def order_refl)
qed

lemma fbox_export3: "|x \<cdot> ad p] q = |x] (d p + d q)"
  using a_de_morgan_var_3 ds.ddual.mult_assoc fbox_def by auto

lemma fbox_seq [simp]: "|x \<cdot> y] q = |x] |y] q"
  by (simp add: fbox_mult)

lemma fbox_seq_var: "p' \<le> |y] q \<Longrightarrow> p \<le> |x] p' \<Longrightarrow> p \<le> |x \<cdot> y] q"
proof -
  assume h1: "p \<le> |x] p'" and h2: "p' \<le> |y] q"
  hence "|x] p' \<le> |x] |y] q"
    by (simp add: dka.dom_iso fbox_iso)
  thus ?thesis
    by (metis h1 dual_order.trans fbox_seq)
qed

lemma fbox_cond_var [simp]: "|if p then x else y fi] q = (ad p + |x] q) \<cdot> (d p + |y] q)"
  using cond_def a_closure' ads_d_def ans_d_def fbox_add2 fbox_export1 by auto

lemma fbox_cond_aux1 [simp]: "d p \<cdot> |if p then x else y fi] q = d p \<cdot> |x] q"
proof -
  have "d p \<cdot> |if p then x else y fi] q = d p \<cdot> |x] q \<cdot> (d p + d ( |y] q))"
    using a_d_add_closure addual.ars_r_def ds.ddual.mult_assoc fbox_def fbox_cond_var by auto
  thus ?thesis
    by (metis addual.ars_r_def am2 dka.dns5 ds.ddual.mult_assoc fbox_def)
qed

lemma fbox_cond_aux2 [simp]: "ad p \<cdot> |if p then x else y fi] q = ad p \<cdot> |y] q"
  by (metis cond_def a_closure' add_commute addual.ars_r_def ans_d_def fbox_cond_aux1)

lemma fbox_cond [simp]: "|if p then x else y fi] q = (d p \<cdot> |x] q) + (ad p \<cdot> |y] q)"
proof -
  have "|if p then x else y fi] q = (d p + ad p) \<cdot> |if p then x else y fi] q"
    by (simp add: addual.ars_r_def)
  thus ?thesis
    by (metis  distrib_right' fbox_cond_aux1 fbox_cond_aux2)
qed

lemma fbox_cond_var2 [simp]: "|if p then x else y fi] q = if p then |x] q else |y] q fi"
  using cond_def fbox_cond by auto

lemma fbox_while_unfold: "|while t do x od] p = (d t + d p) \<cdot> (ad t + |x] |while t do x od] p)"
  by (metis fbox_export1 fbox_export3 dka.dom_add_closed fbox_star_unfold_var while_def)

lemma fbox_while_var1: "d t \<cdot> |while t do x od] p = d t \<cdot> |x] |while t do x od] p"
  by (metis fbox_while_unfold a_mult_add ads_d_def dka.dns5 ds.ddual.mult_assoc join.sup_commute)

lemma fbox_while_var2: "ad t \<cdot> |while t do x od] p \<le> d p"
proof -
  have "ad t \<cdot> |while t do x od] p = ad t \<cdot> (d t + d p) \<cdot> (ad t + |x] |while t do x od] p)"
    by (metis fbox_while_unfold ds.ddual.mult_assoc)
  also have "... =  ad t \<cdot> d p \<cdot> (ad t + |x] |while t do x od] p)"
    by (metis a_de_morgan_var_3 addual.ars_r_def dka.dom_add_closed s4)
  also have "... \<le> d p \<cdot> (ad t + |x] |while t do x od] p)"
    using a_subid_aux1' mult_isor by blast
  finally show ?thesis
    by (metis a_de_morgan_var_3 a_mult_idem addual.ars_r_def ans4 dka.dsr5 dpdz.domain_1'' dual_order.trans fbox_def)
qed

lemma fbox_while: "d p \<cdot> d t \<le> |x] p \<Longrightarrow> d p \<le> |while t do x od] (d p \<cdot> ad t)"
proof -
  assume "d p \<cdot> d t \<le> |x] p"
  hence "d p \<le> |d t \<cdot> x] p"
    by (simp add: fbox_export1 fbox_shunt)
  hence "d p \<le> |(d t \<cdot> x)\<^sup>\<star>] p"
    by (simp add: fbox_star_induct_var)
  thus ?thesis
    using order_trans while_def fbox_export2 by presburger
qed

lemma fbox_while_var: "d p = |d t \<cdot> x] p \<Longrightarrow> d p \<le> |while t do x od] (d p \<cdot> ad t)"
  by (metis eq_refl fbox_export1 fbox_shunt fbox_while)

lemma fbox_whilei: "d p \<le> d i \<Longrightarrow> d i \<cdot> ad t \<le> d q \<Longrightarrow> d i \<cdot> d t \<le> |x] i \<Longrightarrow> d p \<le> |while t inv i do x od] q"
proof -
  assume a1: "d p \<le> d i" and a2: "d i \<cdot> ad t \<le> d q" and "d i \<cdot> d t \<le> |x] i"
  hence "d i \<le> |while t inv i do x od] (d i \<cdot> ad t)"
    by (simp add: fbox_while whilei_def)
  also have "... \<le> |while t inv i do x od] q"
    using a2 dka.dom_iso fbox_iso by fastforce
  finally show ?thesis
    using a1 dual_order.trans by blast
qed

text \<open>The next rule is used for dealing with while loops after a series of sequential steps.\<close>

lemma fbox_whilei_break: "d p \<le> |y] i \<Longrightarrow> d i \<cdot> ad t \<le> d q \<Longrightarrow> d i \<cdot> d t \<le> |x] i \<Longrightarrow> d p \<le> |y \<cdot> (while t inv i do x od)] q"
  apply (rule fbox_seq_var, rule fbox_whilei, simp_all, blast)
  using fbox_simp by auto

text \<open>Finally we derive a frame rule.\<close>

lemma fbox_frame: "d p \<cdot> x \<le> x \<cdot> d p \<Longrightarrow> d q \<le> |x] t \<Longrightarrow> d p \<cdot> d q \<le> |x] (d p \<cdot> d t)"
  using dual.mult_isol_var fbox_add1 fbox_demodalisation3 fbox_simp by auto

lemma fbox_frame_var: "d p \<le> |x] p \<Longrightarrow> d q \<le> |x] t \<Longrightarrow> d p \<cdot> d q \<le> |x] (d p \<cdot> d t)"
  using fbox_frame fbox_demodalisation3 fbox_simp by auto

end

subsubsection \<open>Store and Assignment\<close>

type_synonym 'a store = "string  \<Rightarrow> 'a"

notation rel_antidomain_kleene_algebra.fbox ("wp")
and rel_antidomain_kleene_algebra.fdia ("relfdia")

definition gets :: "string \<Rightarrow> ('a store \<Rightarrow> 'a) \<Rightarrow> 'a store rel" ("_ ::= _" [70, 65] 61) where
   "v ::= e = {(s,s (v := e s)) |s. True}"

lemma assign_prop: "\<lceil>\<lambda>s. P (s (v := e s))\<rceil> ; (v ::= e) = (v ::= e) ; \<lceil>P\<rceil>"
  by (auto simp add: p2r_def gets_def)

lemma wp_assign [simp]: "wp (v ::= e) \<lceil>Q\<rceil> = \<lceil>\<lambda>s. Q (s (v := e s))\<rceil>"
  by (auto simp: rel_antidomain_kleene_algebra.fbox_def gets_def rel_ad_def p2r_def)

lemma wp_assign_var [simp]: "\<lfloor>wp (v ::= e) \<lceil>Q\<rceil>\<rfloor> = (\<lambda>s. Q (s (v := e s)))"
  by (simp, auto simp: r2p_def p2r_def)

lemma wp_assign_det: "wp (v ::= e) \<lceil>Q\<rceil> = relfdia (v ::= e) \<lceil>Q\<rceil>"
  by (auto simp add: rel_antidomain_kleene_algebra.fbox_def rel_antidomain_kleene_algebra.fdia_def gets_def p2r_def rel_ad_def, fast)

subsubsection \<open>Simplifications\<close>

notation rel_antidomain_kleene_algebra.ads_d ("rdom")

abbreviation spec_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a pred \<Rightarrow> bool" ("PRE _ _ POST _" [64,64,64] 63) where
  "PRE P X POST Q \<equiv> rdom \<lceil>P\<rceil> \<subseteq> wp X \<lceil>Q\<rceil>"

abbreviation cond_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("IF _ THEN _ ELSE _ FI" [64,64,64] 63) where
  "IF P THEN X ELSE Y FI \<equiv> rel_antidomain_kleene_algebra.cond \<lceil>P\<rceil> X Y"

abbreviation whilei_sugar :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("WHILE _ INV _ DO _ OD" [64,64,64] 63) where
  "WHILE P INV I DO X OD \<equiv> rel_antidomain_kleene_algebra.whilei \<lceil>P\<rceil> \<lceil>I\<rceil> X"

lemma d_p2r [simp]: "rdom \<lceil>P\<rceil> = \<lceil>P\<rceil>"
  by (simp add: p2r_def rel_antidomain_kleene_algebra.ads_d_def rel_ad_def)

lemma p2r_conj_hom_var_symm [simp]: "\<lceil>P\<rceil> ; \<lceil>Q\<rceil> = \<lceil>P \<sqinter> Q\<rceil>"
  by (simp add: p2r_conj_hom_var)

lemma p2r_neg_hom [simp]: "rel_ad \<lceil>P\<rceil> = \<lceil>- P\<rceil>"
  by (simp add: rel_ad_def p2r_def)

lemma wp_trafo: "\<lfloor>wp X \<lceil>Q\<rceil>\<rfloor> = (\<lambda>s. \<forall>s'. (s,s') \<in> X \<longrightarrow> Q s')"
  by (auto simp: rel_antidomain_kleene_algebra.fbox_def rel_ad_def p2r_def r2p_def)

lemma wp_trafo_var: "\<lfloor>wp X \<lceil>Q\<rceil>\<rfloor> s = (\<forall>s'. (s,s') \<in> X \<longrightarrow> Q s')"
  by (simp add: wp_trafo)

lemma wp_simp: "rdom \<lceil>\<lfloor>wp X Q\<rfloor>\<rceil> = wp X Q"
  by (metis d_p2r rel_antidomain_kleene_algebra.a_subid' rel_antidomain_kleene_algebra.addual.bbox_def rpr)

lemma wp_simp_var [simp]: "wp \<lceil>P\<rceil> \<lceil>Q\<rceil> = \<lceil>- P \<squnion> Q\<rceil>"
  by (simp add: rel_antidomain_kleene_algebra.fbox_def)

lemma impl_prop [simp]: "\<lceil>P\<rceil> \<subseteq> \<lceil>Q\<rceil> \<longleftrightarrow> (\<forall>s. P s \<longrightarrow>  Q s)"
  by (auto simp: p2r_def)

lemma p2r_eq_prop [simp]: "\<lceil>P\<rceil> = \<lceil>Q\<rceil> \<longleftrightarrow> (\<forall>s. P s \<longleftrightarrow>  Q s)"
  by (auto simp: p2r_def)

lemma impl_prop_var [simp]: "rdom \<lceil>P\<rceil> \<subseteq> rdom \<lceil>Q\<rceil> \<longleftrightarrow> (\<forall>s. P s \<longrightarrow>  Q s)"
  by simp

lemma p2r_eq_prop_var [simp]: "rdom \<lceil>P\<rceil> = rdom \<lceil>Q\<rceil> \<longleftrightarrow> (\<forall>s. P s \<longleftrightarrow>  Q s)"
  by simp

lemma wp_whilei: "(\<forall>s. P s \<longrightarrow> I s) \<Longrightarrow> (\<forall>s. (I \<sqinter> -T) s \<longrightarrow> Q s) \<Longrightarrow> (\<forall>s. (I \<sqinter> T) s \<longrightarrow> \<lfloor>wp X \<lceil>I\<rceil>\<rfloor> s)
                  \<Longrightarrow> (\<forall>s. P s \<longrightarrow> \<lfloor>wp (WHILE T INV I DO X OD) \<lceil>Q\<rceil>\<rfloor> s)"
  apply (simp only: impl_prop_var[symmetric] wp_simp)
  by (rule rel_antidomain_kleene_algebra.fbox_whilei, simp_all, simp_all add: p2r_def)

end


(*<*)
theory Abstract_BD_Security
  imports Main
begin
(*>*)

section \<open>BD Security\<close>

subsection \<open>Abstract definition\<close>

no_notation relcomp (infixr "O" 75)

locale Abstract_BD_Security =
 fixes
  validSystemTrace :: "'traces \<Rightarrow> bool"
and \<comment> \<open>secret values:\<close>
  V :: "'traces \<Rightarrow> 'values"
and \<comment> \<open>observations:\<close>
  O :: "'traces \<Rightarrow> 'observations"
and \<comment> \<open>declassification bound:\<close>
  B :: "'values \<Rightarrow> 'values \<Rightarrow> bool"
and \<comment> \<open>declassification trigger:\<close>
  TT :: "'traces \<Rightarrow> bool"
begin

text \<open>A system is considered to be secure if, for all traces that satisfy a given condition
(later instantiated to be the absence of transitions satisfying a declassification trigger
condition, releasing the secret information), the secret value can be replaced by another
secret value within the declassification bound, without changing the observation.
Hence, an observer cannot distinguish secrets related by the declassification bound,
unless and until release of the secret information is allowed by the declassification trigger.\<close>

(* BD security: *)
definition secure :: bool where
"secure \<equiv>
 \<forall> tr vl vl1.
   validSystemTrace tr \<and> TT tr \<and> B vl vl1 \<and> V tr = vl \<longrightarrow>
   (\<exists> tr1. validSystemTrace tr1 \<and> O tr1 = O tr \<and> V tr1 = vl1)"

lemma secureE:
assumes "secure" and "validSystemTrace tr" and "TT tr" and "B (V tr) vl1"
obtains tr1 where "validSystemTrace tr1" "O tr1 = O tr" "V tr1 = vl1"
using assms unfolding secure_def by auto

end (* context BD_Security *)

(*<*)
end
(*>*)


theory Finite_Reachable
imports Small_Step
begin

subsection "Finite number of reachable commands"

text{* This theory shows that in the small-step semantics one can only reach
a finite number of commands from any given command. Hence one can see the
command component of a small-step configuration as a combination of the
program to be executed and a pc. *}

definition reachable :: "com \<Rightarrow> com set" where
"reachable c = {c'. \<exists>s t. (c,s) \<rightarrow>* (c',t)}"

text{* Proofs need induction on the length of a small-step reduction sequence. *}

fun small_stepsn :: "com * state \<Rightarrow> nat \<Rightarrow> com * state \<Rightarrow> bool"
    ("_ \<rightarrow>'(_') _" [55,0,55] 55) where
"(cs \<rightarrow>(0) cs') = (cs' = cs)" |
"cs \<rightarrow>(Suc n) cs'' = (\<exists>cs'. cs \<rightarrow> cs' \<and> cs' \<rightarrow>(n) cs'')"

lemma stepsn_if_star: "cs \<rightarrow>* cs' \<Longrightarrow> \<exists>n. cs \<rightarrow>(n) cs'"
proof(induction rule: star.induct)
  case refl show ?case by (metis small_stepsn.simps(1))
next
  case step thus ?case by (metis small_stepsn.simps(2))
qed

lemma star_if_stepsn: "cs \<rightarrow>(n) cs' \<Longrightarrow> cs \<rightarrow>* cs'"
by(induction n arbitrary: cs) (auto elim: star.step)

lemma SKIP_starD: "(SKIP, s) \<rightarrow>* (c,t) \<Longrightarrow> c = SKIP"
by(induction SKIP s c t rule: star_induct) auto

lemma reachable_SKIP: "reachable SKIP = {SKIP}"
by(auto simp: reachable_def dest: SKIP_starD)

lemma Assign_starD: "(x::=a, s) \<rightarrow>* (c,t) \<Longrightarrow> c \<in> {x::=a, SKIP}"
by (induction "x::=a" s c t rule: star_induct) (auto dest: SKIP_starD)

lemma reachable_Assign: "reachable (x::=a) = {x::=a, SKIP}"
by(auto simp: reachable_def dest:Assign_starD)

lemma Seq_stepsnD: "(c1;; c2, s) \<rightarrow>(n) (c', t) \<Longrightarrow>
  (\<exists>c1' m. c' = c1';; c2 \<and> (c1, s) \<rightarrow>(m) (c1', t) \<and> m \<le> n) \<or>
  (\<exists>s2 m1 m2. (c1,s) \<rightarrow>(m1) (SKIP,s2) \<and> (c2, s2) \<rightarrow>(m2) (c', t) \<and> m1+m2 < n)"
proof(induction n arbitrary: c1 c2 s)
  case 0 thus ?case by auto
next
  case (Suc n)
  from Suc.prems obtain s' c12' where "(c1;;c2, s) \<rightarrow> (c12', s')"
    and n: "(c12',s') \<rightarrow>(n) (c',t)" by auto
  from this(1) show ?case
  proof
    assume "c1 = SKIP" "(c12', s') = (c2, s)"
    hence "(c1,s) \<rightarrow>(0) (SKIP, s') \<and> (c2, s') \<rightarrow>(n) (c', t) \<and> 0 + n < Suc n"
      using n by auto
    thus ?case by blast
  next
    fix c1' s'' assume 1: "(c12', s') = (c1';; c2, s'')" "(c1, s) \<rightarrow> (c1', s'')"
    hence n': "(c1';;c2,s') \<rightarrow>(n) (c',t)" using n by auto
    from Suc.IH[OF n'] show ?case
    proof
      assume "\<exists>c1'' m. c' = c1'';; c2 \<and> (c1', s') \<rightarrow>(m) (c1'', t) \<and> m \<le> n"
        (is "\<exists> a b. ?P a b")
      then obtain c1'' m where 2: "?P c1'' m" by blast
      hence "c' = c1'';;c2 \<and> (c1, s) \<rightarrow>(Suc m) (c1'',t) \<and> Suc m \<le> Suc n"
        using 1 by auto
      thus ?case by blast
    next
      assume "\<exists>s2 m1 m2. (c1',s') \<rightarrow>(m1) (SKIP,s2) \<and>
        (c2,s2) \<rightarrow>(m2) (c',t) \<and> m1+m2 < n" (is "\<exists>a b c. ?P a b c")
      then obtain s2 m1 m2 where "?P s2 m1 m2" by blast
      hence "(c1,s) \<rightarrow>(Suc m1) (SKIP,s2) \<and> (c2,s2) \<rightarrow>(m2) (c',t) \<and>
        Suc m1 + m2 < Suc n"  using 1 by auto
      thus ?case by blast
    qed
  qed
qed

corollary Seq_starD: "(c1;; c2, s) \<rightarrow>* (c', t) \<Longrightarrow>
  (\<exists>c1'. c' = c1';; c2 \<and> (c1, s) \<rightarrow>* (c1', t)) \<or>
  (\<exists>s2. (c1,s) \<rightarrow>* (SKIP,s2) \<and> (c2, s2) \<rightarrow>* (c', t))"
by(metis Seq_stepsnD star_if_stepsn stepsn_if_star)

lemma reachable_Seq: "reachable (c1;;c2) \<subseteq>
  (\<lambda>c1'. c1';;c2) ` reachable c1 \<union> reachable c2"
by(auto simp: reachable_def image_def dest!: Seq_starD)

lemma If_starD: "(IF b THEN c1 ELSE c2, s) \<rightarrow>* (c,t) \<Longrightarrow>
  c = IF b THEN c1 ELSE c2 \<or> (c1,s) \<rightarrow>* (c,t) \<or> (c2,s) \<rightarrow>* (c,t)"
by(induction "IF b THEN c1 ELSE c2" s c t rule: star_induct) auto

lemma reachable_If: "reachable (IF b THEN c1 ELSE c2) \<subseteq>
  {IF b THEN c1 ELSE c2} \<union> reachable c1 \<union> reachable c2"
by(auto simp: reachable_def dest!: If_starD)

lemma While_stepsnD: "(WHILE b DO c, s) \<rightarrow>(n) (c2,t) \<Longrightarrow>
  c2 \<in> {WHILE b DO c, IF b THEN c ;; WHILE b DO c ELSE SKIP, SKIP}
  \<or> (\<exists>c1. c2 = c1 ;; WHILE b DO c \<and> (\<exists> s1 s2. (c,s1) \<rightarrow>* (c1,s2)))"
proof(induction n arbitrary: s rule: less_induct)
  case (less n1)
  show ?case
  proof(cases n1)
    case 0 thus ?thesis using less.prems by (simp)
  next
    case (Suc n2)
    let ?w = "WHILE b DO c"
    let ?iw = "IF b THEN c ;; ?w ELSE SKIP"
    from Suc less.prems have n2: "(?iw,s) \<rightarrow>(n2) (c2,t)" by(auto elim!: WhileE)
    show ?thesis
    proof(cases n2)
      case 0 thus ?thesis using n2 by auto
    next
      case (Suc n3)
      then obtain iw' s' where "(?iw,s) \<rightarrow> (iw',s')"
        and n3: "(iw',s') \<rightarrow>(n3) (c2,t)"  using n2 by auto
      from this(1)
      show ?thesis
      proof
        assume "(iw', s') = (c;; WHILE b DO c, s)"
        with n3 have "(c;;?w, s) \<rightarrow>(n3) (c2,t)" by auto
        from Seq_stepsnD[OF this] show ?thesis
        proof
          assume "\<exists>c1' m. c2 = c1';; ?w \<and> (c,s) \<rightarrow>(m) (c1', t) \<and> m \<le> n3"
          thus ?thesis by (metis star_if_stepsn)
        next
          assume "\<exists>s2 m1 m2. (c, s) \<rightarrow>(m1) (SKIP, s2) \<and>
            (WHILE b DO c, s2) \<rightarrow>(m2) (c2, t) \<and> m1 + m2 < n3" (is "\<exists>x y z. ?P x y z")
          then obtain s2 m1 m2 where "?P s2 m1 m2" by blast
          with `n2 = Suc n3` `n1 = Suc n2`have "m2 < n1" by arith
          from less.IH[OF this] `?P s2 m1 m2` show ?thesis by blast
        qed
      next
        assume "(iw', s') = (SKIP, s)"
        thus ?thesis using star_if_stepsn[OF n3] by(auto dest!: SKIP_starD)
      qed
    qed
  qed
qed

lemma reachable_While: "reachable (WHILE b DO c) \<subseteq>
  {WHILE b DO c, IF b THEN c ;; WHILE b DO c ELSE SKIP, SKIP} \<union>
  (\<lambda>c'. c' ;; WHILE b DO c) ` reachable c"
apply(auto simp: reachable_def image_def)
by (metis While_stepsnD insertE singletonE stepsn_if_star)

theorem finite_reachable: "finite(reachable c)"
apply(induction c)
apply(auto simp: reachable_SKIP reachable_Assign
  finite_subset[OF reachable_Seq] finite_subset[OF reachable_If]
  finite_subset[OF reachable_While])
done

end


section\<open>Left Complemented Monoid\<close>

theory LeftComplementedMonoid
  imports Operations LatticeProperties.Lattice_Prop
begin

class right_pordered_monoid_mult = order + monoid_mult +
  assumes mult_right_mono: "a \<le> b \<Longrightarrow> a * c \<le> b * c"

class one_greatest = one + ord +
  assumes one_greatest [simp]: "a \<le> 1"

class integral_right_pordered_monoid_mult = right_pordered_monoid_mult + one_greatest

class left_residuated = ord + times + left_imp +
  assumes left_residual: "(x * a \<le> b) = (x \<le> a l\<rightarrow> b)"

class left_residuated_pordered_monoid = integral_right_pordered_monoid_mult + left_residuated

class left_inf = inf + times + left_imp +
  assumes inf_l_def: "(a \<sqinter> b)  = (a l\<rightarrow> b) * a"

class left_complemented_monoid = left_residuated_pordered_monoid + left_inf +
  assumes right_divisibility: "(a \<le> b) = (\<exists> c . a = c * b)"
begin
lemma lcm_D: "a l\<rightarrow> a = 1"
  apply (rule order.antisym, simp)
  by (unfold left_residual [THEN sym], simp)

subclass semilattice_inf
    apply unfold_locales
    apply (metis inf_l_def right_divisibility)
    apply (metis inf_l_def left_residual order_refl)
    by (metis inf_l_def left_residual mult_right_mono right_divisibility)

  lemma left_one_inf [simp]: "1 \<sqinter> a = a"
    by (rule order.antisym, simp_all)

  lemma left_one_impl [simp]: "1 l\<rightarrow> a = a"
    (*by (metis inf_l_def left_one_inf mult.right_neutral)*)
    proof -
      have "1 l\<rightarrow> a = 1 \<sqinter> a" by (unfold inf_l_def, simp)
      also have "1 \<sqinter> a = a" by simp
      finally show ?thesis .
    qed

  lemma lcm_A: "(a l\<rightarrow> b) * a = (b l\<rightarrow> a) * b"
    apply (unfold inf_l_def [THEN sym])
    by (simp add: inf_commute)

  lemma lcm_B: "((a * b) l\<rightarrow> c) = (a l\<rightarrow> (b l\<rightarrow> c))"
    apply (rule order.antisym)
    apply (simp add: left_residual [THEN sym] mult.assoc)
    apply (simp add: left_residual)

    apply (simp add: left_residual [THEN sym])
    apply (rule_tac y="(b l\<rightarrow> c) * b" in order_trans)
    apply (simp add: mult.assoc [THEN sym])
    apply (rule mult_right_mono)
    by (simp_all add: left_residual)

  lemma lcm_C: "(a \<le> b) = ((a l\<rightarrow> b) = 1)"
    (*by (metis eq_iff left_residual mult.left_neutral one_greatest)*)
    proof -
      have "(a \<le> b) = (1 * a \<le> b)" by simp
      also have "\<dots> = (1 \<le> a l\<rightarrow> b)" by (unfold left_residual, simp)
      also have "\<dots> = (a l\<rightarrow> b = 1)" apply safe by(rule order.antisym, simp_all)
      finally show ?thesis .
    qed

  end

class less_def = ord +
  assumes less_def: "(a < b) = ((a \<le> b) \<and> \<not> (b \<le> a))"

class one_times = one + times +
  assumes one_left [simp]: "1 * a = a"
  and one_right [simp]: "a * 1 = a"

class left_complemented_monoid_algebra = left_imp + one_times + left_inf + less_def +
  assumes left_impl_one [simp]: "a l\<rightarrow> a = 1"
  and left_impl_times: "(a l\<rightarrow> b) * a = (b l\<rightarrow> a) * b"
  and left_impl_ded: "((a * b) l\<rightarrow> c) = (a l\<rightarrow> (b l\<rightarrow> c))"
  and left_lesseq: "(a \<le> b) = ((a l\<rightarrow> b) = 1)"
begin
  lemma A: "(1 l\<rightarrow> a) l\<rightarrow> 1 = 1"
    proof -
      have "(1 l\<rightarrow> a) l\<rightarrow> 1 = (1 l\<rightarrow> a) * 1 l\<rightarrow> 1" by simp
      also have "... = (a l\<rightarrow> 1) * a l\<rightarrow> 1" by (subst left_impl_times, simp)
      also have "... = 1" by (simp add: left_impl_ded)
      finally show ?thesis .
    qed

  subclass order
    proof
      fix x y show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)" by (unfold less_def, simp)
    next
      fix x show "x \<le> x" by (unfold left_lesseq, simp)
    next
      fix x y z assume a: "x \<le> y" assume b: "y \<le> z"
      have "x l\<rightarrow> z = 1 * x l\<rightarrow> z" by simp
      also have "... = (x l\<rightarrow> y) * x l\<rightarrow> z" by (cut_tac a, simp add: left_lesseq)
      also have "... = (y l\<rightarrow> x) * y l\<rightarrow> z" by (simp add: left_impl_times)
      also have "... = (y l\<rightarrow> x) l\<rightarrow> (y l\<rightarrow> z)" by (simp add: left_impl_ded)
      also have "... = (y l\<rightarrow> x) l\<rightarrow> 1" by (cut_tac b, simp add: left_lesseq)
      also have "... = (1 * y l\<rightarrow> x) l\<rightarrow> 1" by simp
      also have "... = (1 l\<rightarrow> (y l\<rightarrow> x)) l\<rightarrow> 1" by (subst left_impl_ded, simp)
      also have "... = 1" by (simp add: A)
      finally show "x \<le> z"  by (simp add: left_lesseq)
    next
      fix x y z assume a: "x \<le> y" assume b: "y \<le> x"
      have "x = (x l\<rightarrow> y) * x" by (cut_tac a, simp add: left_lesseq)
      also have "... = (y l\<rightarrow> x) * y" by (simp add: left_impl_times)
      also have "... = y" by (cut_tac b, simp add: left_lesseq)
      finally show "x = y" .
    qed

  lemma B: "(1 l\<rightarrow> a) \<le> 1"
    apply (unfold left_lesseq)
    by (rule A)

  lemma C: "a \<le> (1 l\<rightarrow> a)"
    by (simp add: left_lesseq left_impl_ded [THEN sym])

  lemma D: "a \<le> 1"
    apply (rule_tac y = "1 l\<rightarrow> a" in order_trans)
    by (simp_all add: C B)

  lemma less_eq: "(a \<le> b) = (\<exists> c . a = (c * b))"
    (*by (metis left_impl_ded left_impl_one left_impl_times left_lesseq one_left)*)
    apply safe
    apply (unfold left_lesseq)
    apply (rule_tac x = "b l\<rightarrow> a" in exI)
    apply (simp add: left_impl_times)
    apply (simp add: left_impl_ded)
    apply (case_tac "c \<le> 1")
    apply (simp add: left_lesseq)
    by (simp add: D)

  lemma F: "(a * b) * c l\<rightarrow> z = a * (b * c) l\<rightarrow> z"
    by (simp add: left_impl_ded)

  lemma associativity: "(a * b) * c = a * (b * c)"
    (*by (metis F left_impl_one left_impl_times one_left)*)
    apply (rule order.antisym)
    apply (unfold left_lesseq)
    apply (simp add: F)
    by (simp add: F [THEN sym])

  lemma H: "a * b \<le> b"
    apply (simp add: less_eq)
    by auto

  lemma I: "a * b l\<rightarrow> b = 1"
    apply (case_tac "a * b \<le> b")
    apply (simp add: left_lesseq)
    by (simp add: H)

  lemma L: "(x * a \<le> b) = (x \<le> a l\<rightarrow> b)"
    by (simp add: left_lesseq left_impl_ded)

  subclass left_complemented_monoid
    apply unfold_locales
    apply (simp_all add:  less_def D associativity K)
    apply (simp add: L)
    by (simp add: less_eq)
  end

lemma (in left_complemented_monoid) left_complemented_monoid:
    "class.left_complemented_monoid_algebra (*) inf (l\<rightarrow>) (\<le>) (<) 1"
  by (unfold_locales, simp_all add: less_le_not_le lcm_A lcm_B lcm_C lcm_D)

end


theory "AList-Utils-HOLCF"
imports "Launchbury.HOLCF-Utils" "Launchbury.HOLCF-Join-Classes" "Launchbury.AList-Utils"
begin

syntax
  "_BLubMap" :: "[pttrn, pttrn, 'a \<rightharpoonup> 'b, 'b] \<Rightarrow> 'b" ("(3\<Squnion>/_/\<mapsto>/_/\<in>/_/./ _)" [0,0,0, 10] 10)

translations
  "\<Squnion> k\<mapsto>v\<in>m. e" == "CONST lub (CONST mapCollect (\<lambda>k v . e) m)"

lemma below_lubmapI[intro]:
  "m k = Some v \<Longrightarrow> (e k v::'a::Join_cpo) \<sqsubseteq> (\<Squnion> k\<mapsto>v\<in>m. e k v)"
unfolding mapCollect_def by auto

lemma lubmap_belowI[intro]:
  "(\<And> k v . m k = Some v \<Longrightarrow> (e k v::'a::Join_cpo) \<sqsubseteq> u) \<Longrightarrow> (\<Squnion> k\<mapsto>v\<in>m. e k v) \<sqsubseteq> u"
unfolding mapCollect_def by auto

lemma lubmap_const_bottom[simp]:
  "(\<Squnion> k\<mapsto>v\<in>m. \<bottom>) = (\<bottom>::'a::Join_cpo)"
  by (cases "m = Map.empty") auto

lemma lubmap_map_upd[simp]:
  fixes e :: "'a \<Rightarrow> 'b \<Rightarrow> ('c :: Join_cpo)"
  shows "(\<Squnion>k\<mapsto>v\<in>m(k' \<mapsto> v'). e k v) = e k' v' \<squnion> (\<Squnion>k\<mapsto>v\<in>m(k':=None). e k v)"
  by simp

lemma lubmap_below_cong:
  assumes "\<And> k v. m k = Some v \<Longrightarrow> f1 k v \<sqsubseteq> (f2 k v :: 'a :: Join_cpo)"
  shows "(\<Squnion> k\<mapsto>v\<in>m. f1 k v) \<sqsubseteq> (\<Squnion> k\<mapsto>v\<in>m. f2 k v)"
  apply (rule lubmap_belowI)
  apply (rule below_trans[OF assms], assumption)
  apply (rule below_lubmapI, assumption)
  done

lemma cont2cont_lubmap[simp, cont2cont]:
  assumes "(\<And>k v . cont (f k v))"
  shows "cont (\<lambda>x. \<Squnion> k\<mapsto>v\<in>m. (f k v x) :: 'a :: Join_cpo)"
proof (rule contI2)
  show "monofun (\<lambda>x. \<Squnion>k\<mapsto>v\<in>m. f k v x)"
    apply (rule monofunI)
    apply (rule lubmap_below_cong)
    apply (erule cont2monofunE[OF assms])
    done
next
  fix Y :: "nat \<Rightarrow> 'd"
  assume "chain Y"
  assume "chain (\<lambda>i. \<Squnion>k\<mapsto>v\<in>m. f k v (Y i))"

  show "(\<Squnion>k\<mapsto>v\<in>m. f k v (\<Squnion> i. Y i)) \<sqsubseteq> (\<Squnion> i. \<Squnion>k\<mapsto>v\<in>m. f k v (Y i))"
    apply (subst cont2contlubE[OF assms \<open>chain Y\<close>])
    apply (rule lubmap_belowI)
    apply (rule lub_mono[OF ch2ch_cont[OF assms \<open>chain Y\<close>] \<open>chain (\<lambda>i. \<Squnion>k\<mapsto>v\<in>m. f k v (Y i))\<close>])
    apply (erule below_lubmapI)
    done
qed

(*
syntax
  "_BLubMapFilter" :: "[pttrn, pttrn, 'a \<rightharpoonup> 'b, 'b, bool] \<Rightarrow> 'b" ("(3\<Squnion>/_/\<mapsto>/_/\<in>/_/./ _/ |/ _)" [0,0,0,10,10] 10)

translations
  "\<Squnion> k\<mapsto>v\<in>m. e | P" == "CONST lub (CONST mapCollectFilter (\<lambda>k v. (P,e)) m)"
*)

end


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Additions to Isabelle's Main Theories\<close>

theory Additions_to_Main
imports "HOL-Library.Multiset"
begin

subsection \<open>Addition to Finite-Set Theory\<close>

lemma bound_domain_and_range_impl_finitely_many_functions:
  "finite {f::nat\<Rightarrow>nat. (\<forall>i. f i \<le> n) \<and> (\<forall>i\<ge>m. f i = 0)}"
proof (induct m)
  case 0
  have eq: "{f. (\<forall>i. f i \<le> n) \<and> (\<forall>i. f i = 0)} = {(\<lambda>_. 0)}" by auto
  from this show ?case by auto (subst eq; auto)
next
  case (Suc m)
  let ?S = "(\<lambda>(y, f). f(m := y)) ` ({0..n} \<times> {f. (\<forall>i. f i \<le> n) \<and> (\<forall>i\<ge>m. f i = 0)})"
  {
    fix g
    assume "\<forall>i. g i \<le> n" "\<forall>i\<ge>Suc m. g i = 0"
    from this have "g \<in> ?S"
      by (auto intro: image_eqI[where x="(g m, g(m:=0))"])
  }
  from this have "{f. (\<forall>i. f i \<le> n) \<and> (\<forall>i\<ge>Suc m. f i = 0)} = ?S" by auto
  from this Suc show ?case by simp
qed

subsection \<open>Addition to Set-Interval Theory\<close>

lemma sum_atMost_remove_nat:
  assumes "k \<le> (n :: nat)"
  shows "(\<Sum>i\<le>n. f i) = f k + (\<Sum>i\<in>{..n}-{k}. f i)"
using assms by (auto simp add: sum.remove[where x=k])

subsection \<open>Additions to Multiset Theory\<close>

lemma set_mset_Abs_multiset:
  assumes "f \<in> multiset"
  shows "set_mset (Abs_multiset f) = {x. f x > 0}"
using assms unfolding set_mset_def by simp

lemma sum_mset_sum_count:
  "sum_mset M = (\<Sum>i\<in>set_mset M. count M i * i)"
proof (induct M)
  show "sum_mset {#} = (\<Sum>i\<in>set_mset {#}. count {#} i * i)" by simp
next
  fix M x
  assume hyp: "sum_mset M = (\<Sum>i\<in>set_mset M. count M i * i)"
  show "sum_mset (add_mset x M) = (\<Sum>i\<in>set_mset (add_mset x M). count (add_mset x M) i * i)"
  proof (cases "x \<in># M")
    assume a: "\<not> x \<in># M"
    from this have "count M x = 0" by (meson count_inI)
    from \<open>\<not> x \<in># M\<close> this hyp show ?thesis
      by (auto intro!: sum.cong)
  next
    assume "x \<in># M"
    have "sum_mset (add_mset x M) = (\<Sum>i\<in>set_mset M. count M i * i) + x"
      using hyp by simp
    also have "\<dots> = (\<Sum>i\<in>set_mset M - {x}. count M i * i) + count M x * x + x"
      using \<open>x \<in># M\<close> by (simp add: sum.remove[of _ x])
    also have "\<dots> = count (add_mset x M) x * x + (\<Sum>i\<in>set_mset (add_mset x M) - {x}. count (add_mset x M) i * i)"
      by simp
    also have "\<dots> = (\<Sum>i\<in>set_mset (add_mset x M). count (add_mset x M) i * i)"
      using \<open>x \<in># M\<close> by (simp add: sum.remove[of _ x])
    finally show ?thesis .
  qed
qed

lemma sum_mset_eq_sum_on_supersets:
  assumes "finite A" "set_mset M \<subseteq> A"
  shows "(\<Sum>i\<in>set_mset M. count M i * i) = (\<Sum>i\<in>A. count M i * i)"
proof -
  note \<open>finite A\<close> \<open>set_mset M \<subseteq> A\<close>
  moreover have "\<forall>i\<in>A - set_mset M. count M i * i = 0"
    using count_inI by fastforce
  ultimately show ?thesis
    by (auto intro: sum.mono_neutral_cong_left)
qed

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Simple semicategories\<close>
theory CZH_SMC_Simple
  imports
    CZH_DG_Simple
    CZH_SMC_NTSMCF
begin

subsection\<open>Background\<close>

text\<open>
The section presents a variety of simple semicategories, such as the empty
semicategory \<open>0\<close> and a semicategory with one object and one arrow \<open>1\<close>.
All of the entities presented in this section are generalizations of certain
simple categories, whose definitions can be found
in \<^cite>\<open>"mac_lane_categories_2010"\<close>.
\<close>

subsection\<open>Empty semicategory \<open>0\<close>\<close>

subsubsection\<open>Definition and elementary properties\<close>

text\<open>See Chapter I-2 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

definition smc_0 :: "V"
  where "smc_0 = [0, 0, 0, 0, 0]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma smc_0_components:
  shows "smc_0\<lparr>Obj\<rparr> = 0"
    and "smc_0\<lparr>Arr\<rparr> = 0"
    and "smc_0\<lparr>Dom\<rparr> = 0"
    and "smc_0\<lparr>Cod\<rparr> = 0"
    and "smc_0\<lparr>Comp\<rparr> = 0"
  unfolding smc_0_def dg_field_simps by (simp_all add: nat_omega_simps)

text\<open>Slicing.\<close>

lemma smc_dg_smc_0: "smc_dg smc_0 = dg_0"
  unfolding smc_dg_def smc_0_def dg_0_def dg_field_simps
  by (simp add: nat_omega_simps)

lemmas_with (in \<Z>) [folded smc_dg_smc_0, unfolded slicing_simps]:
  smc_0_is_arr_iff = dg_0_is_arr_iff

subsubsection\<open>\<open>0\<close> is a semicategory\<close>

lemma (in \<Z>) semicategory_smc_0[smc_cs_intros]: "semicategory \<alpha> smc_0"
proof(intro semicategoryI)
  show "vfsequence smc_0" unfolding smc_0_def by (simp add: nat_omega_simps)
  show "vcard smc_0 = 5\<^sub>\<nat>" unfolding smc_0_def by (simp add: nat_omega_simps)
  show "digraph \<alpha> (smc_dg smc_0)"
    by (simp add: smc_dg_smc_0 \<Z>.digraph_dg_0 \<Z>_axioms)
qed (auto simp: smc_0_components smc_0_is_arr_iff)

lemmas [smc_cs_intros] = \<Z>.semicategory_smc_0

subsubsection\<open>Opposite of the semicategory \<open>0\<close>\<close>

lemma op_smc_smc_0[smc_op_simps]: "op_smc (smc_0) = smc_0"
proof(rule smc_dg_eqI)
  define \<beta> where "\<beta> = \<omega> + \<omega>"
  interpret \<beta>: \<Z> \<beta> unfolding \<beta>_def by (rule \<Z>_\<omega>\<omega>)
  show "semicategory \<beta> (op_smc smc_0)"
    by (cs_concl cs_shallow cs_intro: smc_cs_intros smc_op_intros)
  show "semicategory \<beta> smc_0" by (cs_concl cs_shallow cs_intro: smc_cs_intros)
qed
  (
    simp_all add:
      smc_0_components op_smc_components smc_dg_smc_0
      slicing_commute[symmetric] dg_op_simps
  )

subsubsection\<open>A semicategory without objects is empty\<close>

lemma (in semicategory) smc_smc_0_if_Obj_0:
  assumes "\<CC>\<lparr>Obj\<rparr> = 0"
  shows "\<CC> = smc_0"
  by (rule smc_eqI[of \<alpha>])
    (
      auto simp:
        smc_cs_intros
        assms
        semicategory_smc_0
        smc_0_components
        smc_Arr_vempty_if_Obj_vempty
        smc_Cod_vempty_if_Arr_vempty
        smc_Dom_vempty_if_Arr_vempty
        smc_Comp_vempty_if_Arr_vempty
    )

subsection\<open>Empty semifunctor\<close>

text\<open>
An empty semifunctor is defined as a semifunctor between an
empty semicategory and an arbitrary semicategory.
\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition smcf_0 :: "V \<Rightarrow> V"
  where "smcf_0 \<AA> = [0, 0, smc_0, \<AA>]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma smcf_0_components:
  shows "smcf_0 \<AA>\<lparr>ObjMap\<rparr> = 0"
    and "smcf_0 \<AA>\<lparr>ArrMap\<rparr> = 0"
    and "smcf_0 \<AA>\<lparr>HomDom\<rparr> = smc_0"
    and "smcf_0 \<AA>\<lparr>HomCod\<rparr> = \<AA>"
  unfolding smcf_0_def dghm_field_simps by (simp_all add: nat_omega_simps)

text\<open>Slicing.\<close>

lemma smcf_dghm_smcf_0: "smcf_dghm (smcf_0 \<AA>) = dghm_0 (smc_dg \<AA>)"
  unfolding
    smcf_dghm_def smcf_0_def dg_0_def smc_0_def dghm_0_def smc_dg_def
    dg_field_simps dghm_field_simps
  by (simp add: nat_omega_simps)

text\<open>Opposite empty semicategory homomorphism.\<close>

lemma op_smcf_smcf_0: "op_smcf (smcf_0 \<CC>) = smcf_0 (op_smc \<CC>)"
  unfolding
    smcf_0_def op_smc_def op_smcf_def smc_0_def dghm_field_simps dg_field_simps
  by (simp add: nat_omega_simps)

subsubsection\<open>Object map\<close>

lemma smcf_0_ObjMap_vsv[smc_cs_intros]: "vsv (smcf_0 \<CC>\<lparr>ObjMap\<rparr>)"
  unfolding smcf_0_components by simp

subsubsection\<open>Arrow map\<close>

lemma smcf_0_ArrMap_vsv[smc_cs_intros]: "vsv (smcf_0 \<CC>\<lparr>ArrMap\<rparr>)"
  unfolding smcf_0_components by simp

subsubsection\<open>Empty semifunctor is a faithful semifunctor\<close>

lemma (in \<Z>) smcf_0_is_ft_semifunctor:
  assumes "semicategory \<alpha> \<AA>"
  shows "smcf_0 \<AA> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>f\<^sub>a\<^sub>i\<^sub>t\<^sub>h\<^sub>f\<^sub>u\<^sub>l\<^bsub>\<alpha>\<^esub> \<AA>"
proof(rule is_ft_semifunctorI)
  show "smcf_0 \<AA> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA>"
  proof(rule is_semifunctorI, unfold smc_dg_smc_0 smcf_dghm_smcf_0)
    show "vfsequence (smcf_0 \<AA>)" unfolding smcf_0_def by simp
    show "vcard (smcf_0 \<AA>) = 4\<^sub>\<nat>"
      unfolding smcf_0_def by (simp add: nat_omega_simps)
    show "dghm_0 (smc_dg \<AA>) : dg_0 \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> smc_dg \<AA>"
      by
        (
          simp add:
            assms
            dghm_0_is_ft_dghm
            is_ft_dghm.axioms(1)
            semicategory.smc_digraph
        )
  qed (auto simp: assms semicategory_smc_0 smcf_0_components smc_0_is_arr_iff)
  show "smcf_dghm (smcf_0 \<AA>) : smc_dg smc_0 \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>f\<^sub>a\<^sub>i\<^sub>t\<^sub>h\<^sub>f\<^sub>u\<^sub>l\<^bsub>\<alpha>\<^esub> smc_dg \<AA>"
    by
      (
        auto simp:
          assms
          \<Z>.dghm_0_is_ft_dghm
          \<Z>_axioms
          smc_dg_smc_0
          semicategory.smc_digraph
          smcf_dghm_smcf_0
      )
qed

lemma (in \<Z>) smcf_0_is_ft_semifunctor'[smcf_cs_intros]:
  assumes "semicategory \<alpha> \<AA>"
    and "\<BB>' = \<AA>"
    and "\<AA>' = smc_0"
  shows "smcf_0 \<AA> : \<AA>' \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>f\<^sub>a\<^sub>i\<^sub>t\<^sub>h\<^sub>f\<^sub>u\<^sub>l\<^bsub>\<alpha>\<^esub> \<BB>'"
  using assms(1) unfolding assms(2,3) by (rule smcf_0_is_ft_semifunctor)

lemmas [smcf_cs_intros] = \<Z>.smcf_0_is_ft_semifunctor'

lemma (in \<Z>) smcf_0_is_semifunctor:
  assumes "semicategory \<alpha> \<AA>"
  shows "smcf_0 \<AA> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA>"
  using smcf_0_is_ft_semifunctor[OF assms] by auto

lemma (in \<Z>) smcf_0_is_semifunctor'[smc_cs_intros]:
  assumes "semicategory \<alpha> \<AA>"
    and "\<BB>' = \<AA>"
    and "\<AA>' = smc_0"
  shows "smcf_0 \<AA> : \<AA>' \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>'"
  using assms(1) unfolding assms(2,3) by (rule smcf_0_is_semifunctor)

lemmas [smc_cs_intros] = \<Z>.smcf_0_is_semifunctor'

subsubsection\<open>Further properties\<close>

lemma is_semifunctor_is_smcf_0_if_smc_0:
  assumes "\<FF> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<FF> = smcf_0 \<CC>"
proof(rule smcf_dghm_eqI)
  interpret \<FF>: is_semifunctor \<alpha> smc_0 \<CC> \<FF> by (rule assms(1))
  show "\<FF> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" by (rule assms(1))
  then have dom_lhs: "\<D>\<^sub>\<circ> (\<FF>\<lparr>ObjMap\<rparr>) = 0" "\<D>\<^sub>\<circ> (\<FF>\<lparr>ArrMap\<rparr>) = 0"
    by (cs_concl cs_simp: smc_cs_simps smc_0_components)+
  show "smcf_0 \<CC> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" by (cs_concl cs_intro: smc_cs_intros)
  show "smcf_dghm \<FF> = smcf_dghm (smcf_0 \<CC>)"
    unfolding smcf_dghm_smcf_0
    by
      (
        rule is_dghm_is_dghm_0_if_dg_0,
        rule \<FF>.smcf_is_dghm[unfolded slicing_simps smc_dg_smc_0]
      )
qed simp_all

subsection\<open>Empty natural transformation of semifunctors\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition ntsmcf_0 :: "V \<Rightarrow> V"
  where "ntsmcf_0 \<CC> = [0, smcf_0 \<CC>, smcf_0 \<CC>, smc_0, \<CC>]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma ntsmcf_0_components:
  shows "ntsmcf_0 \<CC>\<lparr>NTMap\<rparr> = 0"
    and [smc_cs_simps]: "ntsmcf_0 \<CC>\<lparr>NTDom\<rparr> = smcf_0 \<CC>"
    and [smc_cs_simps]: "ntsmcf_0 \<CC>\<lparr>NTCod\<rparr> = smcf_0 \<CC>"
    and [smc_cs_simps]: "ntsmcf_0 \<CC>\<lparr>NTDGDom\<rparr> = smc_0"
    and [smc_cs_simps]: "ntsmcf_0 \<CC>\<lparr>NTDGCod\<rparr> = \<CC>"
  unfolding ntsmcf_0_def nt_field_simps by (simp_all add: nat_omega_simps)

text\<open>Slicing.\<close>

lemma ntsmcf_tdghm_ntsmcf_0: "ntsmcf_tdghm (ntsmcf_0 \<AA>) = tdghm_0 (smc_dg \<AA>)"
  unfolding
    ntsmcf_tdghm_def ntsmcf_0_def tdghm_0_def smcf_dghm_def
    smcf_0_def smc_dg_def smc_0_def dghm_0_def dg_0_def
    dg_field_simps dghm_field_simps nt_field_simps
  by (simp add: nat_omega_simps)

text\<open>Duality.\<close>

lemma op_ntsmcf_ntsmcf_0: "op_ntsmcf (ntsmcf_0 \<CC>) = ntsmcf_0 (op_smc \<CC>)"
  by
    (
      simp_all add:
        op_ntsmcf_def ntsmcf_0_def op_smc_def op_smcf_smcf_0 smc_0_def
        nt_field_simps dg_field_simps nat_omega_simps
    )

subsubsection\<open>Natural transformation map\<close>

lemma ntsmcf_0_NTMap_vsv[smc_cs_intros]: "vsv (ntsmcf_0 \<CC>\<lparr>NTMap\<rparr>)"
  unfolding ntsmcf_0_components by simp

lemma ntsmcf_0_NTMap_vdomain[smc_cs_simps]: "\<D>\<^sub>\<circ> (ntsmcf_0 \<CC>\<lparr>NTMap\<rparr>) = 0"
  unfolding ntsmcf_0_components by simp

lemma ntsmcf_0_NTMap_vrange[smc_cs_simps]: "\<R>\<^sub>\<circ> (ntsmcf_0 \<CC>\<lparr>NTMap\<rparr>) = 0"
  unfolding ntsmcf_0_components by simp

subsubsection\<open>
Empty natural transformation of semifunctors
is a natural transformation of semifunctors
\<close>

lemma (in semicategory) smc_ntsmcf_0_is_ntsmcfI:
  "ntsmcf_0 \<CC> : smcf_0 \<CC> \<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>F smcf_0 \<CC> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
proof(intro is_ntsmcfI)
  show "vfsequence (ntsmcf_0 \<CC>)" unfolding ntsmcf_0_def by simp
  show "vcard (ntsmcf_0 \<CC>) = 5\<^sub>\<nat>"
    unfolding ntsmcf_0_def by (simp add: nat_omega_simps)
  show "ntsmcf_tdghm (ntsmcf_0 \<CC>) :
    smcf_dghm (smcf_0 \<CC>) \<mapsto>\<^sub>D\<^sub>G\<^sub>H\<^sub>M smcf_dghm (smcf_0 \<CC>) :
    smc_dg smc_0 \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> smc_dg \<CC>"
    unfolding ntsmcf_tdghm_ntsmcf_0 smcf_dghm_smcf_0 smc_dg_smc_0
    by (cs_concl cs_shallow cs_intro: dg_cs_intros slicing_intros)
  show
    "ntsmcf_0 \<CC>\<lparr>NTMap\<rparr>\<lparr>b\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> smcf_0 \<CC>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> =
      smcf_0 \<CC>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> ntsmcf_0 \<CC>\<lparr>NTMap\<rparr>\<lparr>a\<rparr>"
    if "f : a \<mapsto>\<^bsub>smc_0\<^esub> b" for a b f
    using that by (elim is_arrE) (auto simp: smc_0_components)
qed
  (
    cs_concl cs_shallow
      cs_simp: smc_cs_simps smc_0_components(1) cs_intro: smc_cs_intros
  )+

lemma (in semicategory) smc_ntsmcf_0_is_ntsmcfI'[smc_cs_intros]:
  assumes "\<FF>' = smcf_0 \<CC>"
    and "\<GG>' = smcf_0 \<CC>"
    and "\<AA>' = smc_0"
    and "\<BB>' = \<CC>"
    and "\<FF>' = \<FF>"
    and "\<GG>' = \<GG>"
  shows "ntsmcf_0 \<CC> : \<FF>' \<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<GG>' : \<AA>' \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>'"
  unfolding assms by (rule smc_ntsmcf_0_is_ntsmcfI)

lemmas [smc_cs_intros] = semicategory.smc_ntsmcf_0_is_ntsmcfI'

lemma is_ntsmcf_is_ntsmcf_0_if_smc_0:
  assumes "\<NN> : \<FF> \<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<GG> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<NN> = ntsmcf_0 \<CC>" and "\<FF> = smcf_0 \<CC>" and "\<GG> = smcf_0 \<CC>"
proof-
  interpret \<NN>: is_ntsmcf \<alpha> smc_0 \<CC> \<FF> \<GG> \<NN> by (rule assms(1))
  note is_tdghm_is_tdghm_0_if_dg_0 = is_tdghm_is_tdghm_0_if_dg_0
    [
      OF \<NN>.ntsmcf_is_tdghm[unfolded smc_dg_smc_0],
      folded smcf_dghm_smcf_0 ntsmcf_tdghm_ntsmcf_0
    ]
  show \<FF>_def: "\<FF> = smcf_0 \<CC>" and \<GG>_def: "\<GG> = smcf_0 \<CC>"
    by (all\<open>intro is_semifunctor_is_smcf_0_if_smc_0\<close>)
      (cs_concl cs_shallow cs_intro: smc_cs_intros)+
  show "\<NN> = ntsmcf_0 \<CC>"
  proof(rule ntsmcf_tdghm_eqI)
    show "\<NN> : \<FF> \<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<GG> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>" by (rule assms(1))
    show "ntsmcf_0 \<CC> : \<FF> \<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<GG> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
      by (cs_concl cs_simp: \<FF>_def \<GG>_def cs_intro: smc_cs_intros)
  qed (simp_all add: \<FF>_def \<GG>_def is_tdghm_is_tdghm_0_if_dg_0)
qed

subsubsection\<open>Further properties\<close>

lemma ntsmcf_vcomp_ntsmcf_ntsmcf_0[smc_cs_simps]:
  assumes "\<NN> : \<FF> \<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<GG> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<NN> \<bullet>\<^sub>N\<^sub>T\<^sub>S\<^sub>M\<^sub>C\<^sub>F ntsmcf_0 \<CC> = ntsmcf_0 \<CC>"
proof-
  interpret \<NN>: is_ntsmcf \<alpha> smc_0 \<CC> \<FF> \<GG> \<NN> by (rule assms(1))
  show ?thesis
    unfolding is_ntsmcf_is_ntsmcf_0_if_smc_0[OF assms]
  proof(rule ntsmcf_eqI)
    show "ntsmcf_0 \<CC> \<bullet>\<^sub>N\<^sub>T\<^sub>S\<^sub>M\<^sub>C\<^sub>F ntsmcf_0 \<CC> :
      smcf_0 \<CC> \<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>F smcf_0 \<CC> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
      by (cs_concl cs_intro: smc_cs_intros)
    then have dom_lhs: "\<D>\<^sub>\<circ> ((ntsmcf_0 \<CC> \<bullet>\<^sub>N\<^sub>T\<^sub>S\<^sub>M\<^sub>C\<^sub>F ntsmcf_0 \<CC>)\<lparr>NTMap\<rparr>) = 0"
      by
        (
          cs_concl
            cs_simp: smc_cs_simps smc_0_components cs_intro: smc_cs_intros
        )
    show "ntsmcf_0 \<CC> : smcf_0 \<CC> \<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>F smcf_0 \<CC> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
      by (cs_concl cs_intro: smc_cs_intros)
    then have dom_rhs: "\<D>\<^sub>\<circ> (ntsmcf_0 \<CC>\<lparr>NTMap\<rparr>) = 0"
      by
        (
          cs_concl
            cs_simp: smc_cs_simps smc_0_components cs_intro: smc_cs_intros
        )
    show "(ntsmcf_0 \<CC> \<bullet>\<^sub>N\<^sub>T\<^sub>S\<^sub>M\<^sub>C\<^sub>F ntsmcf_0 \<CC>)\<lparr>NTMap\<rparr> = ntsmcf_0 \<CC>\<lparr>NTMap\<rparr>"
      by (rule vsv_eqI, unfold dom_lhs dom_rhs) (auto intro: smc_cs_intros)
  qed simp_all
qed

lemma ntsmcf_vcomp_ntsmcf_0_ntsmcf[smc_cs_simps]:
  assumes "\<NN> : \<FF> \<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<GG> : smc_0 \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "ntsmcf_0 \<CC> \<bullet>\<^sub>N\<^sub>T\<^sub>S\<^sub>M\<^sub>C\<^sub>F \<NN> = ntsmcf_0 \<CC>"
proof-
  interpret \<NN>: is_ntsmcf \<alpha> smc_0 \<CC> \<FF> \<GG> \<NN> by (rule assms(1))
  show ?thesis
    unfolding is_ntsmcf_is_ntsmcf_0_if_smc_0[OF assms]
    by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
qed

subsection\<open>\<open>10\<close>: semicategory with one object and no arrows\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition smc_10 :: "V \<Rightarrow> V"
  where "smc_10 \<aa> = [set {\<aa>}, 0, 0, 0, 0]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma smc_10_components:
  shows "smc_10 \<aa>\<lparr>Obj\<rparr> = set {\<aa>}"
    and "smc_10 \<aa>\<lparr>Arr\<rparr> = 0"
    and "smc_10 \<aa>\<lparr>Dom\<rparr> = 0"
    and "smc_10 \<aa>\<lparr>Cod\<rparr> = 0"
    and "smc_10 \<aa>\<lparr>Comp\<rparr> = 0"
  unfolding smc_10_def dg_field_simps by (auto simp: nat_omega_simps)

text\<open>Slicing.\<close>

lemma smc_dg_smc_10: "smc_dg (smc_10 \<aa>) = (dg_10 \<aa>)"
  unfolding smc_dg_def smc_10_def dg_10_def dg_field_simps
  by (simp add: nat_omega_simps)

lemmas_with (in \<Z>) [folded smc_dg_smc_10, unfolded slicing_simps]:
  smc_10_is_arr_iff = dg_10_is_arr_iff

subsubsection\<open>\<open>10\<close> is a semicategory\<close>

lemma (in \<Z>) semicategory_smc_10:
  assumes "\<aa> \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "semicategory \<alpha> (smc_10 \<aa>)"
proof(intro semicategoryI)
  show "vfsequence (smc_10 \<aa>)"
    unfolding smc_10_def by (simp add: nat_omega_simps)
  show "vcard (smc_10 \<aa>) = 5\<^sub>\<nat>"
    unfolding smc_10_def by (simp add: nat_omega_simps)
  show "digraph \<alpha> (smc_dg (smc_10 \<aa>))"
    unfolding smc_dg_smc_10 by (rule digraph_dg_10[OF assms])
qed (auto simp: smc_10_components smc_10_is_arr_iff vsubset_vsingleton_leftI)

subsubsection\<open>Arrow with a domain and a codomain\<close>

lemma smc_10_is_arr_iff: "\<FF> : \<AA> \<mapsto>\<^bsub>smc_10 \<aa>\<^esub> \<BB> \<longleftrightarrow> False"
  unfolding is_arr_def smc_10_components by simp

subsection\<open>\<open>1\<close>: semicategory with one object and one arrow\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition smc_1 :: "V \<Rightarrow> V \<Rightarrow> V"
  where "smc_1 \<aa> \<ff> =
    [set {\<aa>}, set {\<ff>}, set {\<langle>\<ff>, \<aa>\<rangle>}, set {\<langle>\<ff>, \<aa>\<rangle>}, set {\<langle>[\<ff>, \<ff>]\<^sub>\<circ>, \<ff>\<rangle>}]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma smc_1_components:
  shows "smc_1 \<aa> \<ff>\<lparr>Obj\<rparr> = set {\<aa>}"
    and "smc_1 \<aa> \<ff>\<lparr>Arr\<rparr> = set {\<ff>}"
    and "smc_1 \<aa> \<ff>\<lparr>Dom\<rparr> = set {\<langle>\<ff>, \<aa>\<rangle>}"
    and "smc_1 \<aa> \<ff>\<lparr>Cod\<rparr> = set {\<langle>\<ff>, \<aa>\<rangle>}"
    and "smc_1 \<aa> \<ff>\<lparr>Comp\<rparr> = set {\<langle>[\<ff>, \<ff>]\<^sub>\<circ>, \<ff>\<rangle>}"
  unfolding smc_1_def dg_field_simps by (simp_all add: nat_omega_simps)

text\<open>Slicing.\<close>

lemma dg_smc_1: "smc_dg (smc_1 \<aa> \<ff>) = dg_1 \<aa> \<ff>"
  unfolding smc_dg_def smc_1_def dg_1_def dg_field_simps
  by (simp add: nat_omega_simps)

lemmas_with [folded dg_smc_1, unfolded slicing_simps]:
  smc_1_is_arrI = dg_1_is_arrI
  and smc_1_is_arrD = dg_1_is_arrD
  and smc_1_is_arrE = dg_1_is_arrE
  and smc_1_is_arr_iff = dg_1_is_arr_iff

subsubsection\<open>Composition\<close>

lemma smc_1_Comp_app[simp]: "\<ff> \<circ>\<^sub>A\<^bsub>smc_1 \<aa> \<ff>\<^esub> \<ff> = \<ff>"
  unfolding smc_1_components by simp

subsubsection\<open>\<open>1\<close> is a semicategory\<close>

lemma (in \<Z>) semicategory_smc_1:
  assumes "\<aa> \<in>\<^sub>\<circ> Vset \<alpha>" and "\<ff> \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "semicategory \<alpha> (smc_1 \<aa> \<ff>)"
proof(intro semicategoryI, unfold dg_smc_1)
  show "vfsequence (smc_1 \<aa> \<ff>)"
    unfolding smc_1_def by (simp add: nat_omega_simps)
  show "vcard (smc_1 \<aa> \<ff>) = 5\<^sub>\<nat>"
    unfolding smc_1_def by (simp add: nat_omega_simps)
qed
  (
    auto simp:
      assms
      digraph_dg_1
      smc_1_is_arr_iff
      smc_1_components
      vsubset_vsingleton_leftI
  )

text\<open>\newpage\<close>

end


(* Title:      Relation Algebra
   Author:     Alasdair Armstrong, Simon Foster, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Tests\<close>

theory Relation_Algebra_Tests
  imports Relation_Algebra
begin

subsection \<open>Tests\<close>

text \<open>Tests or subidentities provide another way of modelling sets. Once more
we prove the basic properties, most of which stem from Maddux's book.\<close>

context relation_algebra
begin

definition is_test :: "'a \<Rightarrow> bool"
  where "is_test x \<equiv> x \<le> 1'"

lemma test_conv: "is_test x \<Longrightarrow> is_test (x\<^sup>\<smile>)"
by (metis conv_e conv_iso is_test_def)

lemma test_conv_var: "is_test x \<Longrightarrow> x\<^sup>\<smile> \<le> 1'"
by (metis test_conv is_test_def)

lemma test_eq_conv [simp]: "is_test x \<Longrightarrow> x\<^sup>\<smile> = x"
proof (rule antisym)
  assume hyp: "is_test x"
  hence "x \<le> x ; (1' \<cdot> x\<^sup>\<smile> ; 1')"
    by (metis inf.commute inf_absorb2 inf_le2 modular_1' mult.right_neutral is_test_def)
  thus "x \<le> x\<^sup>\<smile>"
    by (metis comp_unitr conv_contrav conv_invol eq_iff hyp inf_absorb2 mult_subdistl test_conv_var)
  thus "x\<^sup>\<smile> \<le> x"
    by (metis conv_invol conv_times le_iff_inf)
qed

lemma test_sum: "\<lbrakk>is_test x; is_test y\<rbrakk> \<Longrightarrow> is_test (x + y)"
by (simp add: is_test_def)

lemma test_prod: "\<lbrakk>is_test x; is_test y\<rbrakk> \<Longrightarrow> is_test (x \<cdot> y)"
by (metis le_infI2 is_test_def)

lemma test_comp: "\<lbrakk>is_test x; is_test y\<rbrakk> \<Longrightarrow> is_test (x ; y)"
by (metis mult_isol comp_unitr order_trans is_test_def)

lemma test_comp_eq_mult:
  assumes "is_test x"
    and "is_test y"
  shows "x ; y = x \<cdot> y"
proof (rule antisym)
  show "x ; y \<le> x \<cdot> y"
    by (metis assms comp_unitr inf_absorb2 le_inf_iff mult_onel mult_subdistl mult_subdistr is_test_def)
next
  have "x \<cdot> y \<le> x ; (1' \<cdot> x\<^sup>\<smile> ; y)"
    by (metis comp_unitr modular_1_var)
  thus "x \<cdot> y \<le> x ; y"
    by (metis assms(1) inf_absorb2 le_infI2 mult.left_neutral mult_isol mult_subdistr order_trans test_eq_conv is_test_def)
qed

lemma test_1 [simp]: "is_test x \<Longrightarrow> x ; 1 \<cdot> y = x ; y"
by (metis inf.commute inf.idem inf_absorb2 mult.left_neutral one_conv ra_1 test_comp_eq_mult test_eq_conv is_test_def)

lemma maddux_32 [simp]: "is_test x \<Longrightarrow> -(x ; 1) \<cdot> 1' = -x \<cdot> 1'"
proof (rule antisym)
  assume "is_test x"
  show "-(x ; 1) \<cdot> 1' \<le> -x \<cdot> 1'"
    by (metis maddux_20 comp_anti inf.commute meet_isor)
next
  assume "is_test x"
  have one: "x ; 1 \<cdot> (-x \<cdot> 1') \<le> x ; x\<^sup>\<smile> ; (-x \<cdot> 1')"
    by (metis maddux_16 inf_top_left mult.assoc)
  hence two: "x ; 1 \<cdot> (-x \<cdot> 1') \<le> -x"
    by (metis inf.commute inf_le1 le_infE)
  hence "x ; 1 \<cdot> (-x \<cdot> 1') \<le> x"
    by (metis one inf.commute le_infE meet_iso one_conv \<open>is_test x\<close> eq_iff test_1 test_eq_conv)
  hence "x ; 1 \<cdot> (-x \<cdot> 1') = 0"
    by (metis two galois_aux2 le_iff_inf)
  thus "-x \<cdot> 1' \<le> -(x ; 1) \<cdot> 1'"
    by (metis double_compl galois_aux2 inf.commute inf_le1 le_inf_iff)
qed

lemma test_distr_1 :
  assumes "is_test x"
    and "is_test y"
  shows "x ; z \<cdot> y ; z = (x \<cdot> y) ; z"
proof (rule antisym)
  have "x ; z \<cdot> y ; z \<le> x ; 1 \<cdot> y ; z"
    by (metis inf_top_left meet_iso mult_subdistl)
  also have "\<dots> = x ; y ; z"
    by (metis assms(1) mult.assoc test_1)
  finally show "x ; z \<cdot> y ; z \<le> (x \<cdot> y) ; z"
    by (metis assms test_comp_eq_mult)
next
  show "(x \<cdot> y) ; z \<le> x ; z \<cdot> y ; z"
    by (metis mult_subdistr_var)
qed

lemma maddux_35: "is_test x \<Longrightarrow> x ; y \<cdot> -z = x ; y \<cdot> -(x ; z)"
proof (rule antisym)
  assume "is_test x"
  show "x ; y \<cdot> -z \<le> x ; y \<cdot> -(x ; z)"
    by (metis \<open>is_test x\<close> comp_anti mult_isor mult_onel is_test_def inf.commute inf_le2 le_infI le_infI1)
  have one: "x ; y \<cdot> -(x ; z) \<le> x ; (y \<cdot> -z)"
    by (metis eq_iff le_infE maddux_23)
  hence two: "x ; y \<cdot> -(x ; z) \<le> x ; y"
    by (metis inf_le1)
  have "x ; y \<cdot> -(x ; z) \<le>  x ; -z"
    using one
    by (metis galois_1 le_iff_sup distrib_left sup_compl_top sup_top_right)
  hence "x ; y \<cdot> -(x ; z) \<le> -z"
    by (metis \<open>is_test x\<close> mult_isor mult_onel is_test_def order_trans)
  thus "x ; y \<cdot> -(x ; z) \<le> x ; y \<cdot> -z"
    using two
    by (metis le_inf_iff)
qed

subsection \<open>Test Complements\<close>

text \<open>Text complements are complements of elements that are ``pushed below''
the multiplicative unit.\<close>

definition tc :: "'a \<Rightarrow> 'a"
  where "tc x = 1' \<cdot> -x"

lemma test_compl_1 [simp]: "is_test x \<Longrightarrow> x + tc x = 1'"
  by (metis is_test_def local.aux4 local.inf.absorb_iff1 local.inf_commute tc_def)

lemma test_compl_2 [simp]: "is_test x \<Longrightarrow> x \<cdot> tc x = 0"
  by (metis galois_aux inf.commute inf_le2 tc_def)

lemma test_test_compl: "is_test x \<Longrightarrow> is_test (tc x)"
  by (simp add: is_test_def tc_def)

lemma test_compl_de_morgan_1: "tc (x + y) = tc x \<cdot> tc y"
  by (metis compl_sup inf.left_commute inf.left_idem meet_assoc tc_def)

lemma test_compl_de_morgan_2: "tc (x \<cdot> y) = tc x + tc y"
  by (metis compl_inf inf_sup_distrib1 tc_def)

lemma test_compl_three [simp]: "tc (tc (tc x)) = tc x"
  by (metis aux4 aux6 de_morgan_3 inf.commute inf_sup_absorb tc_def)

lemma test_compl_double [simp]: "is_test x \<Longrightarrow> tc (tc x) = x"
  by (metis aux6_var compl_inf double_compl inf.commute le_iff_inf tc_def is_test_def)

end (* relation_algebra *)

end


(*  Title:      HOL/Proofs/Lambda/Lambda.thy
    Author:     Tobias Nipkow
    Copyright   1995 TU Muenchen
*)

section \<open>Basic definitions of Lambda-calculus\<close>

theory Lambda
imports Main
begin

declare [[syntax_ambiguity_warning = false]]

subsection \<open>Lambda-terms in de Bruijn notation and substitution\<close>

datatype dB =
    Var nat
  | App dB dB (infixl "\<degree>" 200)
  | Abs dB

primrec
  lift :: "[dB, nat] => dB"
where
    "lift (Var i) k = (if i < k then Var i else Var (i + 1))"
  | "lift (s \<degree> t) k = lift s k \<degree> lift t k"
  | "lift (Abs s) k = Abs (lift s (k + 1))"

primrec
  subst :: "[dB, dB, nat] => dB"  ("_[_'/_]" [300, 0, 0] 300)
where (* FIXME base names *)
    subst_Var: "(Var i)[s/k] =
      (if k < i then Var (i - 1) else if i = k then s else Var i)"
  | subst_App: "(t \<degree> u)[s/k] = t[s/k] \<degree> u[s/k]"
  | subst_Abs: "(Abs t)[s/k] = Abs (t[lift s 0 / k+1])"

declare subst_Var [simp del]

text \<open>Optimized versions of \<^term>\<open>subst\<close> and \<^term>\<open>lift\<close>.\<close>

primrec
  liftn :: "[nat, dB, nat] => dB"
where
    "liftn n (Var i) k = (if i < k then Var i else Var (i + n))"
  | "liftn n (s \<degree> t) k = liftn n s k \<degree> liftn n t k"
  | "liftn n (Abs s) k = Abs (liftn n s (k + 1))"

primrec
  substn :: "[dB, dB, nat] => dB"
where
    "substn (Var i) s k =
      (if k < i then Var (i - 1) else if i = k then liftn k s 0 else Var i)"
  | "substn (t \<degree> u) s k = substn t s k \<degree> substn u s k"
  | "substn (Abs t) s k = Abs (substn t s (k + 1))"

subsection \<open>Beta-reduction\<close>

inductive beta :: "[dB, dB] => bool"  (infixl "\<rightarrow>\<^sub>\<beta>" 50)
  where
    beta [simp, intro!]: "Abs s \<degree> t \<rightarrow>\<^sub>\<beta> s[t/0]"
  | appL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> s \<degree> u \<rightarrow>\<^sub>\<beta> t \<degree> u"
  | appR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> u \<degree> s \<rightarrow>\<^sub>\<beta> u \<degree> t"
  | abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> Abs s \<rightarrow>\<^sub>\<beta> Abs t"

abbreviation
  beta_reds :: "[dB, dB] => bool"  (infixl "\<rightarrow>\<^sub>\<beta>\<^sup>*" 50) where
  "s \<rightarrow>\<^sub>\<beta>\<^sup>* t == beta\<^sup>*\<^sup>* s t"

inductive_cases beta_cases [elim!]:
  "Var i \<rightarrow>\<^sub>\<beta> t"
  "Abs r \<rightarrow>\<^sub>\<beta> s"
  "s \<degree> t \<rightarrow>\<^sub>\<beta> u"

declare if_not_P [simp] not_less_eq [simp]
  \<comment> \<open>don't add \<open>r_into_rtrancl[intro!]\<close>\<close>

subsection \<open>Congruence rules\<close>

lemma rtrancl_beta_Abs [intro!]:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' ==> Abs s \<rightarrow>\<^sub>\<beta>\<^sup>* Abs s'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppL:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' ==> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppR:
    "t \<rightarrow>\<^sub>\<beta>\<^sup>* t' ==> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s \<degree> t'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_App [intro]:
    "[| s \<rightarrow>\<^sub>\<beta>\<^sup>* s'; t \<rightarrow>\<^sub>\<beta>\<^sup>* t' |] ==> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t'"
  by (blast intro!: rtrancl_beta_AppL rtrancl_beta_AppR intro: rtranclp_trans)

subsection \<open>Substitution-lemmas\<close>

lemma subst_eq [simp]: "(Var k)[u/k] = u"
  by (simp add: subst_Var)

lemma subst_gt [simp]: "i < j ==> (Var j)[u/i] = Var (j - 1)"
  by (simp add: subst_Var)

lemma subst_lt [simp]: "j < i ==> (Var j)[u/i] = Var j"
  by (simp add: subst_Var)

lemma lift_lift:
    "i < k + 1 \<Longrightarrow> lift (lift t i) (Suc k) = lift (lift t k) i"
  by (induct t arbitrary: i k) auto

lemma lift_subst [simp]:
    "j < i + 1 \<Longrightarrow> lift (t[s/j]) i = (lift t (i + 1)) [lift s i / j]"
  by (induct t arbitrary: i j s)
    (simp_all add: diff_Suc subst_Var lift_lift split: nat.split)

lemma lift_subst_lt:
    "i < j + 1 \<Longrightarrow> lift (t[s/j]) i = (lift t i) [lift s i / j + 1]"
  by (induct t arbitrary: i j s) (simp_all add: subst_Var lift_lift)

lemma subst_lift [simp]:
    "(lift t k)[s/k] = t"
  by (induct t arbitrary: k s) simp_all

lemma subst_subst:
    "i < j + 1 \<Longrightarrow> t[lift v i / Suc j][u[v/j]/i] = t[u/i][v/j]"
  by (induct t arbitrary: i j u v)
    (simp_all add: diff_Suc subst_Var lift_lift [symmetric] lift_subst_lt
      split: nat.split)

subsection \<open>Equivalence proof for optimized substitution\<close>

lemma liftn_0 [simp]: "liftn 0 t k = t"
  by (induct t arbitrary: k) (simp_all add: subst_Var)

lemma liftn_lift [simp]: "liftn (Suc n) t k = lift (liftn n t k) k"
  by (induct t arbitrary: k) (simp_all add: subst_Var)

lemma substn_subst_n [simp]: "substn t s n = t[liftn n s 0 / n]"
  by (induct t arbitrary: n) (simp_all add: subst_Var)

theorem substn_subst_0: "substn t s 0 = t[s/0]"
  by simp

subsection \<open>Preservation theorems\<close>

text \<open>Not used in Church-Rosser proof, but in Strong
  Normalization. \medskip\<close>

theorem subst_preserves_beta [simp]:
    "r \<rightarrow>\<^sub>\<beta> s ==> r[t/i] \<rightarrow>\<^sub>\<beta> s[t/i]"
  by (induct arbitrary: t i set: beta) (simp_all add: subst_subst [symmetric])

theorem subst_preserves_beta': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s ==> r[t/i] \<rightarrow>\<^sub>\<beta>\<^sup>* s[t/i]"
  apply (induct set: rtranclp)
   apply (rule rtranclp.rtrancl_refl)
  apply (erule rtranclp.rtrancl_into_rtrancl)
  apply (erule subst_preserves_beta)
  done

theorem lift_preserves_beta [simp]:
    "r \<rightarrow>\<^sub>\<beta> s ==> lift r i \<rightarrow>\<^sub>\<beta> lift s i"
  by (induct arbitrary: i set: beta) auto

theorem lift_preserves_beta': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s ==> lift r i \<rightarrow>\<^sub>\<beta>\<^sup>* lift s i"
  apply (induct set: rtranclp)
   apply (rule rtranclp.rtrancl_refl)
  apply (erule rtranclp.rtrancl_into_rtrancl)
  apply (erule lift_preserves_beta)
  done

theorem subst_preserves_beta2 [simp]: "r \<rightarrow>\<^sub>\<beta> s ==> t[r/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t[s/i]"
  apply (induct t arbitrary: r s i)
    apply (simp add: subst_Var r_into_rtranclp)
   apply (simp add: rtrancl_beta_App)
  apply (simp add: rtrancl_beta_Abs)
  done

theorem subst_preserves_beta2': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s ==> t[r/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t[s/i]"
  apply (induct set: rtranclp)
   apply (rule rtranclp.rtrancl_refl)
  apply (erule rtranclp_trans)
  apply (erule subst_preserves_beta2)
  done

end