(*  Title:      HOL/Nonstandard_Analysis/NatStar.thy
    Author:     Jacques D. Fleuriot
    Copyright:  1998  University of Cambridge

Converted to Isar and polished by lcp
*)

section \<open>Star-transforms for the Hypernaturals\<close>

theory NatStar
  imports Star
begin

lemma star_n_eq_starfun_whn: "star_n X = ( *f* X) whn"
  by (simp add: hypnat_omega_def starfun_def star_of_def Ifun_star_n)

lemma starset_n_Un: "*sn* (\<lambda>n. (A n) \<union> (B n)) = *sn* A \<union> *sn* B"
proof -
  have "\<And>N. Iset ((*f* (\<lambda>n. {x. x \<in> A n \<or> x \<in> B n})) N) =
    {x. x \<in> Iset ((*f* A) N) \<or> x \<in> Iset ((*f* B) N)}"
    by transfer simp
  then show ?thesis
    by (simp add: starset_n_def star_n_eq_starfun_whn Un_def)
qed

lemma InternalSets_Un: "X \<in> InternalSets \<Longrightarrow> Y \<in> InternalSets \<Longrightarrow> X \<union> Y \<in> InternalSets"
  by (auto simp add: InternalSets_def starset_n_Un [symmetric])

lemma starset_n_Int: "*sn* (\<lambda>n. A n \<inter> B n) = *sn* A \<inter> *sn* B"
proof -
  have "\<And>N. Iset ((*f* (\<lambda>n. {x. x \<in> A n \<and> x \<in> B n})) N) =
    {x. x \<in> Iset ((*f* A) N) \<and> x \<in> Iset ((*f* B) N)}"
    by transfer simp
  then show ?thesis
    by (simp add: starset_n_def star_n_eq_starfun_whn Int_def)
qed

lemma InternalSets_Int: "X \<in> InternalSets \<Longrightarrow> Y \<in> InternalSets \<Longrightarrow> X \<inter> Y \<in> InternalSets"
  by (auto simp add: InternalSets_def starset_n_Int [symmetric])

lemma starset_n_Compl: "*sn* ((\<lambda>n. - A n)) = - ( *sn* A)"
proof -
  have "\<And>N. Iset ((*f* (\<lambda>n. {x. x \<notin> A n})) N) =
    {x. x \<notin> Iset ((*f* A) N)}"
    by transfer simp
  then show ?thesis
    by (simp add: starset_n_def star_n_eq_starfun_whn Compl_eq)
qed

lemma InternalSets_Compl: "X \<in> InternalSets \<Longrightarrow> - X \<in> InternalSets"
  by (auto simp add: InternalSets_def starset_n_Compl [symmetric])

lemma starset_n_diff: "*sn* (\<lambda>n. (A n) - (B n)) = *sn* A - *sn* B"
proof -
  have "\<And>N. Iset ((*f* (\<lambda>n. {x. x \<in> A n \<and> x \<notin> B n})) N) =
    {x. x \<in> Iset ((*f* A) N) \<and> x \<notin> Iset ((*f* B) N)}"
    by transfer simp
  then show ?thesis
    by (simp add: starset_n_def star_n_eq_starfun_whn set_diff_eq)
qed

lemma InternalSets_diff: "X \<in> InternalSets \<Longrightarrow> Y \<in> InternalSets \<Longrightarrow> X - Y \<in> InternalSets"
  by (auto simp add: InternalSets_def starset_n_diff [symmetric])

lemma NatStar_SHNat_subset: "Nats \<le> *s* (UNIV:: nat set)"
  by simp

lemma NatStar_hypreal_of_real_Int: "*s* X Int Nats = hypnat_of_nat ` X"
  by (auto simp add: SHNat_eq)

lemma starset_starset_n_eq: "*s* X = *sn* (\<lambda>n. X)"
  by (simp add: starset_n_starset)

lemma InternalSets_starset_n [simp]: "( *s* X) \<in> InternalSets"
  by (auto simp add: InternalSets_def starset_starset_n_eq)

lemma InternalSets_UNIV_diff: "X \<in> InternalSets \<Longrightarrow> UNIV - X \<in> InternalSets"
  by (simp add: InternalSets_Compl diff_eq)

subsection \<open>Nonstandard Extensions of Functions\<close>

text \<open>Example of transfer of a property from reals to hyperreals
  --- used for limit comparison of sequences.\<close>

lemma starfun_le_mono: "\<forall>n. N \<le> n \<longrightarrow> f n \<le> g n \<Longrightarrow>
  \<forall>n. hypnat_of_nat N \<le> n \<longrightarrow> ( *f* f) n \<le> ( *f* g) n"
  by transfer

text \<open>And another:\<close>
lemma starfun_less_mono:
  "\<forall>n. N \<le> n \<longrightarrow> f n < g n \<Longrightarrow> \<forall>n. hypnat_of_nat N \<le> n \<longrightarrow> ( *f* f) n < ( *f* g) n"
  by transfer

text \<open>Nonstandard extension when we increment the argument by one.\<close>

lemma starfun_shift_one: "\<And>N. ( *f* (\<lambda>n. f (Suc n))) N = ( *f* f) (N + (1::hypnat))"
  by transfer simp

text \<open>Nonstandard extension with absolute value.\<close>
lemma starfun_abs: "\<And>N. ( *f* (\<lambda>n. \<bar>f n\<bar>)) N = \<bar>( *f* f) N\<bar>"
  by transfer (rule refl)

text \<open>The \<open>hyperpow\<close> function as a nonstandard extension of \<open>realpow\<close>.\<close>
lemma starfun_pow: "\<And>N. ( *f* (\<lambda>n. r ^ n)) N = hypreal_of_real r pow N"
  by transfer (rule refl)

lemma starfun_pow2: "\<And>N. ( *f* (\<lambda>n. X n ^ m)) N = ( *f* X) N pow hypnat_of_nat m"
  by transfer (rule refl)

lemma starfun_pow3: "\<And>R. ( *f* (\<lambda>r. r ^ n)) R = R pow hypnat_of_nat n"
  by transfer (rule refl)

text \<open>The \<^term>\<open>hypreal_of_hypnat\<close> function as a nonstandard extension of
  \<^term>\<open>real_of_nat\<close>.\<close>
lemma starfunNat_real_of_nat: "( *f* real) = hypreal_of_hypnat"
  by transfer (simp add: fun_eq_iff)

lemma starfun_inverse_real_of_nat_eq:
  "N \<in> HNatInfinite \<Longrightarrow> ( *f* (\<lambda>x::nat. inverse (real x))) N = inverse (hypreal_of_hypnat N)"
  by (metis of_hypnat_def starfun_inverse2)

text \<open>Internal functions -- some redundancy with \<open>*f*\<close> now.\<close>

lemma starfun_n: "( *fn* f) (star_n X) = star_n (\<lambda>n. f n (X n))"
  by (simp add: starfun_n_def Ifun_star_n)

text \<open>Multiplication: \<open>( *fn) x ( *gn) = *(fn x gn)\<close>\<close>

lemma starfun_n_mult: "( *fn* f) z * ( *fn* g) z = ( *fn* (\<lambda>i x. f i x * g i x)) z"
  by (cases z) (simp add: starfun_n star_n_mult)

text \<open>Addition: \<open>( *fn) + ( *gn) = *(fn + gn)\<close>\<close>
lemma starfun_n_add: "( *fn* f) z + ( *fn* g) z = ( *fn* (\<lambda>i x. f i x + g i x)) z"
  by (cases z) (simp add: starfun_n star_n_add)

text \<open>Subtraction: \<open>( *fn) - ( *gn) = *(fn + - gn)\<close>\<close>
lemma starfun_n_add_minus: "( *fn* f) z + -( *fn* g) z = ( *fn* (\<lambda>i x. f i x + -g i x)) z"
  by (cases z) (simp add: starfun_n star_n_minus star_n_add)

text \<open>Composition: \<open>( *fn) \<circ> ( *gn) = *(fn \<circ> gn)\<close>\<close>

lemma starfun_n_const_fun [simp]: "( *fn* (\<lambda>i x. k)) z = star_of k"
  by (cases z) (simp add: starfun_n star_of_def)

lemma starfun_n_minus: "- ( *fn* f) x = ( *fn* (\<lambda>i x. - (f i) x)) x"
  by (cases x) (simp add: starfun_n star_n_minus)

lemma starfun_n_eq [simp]: "( *fn* f) (star_of n) = star_n (\<lambda>i. f i n)"
  by (simp add: starfun_n star_of_def)

lemma starfun_eq_iff: "(( *f* f) = ( *f* g)) \<longleftrightarrow> f = g"
  by transfer (rule refl)

lemma starfunNat_inverse_real_of_nat_Infinitesimal [simp]:
  "N \<in> HNatInfinite \<Longrightarrow> ( *f* (\<lambda>x. inverse (real x))) N \<in> Infinitesimal"
  using starfun_inverse_real_of_nat_eq by auto

subsection \<open>Nonstandard Characterization of Induction\<close>

lemma hypnat_induct_obj:
  "\<And>n. (( *p* P) (0::hypnat) \<and> (\<forall>n. ( *p* P) n \<longrightarrow> ( *p* P) (n + 1))) \<longrightarrow> ( *p* P) n"
  by transfer (induct_tac n, auto)

lemma hypnat_induct:
  "\<And>n. ( *p* P) (0::hypnat) \<Longrightarrow> (\<And>n. ( *p* P) n \<Longrightarrow> ( *p* P) (n + 1)) \<Longrightarrow> ( *p* P) n"
  by transfer (induct_tac n, auto)

lemma starP2_eq_iff: "( *p2* (=)) = (=)"
  by transfer (rule refl)

lemma starP2_eq_iff2: "( *p2* (\<lambda>x y. x = y)) X Y \<longleftrightarrow> X = Y"
  by (simp add: starP2_eq_iff)

lemma nonempty_set_star_has_least_lemma:
  "\<exists>n\<in>S. \<forall>m\<in>S. n \<le> m" if "S \<noteq> {}" for S :: "nat set"
proof
  show "\<forall>m\<in>S. (LEAST n. n \<in> S) \<le> m"
    by (simp add: Least_le)
  show "(LEAST n. n \<in> S) \<in> S"
    by (meson that LeastI_ex equals0I)
qed

lemma nonempty_set_star_has_least:
  "\<And>S::nat set star. Iset S \<noteq> {} \<Longrightarrow> \<exists>n \<in> Iset S. \<forall>m \<in> Iset S. n \<le> m"
  using nonempty_set_star_has_least_lemma by (transfer empty_def)

lemma nonempty_InternalNatSet_has_least: "S \<in> InternalSets \<Longrightarrow> S \<noteq> {} \<Longrightarrow> \<exists>n \<in> S. \<forall>m \<in> S. n \<le> m"
  for S :: "hypnat set"
  by (force simp add: InternalSets_def starset_n_def dest!: nonempty_set_star_has_least)

text \<open>Goldblatt, page 129 Thm 11.3.2.\<close>
lemma internal_induct_lemma:
  "\<And>X::nat set star.
    (0::hypnat) \<in> Iset X \<Longrightarrow> \<forall>n. n \<in> Iset X \<longrightarrow> n + 1 \<in> Iset X \<Longrightarrow> Iset X = (UNIV:: hypnat set)"
  apply (transfer UNIV_def)
  apply (rule equalityI [OF subset_UNIV subsetI])
  apply (induct_tac x, auto)
  done

lemma internal_induct:
  "X \<in> InternalSets \<Longrightarrow> (0::hypnat) \<in> X \<Longrightarrow> \<forall>n. n \<in> X \<longrightarrow> n + 1 \<in> X \<Longrightarrow> X = (UNIV:: hypnat set)"
  apply (clarsimp simp add: InternalSets_def starset_n_def)
  apply (erule (1) internal_induct_lemma)
  done

end


(* Title:      Decreasing Diagrams II
   Author:     Bertram Felgenhauer (2015)
   Maintainer: Bertram Felgenhauer <bertram.felgenhauer@uibk.ac.at>
   License:    LGPL or BSD

License clarification: This file is also licensed under the BSD license to facilitate reuse
and moving snippets from here to more suitable places.
*)

section \<open>Preliminaries\<close>

theory Decreasing_Diagrams_II_Aux
imports
  Well_Quasi_Orders.Multiset_Extension
  Well_Quasi_Orders.Well_Quasi_Orders
begin

subsection \<open>Trivialities\<close>

(* move to Relation.thy? *)
lemma asymI2: "(\<And>a b. (a,b) \<in> R \<Longrightarrow> (b,a) \<notin> R) \<Longrightarrow> asym R"
by (metis asymI irrefl_def)

(* move to Relation.thy? *)
abbreviation "strict_order R \<equiv> irrefl R \<and> trans R"

(* move to Relation.thy? *)
lemma order_asym: "trans R \<Longrightarrow> asym R = irrefl R"
unfolding asym.simps irrefl_def trans_def by meson

(* move to Relation.thy? *)
lemma strict_order_strict: "strict_order q \<Longrightarrow> strict (\<lambda>a b. (a, b) \<in> q\<^sup>=) = (\<lambda>a b. (a, b) \<in> q)"
unfolding trans_def irrefl_def by fast

(* move to Wellfounded.thy? *)
lemma mono_lex1: "mono (\<lambda>r. lex_prod r s)"
by (auto simp add: mono_def)

(* move to Wellfounded.thy? *)
lemma mono_lex2: "mono (lex_prod r)"
by (auto simp add: mono_def)

(* move to Wellfounded.thy? *)
lemma irrefl_lex_prod: "irrefl R \<Longrightarrow> irrefl S \<Longrightarrow> irrefl (R <*lex*> S)"
by (auto simp add: lex_prod_def irrefl_def)

lemmas converse_inward = rtrancl_converse[symmetric] converse_Un converse_UNION converse_relcomp
  converse_converse converse_Id

subsection \<open>Complete lattices and least fixed points\<close>

context complete_lattice
begin

subsubsection \<open>A chain-based induction principle\<close>

abbreviation set_chain :: "'a set \<Rightarrow> bool" where
  "set_chain C \<equiv> \<forall>x \<in> C. \<forall>y \<in> C. x \<le> y \<or> y \<le> x"

lemma lfp_chain_induct:
  assumes mono: "mono f"
  and step: "\<And>x. P x \<Longrightarrow> P (f x)"
  and chain: "\<And>C. set_chain C \<Longrightarrow> \<forall> x \<in> C. P x \<Longrightarrow> P (Sup C)"
  shows "P (lfp f)"
unfolding lfp_eq_fixp[OF mono]
proof (rule fixp_induct)
  show "monotone (\<le>) (\<le>) f" using mono unfolding order_class.mono_def monotone_def .
next
  show "P (Sup {})" using chain[of "{}"] by simp
next
  show "ccpo.admissible Sup (\<le>) P"
  by (auto simp add: chain ccpo.admissible_def Complete_Partial_Order.chain_def)
qed fact

subsubsection \<open>Preservation of transitivity, asymmetry, irreflexivity by suprema\<close>

lemma trans_Sup_of_chain:
  assumes "set_chain C" and trans: "\<And>R. R \<in> C \<Longrightarrow> trans R"
  shows "trans (Sup C)"
proof (intro transI)
  fix x y z
  assume "(x,y) \<in> Sup C" and "(y,z) \<in> Sup C"
  from \<open>(x,y) \<in> Sup C\<close> obtain R where "R \<in> C" and "(x,y) \<in> R" by blast
  from \<open>(y,z) \<in> Sup C\<close> obtain S where "S \<in> C" and "(y,z) \<in> S" by blast
  from \<open>R \<in> C\<close> and \<open>S \<in> C\<close> and \<open>set_chain C\<close> have "R \<union> S = R \<or> R \<union> S = S" by blast
  with \<open>R \<in> C\<close> and \<open>S \<in> C\<close> have "R \<union> S \<in> C" by fastforce
  with \<open>(x,y) \<in> R\<close> and \<open>(y,z) \<in> S\<close> and trans[of "R \<union> S"]
  have "(x,z) \<in> R \<union> S" unfolding trans_def by blast
  with \<open>R \<union> S \<in> C\<close> show "(x,z) \<in> \<Union>C" by blast
qed

lemma asym_Sup_of_chain:
  assumes "set_chain C" and asym: "\<And> R. R \<in> C \<Longrightarrow> asym R"
  shows "asym (Sup C)"
proof (intro asymI2 notI)
  fix a b
  assume "(a,b) \<in> Sup C" then obtain "R" where "R \<in> C" and "(a,b) \<in> R" by blast
  assume "(b,a) \<in> Sup C" then obtain "S" where "S \<in> C" and "(b,a) \<in> S" by blast
  from \<open>R \<in> C\<close> and \<open>S \<in> C\<close> and \<open>set_chain C\<close> have "R \<union> S = R \<or> R \<union> S = S" by blast
  with \<open>R \<in> C\<close> and \<open>S \<in> C\<close> have "R \<union> S \<in> C" by fastforce
  with \<open>(a,b) \<in> R\<close> and \<open>(b,a) \<in> S\<close> and asym show "False" unfolding asym.simps by blast
qed

lemma strict_order_lfp:
  assumes "mono f" and "\<And>R. strict_order R \<Longrightarrow> strict_order (f R)"
  shows "strict_order (lfp f)"
proof (intro lfp_chain_induct[of f strict_order])
  fix C :: "('b \<times> 'b) set set"
  assume "set_chain C" and "\<forall>R \<in> C. strict_order R"
  from this show "strict_order (Sup C)" by (metis asym_Sup_of_chain trans_Sup_of_chain order_asym)
qed fact+

lemma trans_lfp:
  assumes "mono f" and "\<And>R. trans R \<Longrightarrow> trans (f R)"
  shows "trans (lfp f)"
by (metis lfp_chain_induct[of f trans] assms trans_Sup_of_chain)

end (* complete_lattice *)

subsection \<open>Multiset extension\<close>

lemma mulex_iff_mult: "mulex r M N \<longleftrightarrow> (M,N) \<in> mult {(M,N) . r M N}"
by (auto simp add: mulex_on_def restrict_to_def mult_def mulex1_def tranclp_unfold)

lemma multI:
  assumes "trans r" "M = I + K" "N = I + J" "J \<noteq> {#}" "\<forall>k \<in> set_mset K. \<exists>j \<in> set_mset J. (k,j) \<in> r"
  shows "(M,N) \<in> mult r"
using assms one_step_implies_mult by blast

lemma multE:
  assumes "trans r" and "(M,N) \<in> mult r"
  obtains I J K where "M = I + K" "N = I + J" "J \<noteq> {#}" "\<forall>k \<in> set_mset K. \<exists>j \<in> set_mset J. (k,j) \<in> r"
using mult_implies_one_step[OF assms] by blast

lemma mult_on_union: "(M,N) \<in> mult r \<Longrightarrow> (K + M, K + N) \<in> mult r"
using mulex_on_union[of "\<lambda>x y. (x,y) \<in> r" UNIV] by (auto simp: mulex_iff_mult)

lemma mult_on_union': "(M,N) \<in> mult r \<Longrightarrow> (M + K, N + K) \<in> mult r"
using mulex_on_union'[of "\<lambda>x y. (x,y) \<in> r" UNIV] by (auto simp: mulex_iff_mult)

lemma mult_on_add_mset: "(M,N) \<in> mult r \<Longrightarrow> (add_mset k M, add_mset k N) \<in> mult r"
unfolding add_mset_add_single[of k M] add_mset_add_single[of k N] by (rule mult_on_union')

lemma mult_empty[simp]: "(M,{#}) \<notin> mult R"
by (metis mult_def not_less_empty trancl.cases)

lemma mult_singleton[simp]: "(x, y) \<in> r \<Longrightarrow> (add_mset x M, add_mset y M) \<in> mult r"
unfolding add_mset_add_single[of x M] add_mset_add_single[of y M]
apply (rule mult_on_union)
using mult1_singleton[of x y r] by (auto simp add: mult_def mult_on_union)

lemma empty_mult[simp]: "({#},N) \<in> mult R \<longleftrightarrow> N \<noteq> {#}"
using empty_mulex_on[of N UNIV "\<lambda>M N. (M,N) \<in> R"] by (auto simp add: mulex_iff_mult)

lemma trans_mult: "trans (mult R)"
unfolding mult_def by simp

lemma strict_order_mult:
  assumes "irrefl R" and "trans R"
  shows "irrefl (mult R)" and "trans (mult R)"
proof -
  show "irrefl (mult R)" unfolding irrefl_def
  proof (intro allI notI, elim multE[OF \<open>trans R\<close>])
    fix M I J K
    assume "M = I + J" "M = I + K" "J \<noteq> {#}" and *: "\<forall>k \<in> set_mset K. \<exists>j \<in> set_mset J. (k, j) \<in> R"
    from \<open>M = I + J\<close> and \<open>M = I + K\<close> have "J = K" by simp
    have "finite (set_mset J)" by simp
    then have "set_mset J = {}" using * unfolding \<open>J = K\<close>
      by (induct rule: finite_induct)
         (simp, metis assms insert_absorb insert_iff insert_not_empty irrefl_def transD)
    then show "False" using \<open>J \<noteq> {#}\<close> by simp
  qed
qed (simp add: trans_mult)

lemma mult_of_image_mset:
  assumes "trans R" and "trans R'"
  and "\<And>x y. x \<in> set_mset N \<Longrightarrow> y \<in> set_mset M \<Longrightarrow> (x,y) \<in> R \<Longrightarrow> (f x, f y) \<in> R'"
  and "(N, M) \<in> mult R"
  shows "(image_mset f N, image_mset f M) \<in> mult R'"
proof (insert assms(4), elim multE[OF assms(1)])
  fix I J K
  assume "N = I + K" "M = I + J" "J \<noteq> {#}" "\<forall>k \<in> set_mset K. \<exists>j \<in> set_mset J. (k, j) \<in> R"
  thus "(image_mset f N, image_mset f M) \<in> mult R'" using assms(2,3)
    by (intro multI) (auto, blast)
qed

subsection \<open>Incrementality of @{term mult1} and @{term mult}\<close>

lemma mono_mult1: "mono mult1"
unfolding mono_def mult1_def by blast

lemma mono_mult: "mono mult"
unfolding mono_def mult_def
proof (intro allI impI subsetI)
  fix R S :: "'a rel" and x
  assume "R \<subseteq> S" and "x \<in> (mult1 R)\<^sup>+"
  then show "x \<in> (mult1 S)\<^sup>+"
  using mono_mult1[unfolded mono_def] trancl_mono[of x "mult1 R" "mult1 S"] by auto
qed

subsection \<open>Well-orders and well-quasi-orders\<close>

lemma wf_iff_wfp_on:
  "wf p \<longleftrightarrow> wfp_on (\<lambda>a b. (a, b) \<in> p) UNIV"
unfolding wfp_on_iff_inductive_on wf_def inductive_on_def by force

lemma well_order_implies_wqo:
  assumes "well_order r"
  shows "wqo_on (\<lambda>a b. (a, b) \<in> r) UNIV"
proof (intro wqo_onI almost_full_onI)
  show "transp_on (\<lambda>a b. (a, b) \<in> r) UNIV" using assms
  by (auto simp only: well_order_on_def linear_order_on_def partial_order_on_def preorder_on_def
    trans_def transp_on_def)
next
  fix f :: "nat \<Rightarrow> 'a"
  show "good (\<lambda>a b. (a, b) \<in> r) f"
  using assms unfolding well_order_on_def wf_iff_wfp_on wfp_on_def not_ex not_all de_Morgan_conj
  proof (elim conjE allE exE)
    fix x assume "linear_order r" and "f x \<notin> UNIV \<or> (f (Suc x), f x) \<notin> r - Id"
    then have "(f x, f (Suc x)) \<in> r" using \<open>linear_order r\<close>
    by (force simp: linear_order_on_def Relation.total_on_def partial_order_on_def preorder_on_def
      refl_on_def)
    then show "good (\<lambda>a b. (a, b) \<in> r) f" by (auto simp: good_def)
  qed
qed

subsection \<open>Splitting lists into prefix, element, and suffix\<close>

fun list_splits :: "'a list \<Rightarrow> ('a list \<times> 'a \<times> 'a list) list" where
  "list_splits [] = []"
| "list_splits (x # xs) = ([], x, xs) # map (\<lambda>(xs, x', xs'). (x # xs, x', xs')) (list_splits xs)"

lemma list_splits_empty[simp]:
  "list_splits xs = [] \<longleftrightarrow> xs = []"
by (cases xs) simp_all

lemma elem_list_splits_append:
  assumes "(ys, y, zs) \<in> set (list_splits xs)"
  shows "ys @ [y] @ zs = xs"
using assms by (induct xs arbitrary: ys) auto

lemma elem_list_splits_length:
  assumes "(ys, y, zs) \<in> set (list_splits xs)"
  shows "length ys < length xs" and "length zs < length xs"
using elem_list_splits_append[OF assms] by auto

lemma elem_list_splits_elem:
  assumes "(xs, y, ys) \<in> set (list_splits zs)"
  shows "y \<in> set zs"
using elem_list_splits_append[OF assms] by force

lemma list_splits_append:
  "list_splits (xs @ ys) = map (\<lambda>(xs', x', ys'). (xs', x', ys' @ ys)) (list_splits xs) @
                           map (\<lambda>(xs', x', ys'). (xs @ xs', x', ys')) (list_splits ys)"
by (induct xs) auto

lemma list_splits_rev:
  "list_splits (rev xs) = map (\<lambda>(xs, x, ys). (rev ys, x, rev xs)) (rev (list_splits xs))"
by (induct xs) (auto simp add: list_splits_append comp_def prod.case_distrib rev_map)

end (* Decreasing_Diagrams_II_Aux *)


(*  Title:      HOL/ex/Tarski.thy
    Author:     Florian Kammüller, Cambridge University Computer Laboratory
*)

section \<open>The Full Theorem of Tarski\<close>

theory Tarski
imports Main "~~/src/HOL/Library/FuncSet"
begin

text \<open>
  Minimal version of lattice theory plus the full theorem of Tarski:
  The fixedpoints of a complete lattice themselves form a complete
  lattice.

  Illustrates first-class theories, using the Sigma representation of
  structures.  Tidied and converted to Isar by lcp.
\<close>

record 'a potype =
  pset  :: "'a set"
  order :: "('a * 'a) set"

definition
  monotone :: "['a => 'a, 'a set, ('a *'a)set] => bool" where
  "monotone f A r = (\<forall>x\<in>A. \<forall>y\<in>A. (x, y): r --> ((f x), (f y)) : r)"

definition
  least :: "['a => bool, 'a potype] => 'a" where
  "least P po = (SOME x. x: pset po & P x &
                       (\<forall>y \<in> pset po. P y --> (x,y): order po))"

definition
  greatest :: "['a => bool, 'a potype] => 'a" where
  "greatest P po = (SOME x. x: pset po & P x &
                          (\<forall>y \<in> pset po. P y --> (y,x): order po))"

definition
  lub  :: "['a set, 'a potype] => 'a" where
  "lub S po = least (%x. \<forall>y\<in>S. (y,x): order po) po"

definition
  glb  :: "['a set, 'a potype] => 'a" where
  "glb S po = greatest (%x. \<forall>y\<in>S. (x,y): order po) po"

definition
  isLub :: "['a set, 'a potype, 'a] => bool" where
  "isLub S po = (%L. (L: pset po & (\<forall>y\<in>S. (y,L): order po) &
                   (\<forall>z\<in>pset po. (\<forall>y\<in>S. (y,z): order po) --> (L,z): order po)))"

definition
  isGlb :: "['a set, 'a potype, 'a] => bool" where
  "isGlb S po = (%G. (G: pset po & (\<forall>y\<in>S. (G,y): order po) &
                 (\<forall>z \<in> pset po. (\<forall>y\<in>S. (z,y): order po) --> (z,G): order po)))"

definition
  "fix"    :: "[('a => 'a), 'a set] => 'a set" where
  "fix f A  = {x. x: A & f x = x}"

definition
  interval :: "[('a*'a) set,'a, 'a ] => 'a set" where
  "interval r a b = {x. (a,x): r & (x,b): r}"

definition
  Bot :: "'a potype => 'a" where
  "Bot po = least (%x. True) po"

definition
  Top :: "'a potype => 'a" where
  "Top po = greatest (%x. True) po"

definition
  PartialOrder :: "('a potype) set" where
  "PartialOrder = {P. refl_on (pset P) (order P) & antisym (order P) &
                       trans (order P)}"

definition
  CompleteLattice :: "('a potype) set" where
  "CompleteLattice = {cl. cl: PartialOrder &
                        (\<forall>S. S \<subseteq> pset cl --> (\<exists>L. isLub S cl L)) &
                        (\<forall>S. S \<subseteq> pset cl --> (\<exists>G. isGlb S cl G))}"

definition
  CLF_set :: "('a potype * ('a => 'a)) set" where
  "CLF_set = (SIGMA cl: CompleteLattice.
            {f. f: pset cl \<rightarrow> pset cl & monotone f (pset cl) (order cl)})"

definition
  induced :: "['a set, ('a * 'a) set] => ('a *'a)set" where
  "induced A r = {(a,b). a : A & b: A & (a,b): r}"

definition
  sublattice :: "('a potype * 'a set)set" where
  "sublattice =
      (SIGMA cl: CompleteLattice.
          {S. S \<subseteq> pset cl &
           (| pset = S, order = induced S (order cl) |): CompleteLattice})"

abbreviation
  sublat :: "['a set, 'a potype] => bool"  ("_ <<= _" [51,50]50) where
  "S <<= cl == S : sublattice `` {cl}"

definition
  dual :: "'a potype => 'a potype" where
  "dual po = (| pset = pset po, order = converse (order po) |)"

locale S =
  fixes cl :: "'a potype"
    and A  :: "'a set"
    and r  :: "('a * 'a) set"
  defines A_def: "A == pset cl"
     and  r_def: "r == order cl"

locale PO = S +
  assumes cl_po:  "cl : PartialOrder"

locale CL = S +
  assumes cl_co:  "cl : CompleteLattice"

sublocale CL < po?: PO
apply (simp_all add: A_def r_def)
apply unfold_locales
using cl_co unfolding CompleteLattice_def by auto

locale CLF = S +
  fixes f :: "'a => 'a"
    and P :: "'a set"
  assumes f_cl:  "(cl,f) : CLF_set" (*was the equivalent "f : CLF_set``{cl}"*)
  defines P_def: "P == fix f A"

sublocale CLF < cl?: CL
apply (simp_all add: A_def r_def)
apply unfold_locales
using f_cl unfolding CLF_set_def by auto

locale Tarski = CLF +
  fixes Y     :: "'a set"
    and intY1 :: "'a set"
    and v     :: "'a"
  assumes
    Y_ss: "Y \<subseteq> P"
  defines
    intY1_def: "intY1 == interval r (lub Y cl) (Top cl)"
    and v_def: "v == glb {x. ((%x: intY1. f x) x, x): induced intY1 r &
                             x: intY1}
                      (| pset=intY1, order=induced intY1 r|)"

subsection \<open>Partial Order\<close>

lemma (in PO) dual:
  "PO (dual cl)"
apply unfold_locales
using cl_po
unfolding PartialOrder_def dual_def
by auto

lemma (in PO) PO_imp_refl_on [simp]: "refl_on A r"
apply (insert cl_po)
apply (simp add: PartialOrder_def A_def r_def)
done

lemma (in PO) PO_imp_sym [simp]: "antisym r"
apply (insert cl_po)
apply (simp add: PartialOrder_def r_def)
done

lemma (in PO) PO_imp_trans [simp]: "trans r"
apply (insert cl_po)
apply (simp add: PartialOrder_def r_def)
done

lemma (in PO) reflE: "x \<in> A ==> (x, x) \<in> r"
apply (insert cl_po)
apply (simp add: PartialOrder_def refl_on_def A_def r_def)
done

lemma (in PO) antisymE: "[| (a, b) \<in> r; (b, a) \<in> r |] ==> a = b"
apply (insert cl_po)
apply (simp add: PartialOrder_def antisym_def r_def)
done

lemma (in PO) transE: "[| (a, b) \<in> r; (b, c) \<in> r|] ==> (a,c) \<in> r"
apply (insert cl_po)
apply (simp add: PartialOrder_def r_def)
apply (unfold trans_def, fast)
done

lemma (in PO) monotoneE:
     "[| monotone f A r;  x \<in> A; y \<in> A; (x, y) \<in> r |] ==> (f x, f y) \<in> r"
by (simp add: monotone_def)

lemma (in PO) po_subset_po:
     "S \<subseteq> A ==> (| pset = S, order = induced S r |) \<in> PartialOrder"
apply (simp (no_asm) add: PartialOrder_def)
apply auto
\<comment> \<open>refl\<close>
apply (simp add: refl_on_def induced_def)
apply (blast intro: reflE)
\<comment> \<open>antisym\<close>
apply (simp add: antisym_def induced_def)
apply (blast intro: antisymE)
\<comment> \<open>trans\<close>
apply (simp add: trans_def induced_def)
apply (blast intro: transE)
done

lemma (in PO) indE: "[| (x, y) \<in> induced S r; S \<subseteq> A |] ==> (x, y) \<in> r"
by (simp add: add: induced_def)

lemma (in PO) indI: "[| (x, y) \<in> r; x \<in> S; y \<in> S |] ==> (x, y) \<in> induced S r"
by (simp add: add: induced_def)

lemma (in CL) CL_imp_ex_isLub: "S \<subseteq> A ==> \<exists>L. isLub S cl L"
apply (insert cl_co)
apply (simp add: CompleteLattice_def A_def)
done

declare (in CL) cl_co [simp]

lemma isLub_lub: "(\<exists>L. isLub S cl L) = isLub S cl (lub S cl)"
by (simp add: lub_def least_def isLub_def some_eq_ex [symmetric])

lemma isGlb_glb: "(\<exists>G. isGlb S cl G) = isGlb S cl (glb S cl)"
by (simp add: glb_def greatest_def isGlb_def some_eq_ex [symmetric])

lemma isGlb_dual_isLub: "isGlb S cl = isLub S (dual cl)"
by (simp add: isLub_def isGlb_def dual_def converse_unfold)

lemma isLub_dual_isGlb: "isLub S cl = isGlb S (dual cl)"
by (simp add: isLub_def isGlb_def dual_def converse_unfold)

lemma (in PO) dualPO: "dual cl \<in> PartialOrder"
apply (insert cl_po)
apply (simp add: PartialOrder_def dual_def refl_on_converse
                 trans_converse antisym_converse)
done

lemma Rdual:
     "\<forall>S. (S \<subseteq> A -->( \<exists>L. isLub S (| pset = A, order = r|) L))
      ==> \<forall>S. (S \<subseteq> A --> (\<exists>G. isGlb S (| pset = A, order = r|) G))"
apply safe
apply (rule_tac x = "lub {y. y \<in> A & (\<forall>k \<in> S. (y, k) \<in> r)}
                      (|pset = A, order = r|) " in exI)
apply (drule_tac x = "{y. y \<in> A & (\<forall>k \<in> S. (y,k) \<in> r) }" in spec)
apply (drule mp, fast)
apply (simp add: isLub_lub isGlb_def)
apply (simp add: isLub_def, blast)
done

lemma lub_dual_glb: "lub S cl = glb S (dual cl)"
by (simp add: lub_def glb_def least_def greatest_def dual_def converse_unfold)

lemma glb_dual_lub: "glb S cl = lub S (dual cl)"
by (simp add: lub_def glb_def least_def greatest_def dual_def converse_unfold)

lemma CL_subset_PO: "CompleteLattice \<subseteq> PartialOrder"
by (simp add: PartialOrder_def CompleteLattice_def, fast)

lemmas CL_imp_PO = CL_subset_PO [THEN subsetD]

(*declare CL_imp_PO [THEN PO.PO_imp_refl, simp]
declare CL_imp_PO [THEN PO.PO_imp_sym, simp]
declare CL_imp_PO [THEN PO.PO_imp_trans, simp]*)

lemma (in CL) CO_refl_on: "refl_on A r"
by (rule PO_imp_refl_on)

lemma (in CL) CO_antisym: "antisym r"
by (rule PO_imp_sym)

lemma (in CL) CO_trans: "trans r"
by (rule PO_imp_trans)

lemma CompleteLatticeI:
     "[| po \<in> PartialOrder; (\<forall>S. S \<subseteq> pset po --> (\<exists>L. isLub S po L));
         (\<forall>S. S \<subseteq> pset po --> (\<exists>G. isGlb S po G))|]
      ==> po \<in> CompleteLattice"
apply (unfold CompleteLattice_def, blast)
done

lemma (in CL) CL_dualCL: "dual cl \<in> CompleteLattice"
apply (insert cl_co)
apply (simp add: CompleteLattice_def dual_def)
apply (fold dual_def)
apply (simp add: isLub_dual_isGlb [symmetric] isGlb_dual_isLub [symmetric]
                 dualPO)
done

lemma (in PO) dualA_iff: "pset (dual cl) = pset cl"
by (simp add: dual_def)

lemma (in PO) dualr_iff: "((x, y) \<in> (order(dual cl))) = ((y, x) \<in> order cl)"
by (simp add: dual_def)

lemma (in PO) monotone_dual:
     "monotone f (pset cl) (order cl)
     ==> monotone f (pset (dual cl)) (order(dual cl))"
by (simp add: monotone_def dualA_iff dualr_iff)

lemma (in PO) interval_dual:
     "[| x \<in> A; y \<in> A|] ==> interval r x y = interval (order(dual cl)) y x"
apply (simp add: interval_def dualr_iff)
apply (fold r_def, fast)
done

lemma (in PO) trans:
  "(x, y) \<in> r \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> (x, z) \<in> r"
using cl_po apply (auto simp add: PartialOrder_def r_def)
unfolding trans_def by blast

lemma (in PO) interval_not_empty:
  "interval r a b \<noteq> {} ==> (a, b) \<in> r"
apply (simp add: interval_def)
using trans by blast

lemma (in PO) interval_imp_mem: "x \<in> interval r a b ==> (a, x) \<in> r"
by (simp add: interval_def)

lemma (in PO) left_in_interval:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |] ==> a \<in> interval r a b"
apply (simp (no_asm_simp) add: interval_def)
apply (simp add: PO_imp_trans interval_not_empty)
apply (simp add: reflE)
done

lemma (in PO) right_in_interval:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |] ==> b \<in> interval r a b"
apply (simp (no_asm_simp) add: interval_def)
apply (simp add: PO_imp_trans interval_not_empty)
apply (simp add: reflE)
done

subsection \<open>sublattice\<close>

lemma (in PO) sublattice_imp_CL:
     "S <<= cl  ==> (| pset = S, order = induced S r |) \<in> CompleteLattice"
by (simp add: sublattice_def CompleteLattice_def r_def)

lemma (in CL) sublatticeI:
     "[| S \<subseteq> A; (| pset = S, order = induced S r |) \<in> CompleteLattice |]
      ==> S <<= cl"
by (simp add: sublattice_def A_def r_def)

lemma (in CL) dual:
  "CL (dual cl)"
apply unfold_locales
using cl_co unfolding CompleteLattice_def
apply (simp add: dualPO isGlb_dual_isLub [symmetric] isLub_dual_isGlb [symmetric] dualA_iff)
done

subsection \<open>lub\<close>

lemma (in CL) lub_unique: "[| S \<subseteq> A; isLub S cl x; isLub S cl L|] ==> x = L"
apply (rule antisymE)
apply (auto simp add: isLub_def r_def)
done

lemma (in CL) lub_upper: "[|S \<subseteq> A; x \<in> S|] ==> (x, lub S cl) \<in> r"
apply (rule CL_imp_ex_isLub [THEN exE], assumption)
apply (unfold lub_def least_def)
apply (rule some_equality [THEN ssubst])
  apply (simp add: isLub_def)
 apply (simp add: lub_unique A_def isLub_def)
apply (simp add: isLub_def r_def)
done

lemma (in CL) lub_least:
     "[| S \<subseteq> A; L \<in> A; \<forall>x \<in> S. (x,L) \<in> r |] ==> (lub S cl, L) \<in> r"
apply (rule CL_imp_ex_isLub [THEN exE], assumption)
apply (unfold lub_def least_def)
apply (rule_tac s=x in some_equality [THEN ssubst])
  apply (simp add: isLub_def)
 apply (simp add: lub_unique A_def isLub_def)
apply (simp add: isLub_def r_def A_def)
done

lemma (in CL) lub_in_lattice: "S \<subseteq> A ==> lub S cl \<in> A"
apply (rule CL_imp_ex_isLub [THEN exE], assumption)
apply (unfold lub_def least_def)
apply (subst some_equality)
apply (simp add: isLub_def)
prefer 2 apply (simp add: isLub_def A_def)
apply (simp add: lub_unique A_def isLub_def)
done

lemma (in CL) lubI:
     "[| S \<subseteq> A; L \<in> A; \<forall>x \<in> S. (x,L) \<in> r;
         \<forall>z \<in> A. (\<forall>y \<in> S. (y,z) \<in> r) --> (L,z) \<in> r |] ==> L = lub S cl"
apply (rule lub_unique, assumption)
apply (simp add: isLub_def A_def r_def)
apply (unfold isLub_def)
apply (rule conjI)
apply (fold A_def r_def)
apply (rule lub_in_lattice, assumption)
apply (simp add: lub_upper lub_least)
done

lemma (in CL) lubIa: "[| S \<subseteq> A; isLub S cl L |] ==> L = lub S cl"
by (simp add: lubI isLub_def A_def r_def)

lemma (in CL) isLub_in_lattice: "isLub S cl L ==> L \<in> A"
by (simp add: isLub_def  A_def)

lemma (in CL) isLub_upper: "[|isLub S cl L; y \<in> S|] ==> (y, L) \<in> r"
by (simp add: isLub_def r_def)

lemma (in CL) isLub_least:
     "[| isLub S cl L; z \<in> A; \<forall>y \<in> S. (y, z) \<in> r|] ==> (L, z) \<in> r"
by (simp add: isLub_def A_def r_def)

lemma (in CL) isLubI:
     "[| L \<in> A; \<forall>y \<in> S. (y, L) \<in> r;
         (\<forall>z \<in> A. (\<forall>y \<in> S. (y, z):r) --> (L, z) \<in> r)|] ==> isLub S cl L"
by (simp add: isLub_def A_def r_def)

subsection \<open>glb\<close>

lemma (in CL) glb_in_lattice: "S \<subseteq> A ==> glb S cl \<in> A"
apply (subst glb_dual_lub)
apply (simp add: A_def)
apply (rule dualA_iff [THEN subst])
apply (rule CL.lub_in_lattice)
apply (rule dual)
apply (simp add: dualA_iff)
done

lemma (in CL) glb_lower: "[|S \<subseteq> A; x \<in> S|] ==> (glb S cl, x) \<in> r"
apply (subst glb_dual_lub)
apply (simp add: r_def)
apply (rule dualr_iff [THEN subst])
apply (rule CL.lub_upper)
apply (rule dual)
apply (simp add: dualA_iff A_def, assumption)
done

text \<open>
  Reduce the sublattice property by using substructural properties;
  abandoned see \<open>Tarski_4.ML\<close>.
\<close>

lemma (in CLF) [simp]:
    "f: pset cl \<rightarrow> pset cl & monotone f (pset cl) (order cl)"
apply (insert f_cl)
apply (simp add: CLF_set_def)
done

declare (in CLF) f_cl [simp]

lemma (in CLF) f_in_funcset: "f \<in> A \<rightarrow> A"
by (simp add: A_def)

lemma (in CLF) monotone_f: "monotone f A r"
by (simp add: A_def r_def)

lemma (in CLF) CLF_dual: "(dual cl, f) \<in> CLF_set"
apply (simp add: CLF_set_def  CL_dualCL monotone_dual)
apply (simp add: dualA_iff)
done

lemma (in CLF) dual:
  "CLF (dual cl) f"
apply (rule CLF.intro)
apply (rule CLF_dual)
done

subsection \<open>fixed points\<close>

lemma fix_subset: "fix f A \<subseteq> A"
by (simp add: fix_def, fast)

lemma fix_imp_eq: "x \<in> fix f A ==> f x = x"
by (simp add: fix_def)

lemma fixf_subset:
     "[| A \<subseteq> B; x \<in> fix (%y: A. f y) A |] ==> x \<in> fix f B"
by (simp add: fix_def, auto)

subsection \<open>lemmas for Tarski, lub\<close>
lemma (in CLF) lubH_le_flubH:
     "H = {x. (x, f x) \<in> r & x \<in> A} ==> (lub H cl, f (lub H cl)) \<in> r"
apply (rule lub_least, fast)
apply (rule f_in_funcset [THEN funcset_mem])
apply (rule lub_in_lattice, fast)
\<comment> \<open>\<open>\<forall>x:H. (x, f (lub H r)) \<in> r\<close>\<close>
apply (rule ballI)
apply (rule transE)
\<comment> \<open>instantiates \<open>(x, ???z) \<in> order cl to (x, f x)\<close>,\<close>
\<comment> \<open>because of the def of \<open>H\<close>\<close>
apply fast
\<comment> \<open>so it remains to show \<open>(f x, f (lub H cl)) \<in> r\<close>\<close>
apply (rule_tac f = "f" in monotoneE)
apply (rule monotone_f, fast)
apply (rule lub_in_lattice, fast)
apply (rule lub_upper, fast)
apply assumption
done

lemma (in CLF) flubH_le_lubH:
     "[|  H = {x. (x, f x) \<in> r & x \<in> A} |] ==> (f (lub H cl), lub H cl) \<in> r"
apply (rule lub_upper, fast)
apply (rule_tac t = "H" in ssubst, assumption)
apply (rule CollectI)
apply (rule conjI)
apply (rule_tac [2] f_in_funcset [THEN funcset_mem])
apply (rule_tac [2] lub_in_lattice)
prefer 2 apply fast
apply (rule_tac f = "f" in monotoneE)
apply (rule monotone_f)
  apply (blast intro: lub_in_lattice)
 apply (blast intro: lub_in_lattice f_in_funcset [THEN funcset_mem])
apply (simp add: lubH_le_flubH)
done

lemma (in CLF) lubH_is_fixp:
     "H = {x. (x, f x) \<in> r & x \<in> A} ==> lub H cl \<in> fix f A"
apply (simp add: fix_def)
apply (rule conjI)
apply (rule lub_in_lattice, fast)
apply (rule antisymE)
apply (simp add: flubH_le_lubH)
apply (simp add: lubH_le_flubH)
done

lemma (in CLF) fix_in_H:
     "[| H = {x. (x, f x) \<in> r & x \<in> A};  x \<in> P |] ==> x \<in> H"
by (simp add: P_def fix_imp_eq [of _ f A] reflE CO_refl_on
                    fix_subset [of f A, THEN subsetD])

lemma (in CLF) fixf_le_lubH:
     "H = {x. (x, f x) \<in> r & x \<in> A} ==> \<forall>x \<in> fix f A. (x, lub H cl) \<in> r"
apply (rule ballI)
apply (rule lub_upper, fast)
apply (rule fix_in_H)
apply (simp_all add: P_def)
done

lemma (in CLF) lubH_least_fixf:
     "H = {x. (x, f x) \<in> r & x \<in> A}
      ==> \<forall>L. (\<forall>y \<in> fix f A. (y,L) \<in> r) --> (lub H cl, L) \<in> r"
apply (rule allI)
apply (rule impI)
apply (erule bspec)
apply (rule lubH_is_fixp, assumption)
done

subsection \<open>Tarski fixpoint theorem 1, first part\<close>
lemma (in CLF) T_thm_1_lub: "lub P cl = lub {x. (x, f x) \<in> r & x \<in> A} cl"
apply (rule sym)
apply (simp add: P_def)
apply (rule lubI)
apply (rule fix_subset)
apply (rule lub_in_lattice, fast)
apply (simp add: fixf_le_lubH)
apply (simp add: lubH_least_fixf)
done

lemma (in CLF) glbH_is_fixp: "H = {x. (f x, x) \<in> r & x \<in> A} ==> glb H cl \<in> P"
  \<comment> \<open>Tarski for glb\<close>
apply (simp add: glb_dual_lub P_def A_def r_def)
apply (rule dualA_iff [THEN subst])
apply (rule CLF.lubH_is_fixp)
apply (rule dual)
apply (simp add: dualr_iff dualA_iff)
done

lemma (in CLF) T_thm_1_glb: "glb P cl = glb {x. (f x, x) \<in> r & x \<in> A} cl"
apply (simp add: glb_dual_lub P_def A_def r_def)
apply (rule dualA_iff [THEN subst])
apply (simp add: CLF.T_thm_1_lub [of _ f, OF dual]
                 dualPO CL_dualCL CLF_dual dualr_iff)
done

subsection \<open>interval\<close>

lemma (in CLF) rel_imp_elem: "(x, y) \<in> r ==> x \<in> A"
apply (insert CO_refl_on)
apply (simp add: refl_on_def, blast)
done

lemma (in CLF) interval_subset: "[| a \<in> A; b \<in> A |] ==> interval r a b \<subseteq> A"
apply (simp add: interval_def)
apply (blast intro: rel_imp_elem)
done

lemma (in CLF) intervalI:
     "[| (a, x) \<in> r; (x, b) \<in> r |] ==> x \<in> interval r a b"
by (simp add: interval_def)

lemma (in CLF) interval_lemma1:
     "[| S \<subseteq> interval r a b; x \<in> S |] ==> (a, x) \<in> r"
by (unfold interval_def, fast)

lemma (in CLF) interval_lemma2:
     "[| S \<subseteq> interval r a b; x \<in> S |] ==> (x, b) \<in> r"
by (unfold interval_def, fast)

lemma (in CLF) a_less_lub:
     "[| S \<subseteq> A; S \<noteq> {};
         \<forall>x \<in> S. (a,x) \<in> r; \<forall>y \<in> S. (y, L) \<in> r |] ==> (a,L) \<in> r"
by (blast intro: transE)

lemma (in CLF) glb_less_b:
     "[| S \<subseteq> A; S \<noteq> {};
         \<forall>x \<in> S. (x,b) \<in> r; \<forall>y \<in> S. (G, y) \<in> r |] ==> (G,b) \<in> r"
by (blast intro: transE)

lemma (in CLF) S_intv_cl:
     "[| a \<in> A; b \<in> A; S \<subseteq> interval r a b |]==> S \<subseteq> A"
by (simp add: subset_trans [OF _ interval_subset])

lemma (in CLF) L_in_interval:
     "[| a \<in> A; b \<in> A; S \<subseteq> interval r a b;
         S \<noteq> {}; isLub S cl L; interval r a b \<noteq> {} |] ==> L \<in> interval r a b"
apply (rule intervalI)
apply (rule a_less_lub)
prefer 2 apply assumption
apply (simp add: S_intv_cl)
apply (rule ballI)
apply (simp add: interval_lemma1)
apply (simp add: isLub_upper)
\<comment> \<open>\<open>(L, b) \<in> r\<close>\<close>
apply (simp add: isLub_least interval_lemma2)
done

lemma (in CLF) G_in_interval:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {}; S \<subseteq> interval r a b; isGlb S cl G;
         S \<noteq> {} |] ==> G \<in> interval r a b"
apply (simp add: interval_dual)
apply (simp add: CLF.L_in_interval [of _ f, OF dual]
                 dualA_iff A_def isGlb_dual_isLub)
done

lemma (in CLF) intervalPO:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |]
      ==> (| pset = interval r a b, order = induced (interval r a b) r |)
          \<in> PartialOrder"
apply (rule po_subset_po)
apply (simp add: interval_subset)
done

lemma (in CLF) intv_CL_lub:
 "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |]
  ==> \<forall>S. S \<subseteq> interval r a b -->
          (\<exists>L. isLub S (| pset = interval r a b,
                          order = induced (interval r a b) r |)  L)"
apply (intro strip)
apply (frule S_intv_cl [THEN CL_imp_ex_isLub])
prefer 2 apply assumption
apply assumption
apply (erule exE)
\<comment> \<open>define the lub for the interval as\<close>
apply (rule_tac x = "if S = {} then a else L" in exI)
apply (simp (no_asm_simp) add: isLub_def split del: if_split)
apply (intro impI conjI)
\<comment> \<open>\<open>(if S = {} then a else L) \<in> interval r a b\<close>\<close>
apply (simp add: CL_imp_PO L_in_interval)
apply (simp add: left_in_interval)
\<comment> \<open>lub prop 1\<close>
apply (case_tac "S = {}")
\<comment> \<open>\<open>S = {}, y \<in> S = False => everything\<close>\<close>
apply fast
\<comment> \<open>\<open>S \<noteq> {}\<close>\<close>
apply simp
\<comment> \<open>\<open>\<forall>y:S. (y, L) \<in> induced (interval r a b) r\<close>\<close>
apply (rule ballI)
apply (simp add: induced_def  L_in_interval)
apply (rule conjI)
apply (rule subsetD)
apply (simp add: S_intv_cl, assumption)
apply (simp add: isLub_upper)
\<comment> \<open>\<open>\<forall>z:interval r a b. (\<forall>y:S. (y, z) \<in> induced (interval r a b) r \<longrightarrow> (if S = {} then a else L, z) \<in> induced (interval r a b) r\<close>\<close>
apply (rule ballI)
apply (rule impI)
apply (case_tac "S = {}")
\<comment> \<open>\<open>S = {}\<close>\<close>
apply simp
apply (simp add: induced_def  interval_def)
apply (rule conjI)
apply (rule reflE, assumption)
apply (rule interval_not_empty)
apply (simp add: interval_def)
\<comment> \<open>\<open>S \<noteq> {}\<close>\<close>
apply simp
apply (simp add: induced_def  L_in_interval)
apply (rule isLub_least, assumption)
apply (rule subsetD)
prefer 2 apply assumption
apply (simp add: S_intv_cl, fast)
done

lemmas (in CLF) intv_CL_glb = intv_CL_lub [THEN Rdual]

lemma (in CLF) interval_is_sublattice:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |]
        ==> interval r a b <<= cl"
apply (rule sublatticeI)
apply (simp add: interval_subset)
apply (rule CompleteLatticeI)
apply (simp add: intervalPO)
 apply (simp add: intv_CL_lub)
apply (simp add: intv_CL_glb)
done

lemmas (in CLF) interv_is_compl_latt =
    interval_is_sublattice [THEN sublattice_imp_CL]

subsection \<open>Top and Bottom\<close>
lemma (in CLF) Top_dual_Bot: "Top cl = Bot (dual cl)"
by (simp add: Top_def Bot_def least_def greatest_def dualA_iff dualr_iff)

lemma (in CLF) Bot_dual_Top: "Bot cl = Top (dual cl)"
by (simp add: Top_def Bot_def least_def greatest_def dualA_iff dualr_iff)

lemma (in CLF) Bot_in_lattice: "Bot cl \<in> A"
apply (simp add: Bot_def least_def)
apply (rule_tac a="glb A cl" in someI2)
apply (simp_all add: glb_in_lattice glb_lower
                     r_def [symmetric] A_def [symmetric])
done

lemma (in CLF) Top_in_lattice: "Top cl \<in> A"
apply (simp add: Top_dual_Bot A_def)
apply (rule dualA_iff [THEN subst])
apply (rule CLF.Bot_in_lattice [OF dual])
done

lemma (in CLF) Top_prop: "x \<in> A ==> (x, Top cl) \<in> r"
apply (simp add: Top_def greatest_def)
apply (rule_tac a="lub A cl" in someI2)
apply (rule someI2)
apply (simp_all add: lub_in_lattice lub_upper
                     r_def [symmetric] A_def [symmetric])
done

lemma (in CLF) Bot_prop: "x \<in> A ==> (Bot cl, x) \<in> r"
apply (simp add: Bot_dual_Top r_def)
apply (rule dualr_iff [THEN subst])
apply (rule CLF.Top_prop [OF dual])
apply (simp add: dualA_iff A_def)
done

lemma (in CLF) Top_intv_not_empty: "x \<in> A  ==> interval r x (Top cl) \<noteq> {}"
apply (rule notI)
apply (drule_tac a = "Top cl" in equals0D)
apply (simp add: interval_def)
apply (simp add: refl_on_def Top_in_lattice Top_prop)
done

lemma (in CLF) Bot_intv_not_empty: "x \<in> A ==> interval r (Bot cl) x \<noteq> {}"
apply (simp add: Bot_dual_Top)
apply (subst interval_dual)
prefer 2 apply assumption
apply (simp add: A_def)
apply (rule dualA_iff [THEN subst])
apply (rule CLF.Top_in_lattice [OF dual])
apply (rule CLF.Top_intv_not_empty [OF dual])
apply (simp add: dualA_iff A_def)
done

subsection \<open>fixed points form a partial order\<close>

lemma (in CLF) fixf_po: "(| pset = P, order = induced P r|) \<in> PartialOrder"
by (simp add: P_def fix_subset po_subset_po)

lemma (in Tarski) Y_subset_A: "Y \<subseteq> A"
apply (rule subset_trans [OF _ fix_subset])
apply (rule Y_ss [simplified P_def])
done

lemma (in Tarski) lubY_in_A: "lub Y cl \<in> A"
  by (rule Y_subset_A [THEN lub_in_lattice])

lemma (in Tarski) lubY_le_flubY: "(lub Y cl, f (lub Y cl)) \<in> r"
apply (rule lub_least)
apply (rule Y_subset_A)
apply (rule f_in_funcset [THEN funcset_mem])
apply (rule lubY_in_A)
\<comment> \<open>\<open>Y \<subseteq> P ==> f x = x\<close>\<close>
apply (rule ballI)
apply (rule_tac t = "x" in fix_imp_eq [THEN subst])
apply (erule Y_ss [simplified P_def, THEN subsetD])
\<comment> \<open>\<open>reduce (f x, f (lub Y cl)) \<in> r to (x, lub Y cl) \<in> r\<close> by monotonicity\<close>
apply (rule_tac f = "f" in monotoneE)
apply (rule monotone_f)
apply (simp add: Y_subset_A [THEN subsetD])
apply (rule lubY_in_A)
apply (simp add: lub_upper Y_subset_A)
done

lemma (in Tarski) intY1_subset: "intY1 \<subseteq> A"
apply (unfold intY1_def)
apply (rule interval_subset)
apply (rule lubY_in_A)
apply (rule Top_in_lattice)
done

lemmas (in Tarski) intY1_elem = intY1_subset [THEN subsetD]

lemma (in Tarski) intY1_f_closed: "x \<in> intY1 \<Longrightarrow> f x \<in> intY1"
apply (simp add: intY1_def  interval_def)
apply (rule conjI)
apply (rule transE)
apply (rule lubY_le_flubY)
\<comment> \<open>\<open>(f (lub Y cl), f x) \<in> r\<close>\<close>
apply (rule_tac f=f in monotoneE)
apply (rule monotone_f)
apply (rule lubY_in_A)
apply (simp add: intY1_def interval_def  intY1_elem)
apply (simp add: intY1_def  interval_def)
\<comment> \<open>\<open>(f x, Top cl) \<in> r\<close>\<close>
apply (rule Top_prop)
apply (rule f_in_funcset [THEN funcset_mem])
apply (simp add: intY1_def interval_def  intY1_elem)
done

lemma (in Tarski) intY1_mono:
     "monotone (%x: intY1. f x) intY1 (induced intY1 r)"
apply (auto simp add: monotone_def induced_def intY1_f_closed)
apply (blast intro: intY1_elem monotone_f [THEN monotoneE])
done

lemma (in Tarski) intY1_is_cl:
    "(| pset = intY1, order = induced intY1 r |) \<in> CompleteLattice"
apply (unfold intY1_def)
apply (rule interv_is_compl_latt)
apply (rule lubY_in_A)
apply (rule Top_in_lattice)
apply (rule Top_intv_not_empty)
apply (rule lubY_in_A)
done

lemma (in Tarski) v_in_P: "v \<in> P"
apply (unfold P_def)
apply (rule_tac A = "intY1" in fixf_subset)
apply (rule intY1_subset)
unfolding v_def
apply (rule CLF.glbH_is_fixp [OF CLF.intro, unfolded CLF_set_def, of "\<lparr>pset = intY1, order = induced intY1 r\<rparr>", simplified])
apply auto
apply (rule intY1_is_cl)
apply (erule intY1_f_closed)
apply (rule intY1_mono)
done

lemma (in Tarski) z_in_interval:
     "[| z \<in> P; \<forall>y\<in>Y. (y, z) \<in> induced P r |] ==> z \<in> intY1"
apply (unfold intY1_def P_def)
apply (rule intervalI)
prefer 2
 apply (erule fix_subset [THEN subsetD, THEN Top_prop])
apply (rule lub_least)
apply (rule Y_subset_A)
apply (fast elim!: fix_subset [THEN subsetD])
apply (simp add: induced_def)
done

lemma (in Tarski) f'z_in_int_rel: "[| z \<in> P; \<forall>y\<in>Y. (y, z) \<in> induced P r |]
      ==> ((%x: intY1. f x) z, z) \<in> induced intY1 r"
apply (simp add: induced_def  intY1_f_closed z_in_interval P_def)
apply (simp add: fix_imp_eq [of _ f A] fix_subset [of f A, THEN subsetD]
                 reflE)
done

lemma (in Tarski) tarski_full_lemma:
     "\<exists>L. isLub Y (| pset = P, order = induced P r |) L"
apply (rule_tac x = "v" in exI)
apply (simp add: isLub_def)
\<comment> \<open>\<open>v \<in> P\<close>\<close>
apply (simp add: v_in_P)
apply (rule conjI)
\<comment> \<open>\<open>v\<close> is lub\<close>
\<comment> \<open>\<open>1. \<forall>y:Y. (y, v) \<in> induced P r\<close>\<close>
apply (rule ballI)
apply (simp add: induced_def subsetD v_in_P)
apply (rule conjI)
apply (erule Y_ss [THEN subsetD])
apply (rule_tac b = "lub Y cl" in transE)
apply (rule lub_upper)
apply (rule Y_subset_A, assumption)
apply (rule_tac b = "Top cl" in interval_imp_mem)
apply (simp add: v_def)
apply (fold intY1_def)
apply (rule CL.glb_in_lattice [OF CL.intro [OF intY1_is_cl], simplified])
apply auto
apply (rule indI)
  prefer 3 apply assumption
 prefer 2 apply (simp add: v_in_P)
apply (unfold v_def)
apply (rule indE)
apply (rule_tac [2] intY1_subset)
apply (rule CL.glb_lower [OF CL.intro [OF intY1_is_cl], simplified])
  apply (simp add: CL_imp_PO intY1_is_cl)
 apply force
apply (simp add: induced_def intY1_f_closed z_in_interval)
apply (simp add: P_def fix_imp_eq [of _ f A] reflE
                 fix_subset [of f A, THEN subsetD])
done

lemma CompleteLatticeI_simp:
     "[| (| pset = A, order = r |) \<in> PartialOrder;
         \<forall>S. S \<subseteq> A --> (\<exists>L. isLub S (| pset = A, order = r |)  L) |]
    ==> (| pset = A, order = r |) \<in> CompleteLattice"
by (simp add: CompleteLatticeI Rdual)

theorem (in CLF) Tarski_full:
     "(| pset = P, order = induced P r|) \<in> CompleteLattice"
apply (rule CompleteLatticeI_simp)
apply (rule fixf_po, clarify)
apply (simp add: P_def A_def r_def)
apply (rule Tarski.tarski_full_lemma [OF Tarski.intro [OF _ Tarski_axioms.intro]])
proof - show "CLF cl f" .. qed

end


(* Author: Dmitriy Traytel *)

header {* Normalization of M2L Formulas *}

(*<*)
theory M2L_Normalization
imports M2L
begin
(*>*)

fun nNot where
  "nNot (FNot \<phi>) = \<phi>"
| "nNot (FAnd \<phi>1 \<phi>2) = FOr (nNot \<phi>1) (nNot \<phi>2)"
| "nNot (FOr \<phi>1 \<phi>2) = FAnd (nNot \<phi>1) (nNot \<phi>2)"
| "nNot \<phi> = FNot \<phi>"

primrec norm where
  "norm (FQ a m) = FQ a m"
| "norm (FLess m n) = FLess m n"
| "norm (FIn m M) = FIn m M"
| "norm (FOr \<phi> \<psi>) = FOr (norm \<phi>) (norm \<psi>)"
| "norm (FAnd \<phi> \<psi>) = FAnd (norm \<phi>) (norm \<psi>)"
| "norm (FNot \<phi>) = nNot (norm \<phi>)"
| "norm (FExists \<phi>) = FExists (norm \<phi>)"
| "norm (FEXISTS \<phi>) = FEXISTS (norm \<phi>)"

context formula
begin

lemma satisfies_nNot[simp]: "satisfies (w, I) (nNot \<phi>) = satisfies (w,I) (FNot \<phi>)"
  by (induct \<phi> rule: nNot.induct) auto

lemma FOV_nNot[simp]: "FOV (nNot \<phi>) = FOV (FNot \<phi>)"
  by (induct \<phi> rule: nNot.induct) auto

lemma SOV_nNot[simp]: "SOV (nNot \<phi>) = SOV (FNot \<phi>)"
  by (induct \<phi> rule: nNot.induct) auto

lemma pre_wf_formula_nNot[simp]: "pre_wf_formula n (nNot \<phi>) = pre_wf_formula n (FNot \<phi>)"
  by (induct \<phi> rule: nNot.induct) auto

lemma FOV_norm[simp]: "FOV (norm \<phi>) = FOV \<phi>"
  by (induct \<phi>) auto

lemma SOV_norm[simp]: "SOV (norm \<phi>) = SOV \<phi>"
  by (induct \<phi>) auto

lemma pre_wf_formula_norm[simp]: "pre_wf_formula n (norm \<phi>) = pre_wf_formula n \<phi>"
  by (induct \<phi> arbitrary: n) auto

lemma satisfies_norm[simp]: "satisfies (w, I) (norm \<phi>) = satisfies (w, I) \<phi>"
  by (induct \<phi> arbitrary: I) auto

lemma lang\<^sub>M\<^sub>2\<^sub>L_norm[simp]: "lang\<^sub>M\<^sub>2\<^sub>L n (norm \<phi>) = lang\<^sub>M\<^sub>2\<^sub>L n \<phi>"
  unfolding lang\<^sub>M\<^sub>2\<^sub>L_def by auto

end

(*<*)
end
(*>*)


theory Design_Operations imports Design_Basics
begin

section \<open>Design Operations\<close>
text \<open>Incidence systems have a number of very typical computational operations
which can be used for constructions in design theory. Definitions in this section are based off
the handbook of combinatorial designs, hypergraph theory \<^cite>\<open>"bergeHypergraphsCombinatoricsFinite1989"\<close>,
and the GAP design theory library \<^cite>\<open>"soicherDesignsGroupsComputing2013"\<close>\<close>

subsection \<open>Incidence system definitions\<close>

context incidence_system
begin

text \<open>The basic add point operation only affects the point set of a design\<close>
definition add_point :: "'a \<Rightarrow> 'a set" where
"add_point p \<equiv> insert p \<V>"

lemma add_existing_point [simp]: "p \<in> \<V> \<Longrightarrow> add_point p = \<V>"
  using add_point_def by fastforce

lemma add_point_wf: "incidence_system (add_point p) \<B>"
  using wf_invalid_point add_point_def by (unfold_locales) (auto)

text \<open>An extension of the basic add point operation also adds the point to a given set of blocks\<close>
definition add_point_to_blocks :: "'a \<Rightarrow> 'a set set \<Rightarrow> 'a set multiset" where
"add_point_to_blocks p bs \<equiv> {# (insert p b) | b \<in># \<B> . b \<in> bs#} + {# b \<in># \<B> . b \<notin> bs#}"

lemma add_point_blocks_blocks_alt: "add_point_to_blocks p bs =
    image_mset (insert p) (filter_mset (\<lambda> b . b \<in> bs) \<B>) + (filter_mset (\<lambda> b . b \<notin> bs) \<B>)"
  using add_point_to_blocks_def by simp

lemma add_point_existing_blocks:
  assumes "(\<And> bl . bl \<in> bs \<Longrightarrow> p \<in> bl)"
  shows "add_point_to_blocks p bs = \<B>"
proof (simp add: add_point_to_blocks_def)
  have "image_mset (insert p) {#b \<in># \<B>. b \<in> bs#} = {#b \<in># \<B>. b \<in> bs#}" using assms
    by (simp add: image_filter_cong insert_absorb)
  thus "image_mset (insert p) {#b \<in># \<B>. b \<in> bs#} + {#b \<in># \<B>. b \<notin> bs#} = \<B>"
    using multiset_partition by simp
qed

lemma add_new_point_rep_number:
  assumes "p \<notin> \<V>"
  shows "(add_point_to_blocks p bs) rep p = size {#b \<in># \<B> . b \<in> bs#}"
proof -
  have "\<And> b. b \<in># \<B> \<Longrightarrow> b \<notin> bs \<Longrightarrow> p \<notin> b"
    by (simp add: assms wf_invalid_point)
  then have zero: "{# b \<in># \<B> . b \<notin> bs#} rep p = 0"
    by (simp add: filter_mset_empty_conv point_replication_number_def)
  have "(add_point_to_blocks p bs) rep p = {# (insert p b) | b \<in># \<B> . b \<in> bs#} rep p + {# b \<in># \<B> . b \<notin> bs#} rep p"
    by (simp add: add_point_to_blocks_def)
  then have eq: "(add_point_to_blocks p bs) rep p = {# (insert p b) | b \<in># \<B> . b \<in> bs#} rep p"
    using zero by simp
  have "\<And> bl . bl \<in># {# (insert p b) | b \<in># \<B> . b \<in> bs#} \<Longrightarrow> p \<in> bl" by auto
  then have "{# (insert p b) | b \<in># \<B> . b \<in> bs#} rep p = size {# (insert p b) | b \<in># \<B> . b \<in> bs#}"
    using point_replication_number_def by (metis filter_mset_True filter_mset_cong)
  thus ?thesis by (simp add: eq)
qed

lemma add_point_blocks_wf: "incidence_system (add_point p) (add_point_to_blocks p bs)"
  by (unfold_locales) (auto simp add: add_point_def wf_invalid_point add_point_to_blocks_def)

text \<open>Basic (weak) delete point operation removes a point from both the point set and from any
blocks that contain it to maintain wellformed property\<close>
definition del_point :: "'a \<Rightarrow> 'a set" where
"del_point p \<equiv> \<V> - {p}"

definition del_point_blocks:: "'a \<Rightarrow> 'a set multiset" where
"del_point_blocks p \<equiv> {# (bl - {p}) . bl \<in># \<B> #}"

lemma del_point_block_count: "size (del_point_blocks p) = size \<B>"
  by (simp add: del_point_blocks_def)

lemma remove_invalid_point_block: "p \<notin> \<V> \<Longrightarrow> bl \<in># \<B> \<Longrightarrow> bl - {p} = bl"
  using wf_invalid_point by blast

lemma del_invalid_point: "p \<notin> \<V> \<Longrightarrow> (del_point p) = \<V>"
  by (simp add: del_point_def)

lemma del_invalid_point_blocks: "p \<notin> \<V> \<Longrightarrow> (del_point_blocks p) = \<B>"
  using del_invalid_point
  by (auto simp add: remove_invalid_point_block del_point_blocks_def)

lemma delete_point_p_not_in_bl_blocks: "(\<And> bl. bl \<in># \<B> \<Longrightarrow> p \<notin> bl) \<Longrightarrow> (del_point_blocks p) = \<B>"
  by (simp add: del_point_blocks_def)

lemma delete_point_blocks_wf: "b \<in># (del_point_blocks p) \<Longrightarrow> b \<subseteq> \<V> - {p}"
  unfolding del_point_blocks_def using wellformed by auto

lemma delete_point_blocks_sub:
  assumes "b \<in># (del_point_blocks p)"
  obtains bl where "bl \<in># \<B> \<and> b \<subseteq> bl"
  using assms by (auto simp add: del_point_blocks_def)

lemma delete_point_split_blocks: "del_point_blocks p =
  {# bl \<in>#\<B> . p \<notin> bl#} + {# bl - {p} | bl \<in># \<B> . p \<in> bl#}"
proof -
  have sm: "\<And> bl . p \<notin> bl \<Longrightarrow> bl - {p} = bl" by simp
  have "del_point_blocks p = {# (bl - {p}) . bl \<in># \<B> #}" by (simp add: del_point_blocks_def)
  also have "... = {# (bl - {p}) | bl \<in># \<B> . p \<notin> bl #} + {# (bl - {p}) | bl \<in># \<B> . p \<in> bl #}"
    using multiset_partition by (metis image_mset_union union_commute)
  finally have "del_point_blocks p = {#bl | bl \<in># \<B> . p \<notin> bl#} +
      {# (bl - {p}) | bl \<in># \<B> . p \<in> bl #}"
    using sm mem_Collect_eq
    by (metis (mono_tags, lifting) Multiset.set_mset_filter  multiset.map_cong)
  thus ?thesis by simp
qed

lemma delete_point_index_eq:
  assumes "ps \<subseteq> (del_point p)"
  shows "(del_point_blocks p) index ps = \<B> index ps"
proof -
  have eq: "filter_mset ((\<subseteq>) ps) {#bl - {p}. bl \<in># \<B>#} =
      image_mset (\<lambda> b . b - {p}) (filter_mset (\<lambda> b. ps \<subseteq> b - {p}) \<B>)"
    using filter_mset_image_mset by blast
  have "p \<notin> ps" using assms del_point_def by blast
  then have "\<And> bl . ps \<subseteq> bl \<longleftrightarrow> ps \<subseteq> bl - {p}" by blast
  then have "((filter_mset (\<lambda> b. ps \<subseteq> b - {p}) \<B>)) = (filter_mset (\<lambda> b . ps \<subseteq> b) \<B>)" by auto
  then have "size (image_mset (\<lambda> b . b - {p}) (filter_mset (\<lambda> b. ps \<subseteq> b - {p}) \<B>))
      = \<B> index ps"
    by (simp add: points_index_def)
  thus ?thesis using eq
    by (simp add: del_point_blocks_def points_index_def)
qed

lemma delete_point_wf: "incidence_system (del_point p) (del_point_blocks p)"
  using delete_point_blocks_wf del_point_def by (unfold_locales) auto

text \<open>The concept of a strong delete point comes from hypergraph theory. When a point is deleted,
any blocks containing it are also deleted\<close>
definition str_del_point_blocks :: "'a \<Rightarrow> 'a set multiset" where
"str_del_point_blocks p \<equiv> {# bl \<in># \<B> . p \<notin> bl#}"

lemma str_del_point_blocks_alt: "str_del_point_blocks p = \<B> - {# bl \<in># \<B> . p \<in> bl#}"
  using add_diff_cancel_left' multiset_partition by (metis str_del_point_blocks_def)

lemma delete_point_strong_block_in:  "p \<notin> bl \<Longrightarrow> bl \<in># \<B>  \<Longrightarrow> bl \<in># str_del_point_blocks p"
  by (simp add: str_del_point_blocks_def)

lemma delete_point_strong_block_not_in: "p \<in> bl \<Longrightarrow> bl \<notin># (str_del_point_blocks) p"
  by (simp add: str_del_point_blocks_def)

lemma delete_point_strong_block_in_iff: "bl \<in># \<B> \<Longrightarrow> bl \<in># str_del_point_blocks p \<longleftrightarrow> p \<notin> bl"
  using delete_point_strong_block_in delete_point_strong_block_not_in
  by (simp add: str_del_point_blocks_def)

lemma delete_point_strong_block_subset: "str_del_point_blocks p \<subseteq># \<B>"
  by (simp add: str_del_point_blocks_def)

lemma delete_point_strong_block_in_orig: "bl \<in># str_del_point_blocks p \<Longrightarrow> bl \<in># \<B>"
  using delete_point_strong_block_subset by (metis mset_subset_eqD)

lemma delete_invalid_pt_strong_eq: "p \<notin> \<V> \<Longrightarrow> \<B> = str_del_point_blocks p"
  unfolding str_del_point_blocks_def using wf_invalid_point empty_iff
  by (metis Multiset.diff_cancel filter_mset_eq_conv set_mset_empty subset_mset.order_refl)

lemma strong_del_point_index_alt:
  assumes "ps \<subseteq> (del_point p)"
  shows "(str_del_point_blocks p) index ps =
    \<B> index ps - {# bl \<in># \<B> . p \<in> bl#} index ps"
  using str_del_point_blocks_alt points_index_def
  by (metis filter_diff_mset multiset_filter_mono multiset_filter_subset  size_Diff_submset)

lemma strong_del_point_incidence_wf: "incidence_system (del_point p) (str_del_point_blocks p)"
  using wellformed str_del_point_blocks_def del_point_def by (unfold_locales) auto

text \<open>Add block operation\<close>

definition add_block :: "'a set \<Rightarrow> 'a set multiset" where
"add_block b \<equiv> \<B> + {#b#}"

lemma add_block_alt: "add_block b = add_mset b \<B>"
  by (simp add: add_block_def)

lemma add_block_rep_number_in:
  assumes "x \<in> b"
  shows "(add_block b) rep x = \<B> rep x + 1"
proof -
  have "(add_block b) = {#b#} + \<B>" by (simp add: add_block_def)
  then have split: "(add_block b) rep x = {#b#} rep x + \<B> rep x"
    by (metis point_rep_number_split)
  have "{#b#} rep x = 1" using assms by simp
  thus ?thesis using split by auto
qed

lemma add_block_rep_number_not_in: "x \<notin> b \<Longrightarrow> (add_block b) rep x = \<B> rep x"
  using point_rep_number_split add_block_alt point_rep_singleton_inval
  by (metis add.right_neutral union_mset_add_mset_right)

lemma add_block_index_in:
  assumes "ps \<subseteq> b"
  shows "(add_block b) index ps = \<B> index ps + 1"
proof -
  have "(add_block b) = {#b#} + \<B>" by (simp add: add_block_def)
  then have split: "(add_block b) index ps = {#b#} index ps + \<B> index ps"
    by (metis point_index_distrib)
  have "{#b#} index ps = 1" using assms points_index_singleton by auto
  thus ?thesis using split by simp
qed

lemma add_block_index_not_in: "\<not> (ps \<subseteq> b) \<Longrightarrow> (add_block b) index ps = \<B> index ps"
  using point_index_distrib points_index_singleton_zero
  by (metis add.right_neutral add_block_def)

text \<open>Note the add block incidence system is defined slightly differently then textbook
definitions due to the modification to the point set. This ensures the operation is closed,
where otherwise a condition that $b \subseteq \mathcal{V}$ would be required.\<close>
lemma add_block_wf: "incidence_system (\<V> \<union> b) (add_block b)"
  using wellformed add_block_def by (unfold_locales) auto

lemma add_block_wf_cond: "b \<subseteq> \<V> \<Longrightarrow> incidence_system \<V> (add_block b)"
  using add_block_wf by (metis sup.order_iff)

text \<open>Delete block removes a block from the block set. The point set is unchanged\<close>
definition del_block :: "'a set \<Rightarrow> 'a set multiset" where
"del_block b \<equiv> \<B> - {#b#}"

lemma delete_block_subset: "(del_block b) \<subseteq># \<B>"
  by (simp add: del_block_def)

lemma delete_invalid_block_eq: "b \<notin># \<B> \<Longrightarrow> del_block b = \<B>"
  by (simp add: del_block_def)

lemma delete_block_wf: "incidence_system \<V> (del_block b)"
  by (unfold_locales) (simp add: del_block_def in_diffD wellformed)

text \<open>The strong delete block operation effectively deletes the block, as well as
all points in that block\<close>
definition str_del_block :: "'a set \<Rightarrow> 'a set multiset" where
"str_del_block b \<equiv> {# bl - b | bl \<in># \<B> . bl \<noteq> b #}"

lemma strong_del_block_alt_def: "str_del_block b = {# bl - b . bl \<in># removeAll_mset b \<B> #}"
  by (simp add: filter_mset_neq str_del_block_def)

lemma strong_del_block_wf: "incidence_system (\<V> - b) (str_del_block b)"
  using wf_invalid_point str_del_block_def by (unfold_locales) auto

lemma str_del_block_del_point:
  assumes "{x} \<notin># \<B>"
  shows "str_del_block {x} = (del_point_blocks x)"
proof -
  have neqx: "\<And> bl. bl \<in># \<B> \<Longrightarrow> bl \<noteq> {x}" using assms by auto
  have "str_del_block {x} = {# bl - {x} | bl \<in># \<B> . bl \<noteq> {x} #}" by (simp add: str_del_block_def)
  then have "str_del_block {x} = {# bl - {x} . bl \<in># \<B> #}" using assms neqx
    by (simp add: filter_mset_cong)
  thus ?thesis by (simp add: del_point_blocks_def)
qed

subsection \<open>Incidence System Interpretations\<close>
text \<open>It is easy to interpret all operations as incidence systems in there own right.
These can then be used to prove local properties on the new constructions, as well
as reason on interactions between different operation sequences\<close>

interpretation add_point_sys: incidence_system "add_point p" "\<B>"
  using add_point_wf by simp

lemma add_point_sys_rep_numbers: "add_point_sys.replication_numbers p =
    replication_numbers \<union> {\<B> rep p}"
  using add_point_sys.replication_numbers_def replication_numbers_def add_point_def by auto

interpretation del_point_sys: incidence_system "del_point p" "del_point_blocks p"
  using delete_point_wf by auto

interpretation add_block_sys: incidence_system "\<V> \<union> bl" "add_block bl"
  using add_block_wf by simp

interpretation del_block_sys: incidence_system "\<V>" "del_block bl"
  using delete_block_wf by simp

lemma add_del_block_inv:
  assumes "bl \<subseteq> \<V>"
  shows "add_block_sys.del_block bl bl = \<B>"
  using add_block_sys.del_block_def add_block_def by simp

lemma del_add_block_inv: "bl \<in># \<B> \<Longrightarrow> del_block_sys.add_block bl bl = \<B>"
  using del_block_sys.add_block_def del_block_def wellformed by fastforce

lemma del_invalid_add_block_eq: "bl \<notin># \<B> \<Longrightarrow> del_block_sys.add_block bl bl = add_block bl"
  using del_block_sys.add_block_def by (simp add: delete_invalid_block_eq)

lemma add_delete_point_inv:
  assumes "p \<notin> \<V>"
  shows "add_point_sys.del_point p p = \<V>"
proof -
  have "(add_point_sys.del_point p p) = (insert p \<V>) - {p}"
    using add_point_sys.del_point_def del_block_sys.add_point_def by auto
  thus ?thesis
    by (simp add: assms)
qed
end

subsection \<open>Operation Closure for Designs\<close>

context finite_incidence_system
begin

lemma add_point_finite: "finite_incidence_system (add_point p) \<B>"
  using add_point_wf finite_sets add_point_def
  by (unfold_locales) (simp_all add: incidence_system_def)

lemma add_point_to_blocks_finite: "finite_incidence_system (add_point p) (add_point_to_blocks p bs)"
  using add_point_blocks_wf add_point_finite finite_incidence_system.finite_sets
    incidence_system.finite_sysI by blast

lemma delete_point_finite:
    "finite_incidence_system (del_point p) (del_point_blocks p)"
  using finite_sets delete_point_wf
  by (unfold_locales) (simp_all add: incidence_system_def del_point_def)

lemma del_point_order:
  assumes "p \<in> \<V>"
  shows "card (del_point p) = \<v> - 1"
proof -
  have vg0: "card \<V> > 0" using assms finite_sets card_gt_0_iff by auto
  then have "card (del_point p) = card \<V> - 1" using assms del_point_def
    by (metis card_Diff_singleton)
  thus ?thesis
    using vg0 by linarith
qed

lemma strong_del_point_finite:"finite_incidence_system (del_point p) (str_del_point_blocks p)"
  using strong_del_point_incidence_wf del_point_def
  by (intro_locales) (simp_all add: finite_incidence_system_axioms_def finite_sets)

lemma add_block_fin: "finite b \<Longrightarrow> finite_incidence_system (\<V> \<union> b) (add_block b)"
  using wf_invalid_point finite_sets add_block_def by (unfold_locales) auto

lemma add_block_fin_cond: "b \<subseteq> \<V> \<Longrightarrow> finite_incidence_system \<V> (add_block b)"
  using add_block_wf_cond finite_incidence_system_axioms.intro finite_sets
  by (intro_locales) (simp_all)

lemma delete_block_fin_incidence_sys: "finite_incidence_system \<V> (del_block b)"
  using delete_block_wf finite_sets by (unfold_locales) (simp_all add: incidence_system_def)

lemma strong_del_block_fin: "finite_incidence_system (\<V> - b) (str_del_block b)"
  using strong_del_block_wf finite_sets finite_incidence_system_axioms_def by (intro_locales) auto

end

context design
begin
lemma add_point_design: "design (add_point p) \<B>"
  using add_point_wf finite_sets blocks_nempty add_point_def
  by (unfold_locales) (auto simp add: incidence_system_def)

lemma delete_point_design:
  assumes "(\<And> bl . bl \<in># \<B> \<Longrightarrow> p \<in> bl \<Longrightarrow> card bl \<ge> 2)"
  shows "design (del_point p) (del_point_blocks p)"
proof (cases "p \<in> \<V>")
  case True
  interpret fis: finite_incidence_system "(del_point p)" "(del_point_blocks p)"
    using delete_point_finite by simp
  show ?thesis
  proof (unfold_locales)
    show "\<And>bl. bl \<in># (del_point_blocks p) \<Longrightarrow> bl \<noteq> {}" using assms del_point_def
    proof -
      fix bl
      assume "bl \<in>#(del_point_blocks p)"
      then obtain bl' where block: "bl' \<in># \<B>" and rem: "bl = bl' - {p}"
        by (auto simp add: del_point_blocks_def)
      then have eq: "p \<notin> bl' \<Longrightarrow> bl \<noteq> {}" using block blocks_nempty by (simp add: rem)
      have "p \<in> bl' \<Longrightarrow> card bl \<ge> 1" using rem finite_blocks block assms block by fastforce
      then show "bl \<noteq> {}" using  eq assms by fastforce
    qed
  qed
next
  case False
  then show ?thesis using del_invalid_point del_invalid_point_blocks
    by (simp add: wf_design)
qed

lemma strong_del_point_design: "design (del_point p) (str_del_point_blocks p)"
proof -
  interpret fin: finite_incidence_system "(del_point p)" "(str_del_point_blocks p)"
    using strong_del_point_finite by simp
  show ?thesis using wf_design wf_design_iff del_point_def str_del_point_blocks_def
    by (unfold_locales) (auto)
qed

lemma add_block_design:
  assumes "finite bl"
  assumes "bl \<noteq> {}"
  shows "design (\<V> \<union> bl) (add_block bl)"
proof -
  interpret fin: finite_incidence_system "(\<V> \<union> bl)" "(add_block bl)"
    using add_block_fin assms by simp
  show ?thesis using blocks_nempty assms add_block_def by (unfold_locales) auto
qed

lemma add_block_design_cond:
  assumes "bl \<subseteq> \<V>" and "bl \<noteq> {}"
  shows "design \<V> (add_block bl)"
proof -
  interpret fin: finite_incidence_system "\<V>" "(add_block bl)"
    using add_block_fin_cond assms by simp
  show ?thesis using blocks_nempty assms add_block_def by (unfold_locales) auto
qed

lemma delete_block_design: "design \<V> (del_block bl)"
proof -
  interpret fin: finite_incidence_system \<V> "(del_block bl)"
    using delete_block_fin_incidence_sys by simp
  have "\<And> b . b \<in># (del_block bl) \<Longrightarrow> b \<noteq> {}"
    using blocks_nempty delete_block_subset by blast
  then show ?thesis by (unfold_locales) (simp_all)
qed

lemma strong_del_block_des:
  assumes "\<And> bl . bl \<in># \<B> \<Longrightarrow> \<not> (bl \<subset> b)"
  shows "design (\<V> - b) (str_del_block b)"
proof -
  interpret fin: finite_incidence_system "\<V> - b" "(str_del_block b)"
    using strong_del_block_fin by simp
  show ?thesis using assms str_del_block_def by (unfold_locales) auto
qed

end

context proper_design
begin
lemma delete_point_proper:
  assumes "\<And>bl. bl \<in># \<B> \<Longrightarrow> p \<in> bl \<Longrightarrow> 2 \<le> card bl"
  shows "proper_design (del_point p) (del_point_blocks p)"
proof -
  interpret des: design "del_point p" "del_point_blocks p"
    using delete_point_design assms by blast
  show ?thesis using design_blocks_nempty del_point_def del_point_blocks_def
    by (unfold_locales) simp
qed

lemma strong_delete_point_proper:
  assumes "\<And>bl. bl \<in># \<B> \<Longrightarrow> p \<in> bl \<Longrightarrow> 2 \<le> card bl"
  assumes "\<B> rep p < \<b>"
  shows "proper_design (del_point p) (str_del_point_blocks p)"
proof -
  interpret des: design "del_point p" "str_del_point_blocks p"
    using strong_del_point_design assms by blast
  show ?thesis using assms design_blocks_nempty point_rep_num_inv_non_empty
    str_del_point_blocks_def del_point_def by (unfold_locales) simp
qed

end

subsection \<open>Combining Set Systems\<close>
text \<open>Similar to multiple, another way to construct a new set system is to combine two existing ones.
We introduce a new locale enabling us to reason on two different incidence systems\<close>
locale two_set_systems = sys1: incidence_system \<V> \<B> + sys2: incidence_system \<V>' \<B>'
  for \<V> :: "('a set)" and \<B> and \<V>' :: "('a set)" and \<B>'
begin

abbreviation "combine_points \<equiv> \<V> \<union> \<V>'"

notation combine_points ("\<V>\<^sup>+")

abbreviation "combine_blocks \<equiv> \<B> + \<B>'"

notation combine_blocks ("\<B>\<^sup>+")

sublocale combine_sys: incidence_system "\<V>\<^sup>+" "\<B>\<^sup>+"
  using sys1.wellformed sys2.wellformed by (unfold_locales) auto

lemma combine_points_index: "\<B>\<^sup>+ index ps = \<B> index ps  + \<B>' index ps"
  by (simp add: point_index_distrib)

lemma combine_rep_number: "\<B>\<^sup>+ rep x = \<B> rep x + \<B>' rep x"
  by (simp add: point_replication_number_def)

lemma combine_multiple1: "\<V> = \<V>' \<Longrightarrow> \<B> = \<B>' \<Longrightarrow> \<B>\<^sup>+ = sys1.multiple_blocks 2"
  by auto

lemma combine_multiple2: "\<V> = \<V>' \<Longrightarrow> \<B> = \<B>' \<Longrightarrow> \<B>\<^sup>+ = sys2.multiple_blocks 2"
  by auto

lemma combine_multiplicity: "combine_sys.multiplicity b = sys1.multiplicity b + sys2.multiplicity b"
  by simp

lemma combine_block_sizes: "combine_sys.sys_block_sizes =
    sys1.sys_block_sizes \<union> sys2.sys_block_sizes"
  using sys1.sys_block_sizes_def sys2.sys_block_sizes_def combine_sys.sys_block_sizes_def by (auto)

end

locale two_fin_set_systems = two_set_systems \<V> \<B> \<V>' \<B>' + sys1: finite_incidence_system \<V> \<B> +
  sys2: finite_incidence_system \<V>' \<B>' for \<V> \<B> \<V>' \<B>'
begin

sublocale combine_fin_sys: finite_incidence_system "\<V>\<^sup>+" "\<B>\<^sup>+"
  using sys1.finite_sets sys2.finite_sets by (unfold_locales) (simp)

lemma combine_order: "card (\<V>\<^sup>+) \<ge> card \<V>"
  by (meson Un_upper1 card_mono combine_fin_sys.finite_sets)

lemma  combine_order_2: "card (\<V>\<^sup>+) \<ge> card \<V>'"
  by (meson Un_upper2 card_mono combine_fin_sys.finite_sets)

end

locale two_designs = two_fin_set_systems \<V> \<B> \<V>' \<B>' + des1: design \<V> \<B> +
  des2: design \<V>' \<B>' for \<V> \<B> \<V>' \<B>'
begin

sublocale combine_des: design "\<V>\<^sup>+" "\<B>\<^sup>+"
  apply (unfold_locales)
  using des1.blocks_nempty_alt des2.blocks_nempty_alt by fastforce

end

locale two_designs_proper = two_designs +
  assumes blocks_nempty: "\<B> \<noteq> {#} \<or> \<B>' \<noteq> {#}"
begin

lemma des1_is_proper: "\<B> \<noteq> {#} \<Longrightarrow> proper_design \<V> \<B>"
  by (unfold_locales) (simp)

lemma des2_is_proper: "\<B>' \<noteq> {#} \<Longrightarrow> proper_design \<V>' \<B>'"
  by (unfold_locales) (simp)

lemma min_one_proper_design: "proper_design \<V> \<B> \<or> proper_design \<V>' \<B>'"
  using blocks_nempty des1_is_proper des2_is_proper by (unfold_locales, blast)

sublocale combine_proper_des: proper_design "\<V>\<^sup>+" "\<B>\<^sup>+"
  apply (unfold_locales)
  by (metis blocks_nempty size_eq_0_iff_empty subset_mset.zero_eq_add_iff_both_eq_0)
end

end


(* Author: Tobias Nipkow *)

theory Hoare_Examples imports Hoare begin

text{* Summing up the first @{text x} natural numbers in variable @{text y}. *}

fun sum :: "int \<Rightarrow> int" where
"sum i = (if i \<le> 0 then 0 else sum (i - 1) + i)"

lemma sum_simps[simp]:
  "0 < i \<Longrightarrow> sum i = sum (i - 1) + i"
  "i \<le> 0 \<Longrightarrow> sum i = 0"
by(simp_all)

declare sum.simps[simp del]

abbreviation "wsum ==
  WHILE Less (N 0) (V ''x'')
  DO (''y'' ::= Plus (V ''y'') (V ''x'');;
      ''x'' ::= Plus (V ''x'') (N (- 1)))"

subsubsection{* Proof by Operational Semantics *}

text{* The behaviour of the loop is proved by induction: *}

lemma while_sum:
  "(wsum, s) \<Rightarrow> t \<Longrightarrow> t ''y'' = s ''y'' + sum(s ''x'')"
apply(induction wsum s t rule: big_step_induct)
apply(auto)
done

text{* We were lucky that the proof was automatic, except for the
induction. In general, such proofs will not be so easy. The automation is
partly due to the right inversion rules that we set up as automatic
elimination rules that decompose big-step premises.

Now we prefix the loop with the necessary initialization: *}

lemma sum_via_bigstep:
  assumes "(''y'' ::= N 0;; wsum, s) \<Rightarrow> t"
  shows "t ''y'' = sum (s ''x'')"
proof -
  from assms have "(wsum,s(''y'':=0)) \<Rightarrow> t" by auto
  from while_sum[OF this] show ?thesis by simp
qed

subsubsection{* Proof by Hoare Logic *}

text{* Note that we deal with sequences of commands from right to left,
pulling back the postcondition towards the precondition. *}

lemma "\<turnstile> {\<lambda>s. s ''x'' = n} ''y'' ::= N 0;; wsum {\<lambda>s. s ''y'' = sum n}"
apply(rule Seq)
 prefer 2
 apply(rule While' [where P = "\<lambda>s. (s ''y'' = sum n - sum(s ''x''))"])
  apply(rule Seq)
   prefer 2
   apply(rule Assign)
  apply(rule Assign')
  apply simp
 apply(simp)
apply(rule Assign')
apply simp
done

text{* The proof is intentionally an apply skript because it merely composes
the rules of Hoare logic. Of course, in a few places side conditions have to
be proved. But since those proofs are 1-liners, a structured proof is
overkill. In fact, we shall learn later that the application of the Hoare
rules can be automated completely and all that is left for the user is to
provide the loop invariants and prove the side-conditions. *}

end


(*  Author:     Andreas Lochbihler *)

section \<open>Predicates modelled as FinFuns\<close>

theory FinFunPred
imports FinFun
begin

unbundle finfun_syntax

text \<open>Instantiate FinFun predicates just like predicates\<close>

type_synonym 'a pred\<^sub>f = "'a \<Rightarrow>f bool"

instantiation "finfun" :: (type, ord) ord
begin

definition le_finfun_def [code del]: "f \<le> g \<longleftrightarrow> (\<forall>x. f $ x \<le> g $ x)"

definition [code del]: "(f::'a \<Rightarrow>f 'b) < g \<longleftrightarrow> f \<le> g \<and> \<not> g \<le> f"

instance ..

lemma le_finfun_code [code]:
  "f \<le> g \<longleftrightarrow> finfun_All ((\<lambda>(x, y). x \<le> y) \<circ>$ ($f, g$))"
by(simp add: le_finfun_def finfun_All_All o_def)

end

instance "finfun" :: (type, preorder) preorder
  by(intro_classes)(auto simp add: less_finfun_def le_finfun_def intro: order_trans)

instance "finfun" :: (type, order) order
by(intro_classes)(auto simp add: le_finfun_def order_antisym_conv intro: finfun_ext)

instantiation "finfun" :: (type, order_bot) order_bot begin
definition "bot = finfun_const bot"
instance by(intro_classes)(simp add: bot_finfun_def le_finfun_def)
end

lemma bot_finfun_apply [simp]: "($) bot = (\<lambda>_. bot)"
by(auto simp add: bot_finfun_def)

instantiation "finfun" :: (type, order_top) order_top begin
definition "top = finfun_const top"
instance by(intro_classes)(simp add: top_finfun_def le_finfun_def)
end

lemma top_finfun_apply [simp]: "($) top = (\<lambda>_. top)"
by(auto simp add: top_finfun_def)

instantiation "finfun" :: (type, inf) inf begin
definition [code]: "inf f g = (\<lambda>(x, y). inf x y) \<circ>$ ($f, g$)"
instance ..
end

lemma inf_finfun_apply [simp]: "($) (inf f g) = inf (($) f) (($) g)"
by(auto simp add: inf_finfun_def o_def inf_fun_def)

instantiation "finfun" :: (type, sup) sup begin
definition [code]: "sup f g = (\<lambda>(x, y). sup x y) \<circ>$ ($f, g$)"
instance ..
end

lemma sup_finfun_apply [simp]: "($) (sup f g) = sup (($) f) (($) g)"
by(auto simp add: sup_finfun_def o_def sup_fun_def)

instance "finfun" :: (type, semilattice_inf) semilattice_inf
by(intro_classes)(simp_all add: inf_finfun_def le_finfun_def)

instance "finfun" :: (type, semilattice_sup) semilattice_sup
by(intro_classes)(simp_all add: sup_finfun_def le_finfun_def)

instance "finfun" :: (type, lattice) lattice ..

instance "finfun" :: (type, bounded_lattice) bounded_lattice
by(intro_classes)

instance "finfun" :: (type, distrib_lattice) distrib_lattice
by(intro_classes)(simp add: sup_finfun_def inf_finfun_def expand_finfun_eq o_def sup_inf_distrib1)

instantiation "finfun" :: (type, minus) minus begin
definition "f - g = case_prod (-) \<circ>$ ($f, g$)"
instance ..
end

lemma minus_finfun_apply [simp]: "($) (f - g) = ($) f - ($) g"
by(simp add: minus_finfun_def o_def fun_diff_def)

instantiation "finfun" :: (type, uminus) uminus begin
definition "- A = uminus \<circ>$ A"
instance ..
end

lemma uminus_finfun_apply [simp]: "($) (- g) = - ($) g"
by(simp add: uminus_finfun_def o_def fun_Compl_def)

instance "finfun" :: (type, boolean_algebra) boolean_algebra
by(intro_classes)
  (simp_all add: uminus_finfun_def inf_finfun_def expand_finfun_eq sup_fun_def inf_fun_def fun_Compl_def o_def inf_compl_bot sup_compl_top diff_eq)

text \<open>
  Replicate predicate operations for FinFuns
\<close>

abbreviation finfun_empty :: "'a pred\<^sub>f" ("{}\<^sub>f")
where "{}\<^sub>f \<equiv> bot"

abbreviation finfun_UNIV :: "'a pred\<^sub>f"
where "finfun_UNIV \<equiv> top"

definition finfun_single :: "'a \<Rightarrow> 'a pred\<^sub>f"
where [code]: "finfun_single x = finfun_empty(x $:= True)"

lemma finfun_single_apply [simp]:
  "finfun_single x $ y \<longleftrightarrow> x = y"
by(simp add: finfun_single_def finfun_upd_apply)

lemma finfun_leI [intro!]: "(!!x. A $ x \<Longrightarrow> B $ x) \<Longrightarrow> A \<le> B"
by(simp add: le_finfun_def)

lemma finfun_leD [elim]: "\<lbrakk> A \<le> B; A $ x \<rbrakk> \<Longrightarrow> B $ x"
by(simp add: le_finfun_def)

text \<open>Bounded quantification.
  Warning: \<open>finfun_Ball\<close> and \<open>finfun_Ex\<close> may raise an exception, they should not be used for quickcheck
\<close>

definition finfun_Ball_except :: "'a list \<Rightarrow> 'a pred\<^sub>f \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
where [code del]: "finfun_Ball_except xs A P = (\<forall>a. A $ a \<longrightarrow> a \<in> set xs \<or> P a)"

lemma finfun_Ball_except_const:
  "finfun_Ball_except xs (K$ b) P \<longleftrightarrow> \<not> b \<or> set xs = UNIV \<or> Code.abort (STR ''finfun_ball_except'') (\<lambda>u. finfun_Ball_except xs (K$ b) P)"
by(auto simp add: finfun_Ball_except_def)

lemma finfun_Ball_except_const_finfun_UNIV_code [code]:
  "finfun_Ball_except xs (K$ b) P \<longleftrightarrow> \<not> b \<or> is_list_UNIV xs \<or> Code.abort (STR ''finfun_ball_except'') (\<lambda>u. finfun_Ball_except xs (K$ b) P)"
by(auto simp add: finfun_Ball_except_def is_list_UNIV_iff)

lemma finfun_Ball_except_update:
  "finfun_Ball_except xs (A(a $:= b)) P = ((a \<in> set xs \<or> (b \<longrightarrow> P a)) \<and> finfun_Ball_except (a # xs) A P)"
by(fastforce simp add: finfun_Ball_except_def finfun_upd_apply split: if_split_asm)

lemma finfun_Ball_except_update_code [code]:
  fixes a :: "'a :: card_UNIV"
  shows "finfun_Ball_except xs (finfun_update_code f a b) P = ((a \<in> set xs \<or> (b \<longrightarrow> P a)) \<and> finfun_Ball_except (a # xs) f P)"
by(simp add: finfun_Ball_except_update)

definition finfun_Ball :: "'a pred\<^sub>f \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
where [code del]: "finfun_Ball A P = Ball {x. A $ x} P"

lemma finfun_Ball_code [code]: "finfun_Ball = finfun_Ball_except []"
by(auto intro!: ext simp add: finfun_Ball_except_def finfun_Ball_def)

definition finfun_Bex_except :: "'a list \<Rightarrow> 'a pred\<^sub>f \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
where [code del]: "finfun_Bex_except xs A P = (\<exists>a. A $ a \<and> a \<notin> set xs \<and> P a)"

lemma finfun_Bex_except_const:
  "finfun_Bex_except xs (K$ b) P \<longleftrightarrow> b \<and> set xs \<noteq> UNIV \<and> Code.abort (STR ''finfun_Bex_except'') (\<lambda>u. finfun_Bex_except xs (K$ b) P)"
by(auto simp add: finfun_Bex_except_def)

lemma finfun_Bex_except_const_finfun_UNIV_code [code]:
  "finfun_Bex_except xs (K$ b) P \<longleftrightarrow> b \<and> \<not> is_list_UNIV xs \<and> Code.abort (STR ''finfun_Bex_except'') (\<lambda>u. finfun_Bex_except xs (K$ b) P)"
by(auto simp add: finfun_Bex_except_def is_list_UNIV_iff)

lemma finfun_Bex_except_update:
  "finfun_Bex_except xs (A(a $:= b)) P \<longleftrightarrow> (a \<notin> set xs \<and> b \<and> P a) \<or> finfun_Bex_except (a # xs) A P"
by(fastforce simp add: finfun_Bex_except_def finfun_upd_apply dest: bspec split: if_split_asm)

definition finfun_Bex :: "'a pred\<^sub>f \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
where [code del]: "finfun_Bex A P = Bex {x. A $ x} P"

lemma finfun_Bex_code [code]: "finfun_Bex = finfun_Bex_except []"
by(auto intro!: ext simp add: finfun_Bex_except_def finfun_Bex_def)

text \<open>Automatically replace predicate operations by finfun predicate operations where possible\<close>

lemma iso_finfun_le [code_unfold]:
  "($) A \<le> ($) B \<longleftrightarrow> A \<le> B"
by (metis le_finfun_def le_funD le_funI)

lemma iso_finfun_less [code_unfold]:
  "($) A < ($) B \<longleftrightarrow> A < B"
by (metis iso_finfun_le less_finfun_def less_fun_def)

lemma iso_finfun_eq [code_unfold]:
  "($) A = ($) B \<longleftrightarrow> A = B"
by(simp only: expand_finfun_eq)

lemma iso_finfun_sup [code_unfold]:
  "sup (($) A) (($) B) = ($) (sup A B)"
by(simp)

lemma iso_finfun_disj [code_unfold]:
  "A $ x \<or> B $ x \<longleftrightarrow> sup A B $ x"
by(simp add: sup_fun_def)

lemma iso_finfun_inf [code_unfold]:
  "inf (($) A) (($) B) = ($) (inf A B)"
by(simp)

lemma iso_finfun_conj [code_unfold]:
  "A $ x \<and> B $ x \<longleftrightarrow> inf A B $ x"
by(simp add: inf_fun_def)

lemma iso_finfun_empty_conv [code_unfold]:
  "(\<lambda>_. False) = ($) {}\<^sub>f"
by simp

lemma iso_finfun_UNIV_conv [code_unfold]:
  "(\<lambda>_. True) = ($) finfun_UNIV"
by simp

lemma iso_finfun_upd [code_unfold]:
  fixes A :: "'a pred\<^sub>f"
  shows "(($) A)(x := b) = ($) (A(x $:= b))"
by(simp add: fun_eq_iff)

lemma iso_finfun_uminus [code_unfold]:
  fixes A :: "'a pred\<^sub>f"
  shows "- ($) A = ($) (- A)"
by(simp)

lemma iso_finfun_minus [code_unfold]:
  fixes A :: "'a pred\<^sub>f"
  shows "($) A - ($) B = ($) (A - B)"
by(simp)

text \<open>
  Do not declare the following two theorems as \<open>[code_unfold]\<close>,
  because this causes quickcheck to fail frequently when bounded quantification is used which raises an exception.
  For code generation, the same problems occur, but then, no randomly generated FinFun is usually around.
\<close>

lemma iso_finfun_Ball_Ball:
  "(\<forall>x. A $ x \<longrightarrow> P x) \<longleftrightarrow> finfun_Ball A P"
by(simp add: finfun_Ball_def)

lemma iso_finfun_Bex_Bex:
  "(\<exists>x. A $ x \<and> P x) \<longleftrightarrow> finfun_Bex A P"
by(simp add: finfun_Bex_def)

text \<open>Test code setup\<close>

notepad begin
have "inf ((\<lambda>_ :: nat. False)(1 := True, 2 := True)) ((\<lambda>_. True)(3 := False)) \<le>
      sup ((\<lambda>_. False)(1 := True, 5 := True)) (- ((\<lambda>_. True)(2 := False, 3 := False)))"
  by eval
end

declare iso_finfun_Ball_Ball[code_unfold]
notepad begin
have "(\<forall>x. ((\<lambda>_ :: nat. False)(1 := True, 2 := True)) x \<longrightarrow> x < 3)"
  by eval
end
declare iso_finfun_Ball_Ball[code_unfold del]

end


(*
 * Copyright Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* Author: Jeremy Dawson and Gerwin Klein, NICTA *)

section \<open>Splitting words into lists\<close>

theory Rsplit
  imports "HOL-Library.Word" More_Word Bits_Int
begin

definition word_rsplit :: "'a::len word \<Rightarrow> 'b::len word list"
  where "word_rsplit w = map word_of_int (bin_rsplit LENGTH('b) (LENGTH('a), uint w))"

lemma word_rsplit_no:
  "(word_rsplit (numeral bin :: 'b::len word) :: 'a word list) =
    map word_of_int (bin_rsplit (LENGTH('a::len))
      (LENGTH('b), take_bit (LENGTH('b)) (numeral bin)))"
  by (simp add: word_rsplit_def of_nat_take_bit)

lemmas word_rsplit_no_cl [simp] = word_rsplit_no
  [unfolded bin_rsplitl_def bin_rsplit_l [symmetric]]

text \<open>
  This odd result arises from the fact that the statement of the
  result implies that the decoded words are of the same type,
  and therefore of the same length, as the original word.\<close>

lemma word_rsplit_same: "word_rsplit w = [w]"
  apply (simp add: word_rsplit_def bin_rsplit_all)
  apply transfer
  apply simp
  done

lemma word_rsplit_empty_iff_size: "word_rsplit w = [] \<longleftrightarrow> size w = 0"
  by (simp add: word_rsplit_def bin_rsplit_def word_size bin_rsplit_aux_simp_alt Let_def
      split: prod.split)

lemma test_bit_rsplit:
  "sw = word_rsplit w \<Longrightarrow> m < size (hd sw) \<Longrightarrow>
    k < length sw \<Longrightarrow> bit (rev sw ! k) m = bit w (k * size (hd sw) + m)"
  for sw :: "'a::len word list"
  apply (unfold word_rsplit_def word_test_bit_def)
  apply (rule trans)
   apply (rule_tac f = "\<lambda>x. bit x m" in arg_cong)
   apply (rule nth_map [symmetric])
   apply simp
  apply (rule bin_nth_rsplit)
     apply simp_all
  apply (simp add : word_size rev_map)
  apply (rule trans)
   defer
   apply (rule map_ident [THEN fun_cong])
  apply (rule refl [THEN map_cong])
  apply (simp add: unsigned_of_int take_bit_int_eq_self_iff)
  using bin_rsplit_size_sign take_bit_int_eq_self_iff by blast

lemma test_bit_rsplit_alt:
  \<open>bit ((word_rsplit w  :: 'b::len word list) ! i) m \<longleftrightarrow>
    bit w ((length (word_rsplit w :: 'b::len word list) - Suc i) * size (hd (word_rsplit w :: 'b::len word list)) + m)\<close>
  if \<open>i < length (word_rsplit w :: 'b::len word list)\<close> \<open>m < size (hd (word_rsplit w :: 'b::len word list))\<close> \<open>0 < length (word_rsplit w :: 'b::len word list)\<close>
  for w :: \<open>'a::len word\<close>
  apply (rule trans)
   apply (rule test_bit_cong)
   apply (rule rev_nth [of _ \<open>rev (word_rsplit w)\<close>, simplified rev_rev_ident])
  apply simp
   apply (rule that(1))
  apply simp
  apply (rule test_bit_rsplit)
    apply (rule refl)
  apply (rule asm_rl)
   apply (rule that(2))
  apply (rule diff_Suc_less)
  apply (rule that(3))
  done

lemma word_rsplit_len_indep [OF refl refl refl refl]:
  "[u,v] = p \<Longrightarrow> [su,sv] = q \<Longrightarrow> word_rsplit u = su \<Longrightarrow>
    word_rsplit v = sv \<Longrightarrow> length su = length sv"
  by (auto simp: word_rsplit_def bin_rsplit_len_indep)

lemma length_word_rsplit_size:
  "n = LENGTH('a::len) \<Longrightarrow>
    length (word_rsplit w :: 'a word list) \<le> m \<longleftrightarrow> size w \<le> m * n"
  by (auto simp: word_rsplit_def word_size bin_rsplit_len_le)

lemmas length_word_rsplit_lt_size =
  length_word_rsplit_size [unfolded Not_eq_iff linorder_not_less [symmetric]]

lemma length_word_rsplit_exp_size:
  "n = LENGTH('a::len) \<Longrightarrow>
    length (word_rsplit w :: 'a word list) = (size w + n - 1) div n"
  by (auto simp: word_rsplit_def word_size bin_rsplit_len)

lemma length_word_rsplit_even_size:
  "n = LENGTH('a::len) \<Longrightarrow> size w = m * n \<Longrightarrow>
    length (word_rsplit w :: 'a word list) = m"
  by (cases \<open>LENGTH('a)\<close>) (simp_all add: length_word_rsplit_exp_size div_nat_eqI)

lemmas length_word_rsplit_exp_size' = refl [THEN length_word_rsplit_exp_size]

\<comment> \<open>alternative proof of \<open>word_rcat_rsplit\<close>\<close>
lemmas tdle = times_div_less_eq_dividend
lemmas dtle = xtrans(4) [OF tdle mult.commute]

lemma word_rcat_rsplit: "word_rcat (word_rsplit w) = w"
  apply (rule word_eqI)
  apply (clarsimp simp: test_bit_rcat word_size)
  apply (subst refl [THEN test_bit_rsplit])
    apply (simp_all add: word_size
      refl [THEN length_word_rsplit_size [simplified not_less [symmetric], simplified]])
   apply safe
   apply (erule xtrans(7), rule dtle)+
  done

lemma size_word_rsplit_rcat_size:
  "word_rcat ws = frcw \<Longrightarrow> size frcw = length ws * LENGTH('a)
    \<Longrightarrow> length (word_rsplit frcw::'a word list) = length ws"
  for ws :: "'a::len word list" and frcw :: "'b::len word"
  by (cases \<open>LENGTH('a)\<close>) (simp_all add: word_size length_word_rsplit_exp_size' div_nat_eqI)

lemma word_rsplit_rcat_size [OF refl]:
  "word_rcat ws = frcw \<Longrightarrow>
    size frcw = length ws * LENGTH('a) \<Longrightarrow> word_rsplit frcw = ws"
  for ws :: "'a::len word list"
  apply (frule size_word_rsplit_rcat_size, assumption)
  apply (clarsimp simp add : word_size)
  apply (rule nth_equalityI, assumption)
  apply clarsimp
  apply (rule word_eqI [rule_format])
  apply (rule trans)
   apply (rule test_bit_rsplit_alt)
     apply (clarsimp simp: word_size)+
  apply (rule trans)
   apply (rule test_bit_rcat [OF refl refl])
  apply (simp add: word_size)
  apply (subst rev_nth)
   apply arith
  apply (simp add: le0 [THEN [2] xtrans(7), THEN diff_Suc_less])
  apply safe
  apply (simp add: diff_mult_distrib)
   apply (cases "size ws")
    apply simp_all
  done

lemma word_rsplit_upt:
  "\<lbrakk> size x = LENGTH('a :: len) * n; n \<noteq> 0 \<rbrakk>
    \<Longrightarrow> word_rsplit x = map (\<lambda>i. ucast (x >> (i * LENGTH('a))) :: 'a word) (rev [0 ..< n])"
  apply (subgoal_tac "length (word_rsplit x :: 'a word list) = n")
   apply (rule nth_equalityI, simp)
   apply (intro allI word_eqI impI)
   apply (simp add: test_bit_rsplit_alt word_size)
   apply (simp add: nth_ucast bit_simps rev_nth field_simps)
  apply (simp add: length_word_rsplit_exp_size word_size)
  apply (subst diff_add_assoc)
   apply (simp flip: less_eq_Suc_le)
  apply simp
  done

end