(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_47
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun y :: "Nat => Nat => bool" where
  "y (Z) (Z) = True"
| "y (Z) (S z2) = False"
| "y (S x22) (Z) = False"
| "y (S x22) (S y22) = y x22 y22"

fun z :: "Nat => Nat => bool" where
  "z x2 y2 = (~ (y x2 y2))"

fun x :: "bool => bool => bool" where
  "x True y2 = True"
| "x False y2 = y2"

fun elem :: "Nat => Nat list => bool" where
  "elem x2 (nil2) = False"
| "elem x2 (cons2 z2 xs) = x (y x2 z2) (elem x2 xs)"

fun t2 :: "Nat => Nat => bool" where
  "t2 (Z) y2 = True"
| "t2 (S z2) (Z) = False"
| "t2 (S z2) (S x22) = t2 z2 x22"

fun insert :: "Nat => Nat list => Nat list" where
  "insert x2 (nil2) = cons2 x2 (nil2)"
| "insert x2 (cons2 z2 xs) =
     (if t2 x2 z2 then cons2 x2 (cons2 z2 xs) else
        cons2 z2 (insert x2 xs))"

theorem property0 :
  "((z x2 y2) ==> ((elem x2 (insert y2 z2)) = (elem x2 z2)))"
  oops

end


subsubsection \<open>Wrap-up: Combining all state equations\<close>

theory All_State_Equations imports State_Unique_Equations State_d_Equation

begin

text \<open>The remaining equations:\<close>

context rm_eq_fixes
begin

  text \<open>Equation 4.27\<close>
  definition state_m :: "bool" where
    "state_m \<equiv> s m = b ^ q"

  text \<open>Equation not in the book\<close>
  definition state_partial_sum_mask :: "bool" where
    "state_partial_sum_mask \<equiv> \<forall>M\<le>m. (\<Sum>k\<le>M. s k) \<preceq> e"

  text \<open>Wrapping it all up\<close>

  definition state_equations :: "bool" where
    "state_equations \<equiv> state_relations_from_recursion \<and> state_unique_equations
                     \<and> state_partial_sum_mask \<and> state_m"

end

context register_machine
begin

lemma state_m_dioph:
  fixes b q :: polynomial
  fixes s :: "polynomial list"
  assumes "length s = Suc m"
  defines "DR \<equiv> LARY (\<lambda>ll. rm_eq_fixes.state_m p (ll!0!0) (ll!0!1) (nth (ll!1))) [[b, q], s]"
  shows "is_dioph_rel DR"
proof -
  define DS where "DS \<equiv> [(s!m) = b ^ q]"

  have "eval DS a = eval DR a" for a
    using DS_def DR_def rm_eq_fixes.state_m_def rm_eq_fixes_def local.register_machine_axioms
    using assms by (simp add: defs)

  moreover have "is_dioph_rel DS"
    unfolding DS_def by (auto simp: dioph)

  ultimately show ?thesis using is_dioph_rel_def by auto
qed

lemma state_partial_sum_mask_dioph:
  fixes e :: polynomial
  fixes s :: "polynomial list"
  assumes "length s = Suc m"
  defines "DR \<equiv> LARY (\<lambda>ll. rm_eq_fixes.state_partial_sum_mask p (ll!0!0) (nth (ll!1))) [[e], s]"
  shows "is_dioph_rel DR"
proof -

  define partial_sum_mask where "partial_sum_mask \<equiv> (\<lambda>m. (sum_polynomial (nth s) [0..<Suc m] [\<preceq>] e))"
  define DS where "DS \<equiv> [\<forall><Suc m] partial_sum_mask"

  have "eval DS a = eval DR a" for a
  proof -

    have aux: "((\<Sum>j = 0..<k. peval (s ! (([0..<Suc k]) ! j)) a)
                        + peval (s ! (([0..<Suc k]) ! k)) a \<preceq> peval e a)
             = ((\<Sum>j = 0..<k. peval (s ! j) a)
                        + peval (s ! k) a \<preceq> peval e a)" for k
    proof -
      have "[0..<Suc k] ! k = 0 + k"
        using nth_upt[of 0 k "Suc k"] by simp

      moreover have "(\<Sum>j = 0..<k. peval (s ! (([0..<Suc k]) ! j)) a)
                   = (\<Sum>j = 0..<k. peval (s ! j) a)"
        apply (rule sum.cong, simp) using nth_upt[of 0 _ "Suc k"]
        by (metis Suc_lessD add_cancel_right_left ex_nat_less_eq not_less_eq)
      ultimately show ?thesis
        by auto
    qed

    have aux2: "(\<Sum>j = 0..<Suc k. peval (s ! j) a) =
                (sum ((!) (map (\<lambda>P. peval P a) s)) {..k})" if "k\<le>m" for k
      apply (rule sum.cong, auto)
      by (metis assms(1) dual_order.strict_trans le_imp_less_Suc nth_map
          order.not_eq_order_implies_strict that)

    have "eval DS a = (\<forall>k<Suc m.
                      (\<Sum>j = 0..<k. peval (s ! j) a) + peval (s ! k) a \<preceq> peval e a)"
      unfolding DS_def partial_sum_mask_def using aux
      by (simp add: defs \<open>length s = Suc m\<close> sum_polynomial_eval)

    also have "... = (\<forall>k\<le>m.
                     (\<Sum>j = 0..<k. peval (s ! j) a) + peval (s ! k) a \<preceq> peval e a)"
      by (simp add: less_Suc_eq_le)

    finally show ?thesis using rm_eq_fixes_def local.register_machine_axioms DR_def
      rm_eq_fixes.state_partial_sum_mask_def aux2 by (simp add: defs)
  qed

  moreover have "is_dioph_rel DS"
    unfolding DS_def partial_sum_mask_def by (auto simp: dioph)

  ultimately show ?thesis using is_dioph_rel_def by auto
qed

definition state_equations_relation :: "polynomial \<Rightarrow> polynomial \<Rightarrow> polynomial \<Rightarrow> polynomial list
    \<Rightarrow> polynomial list \<Rightarrow> relation" ("[STATE] _ _ _ _ _")where
  "[STATE] b e q z s \<equiv> LARY (\<lambda>ll. rm_eq_fixes.state_equations p (ll!0!0) (ll!0!1) (ll!0!2)
                                                          (nth (ll!1)) (nth (ll!2)))
                        [[b, e, q], z, s]"

lemma state_equations_dioph:
  fixes b e q :: polynomial
  fixes s z :: "polynomial list"
  assumes "length s = Suc m" "length z = n"
  defines "DR \<equiv> [STATE] b e q z s"
  shows "is_dioph_rel DR"
proof -

  define DS where
    "DS \<equiv>  (LARY (\<lambda>ll. rm_eq_fixes.state_relations_from_recursion p (ll!0!0) (ll!0!1)
                 (nth (ll!1)) (nth (ll!2))) [[b, e], z, s])
       [\<and>] (LARY (\<lambda>ll. rm_eq_fixes.state_unique_equations p (ll!0!0) (ll!0!1) (ll!0!2) (nth (ll!1)))
                 [[b, e, q], s])
       [\<and>] (LARY (\<lambda>ll. rm_eq_fixes.state_partial_sum_mask p (ll!0!0) (nth (ll!1))) [[e], s])
       [\<and>] (LARY (\<lambda>ll. rm_eq_fixes.state_m p (ll!0!0) (ll!0!1) (nth (ll!1))) [[b, q], s])"

  have "eval DS a = eval DR a" for a
    using DS_def DR_def rm_eq_fixes.state_equations_def
    state_equations_relation_def rm_eq_fixes_def local.register_machine_axioms by (auto simp: defs)

  moreover have "is_dioph_rel DS"
    unfolding DS_def using assms state_relations_from_recursion_dioph[of z s] state_m_dioph[of s]
    state_partial_sum_mask_dioph state_unique_equations_dioph and_dioph
    by (auto simp: dioph)

  ultimately show ?thesis using is_dioph_rel_def by auto
qed

end

end


(*  Title:      ZF/Finite.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

prove:  b \<in> Fin(A) ==> inj(b,b) \<subseteq> surj(b,b)
*)

section\<open>Finite Powerset Operator and Finite Function Space\<close>

theory Finite imports Inductive Epsilon Nat begin

(*The natural numbers as a datatype*)
rep_datatype
  elimination    natE
  induction      nat_induct
  case_eqns      nat_case_0 nat_case_succ
  recursor_eqns  recursor_0 recursor_succ

consts
  Fin       :: "i=>i"
  FiniteFun :: "[i,i]=>i"         (\<open>(_ -||>/ _)\<close> [61, 60] 60)

inductive
  domains   "Fin(A)" \<subseteq> "Pow(A)"
  intros
    emptyI:  "0 \<in> Fin(A)"
    consI:   "[| a \<in> A;  b \<in> Fin(A) |] ==> cons(a,b) \<in> Fin(A)"
  type_intros  empty_subsetI cons_subsetI PowI
  type_elims   PowD [elim_format]

inductive
  domains   "FiniteFun(A,B)" \<subseteq> "Fin(A*B)"
  intros
    emptyI:  "0 \<in> A -||> B"
    consI:   "[| a \<in> A;  b \<in> B;  h \<in> A -||> B;  a \<notin> domain(h) |]
              ==> cons(<a,b>,h) \<in> A -||> B"
  type_intros Fin.intros

subsection \<open>Finite Powerset Operator\<close>

lemma Fin_mono: "A<=B ==> Fin(A) \<subseteq> Fin(B)"
apply (unfold Fin.defs)
apply (rule lfp_mono)
apply (rule Fin.bnd_mono)+
apply blast
done

(* @{term"A \<in> Fin(B) ==> A \<subseteq> B"} *)
lemmas FinD = Fin.dom_subset [THEN subsetD, THEN PowD]

(** Induction on finite sets **)

(*Discharging @{term"x\<notin>y"} entails extra work*)
lemma Fin_induct [case_names 0 cons, induct set: Fin]:
    "[| b \<in> Fin(A);
        P(0);
        !!x y. [| x \<in> A;  y \<in> Fin(A);  x\<notin>y;  P(y) |] ==> P(cons(x,y))
     |] ==> P(b)"
apply (erule Fin.induct, simp)
apply (case_tac "a \<in> b")
 apply (erule cons_absorb [THEN ssubst], assumption) (*backtracking!*)
apply simp
done

(** Simplification for Fin **)
declare Fin.intros [simp]

lemma Fin_0: "Fin(0) = {0}"
by (blast intro: Fin.emptyI dest: FinD)

(*The union of two finite sets is finite.*)
lemma Fin_UnI [simp]: "[| b \<in> Fin(A);  c \<in> Fin(A) |] ==> b \<union> c \<in> Fin(A)"
apply (erule Fin_induct)
apply (simp_all add: Un_cons)
done

(*The union of a set of finite sets is finite.*)
lemma Fin_UnionI: "C \<in> Fin(Fin(A)) ==> \<Union>(C) \<in> Fin(A)"
by (erule Fin_induct, simp_all)

(*Every subset of a finite set is finite.*)
lemma Fin_subset_lemma [rule_format]: "b \<in> Fin(A) ==> \<forall>z. z<=b \<longrightarrow> z \<in> Fin(A)"
apply (erule Fin_induct)
apply (simp add: subset_empty_iff)
apply (simp add: subset_cons_iff distrib_simps, safe)
apply (erule_tac b = z in cons_Diff [THEN subst], simp)
done

lemma Fin_subset: "[| c<=b;  b \<in> Fin(A) |] ==> c \<in> Fin(A)"
by (blast intro: Fin_subset_lemma)

lemma Fin_IntI1 [intro,simp]: "b \<in> Fin(A) ==> b \<inter> c \<in> Fin(A)"
by (blast intro: Fin_subset)

lemma Fin_IntI2 [intro,simp]: "c \<in> Fin(A) ==> b \<inter> c \<in> Fin(A)"
by (blast intro: Fin_subset)

lemma Fin_0_induct_lemma [rule_format]:
    "[| c \<in> Fin(A);  b \<in> Fin(A); P(b);
        !!x y. [| x \<in> A;  y \<in> Fin(A);  x \<in> y;  P(y) |] ==> P(y-{x})
     |] ==> c<=b \<longrightarrow> P(b-c)"
apply (erule Fin_induct, simp)
apply (subst Diff_cons)
apply (simp add: cons_subset_iff Diff_subset [THEN Fin_subset])
done

lemma Fin_0_induct:
    "[| b \<in> Fin(A);
        P(b);
        !!x y. [| x \<in> A;  y \<in> Fin(A);  x \<in> y;  P(y) |] ==> P(y-{x})
     |] ==> P(0)"
apply (rule Diff_cancel [THEN subst])
apply (blast intro: Fin_0_induct_lemma)
done

(*Functions from a finite ordinal*)
lemma nat_fun_subset_Fin: "n \<in> nat ==> n->A \<subseteq> Fin(nat*A)"
apply (induct_tac "n")
apply (simp add: subset_iff)
apply (simp add: succ_def mem_not_refl [THEN cons_fun_eq])
apply (fast intro!: Fin.consI)
done

subsection\<open>Finite Function Space\<close>

lemma FiniteFun_mono:
    "[| A<=C;  B<=D |] ==> A -||> B  \<subseteq>  C -||> D"
apply (unfold FiniteFun.defs)
apply (rule lfp_mono)
apply (rule FiniteFun.bnd_mono)+
apply (intro Fin_mono Sigma_mono basic_monos, assumption+)
done

lemma FiniteFun_mono1: "A<=B ==> A -||> A  \<subseteq>  B -||> B"
by (blast dest: FiniteFun_mono)

lemma FiniteFun_is_fun: "h \<in> A -||>B ==> h \<in> domain(h) -> B"
apply (erule FiniteFun.induct, simp)
apply (simp add: fun_extend3)
done

lemma FiniteFun_domain_Fin: "h \<in> A -||>B ==> domain(h) \<in> Fin(A)"
by (erule FiniteFun.induct, simp, simp)

lemmas FiniteFun_apply_type = FiniteFun_is_fun [THEN apply_type]

(*Every subset of a finite function is a finite function.*)
lemma FiniteFun_subset_lemma [rule_format]:
     "b \<in> A-||>B ==> \<forall>z. z<=b \<longrightarrow> z \<in> A-||>B"
apply (erule FiniteFun.induct)
apply (simp add: subset_empty_iff FiniteFun.intros)
apply (simp add: subset_cons_iff distrib_simps, safe)
apply (erule_tac b = z in cons_Diff [THEN subst])
apply (drule spec [THEN mp], assumption)
apply (fast intro!: FiniteFun.intros)
done

lemma FiniteFun_subset: "[| c<=b;  b \<in> A-||>B |] ==> c \<in> A-||>B"
by (blast intro: FiniteFun_subset_lemma)

(** Some further results by Sidi O. Ehmety **)

lemma fun_FiniteFunI [rule_format]: "A \<in> Fin(X) ==> \<forall>f. f \<in> A->B \<longrightarrow> f \<in> A-||>B"
apply (erule Fin.induct)
 apply (simp add: FiniteFun.intros, clarify)
apply (case_tac "a \<in> b")
 apply (simp add: cons_absorb)
apply (subgoal_tac "restrict (f,b) \<in> b -||> B")
 prefer 2 apply (blast intro: restrict_type2)
apply (subst fun_cons_restrict_eq, assumption)
apply (simp add: restrict_def lam_def)
apply (blast intro: apply_funtype FiniteFun.intros
                    FiniteFun_mono [THEN [2] rev_subsetD])
done

lemma lam_FiniteFun: "A \<in> Fin(X) ==> (\<lambda>x\<in>A. b(x)) \<in> A -||> {b(x). x \<in> A}"
by (blast intro: fun_FiniteFunI lam_funtype)

lemma FiniteFun_Collect_iff:
     "f \<in> FiniteFun(A, {y \<in> B. P(y)})
      \<longleftrightarrow> f \<in> FiniteFun(A,B) & (\<forall>x\<in>domain(f). P(f`x))"
apply auto
apply (blast intro: FiniteFun_mono [THEN [2] rev_subsetD])
apply (blast dest: Pair_mem_PiD FiniteFun_is_fun)
apply (rule_tac A1="domain(f)" in
       subset_refl [THEN [2] FiniteFun_mono, THEN subsetD])
 apply (fast dest: FiniteFun_domain_Fin Fin.dom_subset [THEN subsetD])
apply (rule fun_FiniteFunI)
apply (erule FiniteFun_domain_Fin)
apply (rule_tac B = "range (f) " in fun_weaken_type)
 apply (blast dest: FiniteFun_is_fun range_of_fun range_type apply_equality)+
done

subsection\<open>The Contents of a Singleton Set\<close>

definition
  contents :: "i=>i"  where
   "contents(X) == THE x. X = {x}"

lemma contents_eq [simp]: "contents ({x}) = x"
by (simp add: contents_def)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
theory Binary_Relations_Order_Base
  imports
    Binary_Relation_Functions
    HOL.Orderings
begin

lemma le_relI [intro]:
  assumes "\<And>x y. R x y \<Longrightarrow> S x y"
  shows "R \<le> S"
  using assms by (rule predicate2I)

lemma le_relD [dest]:
  assumes "R \<le> S"
  and "R x y"
  shows "S x y"
  using assms by (rule predicate2D)

lemma le_relE:
  assumes "R \<le> S"
  and "R x y"
  obtains "S x y"
  using assms by blast

lemma rel_inv_le_rel_inv_iff [iff]: "R\<inverse> \<le> S\<inverse> \<longleftrightarrow> R \<le> S"
  by blast

lemma restrict_left_top_eq [simp]: "(R :: 'a \<Rightarrow> _)\<restriction>\<^bsub>(\<top> :: 'a \<Rightarrow> bool)\<^esub> = R"
  by (intro ext) auto

end


theory Lam_Funs
  imports "../Nominal"
begin

text {*
  Provides useful definitions for reasoning
  with lambda-terms.
*}

atom_decl name

nominal_datatype lam =
    Var "name"
  | App "lam" "lam"
  | Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [100,100] 100)

text {* The depth of a lambda-term. *}

nominal_primrec
  depth :: "lam \<Rightarrow> nat"
where
  "depth (Var x) = 1"
| "depth (App t1 t2) = (max (depth t1) (depth t2)) + 1"
| "depth (Lam [a].t) = (depth t) + 1"
  apply(finite_guess)+
  apply(rule TrueI)+
  apply(simp add: fresh_nat)
  apply(fresh_guess)+
  done

text {*
  The free variables of a lambda-term. A complication in this
  function arises from the fact that it returns a name set, which
  is not a finitely supported type. Therefore we have to prove
  the invariant that frees always returns a finite set of names.
*}

nominal_primrec (invariant: "\<lambda>s::name set. finite s")
  frees :: "lam \<Rightarrow> name set"
where
  "frees (Var a) = {a}"
| "frees (App t1 t2) = (frees t1) \<union> (frees t2)"
| "frees (Lam [a].t) = (frees t) - {a}"
apply(finite_guess)+
apply(simp)+
apply(simp add: fresh_def)
apply(simp add: supp_of_fin_sets[OF pt_name_inst, OF at_name_inst, OF fs_at_inst[OF at_name_inst]])
apply(simp add: supp_atm)
apply(blast)
apply(fresh_guess)+
done

text {*
  We can avoid the definition of frees by
  using the build in notion of support.
*}

lemma frees_equals_support:
  shows "frees t = supp t"
by (nominal_induct t rule: lam.strong_induct)
   (simp_all add: lam.supp supp_atm abs_supp)

text {* Parallel and single capture-avoiding substitution. *}

fun
  lookup :: "(name\<times>lam) list \<Rightarrow> name \<Rightarrow> lam"
where
  "lookup [] x        = Var x"
| "lookup ((y,e)#\<theta>) x = (if x=y then e else lookup \<theta> x)"

lemma lookup_eqvt[eqvt]:
  fixes pi::"name prm"
  and   \<theta>::"(name\<times>lam) list"
  and   X::"name"
  shows "pi\<bullet>(lookup \<theta> X) = lookup (pi\<bullet>\<theta>) (pi\<bullet>X)"
by (induct \<theta>) (auto simp add: eqvts)

nominal_primrec
  psubst :: "(name\<times>lam) list \<Rightarrow> lam \<Rightarrow> lam"  ("_<_>" [95,95] 105)
where
  "\<theta><(Var x)> = (lookup \<theta> x)"
| "\<theta><(App e\<^sub>1 e\<^sub>2)> = App (\<theta><e\<^sub>1>) (\<theta><e\<^sub>2>)"
| "x\<sharp>\<theta> \<Longrightarrow> \<theta><(Lam [x].e)> = Lam [x].(\<theta><e>)"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)+
apply(fresh_guess)+
done

lemma psubst_eqvt[eqvt]:
  fixes pi::"name prm"
  and   t::"lam"
  shows "pi\<bullet>(\<theta><t>) = (pi\<bullet>\<theta>)<(pi\<bullet>t)>"
by (nominal_induct t avoiding: \<theta> rule: lam.strong_induct)
   (simp_all add: eqvts fresh_bij)

abbreviation
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam" ("_[_::=_]" [100,100,100] 100)
where
  "t[x::=t']  \<equiv> ([(x,t')])<t>"

lemma subst[simp]:
  shows "(Var x)[y::=t'] = (if x=y then t' else (Var x))"
  and   "(App t1 t2)[y::=t'] = App (t1[y::=t']) (t2[y::=t'])"
  and   "x\<sharp>(y,t') \<Longrightarrow> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])"
by (simp_all add: fresh_list_cons fresh_list_nil)

lemma subst_supp:
  shows "supp(t1[a::=t2]) \<subseteq> (((supp(t1)-{a})\<union>supp(t2))::name set)"
apply(nominal_induct t1 avoiding: a t2 rule: lam.strong_induct)
apply(auto simp add: lam.supp supp_atm fresh_prod abs_supp)
apply(blast)+
done

text {*
  Contexts - lambda-terms with a single hole.
  Note that the lambda case in contexts does not bind a
  name, even if we introduce the notation [_]._ for CLam.
*}
nominal_datatype clam =
    Hole ("\<box>" 1000)
  | CAppL "clam" "lam"
  | CAppR "lam" "clam"
  | CLam "name" "clam"  ("CLam [_]._" [100,100] 100)

text {* Filling a lambda-term into a context. *}

nominal_primrec
  filling :: "clam \<Rightarrow> lam \<Rightarrow> lam" ("_\<lbrakk>_\<rbrakk>" [100,100] 100)
where
  "\<box>\<lbrakk>t\<rbrakk> = t"
| "(CAppL E t')\<lbrakk>t\<rbrakk> = App (E\<lbrakk>t\<rbrakk>) t'"
| "(CAppR t' E)\<lbrakk>t\<rbrakk> = App t' (E\<lbrakk>t\<rbrakk>)"
| "(CLam [x].E)\<lbrakk>t\<rbrakk> = Lam [x].(E\<lbrakk>t\<rbrakk>)"
by (rule TrueI)+

text {* Composition od two contexts *}

nominal_primrec
 clam_compose :: "clam \<Rightarrow> clam \<Rightarrow> clam" ("_ \<circ> _" [100,100] 100)
where
  "\<box> \<circ> E' = E'"
| "(CAppL E t') \<circ> E' = CAppL (E \<circ> E') t'"
| "(CAppR t' E) \<circ> E' = CAppR t' (E \<circ> E')"
| "(CLam [x].E) \<circ> E' = CLam [x].(E \<circ> E')"
by (rule TrueI)+

lemma clam_compose:
  shows "(E1 \<circ> E2)\<lbrakk>t\<rbrakk> = E1\<lbrakk>E2\<lbrakk>t\<rbrakk>\<rbrakk>"
by (induct E1 rule: clam.induct) (auto)

end


theory Konig
  imports
    Cofinality
    Cardinal_Library

begin

text\<open>Now, using the Axiom of choice, we can show that all successor
cardinals are regular.\<close>

lemma cf_csucc:
  assumes "InfCard(z)"
  shows "cf(z\<^sup>+) = z\<^sup>+"
proof (rule ccontr)
  assume "cf(z\<^sup>+) \<noteq> z\<^sup>+"
  moreover from \<open>InfCard(z)\<close>
  have "Ord(z\<^sup>+)" "Ord(z)" "Limit(z)" "Limit(z\<^sup>+)" "Card(z\<^sup>+)" "Card(z)"
    using InfCard_csucc Card_is_Ord InfCard_is_Card InfCard_is_Limit
    by fastforce+
  moreover from calculation
  have "cf(z\<^sup>+) < z\<^sup>+"
    using cf_le_cardinal[of "z\<^sup>+", THEN le_iff[THEN iffD1]]
      Card_cardinal_eq
    by simp
  ultimately
  obtain G where "G:cf(z\<^sup>+)\<rightarrow> z\<^sup>+" "\<forall>\<beta>\<in>z\<^sup>+. \<exists>y\<in>cf(z\<^sup>+). \<beta> < G`y"
    using Limit_cofinal_fun_lt[of "z\<^sup>+" _ "cf(z\<^sup>+)"] Ord_cf
      cf_le_cf_fun[of "z\<^sup>+" "cf(z\<^sup>+)"] le_refl[of "cf(z\<^sup>+)"]
    by auto
  with \<open>Card(z)\<close> \<open>Card(z\<^sup>+)\<close> \<open>Ord(z\<^sup>+)\<close>
  have "\<forall>\<beta>\<in>cf(z\<^sup>+). |G`\<beta>| \<le> z"
    using apply_type[of G "cf(z\<^sup>+)" "\<lambda>_. z\<^sup>+", THEN ltI] Card_lt_iff[THEN iffD2]
      Ord_in_Ord[OF Card_is_Ord, of "z\<^sup>+"] cardinal_lt_csucc_iff[THEN iffD1]
    by auto
  from \<open>cf(z\<^sup>+) < z\<^sup>+\<close> \<open>InfCard(z)\<close> \<open>Ord(z)\<close>
  have "cf(z\<^sup>+) \<lesssim> z"
    using cardinal_lt_csucc_iff[of "z" "cf(z\<^sup>+)"] Card_csucc[of "z"]
      le_Card_iff[of "z" "cf(z\<^sup>+)"] InfCard_is_Card
      Card_lt_iff[of "cf(z\<^sup>+)" "z\<^sup>+"] lt_Ord[of "cf(z\<^sup>+)" "z\<^sup>+"]
    by simp
  with \<open>cf(z\<^sup>+) < z\<^sup>+\<close> \<open>\<forall>\<beta>\<in>cf(z\<^sup>+). |G`\<beta>| \<le> _\<close> \<open>InfCard(z)\<close>
  have "|\<Union>\<beta>\<in>cf(z\<^sup>+). G`\<beta>| \<le> z"
    using InfCard_csucc[of z]
      subset_imp_lepoll[THEN lepoll_imp_cardinal_le, of "\<Union>\<beta>\<in>cf(z\<^sup>+). G`\<beta>" "z"]
    by (rule_tac lepoll_imp_cardinal_UN_le) auto
  moreover
  note \<open>Ord(z)\<close>
  moreover from \<open>\<forall>\<beta>\<in>z\<^sup>+. \<exists>y\<in>cf(z\<^sup>+). \<beta> < G`y\<close> and this
  have "z\<^sup>+ \<subseteq> (\<Union>\<beta>\<in>cf(z\<^sup>+). G`\<beta>)"
    by (blast dest:ltD)
  ultimately
  have "z\<^sup>+ \<le> z"
    using subset_imp_le_cardinal[of "z\<^sup>+" "\<Union>\<beta>\<in>cf(z\<^sup>+). G`\<beta>"] le_trans
      InfCard_is_Card Card_csucc[of z] Card_cardinal_eq
    by auto
  with \<open>Ord(z)\<close>
  show "False"
    using lt_csucc[of z] not_lt_iff_le[THEN iffD2, of z "z\<^sup>+"]
      Card_csucc[THEN Card_is_Ord]
    by auto
qed

text\<open>And this finishes the calculation of cofinality of Alephs.\<close>

lemma cf_Aleph_succ: "Ord(z) \<Longrightarrow> cf(\<aleph>\<^bsub>succ(z)\<^esub>) = \<aleph>\<^bsub>succ(z)\<^esub>"
  using Aleph_succ cf_csucc InfCard_Aleph by simp

subsection\<open>König's Theorem\label{sec:konig}\<close>

text\<open>We end this section by proving König's Theorem on the cofinality
of cardinal exponentiation. This is a strengthening of Cantor's theorem
and it is essentially the only basic way to prove strict cardinal
inequalities.

It is proved rather straightforwardly with the tools already developed.\<close>

lemma konigs_theorem:
  notes [dest] = InfCard_is_Card Card_is_Ord
    and [trans] = lt_trans1 lt_trans2
  assumes
    "InfCard(\<kappa>)" "InfCard(\<nu>)" "cf(\<kappa>) \<le> \<nu>"
  shows
    "\<kappa> < \<kappa>\<^bsup>\<up>\<nu>\<^esup>"
  using assms(1,2) Card_cexp
proof (intro not_le_iff_lt[THEN iffD1] notI)
  assume "\<kappa>\<^bsup>\<up>\<nu>\<^esup> \<le> \<kappa>"
  moreover
  note \<open>InfCard(\<kappa>)\<close>
  moreover from calculation
  have "\<nu> \<rightarrow> \<kappa> \<lesssim> \<kappa>"
    using Card_cardinal_eq[OF InfCard_is_Card, symmetric]
      Card_le_imp_lepoll
    unfolding cexp_def by simp
  ultimately
  obtain G where "G \<in> surj(\<kappa>, \<nu> \<rightarrow> \<kappa>)"
    using inj_imp_surj[OF _ function_space_nonempty,
        OF _ nat_into_InfCard] by blast
  from assms
  obtain f where "f:\<nu> \<rightarrow> \<kappa>" "cf_fun(f,\<kappa>)"
    using cf_le_cf_fun[OF _ InfCard_is_Limit] by blast
  define H where "H(\<alpha>) \<equiv> \<mu> x. x\<in>\<kappa> \<and> (\<forall>m<f`\<alpha>. G`m`\<alpha> \<noteq> x)"
    (is "_ \<equiv> \<mu> x. ?P(\<alpha>,x)") for \<alpha>
  have H_satisfies: "?P(\<alpha>,H(\<alpha>))" if "\<alpha> \<in> \<nu>" for \<alpha>
  proof -
    obtain h where "?P(\<alpha>,h)"
    proof -
      from \<open>\<alpha>\<in>\<nu>\<close> \<open>f:\<nu> \<rightarrow> \<kappa>\<close> \<open>InfCard(\<kappa>)\<close>
      have "f`\<alpha> < \<kappa>"
        using apply_type[of _ _ "\<lambda>_ . \<kappa>"] by (auto intro:ltI)
      have "|{G`m`\<alpha> . m \<in> {x\<in>\<kappa> . x < f`\<alpha>}}| \<le> |{x\<in>\<kappa> . x < f`\<alpha>}|"
        using cardinal_RepFun_le by simp
      also from \<open>f`\<alpha> < \<kappa>\<close> \<open>InfCard(\<kappa>)\<close>
      have "|{x\<in>\<kappa> . x < f`\<alpha>}| < |\<kappa>|"
        using Card_lt_iff[OF lt_Ord, THEN iffD2, of "f`\<alpha>" \<kappa> \<kappa>]
          Ord_eq_Collect_lt[of "f`\<alpha>" \<kappa>] Card_cardinal_eq
        by force
      finally
      have "|{G`m`\<alpha> . m \<in> {x\<in>\<kappa> . x < f`\<alpha>}}| < |\<kappa>|" .
      moreover from \<open>f`\<alpha> < \<kappa>\<close> \<open>InfCard(\<kappa>)\<close>
      have "m<f`\<alpha> \<Longrightarrow> m\<in>\<kappa>" for m
        using Ord_trans[of m "f`\<alpha>" \<kappa>]
        by (auto dest:ltD)
      ultimately
      have "\<exists>h. ?P(\<alpha>,h)"
        using lt_cardinal_imp_not_subset by blast
      with that
      show ?thesis by blast
    qed
    with assms
    show "?P(\<alpha>,H(\<alpha>))"
      using LeastI[of "?P(\<alpha>)" h] lt_Ord Ord_in_Ord
      unfolding H_def by fastforce
  qed
  then
  have "(\<lambda>\<alpha>\<in>\<nu>. H(\<alpha>)): \<nu> \<rightarrow> \<kappa>"
    using lam_type by auto
  with \<open>G \<in> surj(\<kappa>, \<nu> \<rightarrow> \<kappa>)\<close>
  obtain n where "n\<in>\<kappa>" "G`n = (\<lambda>\<alpha>\<in>\<nu>. H(\<alpha>))"
    unfolding surj_def by blast
  moreover
  note \<open>InfCard(\<kappa>)\<close> \<open>f: \<nu> \<rightarrow> \<kappa>\<close> \<open>cf_fun(f,_)\<close>
  ultimately
  obtain \<alpha> where "n < f`\<alpha>" "\<alpha>\<in>\<nu>"
    using Limit_cofinal_fun_lt[OF InfCard_is_Limit] by blast
  moreover from calculation and \<open>G`n = (\<lambda>\<alpha>\<in>\<nu>. H(\<alpha>))\<close>
  have "G`n`\<alpha> = H(\<alpha>)"
    using ltD by simp
  moreover from calculation and H_satisfies
  have "\<forall>m<f`\<alpha>. G`m`\<alpha> \<noteq> H(\<alpha>)" by simp
  ultimately
  show "False" by blast
qed blast+

lemma cf_cexp:
  assumes
    "Card(\<kappa>)" "InfCard(\<nu>)" "2 \<le> \<kappa>"
  shows
    "\<nu> < cf(\<kappa>\<^bsup>\<up>\<nu>\<^esup>)"
proof (rule ccontr)
  assume "\<not> \<nu> < cf(\<kappa>\<^bsup>\<up>\<nu>\<^esup>)"
  with \<open>InfCard(\<nu>)\<close>
  have "cf(\<kappa>\<^bsup>\<up>\<nu>\<^esup>) \<le> \<nu>"
    using not_lt_iff_le Ord_cf InfCard_is_Card Card_is_Ord by simp
  moreover
  note assms
  moreover from calculation
  have "InfCard(\<kappa>\<^bsup>\<up>\<nu>\<^esup>)" using InfCard_cexp by simp
  moreover from calculation
  have "\<kappa>\<^bsup>\<up>\<nu>\<^esup> < (\<kappa>\<^bsup>\<up>\<nu>\<^esup>)\<^bsup>\<up>\<nu>\<^esup>"
    using konigs_theorem by simp
  ultimately
  show "False" using cexp_cexp_cmult InfCard_csquare_eq by auto
qed

text\<open>Finally, the next two corollaries illustrate the only possible
exceptions to the value of the cardinality of the continuum: The limit
cardinals of countable cofinality. That these are the only exceptions
is a consequence of Easton's Theorem~\<^cite>\<open>\<open>Thm 15.18\<close> in "Jech_Millennium"\<close>.\<close>

corollary cf_continuum: "\<aleph>\<^bsub>0\<^esub> < cf(2\<^bsup>\<up>\<aleph>\<^bsub>0\<^esub>\<^esup>)"
  using cf_cexp InfCard_Aleph nat_into_Card by simp

corollary continuum_not_eq_Aleph_nat: "2\<^bsup>\<up>\<aleph>\<^bsub>0\<^esub>\<^esup> \<noteq> \<aleph>\<^bsub>\<omega>\<^esub>"
  using cf_continuum cf_Aleph_Limit[OF Limit_nat] cf_nat
    Aleph_zero_eq_nat by auto

end


theory topo_interior_algebra
  imports topo_operators_basic
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Interior algebra\<close>
text\<open>\noindent{We define a topological Boolean algebra taking the interior operator as primitive and verify some properties.}\<close>

text\<open>\noindent{Declares a primitive (unconstrained) interior operation and defines others from it.}\<close>
consts \<I>::"\<sigma>\<Rightarrow>\<sigma>"
abbreviation "\<C> \<equiv> \<I>\<^sup>d" \<comment>\<open> closure \<close>
abbreviation "\<B> \<equiv> \<B>\<^sub>I \<I>" \<comment>\<open> border \<close>
abbreviation "\<F> \<equiv> \<F>\<^sub>I \<I>" \<comment>\<open> frontier \<close>

subsection \<open>Basic properties\<close>

text\<open>\noindent{Verifies minimal conditions under which operators resulting from conversion functions coincide.}\<close>
lemma ICdual:  "\<I> \<^bold>\<equiv> \<C>\<^sup>d" using dual_symm equal_op_def by auto
lemma IB_rel: "Int_2 \<I> \<Longrightarrow> \<I> \<^bold>\<equiv> \<I>\<^sub>B \<B>" by (smt Br_int_def Int_br_def dEXP_def diff_def equal_op_def)
lemma IF_rel: "Int_2 \<I> \<Longrightarrow> \<I> \<^bold>\<equiv> \<I>\<^sub>F \<F>" using EXP_def EXP_dual2 Fr_int_def IB_rel Int_br_def Int_fr_def compl_def diff_def equal_op_def meet_def by fastforce

text\<open>\noindent{Fixed-point and other operators are interestingly related.}\<close>
lemma fp1: "Int_2 \<I> \<Longrightarrow> \<I>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B>\<^sup>c" by (smt Br_int_def IB_rel Int_br_def compl_def diff_def dimp_def equal_op_def)
lemma fp2: "Int_2 \<I> \<Longrightarrow> \<B>\<^sup>f\<^sup>p \<^bold>\<equiv> \<I>\<^sup>c" using fp1 unfolding compl_def dimp_def equal_op_def by smt
lemma fp3: "Int_2 \<I> \<Longrightarrow> \<C>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B>\<^sup>d" by (metis (no_types) dual_comp eq_ext' fp2 ofp_c ofp_d ofp_invol)
lemma fp4: "Int_2 \<I> \<Longrightarrow> (\<B>\<^sup>d)\<^sup>f\<^sup>p \<^bold>\<equiv> \<C>" by (smt dimp_def equal_op_def fp3)
lemma fp5: "Int_2 \<I> \<Longrightarrow> \<F>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B> \<^bold>\<squnion> (\<C>\<^sup>c)" by (smt BC_rel Br_cl_def CF_rel Cl_fr_def FI2 Fr_2_def compl_def dimp_def eq_ext' equal_op_def join_def meet_def)

text\<open>\noindent{Define some fixed-point predicates and prove some properties.}\<close>
abbreviation openset ("Op") where "Op A \<equiv> fp \<I> A"
abbreviation closedset ("Cl") where "Cl A \<equiv> fp \<C> A"
abbreviation borderset ("Br") where "Br A \<equiv> fp \<B> A"
abbreviation frontierset ("Fr") where "Fr A \<equiv> fp \<F> A"

lemma Int_Open: "Int_4 \<I> \<Longrightarrow> \<forall>A. Op(\<I> A)" by (simp add: IDEM_def)
lemma Cl_Closed: "Int_4 \<I> \<Longrightarrow> \<forall>A. Cl(\<C> A)" using IC4 IDEM_def by blast
lemma Br_Border: "Int_1a \<I> \<Longrightarrow> \<forall>A. Br(\<B> A)" by (metis Br_int_def MONO_MULTa MONO_def diff_def)
text\<open>\noindent{In contrast, there is no analogous fixed-point result for frontier:}\<close>
lemma "\<II> \<I> \<Longrightarrow> \<forall>A. Fr(\<F> A)" nitpick oops (*counterexample even if assuming all interior conditions*)

lemma OpCldual: "\<forall>A. Cl A \<longleftrightarrow> Op(\<^bold>\<midarrow>A)" by (simp add: fp_d)
lemma ClOpdual: "\<forall>A. Op A \<longleftrightarrow> Cl(\<^bold>\<midarrow>A)" by (simp add: compl_def dual_def)
lemma Fr_ClBr: "Int_2 \<I> \<Longrightarrow> \<forall>A. Fr(A) = (Cl(A) \<and> Br(A))" using BF_rel Br_fr_def CF_rel Cl_fr_def eq_ext' join_def meet_def by fastforce
lemma Cl_F: "Int_1a \<I> \<Longrightarrow> Int_2 \<I> \<Longrightarrow> Int_4 \<I> \<Longrightarrow> \<forall>A. Cl(\<F> A)" by (metis CF_rel Cl_fr_def FI4 Fr_4_def eq_ext' join_def)

end


(*  Title:      HOL/ZF/Zet.thy
    Author:     Steven Obua

    Introduces a type 'a zet of ZF representable sets.
    See "Partizan Games in Isabelle/HOLZF", available from http://www4.in.tum.de/~obua/partizan
*)

theory Zet
imports HOLZF
begin

definition "zet = {A :: 'a set | A f z. inj_on f A \<and> f ` A \<subseteq> explode z}"

typedef 'a zet = "zet :: 'a set set"
  unfolding zet_def by blast

definition zin :: "'a \<Rightarrow> 'a zet \<Rightarrow> bool" where
  "zin x A == x \<in> (Rep_zet A)"

lemma zet_ext_eq: "(A = B) = (! x. zin x A = zin x B)"
  by (auto simp add: Rep_zet_inject[symmetric] zin_def)

definition zimage :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a zet \<Rightarrow> 'b zet" where
  "zimage f A == Abs_zet (image f (Rep_zet A))"

lemma zet_def': "zet = {A :: 'a set | A f z. inj_on f A \<and> f ` A = explode z}"
  apply (rule set_eqI)
  apply (auto simp add: zet_def)
  apply (rule_tac x=f in exI)
  apply auto
  apply (rule_tac x="Sep z (\<lambda> y. y \<in> (f ` x))" in exI)
  apply (auto simp add: explode_def Sep)
  done

lemma image_zet_rep: "A \<in> zet \<Longrightarrow> ? z . g ` A = explode z"
  apply (auto simp add: zet_def')
  apply (rule_tac x="Repl z (g o (inv_into A f))" in exI)
  apply (simp add: explode_Repl_eq)
  apply (subgoal_tac "explode z = f ` A")
  apply (simp_all add: image_comp [symmetric])
  done

lemma zet_image_mem:
  assumes Azet: "A \<in> zet"
  shows "g ` A \<in> zet"
proof -
  from Azet have "? (f :: _ \<Rightarrow> ZF). inj_on f A"
    by (auto simp add: zet_def')
  then obtain f where injf: "inj_on (f :: _ \<Rightarrow> ZF) A"
    by auto
  let ?w = "f o (inv_into A g)"
  have subset: "(inv_into A g) ` (g ` A) \<subseteq> A"
    by (auto simp add: inv_into_into)
  have "inj_on (inv_into A g) (g ` A)" by (simp add: inj_on_inv_into)
  then have injw: "inj_on ?w (g ` A)"
    apply (rule comp_inj_on)
    apply (rule subset_inj_on[where B=A])
    apply (auto simp add: subset injf)
    done
  show ?thesis
    apply (simp add: zet_def' image_comp)
    apply (rule exI[where x="?w"])
    apply (simp add: injw image_zet_rep Azet)
    done
qed

lemma Rep_zimage_eq: "Rep_zet (zimage f A) = image f (Rep_zet A)"
  apply (simp add: zimage_def)
  apply (subst Abs_zet_inverse)
  apply (simp_all add: Rep_zet zet_image_mem)
  done

lemma zimage_iff: "zin y (zimage f A) = (? x. zin x A & y = f x)"
  by (auto simp add: zin_def Rep_zimage_eq)

definition zimplode :: "ZF zet \<Rightarrow> ZF" where
  "zimplode A == implode (Rep_zet A)"

definition zexplode :: "ZF \<Rightarrow> ZF zet" where
  "zexplode z == Abs_zet (explode z)"

lemma Rep_zet_eq_explode: "? z. Rep_zet A = explode z"
  by (rule image_zet_rep[where g="\<lambda> x. x",OF Rep_zet, simplified])

lemma zexplode_zimplode: "zexplode (zimplode A) = A"
  apply (simp add: zimplode_def zexplode_def)
  apply (simp add: implode_def)
  apply (subst f_inv_into_f[where y="Rep_zet A"])
  apply (auto simp add: Rep_zet_inverse Rep_zet_eq_explode image_def)
  done

lemma explode_mem_zet: "explode z \<in> zet"
  apply (simp add: zet_def')
  apply (rule_tac x="% x. x" in exI)
  apply (auto simp add: inj_on_def)
  done

lemma zimplode_zexplode: "zimplode (zexplode z) = z"
  apply (simp add: zimplode_def zexplode_def)
  apply (subst Abs_zet_inverse)
  apply (auto simp add: explode_mem_zet implode_explode)
  done

lemma zin_zexplode_eq: "zin x (zexplode A) = Elem x A"
  apply (simp add: zin_def zexplode_def)
  apply (subst Abs_zet_inverse)
  apply (simp_all add: explode_Elem explode_mem_zet)
  done

lemma comp_zimage_eq: "zimage g (zimage f A) = zimage (g o f) A"
  apply (simp add: zimage_def)
  apply (subst Abs_zet_inverse)
  apply (simp_all add: image_comp zet_image_mem Rep_zet)
  done

definition zunion :: "'a zet \<Rightarrow> 'a zet \<Rightarrow> 'a zet" where
  "zunion a b \<equiv> Abs_zet ((Rep_zet a) \<union> (Rep_zet b))"

definition zsubset :: "'a zet \<Rightarrow> 'a zet \<Rightarrow> bool" where
  "zsubset a b \<equiv> ! x. zin x a \<longrightarrow> zin x b"

lemma explode_union: "explode (union a b) = (explode a) \<union> (explode b)"
  apply (rule set_eqI)
  apply (simp add: explode_def union)
  done

lemma Rep_zet_zunion: "Rep_zet (zunion a b) = (Rep_zet a) \<union> (Rep_zet b)"
proof -
  from Rep_zet[of a] have "? f z. inj_on f (Rep_zet a) \<and> f ` (Rep_zet a) = explode z"
    by (auto simp add: zet_def')
  then obtain fa za where a:"inj_on fa (Rep_zet a) \<and> fa ` (Rep_zet a) = explode za"
    by blast
  from a have fa: "inj_on fa (Rep_zet a)" by blast
  from a have za: "fa ` (Rep_zet a) = explode za" by blast
  from Rep_zet[of b] have "? f z. inj_on f (Rep_zet b) \<and> f ` (Rep_zet b) = explode z"
    by (auto simp add: zet_def')
  then obtain fb zb where b:"inj_on fb (Rep_zet b) \<and> fb ` (Rep_zet b) = explode zb"
    by blast
  from b have fb: "inj_on fb (Rep_zet b)" by blast
  from b have zb: "fb ` (Rep_zet b) = explode zb" by blast
  let ?f = "(\<lambda> x. if x \<in> (Rep_zet a) then Opair (fa x) (Empty) else Opair (fb x) (Singleton Empty))"
  let ?z = "CartProd (union za zb) (Upair Empty (Singleton Empty))"
  have se: "Singleton Empty \<noteq> Empty"
    apply (auto simp add: Ext Singleton)
    apply (rule exI[where x=Empty])
    apply (simp add: Empty)
    done
  show ?thesis
    apply (simp add: zunion_def)
    apply (subst Abs_zet_inverse)
    apply (auto simp add: zet_def)
    apply (rule exI[where x = ?f])
    apply (rule conjI)
    apply (auto simp add: inj_on_def Opair inj_onD[OF fa] inj_onD[OF fb] se se[symmetric])
    apply (rule exI[where x = ?z])
    apply (insert za zb)
    apply (auto simp add: explode_def CartProd union Upair Opair)
    done
qed

lemma zunion: "zin x (zunion a b) = ((zin x a) \<or> (zin x b))"
  by (auto simp add: zin_def Rep_zet_zunion)

lemma zimage_zexplode_eq: "zimage f (zexplode z) = zexplode (Repl z f)"
  by (simp add: zet_ext_eq zin_zexplode_eq Repl zimage_iff)

lemma range_explode_eq_zet: "range explode = zet"
  apply (rule set_eqI)
  apply (auto simp add: explode_mem_zet)
  apply (drule image_zet_rep)
  apply (simp add: image_def)
  apply auto
  apply (rule_tac x=z in exI)
  apply auto
  done

lemma Elem_zimplode: "(Elem x (zimplode z)) = (zin x z)"
  apply (simp add: zimplode_def)
  apply (subst Elem_implode)
  apply (simp_all add: zin_def Rep_zet range_explode_eq_zet)
  done

definition zempty :: "'a zet" where
  "zempty \<equiv> Abs_zet {}"

lemma zempty[simp]: "\<not> (zin x zempty)"
  by (auto simp add: zin_def zempty_def Abs_zet_inverse zet_def)

lemma zimage_zempty[simp]: "zimage f zempty = zempty"
  by (auto simp add: zet_ext_eq zimage_iff)

lemma zunion_zempty_left[simp]: "zunion zempty a = a"
  by (simp add: zet_ext_eq zunion)

lemma zunion_zempty_right[simp]: "zunion a zempty = a"
  by (simp add: zet_ext_eq zunion)

lemma zimage_id[simp]: "zimage id A = A"
  by (simp add: zet_ext_eq zimage_iff)

lemma zimage_cong[fundef_cong]: "\<lbrakk> M = N; !! x. zin x N \<Longrightarrow> f x = g x \<rbrakk> \<Longrightarrow> zimage f M = zimage g N"
  by (auto simp add: zet_ext_eq zimage_iff)

end


(*
Author:  Christian Sternagel <c.sternagel@gmail.com>
Author:  René Thiemann <rene.thiemann@uibk.ac.at>
License: LGPL
*)
subsection \<open>A Concrete Unification Algorithm\<close>

theory Unification
  imports
    Abstract_Unification
    Option_Monad
begin

definition
  "decompose s t =
    (case (s, t) of
      (Fun f ss, Fun g ts) \<Rightarrow> if f = g then zip_option ss ts else None
    | _ \<Rightarrow> None)"

lemma decompose_Some [dest]:
  "decompose (Fun f ss) (Fun g ts) = Some E \<Longrightarrow>
    f = g \<and> length ss = length ts \<and> E = zip ss ts"
  by (cases "f = g") (auto simp: decompose_def)

lemma decompose_None [dest]:
  "decompose (Fun f ss) (Fun g ts) = None \<Longrightarrow> f \<noteq> g \<or> length ss \<noteq> length ts"
  by (cases "f = g") (auto simp: decompose_def)

text \<open>Applying a substitution to a list of equations.\<close>
definition
  subst_list :: "('f, 'v) subst \<Rightarrow> ('f, 'v) equation list \<Rightarrow> ('f, 'v) equation list"
  where
    "subst_list \<sigma> ys = map (\<lambda>p. (fst p \<cdot> \<sigma>, snd p \<cdot> \<sigma>)) ys"

lemma mset_subst_list [simp]:
  "mset (subst_list (subst x t) ys) = subst_mset (subst x t) (mset ys)"
  by (auto simp: subst_mset_def subst_list_def)

lemma subst_list_append:
  "subst_list \<sigma> (xs @ ys) = subst_list \<sigma> xs @ subst_list \<sigma> ys"
by (auto simp: subst_list_def)

function (sequential)
  unify ::
    "('f, 'v) equation list \<Rightarrow> ('v \<times> ('f, 'v) term) list \<Rightarrow> ('v \<times> ('f, 'v) term) list option"
where
  "unify [] bs = Some bs"
| "unify ((Fun f ss, Fun g ts) # E) bs =
    (case decompose (Fun f ss) (Fun g ts) of
      None \<Rightarrow> None
    | Some us \<Rightarrow> unify (us @ E) bs)"
| "unify ((Var x, t) # E) bs =
    (if t = Var x then unify E bs
    else if x \<in> vars_term t then None
    else unify (subst_list (subst x t) E) ((x, t) # bs))"
| "unify ((t, Var x) # E) bs =
    (if x \<in> vars_term t then None
    else unify (subst_list (subst x t) E) ((x, t) # bs))"
  by pat_completeness auto
termination
  by (standard, rule wf_inv_image [of "unif\<inverse>" "mset \<circ> fst", OF wf_converse_unif])
     (force intro: UNIF1.intros simp: unif_def union_commute)+

definition subst_of :: "('v \<times> ('f, 'v) term) list \<Rightarrow> ('f, 'v) subst"
  where
    "subst_of ss = List.foldr (\<lambda>(x, t) \<sigma>. \<sigma> \<circ>\<^sub>s subst x t) ss Var"

text \<open>Computing the mgu of two terms.\<close>
fun mgu :: "('f, 'v) term \<Rightarrow> ('f, 'v) term \<Rightarrow> ('f, 'v) subst option" where
  "mgu s t =
    (case unify [(s, t)] [] of
      None \<Rightarrow> None
    | Some res \<Rightarrow> Some (subst_of res))"

lemma subst_of_simps [simp]:
  "subst_of [] = Var"
  "subst_of ((x, Var x) # ss) = subst_of ss"
  "subst_of (b # ss) = subst_of ss \<circ>\<^sub>s subst (fst b) (snd b)"
  by (simp_all add: subst_of_def split: prod.splits)

lemma subst_of_append [simp]:
  "subst_of (ss @ ts) = subst_of ts \<circ>\<^sub>s subst_of ss"
  by (induct ss) (auto simp: ac_simps)

text \<open>The concrete algorithm \<open>unify\<close> can be simulated by the inference
  rules of \<open>UNIF\<close>.\<close>
lemma unify_Some_UNIF:
  assumes "unify E bs = Some cs"
  shows "\<exists>ds ss. cs = ds @ bs \<and> subst_of ds = compose ss \<and> UNIF ss (mset E) {#}"
using assms
proof (induction E bs arbitrary: cs rule: unify.induct)
  case (2 f ss g ts E bs)
  then obtain us where "decompose (Fun f ss) (Fun g ts) = Some us"
    and [simp]: "f = g" "length ss = length ts" "us = zip ss ts"
    and "unify (us @ E) bs = Some cs" by (auto split: option.splits)
  from "2.IH" [OF this(1, 5)] obtain xs ys
    where "cs = xs @ bs"
    and [simp]: "subst_of xs = compose ys"
    and *: "UNIF ys (mset (us @ E)) {#}" by auto
  then have "UNIF (Var # ys) (mset ((Fun f ss, Fun g ts) # E)) {#}"
    by (force intro: UNIF1.decomp simp: ac_simps)
  moreover have "cs = xs @ bs" by fact
  moreover have "subst_of xs = compose (Var # ys)" by simp
  ultimately show ?case by blast
next
  case (3 x t E bs)
  show ?case
  proof (cases "t = Var x")
    assume "t = Var x"
    then show ?case
      using 3 by auto (metis UNIF.step compose_simps(2) UNIF1.trivial)
  next
    assume "t \<noteq> Var x"
    with 3 obtain xs ys
      where [simp]: "cs = (ys @ [(x, t)]) @ bs"
      and [simp]: "subst_of ys = compose xs"
      and "x \<notin> vars_term t"
      and "UNIF xs (mset (subst_list (subst x t) E)) {#}"
        by (cases "x \<in> vars_term t") force+
    then have "UNIF (subst x t # xs) (mset ((Var x, t) # E)) {#}"
      by (force intro: UNIF1.Var_left simp: ac_simps)
    moreover have "cs = (ys @ [(x, t)]) @ bs" by simp
    moreover have "subst_of (ys @ [(x, t)]) = compose (subst x t # xs)" by simp
    ultimately show ?case by blast
  qed
next
  case (4 f ss x E bs)
  with 4 obtain xs ys
    where [simp]: "cs = (ys @ [(x, Fun f ss)]) @ bs"
    and [simp]: "subst_of ys = compose xs"
    and "x \<notin> vars_term (Fun f ss)"
    and "UNIF xs (mset (subst_list (subst x (Fun f ss)) E)) {#}"
      by (cases "x \<in> vars_term (Fun f ss)") force+
  then have "UNIF (subst x (Fun f ss) # xs) (mset ((Fun f ss, Var x) # E)) {#}"
    by (force intro: UNIF1.Var_right simp: ac_simps)
  moreover have "cs = (ys @ [(x, Fun f ss)]) @ bs" by simp
  moreover have "subst_of (ys @ [(x, Fun f ss)]) = compose (subst x (Fun f ss) # xs)" by simp
  ultimately show ?case by blast
qed force

lemma unify_sound:
  assumes "unify E [] = Some cs"
  shows "is_imgu (subst_of cs) (set E)"
proof -
  from unify_Some_UNIF [OF assms] obtain ss
    where "subst_of cs = compose ss"
    and "UNIF ss (mset E) {#}" by auto
  with UNIF_empty_imp_is_mgu_compose [OF this(2)]
    and UNIF_idemp [OF this(2)]
    show ?thesis
      by (auto simp add: is_imgu_def is_mgu_def)
         (metis subst_compose_assoc)
qed

text \<open>If \<open>unify\<close> gives up, then the given set of equations
  cannot be reduced to the empty set by \<open>UNIF\<close>.\<close>
lemma unify_None:
  assumes "unify E ss = None"
  shows "\<exists>E'. E' \<noteq> {#} \<and> (mset E, E') \<in> unif\<^sup>!"
using assms
proof (induction E ss rule: unify.induct)
  case (1 bs)
  then show ?case by simp
next
  case (2 f ss g ts E bs)
  moreover
  { assume *: "decompose (Fun f ss) (Fun g ts) = None"
    have ?case
    proof (cases "unifiable (set E)")
      case True
      then have "(mset E, {#}) \<in> unif\<^sup>*"
        by (simp add: unifiable_imp_empty)
      from unif_rtrancl_mono [OF this, of "{#(Fun f ss, Fun g ts)#}"] obtain \<sigma>
        where "(mset E + {#(Fun f ss, Fun g ts)#}, {#(Fun f ss \<cdot> \<sigma>, Fun g ts \<cdot> \<sigma>)#}) \<in> unif\<^sup>*"
        by (auto simp: subst_mset_def)
      moreover have "{#(Fun f ss \<cdot> \<sigma>, Fun g ts \<cdot> \<sigma>)#} \<in> NF unif"
        using decompose_None [OF *]
        by (auto simp: single_is_union NF_def unif_def elim!: UNIF1.cases)
           (metis length_map)
      ultimately show ?thesis
        by auto (metis normalizability_I add_mset_not_empty)
    next
      case False
      moreover have "\<not> unifiable {(Fun f ss, Fun g ts)}"
        using * by (auto simp: unifiable_def)
      ultimately have "\<not> unifiable (set ((Fun f ss, Fun g ts) # E))" by (auto simp: unifiable_def unifiers_def)
      then show ?thesis by (simp add: not_unifiable_imp_not_empty_NF)
    qed }
  moreover
  { fix us
    assume *: "decompose (Fun f ss) (Fun g ts) = Some us"
      and "unify (us @ E) bs = None"
    from "2.IH" [OF this] obtain E'
      where "E' \<noteq> {#}" and "(mset (us @ E), E') \<in> unif\<^sup>!" by blast
    moreover have "(mset ((Fun f ss, Fun g ts) # E), mset (us @ E)) \<in> unif"
    proof -
      have "g = f" and "length ss = length ts" and "us = zip ss ts"
        using * by auto
      then show ?thesis
        by (auto intro: UNIF1.decomp simp: unif_def ac_simps)
    qed
    ultimately have ?case by auto }
  ultimately show ?case by (auto split: option.splits)
next
  case (3 x t E bs)
  { assume [simp]: "t = Var x"
    obtain E' where "E' \<noteq> {#}" and "(mset E, E') \<in> unif\<^sup>!" using 3 by auto
    moreover have "(mset ((Var x, t) # E), mset E) \<in> unif"
      by (auto intro: UNIF1.trivial simp: unif_def)
    ultimately have ?case by auto }
  moreover
  { assume *: "t \<noteq> Var x" "x \<notin> vars_term t"
    then obtain E' where "E' \<noteq> {#}"
      and "(mset (subst_list (subst x t) E), E') \<in> unif\<^sup>!" using 3 by auto
    moreover have "(mset ((Var x, t) # E), mset (subst_list (subst x t) E)) \<in> unif"
      using * by (auto intro: UNIF1.Var_left simp: unif_def)
    ultimately have ?case by auto }
  moreover
  { assume *: "t \<noteq> Var x" "x \<in> vars_term t"
    then have "x \<in> vars_term t" "is_Fun t" by auto
    then have "\<not> unifiable {(Var x, t)}" by (rule in_vars_is_Fun_not_unifiable)
    then have **: "\<not> unifiable {(Var x \<cdot> \<sigma>, t \<cdot> \<sigma>)}" for \<sigma> :: "('b, 'a) subst"
      using subst_set_reflects_unifiable [of \<sigma> "{(Var x, t)}"] by (auto simp: subst_set_def)
    have ?case
    proof (cases "unifiable (set E)")
      case True
      then have "(mset E, {#}) \<in> unif\<^sup>*"
        by (simp add: unifiable_imp_empty)
      from unif_rtrancl_mono [OF this, of "{#(Var x, t)#}"] obtain \<sigma>
        where "(mset E + {#(Var x, t)#}, {#(Var x \<cdot> \<sigma>, t \<cdot> \<sigma>)#}) \<in> unif\<^sup>*"
        by (auto simp: subst_mset_def)
      moreover obtain E' where "E' \<noteq> {#}"
        and "({#(Var x \<cdot> \<sigma>, t \<cdot> \<sigma>)#}, E') \<in> unif\<^sup>!"
        using not_unifiable_imp_not_empty_NF and **
          by (metis set_mset_single)
      ultimately show ?thesis by auto
    next
      case False
      moreover have "\<not> unifiable {(Var x, t)}"
        using * by (force simp: unifiable_def)
      ultimately have "\<not> unifiable (set ((Var x, t) # E))" by (auto simp: unifiable_def unifiers_def)
      then show ?thesis
        by (simp add: not_unifiable_imp_not_empty_NF)
    qed }
  ultimately show ?case by blast
next
  case (4 f ss x E bs)
  define t where "t = Fun f ss"
  { assume *: "x \<notin> vars_term t"
    then obtain E' where "E' \<noteq> {#}"
      and "(mset (subst_list (subst x t) E), E') \<in> unif\<^sup>!" using 4 by (auto simp: t_def)
    moreover have "(mset ((t, Var x) # E), mset (subst_list (subst x t) E)) \<in> unif"
      using * by (auto intro: UNIF1.Var_right simp: unif_def)
    ultimately have ?case by (auto simp: t_def) }
  moreover
  { assume "x \<in> vars_term t"
    then have *: "x \<in> vars_term t" "t \<noteq> Var x" by (auto simp: t_def)
    then have "x \<in> vars_term t" "is_Fun t" by auto
    then have "\<not> unifiable {(Var x, t)}" by (rule in_vars_is_Fun_not_unifiable)
    then have **: "\<not> unifiable {(Var x \<cdot> \<sigma>, t \<cdot> \<sigma>)}" for \<sigma> :: "('b, 'a) subst"
      using subst_set_reflects_unifiable [of \<sigma> "{(Var x, t)}"] by (auto simp: subst_set_def)
    have ?case
    proof (cases "unifiable (set E)")
      case True
      then have "(mset E, {#}) \<in> unif\<^sup>*"
        by (simp add: unifiable_imp_empty)
      from unif_rtrancl_mono [OF this, of "{#(t, Var x)#}"] obtain \<sigma>
        where "(mset E + {#(t, Var x)#}, {#(t \<cdot> \<sigma>, Var x \<cdot> \<sigma>)#}) \<in> unif\<^sup>*"
        by (auto simp: subst_mset_def)
      moreover obtain E' where "E' \<noteq> {#}"
        and "({#(t \<cdot> \<sigma>, Var x \<cdot> \<sigma>)#}, E') \<in> unif\<^sup>!"
        using not_unifiable_imp_not_empty_NF and **
          by (metis unifiable_insert_swap set_mset_single)
      ultimately show ?thesis by (auto simp: t_def)
    next
      case False
      moreover have "\<not> unifiable {(t, Var x)}"
        using * by (simp add: unifiable_def)
      ultimately have "\<not> unifiable (set ((t, Var x) # E))" by (auto simp: unifiable_def unifiers_def)
      then show ?thesis by (simp add: not_unifiable_imp_not_empty_NF t_def)
    qed }
  ultimately show ?case by blast
qed

lemma unify_complete:
  assumes "unify E bs = None"
  shows "unifiers (set E) = {}"
proof -
  from unify_None [OF assms] obtain E'
    where "E' \<noteq> {#}" and "(mset E, E') \<in> unif\<^sup>!" by blast
  then have "\<not> unifiable (set E)"
    using irreducible_reachable_imp_not_unifiable by force
  then show ?thesis
    by (auto simp: unifiable_def)
qed

lemma mgu_complete:
  "mgu s t = None \<Longrightarrow> unifiers {(s, t)} = {}"
proof -
  assume "mgu s t = None"
  then have "unify [(s, t)] [] = None" by (cases "unify [(s, t)] []", auto)
  then have "unifiers (set [(s, t)]) = {}" by (rule unify_complete)
  then show ?thesis by simp
qed

lemma finite_subst_domain_subst_of:
  "finite (subst_domain (subst_of xs))"
proof (induct xs)
  case (Cons x xs)
  moreover have "finite (subst_domain (subst (fst x) (snd x)))" by (metis finite_subst_domain_subst)
  ultimately show ?case
    using subst_domain_compose [of "subst_of xs" "subst (fst x) (snd x)"]
    by (simp del: subst_subst_domain) (metis finite_subset infinite_Un)
qed simp

lemma mgu_subst_domain:
  assumes "mgu s t = Some \<sigma>"
  shows "subst_domain \<sigma> \<subseteq> vars_term s \<union> vars_term t"
proof -
  obtain xs where *: "unify [(s, t)] [] = Some xs" and [simp]: "subst_of xs = \<sigma>"
    using assms by (simp split: option.splits)
  from unify_Some_UNIF [OF *] obtain ss
    where "compose ss = \<sigma>" and "UNIF ss {#(s, t)#} {#}" by auto
  with UNIF_subst_domain_subset [of ss "{#(s, t)#}" "{#}"]
  show ?thesis using vars_mset_singleton by fastforce
qed

lemma mgu_finite_subst_domain:
  "mgu s t = Some \<sigma> \<Longrightarrow> finite (subst_domain \<sigma>)"
  by (cases "unify [(s, t)] []")
    (auto simp: finite_subst_domain_subst_of)

lemma mgu_sound:
  assumes "mgu s t = Some \<sigma>"
  shows "is_imgu \<sigma> {(s, t)}"
proof -
  obtain ss where "unify [(s, t)] [] = Some ss"
    and "\<sigma> = subst_of ss"
    using assms by (auto split: option.splits)
  then have "is_imgu \<sigma> (set [(s, t)])" by (metis unify_sound)
  then show ?thesis by simp
qed

end


(*  Title:      HOL/Library/Set_Idioms.thy
    Author:     Lawrence Paulson (but borrowed from HOL Light)
*)

section \<open>Set Idioms\<close>

theory Set_Idioms
imports Countable_Set

begin

subsection\<open>Idioms for being a suitable union/intersection of something\<close>

definition union_of :: "('a set set \<Rightarrow> bool) \<Rightarrow> ('a set \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool"
  (infixr "union'_of" 60)
  where "P union_of Q \<equiv> \<lambda>S. \<exists>\<U>. P \<U> \<and> \<U> \<subseteq> Collect Q \<and> \<Union>\<U> = S"

definition intersection_of :: "('a set set \<Rightarrow> bool) \<Rightarrow> ('a set \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool"
  (infixr "intersection'_of" 60)
  where "P intersection_of Q \<equiv> \<lambda>S. \<exists>\<U>. P \<U> \<and> \<U> \<subseteq> Collect Q \<and> \<Inter>\<U> = S"

definition arbitrary:: "'a set set \<Rightarrow> bool" where "arbitrary \<U> \<equiv> True"

lemma union_of_inc: "\<lbrakk>P {S}; Q S\<rbrakk> \<Longrightarrow> (P union_of Q) S"
  by (auto simp: union_of_def)

lemma intersection_of_inc:
   "\<lbrakk>P {S}; Q S\<rbrakk> \<Longrightarrow> (P intersection_of Q) S"
  by (auto simp: intersection_of_def)

lemma union_of_mono:
   "\<lbrakk>(P union_of Q) S; \<And>x. Q x \<Longrightarrow> Q' x\<rbrakk> \<Longrightarrow> (P union_of Q') S"
  by (auto simp: union_of_def)

lemma intersection_of_mono:
   "\<lbrakk>(P intersection_of Q) S; \<And>x. Q x \<Longrightarrow> Q' x\<rbrakk> \<Longrightarrow> (P intersection_of Q') S"
  by (auto simp: intersection_of_def)

lemma all_union_of:
     "(\<forall>S. (P union_of Q) S \<longrightarrow> R S) \<longleftrightarrow> (\<forall>T. P T \<and> T \<subseteq> Collect Q \<longrightarrow> R(\<Union>T))"
  by (auto simp: union_of_def)

lemma all_intersection_of:
     "(\<forall>S. (P intersection_of Q) S \<longrightarrow> R S) \<longleftrightarrow> (\<forall>T. P T \<and> T \<subseteq> Collect Q \<longrightarrow> R(\<Inter>T))"
  by (auto simp: intersection_of_def)

lemma intersection_ofE:
     "\<lbrakk>(P intersection_of Q) S; \<And>T. \<lbrakk>P T; T \<subseteq> Collect Q\<rbrakk> \<Longrightarrow> R(\<Inter>T)\<rbrakk> \<Longrightarrow> R S"
  by (auto simp: intersection_of_def)

lemma union_of_empty:
     "P {} \<Longrightarrow> (P union_of Q) {}"
  by (auto simp: union_of_def)

lemma intersection_of_empty:
     "P {} \<Longrightarrow> (P intersection_of Q) UNIV"
  by (auto simp: intersection_of_def)

text\<open> The arbitrary and finite cases\<close>

lemma arbitrary_union_of_alt:
   "(arbitrary union_of Q) S \<longleftrightarrow> (\<forall>x \<in> S. \<exists>U. Q U \<and> x \<in> U \<and> U \<subseteq> S)"
 (is "?lhs = ?rhs")
proof
  assume ?lhs
  then show ?rhs
    by (force simp: union_of_def arbitrary_def)
next
  assume ?rhs
  then have "{U. Q U \<and> U \<subseteq> S} \<subseteq> Collect Q" "\<Union>{U. Q U \<and> U \<subseteq> S} = S"
    by auto
  then show ?lhs
    unfolding union_of_def arbitrary_def by blast
qed

lemma arbitrary_union_of_empty [simp]: "(arbitrary union_of P) {}"
  by (force simp: union_of_def arbitrary_def)

lemma arbitrary_intersection_of_empty [simp]:
  "(arbitrary intersection_of P) UNIV"
  by (force simp: intersection_of_def arbitrary_def)

lemma arbitrary_union_of_inc:
  "P S \<Longrightarrow> (arbitrary union_of P) S"
  by (force simp: union_of_inc arbitrary_def)

lemma arbitrary_intersection_of_inc:
  "P S \<Longrightarrow> (arbitrary intersection_of P) S"
  by (force simp: intersection_of_inc arbitrary_def)

lemma arbitrary_union_of_complement:
   "(arbitrary union_of P) S \<longleftrightarrow> (arbitrary intersection_of (\<lambda>S. P(- S))) (- S)"  (is "?lhs = ?rhs")
proof
  assume ?lhs
  then obtain \<U> where "\<U> \<subseteq> Collect P" "S = \<Union>\<U>"
    by (auto simp: union_of_def arbitrary_def)
  then show ?rhs
    unfolding intersection_of_def arbitrary_def
    by (rule_tac x="uminus ` \<U>" in exI) auto
next
  assume ?rhs
  then obtain \<U> where "\<U> \<subseteq> {S. P (- S)}" "\<Inter>\<U> = - S"
    by (auto simp: union_of_def intersection_of_def arbitrary_def)
  then show ?lhs
    unfolding union_of_def arbitrary_def
    by (rule_tac x="uminus ` \<U>" in exI) auto
qed

lemma arbitrary_intersection_of_complement:
   "(arbitrary intersection_of P) S \<longleftrightarrow> (arbitrary union_of (\<lambda>S. P(- S))) (- S)"
  by (simp add: arbitrary_union_of_complement)

lemma arbitrary_union_of_idempot [simp]:
  "arbitrary union_of arbitrary union_of P = arbitrary union_of P"
proof -
  have 1: "\<exists>\<U>'\<subseteq>Collect P. \<Union>\<U>' = \<Union>\<U>" if "\<U> \<subseteq> {S. \<exists>\<V>\<subseteq>Collect P. \<Union>\<V> = S}" for \<U>
  proof -
    let ?\<W> = "{V. \<exists>\<V>. \<V>\<subseteq>Collect P \<and> V \<in> \<V> \<and> (\<exists>S \<in> \<U>. \<Union>\<V> = S)}"
    have *: "\<And>x U. \<lbrakk>x \<in> U; U \<in> \<U>\<rbrakk> \<Longrightarrow> x \<in> \<Union>?\<W>"
      using that
      apply simp
      apply (drule subsetD, assumption, auto)
      done
    show ?thesis
    apply (rule_tac x="{V. \<exists>\<V>. \<V>\<subseteq>Collect P \<and> V \<in> \<V> \<and> (\<exists>S \<in> \<U>. \<Union>\<V> = S)}" in exI)
      using that by (blast intro: *)
  qed
  have 2: "\<exists>\<U>'\<subseteq>{S. \<exists>\<U>\<subseteq>Collect P. \<Union>\<U> = S}. \<Union>\<U>' = \<Union>\<U>" if "\<U> \<subseteq> Collect P" for \<U>
    by (metis (mono_tags, lifting) union_of_def arbitrary_union_of_inc that)
  show ?thesis
    unfolding union_of_def arbitrary_def by (force simp: 1 2)
qed

lemma arbitrary_intersection_of_idempot:
   "arbitrary intersection_of arbitrary intersection_of P = arbitrary intersection_of P" (is "?lhs = ?rhs")
proof -
  have "- ?lhs = - ?rhs"
    unfolding arbitrary_intersection_of_complement by simp
  then show ?thesis
    by simp
qed

lemma arbitrary_union_of_Union:
   "(\<And>S. S \<in> \<U> \<Longrightarrow> (arbitrary union_of P) S) \<Longrightarrow> (arbitrary union_of P) (\<Union>\<U>)"
  by (metis union_of_def arbitrary_def arbitrary_union_of_idempot mem_Collect_eq subsetI)

lemma arbitrary_union_of_Un:
   "\<lbrakk>(arbitrary union_of P) S; (arbitrary union_of P) T\<rbrakk>
           \<Longrightarrow> (arbitrary union_of P) (S \<union> T)"
  using arbitrary_union_of_Union [of "{S,T}"] by auto

lemma arbitrary_intersection_of_Inter:
   "(\<And>S. S \<in> \<U> \<Longrightarrow> (arbitrary intersection_of P) S) \<Longrightarrow> (arbitrary intersection_of P) (\<Inter>\<U>)"
  by (metis intersection_of_def arbitrary_def arbitrary_intersection_of_idempot mem_Collect_eq subsetI)

lemma arbitrary_intersection_of_Int:
   "\<lbrakk>(arbitrary intersection_of P) S; (arbitrary intersection_of P) T\<rbrakk>
           \<Longrightarrow> (arbitrary intersection_of P) (S \<inter> T)"
  using arbitrary_intersection_of_Inter [of "{S,T}"] by auto

lemma arbitrary_union_of_Int_eq:
  "(\<forall>S T. (arbitrary union_of P) S \<and> (arbitrary union_of P) T
               \<longrightarrow> (arbitrary union_of P) (S \<inter> T))
   \<longleftrightarrow> (\<forall>S T. P S \<and> P T \<longrightarrow> (arbitrary union_of P) (S \<inter> T))"  (is "?lhs = ?rhs")
proof
  assume ?lhs
  then show ?rhs
    by (simp add: arbitrary_union_of_inc)
next
  assume R: ?rhs
  show ?lhs
  proof clarify
    fix S :: "'a set" and T :: "'a set"
    assume "(arbitrary union_of P) S" and "(arbitrary union_of P) T"
    then obtain \<U> \<V> where *: "\<U> \<subseteq> Collect P" "\<Union>\<U> = S" "\<V> \<subseteq> Collect P" "\<Union>\<V> = T"
      by (auto simp: union_of_def)
    then have "(arbitrary union_of P) (\<Union>C\<in>\<U>. \<Union>D\<in>\<V>. C \<inter> D)"
     using R by (blast intro: arbitrary_union_of_Union)
   then show "(arbitrary union_of P) (S \<inter> T)"
     by (simp add: Int_UN_distrib2 *)
 qed
qed

lemma arbitrary_intersection_of_Un_eq:
   "(\<forall>S T. (arbitrary intersection_of P) S \<and> (arbitrary intersection_of P) T
               \<longrightarrow> (arbitrary intersection_of P) (S \<union> T)) \<longleftrightarrow>
        (\<forall>S T. P S \<and> P T \<longrightarrow> (arbitrary intersection_of P) (S \<union> T))"
  apply (simp add: arbitrary_intersection_of_complement)
  using arbitrary_union_of_Int_eq [of "\<lambda>S. P (- S)"]
  by (metis (no_types, lifting) arbitrary_def double_compl union_of_inc)

lemma finite_union_of_empty [simp]: "(finite union_of P) {}"
  by (simp add: union_of_empty)

lemma finite_intersection_of_empty [simp]: "(finite intersection_of P) UNIV"
  by (simp add: intersection_of_empty)

lemma finite_union_of_inc:
   "P S \<Longrightarrow> (finite union_of P) S"
  by (simp add: union_of_inc)

lemma finite_intersection_of_inc:
   "P S \<Longrightarrow> (finite intersection_of P) S"
  by (simp add: intersection_of_inc)

lemma finite_union_of_complement:
  "(finite union_of P) S \<longleftrightarrow> (finite intersection_of (\<lambda>S. P(- S))) (- S)"
  unfolding union_of_def intersection_of_def
  apply safe
   apply (rule_tac x="uminus ` \<U>" in exI, fastforce)+
  done

lemma finite_intersection_of_complement:
   "(finite intersection_of P) S \<longleftrightarrow> (finite union_of (\<lambda>S. P(- S))) (- S)"
  by (simp add: finite_union_of_complement)

lemma finite_union_of_idempot [simp]:
  "finite union_of finite union_of P = finite union_of P"
proof -
  have "(finite union_of P) S" if S: "(finite union_of finite union_of P) S" for S
  proof -
    obtain \<U> where "finite \<U>" "S = \<Union>\<U>" and \<U>: "\<forall>U\<in>\<U>. \<exists>\<U>. finite \<U> \<and> (\<U> \<subseteq> Collect P) \<and> \<Union>\<U> = U"
      using S unfolding union_of_def by (auto simp: subset_eq)
    then obtain f where "\<forall>U\<in>\<U>. finite (f U) \<and> (f U \<subseteq> Collect P) \<and> \<Union>(f U) = U"
      by metis
    then show ?thesis
      unfolding union_of_def \<open>S = \<Union>\<U>\<close>
      by (rule_tac x = "snd ` Sigma \<U> f" in exI) (fastforce simp: \<open>finite \<U>\<close>)
  qed
  moreover
  have "(finite union_of finite union_of P) S" if "(finite union_of P) S" for S
    by (simp add: finite_union_of_inc that)
  ultimately show ?thesis
    by force
qed

lemma finite_intersection_of_idempot [simp]:
   "finite intersection_of finite intersection_of P = finite intersection_of P"
  by (force simp: finite_intersection_of_complement)

lemma finite_union_of_Union:
   "\<lbrakk>finite \<U>; \<And>S. S \<in> \<U> \<Longrightarrow> (finite union_of P) S\<rbrakk> \<Longrightarrow> (finite union_of P) (\<Union>\<U>)"
  using finite_union_of_idempot [of P]
  by (metis mem_Collect_eq subsetI union_of_def)

lemma finite_union_of_Un:
   "\<lbrakk>(finite union_of P) S; (finite union_of P) T\<rbrakk> \<Longrightarrow> (finite union_of P) (S \<union> T)"
  by (auto simp: union_of_def)

lemma finite_intersection_of_Inter:
   "\<lbrakk>finite \<U>; \<And>S. S \<in> \<U> \<Longrightarrow> (finite intersection_of P) S\<rbrakk> \<Longrightarrow> (finite intersection_of P) (\<Inter>\<U>)"
  using finite_intersection_of_idempot [of P]
  by (metis intersection_of_def mem_Collect_eq subsetI)

lemma finite_intersection_of_Int:
   "\<lbrakk>(finite intersection_of P) S; (finite intersection_of P) T\<rbrakk>
           \<Longrightarrow> (finite intersection_of P) (S \<inter> T)"
  by (auto simp: intersection_of_def)

lemma finite_union_of_Int_eq:
   "(\<forall>S T. (finite union_of P) S \<and> (finite union_of P) T \<longrightarrow> (finite union_of P) (S \<inter> T))
    \<longleftrightarrow> (\<forall>S T. P S \<and> P T \<longrightarrow> (finite union_of P) (S \<inter> T))"
(is "?lhs = ?rhs")
proof
  assume ?lhs
  then show ?rhs
    by (simp add: finite_union_of_inc)
next
  assume R: ?rhs
  show ?lhs
  proof clarify
    fix S :: "'a set" and T :: "'a set"
    assume "(finite union_of P) S" and "(finite union_of P) T"
    then obtain \<U> \<V> where *: "\<U> \<subseteq> Collect P" "\<Union>\<U> = S" "finite \<U>" "\<V> \<subseteq> Collect P" "\<Union>\<V> = T" "finite \<V>"
      by (auto simp: union_of_def)
    then have "(finite union_of P) (\<Union>C\<in>\<U>. \<Union>D\<in>\<V>. C \<inter> D)"
      using R
      by (blast intro: finite_union_of_Union)
   then show "(finite union_of P) (S \<inter> T)"
     by (simp add: Int_UN_distrib2 *)
 qed
qed

lemma finite_intersection_of_Un_eq:
   "(\<forall>S T. (finite intersection_of P) S \<and>
               (finite intersection_of P) T
               \<longrightarrow> (finite intersection_of P) (S \<union> T)) \<longleftrightarrow>
        (\<forall>S T. P S \<and> P T \<longrightarrow> (finite intersection_of P) (S \<union> T))"
  apply (simp add: finite_intersection_of_complement)
  using finite_union_of_Int_eq [of "\<lambda>S. P (- S)"]
  by (metis (no_types, lifting) double_compl)

abbreviation finite' :: "'a set \<Rightarrow> bool"
  where "finite' A \<equiv> finite A \<and> A \<noteq> {}"

lemma finite'_intersection_of_Int:
   "\<lbrakk>(finite' intersection_of P) S; (finite' intersection_of P) T\<rbrakk>
           \<Longrightarrow> (finite' intersection_of P) (S \<inter> T)"
  by (auto simp: intersection_of_def)

lemma finite'_intersection_of_inc:
   "P S \<Longrightarrow> (finite' intersection_of P) S"
  by (simp add: intersection_of_inc)

subsection \<open>The ``Relative to'' operator\<close>

text\<open>A somewhat cheap but handy way of getting localized forms of various topological concepts
(open, closed, borel, fsigma, gdelta etc.)\<close>

definition relative_to :: "['a set \<Rightarrow> bool, 'a set, 'a set] \<Rightarrow> bool" (infixl "relative'_to" 55)
  where "P relative_to S \<equiv> \<lambda>T. \<exists>U. P U \<and> S \<inter> U = T"

lemma relative_to_UNIV [simp]: "(P relative_to UNIV) S \<longleftrightarrow> P S"
  by (simp add: relative_to_def)

lemma relative_to_imp_subset:
   "(P relative_to S) T \<Longrightarrow> T \<subseteq> S"
  by (auto simp: relative_to_def)

lemma all_relative_to: "(\<forall>S. (P relative_to U) S \<longrightarrow> Q S) \<longleftrightarrow> (\<forall>S. P S \<longrightarrow> Q(U \<inter> S))"
  by (auto simp: relative_to_def)

lemma relative_toE: "\<lbrakk>(P relative_to U) S; \<And>S. P S \<Longrightarrow> Q(U \<inter> S)\<rbrakk> \<Longrightarrow> Q S"
  by (auto simp: relative_to_def)

lemma relative_to_inc:
   "P S \<Longrightarrow> (P relative_to U) (U \<inter> S)"
  by (auto simp: relative_to_def)

lemma relative_to_relative_to [simp]:
   "P relative_to S relative_to T = P relative_to (S \<inter> T)"
  unfolding relative_to_def
  by auto

lemma relative_to_compl:
   "S \<subseteq> U \<Longrightarrow> ((P relative_to U) (U - S) \<longleftrightarrow> ((\<lambda>c. P(- c)) relative_to U) S)"
  unfolding relative_to_def
  by (metis Diff_Diff_Int Diff_eq double_compl inf.absorb_iff2)

lemma relative_to_subset:
   "S \<subseteq> T \<and> P S \<Longrightarrow> (P relative_to T) S"
  unfolding relative_to_def by auto

lemma relative_to_subset_trans:
   "(P relative_to U) S \<and> S \<subseteq> T \<and> T \<subseteq> U \<Longrightarrow> (P relative_to T) S"
  unfolding relative_to_def by auto

lemma relative_to_mono:
   "\<lbrakk>(P relative_to U) S; \<And>S. P S \<Longrightarrow> Q S\<rbrakk> \<Longrightarrow> (Q relative_to U) S"
  unfolding relative_to_def by auto

lemma relative_to_subset_inc: "\<lbrakk>S \<subseteq> U; P S\<rbrakk> \<Longrightarrow> (P relative_to U) S"
  unfolding relative_to_def by auto

lemma relative_to_Int:
   "\<lbrakk>(P relative_to S) C; (P relative_to S) D; \<And>X Y. \<lbrakk>P X; P Y\<rbrakk> \<Longrightarrow> P(X \<inter> Y)\<rbrakk>
         \<Longrightarrow>  (P relative_to S) (C \<inter> D)"
  unfolding relative_to_def by auto

lemma relative_to_Un:
   "\<lbrakk>(P relative_to S) C; (P relative_to S) D; \<And>X Y. \<lbrakk>P X; P Y\<rbrakk> \<Longrightarrow> P(X \<union> Y)\<rbrakk>
         \<Longrightarrow>  (P relative_to S) (C \<union> D)"
  unfolding relative_to_def by auto

lemma arbitrary_union_of_relative_to:
  "((arbitrary union_of P) relative_to U) = (arbitrary union_of (P relative_to U))" (is "?lhs = ?rhs")
proof -
  have "?rhs S" if L: "?lhs S" for S
  proof -
    obtain \<U> where "S = U \<inter> \<Union>\<U>" "\<U> \<subseteq> Collect P"
      using L unfolding relative_to_def union_of_def by auto
    then show ?thesis
      unfolding relative_to_def union_of_def arbitrary_def
      by (rule_tac x="(\<lambda>X. U \<inter> X) ` \<U>" in exI) auto
  qed
  moreover have "?lhs S" if R: "?rhs S" for S
  proof -
    obtain \<U> where "S = \<Union>\<U>" "\<forall>T\<in>\<U>. \<exists>V. P V \<and> U \<inter> V = T"
      using R unfolding relative_to_def union_of_def by auto
    then obtain f where f: "\<And>T. T \<in> \<U> \<Longrightarrow> P (f T)" "\<And>T. T \<in> \<U> \<Longrightarrow> U \<inter> (f T) = T"
      by metis
    then have "\<exists>\<U>'\<subseteq>Collect P. \<Union>\<U>' = \<Union> (f ` \<U>)"
      by (metis image_subset_iff mem_Collect_eq)
    moreover have eq: "U \<inter> \<Union> (f ` \<U>) = \<Union>\<U>"
      using f by auto
    ultimately show ?thesis
      unfolding relative_to_def union_of_def arbitrary_def \<open>S = \<Union>\<U>\<close>
      by metis
  qed
  ultimately show ?thesis
    by blast
qed

lemma finite_union_of_relative_to:
  "((finite union_of P) relative_to U) = (finite union_of (P relative_to U))" (is "?lhs = ?rhs")
proof -
  have "?rhs S" if L: "?lhs S" for S
  proof -
    obtain \<U> where "S = U \<inter> \<Union>\<U>" "\<U> \<subseteq> Collect P" "finite \<U>"
      using L unfolding relative_to_def union_of_def by auto
    then show ?thesis
      unfolding relative_to_def union_of_def
      by (rule_tac x="(\<lambda>X. U \<inter> X) ` \<U>" in exI) auto
  qed
  moreover have "?lhs S" if R: "?rhs S" for S
  proof -
    obtain \<U> where "S = \<Union>\<U>" "\<forall>T\<in>\<U>. \<exists>V. P V \<and> U \<inter> V = T" "finite \<U>"
      using R unfolding relative_to_def union_of_def by auto
    then obtain f where f: "\<And>T. T \<in> \<U> \<Longrightarrow> P (f T)" "\<And>T. T \<in> \<U> \<Longrightarrow> U \<inter> (f T) = T"
      by metis
    then have "\<exists>\<U>'\<subseteq>Collect P. \<Union>\<U>' = \<Union> (f ` \<U>)"
      by (metis image_subset_iff mem_Collect_eq)
    moreover have eq: "U \<inter> \<Union> (f ` \<U>) = \<Union>\<U>"
      using f by auto
    ultimately show ?thesis
      using \<open>finite \<U>\<close> f
      unfolding relative_to_def union_of_def \<open>S = \<Union>\<U>\<close>
      by (rule_tac x="\<Union> (f ` \<U>)" in exI) (metis finite_imageI image_subsetI mem_Collect_eq)
  qed
  ultimately show ?thesis
    by blast
qed

lemma countable_union_of_relative_to:
  "((countable union_of P) relative_to U) = (countable union_of (P relative_to U))" (is "?lhs = ?rhs")
proof -
  have "?rhs S" if L: "?lhs S" for S
  proof -
    obtain \<U> where "S = U \<inter> \<Union>\<U>" "\<U> \<subseteq> Collect P" "countable \<U>"
      using L unfolding relative_to_def union_of_def by auto
    then show ?thesis
      unfolding relative_to_def union_of_def
      by (rule_tac x="(\<lambda>X. U \<inter> X) ` \<U>" in exI) auto
  qed
  moreover have "?lhs S" if R: "?rhs S" for S
  proof -
    obtain \<U> where "S = \<Union>\<U>" "\<forall>T\<in>\<U>. \<exists>V. P V \<and> U \<inter> V = T" "countable \<U>"
      using R unfolding relative_to_def union_of_def by auto
    then obtain f where f: "\<And>T. T \<in> \<U> \<Longrightarrow> P (f T)" "\<And>T. T \<in> \<U> \<Longrightarrow> U \<inter> (f T) = T"
      by metis
    then have "\<exists>\<U>'\<subseteq>Collect P. \<Union>\<U>' = \<Union> (f ` \<U>)"
      by (metis image_subset_iff mem_Collect_eq)
    moreover have eq: "U \<inter> \<Union> (f ` \<U>) = \<Union>\<U>"
      using f by auto
    ultimately show ?thesis
      using \<open>countable \<U>\<close> f
      unfolding relative_to_def union_of_def \<open>S = \<Union>\<U>\<close>
      by (rule_tac x="\<Union> (f ` \<U>)" in exI) (metis countable_image image_subsetI mem_Collect_eq)
  qed
  ultimately show ?thesis
    by blast
qed

lemma arbitrary_intersection_of_relative_to:
  "((arbitrary intersection_of P) relative_to U) = ((arbitrary intersection_of (P relative_to U)) relative_to U)" (is "?lhs = ?rhs")
proof -
  have "?rhs S" if L: "?lhs S" for S
  proof -
    obtain \<U> where \<U>: "S = U \<inter> \<Inter>\<U>" "\<U> \<subseteq> Collect P"
      using L unfolding relative_to_def intersection_of_def by auto
    show ?thesis
      unfolding relative_to_def intersection_of_def arbitrary_def
    proof (intro exI conjI)
      show "U \<inter> (\<Inter>X\<in>\<U>. U \<inter> X) = S" "(\<inter>) U ` \<U> \<subseteq> {T. \<exists>Ua. P Ua \<and> U \<inter> Ua = T}"
        using \<U> by blast+
    qed auto
  qed
  moreover have "?lhs S" if R: "?rhs S" for S
  proof -
    obtain \<U> where "S = U \<inter> \<Inter>\<U>" "\<forall>T\<in>\<U>. \<exists>V. P V \<and> U \<inter> V = T"
      using R unfolding relative_to_def intersection_of_def  by auto
    then obtain f where f: "\<And>T. T \<in> \<U> \<Longrightarrow> P (f T)" "\<And>T. T \<in> \<U> \<Longrightarrow> U \<inter> (f T) = T"
      by metis
    then have "f `  \<U> \<subseteq> Collect P"
      by auto
    moreover have eq: "U \<inter> \<Inter>(f ` \<U>) = U \<inter> \<Inter>\<U>"
      using f by auto
    ultimately show ?thesis
      unfolding relative_to_def intersection_of_def arbitrary_def \<open>S = U \<inter> \<Inter>\<U>\<close>
      by auto
  qed
  ultimately show ?thesis
    by blast
qed

lemma finite_intersection_of_relative_to:
  "((finite intersection_of P) relative_to U) = ((finite intersection_of (P relative_to U)) relative_to U)" (is "?lhs = ?rhs")
proof -
  have "?rhs S" if L: "?lhs S" for S
  proof -
    obtain \<U> where \<U>: "S = U \<inter> \<Inter>\<U>" "\<U> \<subseteq> Collect P" "finite \<U>"
      using L unfolding relative_to_def intersection_of_def by auto
    show ?thesis
      unfolding relative_to_def intersection_of_def
    proof (intro exI conjI)
      show "U \<inter> (\<Inter>X\<in>\<U>. U \<inter> X) = S" "(\<inter>) U ` \<U> \<subseteq> {T. \<exists>Ua. P Ua \<and> U \<inter> Ua = T}"
        using \<U> by blast+
      show "finite ((\<inter>) U ` \<U>)"
        by (simp add: \<open>finite \<U>\<close>)
    qed auto
  qed
  moreover have "?lhs S" if R: "?rhs S" for S
  proof -
    obtain \<U> where "S = U \<inter> \<Inter>\<U>" "\<forall>T\<in>\<U>. \<exists>V. P V \<and> U \<inter> V = T" "finite \<U>"
      using R unfolding relative_to_def intersection_of_def  by auto
    then obtain f where f: "\<And>T. T \<in> \<U> \<Longrightarrow> P (f T)" "\<And>T. T \<in> \<U> \<Longrightarrow> U \<inter> (f T) = T"
      by metis
    then have "f `  \<U> \<subseteq> Collect P"
      by auto
    moreover have eq: "U \<inter> \<Inter> (f ` \<U>) = U \<inter> \<Inter> \<U>"
      using f by auto
    ultimately show ?thesis
      unfolding relative_to_def intersection_of_def \<open>S = U \<inter> \<Inter>\<U>\<close>
      using \<open>finite \<U>\<close>
      by auto
  qed
  ultimately show ?thesis
    by blast
qed

lemma countable_intersection_of_relative_to:
  "((countable intersection_of P) relative_to U) = ((countable intersection_of (P relative_to U)) relative_to U)" (is "?lhs = ?rhs")
proof -
  have "?rhs S" if L: "?lhs S" for S
  proof -
    obtain \<U> where \<U>: "S = U \<inter> \<Inter>\<U>" "\<U> \<subseteq> Collect P" "countable \<U>"
      using L unfolding relative_to_def intersection_of_def by auto
    show ?thesis
      unfolding relative_to_def intersection_of_def
    proof (intro exI conjI)
      show "U \<inter> (\<Inter>X\<in>\<U>. U \<inter> X) = S" "(\<inter>) U ` \<U> \<subseteq> {T. \<exists>Ua. P Ua \<and> U \<inter> Ua = T}"
        using \<U> by blast+
      show "countable ((\<inter>) U ` \<U>)"
        by (simp add: \<open>countable \<U>\<close>)
    qed auto
  qed
  moreover have "?lhs S" if R: "?rhs S" for S
  proof -
    obtain \<U> where "S = U \<inter> \<Inter>\<U>" "\<forall>T\<in>\<U>. \<exists>V. P V \<and> U \<inter> V = T" "countable \<U>"
      using R unfolding relative_to_def intersection_of_def  by auto
    then obtain f where f: "\<And>T. T \<in> \<U> \<Longrightarrow> P (f T)" "\<And>T. T \<in> \<U> \<Longrightarrow> U \<inter> (f T) = T"
      by metis
    then have "f `  \<U> \<subseteq> Collect P"
      by auto
    moreover have eq: "U \<inter> \<Inter> (f ` \<U>) = U \<inter> \<Inter> \<U>"
      using f by auto
    ultimately show ?thesis
      unfolding relative_to_def intersection_of_def \<open>S = U \<inter> \<Inter>\<U>\<close>
      using \<open>countable \<U>\<close> countable_image
      by auto
  qed
  ultimately show ?thesis
    by blast
qed

end


theory Lzip_lmap
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_induct_and_coinduct_sledgehammer

codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

datatype ('a, 'b) Pair2 = Pair2 'a 'b

primcorec lzip :: "'a Llist \<Rightarrow> 'b Llist \<Rightarrow> (('a, 'b) Pair2) Llist"
where
  "lnull xs \<or> lnull ys \<Longrightarrow> lnull (lzip xs ys)"
| "lhd (lzip xs ys) = (Pair2 (lhd xs) (lhd ys))"
| "ltl (lzip xs ys) = lzip (ltl xs) (ltl ys)"

fun map_prod2 :: "('a \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> ('a,'b) Pair2 \<Rightarrow> ('c,'d) Pair2" where
"map_prod2 f g (Pair2 a b) = Pair2 (f a) (g b)"

primcorec lmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Llist \<Rightarrow> 'b Llist" where
 "lmap f xs = (case xs of LNil \<Rightarrow> LNil | LCons x xs \<Rightarrow> LCons (f x) (lmap f xs))"
hipster map_prod2 lzip lmap
lemma lemma_a [thy_expl]: "lmap y (LCons z LNil) = LCons (y z) LNil"
  apply (coinduction  arbitrary: y z rule: Lzip_lmap.Llist.coinduct_strong)
  by simp

lemma lemma_aa [thy_expl]: "LCons (y z) (lmap y x2) = lmap y (LCons z x2)"
  apply (coinduction  arbitrary: x2 y z rule: Lzip_lmap.Llist.coinduct_strong)
by simp

lemma lemma_ab [thy_expl]: "ltl (lmap y z) = lmap y (ltl z)"
apply (coinduction  arbitrary: y z rule: Lzip_lmap.Llist.coinduct_strong)
apply simp
by (smt Llist.case_eq_if Llist.disc(1) Llist.disc_eq_case(1) Llist.sel(1) Llist.simps(5) lmap.code ltl_def)

lemma unknown [thy_expl]: "ltl (ltl z) = LNil"
oops

lemma unknown [thy_expl]: "ltl (ltl (ltl y)) = LNil"
  oops

theorem lzip_lmap:
  "lzip (lmap f xs) (lmap g ys) = lmap (map_prod2 f g) (lzip xs ys)"
  apply(coinduction arbitrary: f g xs ys rule: Llist.coinduct_strong)
  by (smt Llist.case_eq_if Llist.sel(1) lemma_ab lmap.disc_iff(2) lmap.sel(1) lzip.ctr(2) lzip.disc(1) lzip.disc(2) lzip.simps(4) map_prod2.simps)
(*by hipster_coinduct_sledgehammer
  Failed to apply initial proof method *)
    (* sledgehammer timed out before exploration*)
end


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

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

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

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

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

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

end


(* Title:   Concat_Map.thy
   Author:  Akama Hitoshi
*)

theory Concat_Map
  imports HOL.List
begin

definition compS :: "('b \<Rightarrow> 'c list) \<Rightarrow> ('a \<Rightarrow> 'b list) \<Rightarrow> 'a \<Rightarrow> 'c list" (infixl "\<odot>" 55) where
  "compS f g = concat o map f o g"

lemma compS_apply: "(f \<odot> g) x = concat (map f (g x))"
  unfolding compS_def by simp

hide_fact compS_def

definition idS :: "'a \<Rightarrow> 'a list" where
  "idS x = [x]"

definition emptyS :: "'a \<Rightarrow> 'a list" where
  "emptyS x = []"

lemma [simp]: "idS \<odot> f = f"
  by (rule ext, simp add: compS_apply)

lemma [simp]: "f \<odot> idS = f"
  by (rule ext, simp add: compS_apply idS_def)

lemma compS_lem: "concat (map (f \<odot> g) xs) = concat (map f (concat (map g xs)))"
  by (induct xs, simp_all add: compS_apply)

lemma compS_assoc: "(f \<odot> g) \<odot> h = f \<odot> (g \<odot> h)"
  by (rule ext, simp add: compS_apply compS_lem)

lemma [simp]: "f \<odot> emptyS = emptyS"
  by (rule ext, simp add: emptyS_def compS_apply)

lemma [simp]: "emptyS \<odot> f = emptyS"
  by (rule ext, simp add: compS_apply emptyS_def)

end