(*  Title:       General Algorithms for Iterators
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
section {* General Algorithms for Iterators over Finite Sets *}
theory SetIteratorGA
imports Main "SetIteratorOperations"
begin

subsection {* Quantification *}

definition iterate_ball where
    "iterate_ball (it::('x,bool) set_iterator) P = it id (\<lambda>x \<sigma>. P x) True"

lemma iterate_ball_correct :
assumes it: "set_iterator it S0"
shows "iterate_ball it P = (\<forall>x\<in>S0. P x)"
unfolding iterate_ball_def
apply (rule set_iterator_rule_P [OF it,
            where I = "\<lambda>S \<sigma>. \<sigma> = (\<forall>x\<in>S0-S. P x)"])
apply auto
done

definition iterate_bex where
    "iterate_bex (it::('x,bool) set_iterator) P = it (\<lambda>\<sigma>. \<not>\<sigma>) (\<lambda>x \<sigma>. P x) False"

lemma iterate_bex_correct :
assumes it: "set_iterator it S0"
shows "iterate_bex it P = (\<exists>x\<in>S0. P x)"
unfolding iterate_bex_def
apply (rule set_iterator_rule_P [OF it, where I = "\<lambda>S \<sigma>. \<sigma> = (\<exists>x\<in>S0-S. P x)"])
apply auto
done

subsection {* Iterator to List *}

definition iterate_to_list where
    "iterate_to_list (it::('x,'x list) set_iterator) = it (\<lambda>_. True) (\<lambda>x \<sigma>. x # \<sigma>) []"

lemma iterate_to_list_foldli [simp] :
  "iterate_to_list (foldli xs) = rev xs"
unfolding iterate_to_list_def
by (induct xs rule: rev_induct, simp_all add: foldli_snoc)

lemma iterate_to_list_genord_correct :
assumes it: "set_iterator_genord it S0 R"
shows "set (iterate_to_list it) = S0 \<and> distinct (iterate_to_list it) \<and>
       sorted_by_rel R (rev (iterate_to_list it))"
using it unfolding set_iterator_genord_foldli_conv by auto

lemma iterate_to_list_correct :
assumes it: "set_iterator it S0"
shows "set (iterate_to_list it) = S0 \<and> distinct (iterate_to_list it)"
using iterate_to_list_genord_correct [OF it[unfolded set_iterator_def]]
by simp

lemma (in linorder) iterate_to_list_linord_correct :
fixes S0 :: "'a set"
assumes it_OK: "set_iterator_linord it S0"
shows "set (iterate_to_list it) = S0 \<and> distinct (iterate_to_list it) \<and>
       sorted (rev (iterate_to_list it))"
using it_OK unfolding set_iterator_linord_foldli_conv by auto

lemma (in linorder) iterate_to_list_rev_linord_correct :
fixes S0 :: "'a set"
assumes it_OK: "set_iterator_rev_linord it S0"
shows "set (iterate_to_list it) = S0 \<and> distinct (iterate_to_list it) \<and>
       sorted (iterate_to_list it)"
using it_OK unfolding set_iterator_rev_linord_foldli_conv by auto

lemma (in linorder) iterate_to_list_map_linord_correct :
assumes it_OK: "map_iterator_linord it m"
shows "map_of (iterate_to_list it) = m \<and> distinct (map fst (iterate_to_list it)) \<and>
       sorted (map fst (rev (iterate_to_list it)))"
using it_OK unfolding map_iterator_linord_foldli_conv
by clarify (simp add: rev_map[symmetric])

lemma (in linorder) iterate_to_list_map_rev_linord_correct :
assumes it_OK: "map_iterator_rev_linord it m"
shows "map_of (iterate_to_list it) = m \<and> distinct (map fst (iterate_to_list it)) \<and>
       sorted (map fst (iterate_to_list it))"
using it_OK unfolding map_iterator_rev_linord_foldli_conv
by clarify (simp add: rev_map[symmetric])

subsection {* Size *}

lemma set_iterator_finite :
assumes it: "set_iterator it S0"
shows "finite S0"
using set_iterator_genord.finite_S0 [OF it[unfolded set_iterator_def]] .

lemma map_iterator_finite :
assumes it: "map_iterator it m"
shows "finite (dom m)"
using set_iterator_genord.finite_S0 [OF it[unfolded set_iterator_def]]
by (simp add: finite_map_to_set)

definition iterate_size where
    "iterate_size (it::('x,nat) set_iterator) = it (\<lambda>_. True) (\<lambda>x \<sigma>. Suc \<sigma>) 0"

lemma iterate_size_correct :
assumes it: "set_iterator it S0"
shows "iterate_size it = card S0 \<and> finite S0"
unfolding iterate_size_def
apply (rule_tac set_iterator_rule_insert_P [OF it,
    where I = "\<lambda>S \<sigma>. \<sigma> = card S \<and> finite S"])
apply auto
done

definition iterate_size_abort where
  "iterate_size_abort (it::('x,nat) set_iterator) n = it (\<lambda>\<sigma>. \<sigma> < n) (\<lambda>x \<sigma>. Suc \<sigma>) 0"

lemma iterate_size_abort_correct :
assumes it: "set_iterator it S0"
shows "iterate_size_abort it n = (min n (card S0)) \<and> finite S0"
unfolding iterate_size_abort_def
proof (rule set_iterator_rule_insert_P [OF it,
   where I = "\<lambda>S \<sigma>. \<sigma> = (min n (card S)) \<and> finite S"], goal_cases)
  case (4 \<sigma> S)
  assume "S \<subseteq> S0" "S \<noteq> S0" "\<not> \<sigma> < n" "\<sigma> = min n (card S) \<and> finite S"

  from `\<sigma> = min n (card S) \<and> finite S` `\<not> \<sigma> < n`
  have "\<sigma> = n" "n \<le> card S"
    by (auto simp add: min_less_iff_disj)

  note fin_S0 = set_iterator_genord.finite_S0 [OF it[unfolded set_iterator_def]]
  from card_mono [OF fin_S0 `S \<subseteq> S0`] have "card S \<le> card S0" .

  with `\<sigma> = n` `n \<le> card S` fin_S0
  show "\<sigma> = min n (card S0) \<and> finite S0" by simp
qed simp_all

subsection {* Emptyness Check *}

definition iterate_is_empty_by_size where
    "iterate_is_empty_by_size it = (iterate_size_abort it 1 = 0)"

lemma iterate_is_empty_by_size_correct :
assumes it: "set_iterator it S0"
shows "iterate_is_empty_by_size it = (S0 = {})"
using iterate_size_abort_correct[OF it, of 1]
unfolding iterate_is_empty_by_size_def
by (cases "card S0") auto

definition iterate_is_empty where
    "iterate_is_empty (it::('x,bool) set_iterator) = (it (\<lambda>b. b) (\<lambda>_ _. False) True)"

lemma iterate_is_empty_correct :
assumes it: "set_iterator it S0"
shows "iterate_is_empty it = (S0 = {})"
unfolding iterate_is_empty_def
apply (rule set_iterator_rule_insert_P [OF it,
   where I = "\<lambda>S \<sigma>. \<sigma> \<longleftrightarrow> S = {}"])
apply auto
done

subsection {* Check for singleton Sets *}

definition iterate_is_sng where
    "iterate_is_sng it = (iterate_size_abort it 2 = 1)"

lemma iterate_is_sng_correct :
assumes it: "set_iterator it S0"
shows "iterate_is_sng it = (card S0 = 1)"
using iterate_size_abort_correct[OF it, of 2]
unfolding iterate_is_sng_def
apply (cases "card S0", simp, rename_tac n')
apply (case_tac n')
apply auto
done

subsection {* Selection *}

definition iterate_sel where
    "iterate_sel (it::('x,'y option) set_iterator) f = it (\<lambda>\<sigma>. \<sigma> = None) (\<lambda>x \<sigma>. f x) None"

lemma iterate_sel_genord_correct :
assumes it_OK: "set_iterator_genord it S0 R"
shows "iterate_sel it f = None \<longleftrightarrow> (\<forall>x\<in>S0. (f x = None))"
      "iterate_sel it f = Some y \<Longrightarrow> (\<exists>x \<in> S0. f x = Some y \<and> (\<forall>x' \<in> S0-{x}. \<forall>y. f x' = Some y' \<longrightarrow> R x x'))"
proof -
  show "iterate_sel it f = None \<longleftrightarrow> (\<forall>x\<in>S0. (f x = None))"
    unfolding iterate_sel_def
    apply (rule_tac set_iterator_genord.iteratei_rule_insert_P [OF it_OK,
       where I = "\<lambda>S \<sigma>. (\<sigma> = None) \<longleftrightarrow> (\<forall>x\<in>S. (f x = None))"])
    apply auto
  done
next
  have "iterate_sel it f = Some y \<longrightarrow> (\<exists>x \<in> S0. f x = Some y \<and> (\<forall>x' \<in> S0-{x}. \<forall>y'. f x' = Some y' \<longrightarrow> R x x'))"
    unfolding iterate_sel_def
    apply (rule_tac set_iterator_genord.iteratei_rule_insert_P [OF it_OK,
       where I = "\<lambda>S \<sigma>. (\<forall>y. \<sigma> = Some y \<longrightarrow> (\<exists>x \<in> S. f x = Some y \<and> (\<forall>x' \<in> S-{x}.\<forall>y'. f x' = Some y' \<longrightarrow> R x x'))) \<and>
                        ((\<sigma> = None) \<longleftrightarrow> (\<forall>x\<in>S. f x = None))"])
    apply simp
    apply (auto simp add: Bex_def subset_iff Ball_def)
    apply metis
  done
  moreover assume "iterate_sel it f = Some y"
  finally show "(\<exists>x \<in> S0. f x = Some y \<and> (\<forall>x' \<in> S0-{x}. \<forall>y. f x' = Some y' \<longrightarrow> R x x'))" by blast
qed

definition iterate_sel_no_map where
    "iterate_sel_no_map it P = iterate_sel it (\<lambda>x. if P x then Some x else None)"
lemmas iterate_sel_no_map_alt_def = iterate_sel_no_map_def[unfolded iterate_sel_def, code]

lemma iterate_sel_no_map_genord_correct :
assumes it_OK: "set_iterator_genord it S0 R"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
      "iterate_sel_no_map it P = Some x \<Longrightarrow> (x \<in> S0 \<and> P x \<and> (\<forall>x' \<in> S0-{x}. P x' \<longrightarrow> R x x'))"
unfolding iterate_sel_no_map_def
using iterate_sel_genord_correct[OF it_OK, of "\<lambda>x. if P x then Some x else None"]
apply (simp_all add: Bex_def)
apply (metis option.inject option.simps(2))
done

lemma iterate_sel_no_map_correct :
assumes it_OK: "set_iterator it S0"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
      "iterate_sel_no_map it P = Some x \<Longrightarrow> x \<in> S0 \<and> P x"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
       "iterate_sel_no_map it P = Some x \<Longrightarrow> x \<in> S0 \<and> P x"
    by simp_all
qed

lemma (in linorder) iterate_sel_no_map_linord_correct :
assumes it_OK: "set_iterator_linord it S0"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
      "iterate_sel_no_map it P = Some x \<Longrightarrow> (x \<in> S0 \<and> P x \<and> (\<forall>x'\<in>S0. P x' \<longrightarrow> x \<le> x'))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_linord_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
       "iterate_sel_no_map it P = Some x \<Longrightarrow> (x \<in> S0 \<and> P x \<and> (\<forall>x'\<in>S0. P x' \<longrightarrow> x \<le> x'))"
    by auto
qed

lemma (in linorder) iterate_sel_no_map_rev_linord_correct :
assumes it_OK: "set_iterator_rev_linord it S0"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
      "iterate_sel_no_map it P = Some x \<Longrightarrow> (x \<in> S0 \<and> P x \<and> (\<forall>x'\<in>S0. P x' \<longrightarrow> x' \<le> x))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_rev_linord_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
       "iterate_sel_no_map it P = Some x \<Longrightarrow> (x \<in> S0 \<and> P x \<and> (\<forall>x'\<in>S0. P x' \<longrightarrow> x' \<le> x))"
    by auto
qed

lemma iterate_sel_no_map_map_correct :
assumes it_OK: "map_iterator it m"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
      "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
       "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v))"
    by (auto simp add: map_to_set_def)
qed

lemma (in linorder) iterate_sel_no_map_map_linord_correct :
assumes it_OK: "map_iterator_linord it m"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
      "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v) \<and> (\<forall>k' v' . m k' = Some v' \<and>
           P (k', v') \<longrightarrow> k \<le> k'))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_map_linord_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
       "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v) \<and> (\<forall>k' v' . m k' = Some v' \<and>
           P (k', v') \<longrightarrow> k \<le> k'))"
    apply (auto simp add: map_to_set_def Ball_def)
  done
qed

lemma (in linorder) iterate_sel_no_map_map_rev_linord_correct :
assumes it_OK: "map_iterator_rev_linord it m"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
      "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v) \<and> (\<forall>k' v' . m k' = Some v' \<and>
           P (k', v') \<longrightarrow> k' \<le> k))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_map_rev_linord_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
       "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v) \<and> (\<forall>k' v' . m k' = Some v' \<and>
           P (k', v') \<longrightarrow> k' \<le> k))"
    apply (auto simp add: map_to_set_def Ball_def)
  done
qed

subsection {* Creating ordered iterators *}

text {* One can transform an iterator into an ordered one by converting it to list,
        sorting this list and then converting back to an iterator. In general, this brute-force
        method is inefficient, though. *}

definition iterator_to_ordered_iterator where
  "iterator_to_ordered_iterator sort_fun it =
   foldli (sort_fun (iterate_to_list it))"

lemma iterator_to_ordered_iterator_correct :
assumes sort_fun_OK: "\<And>l. sorted_by_rel R (sort_fun l) \<and> mset (sort_fun l) = mset l"
    and it_OK: "set_iterator it S0"
shows "set_iterator_genord (iterator_to_ordered_iterator sort_fun it) S0 R"
proof -
  def l \<equiv> "iterate_to_list it"
  have l_props: "set l = S0" "distinct l"
    using iterate_to_list_correct [OF it_OK, folded l_def] by simp_all

  with sort_fun_OK[of l] have sort_l_props:
    "sorted_by_rel R (sort_fun l)"
    "set (sort_fun l) = S0" "distinct (sort_fun l)"
    apply (simp_all)
    apply (metis set_mset_mset)
    apply (metis distinct_count_atmost_1 set_mset_mset)
  done

  show ?thesis
    apply (rule set_iterator_genord_I[of "sort_fun l"])
    apply (simp_all add: sort_l_props iterator_to_ordered_iterator_def l_def[symmetric])
  done
qed

definition iterator_to_ordered_iterator_quicksort where
  "iterator_to_ordered_iterator_quicksort R it =
   iterator_to_ordered_iterator (quicksort_by_rel R []) it"

lemmas iterator_to_ordered_iterator_quicksort_code[code] =
  iterator_to_ordered_iterator_quicksort_def[unfolded iterator_to_ordered_iterator_def]

lemma iterator_to_ordered_iterator_quicksort_correct :
assumes lin : "\<And>x y. (R x y) \<or> (R y x)"
    and trans_R: "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
    and it_OK: "set_iterator it S0"
shows "set_iterator_genord (iterator_to_ordered_iterator_quicksort R it) S0 R"
unfolding iterator_to_ordered_iterator_quicksort_def
apply (rule iterator_to_ordered_iterator_correct [OF _ it_OK])
apply (simp_all add: sorted_by_rel_quicksort_by_rel[OF lin trans_R])
done

definition iterator_to_ordered_iterator_mergesort where
  "iterator_to_ordered_iterator_mergesort R it =
   iterator_to_ordered_iterator (mergesort_by_rel R) it"

lemmas iterator_to_ordered_iterator_mergesort_code[code] =
  iterator_to_ordered_iterator_mergesort_def[unfolded iterator_to_ordered_iterator_def]

lemma iterator_to_ordered_iterator_mergesort_correct :
assumes lin : "\<And>x y. (R x y) \<or> (R y x)"
    and trans_R: "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
    and it_OK: "set_iterator it S0"
shows "set_iterator_genord (iterator_to_ordered_iterator_mergesort R it) S0 R"
unfolding iterator_to_ordered_iterator_mergesort_def
apply (rule iterator_to_ordered_iterator_correct [OF _ it_OK])
apply (simp_all add: sorted_by_rel_mergesort_by_rel[OF lin trans_R])
done

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   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.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_32
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun min :: "Nat => Nat => Nat" where
  "min (Z) y = Z"
| "min (S z) (Z) = Z"
| "min (S z) (S y1) = S (min z y1)"

theorem property0 :(* Similar to TIP_prop_23.thy *)
  "((min a b) = (min b a))"
  apply(induct a arbitrary:b)
   apply(case_tac b)
    apply fastforce+
  apply(case_tac b)
   apply fastforce+
  done

end


theory ex3_07 imports Main "~~/src/HOL/IMP/AExp" "~~/src/HOL/IMP/BExp" begin

fun Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Eq a1 a2 = And (Not (Less a1 a2)) (Not (Less a2 a1))"

fun Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"Le a1 a2 = Not (Less a2 a1)"

theorem "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
apply auto
done

theorem "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
apply auto
done

end


theory Support
  imports "HOL-Nominal.Nominal"
begin

text \<open>
  An example showing that in general

  x\<sharp>(A \<union> B) does not imply  x\<sharp>A and  x\<sharp>B

  For this we set A to the set of even atoms and B to
  the set of odd atoms. Then A \<union> B, that is the set of
  all atoms, has empty support. The sets A, respectively B,
  however have the set of all atoms as their support.
\<close>

atom_decl atom

text \<open>The set of even atoms.\<close>
abbreviation
  EVEN :: "atom set"
where
  "EVEN \<equiv> {atom n | n. \<exists>i. n=2*i}"

text \<open>The set of odd atoms:\<close>
abbreviation
  ODD :: "atom set"
where
  "ODD \<equiv> {atom n | n. \<exists>i. n=2*i+1}"

text \<open>An atom is either even or odd.\<close>
lemma even_or_odd:
  fixes n :: nat
  shows "\<exists>i. (n = 2*i) \<or> (n=2*i+1)"
  by (induct n) (presburger)+

text \<open>
  The union of even and odd atoms is the set of all atoms.
  (Unfortunately I do not know a simpler proof of this fact.)\<close>
lemma EVEN_union_ODD:
  shows "EVEN \<union> ODD = UNIV"
  using even_or_odd
proof -
  have "EVEN \<union> ODD = (\<lambda>n. atom n) ` {n. \<exists>i. n = 2*i} \<union> (\<lambda>n. atom n) ` {n. \<exists>i. n = 2*i+1}" by auto
  also have "\<dots> = (\<lambda>n. atom n) ` ({n. \<exists>i. n = 2*i} \<union> {n. \<exists>i. n = 2*i+1})" by auto
  also have "\<dots> = (\<lambda>n. atom n) ` ({n. \<exists>i. n = 2*i \<or> n = 2*i+1})" by auto
  also have "\<dots> = (\<lambda>n. atom n) ` (UNIV::nat set)" using even_or_odd by auto
  also have "\<dots> = (UNIV::atom set)" using atom.exhaust
    by (auto simp add: surj_def)
  finally show "EVEN \<union> ODD = UNIV" by simp
qed

text \<open>The sets of even and odd atoms are disjunct.\<close>
lemma EVEN_intersect_ODD:
  shows "EVEN \<inter> ODD = {}"
  using even_or_odd
  by (auto) (presburger)

text \<open>
  The preceeding two lemmas help us to prove
  the following two useful equalities:\<close>

lemma UNIV_subtract:
  shows "UNIV - EVEN = ODD"
  and   "UNIV - ODD  = EVEN"
  using EVEN_union_ODD EVEN_intersect_ODD
  by (blast)+

text \<open>The sets EVEN and ODD are infinite.\<close>
lemma EVEN_ODD_infinite:
  shows "infinite EVEN"
  and   "infinite ODD"
unfolding infinite_iff_countable_subset
proof -
  let ?f = "\<lambda>n. atom (2*n)"
  have "inj ?f \<and> range ?f \<subseteq> EVEN" by (auto simp add: inj_on_def)
  then show "\<exists>f::nat\<Rightarrow>atom. inj f \<and> range f \<subseteq> EVEN" by (rule_tac exI)
next
  let ?f = "\<lambda>n. atom (2*n+1)"
  have "inj ?f \<and> range ?f \<subseteq> ODD" by (auto simp add: inj_on_def)
  then show "\<exists>f::nat\<Rightarrow>atom. inj f \<and> range f \<subseteq> ODD" by (rule_tac exI)
qed

text \<open>
  A general fact about a set S of atoms that is both infinite and
  coinfinite. Then S has all atoms as its support. Steve Zdancewic
  helped with proving this fact.\<close>

lemma supp_infinite_coinfinite:
  fixes S::"atom set"
  assumes asm1: "infinite S"
  and     asm2: "infinite (UNIV-S)"
  shows "(supp S) = (UNIV::atom set)"
proof -
  have "\<forall>(x::atom). x\<in>(supp S)"
  proof
    fix x::"atom"
    show "x\<in>(supp S)"
    proof (cases "x\<in>S")
      case True
      have "x\<in>S" by fact
      hence "\<forall>b\<in>(UNIV-S). [(x,b)]\<bullet>S\<noteq>S" by (auto simp add: perm_set_def calc_atm)
      with asm2 have "infinite {b\<in>(UNIV-S). [(x,b)]\<bullet>S\<noteq>S}" by (rule infinite_Collection)
      hence "infinite {b. [(x,b)]\<bullet>S\<noteq>S}" by (rule_tac infinite_super, auto)
      then show "x\<in>(supp S)" by (simp add: supp_def)
    next
      case False
      have "x\<notin>S" by fact
      hence "\<forall>b\<in>S. [(x,b)]\<bullet>S\<noteq>S" by (auto simp add: perm_set_def calc_atm)
      with asm1 have "infinite {b\<in>S. [(x,b)]\<bullet>S\<noteq>S}" by (rule infinite_Collection)
      hence "infinite {b. [(x,b)]\<bullet>S\<noteq>S}" by (rule_tac infinite_super, auto)
      then show "x\<in>(supp S)" by (simp add: supp_def)
    qed
  qed
  then show "(supp S) = (UNIV::atom set)" by auto
qed

text \<open>As a corollary we get that EVEN and ODD have infinite support.\<close>
lemma EVEN_ODD_supp:
  shows "supp EVEN = (UNIV::atom set)"
  and   "supp ODD  = (UNIV::atom set)"
  using supp_infinite_coinfinite UNIV_subtract EVEN_ODD_infinite
  by simp_all

text \<open>
  The set of all atoms has empty support, since any swappings leaves
  this set unchanged.\<close>

lemma UNIV_supp:
  shows "supp (UNIV::atom set) = ({}::atom set)"
proof -
  have "\<forall>(x::atom) (y::atom). [(x,y)]\<bullet>UNIV = (UNIV::atom set)"
    by (auto simp add: perm_set_def calc_atm)
  then show "supp (UNIV::atom set) = ({}::atom set)" by (simp add: supp_def)
qed

text \<open>Putting everything together.\<close>
theorem EVEN_ODD_freshness:
  fixes x::"atom"
  shows "x\<sharp>(EVEN \<union> ODD)"
  and   "\<not>x\<sharp>EVEN"
  and   "\<not>x\<sharp>ODD"
  by (auto simp only: fresh_def EVEN_union_ODD EVEN_ODD_supp UNIV_supp)

text \<open>Moral: support is a sublte notion.\<close>

end


theory Mereotopology
imports Mereology
begin
section {* theories *}

subsection {* Ground Topology *}

locale T =
 fixes C :: "i \<Rightarrow> i \<Rightarrow> bool" ("C")--"Connectedness"
 assumes connection_reflexivity: "C x x" -- "reflexivity of connectedness "
 and connection_symmetry: "C x y \<longrightarrow> C y x" -- "symmetry of connectedness"

begin

definition E :: "i \<Rightarrow> i \<Rightarrow> bool" ("E") --"Enclosure"
  where "E x y \<equiv> \<forall>z. C z x \<longrightarrow> C z y"

lemma enclosure_reflexivity: "E x x"
  by (simp add: E_def)

lemma enclosure_transitivity: "E x y \<longrightarrow> E y z \<longrightarrow> E x z "
  by (simp add: E_def)

lemma connection_extensional: "(\<forall> z. C x z \<longleftrightarrow> C y z) \<longleftrightarrow> x = y" nitpick oops

lemma
  assumes connection_extensional: "(\<forall> z. C x z \<longleftrightarrow> C y z) \<longleftrightarrow> x = y"
  shows enclousre_antisymmetry: "E x y \<and> E y x \<longrightarrow> x = y"
    using E_def connection_extensional connection_symmetry by blast

end

section{* Ground Mereotopology *}

locale MT = ground_mereology + T +
  assumes monotonicity: "P x y \<longrightarrow> E x y"

begin

lemma "P x y \<longrightarrow> (\<forall>z. C x z \<longrightarrow> C z y)"
  using E_def monotonicity connection_symmetry by blast

lemma connection_extensional: "(\<forall> z. C x z \<longleftrightarrow> C y z) \<longleftrightarrow> x = y" nitpick oops

lemma overlap_implies_connection: "O x y \<longrightarrow> C x y"
  using E_def monotonicity overlap_def connection_symmetry connection_reflexivity by blast

lemma  "C x y \<longrightarrow> O x y" nitpick oops

definition EC :: "i => i\<Rightarrow> bool" ("EC") -- "external connection"
  where "EC x y \<equiv> C x y \<and> D x y"

lemma external_connection_irreflexive: "\<not> EC x x"
  by (simp add: EC_def disjoint_irreflexive)

lemma external_connection_symmetric: "EC x y \<longrightarrow> EC y x"
  using EC_def connection_symmetry disjoint_symmetric by blast

definition IP :: "i => i\<Rightarrow> bool" ("IP") -- "Internal part - part of y connected only to overlappers of y"
  where
"IP x y \<equiv> P x y \<and> (\<forall>z. C z x \<longrightarrow> O z y)"

lemma internal_part_antisymmetry: "IP x y \<longrightarrow> IP y x \<longrightarrow> x = y"
  by (simp add: IP_def P_antisymmetry)

lemma internal_part_transitivity: "IP x y \<longrightarrow> IP y z \<longrightarrow> IP x z"
  using IP_def P_transitivity overlap_implies_connection by blast

definition TP :: "i \<Rightarrow> i \<Rightarrow> bool" ("TP") -- "Tangential part"
  where "TP x y \<equiv> P x y \<and> \<not> IP x y"

lemma tangential_part_reflexivity: "\<exists> y. TP y x \<longrightarrow> TP x x" by simp

lemma tangential_part_antisymmetry: "TP x y \<longrightarrow> TP y x \<longrightarrow> x = y"
  by (simp add: P_antisymmetry TP_def)

definition IO :: "i \<Rightarrow> i \<Rightarrow> bool" ("IO")--"Internal overlap"
  where
"IO x y \<equiv> \<exists> z. IP z x \<and> IP z y"

lemma IO_reflexive: "\<exists> y. IO y x \<longrightarrow> IO x x"
  by simp
lemma IO_symmetric: "IO x y \<longrightarrow> IO y x"
  using IO_def by blast

definition TO :: "i \<Rightarrow> i \<Rightarrow> bool" ("TO")--"tangential overlap"
  where
"TO x y \<equiv> O x y \<and> \<not>IO x y"

lemma TO_reflexive: "\<exists> y. TO y x \<longrightarrow> TO x x"
  by simp
lemma TO_symmetric: "TO x y \<longrightarrow> TO y x"
  using IO_symmetric TO_def overlap_symmetric by blast

definition IU :: "i\<Rightarrow>i\<Rightarrow> bool" ("IU")--"Internal underlap"
  where "IU x y \<equiv> \<exists>z. IP x z \<and> IP y z"

definition TU :: "i\<Rightarrow>i\<Rightarrow>bool" ("TU")--"Tangentially underlap"
  where "TU x y \<equiv> U x y \<and> \<not> IU x y"

definition IPP :: "i => i\<Rightarrow> bool" ("IPP")--"internal proper part"
  where "IPP x y \<equiv> IP x y \<and> \<not>(IP y x)"

definition TPP :: "i\<Rightarrow>i\<Rightarrow>bool" ("TPP")--"tangential proper part"
  where
"TPP x y \<equiv> TP x y \<and> \<not>( TP y x)"

definition SC :: "i \<Rightarrow> bool" ("SC") -- "Self-connectedness"
  where
"SC x \<equiv> \<forall> y.\<forall> z.(\<forall> w. O w x \<longleftrightarrow> O w y \<or> O w z) \<longrightarrow> C y z"

end

section {* Closed Mereotopology *}

locale CMT = closure_mereology + MT +
  assumes connection_implies_underlap: "C x y \<longrightarrow> U x y "

lemma (in CMT) SCC: "(C x y \<and> SC x \<and> SC y) \<longrightarrow> (\<exists>z. SC z \<and> (\<forall> w. O w z \<longleftrightarrow> O w x \<or> O w y))" nitpick [user_axioms] oops

text {* The failure of SCC in closed minimal mereotopology seems to be a minor error in Casati and Varzi. *}

locale CEMT = closed_extensional_mereology + CMT

section {* Classical Extensional Mereotopology *}

locale GEMT = classical_extensional_mereology + MT

begin

lemma C_implies_U: "C x y \<longrightarrow> U x y"
  by (simp add: universal_underlap)

lemma "\<forall> x. IP x u"
  by (simp add: IP_def P_implies_overlap universe_character)

lemma SC_def2:  "SC x \<longleftrightarrow> (\<forall> y z. x = (y \<oplus> z) \<longrightarrow> C y z)"
proof
  assume "SC x"
  hence "\<forall> y z. (\<forall> w. O w x \<longleftrightarrow> (O w y \<or> O w z)) \<longrightarrow> C y z"
    using SC_def by simp
  thus "(\<forall> y z. x = (y \<oplus> z) \<longrightarrow> C y z)"
    using sum_character by simp
next
  assume "\<forall> y z. x = (y \<oplus> z) \<longrightarrow> C y z"
  have "\<forall> y z. (\<forall> w. O w x \<longleftrightarrow> (O w y \<or> O w z)) \<longrightarrow> C y z"
  proof fix y
    show "\<forall> z. (\<forall> w. O w x \<longleftrightarrow> (O w y \<or> O w z)) \<longrightarrow> C y z"
    proof fix z
      show "(\<forall> w. O w x \<longleftrightarrow> (O w y \<or> O w z)) \<longrightarrow> C y z"
      proof
        assume "\<forall> w. O w x \<longleftrightarrow> (O w y \<or> O w z)"
        with sum_intro have "(y \<oplus> z) = x"..
        thus "C y z" using \<open>\<forall>y z. x = y \<oplus> z \<longrightarrow> C y z\<close> by blast
      qed
    qed
  qed
  thus "SC x" using SC_def by simp
qed

lemma separation: "O x y \<longrightarrow> O x z \<longrightarrow> (P x (y \<oplus> z) \<longrightarrow> ((x \<otimes> y) \<oplus> (x \<otimes> z)) = x)" sorry (* Can you prove this? *)

lemma identity: "x \<oplus> y = w \<oplus> v \<longrightarrow> \<not> (O v x \<and> O w x \<or> O v y \<and> O w y) \<longrightarrow> x = w \<and> y = v \<or> x = v \<and> y = w"  sorry (* Can you prove this? *)

lemma connected_self_connected_sum: "(C x y \<and> SC x \<and> SC y) \<longrightarrow> SC (x \<oplus> y)"
proof
  assume "C x y \<and> SC x \<and> SC y"
  have "\<forall> v w. (x \<oplus> y) = (v \<oplus> w) \<longrightarrow> C v w"
  proof
    fix v
    show "\<forall> w. (x \<oplus> y) = (v \<oplus> w) \<longrightarrow> C v w"
    proof
      fix w
      show "(x \<oplus> y) = (v \<oplus> w) \<longrightarrow> C v w"
      proof
        assume "(x \<oplus> y) = (v \<oplus> w)"
        show "C v w"
        proof (cases)
          assume "O v x \<and> O w x \<or> O v y \<and> O w y"
          thus "C v w"
          proof (rule disjE)
            assume "O v x \<and> O w x"
            hence "P x (v \<oplus> w) \<longrightarrow>  x = ((x \<otimes> v) \<oplus> (x \<otimes> w))"
              by (simp add: \<open>O v x \<and> O w x\<close> overlap_symmetric separation)
            have "P x (v \<oplus> w)"
              by (metis \<open>x \<oplus> y = v \<oplus> w\<close> first_summand_inclusion)
            hence "x = ((x \<otimes> v) \<oplus> (x \<otimes> w))"
              using \<open>x \<preceq> v \<oplus> w \<longrightarrow> x = x \<otimes> v \<oplus> x \<otimes> w\<close> by auto
            hence "C (x \<otimes> v) (x \<otimes> w)"
              using SC_def2 \<open>C x y \<and> SC x \<and> SC y\<close> by blast
            hence "C v (x \<otimes> w)"
              by (metis P_of_first_factor T.E_def T_axioms \<open>O v x \<and> O w x\<close> connection_symmetry monotonicity product_commutative)
            thus "C v w"
              by (metis P_of_first_factor T.E_def T_axioms \<open>O v x \<and> O w x\<close> monotonicity product_commutative)
          next
            assume "O v y \<and> O w y"
            hence "P y (v \<oplus> w) \<longrightarrow>  y = ((y \<otimes> v) \<oplus> (y \<otimes> w))"
              by (simp add: \<open>O v y \<and> O w y\<close> overlap_symmetric separation)
            have "P y (v \<oplus> w)"
              by (metis \<open>x \<oplus> y = v \<oplus> w\<close> second_summand_inclusion)
            hence "y = ((y \<otimes> v) \<oplus> (y \<otimes> w))"
              using \<open>y \<preceq> v \<oplus> w \<longrightarrow> y = y \<otimes> v \<oplus> y \<otimes> w\<close> by auto
            hence "C (y \<otimes> v) (y \<otimes> w)"
              using SC_def2 \<open>C x y \<and> SC x \<and> SC y\<close> by blast
            hence "C v (y \<otimes> w)"
              by (metis E_def P_of_first_factor \<open>O v y \<and> O w y\<close> connection_symmetry monotonicity product_commutative)
            thus "C v w"
              by (metis E_def P_of_first_factor \<open>O v y \<and> O w y\<close> monotonicity product_commutative)
          qed
        next
          assume "\<not> (O v x \<and> O w x \<or> O v y \<and> O w y)"
          hence "x = w \<and> y = v \<or> x = v \<and> y = w"
            using identity \<open>x \<oplus> y = v \<oplus> w\<close> by auto
          thus "C v w"
            using \<open>C x y \<and> SC x \<and> SC y\<close> connection_symmetry by blast
        qed
      qed
    qed
  qed
  thus "SC (x \<oplus> y)" using SC_def2 by simp
qed

lemma "(C x y \<and> SC x \<and> SC y) \<longrightarrow> (\<exists> z. SC z \<and> (\<forall> w. O w z \<longleftrightarrow> O w x \<or> O w y))"
proof
  assume "(C x y \<and> SC x \<and> SC y)"
  with connected_self_connected_sum have "SC (x \<oplus> y)"..
  have "\<forall> w. O w (x \<oplus> y) \<longleftrightarrow> O w x \<or> O w y" using sum_character.
  hence "SC (x \<oplus> y) \<and> (\<forall> w. O w (x \<oplus> y) \<longleftrightarrow> O w x \<or> O w y)"
    using \<open>SC (x \<oplus> y)\<close> by simp
  thus "\<exists> z. SC z \<and> (\<forall> w. O w z \<longleftrightarrow> O w x \<or> O w y)"..
qed

definition i :: "(i \<Rightarrow> i)" ("\<^bold>i")--"interior"
  where "\<^bold>i x \<equiv> \<sigma> z. IP z x"

lemma interior_fusion: "(\<exists> y. IP y x) \<longrightarrow> (\<exists> v. \<forall> y. O y v \<longleftrightarrow> (\<exists> z. IP z x \<and> O z y))" using fusion.

lemma interior_intro: "(\<forall> y. O y a \<longleftrightarrow> (\<exists> z. IP z x \<and> O z y)) \<longrightarrow> (\<^bold>i x) = a"
proof -
  have "(\<forall> y. O y a \<longleftrightarrow> (\<exists> z. IP z x \<and> O z y)) \<longrightarrow> (\<sigma> z. IP z x) = a" using general_sum_intro.
  thus ?thesis using i_def by simp
qed

lemma interior_character: "(\<exists> y. IP y x) \<longrightarrow> (\<forall> y. O y (\<^bold>i x) \<longleftrightarrow> (\<exists> z. IP z x \<and> O z y))"
proof
  assume antecedent: "(\<exists> y. IP y x)"
  with interior_fusion have "\<exists> v. \<forall> y. O y v \<longleftrightarrow> (\<exists> z. IP z x \<and> O z y)"..
  then obtain v where v: "\<forall> y. O y v \<longleftrightarrow> (\<exists> z. IP z x \<and> O z y)"..
  with interior_intro have "(\<^bold>i x) = v"..
  thus "(\<forall> y. O y (\<^bold>i x) \<longleftrightarrow> (\<exists> z. IP z x \<and> O z y))"
    using v by blast
qed

lemma interior_is_part: "(\<exists> y. IP y x) \<longrightarrow> P (\<^bold>i x) x" -- "the interior of an individual is part of it"
proof
  assume "(\<exists> y. IP y x)"
  with interior_fusion have "\<exists> v. \<forall> y. O y v \<longleftrightarrow> (\<exists> z. IP z x \<and> O z y)"..
  then obtain a where a: "\<forall> y. O y a \<longleftrightarrow> (\<exists> z. IP z x \<and> O z y)"..
  with interior_intro have "(\<^bold>i x) = a"..
  thus "P (\<^bold>i x) x"
    by (metis IP_def P_overlappers_overlap a overlap_symmetric)
qed

lemma interior_overlaps: "(\<exists> y. IP y x) \<longrightarrow> O (\<^bold>i x) x"
  by (simp add: P_implies_overlap interior_is_part)
lemma interior_connects:  "(\<exists> y. IP y x) \<longrightarrow> C (\<^bold>i x) x"
  using P_implies_overlap interior_is_part overlap_implies_connection by blast
lemma encloses_interior:  "(\<exists> y. IP y x) \<longrightarrow> E (\<^bold>i x) x"
  by (simp add: interior_is_part monotonicity)

lemma "(\<exists> y. IP y x) \<longrightarrow> (\<exists> y. IP y z) \<longrightarrow> P z x \<longrightarrow> P (\<^bold>i z) (\<^bold>i x)" nitpick oops

definition e :: "(i\<Rightarrow>i)" ("e") -- "exterior"
  where "e x \<equiv> \<^bold>i (\<midarrow> x)"

lemma exterior_closure: "(\<exists> y. IP y (\<midarrow> x)) \<longrightarrow> (\<exists> a. \<forall> y. O y a \<longleftrightarrow> (\<exists> z. IP z (\<midarrow> x) \<and> O z y))" sorry (* prove this! *)

lemma exterior_intro: "(\<forall> y. O y a \<longleftrightarrow> (\<exists> z. IP z (\<midarrow> x) \<and> O z y)) \<longrightarrow> (e x) = a"
proof
  assume "(\<forall> y. O y a \<longleftrightarrow> (\<exists> z. IP z (\<midarrow> x) \<and> O z y))"
  with interior_intro have "(\<^bold>i (\<midarrow> x)) = a"..
  thus "(e x) = a"
    using e_def by simp
qed

lemma exterior_character: "(\<exists> y. IP y (\<midarrow> x)) \<longrightarrow> (\<forall> y. O y (e x) \<longleftrightarrow> (\<exists> z. IP z (\<midarrow> x) \<and> O z y))" sorry (* prove this! *)

lemma "x \<noteq> u \<and> (\<exists> y. IP y (\<midarrow> x)) \<longrightarrow> \<not> P (e x) x"
  using e_def P_implies_overlap in_comp_iff_disjoint interior_is_part disjoint_def by fastforce

lemma "x \<noteq> u \<and> (\<exists> y. IP y (\<midarrow> x)) \<longrightarrow> \<not> P x (e x)"
  by (metis e_def P_implies_overlap P_overlappers_overlap complement_disjointness interior_is_part disjoint_def)

lemma "x \<noteq> u \<and> (\<exists> y. IP y (\<midarrow> x)) \<longrightarrow> D x (e x)"
  using complement_disjointness P_overlappers_overlap extensional_mereology_axioms
exterior_character interior_character interior_is_part disjoint_def by blast

definition c :: "i\<Rightarrow>i" ("c")--"closure"
  where
"c x \<equiv> \<midarrow> (e x)"

lemma closure_intro:  "(\<forall> y. P y a \<longleftrightarrow> D y (e x)) \<longrightarrow> (c x) = a"
  by (metis P_antisymmetry P_implies_overlap P_overlappers_overlap P_reflexivity c_def
complement_character disjoint_def overlap_def overlap_symmetric overlap_def overlap_reflexive)

lemma closure_character: "x \<noteq> u \<and> (\<exists> y. IP y (\<midarrow> x)) \<longrightarrow> (\<forall> y. P y (c x) \<longleftrightarrow> D y (e x))" sorry (* prove this *)

lemma closure_closure: "x \<noteq> u \<and> (\<exists> y. IP y (\<midarrow> x)) \<longrightarrow> (\<exists> a. \<forall> y. P y a \<longleftrightarrow> D y (e x))"
proof
  assume antecedent: "x \<noteq> u \<and> (\<exists> y. IP y (\<midarrow> x))"
  with closure_character have "(\<forall> y. P y (c x) \<longleftrightarrow> D y (e x))"..
  thus "(\<exists> a. \<forall> y. P y a \<longleftrightarrow> D y (e x))"..
qed

lemma closure_inclusion: "x \<noteq> u \<and> (\<exists> y. IP y (\<midarrow> x)) \<longrightarrow> P x (c x)"
  using closure_character disjoint_symmetric e_def in_comp_iff_disjoint interior_is_part by fastforce

lemma closure_overlap: "x \<noteq> u \<and> (\<exists> y. IP y (\<midarrow> x)) \<longrightarrow> O x (c x)"
  by (simp add: P_implies_overlap closure_inclusion)

lemma closure_connection: "x \<noteq> u \<and> (\<exists> y. IP y (\<midarrow> x)) \<longrightarrow> C x (c x)"
  by (simp add: closure_overlap overlap_implies_connection)

definition b :: "i\<Rightarrow>i" ("b")--"boundary"
  where "b x \<equiv> \<midarrow> (\<^bold>i x \<oplus> e x)"

lemma boundary_closure: "(\<^bold>i x \<oplus> e x) \<noteq> u \<longrightarrow> x \<noteq> u \<longrightarrow> (\<exists> z. IP z x) \<longrightarrow> (\<exists> z. IP z (\<midarrow> x)) \<longrightarrow> (\<exists> a. \<forall> z. P z a \<longleftrightarrow> D z (\<^bold>i x \<oplus> e x))" sorry  (* prove this *)

lemma boundary_intro : "(\<forall> w. P w a \<longleftrightarrow> D w (\<^bold>i x \<oplus> e x)) \<longrightarrow> b x = a" (* Very good work on proving this in the last version *)
  by (metis P_antisymmetry P_implies_overlap P_reflexivity b_def complement_character disjoint_def)

lemma boundary_character: "(\<^bold>i x \<oplus> e x) \<noteq> u \<longrightarrow> x \<noteq> u \<longrightarrow> (\<exists> z. IP z x) \<longrightarrow> (\<exists> z. IP z (\<midarrow> x)) \<longrightarrow> (\<forall> z. P z (b x) \<longleftrightarrow> D z (\<^bold>i x \<oplus> e x))" sorry (*prove this*)

text {* The following axioms are from Varzi "Parts, Wholes and Part-Whole Relations: The Prospects of Mereotopology page 273: *}

definition OP :: "i \<Rightarrow> bool" ("OP")--"open"
  where "OP x \<equiv> \<^bold>i x = x"

definition CL :: "i \<Rightarrow> bool" ("CL") -- "closed"
  where "CL x \<equiv> c x = x"

end

locale GEMTC = GEMT +
  assumes C4: "CL x \<and> CL y \<longrightarrow> CL (x \<oplus> y)"
  assumes C5: "(\<forall> x. F x \<longrightarrow> Cl x) \<longrightarrow> (\<exists> z. \<forall> y. F y \<longrightarrow> z \<preceq> y) \<longrightarrow> CL (\<pi> z. F z)"

begin

lemma C4': "OP x \<and> OP y \<longrightarrow> z = x \<otimes> y \<longrightarrow> OP z"  sorry (* can your prove this? *)

lemma C5': "(\<exists> x. F x) \<longrightarrow> (\<forall> x. F x \<longrightarrow> OP x) \<longrightarrow> OP (\<sigma> x. F x)"  sorry (* can you prove this? *)

lemma interior_inclusion : "\<exists> y. IP y x \<longrightarrow> P (\<^bold>i x) x"
  by (simp add: IP_def)

lemma interior_idempotence: "\<exists> y. IP y x \<longrightarrow> \<^bold>i (\<^bold>i x) = \<^bold>i x"
  by (metis IP_def P_overlappers_overlap interior_character internal_part_antisymmetry overlap_reflexive)

lemma interior_distributes_over_product:
"(\<exists> z. IP z (x \<otimes> y)) \<and> (\<exists> z. IP z x) \<and> (\<exists> z. IP z y) \<longrightarrow> \<^bold>i (x \<otimes> y) = \<^bold>i x \<otimes> \<^bold>i y" sorry (* This proof might be a hard one. *)

lemma closure_inclusion: "(\<exists> y. IP y (\<midarrow> x)) \<longrightarrow> P x (c x)" sorry (* can you prove this? *)

lemma closure_idempotence: "(\<exists> y. IP y (\<midarrow> x)) \<longrightarrow> c (c x) = c x"  sorry (* can you prove this? *)

lemma closure_distributes_over_sum:
"(\<exists> z. IP z (\<midarrow>(x \<oplus> y))) \<longrightarrow> (\<exists> z. IP z (\<midarrow> x)) \<longrightarrow> (\<exists> z. IP z (\<midarrow> y)) \<longrightarrow> c (x \<oplus> y) = c x \<oplus> c y" sorry (* This proof might be a hard one. *)

lemma boundary_sharing:
  assumes "(\<^bold>i x \<oplus> e x) \<noteq> u \<longrightarrow> x \<noteq> u \<longrightarrow> (\<exists> z. IP z x) \<longrightarrow> (\<exists> z. IP z (\<midarrow> x))"
  shows  "b x = b (\<midarrow> x)"  sorry  (* can your prove this? *)

lemma boundary_idempotence:
  assumes "(\<^bold>i x \<oplus> e x) \<noteq> u \<longrightarrow> x \<noteq> u \<longrightarrow> (\<exists> z. IP z x) \<longrightarrow> (\<exists> z. IP z (\<midarrow> x))"
  shows "b (b x) = b x"  sorry  (* can your prove this? *)

lemma boundary_distributes_over_sum:
  assumes "(\<^bold>i x \<oplus> e x) \<noteq> u \<longrightarrow> x \<noteq> u \<longrightarrow> (\<exists> z. IP z x) \<longrightarrow> (\<exists> z. IP z (\<midarrow> x))"
  shows "b (x \<otimes> y) \<oplus> b (x \<oplus> y) = b x \<oplus> b y"  sorry (* can your prove this? *)

(* These lemmas look helpful - well done: *)

lemma p_intro : "(\<forall>z. P a z \<longleftrightarrow> (P z (\<^bold>i x) \<and> P z (\<^bold>i y))) \<longrightarrow> ((\<^bold>i x) \<otimes> (\<^bold>i y)) = a"
  by (metis (full_types) P_antisymmetry P_implies_overlap complement_disjointness disjoint_def universe_closure universe_intro)

lemma p : "(\<forall>z. P a z \<longleftrightarrow> (P z x \<and> P z y)) \<longrightarrow> (x \<otimes> y) = a"
  by (metis P_antisymmetry P_implies_overlap disjoint_def in_comp_iff_disjoint universe_closure)

lemma pi : "(\<exists>w. IP a w \<and> (\<forall>v. P w v \<longleftrightarrow> P v x \<and> P v y)\<longrightarrow> a = \<^bold>i (x \<otimes> y))"
  by (meson P_antisymmetry P_reflexivity)

lemma pi2 : "(\<forall>z. O z a \<longleftrightarrow> (\<exists>w. IP w (x \<otimes> y) \<and> O w z))\<longrightarrow> \<^bold>i (x \<otimes> y) = a" sledgehammer oops

lemma Px : "\<exists>w. IP (x \<otimes> y) w \<longrightarrow> (\<forall>v. P w v \<longleftrightarrow> P v x \<and> P v y)" sledgehammer oops

lemma "(\<forall>v.\<exists>w. P w v \<and> P v x \<and> P v y \<longrightarrow> P w x \<and> P w y)"
  by auto

lemma Pi3 : "\<exists>w. IP (x \<otimes> y) w \<longrightarrow> P w x \<and> P w y"
  using IP_def by blast

lemma pp : "(\<exists>z. IP z (x \<otimes> y)) \<longrightarrow> P (\<^bold>i (x \<otimes> y)) (x \<otimes> y)"
  using interior_is_part by auto

lemma "\<not> (\<forall> x. C x a) \<longrightarrow> (\<forall> y. P y (e a) \<longleftrightarrow> \<not> C y a)"  oops

lemma "x \<noteq> u \<longrightarrow> (\<forall> y. P y (c x) \<longleftrightarrow> P y x \<or> (\<forall> z. P z y \<longrightarrow> C z x))"  oops

lemma  C_iff_O_orEC: "C x y \<longleftrightarrow> (O x y \<or> EC x y)"
  using EC_def disjoint_def overlap_implies_connection by blast

lemma  "EC x y \<longrightarrow> (\<exists> y. IP y (\<midarrow> x))"  oops

(* The following theses are still the main ones left to prove. But I don't feel we can attack it until
we at least understand the informal idea behind it. I will find out about this for you. *)

lemma C_implies_O_c:  "C x y \<longrightarrow> (O x (c y) \<or> O (c x) y)"  oops

lemma EC_implies_O_c: "((\<exists> z. IP z (\<midarrow> x)) \<or> (\<exists> z. IP z (\<midarrow> y))) \<longrightarrow>
EC x y \<longrightarrow> (O x (c y) \<or> O (c x) y)"
proof
  assume "(\<exists> z. IP z (\<midarrow> x)) \<or> (\<exists> z. IP z (\<midarrow> y))"
  thus "EC x y \<longrightarrow> (O x (c y) \<or> O (c x) y)"
  proof (rule disjE)
    assume "\<exists> z. IP z (\<midarrow> x)"
    show "EC x y \<longrightarrow> (O x (c y) \<or> O (c x) y)"
    proof
      assume "EC x y"
      hence "x \<noteq> u"
        using EC_def P_implies_overlap disjoint_def overlap_symmetric universe_character by blast
      hence "x \<noteq> u \<and> (\<exists> z. IP z (\<midarrow> x))" using \<open>\<exists>z. IP z (\<midarrow> x)\<close>..
      with closure_closure have "(\<exists> a. \<forall> y. P y a \<longleftrightarrow> D y (e x))"..
      then obtain a where a: "\<forall> y. P y a \<longleftrightarrow> D y (e x)"..
      with closure_intro have "(c x) = a"..
      hence "O (c x) y" sorry
      thus "O x (c y) \<or> O (c x) y"..
    qed
  next
    assume "(\<exists> z. IP z (\<midarrow> y))"
    show "EC x y \<longrightarrow> (O x (c y) \<or> O (c x) y)"
    proof
      assume "EC x y"
      hence "O x (c y)" sorry
      thus "O x (c y) \<or> O (c x) y"..
    qed
  qed
qed

lemma "C x y \<longleftrightarrow> (O x y \<or> (O x (c y) \<or> O (c x) y))" nitpick oops

lemma "C x y \<longleftrightarrow> (O x y \<or> (O x (c y) \<or> O (c x) y))"
proof
  assume "C x y"
  show "O x y \<or> (O x (c y) \<or> O (c x) y)"
  proof
    cases
    assume "O x y"
    thus "O x y \<or> (O x (c y) \<or> O (c x) y)"..
  next assume "D x y"
    hence "EC x y" using EC_def \<open>C x y\<close> by blast
    hence "(O x (c y) \<or> O (c x) y)"
      using EC_implies_O_c by blast
    thus "(O x y \<or> (O x (c y) \<or> O (c x) y))"..
  qed
next
  assume "O x y \<or> (O x (c y) \<or> O (c x) y)"
  thus "C x y"
  proof (rule disjE)
    assume "O x y"
    thus "C x y" by (simp add: overlap_imnplies_connection)
  next
    assume "(O x (c y) \<or> O (c x) y)"
    thus "C x y"
    proof (rule disjE)
      assume "O x (c y)"
      show "C x y"
      proof cases
        assume "y = u"
        hence "O x y"
          by (simp add: T11 T51a)
        thus "C x y" by (simp add: overlap_imnplies_connection)
      next
        assume "y \<noteq> u"
        thus "C x y"  sorry
      qed
        next
          assume "O (c x) y"
      show "C x y"
      proof
        cases
        assume "x = u"
        thus "C x y" using T10 T11 T51a overlap_imnplies_connection by blast
        next
          assume "x \<noteq> u"
          thus "C x y"  sorry
        qed
      qed
    qed
  qed

lemma "(\<exists> z. IP z x) \<and> (\<exists> z. IP z y) \<longrightarrow> EC x y \<longrightarrow> C z y \<and> \<not> C (\<^bold>i x) (\<^bold>i y)" oops

lemma "C x y \<longleftrightarrow> (O x y \<or> (O x (c y) \<or> O (c x) y))" oops

lemma  "x \<noteq> u \<and> (\<exists> z. IP z (\<midarrow> x)) \<and> y \<noteq> u \<and> (\<exists> z. IP z (\<midarrow> y)) \<longrightarrow>
 C x y \<longleftrightarrow> (O x y \<or> (O x (c y) \<or> O (c x) y))" sledgehammer oops

lemma (in GEmonotonicity) "x \<noteq> u \<and> (\<exists> z. IP z (\<midarrow> x)) \<and> y \<noteq> u \<and> (\<exists> z. IP z (\<midarrow> y)) \<longrightarrow>
 C x y \<longleftrightarrow> (O x y \<or> (O x (c y) \<or> O (c x) y))" sledgehammer oops

definition SSC :: "i\<Rightarrow>bool" ("SSC")
  where
"SSC x \<equiv> SC x \<and> SC (\<^bold>i x) "

definition MSSC :: "(i\<Rightarrow>bool)" ("MSSC")
  where
"MSSC x \<equiv> SSC x \<and> (\<forall>y. (SSC y \<and> O y x) \<longrightarrow> P y x)"

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   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.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_84
imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

fun zip :: "'a list => 'b list => (('a, 'b) pair) list" where
"zip (nil2) z = nil2"
| "zip (cons2 z2 x2) (nil2) = nil2"
| "zip (cons2 z2 x2) (cons2 x3 x4) =
     cons2 (pair2 z2 x3) (zip x2 x4)"

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

fun take :: "Nat => 'a list => 'a list" where
"take (Z) z = nil2"
| "take (S z2) (nil2) = nil2"
| "take (S z2) (cons2 x2 x3) = cons2 x2 (take z2 x3)"

fun len :: "'a list => Nat" where
"len (nil2) = Z"
| "len (cons2 z xs) = S (len xs)"

fun drop :: "Nat => 'a list => 'a list" where
"drop (Z) z = z"
| "drop (S z2) (nil2) = nil2"
| "drop (S z2) (cons2 x2 x3) = drop z2 x3"

theorem property0 :
  "((zip xs (x ys zs)) =
      (x (zip (take (len ys) xs) ys) (zip (drop (len ys) xs) zs)))"
  oops

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   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.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_81
imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun take :: "Nat => 'a list => 'a list" where
"take (Z) y = nil2"
| "take (S z) (nil2) = nil2"
| "take (S z) (cons2 x2 x3) = cons2 x2 (take z x3)"

fun drop :: "Nat => 'a list => 'a list" where
"drop (Z) y = y"
| "drop (S z) (nil2) = nil2"
| "drop (S z) (cons2 x2 x3) = drop z x3"

fun t2 :: "Nat => Nat => Nat" where
"t2 (Z) y = y"
| "t2 (S z) y = S (t2 z y)"

theorem property0 :
  "((take n (drop m xs)) = (drop m (take (t2 n m) xs)))"
  oops

end


(*  Title:       Category theory using Isar and Locales
    Author:      Greg O'Keefe, June, July, August 2003
    License: LGPL

Functors: Define functors and prove a trivial example.
*)

section \<open>Functors\<close>

theory Functors
imports Cat
begin

subsection \<open>Definitions\<close>

record ('o1,'a1,'o2,'a2) "functor" =
  om :: "'o1 \<Rightarrow> 'o2"
  am :: "'a1 \<Rightarrow> 'a2"

abbreviation
  om_syn  ("_ \<^bsub>\<o>\<^esub>" [81]) where
  "F\<^bsub>\<o>\<^esub> \<equiv> om F"

abbreviation
  am_syn  ("_ \<^bsub>\<a>\<^esub>" [81]) where
  "F\<^bsub>\<a>\<^esub> \<equiv> am F"

locale two_cats = AA?: category AA + BB?: category BB
    for AA :: "('o1,'a1,'m1)category_scheme" (structure)
    and BB :: "('o2,'a2,'m2)category_scheme" (structure) +
  fixes preserves_dom  ::  "('o1,'a1,'o2,'a2)functor \<Rightarrow> bool"
    and preserves_cod  ::  "('o1,'a1,'o2,'a2)functor \<Rightarrow> bool"
    and preserves_id  ::  "('o1,'a1,'o2,'a2)functor \<Rightarrow> bool"
    and preserves_comp  ::  "('o1,'a1,'o2,'a2)functor \<Rightarrow> bool"
  defines "preserves_dom G \<equiv> \<forall>f\<in>Ar\<^bsub>AA\<^esub>. G\<^bsub>\<o>\<^esub> (Dom\<^bsub>AA\<^esub> f) = Dom\<^bsub>BB\<^esub> (G\<^bsub>\<a>\<^esub> f)"
    and "preserves_cod G \<equiv> \<forall>f\<in>Ar\<^bsub>AA\<^esub>. G\<^bsub>\<o>\<^esub> (Cod\<^bsub>AA\<^esub> f) = Cod\<^bsub>BB\<^esub> (G\<^bsub>\<a>\<^esub> f)"
    and "preserves_id G \<equiv> \<forall>A\<in>Ob\<^bsub>AA\<^esub>. G\<^bsub>\<a>\<^esub> (Id\<^bsub>AA\<^esub> A) = Id\<^bsub>BB\<^esub> (G\<^bsub>\<o>\<^esub> A)"
    and "preserves_comp G \<equiv>
      \<forall>f\<in>Ar\<^bsub>AA\<^esub>. \<forall>g\<in>Ar\<^bsub>AA\<^esub>. Cod\<^bsub>AA\<^esub> f = Dom\<^bsub>AA\<^esub> g \<longrightarrow> G\<^bsub>\<a>\<^esub> (g \<bullet>\<^bsub>AA\<^esub> f) = (G\<^bsub>\<a>\<^esub> g) \<bullet>\<^bsub>BB\<^esub> (G\<^bsub>\<a>\<^esub> f)"

locale "functor" = two_cats +
  fixes F (structure)
  assumes F_preserves_arrows: "F\<^bsub>\<a>\<^esub> : Ar\<^bsub>AA\<^esub> \<rightarrow> Ar\<^bsub>BB\<^esub>"
    and F_preserves_objects: "F\<^bsub>\<o>\<^esub> : Ob\<^bsub>AA\<^esub> \<rightarrow> Ob\<^bsub>BB\<^esub>"
    and F_preserves_dom: "preserves_dom F"
    and F_preserves_cod: "preserves_cod F"
    and F_preserves_id: "preserves_id F"
    and F_preserves_comp: "preserves_comp F"
begin

lemmas F_axioms = F_preserves_arrows F_preserves_objects F_preserves_dom
  F_preserves_cod F_preserves_id F_preserves_comp

lemmas func_pred_defs = preserves_dom_def preserves_cod_def preserves_id_def preserves_comp_def

end

text \<open>This gives us nicer notation for asserting that things are functors.\<close>

abbreviation
  Functor  ("Functor _ : _ \<longrightarrow> _" [81]) where
  "Functor F : AA \<longrightarrow> BB \<equiv> functor AA BB F"

subsection \<open>Simple Lemmas\<close>

text \<open>For example:\<close>

lemma (in "functor") "Functor F : AA \<longrightarrow> BB" ..

lemma functors_preserve_arrows [intro]:
  assumes "Functor F : AA \<longrightarrow> BB"
    and "f \<in> ar AA"
  shows "F\<^bsub>\<a>\<^esub> f \<in> ar BB"
proof-
  from \<open>Functor F : AA \<longrightarrow> BB\<close>
  have "F\<^bsub>\<a>\<^esub> : ar AA \<rightarrow> ar BB"
    by (simp add: functor_def functor_axioms_def)
  from this and \<open>f \<in> ar AA\<close>
  show ?thesis by (rule funcset_mem)
qed

lemma (in "functor") functors_preserve_homsets:
  assumes 1: "A \<in> Ob\<^bsub>AA\<^esub>"
  and 2: "B \<in> Ob\<^bsub>AA\<^esub>"
  and 3: "f \<in> Hom\<^bsub>AA\<^esub> A B"
  shows "F\<^bsub>\<a>\<^esub> f \<in> Hom\<^bsub>BB\<^esub> (F\<^bsub>\<o>\<^esub> A) (F\<^bsub>\<o>\<^esub> B)"
proof-
  from 3
  have 4: "f \<in> Ar"
    by (simp add: hom_def)
  with F_preserves_arrows
  have 5: "F\<^bsub>\<a>\<^esub> f \<in> Ar\<^bsub>BB\<^esub>"
    by (rule funcset_mem)
  from 4 and F_preserves_dom
  have "Dom\<^bsub>BB\<^esub> (F\<^bsub>\<a>\<^esub> f) = F\<^bsub>\<o>\<^esub> (Dom\<^bsub>AA\<^esub> f)"
    by (simp add: preserves_dom_def)
  also from 3 have "\<dots> = F\<^bsub>\<o>\<^esub> A"
    by (simp add: hom_def)
  finally have 6: "Dom\<^bsub>BB\<^esub> (F\<^bsub>\<a>\<^esub> f) = F\<^bsub>\<o>\<^esub> A" .
  from 4 and F_preserves_cod
  have "Cod\<^bsub>BB\<^esub> (F\<^bsub>\<a>\<^esub> f) = F\<^bsub>\<o>\<^esub> (Cod\<^bsub>AA\<^esub> f)"
    by (simp add: preserves_cod_def)
  also from 3 have "\<dots> = F\<^bsub>\<o>\<^esub> B"
    by (simp add: hom_def)
  finally have 7: "Cod\<^bsub>BB\<^esub> (F\<^bsub>\<a>\<^esub> f) = F\<^bsub>\<o>\<^esub> B" .
  from 5 and 6 and 7
  show ?thesis
    by (simp add: hom_def)
qed

lemma functors_preserve_objects [intro]:
  assumes "Functor F : AA \<longrightarrow> BB"
    and "A \<in> ob AA"
  shows "F\<^bsub>\<o>\<^esub> A \<in> ob BB"
proof-
  from \<open>Functor F : AA \<longrightarrow> BB\<close>
  have "F\<^bsub>\<o>\<^esub> : ob AA \<rightarrow> ob BB"
    by (simp add: functor_def functor_axioms_def)
  from this and \<open>A \<in> ob AA\<close>
  show ?thesis by (rule funcset_mem)
qed

subsection \<open>Identity Functor\<close>

definition
  id_func :: "('o,'a,'m) category_scheme \<Rightarrow> ('o,'a,'o,'a) functor" where
  "id_func CC = \<lparr>om=(\<lambda>A\<in>ob CC. A), am=(\<lambda>f\<in>ar CC. f)\<rparr>"

locale one_cat = two_cats +
  assumes endo: "BB = AA"

lemma (in one_cat) id_func_preserves_arrows:
  shows "(id_func AA)\<^bsub>\<a>\<^esub> : Ar \<rightarrow> Ar"
  by (unfold id_func_def, rule funcsetI, simp)

lemma (in one_cat) id_func_preserves_objects:
  shows "(id_func AA)\<^bsub>\<o>\<^esub> : Ob \<rightarrow> Ob"
  by (unfold id_func_def, rule funcsetI, simp)

lemma (in one_cat) id_func_preserves_dom:
  shows  "preserves_dom (id_func AA)"
unfolding preserves_dom_def endo
proof
  fix f
  assume f: "f \<in> Ar"
  hence lhs: "(id_func AA)\<^bsub>\<o>\<^esub> (Dom f) = Dom f"
    by (simp add: id_func_def) auto
  have "(id_func AA)\<^bsub>\<a>\<^esub> f = f"
    using f by (simp add: id_func_def)
  hence rhs: "Dom (id_func AA)\<^bsub>\<a>\<^esub> f = Dom f"
    by simp
  from lhs and rhs show "(id_func AA)\<^bsub>\<o>\<^esub> (Dom f) = Dom (id_func AA)\<^bsub>\<a>\<^esub> f"
    by simp
qed

lemma (in one_cat) id_func_preserves_cod:
  "preserves_cod (id_func AA)"
apply (unfold preserves_cod_def, simp only: endo)
proof
  fix f
  assume f: "f \<in> Ar"
  hence lhs: "(id_func AA)\<^bsub>\<o>\<^esub> (Cod f) = Cod f"
    by (simp add: id_func_def) auto
  have "(id_func AA)\<^bsub>\<a>\<^esub> f = f"
    using f by (simp add: id_func_def)
  hence rhs: "Cod (id_func AA)\<^bsub>\<a>\<^esub> f = Cod f"
    by simp
  from lhs and rhs show "(id_func AA)\<^bsub>\<o>\<^esub> (Cod f) = Cod (id_func AA)\<^bsub>\<a>\<^esub> f"
    by simp
qed

lemma (in one_cat) id_func_preserves_id:
  "preserves_id (id_func AA)"
unfolding preserves_id_def endo
proof
  fix A
  assume A: "A \<in> Ob"
  hence lhs: "(id_func AA)\<^bsub>\<a>\<^esub> (Id A) = Id A"
    by (simp add: id_func_def) auto
  have "(id_func AA)\<^bsub>\<o>\<^esub> A = A"
    using A by (simp add: id_func_def)
  hence rhs: "Id ((id_func AA)\<^bsub>\<o>\<^esub> A) = Id A"
    by simp
  from lhs and rhs show "(id_func AA)\<^bsub>\<a>\<^esub> (Id A) = Id ((id_func AA)\<^bsub>\<o>\<^esub> A)"
    by simp
qed

lemma (in one_cat) id_func_preserves_comp:
  "preserves_comp (id_func AA)"
unfolding preserves_comp_def endo
proof (intro ballI impI)
  fix f and g
  assume f: "f \<in> Ar" and g: "g \<in> Ar" and "Cod f = Dom g"
  then have "g \<bullet> f \<in> Ar" ..
  hence lhs: "(id_func AA)\<^bsub>\<a>\<^esub> (g \<bullet> f) = g \<bullet> f"
    by (simp add: id_func_def)
  have id_f: "(id_func AA)\<^bsub>\<a>\<^esub> f = f"
    using f by (simp add: id_func_def)
  have id_g: "(id_func AA)\<^bsub>\<a>\<^esub> g = g"
    using g by (simp add: id_func_def)
  hence rhs: "(id_func AA)\<^bsub>\<a>\<^esub> g \<bullet> (id_func AA)\<^bsub>\<a>\<^esub> f = g \<bullet> f"
    by (simp add: id_f id_g)
  from lhs and rhs
  show "(id_func AA)\<^bsub>\<a>\<^esub> (g \<bullet> f) = (id_func AA)\<^bsub>\<a>\<^esub> g \<bullet> (id_func AA)\<^bsub>\<a>\<^esub> f"
    by simp
qed

theorem (in one_cat) id_func_functor:
  "Functor (id_func AA) : AA \<longrightarrow> AA"
proof-
  from id_func_preserves_arrows
    and id_func_preserves_objects
    and id_func_preserves_dom
    and id_func_preserves_cod
    and id_func_preserves_id
    and id_func_preserves_comp
  show ?thesis
    by unfold_locales (simp_all add: endo preserves_dom_def
      preserves_cod_def preserves_id_def preserves_comp_def)
qed

end


chapter \<open>General Lemmas for Proving Function Inequalities\<close>

theory Bounds_Lemmas
imports Complex_Main

begin

text\<open>These are for functions that are differentiable over a closed interval.\<close>

lemma gen_lower_bound_increasing:
  fixes a :: real
  assumes "a \<le> x"
      and "\<And>y. a \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> ((\<lambda>x. fl x - f x) has_real_derivative g y) (at y)"
      and "\<And>y. a \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> g y \<le> 0"
      and "fl a = f a"
    shows "fl x \<le> f x"
proof -
  have "fl x - f x \<le> fl a - f a"
    apply (rule DERIV_nonpos_imp_nonincreasing [where f = "\<lambda>x. fl x - f x"])
    apply (rule assms)
    apply (intro allI impI exI conjI)
    apply (rule assms | simp)+
    done
  also have "... = 0"
    by (simp add: assms)
  finally show ?thesis
    by simp
qed

lemma gen_lower_bound_decreasing:
  fixes a :: real
  assumes "x \<le> a"
      and "\<And>y. x \<le> y \<Longrightarrow> y \<le> a \<Longrightarrow> ((\<lambda>x. fl x - f x) has_real_derivative g y) (at y)"
      and "\<And>y. x \<le> y \<Longrightarrow> y \<le> a \<Longrightarrow> g y \<ge> 0"
      and "fl a = f a"
    shows "fl x \<le> f x"
proof -
  have "fl (- (-x)) \<le> f (- (-x))"
    apply (rule gen_lower_bound_increasing [of "-a" "-x" _ _ "\<lambda>u. - g (-u)"])
    apply (auto simp: assms)
    apply (subst DERIV_mirror [symmetric])
    apply (simp add: assms)
    done
  then show ?thesis
    by simp
qed

lemma gen_upper_bound_increasing:
  fixes a :: real
  assumes "a \<le> x"
      and "\<And>y. a \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> ((\<lambda>x. fu x - f x) has_real_derivative g y) (at y)"
      and "\<And>y. a \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> g y \<ge> 0"
      and "fu a = f a"
    shows "f x \<le> fu x"
apply (rule gen_lower_bound_increasing [of a x f fu  "\<lambda>u. - g u"])
using assms DERIV_minus [where f = "\<lambda>x. fu x - f x"]
apply auto
done

lemma gen_upper_bound_decreasing:
  fixes a :: real
  assumes "x \<le> a"
      and "\<And>y. x \<le> y \<Longrightarrow> y \<le> a \<Longrightarrow> ((\<lambda>x. fu x - f x) has_real_derivative g y) (at y)"
      and "\<And>y. x \<le> y \<Longrightarrow> y \<le> a \<Longrightarrow> g y \<le> 0"
      and "fu a = f a"
    shows "f x \<le> fu x"
apply (rule gen_lower_bound_decreasing [of x a _ _  "\<lambda>u. - g u"])
using assms DERIV_minus [where f = "\<lambda>x. fu x - f x"]
apply auto
done

end


header {* Example usage of the ``sturm'' method *}
(* Author: Manuel Eberl <eberlm@in.tum.de> *)
theory Sturm_Ex
imports "../Sturm"
begin

text {*
  In this section, we give a variety of statements about real polynomials that can b
  proven by the \emph{sturm} method.
*}

lemma
 "\<forall>x::real. x^2 + 1 \<noteq> 0"
by sturm

lemma
  fixes x :: real
  shows "x^2 + 1 \<noteq> 0" by sturm

lemma "(x::real) > 1 \<Longrightarrow> x^3 > 1" by sturm

lemma "\<forall>x::real. x*x \<noteq> -1" by sturm

schematic_lemma A:
"card {x::real. -0.010831 < x \<and> x < 0.010831 \<and>
    1/120*x^5 + 1/24*x^4 +1/6*x^3 - 49/16777216*x^2 - 17/2097152*x = 0}
  = ?n"
  by sturm

lemma "card {x::real. x^3 + x = 2*x^2 \<and> x^3 - 6*x^2 + 11*x = 6} = 1"
by sturm

schematic_lemma "card {x::real. x^3 + x = 2*x^2 \<or> x^3 - 6*x^2 + 11*x = 6} = ?n" by sturm

lemma
  "card {x::real. -0.010831 < x \<and> x < 0.010831 \<and>
     poly [:0, -17/2097152, -49/16777216, 1/6, 1/24, 1/120:] x = 0} = 3"
  by sturm

lemma "\<forall>x::real. x*x \<noteq> 0 \<or> x*x - 1 \<noteq> 2*x" by sturm

lemma "(x::real)*x+1 \<noteq> 0 \<and> (x^2+1)*(x^2+2) \<noteq> 0" by sturm

text{*3 examples related to continued fraction approximants to exp: LCP*}
lemma fixes x::real
  shows "-7.29347719 \<le> x \<Longrightarrow> 0 < x^5 + 30*x^4 + 420*x^3 + 3360*x^2 + 15120*x + 30240"
by sturm

lemma fixes x::real
  shows "0 < x^6 + 42*x^5 + 840*x^4 + 10080*x^3 + 75600*x\<^sup>2 + 332640*x + 665280"
by sturm

schematic_lemma "card {x::real. x^7 + 56*x^6 + 1512*x^5 + 25200*x^4 + 277200*x^3 + 1995840*x^2 + 8648640*x = -17297280} = ?n"
by sturm

end


\<^marker>\<open>creator "Alexander Krauss"\<close>
\<^marker>\<open>creator "Josh Chen"\<close>
\<^marker>\<open>creator "Kevin Kappelmann"\<close>
section\<open>Ordinals\<close>
theory Ordinals
  imports Least_Fixpoint
begin

text \<open>The class of ordinal numbers is defined abstractly, as the \<in>-transitive sets
whose members are also \<in>-transitive.\<close>

definition [typedef]: "Ord \<equiv> type (\<lambda>x. mem_trans x \<and> (\<forall>y \<in> x. mem_trans y))"

lemma OrdI: "mem_trans X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> mem_trans x) \<Longrightarrow> X : Ord"
  by unfold_types auto

text \<open>Basic properties of ordinals:\<close>

lemma Ord_if_mem_Ord [elim]: "x : Ord \<Longrightarrow> y \<in> x \<Longrightarrow> y : Ord"
  by unfold_types (unfold mem_trans_def, auto)

lemma mem_trans_if_Ord: "x : Ord \<Longrightarrow> mem_trans x"
  by unfold_types

lemma subset_if_mem_Ord [elim]: "x : Ord \<Longrightarrow> y \<in> x \<Longrightarrow> y \<subseteq> x"
  by unfold_types (fastforce simp: mem_trans_def)

lemma Subset_if_Element_Ord [derive]:
  "x : Ord \<Longrightarrow> y : Element x \<Longrightarrow> y : Subset x"
  (*TODO: should be discharged by the type checker*)
  by (intro SubsetI, drule ElementD) (fact subset_if_mem_Ord)

(*Adapted from a proof by Chad Brown*)
lemma Ord_eq_if_not_mem_if_not_mem:
  "X : Ord \<Longrightarrow> Y : Ord \<Longrightarrow> X \<notin> Y \<Longrightarrow> Y \<notin> X \<Longrightarrow> X = Y"
proof (induction X Y rule: mem_double_induct)
  fix X Y
  assume
    ord: "X : Ord" "Y: Ord" and
    IH1: "\<And>x. x \<in> X \<Longrightarrow> x : Ord \<Longrightarrow> Y : Ord \<Longrightarrow> x \<notin> Y \<Longrightarrow> Y \<notin> x \<Longrightarrow> x = Y" and
    IH2: "\<And>y. y \<in> Y \<Longrightarrow> X : Ord \<Longrightarrow> y : Ord \<Longrightarrow> X \<notin> y \<Longrightarrow> y \<notin> X \<Longrightarrow> X = y" and
    not_mem: "X \<notin> Y" "Y \<notin> X"
  show "X = Y"
  proof (rule eqI)
    fix x assume "x \<in> X"
    with \<open>X : Ord\<close> have "x \<subseteq> X" "x : Ord" by auto
    with not_mem ord IH1 \<open>x \<in> X\<close> show "x \<in> Y" by blast
  next
    fix y assume "y \<in> Y"
    with \<open>Y : Ord\<close>  have "y \<subseteq> Y" "y: Ord" by auto
    with not_mem ord IH2 \<open>y \<in> Y\<close> show "y \<in> X" by blast
  qed
qed

lemma Ord_trichotomy:
  assumes "X : Ord" "Y : Ord"
  obtains (lt) "X \<in> Y" | (eq) "X = Y" | (gt) "Y \<in> X"
  using assms Ord_eq_if_not_mem_if_not_mem by auto

lemma emptyset_Ord [type]: "{} : Ord"
  by unfold_types auto

subsection \<open>Successor ordinals\<close>

definition succ where "succ x \<equiv> x \<union> {x}"

lemma succ_type [type]: "succ : Ord \<Rightarrow> Ord"
  unfolding succ_def by unfold_types (unfold mem_trans_def, auto 5 0)

lemma mem_succE [elim]:
  assumes "x \<in> succ y"
  obtains "x \<in> y" | "x = y"
  using assms unfolding succ_def by auto

text \<open>Simp rules\<close>

lemma succ_empty_eq [iff]: "succ {} = {{}}"
  unfolding succ_def by simp

lemma succ_succ_empty_eq [iff]: "succ (succ {}) = {{}, {{}}}"
  unfolding succ_def by auto

lemma succ_ne_self [iff]: "succ x \<noteq> x"
  unfolding succ_def by auto

lemma succ_ne_empty [iff]: "succ x \<noteq> {}"
  unfolding succ_def by auto

lemma mem_succ_self [iff]: "x \<in> succ x"
  unfolding succ_def by auto

text \<open>Injectivity\<close>

lemma succ_inj [dest]: "succ x = succ y \<Longrightarrow> x = y"
proof (rule ccontr)
  assume succ_eq: "succ x = succ y" and neq: "x \<noteq> y"
  have "x \<in> succ x" and "y \<in> succ y" by auto
  then have "x \<in> succ y" and "y \<in> succ x" by (auto simp only: succ_eq)
  with neq have "x \<in> y" and "y \<in> x" by auto
  then show False using not_mem_if_mem by blast
qed

lemma succ_ne_if_ne [intro!]: "x \<noteq> y \<Longrightarrow> succ x \<noteq> succ y"
  by auto

lemma mem_succ_if_mem [intro]: "x \<in> y \<Longrightarrow> x \<in> succ y"
  unfolding succ_def by auto

lemma univ_closed_succ [intro!]: "x \<in> univ X \<Longrightarrow> succ x \<in> univ X"
  unfolding succ_def by auto

subsection \<open>The Smallest Infinite Ordinal \<omega>\<close>

definition "omega_op X = {{}} \<union> {succ x | x \<in> X}"

lemma omega_op_Monop [type]: "omega_op : Monop V"
  unfolding omega_op_def by (rule MonopI) auto

definition "omega \<equiv> lfp V omega_op"

bundle isa_set_omega_syntax begin notation omega ("\<omega>") end
bundle no_isa_set_omega_syntax begin no_notation omega ("\<omega>") end
unbundle isa_set_omega_syntax

lemma fixpoint_omega [iff]: "fixpoint \<omega> omega_op"
  unfolding omega_def by auto

lemma empty_mem_omega [iff]: "{} \<in> \<omega>"
  by (subst fixpoint_omega[unfolded fixpoint_def omega_op_def, symmetric])
    simp

lemma succ_mem_omega_if_mem [intro!]: "n \<in> \<omega> \<Longrightarrow> succ n \<in> \<omega>"
  by (subst fixpoint_omega[unfolded fixpoint_def omega_op_def, symmetric])
    auto

lemma omega_induct [case_names empty succ, induct set: omega]:
  assumes "n \<in> \<omega>"
  and "P {}"
  and "\<And>n. \<lbrakk>n \<in> \<omega>; P n\<rbrakk> \<Longrightarrow> P (succ n)"
  shows "P n"
  using \<open>n \<in> \<omega>\<close>[unfolded omega_def]
  by (rule lfp_induct[OF omega_op_Monop])
    (auto intro: assms(2-3) simp only: omega_op_def omega_def)

lemma mem_omegaE:
  assumes "n \<in> \<omega>"
  obtains (empty) "n = {}" | (succ) m where "m \<in> \<omega>" "n = succ m"
  using assms omega_induct[where ?P="\<lambda>m. n = m \<longrightarrow> _"] by blast

lemma eq_empty_or_empty_mem_if_mem_omegaE:
  assumes "n \<in> \<omega>"
  obtains (eq_empty) "n = {}" | (empty_mem) "{} \<in> n"
  using assms by (induction n rule: omega_induct) auto

lemma empty_mem_succ_if_mem_omega: "n \<in> \<omega> \<Longrightarrow> {} \<in> succ n"
  by (rule eq_empty_or_empty_mem_if_mem_omegaE) auto

lemma mem_trans_omega [iff]: "mem_trans \<omega>"
  by (rule mem_transI, rule omega_induct) auto

lemma mem_trans_if_mem_omega: "n \<in> \<omega> \<Longrightarrow> mem_trans n"
  by (induction n rule: omega_induct) (auto simp: mem_trans_def)

lemma omega_Ord [type]: "\<omega> : Ord"
  by (rule OrdI) (auto elim: mem_trans_if_mem_omega)

lemma Ord_if_mem_omega: "n \<in> \<omega> \<Longrightarrow> n : Ord"
  by (fact Ord_if_mem_Ord[OF omega_Ord])

lemma mem_trans_if_mem_omega' [trans]: "\<lbrakk>n \<in> \<omega>; k \<in> m; m \<in> n\<rbrakk> \<Longrightarrow> k \<in> n"
  using mem_trans_if_mem_omega[unfolded mem_trans_def] by auto

lemma mem_if_succ_mem_if_mem_omega: "n \<in> \<omega> \<Longrightarrow> succ m \<in> n \<Longrightarrow> m \<in> n"
  using mem_trans_if_mem_omega'[of n m "succ m"] by auto

lemma subset_omega_if_mem_omega: "n \<in> \<omega> \<Longrightarrow> n \<subseteq> \<omega>"
  using mem_trans_omega[unfolded mem_trans_def] by blast

lemma mem_omega_if_mem_if_mem_omega: "x \<in> \<omega> \<Longrightarrow> y \<in> x \<Longrightarrow> y \<in> \<omega>"
  using subset_omega_if_mem_omega by auto

lemma succ_mem_succ_if_mem_if_mem_omega:
  "\<lbrakk>n \<in> \<omega>; m \<in> n\<rbrakk> \<Longrightarrow> succ m \<in> succ n"
  by (induction n rule: omega_induct) auto

lemma mem_if_succ_mem_succ_if_mem_omega:
  assumes "n \<in> \<omega>" and succ_m_mem: "succ m \<in> succ n"
  shows "m \<in> n"
proof -
  have "mem_trans (succ n)" by (rule mem_trans_if_mem_omega) auto
  from mem_transD[OF this] have "succ m \<subseteq> succ n" by auto
  then have "m \<in> (n \<union> {n})" by auto
  with succ_m_mem show "m \<in> n" by auto
qed

lemma succ_mem_succ_iff_mem_if_mem_omega [iff]:
  "n \<in> \<omega> \<Longrightarrow> succ m \<in> succ n \<longleftrightarrow> m \<in> n"
  using succ_mem_succ_if_mem_if_mem_omega mem_if_succ_mem_succ_if_mem_omega
  by blast

end