(* Title:      Formal Power Series Model of Kleene Algebra
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Formal Power Series\<close>

theory Formal_Power_Series
imports Finite_Suprema Kleene_Algebra
begin

subsection \<open>The Type of Formal Power Series\<close>

text \<open>Formal powerseries are functions from a free monoid into a
dioid. They have applications in formal language theory, e.g.,
weighted automata. As usual, we represent elements of a free monoid
by lists.

This theory generalises Amine Chaieb's development of formal power
series as functions from natural numbers, which may be found in {\em
HOL/Library/Formal\_Power\_Series.thy}.\<close>

typedef ('a, 'b) fps = "{f::'a list \<Rightarrow> 'b. True}"
  morphisms fps_nth Abs_fps
  by simp

text \<open>It is often convenient to reason about functions, and transfer
results to formal power series.\<close>

setup_lifting type_definition_fps

declare fps_nth_inverse [simp]

notation fps_nth (infixl "$" 75)

lemma expand_fps_eq: "p = q \<longleftrightarrow> (\<forall>n. p $ n = q $ n)"
by (simp add: fps_nth_inject [symmetric] fun_eq_iff)

lemma fps_ext: "(\<And>n. p $ n = q $ n) \<Longrightarrow> p = q"
by (simp add: expand_fps_eq)

lemma fps_nth_Abs_fps [simp]: "Abs_fps f $ n = f n"
by (simp add: Abs_fps_inverse)

subsection \<open>Definition of the Basic Elements~0 and~1 and the Basic
Operations of Addition and Multiplication\<close>

text \<open>The zero formal power series maps all elements of the monoid
(all lists) to zero.\<close>

instantiation fps :: (type,zero) zero
begin
  definition zero_fps where
    "0 = Abs_fps (\<lambda>n. 0)"
  instance ..
end

lemma fps_zero_nth [simp]: "0 $ n = 0"
unfolding zero_fps_def by simp

text \<open>The unit formal power series maps the monoidal unit (the empty
list) to one and all other elements to zero.\<close>

instantiation fps :: (type,"{one,zero}") one
begin
  definition one_fps where
    "1 = Abs_fps (\<lambda>n. if n = [] then 1 else 0)"
  instance ..
end

lemma fps_one_nth_Nil [simp]: "1 $ [] = 1"
unfolding one_fps_def by simp

lemma fps_one_nth_Cons [simp]: "1 $ (x # xs) = 0"
unfolding one_fps_def by simp

text \<open>Addition of formal power series is the usual pointwise
addition of functions.\<close>

instantiation fps :: (type,plus) plus
begin
  definition plus_fps where
    "f + g = Abs_fps (\<lambda>n. f $ n + g $ n)"
  instance ..
end

lemma fps_add_nth [simp]: "(f + g) $ n = f $ n + g $ n"
unfolding plus_fps_def by simp

text \<open>This directly shows that formal power series form a
semilattice with zero.\<close>

lemma fps_add_assoc: "((f::('a,'b::semigroup_add) fps) + g) + h = f + (g + h)"
unfolding plus_fps_def by (simp add: add.assoc)

lemma fps_add_comm [simp]: "(f::('a,'b::ab_semigroup_add) fps) + g = g + f"
unfolding plus_fps_def by (simp add: add.commute)

lemma fps_add_idem [simp]: "(f::('a,'b::join_semilattice) fps) + f = f"
unfolding plus_fps_def by simp

lemma fps_zerol [simp]: "(f::('a,'b::monoid_add) fps) + 0 = f"
unfolding plus_fps_def by simp

lemma fps_zeror [simp]: "0 + (f::('a,'b::monoid_add) fps) = f"
unfolding plus_fps_def by simp

text \<open>The product of formal power series is convolution. The product
of two formal powerseries at a list is obtained by splitting the list
into all possible prefix/suffix pairs, taking the product of the first
series applied to the first coordinate and the second series applied
to the second coordinate of each pair, and then adding the results.\<close>

instantiation fps :: (type,"{comm_monoid_add,times}") times
begin
  definition times_fps where
    "f * g = Abs_fps (\<lambda>n. \<Sum>{f $ y * g $ z |y z. n = y @ z})"
  instance ..
end

text \<open>We call the set of all prefix/suffix splittings of a
list~@{term xs} the \emph{splitset} of~@{term xs}.\<close>

definition splitset where
  "splitset xs \<equiv> {(p, q). xs = p @ q}"

text \<open>Altenatively, splitsets can be defined recursively, which
yields convenient simplification rules in Isabelle.\<close>

fun splitset_fun where
  "splitset_fun []       = {([], [])}"
| "splitset_fun (x # xs) = insert ([], x # xs) (apfst (Cons x) ` splitset_fun xs)"

lemma splitset_consl:
  "splitset (x # xs) = insert ([], x # xs) (apfst (Cons x) ` splitset xs)"
by (auto simp add: image_def splitset_def) (metis append_eq_Cons_conv)+

lemma splitset_eq_splitset_fun: "splitset xs = splitset_fun xs"
apply (induct xs)
 apply (simp add: splitset_def)
apply (simp add: splitset_consl)
done

text \<open>The definition of multiplication is now more precise.\<close>

lemma fps_mult_var:
  "(f * g) $ n = \<Sum>{f $ (fst p) * g $ (snd p) | p. p \<in> splitset n}"
by (simp add: times_fps_def splitset_def)

lemma fps_mult_image:
  "(f * g) $ n = \<Sum>((\<lambda>p. f $ (fst p) * g $ (snd p)) ` splitset n)"
by (simp only: Collect_mem_eq fps_mult_var fun_im)

text \<open>Next we show that splitsets are finite and non-empty.\<close>

lemma splitset_fun_finite [simp]: "finite (splitset_fun xs)"
  by (induct xs, simp_all)

lemma splitset_finite [simp]: "finite (splitset xs)"
  by (simp add: splitset_eq_splitset_fun)

lemma split_append_finite [simp]: "finite {(p, q). xs = p @ q}"
  by (fold splitset_def, fact splitset_finite)

lemma splitset_fun_nonempty [simp]: "splitset_fun xs \<noteq> {}"
  by (cases xs, simp_all)

lemma splitset_nonempty [simp]: "splitset xs \<noteq> {}"
  by (simp add: splitset_eq_splitset_fun)

text \<open>We now proceed with proving algebraic properties of formal
power series.\<close>

lemma fps_annil [simp]:
  "0 * (f::('a::type,'b::{comm_monoid_add,mult_zero}) fps) = 0"
by (rule fps_ext) (simp add: times_fps_def sum.neutral)

lemma fps_annir [simp]:
  "(f::('a::type,'b::{comm_monoid_add,mult_zero}) fps) * 0 = 0"
by (simp add: fps_ext times_fps_def sum.neutral)

lemma fps_distl:
  "(f::('a::type,'b::{join_semilattice_zero,semiring}) fps) * (g + h) = (f * g) + (f * h)"
by (simp add: fps_ext fps_mult_image distrib_left sum_fun_sum)

lemma fps_distr:
  "((f::('a::type,'b::{join_semilattice_zero,semiring}) fps) + g) * h = (f * h) + (g * h)"
by (simp add: fps_ext fps_mult_image distrib_right sum_fun_sum)

text \<open>The multiplicative unit laws are surprisingly tedious. For the
proof of the left unit law we use the recursive definition, which we
could as well have based on splitlists instead of splitsets.

However, a right unit law cannot simply be obtained along the lines of
this proofs. The reason is that an alternative recursive definition
that produces a unit with coordinates flipped would be needed. But
this is difficult to obtain without snoc lists. We therefore prove the
right unit law more directly by using properties of suprema.\<close>

lemma fps_onel [simp]:
  "1 * (f::('a::type,'b::{join_semilattice_zero,monoid_mult,mult_zero}) fps) = f"
proof (rule fps_ext)
  fix n :: "'a list"
  show "(1 * f) $ n = f $ n"
  proof (cases n)
    case Nil thus ?thesis
      by (simp add: times_fps_def)
  next
    case Cons thus ?thesis
      by (simp add: fps_mult_image splitset_eq_splitset_fun image_comp one_fps_def comp_def image_constant_conv)
  qed
qed

lemma fps_oner [simp]:
  "(f::('a::type,'b::{join_semilattice_zero,monoid_mult,mult_zero}) fps) * 1 = f"
proof (rule fps_ext)
  fix n :: "'a list"
  {
    fix z :: 'b
    have "(f * 1) $ n \<le> z \<longleftrightarrow> (\<forall>p \<in> splitset n. f $ (fst p) * 1 $ (snd p) \<le> z)"
      by (simp add: fps_mult_image sum_fun_image_sup)
    also have "... \<longleftrightarrow> (\<forall>a b. n = a @ b \<longrightarrow> f $ a * 1 $ b \<le> z)"
      unfolding splitset_def by simp
    also have "... \<longleftrightarrow> (f $ n * 1 $ [] \<le> z)"
      by (simp add: one_fps_def)
    finally have "(f * 1) $ n \<le> z \<longleftrightarrow> f $ n \<le> z"
      by simp
  }
  thus "(f * 1) $ n = f $ n"
    by (metis eq_iff)
qed

text \<open>Finally we prove associativity of convolution. This requires
splitting lists into three parts and rearranging these parts in two
different ways into splitsets. This rearrangement is captured by the
following technical lemma.\<close>

lemma splitset_rearrange:
  fixes F :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'b::join_semilattice_zero"
  shows "\<Sum>{\<Sum>{F (fst p) (fst q) (snd q) | q. q \<in> splitset (snd p)} | p. p \<in> splitset x} =
         \<Sum>{\<Sum>{F (fst q) (snd q) (snd p) | q. q \<in> splitset (fst p)} | p. p \<in> splitset x}"
    (is "?lhs = ?rhs")
proof -
  {
    fix z :: 'b
    have "?lhs \<le> z \<longleftrightarrow> (\<forall>p q r. x = p @ q @ r \<longrightarrow> F p q r \<le> z)"
      by (simp only: fset_to_im sum_fun_image_sup splitset_finite)
         (auto simp add: splitset_def)
    hence "?lhs \<le> z \<longleftrightarrow> ?rhs \<le> z"
      by (simp only: fset_to_im sum_fun_image_sup splitset_finite)
         (auto simp add: splitset_def)
  }
  thus ?thesis
    by (simp add: eq_iff)
qed

lemma fps_mult_assoc: "(f::('a::type,'b::dioid_one_zero) fps) * (g * h) = (f * g) * h"
proof (rule fps_ext)
  fix n :: "'a list"
  have "(f * (g * h)) $ n = \<Sum>{\<Sum>{f $ (fst p) * g $ (fst q) * h $ (snd q) | q. q \<in> splitset (snd p)} | p. p \<in> splitset n}"
    by (simp add: fps_mult_image sum_sum_distl_fun mult.assoc)
  also have "... = \<Sum>{\<Sum>{f $ (fst q) * g $ (snd q) * h $ (snd p) | q. q \<in> splitset (fst p)} | p. p \<in> splitset n}"
    by (fact splitset_rearrange)
  finally show "(f * (g * h)) $ n = ((f * g) * h) $ n"
    by (simp add: fps_mult_image sum_sum_distr_fun mult.assoc)
qed

subsection \<open>The Dioid Model of Formal Power Series\<close>

text \<open>We can now show that formal power series with suitably
defined operations form a dioid. Many of the underlying properties
already hold in weaker settings, where the target algebra is a
semilattice or semiring. We currently ignore this fact.\<close>

subclass (in dioid_one_zero) mult_zero
proof
  fix x :: 'a
  show "0 * x = 0"
    by (fact annil)
  show "x * 0 = 0"
    by (fact annir)
qed

instantiation fps :: (type,dioid_one_zero) dioid_one_zero
begin

  definition less_eq_fps where
    "(f::('a,'b) fps) \<le> g \<longleftrightarrow> f + g = g"

  definition less_fps where
    "(f::('a,'b) fps) < g \<longleftrightarrow> f \<le> g \<and> f \<noteq> g"

  instance
  proof
    fix f g h :: "('a,'b) fps"
    show "f + g + h = f + (g + h)"
      by (fact fps_add_assoc)
    show "f + g = g + f"
      by (fact fps_add_comm)
    show "f * g * h = f * (g * h)"
      by (metis fps_mult_assoc)
    show "(f + g) * h = f * h + g * h"
      by (fact fps_distr)
    show "1 * f = f"
      by (fact fps_onel)
    show "f * 1 = f"
      by (fact fps_oner)
    show "0 + f = f"
      by (fact fps_zeror)
    show "0 * f = 0"
      by (fact fps_annil)
    show "f * 0 = 0"
      by (fact fps_annir)
    show "f \<le> g \<longleftrightarrow> f + g = g"
      by (fact less_eq_fps_def)
    show "f < g \<longleftrightarrow> f \<le> g \<and> f \<noteq> g"
      by (fact less_fps_def)
    show "f + f = f"
      by (fact fps_add_idem)
    show "f * (g + h) = f \<cdot> g + f \<cdot> h"
      by (fact fps_distl)
  qed

end (* instantiation *)

lemma expand_fps_less_eq: "(f::('a,'b::dioid_one_zero) fps) \<le> g \<longleftrightarrow> (\<forall>n. f $ n \<le> g $ n)"
by (simp add: expand_fps_eq less_eq_def less_eq_fps_def)

subsection \<open>The Kleene Algebra Model of Formal Power Series\<close>

text \<open>There are two approaches to define the Kleene star. The first
one defines the star for a certain kind of (so-called proper) formal
power series into a semiring or dioid. The second one, which is more
interesting in the context of our algebraic hierarchy, shows that
formal power series into a Kleene algebra form a Kleene algebra. We
have only formalised the latter approach.\<close>

lemma Sum_splitlist_nonempty:
  "\<Sum>{f ys zs |ys zs. xs = ys @ zs} = ((f [] xs)::'a::join_semilattice_zero) + \<Sum>{f ys zs |ys zs. xs = ys @ zs \<and> ys \<noteq> []}"
proof -
  have "{f ys zs |ys zs. xs = ys @ zs} = {f ys zs |ys zs. xs = ys @ zs \<and> ys = []} \<union> {f ys zs |ys zs. xs = ys @ zs \<and> ys \<noteq> []}"
    by blast
  thus ?thesis using [[simproc add: finite_Collect]]
    by (simp add: sum.insert)
qed

lemma (in left_kleene_algebra) add_star_eq:
  "x + y \<cdot> y\<^sup>\<star> \<cdot> x = y\<^sup>\<star> \<cdot> x"
by (metis add.commute mult_onel star2 star_one troeger)

declare rev_conj_cong[fundef_cong]
  \<comment> \<open>required for the function package to prove termination of @{term star_fps_rep}\<close>

fun star_fps_rep where
  star_fps_rep_Nil: "star_fps_rep f [] = (f [])\<^sup>\<star>"
| star_fps_rep_Cons: "star_fps_rep f n = (f [])\<^sup>\<star> \<cdot> \<Sum>{f y \<cdot> star_fps_rep f z |y z. n = y @ z \<and> y \<noteq> []}"

instantiation fps :: (type,kleene_algebra) kleene_algebra
begin

  text \<open>We first define the star on functions, where we can use
  Isabelle's package for recursive functions, before lifting the
  definition to the type of formal power series.

  This definition of the star is from an unpublished manuscript by
  Esik and Kuich.\<close>

  lift_definition star_fps :: "('a, 'b) fps \<Rightarrow> ('a, 'b) fps" is star_fps_rep ..

  lemma star_fps_Nil [simp]: "f\<^sup>\<star> $ [] = (f $ [])\<^sup>\<star>"
  by (simp add: star_fps_def)

  lemma star_fps_Cons [simp]: "f\<^sup>\<star> $ (x # xs) = (f $ [])\<^sup>\<star> \<cdot> \<Sum>{f $ y \<cdot> f\<^sup>\<star> $ z |y z. x # xs = y @ z \<and> y \<noteq> []}"
  by (simp add: star_fps_def)

  instance
  proof
    fix f g h :: "('a,'b) fps"
    have "1 + f \<cdot> f\<^sup>\<star> = f\<^sup>\<star>"
      apply (rule fps_ext)
      apply (case_tac n)
       apply (auto simp add: times_fps_def)
      apply (simp add: add_star_eq mult.assoc[THEN sym] Sum_splitlist_nonempty)
      apply (simp add: add_star_eq join.sup_commute)
    done
    thus "1 + f \<cdot> f\<^sup>\<star> \<le> f\<^sup>\<star>"
      by (metis order_refl)
    have "f \<cdot> g \<le> g \<longrightarrow> f\<^sup>\<star> \<cdot> g \<le> g"
      proof
        assume "f \<cdot> g \<le> g"
        hence 1: "\<And>u v. f $ u \<cdot> g $ v \<le> g $ (u @ v)"
          using [[simproc add: finite_Collect]]
          apply (simp add: expand_fps_less_eq)
          apply (drule_tac x="u @ v" in spec)
          apply (simp add: times_fps_def)
          apply (auto elim!: sum_less_eqE)
        done
        hence 2: "\<And>v. (f $ []) \<^sup>\<star> \<cdot> g $ v \<le> g $ v"
          apply (subgoal_tac "f $ [] \<cdot> g $ v \<le> g $ v")
           apply (metis star_inductl_var)
          apply (metis append_Nil)
        done
        show "f\<^sup>\<star> \<cdot> g \<le> g"
          using [[simproc add: finite_Collect]]
          apply (auto intro!: sum_less_eqI simp add: expand_fps_less_eq times_fps_def)
          apply (induct_tac "y" rule: length_induct)
          apply (case_tac "xs")
           apply (simp add: "2")
          using "2" apply (auto simp add: mult.assoc sum_distr)
          apply (rule_tac y="(f $ [])\<^sup>\<star> \<cdot> g $ (a # list @ z)" in order_trans)
           prefer 2
           apply (rule "2")
          apply (auto intro!: mult_isol[rule_format] sum_less_eqI)
          apply (drule_tac x="za" in spec)
          apply (drule mp)
           apply (metis append_eq_Cons_conv length_append less_not_refl2 add.commute not_less_eq trans_less_add1)
          apply (drule_tac z="f $ y" in mult_isol[rule_format])
          apply (auto elim!: order_trans simp add: mult.assoc)
          apply (metis "1" append_Cons append_assoc)
        done
      qed
    thus "h + f \<cdot> g \<le> g \<Longrightarrow> f\<^sup>\<star> \<cdot> h \<le> g"
      by (metis (no_types, lifting) distrib_left join.sup.bounded_iff less_eq_def)
    have "g \<cdot> f \<le> g \<longrightarrow> g \<cdot> f\<^sup>\<star> \<le> g"
      \<comment> \<open>this property is dual to the previous one; the proof is slightly different\<close>
      proof
        assume "g \<cdot> f \<le> g"
        hence 1: "\<And>u v. g $ u \<cdot> f $ v \<le> g $ (u @ v)"
          using [[simproc add: finite_Collect]]
          apply (simp add: expand_fps_less_eq)
          apply (drule_tac x="u @ v" in spec)
          apply (simp add: times_fps_def)
          apply (auto elim!: sum_less_eqE)
        done
        hence 2: "\<And>u. g $ u \<cdot> (f $ [])\<^sup>\<star> \<le> g $ u"
          apply (subgoal_tac "g $ u \<cdot> f $ [] \<le> g $ u")
           apply (metis star_inductr_var)
          apply (metis append_Nil2)
        done
        show "g \<cdot> f\<^sup>\<star> \<le> g"
          using [[simproc add: finite_Collect]]
          apply (auto intro!: sum_less_eqI simp add: expand_fps_less_eq times_fps_def)
          apply (rule_tac P="\<lambda>y. g $ y \<cdot> f\<^sup>\<star> $ z \<le> g $ (y @ z)" and x="y" in allE)
           prefer 2
           apply assumption
          apply (induct_tac "z" rule: length_induct)
          apply (case_tac "xs")
           apply (simp add: "2")
          apply (auto intro!: sum_less_eqI simp add: sum_distl)
          apply (rule_tac y="g $ x \<cdot> f $ yb \<cdot> f\<^sup>\<star> $ z" in order_trans)
           apply (simp add: "2" mult.assoc[THEN sym] mult_isor)
          apply (rule_tac y="g $ (x @ yb) \<cdot> f\<^sup>\<star> $ z" in order_trans)
           apply (simp add: "1" mult_isor)
          apply (drule_tac x="z" in spec)
          apply (drule mp)
           apply (metis append_eq_Cons_conv length_append less_not_refl2 add.commute not_less_eq trans_less_add1)
          apply (metis append_assoc)
        done
      qed
    thus "h + g \<cdot> f \<le> g \<Longrightarrow> h \<cdot> f\<^sup>\<star> \<le> g"
      by (metis (no_types, lifting) distrib_right' join.sup.bounded_iff order_prop)
  qed

end (* instantiation *)

end


(*  Title:      HOL/Induct/Comb.thy
    Author:     Lawrence C Paulson
    Copyright   1996  University of Cambridge
*)

section \<open>Combinatory Logic example: the Church-Rosser Theorem\<close>

theory Comb
imports MainRLT
begin

text \<open>
  Combinator terms do not have free variables.
  Example taken from @{cite camilleri92}.
\<close>

subsection \<open>Definitions\<close>

text \<open>Datatype definition of combinators \<open>S\<close> and \<open>K\<close>.\<close>

datatype comb = K
              | S
              | Ap comb comb (infixl "\<bullet>" 90)

text \<open>
  Inductive definition of contractions, \<open>\<rightarrow>\<^sup>1\<close> and
  (multi-step) reductions, \<open>\<rightarrow>\<close>.
\<close>

inductive contract1 :: "[comb,comb] \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sup>1" 50)
  where
    K:     "K\<bullet>x\<bullet>y \<rightarrow>\<^sup>1 x"
  | S:     "S\<bullet>x\<bullet>y\<bullet>z \<rightarrow>\<^sup>1 (x\<bullet>z)\<bullet>(y\<bullet>z)"
  | Ap1:   "x \<rightarrow>\<^sup>1 y \<Longrightarrow> x\<bullet>z \<rightarrow>\<^sup>1 y\<bullet>z"
  | Ap2:   "x \<rightarrow>\<^sup>1 y \<Longrightarrow> z\<bullet>x \<rightarrow>\<^sup>1 z\<bullet>y"

abbreviation
  contract :: "[comb,comb] \<Rightarrow> bool"   (infixl "\<rightarrow>" 50) where
  "contract \<equiv> contract1\<^sup>*\<^sup>*"

text \<open>
  Inductive definition of parallel contractions, \<open>\<Rrightarrow>\<^sup>1\<close> and
  (multi-step) parallel reductions, \<open>\<Rrightarrow>\<close>.
\<close>

inductive parcontract1 :: "[comb,comb] \<Rightarrow> bool"  (infixl "\<Rrightarrow>\<^sup>1" 50)
  where
    refl:  "x \<Rrightarrow>\<^sup>1 x"
  | K:     "K\<bullet>x\<bullet>y \<Rrightarrow>\<^sup>1 x"
  | S:     "S\<bullet>x\<bullet>y\<bullet>z \<Rrightarrow>\<^sup>1 (x\<bullet>z)\<bullet>(y\<bullet>z)"
  | Ap:    "\<lbrakk>x \<Rrightarrow>\<^sup>1 y; z \<Rrightarrow>\<^sup>1 w\<rbrakk> \<Longrightarrow> x\<bullet>z \<Rrightarrow>\<^sup>1 y\<bullet>w"

abbreviation
  parcontract :: "[comb,comb] \<Rightarrow> bool"   (infixl "\<Rrightarrow>" 50) where
  "parcontract \<equiv> parcontract1\<^sup>*\<^sup>*"

text \<open>
  Misc definitions.
\<close>

definition
  I :: comb where
  "I \<equiv> S\<bullet>K\<bullet>K"

definition
  diamond   :: "([comb,comb] \<Rightarrow> bool) \<Rightarrow> bool" where
    \<comment> \<open>confluence; Lambda/Commutation treats this more abstractly\<close>
  "diamond r \<equiv> \<forall>x y. r x y \<longrightarrow>
                  (\<forall>y'. r x y' \<longrightarrow>
                    (\<exists>z. r y z \<and> r y' z))"

subsection \<open>Reflexive/Transitive closure preserves Church-Rosser property\<close>

text\<open>Remark: So does the Transitive closure, with a similar proof\<close>

text\<open>Strip lemma.
   The induction hypothesis covers all but the last diamond of the strip.\<close>
lemma strip_lemma [rule_format]:
  assumes "diamond r" and r: "r\<^sup>*\<^sup>* x y" "r x y'"
  shows "\<exists>z. r\<^sup>*\<^sup>* y' z \<and> r y z"
  using r
proof (induction rule: rtranclp_induct)
  case base
  then show ?case
    by blast
next
  case (step y z)
  then show ?case
    using \<open>diamond r\<close> unfolding diamond_def
    by (metis rtranclp.rtrancl_into_rtrancl)
qed

proposition diamond_rtrancl:
  assumes "diamond r"
  shows "diamond(r\<^sup>*\<^sup>*)"
  unfolding diamond_def
proof (intro strip)
  fix x y y'
  assume "r\<^sup>*\<^sup>* x y" "r\<^sup>*\<^sup>* x y'"
  then show "\<exists>z. r\<^sup>*\<^sup>* y z \<and> r\<^sup>*\<^sup>* y' z"
  proof (induction rule: rtranclp_induct)
    case base
    then show ?case
      by blast
  next
    case (step y z)
    then show ?case
      by (meson assms strip_lemma rtranclp.rtrancl_into_rtrancl)
  qed
qed

subsection \<open>Non-contraction results\<close>

text \<open>Derive a case for each combinator constructor.\<close>

inductive_cases
  K_contractE [elim!]: "K \<rightarrow>\<^sup>1 r"
  and S_contractE [elim!]: "S \<rightarrow>\<^sup>1 r"
  and Ap_contractE [elim!]: "p\<bullet>q \<rightarrow>\<^sup>1 r"

declare contract1.K [intro!] contract1.S [intro!]
declare contract1.Ap1 [intro] contract1.Ap2 [intro]

lemma I_contract_E [iff]: "\<not> I \<rightarrow>\<^sup>1 z"
  unfolding I_def by blast

lemma K1_contractD [elim!]: "K\<bullet>x \<rightarrow>\<^sup>1 z \<Longrightarrow> (\<exists>x'. z = K\<bullet>x' \<and> x \<rightarrow>\<^sup>1 x')"
  by blast

lemma Ap_reduce1 [intro]: "x \<rightarrow> y \<Longrightarrow> x\<bullet>z \<rightarrow> y\<bullet>z"
  by (induction rule: rtranclp_induct; blast intro: rtranclp_trans)

lemma Ap_reduce2 [intro]: "x \<rightarrow> y \<Longrightarrow> z\<bullet>x \<rightarrow> z\<bullet>y"
  by (induction rule: rtranclp_induct; blast intro: rtranclp_trans)

text \<open>Counterexample to the diamond property for \<^term>\<open>x \<rightarrow>\<^sup>1 y\<close>\<close>

lemma not_diamond_contract: "\<not> diamond(contract1)"
  unfolding diamond_def by (metis S_contractE contract1.K)

subsection \<open>Results about Parallel Contraction\<close>

text \<open>Derive a case for each combinator constructor.\<close>

inductive_cases
      K_parcontractE [elim!]: "K \<Rrightarrow>\<^sup>1 r"
  and S_parcontractE [elim!]: "S \<Rrightarrow>\<^sup>1 r"
  and Ap_parcontractE [elim!]: "p\<bullet>q \<Rrightarrow>\<^sup>1 r"

declare parcontract1.intros [intro]

subsection \<open>Basic properties of parallel contraction\<close>
text\<open>The rules below are not essential but make proofs much faster\<close>

lemma K1_parcontractD [dest!]: "K\<bullet>x \<Rrightarrow>\<^sup>1 z \<Longrightarrow> (\<exists>x'. z = K\<bullet>x' \<and> x \<Rrightarrow>\<^sup>1 x')"
  by blast

lemma S1_parcontractD [dest!]: "S\<bullet>x \<Rrightarrow>\<^sup>1 z \<Longrightarrow> (\<exists>x'. z = S\<bullet>x' \<and> x \<Rrightarrow>\<^sup>1 x')"
  by blast

lemma S2_parcontractD [dest!]: "S\<bullet>x\<bullet>y \<Rrightarrow>\<^sup>1 z \<Longrightarrow> (\<exists>x' y'. z = S\<bullet>x'\<bullet>y' \<and> x \<Rrightarrow>\<^sup>1 x' \<and> y \<Rrightarrow>\<^sup>1 y')"
  by blast

text\<open>Church-Rosser property for parallel contraction\<close>
proposition diamond_parcontract: "diamond parcontract1"
proof -
  have "(\<exists>z. w \<Rrightarrow>\<^sup>1 z \<and> y' \<Rrightarrow>\<^sup>1 z)" if "y \<Rrightarrow>\<^sup>1 w" "y \<Rrightarrow>\<^sup>1 y'" for w y y'
    using that by (induction arbitrary: y' rule: parcontract1.induct) fast+
  then show ?thesis
    by (auto simp: diamond_def)
qed

subsection \<open>Equivalence of \<^prop>\<open>p \<rightarrow> q\<close> and \<^prop>\<open>p \<Rrightarrow> q\<close>.\<close>

lemma contract_imp_parcontract: "x \<rightarrow>\<^sup>1 y \<Longrightarrow> x \<Rrightarrow>\<^sup>1 y"
  by (induction rule: contract1.induct; blast)

text\<open>Reductions: simply throw together reflexivity, transitivity and
  the one-step reductions\<close>

proposition reduce_I: "I\<bullet>x \<rightarrow> x"
  unfolding I_def
  by (meson contract1.K contract1.S r_into_rtranclp rtranclp.rtrancl_into_rtrancl)

lemma parcontract_imp_reduce: "x \<Rrightarrow>\<^sup>1 y \<Longrightarrow> x \<rightarrow> y"
proof (induction rule: parcontract1.induct)
  case (Ap x y z w)
  then show ?case
    by (meson Ap_reduce1 Ap_reduce2 rtranclp_trans)
qed auto

lemma reduce_eq_parreduce: "x \<rightarrow> y  \<longleftrightarrow>  x \<Rrightarrow> y"
  by (metis contract_imp_parcontract parcontract_imp_reduce predicate2I rtranclp_subset)

theorem diamond_reduce: "diamond(contract)"
  using diamond_parcontract diamond_rtrancl reduce_eq_parreduce by presburger

end


(*  Title:      HOL/ex/Set_Theory.thy
    Author:     Tobias Nipkow and Lawrence C Paulson
    Copyright   1991  University of Cambridge
*)

section \<open>Set Theory examples: Cantor's Theorem, Schröder-Bernstein Theorem, etc.\<close>

theory Set_Theory
imports MainRLT
begin

text\<open>
  These two are cited in Benzmueller and Kohlhase's system description
  of LEO, CADE-15, 1998 (pages 139-143) as theorems LEO could not
  prove.
\<close>

lemma "(X = Y \<union> Z) =
    (Y \<subseteq> X \<and> Z \<subseteq> X \<and> (\<forall>V. Y \<subseteq> V \<and> Z \<subseteq> V \<longrightarrow> X \<subseteq> V))"
  by blast

lemma "(X = Y \<inter> Z) =
    (X \<subseteq> Y \<and> X \<subseteq> Z \<and> (\<forall>V. V \<subseteq> Y \<and> V \<subseteq> Z \<longrightarrow> V \<subseteq> X))"
  by blast

text \<open>
  Trivial example of term synthesis: apparently hard for some provers!
\<close>

schematic_goal "a \<noteq> b \<Longrightarrow> a \<in> ?X \<and> b \<notin> ?X"
  by blast

subsection \<open>Examples for the \<open>blast\<close> paper\<close>

lemma "(\<Union>x \<in> C. f x \<union> g x) = \<Union>(f ` C)  \<union>  \<Union>(g ` C)"
  \<comment> \<open>Union-image, called \<open>Un_Union_image\<close> in Main HOL\<close>
  by blast

lemma "(\<Inter>x \<in> C. f x \<inter> g x) = \<Inter>(f ` C) \<inter> \<Inter>(g ` C)"
  \<comment> \<open>Inter-image, called \<open>Int_Inter_image\<close> in Main HOL\<close>
  by blast

lemma singleton_example_1:
     "\<And>S::'a set set. \<forall>x \<in> S. \<forall>y \<in> S. x \<subseteq> y \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
  by blast

lemma singleton_example_2:
     "\<forall>x \<in> S. \<Union>S \<subseteq> x \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
  \<comment> \<open>Variant of the problem above.\<close>
  by blast

lemma "\<exists>!x. f (g x) = x \<Longrightarrow> \<exists>!y. g (f y) = y"
  \<comment> \<open>A unique fixpoint theorem --- \<open>fast\<close>/\<open>best\<close>/\<open>meson\<close> all fail.\<close>
  by metis

subsection \<open>Cantor's Theorem: There is no surjection from a set to its powerset\<close>

lemma cantor1: "\<not> (\<exists>f:: 'a \<Rightarrow> 'a set. \<forall>S. \<exists>x. f x = S)"
  \<comment> \<open>Requires best-first search because it is undirectional.\<close>
  by best

schematic_goal "\<forall>f:: 'a \<Rightarrow> 'a set. \<forall>x. f x \<noteq> ?S f"
  \<comment> \<open>This form displays the diagonal term.\<close>
  by best

schematic_goal "?S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
  \<comment> \<open>This form exploits the set constructs.\<close>
  by (rule notI, erule rangeE, best)

schematic_goal "?S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
  \<comment> \<open>Or just this!\<close>
  by best

subsection \<open>The Schröder-Bernstein Theorem\<close>

lemma disj_lemma: "- (f ` X) = g' ` (-X) \<Longrightarrow> f a = g' b \<Longrightarrow> a \<in> X \<Longrightarrow> b \<in> X"
  by blast

lemma surj_if_then_else:
  "-(f ` X) = g' ` (-X) \<Longrightarrow> surj (\<lambda>z. if z \<in> X then f z else g' z)"
  by (simp add: surj_def) blast

lemma bij_if_then_else:
  "inj_on f X \<Longrightarrow> inj_on g' (-X) \<Longrightarrow> -(f ` X) = g' ` (-X) \<Longrightarrow>
    h = (\<lambda>z. if z \<in> X then f z else g' z) \<Longrightarrow> inj h \<and> surj h"
  apply (unfold inj_on_def)
  apply (simp add: surj_if_then_else)
  apply (blast dest: disj_lemma sym)
  done

lemma decomposition: "\<exists>X. X = - (g ` (- (f ` X)))"
  apply (rule exI)
  apply (rule lfp_unfold)
  apply (rule monoI, blast)
  done

theorem Schroeder_Bernstein:
  "inj (f :: 'a \<Rightarrow> 'b) \<Longrightarrow> inj (g :: 'b \<Rightarrow> 'a)
    \<Longrightarrow> \<exists>h:: 'a \<Rightarrow> 'b. inj h \<and> surj h"
  apply (rule decomposition [where f=f and g=g, THEN exE])
  apply (rule_tac x = "(\<lambda>z. if z \<in> x then f z else inv g z)" in exI)
    \<comment> \<open>The term above can be synthesized by a sufficiently detailed proof.\<close>
  apply (rule bij_if_then_else)
     apply (rule_tac [4] refl)
    apply (rule_tac [2] inj_on_inv_into)
    apply (erule subset_inj_on [OF _ subset_UNIV])
   apply blast
  apply (erule ssubst, subst double_complement, erule image_inv_f_f [symmetric])
  done

subsection \<open>A simple party theorem\<close>

text\<open>\emph{At any party there are two people who know the same
number of people}. Provided the party consists of at least two people
and the knows relation is symmetric. Knowing yourself does not count
--- otherwise knows needs to be reflexive. (From Freek Wiedijk's talk
at TPHOLs 2007.)\<close>

lemma equal_number_of_acquaintances:
assumes "Domain R <= A" and "sym R" and "card A \<ge> 2"
shows "\<not> inj_on (%a. card(R `` {a} - {a})) A"
proof -
  let ?N = "%a. card(R `` {a} - {a})"
  let ?n = "card A"
  have "finite A" using \<open>card A \<ge> 2\<close> by(auto intro:ccontr)
  have 0: "R `` A <= A" using \<open>sym R\<close> \<open>Domain R <= A\<close>
    unfolding Domain_unfold sym_def by blast
  have h: "\<forall>a\<in>A. R `` {a} <= A" using 0 by blast
  hence 1: "\<forall>a\<in>A. finite(R `` {a})" using \<open>finite A\<close>
    by(blast intro: finite_subset)
  have sub: "?N ` A <= {0..<?n}"
  proof -
    have "\<forall>a\<in>A. R `` {a} - {a} < A" using h by blast
    thus ?thesis using psubset_card_mono[OF \<open>finite A\<close>] by auto
  qed
  show "~ inj_on ?N A" (is "~ ?I")
  proof
    assume ?I
    hence "?n = card(?N ` A)" by(rule card_image[symmetric])
    with sub \<open>finite A\<close> have 2[simp]: "?N ` A = {0..<?n}"
      using subset_card_intvl_is_intvl[of _ 0] by(auto)
    have "0 \<in> ?N ` A" and "?n - 1 \<in> ?N ` A"  using \<open>card A \<ge> 2\<close> by simp+
    then obtain a b where ab: "a\<in>A" "b\<in>A" and Na: "?N a = 0" and Nb: "?N b = ?n - 1"
      by (auto simp del: 2)
    have "a \<noteq> b" using Na Nb \<open>card A \<ge> 2\<close> by auto
    have "R `` {a} - {a} = {}" by (metis 1 Na ab card_eq_0_iff finite_Diff)
    hence "b \<notin> R `` {a}" using \<open>a\<noteq>b\<close> by blast
    hence "a \<notin> R `` {b}" by (metis Image_singleton_iff assms(2) sym_def)
    hence 3: "R `` {b} - {b} <= A - {a,b}" using 0 ab by blast
    have 4: "finite (A - {a,b})" using \<open>finite A\<close> by simp
    have "?N b <= ?n - 2" using ab \<open>a\<noteq>b\<close> \<open>finite A\<close> card_mono[OF 4 3] by simp
    then show False using Nb \<open>card A \<ge>  2\<close> by arith
  qed
qed

text \<open>
  From W. W. Bledsoe and Guohui Feng, SET-VAR. JAR 11 (3), 1993, pages
  293-314.

  Isabelle can prove the easy examples without any special mechanisms,
  but it can't prove the hard ones.
\<close>

lemma "\<exists>A. (\<forall>x \<in> A. x \<le> (0::int))"
  \<comment> \<open>Example 1, page 295.\<close>
  by force

lemma "D \<in> F \<Longrightarrow> \<exists>G. \<forall>A \<in> G. \<exists>B \<in> F. A \<subseteq> B"
  \<comment> \<open>Example 2.\<close>
  by force

lemma "P a \<Longrightarrow> \<exists>A. (\<forall>x \<in> A. P x) \<and> (\<exists>y. y \<in> A)"
  \<comment> \<open>Example 3.\<close>
  by force

lemma "a < b \<and> b < (c::int) \<Longrightarrow> \<exists>A. a \<notin> A \<and> b \<in> A \<and> c \<notin> A"
  \<comment> \<open>Example 4.\<close>
  by auto \<comment> \<open>slow\<close>

lemma "P (f b) \<Longrightarrow> \<exists>s A. (\<forall>x \<in> A. P x) \<and> f s \<in> A"
  \<comment> \<open>Example 5, page 298.\<close>
  by force

lemma "P (f b) \<Longrightarrow> \<exists>s A. (\<forall>x \<in> A. P x) \<and> f s \<in> A"
  \<comment> \<open>Example 6.\<close>
  by force

lemma "\<exists>A. a \<notin> A"
  \<comment> \<open>Example 7.\<close>
  by force

lemma "(\<forall>u v. u < (0::int) \<longrightarrow> u \<noteq> \<bar>v\<bar>)
    \<longrightarrow> (\<exists>A::int set. -2 \<in> A & (\<forall>y. \<bar>y\<bar> \<notin> A))"
  \<comment> \<open>Example 8 needs a small hint.\<close>
  by force
    \<comment> \<open>not \<open>blast\<close>, which can't simplify \<open>-2 < 0\<close>\<close>

text \<open>Example 9 omitted (requires the reals).\<close>

text \<open>The paper has no Example 10!\<close>

lemma "(\<forall>A. 0 \<in> A \<and> (\<forall>x \<in> A. Suc x \<in> A) \<longrightarrow> n \<in> A) \<and>
  P 0 \<and> (\<forall>x. P x \<longrightarrow> P (Suc x)) \<longrightarrow> P n"
  \<comment> \<open>Example 11: needs a hint.\<close>
by(metis nat.induct)

lemma
  "(\<forall>A. (0, 0) \<in> A \<and> (\<forall>x y. (x, y) \<in> A \<longrightarrow> (Suc x, Suc y) \<in> A) \<longrightarrow> (n, m) \<in> A)
    \<and> P n \<longrightarrow> P m"
  \<comment> \<open>Example 12.\<close>
  by auto

lemma
  "(\<forall>x. (\<exists>u. x = 2 * u) = (\<not> (\<exists>v. Suc x = 2 * v))) \<longrightarrow>
    (\<exists>A. \<forall>x. (x \<in> A) = (Suc x \<notin> A))"
  \<comment> \<open>Example EO1: typo in article, and with the obvious fix it seems
      to require arithmetic reasoning.\<close>
  apply clarify
  apply (rule_tac x = "{x. \<exists>u. x = 2 * u}" in exI, auto)
   apply metis+
  done

end


theory topological_dynamics imports continuous   begin

definition (in topological_space )
  covering ::"'a set set \<Rightarrow> bool"where
 "covering C \<longleftrightarrow> (\<Union>C = X \<and> C \<subseteq> Pow X ) "

definition (in topological_space)
  open_covering ::"'a set set \<Rightarrow> bool" where
  "open_covering C \<longleftrightarrow> (covering C \<and>  (\<forall>c\<in>C. (open_set c)))"

definition (in topological_space)
  compact where
  "compact \<longleftrightarrow> ( \<forall>C. (open_covering C)\<longrightarrow>  (\<exists>A. ( A \<subseteq> C   \<and>  \<Union>A = X \<and>  finite A )) )"

thm  topological_space.compact_def

locale Group =
  fixes G
  fixes f
  fixes e
  fixes f_inv
  assumes G1: "e\<in> G"
    and   G2: "\<forall>x\<in>G. f(x,e) = x "
    and   G3: "\<forall>x\<in>G. f(e,x) = x"
    and   G4: "f: G \<times> G \<rightarrow> G"
    and   G5: "f_inv: G \<rightarrow> G"
    and   G6: "\<forall>x\<in>G. \<forall>y\<in>G. \<forall>z\<in>G. f(f(x,y),z)=f(x,f(y,z))"
    and   G7: "\<forall>x\<in>G. f(x,f_inv(x))=e"
    and   G8: "\<forall>x\<in>G. f(f_inv(x),x)=e"
thm Group_def
(*  this is Tx is top
definition product_topology_base where
   "product_topology_base Tx Ty \<equiv>{u. \<forall>x\<in>Tx. \<forall>y\<in>Ty. ( (u=(x \<times> y)) \<and>  (topological_space (\<Union>Tx) Tx) \<and>  (topological_space (\<Union>Ty) Ty))

}"*)

definition product_topology_base where
   "product_topology_base Tx Ty \<equiv>{b. \<forall>x\<in>Tx. \<forall>y\<in>Ty.  (b=(x \<times> y)) }"

definition
  "product_topology Tx Ty  \<equiv>  {t.  \<forall>p \<in> Pow(product_topology_base Tx Ty ). t=\<Union>p}"

locale topological_group = topological_space +
  fixes f
  fixes e
  fixes f_inv
  assumes tg1:"Group X f e f_inv"
   and    tg2:"continuous f  (X\<times>X) (product_topology T T) X T"
   and    tg3:"continuous f_inv X T X T"
thm topological_group_def

thm topological_group_axioms_def

locale topological_transformation_group = topological_group +
  fixes M
  fixes Tm
  fixes mappi ("\<phi>  _" 89)
  assumes istop :"topological_space M Tm"
  assumes map1 : "mappi : (X  \<times>  M \<rightarrow>  M)"
  assumes ident : "\<forall>x \<in> M.  \<phi> (x, e) = x"
  assumes Homom:   "\<forall>x\<in>M. \<forall>g1\<in>X. \<forall>g2\<in>X. \<phi>(g1,\<phi>(g2,x) ) = \<phi>(f(g1,g2),x)"
  assumes Conti:   "continuous f  (X\<times>M) (product_topology T Tm ) M Tm"

locale hausdorff_space = topological_space +
      assumes t1 : "!! x1 x2. [|x1: X; x2: X; x1 ~= x2 |]
                    ==> EX U V. (neighborhood U x1)  &
                            (neighborhood V x2)  &
                             x2 ~: U & x1 ~: V "
thm hausdorff_space_def
thm topological_space.compact_def

locale topological_dynamic_system =
    topological_transformation_group +
  assumes iscompact :"topological_space.compact M Tm"
  assumes map1 : "hausdorff_space M Tm"

thm topological_dynamic_system_def

definition (in topological_transformation_group )
  invariant_set where
  "invariant_set A \<longleftrightarrow> (A \<subseteq> M \<and> (\<forall>g \<in> X.  {x. \<exists>a\<in>A. x = \<phi>(g,a)} \<subseteq> A)) "

lemma forall_conjI:"\<lbrakk> (\<forall>x\<in>X. (P x)); (\<forall>x\<in>X. (Q x))\<rbrakk> \<Longrightarrow> \<forall>x\<in>X. (P x) \<and> (Q x)"
apply blast
done

lemma "\<lbrakk>\<forall>x\<in>X. (P x) \<and> (Q x)\<rbrakk> \<Longrightarrow> (\<forall>x\<in>X. (P x)) \<and> (\<forall>x\<in>X. (Q x))"
apply blast
done

lemma  "\<lbrakk>A \<subseteq> M; B \<subseteq> M\<rbrakk> \<Longrightarrow> A \<inter> B \<subseteq> M"
apply blast
done
lemma (in topological_transformation_group)
int_is_inv:
"\<lbrakk> invariant_set A; invariant_set B \<rbrakk> \<Longrightarrow> invariant_set (A \<inter> B)"
apply (simp add :invariant_set_def)
apply (rule conjI)
apply (drule_tac  conjunct1)
apply (drule_tac  conjunct1)
apply (blast 1)
apply (drule_tac conjunct2)
apply (drule_tac  conjunct2)
apply (rule forall_conjI)
apply blast
apply (rotate_tac 1)
apply blast
done
(*
lemma  (in topological_transformation_group) closure_is_invariant:
  "invariant_set A ==> invariant_set (closure A) "
apply (simp add :closure_def invariant_set_def)
apply (rule conjI)
apply (drule_tac conjunct1)
apply (drule_tac conjunct1)
apply (simp add:Lattices.lower_semilattice_class.le_infI1)
apply (drule_tac conjunct2)
apply (drule_tac conjunct2)
apply (rule forall_conjI)
apply blast
apply (rotate_tac 1)
apply blast
*)

lemma (in topological_transformation_group)
int_is_inv1:
assumes a1: "invariant_set A"
 and  a2:" invariant_set B"
shows "invariant_set (A\<inter>B)"
proof-
 from a1 have s1:"A \<subseteq> M" by (simp add:invariant_set_def)
 from a2 have s2:"B \<subseteq> M" by (simp add:invariant_set_def)
 from s1 s2 have s3: "A \<inter> B \<subseteq> M" by blast
 from a1 have s4:"\<forall>g \<in> X.  {x. \<exists> a\<in>A. x = \<phi>(g,a)} \<subseteq> A" by (simp add:invariant_set_def)
 from a2 have s5:"\<forall>g \<in> X.  {x. \<exists> a\<in>B. x = \<phi>(g,a)} \<subseteq> B" by (simp add:invariant_set_def)
 from s4 s5 have s6:"\<forall>g \<in> X. {x. \<exists> a\<in>A. x = \<phi>(g,a)} \<subseteq> A  \<and>  {x. \<exists>a\<in>B. x = \<phi>(g,a)} \<subseteq> B" by (simp)
 from s4 have s7:"\<And> g. g \<in> X \<Longrightarrow>  {x. \<exists>a\<in>A \<inter> B. x = \<phi>(g,a)} \<subseteq>  A"  apply blast done
 from s5 have s8:"\<And> g. g \<in> X \<Longrightarrow>  {x. \<exists>a\<in>A \<inter> B. x = \<phi>(g,a)} \<subseteq>  B"  apply blast done
 from s7 s8 have s9:"\<And> g. g \<in> X \<Longrightarrow>  {x. \<exists>a\<in>A \<inter> B. x = \<phi>(g,a)} \<subseteq>  A \<inter> B" apply auto done
 from s1 s2 s9 show ?thesis apply (simp add:invariant_set_def)  apply blast done
qed

lemma dddd:"y \<in> {x. \<exists> a\<in> A\<union> B . x =P a} \<Longrightarrow>  y \<in> {x. \<exists> a\<in> A. x =P a} \<or> y \<in> {x. \<exists> a\<in> B. x =P a}"
apply blast
done

lemma eeee:"{x. \<exists> a\<in> A\<union> B . x =P a}\<subseteq>  {x. \<exists> a\<in> A. x =P a} \<union> {x. \<exists> a\<in> B. x =P a}"
apply auto
done

lemma (in topological_transformation_group)
union_is_inv:
assumes a1: "invariant_set A"
 and  a2:" invariant_set B"
shows "invariant_set (A \<union> B)"
proof-
 from a1 have s1:"A \<subseteq> M" by (simp add:invariant_set_def)
 from a2 have s2:"B \<subseteq> M" by (simp add:invariant_set_def)
 from s1 s2 have s3: "A \<union>  B \<subseteq> M" by blast
 from a1 have s4:"\<And>g. g \<in> X \<Longrightarrow>   {x. \<exists> a\<in>A. x = \<phi>(g,a)} \<subseteq> A" by (simp add:invariant_set_def)
 from a2 have s5:"\<And>g. g \<in> X \<Longrightarrow> {x. \<exists> a\<in>B. x = \<phi>(g,a)} \<subseteq> B" by (simp add:invariant_set_def)
 from s4 s5 have s6:"\<And>g. g \<in> X \<Longrightarrow>  {x. \<exists> a\<in>A. x = \<phi>(g,a)} \<subseteq> A  \<and>  {x. \<exists>a\<in>B. x = \<phi>(g,a)} \<subseteq> B" by (simp)
 from s6 have s7: "\<And>g. g \<in> X \<Longrightarrow>  {x. \<exists> a\<in>A \<union> B. x = \<phi>(g,a)} \<subseteq>  {x. \<exists> a\<in>A. x = \<phi>(g,a)} \<union> {x. \<exists> a\<in>B. x = \<phi>(g,a)}"
 by blast
 from s7 s6 have s8:"\<And> g. g \<in> X \<Longrightarrow>  {x. \<exists>a\<in>A \<union>  B. x = \<phi>(g,a)} \<subseteq>  A \<union> B"
   proof-
     fix g assume a8_1: "g \<in> X"
     show "{x. \<exists>a\<in>A \<union>  B. x = \<phi>(g,a)} \<subseteq>  A \<union> B"
     proof-
        from a8_1  s7 have s8_1: "{x. \<exists> a\<in>A \<union> B. x = \<phi>(g,a)} \<subseteq>  {x. \<exists> a\<in>A. x = \<phi>(g,a)} \<union> {x. \<exists> a\<in>B. x = \<phi>(g,a)}" apply simp done
        from a8_1 s4 have s8_2:" {x. \<exists> a\<in>A. x = \<phi>(g,a)} \<subseteq> A" by simp
        from a8_1 s5 have s8_3:" {x. \<exists> a\<in>B. x = \<phi>(g,a)} \<subseteq> B" by simp
        from s8_1 s8_2 s8_3 show ?thesis by blast
 qed
qed
 from s3 s8 show ?thesis apply (simp add:invariant_set_def)  done
qed

(*

(*
lemma  (in topological_transformation_group) closure_is_invariant:
  "invariant_set A ==> invariant_set (closure A) "
apply (simp add :closure_def invariant_set_def)
apply (rule conjI)
apply (drule_tac conjunct1)
apply (drule_tac conjunct1)
apply (simp add:Lattices.lower_semilattice_class.le_infI1)
apply (drule_tac conjunct2)
apply (drule_tac conjunct2)
apply (rule forall_conjI)
apply blast
apply (rotate_tac 1)
apply blast
*)
*)
(*
lemma "\<lbrakk> A\<Longrightarrow>B \<rbrakk> \<Longrightarrow>  A\<longrightarrow> B" impI *)

thm topological_transformation_group_def
lemma (in topological_transformation_group)
 " \<lbrakk>g \<in> X; x\<in> M \<rbrakk> \<Longrightarrow> \<phi> (g, x) \<in> M"
apply (insert map1)
apply blast
done

lemma (in topological_transformation_group)
"\<lbrakk> g\<in>X; h= (\<lambda>x. \<phi>(g,x)) \<rbrakk> \<Longrightarrow> (h: M\<rightarrow>M)"
apply (insert map1)
apply blast
done

definition orbit where
  "orbit x G = {g}"

definition product1 where
  "product1 A B \<equiv> (A \<times> B) "

definition product2 where
  "product2 A B \<equiv> {(product1 a b). ( a \<subseteq> A  \<and> b \<subseteq> B)} "

(*lemma "\<lbrakk> A\<subseteq> B; C \<subseteq> D \<rbrakk> \<Longrightarrow> (A \<times> C) \<subseteq> (B \<times> D)"
*)

thm times_def

definition ProductTopology where
  "ProductTopology T S \<equiv>  {\<Union>W. W \<in> Pow(ProductCollection T S)}"

definition  product_topology  where
 "product X Y ="
lemma "\<lbrakk> topological_space X Tx;topological_space Y Ty \<rbrakk> \<Longrightarrow> "

locale
(*
  defines prodtop_def [simp]: "$\tau \equiv$ ProductTopology(T,T)"
  fixes f
  assumes isgroup: "IsAgroup(G,f)"
  assumes isconti: "IsContinuous($\tau$,T,f)"
  assumes invisconti: "IsContinuous(T,T,GroupInv(G,f))"*)

(*  defines G_def [simp]: "G $\equiv \bigcup$ T"
  fixes prodtop ("$\tau$")
  defines prodtop_def [simp]: "$\tau \equiv$ ProductTopology(T,T)"
  fixes f
  assumes isgroup: "IsAgroup(G,f)"
  assumes isconti: "IsContinuous($\tau$,T,f)"
  assumes invisconti: "IsContinuous(T,T,GroupInv(G,f))"*)

lemma "\<lbrakk> topological_space X T ;
         Y = (X \<times> X);
         Ty = (ProductTopology T T) \<rbrakk> \<Longrightarrow> topological_space Y Ty "
apply (si)

definition product_topology1 where
   "product_topology1 X Tx  Y Ty \<equiv> \<Union>{u. \<exists>x\<in>Tx. \<exists>y\<in>Ty. ( (u=(x \<times> y)) \<and>
                (topological_space X  Tx) \<and>
                 (topological_space Y Ty))  }"*)
(*
lemma "\<lbrakk> topological_space X  (T::'a set set) ;Y = (X \<times> X) \<rbrakk> \<Longrightarrow> (product_topology1 T T) \<subseteq> Pow Y  "

lemma "\<lbrakk> topological_space X  T ;
          Y = (X \<times> X) ;
          Ty = Pow Y
       \<rbrakk> \<Longrightarrow>  Y \<in> Ty"

lemma "\<lbrakk> topological_space X  T ;
     orbit     Y = (X \<times> X) ;
          Ty = (product_topology1 X T X T )
       \<rbrakk> \<Longrightarrow> topological_space Y Ty "
apply (simp add:product_topology_def topological_space_def)

end


(*
    $Id: ex.thy,v 1.3 2011/06/28 18:11:39 webertj Exp $
    Author: Stefan Berghofer
*)

header {* Binary Decision Diagrams *}

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

text {*
Boolean functions (in finitely many variables) can be represented by so-called
{\it binary decision diagrams} (BDDs), which are given by the following data
type:
*}

datatype bdd = Leaf bool | Branch bdd bdd

text {*
A constructor @{term "Branch b1 b2"} that is $i$ steps away from the root of
the tree corresponds to a case distinction based on the value of the variable
$v_i$.  If the value of $v_i$ is @{term "False"}, the left subtree @{term "b1"}
is evaluated, otherwise the right subtree @{term "b2"} is evaluated.  The
following figure shows a Boolean function and the corresponding BDD.
\begin{center}
\begin{minipage}{8cm}
\begin{tabular}{|c|c|c|c|} \hline
$v_0$ & $v_1$ & $v_2$ & $f(v_0,v_1,v_2)$ \\ \hline
@{term "False"} & @{term "False"} & *               & @{term "True"} \\
@{term "False"} & @{term "True"}  & *               & @{term "False"} \\
@{term "True"}  & @{term "False"} & *               & @{term "False"} \\
@{term "True"}  & @{term "True"}  & @{term "False"} & @{term "False"} \\
@{term "True"}  & @{term "True"}  & @{term "True"}  & @{term "True"} \\ \hline
\end{tabular}
\end{minipage}
\begin{minipage}{7cm}
\begin{picture}(0,0)%
\includegraphics[scale=0.5]{bdd}%
\end{picture}%
\setlength{\unitlength}{2072sp}%
\begin{picture}(6457,3165)(1329,-4471)
\put(1351,-3571){\makebox(0,0)[b]{@{term "True"}}}%
\put(3151,-3571){\makebox(0,0)[b]{@{term "False"}}}%
\put(4951,-3571){\makebox(0,0)[b]{@{term "False"}}}%
\put(5851,-4471){\makebox(0,0)[b]{@{term "False"}}}%
\put(7651,-4471){\makebox(0,0)[b]{@{term "True"}}}%
\put(7786,-3301){\makebox(0,0)[lb]{$v_2$}}%
\put(7786,-2401){\makebox(0,0)[lb]{$v_1$}}%
\put(7786,-1501){\makebox(0,0)[lb]{$v_0$}}%
\end{picture}
\end{minipage}
\end{center}

{\bf Exercise 1:} Define a function
*}

consts eval :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bdd \<Rightarrow> bool"

text {*
that evaluates a BDD under a given variable assignment, beginning at a variable
with a given index.
*}

text {*
{\bf Exercise 2:} Define two functions
*}

consts
  bdd_unop :: "(bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd"
  bdd_binop :: "(bool \<Rightarrow> bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd \<Rightarrow> bdd"

text {*
for the application of unary and binary operators to BDDs, and prove their
correctness.
*}

text {*
Now use @{term "bdd_unop"} and @{term "bdd_binop"} to define
*}

consts
  bdd_and :: "bdd \<Rightarrow> bdd \<Rightarrow> bdd"
  bdd_or :: "bdd \<Rightarrow> bdd \<Rightarrow> bdd"
  bdd_not :: "bdd \<Rightarrow> bdd"
  bdd_xor :: "bdd \<Rightarrow> bdd \<Rightarrow> bdd"

text {*
and show correctness.
*}

text {*
Finally, define a function
*}

consts bdd_var :: "nat \<Rightarrow> bdd"

text {*
to create a BDD that evaluates to @{term "True"} if and only if the variable
with the given index evaluates to @{term "True"}.  Again prove a suitable
correctness theorem.

{\bf Hint:} If a lemma cannot be proven by induction because in the inductive
step a different value is used for a (non-induction) variable than in the
induction hypothesis, it may be necessary to strengthen the lemma by universal
quantification over that variable (cf.\ Section 3.2 in the Tutorial on
Isabelle/HOL).
*}

text_raw {* \begin{minipage}[t]{0.45\textwidth} *}

text{*
{\bf Example:} instead of
*}

lemma "P (b::bdd) x"
apply (induct b) (*<*) oops (*>*)

text_raw {* \end{minipage} *}
text_raw {* \begin{minipage}[t]{0.45\textwidth} *}

text {* Strengthening: *}

lemma "\<forall>x. P (b::bdd) x"
apply (induct b) (*<*) oops (*>*)

text_raw {* \end{minipage} \\[0.5cm]*}

text {*
{\bf Exercise 3:} Recall the following data type of propositional formulae
(cf.\ the exercise on ``Representation of Propositional Formulae by
Polynomials'')
*}

datatype form = T | Var nat | And form form | Xor form form

text {*
together with the evaluation function @{text "evalf"}:
*}

definition xor :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
  "xor x y \<equiv>  (x \<and> \<not> y) \<or> (\<not> x \<and> y)"

primrec evalf :: "(nat \<Rightarrow> bool) \<Rightarrow> form \<Rightarrow> bool" where
  "evalf e T = True"
| "evalf e (Var i) = e i"
| "evalf e (And f1 f2) = (evalf e f1 \<and> evalf e f2)"
| "evalf e (Xor f1 f2) = xor (evalf e f1) (evalf e f2)"

text {*
Define a function
*}

consts mk_bdd :: "form \<Rightarrow> bdd"

text {*
that transforms a propositional formula of type @{typ "form"} into a BDD.
Prove the correctness theorem
*}

theorem mk_bdd_correct: "eval e 0 (mk_bdd f) = evalf e f"
(*<*) oops (*>*)

(*<*) end (*>*)


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

text \<open>\NumHomework{Tries with Same-Length Keys}{22.~6.~2018}

  Consider the following trie datatype:
\<close>

datatype trie = LeafF | LeafT | Node "trie * trie"

text \<open>It is meant to store keys of the same length only.
  Thus, the @{const Node} constructor stores inner nodes, and there are two
  types of leaves, @{const LeafF} if this path is not in the set,
  and @{const LeafT} if it is in the set.

  Define an invariant \<open>is_trie N t\<close> that states that all keys in \<open>t\<close>
  have length \<open>N\<close>, and that there are no superfluous nodes, i.e.,
  no nodes of the form @{term \<open>Node (LeafF, LeafF)\<close>}.
\<close>

fun is_trie :: "nat \<Rightarrow> trie \<Rightarrow> bool"
where
  "is_trie 0 (Node (x,y)) \<longleftrightarrow> False"
| "is_trie 0 _ \<longleftrightarrow> True"
| "is_trie _ (Node (LeafF, LeafF)) \<longleftrightarrow> False"
| "is_trie (Suc n) LeafT \<longleftrightarrow> False"
| "is_trie (Suc n) LeafF \<longleftrightarrow> True"
(*| "is_trie (Suc 0) (Node (x,y)) \<longleftrightarrow> ((x = LeafF) \<or> (x = LeafT)) \<and> ((y = LeafF) \<or> (y = LeafT))"*)
| "is_trie (Suc n) (Node (x,y)) \<longleftrightarrow> is_trie n x \<and> is_trie n y"

text \<open>Hint: The following should evaluate to true!\<close>
value "is_trie 42 LeafF"
value "is_trie 2 (Node (LeafF,Node (LeafT,LeafF)))"
text \<open>Whereas these should be false\<close>
value "is_trie 42 LeafT" -- \<open>Wrong key length\<close>
value "is_trie 2 (Node (LeafT,Node (LeafT,LeafF)))" -- \<open>Wrong key length\<close>
value "is_trie 1 (Node (LeafT,Node (LeafF,LeafF)))" -- \<open>Superfluous node\<close>

value "is_trie 1 (Node (LeafT,LeafF))"

text \<open>Define membership, insert, and delete functions, and prove them correct! \<close>

fun isin :: "trie \<Rightarrow> bool list \<Rightarrow> bool"
  where
  "isin (Node (x, y)) (b#[]) = (if b then (x = LeafT) else (y = LeafT))"
| "isin (Node (x, y)) (b#bs) = (if b then (isin x bs) else (isin y bs))"
| "isin LeafT [] = True"
| "isin _ _ = False"

value "isin (Node (LeafF,Node (LeafT,LeafF))) [False, True]"

fun ins :: "bool list \<Rightarrow> trie \<Rightarrow> trie"
  where
  "ins (b#[]) LeafF = (if b then (Node (LeafT, LeafF)) else (Node(LeafF, LeafT)))"
| "ins (b#[]) LeafT = (if b then (Node (LeafT, LeafF)) else (Node(LeafF, LeafT)))"
| "ins (b#[]) (Node(x,y)) = (if b then (Node (LeafT, y)) else (Node(x, LeafT)))"
| "ins [] x = x"
| "ins (b#bs) (Node(x,y)) =  (if b then (Node ((ins bs x),y)) else (Node (x, (ins bs y))))"
| "ins (b#bs) LeafF = (if b then (Node ((ins bs LeafF),LeafF)) else (Node (LeafF, (ins bs LeafF))))"
| "ins (b#bs) LeafT = (if b then (Node ((ins bs LeafT),LeafF)) else (Node (LeafF, (ins bs LeafT))))"

(*fun ins :: "bool list \<Rightarrow> trie \<Rightarrow> trie"
  where
  "ins [] x = LeafT"
| "ins (b#bs) (Node(x,y)) =  (if b then (Node ((ins bs x),y)) else (Node (x, (ins bs y))))"
| "ins (b#bs) x = (if b then (Node ((ins bs x),LeafF)) else (Node (LeafF, (ins bs x))))"*)

value "ins [True, False] (Node (LeafF,Node (LeafT,LeafF)))"
value "ins [False] LeafF"
value "ins [True,True,True] (Node (LeafF,Node (LeafT,LeafF)))"

lemma isin_ins1:
  assumes "is_trie n t" and "length as = n"
  shows "isin (ins as t) bs = (as = bs \<or> isin t bs)"
  apply (induction as t arbitrary: bs n rule: ins.induct)

lemma isin_ins2:
  assumes "is_trie n t" and "length as = n"
  shows "is_trie n (ins as t)"
proof(induction as)
  case Nil
then show ?case
  by (simp add: assms(1))
next
case (Cons a as)
  then show ?case
    by (metis One_nat_def ins.simps(2) ins.simps(3) is_trie.simps(2) isin.simps(4) isin_ins1 le_numeral_extra(4) length_Cons list.size(3) not_less_eq_eq not_one_le_zero order_antisym_conv zero_induct)
qed

lemma isin_ins:
  assumes "is_trie n t" and "length as = n"
  shows "isin (ins as t) bs = (as = bs \<or> isin t bs)"
    and "is_trie n (ins as t)"
  using assms(1) assms(2) isin_ins1 apply auto[1]

fun delete2 :: "bool list \<Rightarrow> trie \<Rightarrow> trie" where
  "delete2 _ _ = undefined"

lemma
  assumes "is_trie n t"
  shows "isin (delete2 as t) bs = (as\<noteq>bs \<and> isin t bs)"
    and "(is_trie n (delete2 as t))"
  oops

text \<open>Hints:
  \<^item> Like in the \<open>delete2\<close> function for standard tries, you may want to define
    a "smart-constructor" \<open>node :: trie \<times> trie \<Rightarrow> trie\<close> for nodes,
    that constructs a node and handles the case that both successors are \<open>LeafF\<close>.
  \<^item> Consider proving auxiliary lemmas about the smart-constructor, instead of
    always unfolding it with the simplifier.
\<close>

(*<*)
end
(*>*)


theory MyList
  imports Main
begin

(* datatype requires no quotation marks on the left-hand side, but on the
right-hand side each of the argument types of a constructor needs to be
enclosed in quotation marks, unless it is just an identifier (e.g., nat or 'a).*)
datatype 'a list = Nil | Cons 'a "'a list"

fun app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"app Nil ys = ys" |
"app (Cons x xs) ys = Cons x (app xs ys)"

fun rev :: "'a list \<Rightarrow> 'a list" where
"rev Nil = Nil" |
"rev (Cons x xs) = app (rev xs) (Cons x Nil)"

value "rev (Cons True (Cons False Nil))"

(*
To prove that some property P holds for
all lists xs, i.e., P xs, you need to prove
1. the base case P Nil and
2. the inductive case P (Cons x xs) under the assumption P xs, for some
arbitrary but fixed x and xs.
This is often called structural induction
 *)

lemma app_Nil2 [simp]: "app xs Nil = xs"
  apply(induction xs)
  apply(auto)
  done

lemma app_assoc [simp]: "app (app xs ys) zs = app xs (app ys zs)"
  apply(induction xs)
  apply(auto)
  done

(*
lemma app_assoc[simp]: "rev (app xs ys) = app (rev ys) (rev xs) \<Longrightarrow>
       app (app (rev ys) (rev xs)) (Cons x1 Nil) =
       app (rev ys) (app (rev xs) (Cons x1 Nil))"
  apply(induction xs)
   apply(auto)
  done
*)

(*
Insert this lemma, and find more simpler lemma `app_Nil`
lemma " (app (app (rev xs) (Cons x1a Nil)) (Cons x1 Nil)) = Cons x1 (Cons x1a xs)"
*)
(*
 1. \<And>x1 xs.
       MyList.rev (app xs ys) = app (MyList.rev xs) (MyList.rev ys) \<Longrightarrow>
       app (app (MyList.rev xs) (MyList.rev ys)) (MyList.list.Cons x1 MyList.list.Nil) =
       app (app (MyList.rev xs) (MyList.list.Cons x1 MyList.list.Nil)) (MyList.rev ys)
 1. \<And>x1 xs.
       MyList.rev (app xs ys) = app (MyList.rev xs) (MyList.rev ys) \<Longrightarrow>
       app (MyList.rev xs) (app (MyList.rev ys) (MyList.list.Cons x1 MyList.list.Nil)) =
       app (MyList.rev xs) (MyList.list.Cons x1 (MyList.rev ys))
*)

(*lemma rev_app [simp]: "rev (app (rev xs) (Cons x1 Nil)) = Cons x1 xs" *)
lemma rev_app [simp]: "rev (app xs ys) = app (rev ys) (rev xs)"
  apply(induction xs)
   apply(auto)
  done

(* rev (app (rev xs) (Cons x1 Nil)) = Cons x1 xs is needed to be proved*)

theorem rev_rev [simp]: "rev(rev xs) = xs" (* Via the bracketed attribute simp we also tell *)
                                           (* Isabelle to make the eventual theorem a simplification rule *)
  apply(induction xs)
  apply(auto) (* subgoal 1 is proved *)
  done

end


(*  Author:     Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)
section \<open>Sum of Powers\<close>

theory Sum_of_Powers
imports Complex_Main
begin

subsection \<open>Preliminaries\<close>

lemma integrals_eq:
  assumes "f a = g a"
  assumes "\<And> x. ((\<lambda>x. f x - g x) has_real_derivative 0) (at x)"
  shows "f x = g x"
  by (metis (no_types, lifting) DERIV_isconst_all assms(1) assms(2) eq_iff_diff_eq_0)

lemma sum_diff: "((\<Sum>i\<le>n::nat. f (i + 1) - f i)::'a::field) = f (n + 1) - f 0"
  by (induct n) (auto simp add: field_simps)

declare One_nat_def [simp del]

subsection \<open>Bernoulli Numbers and Bernoulli Polynomials\<close>

declare sum.cong [fundef_cong]

fun bernoulli :: "nat \<Rightarrow> real"
where
  "bernoulli 0 = (1::real)"
| "bernoulli (Suc n) =  (-1 / (n + 2)) * (\<Sum>k \<le> n. ((n + 2 choose k) * bernoulli k))"

declare bernoulli.simps[simp del]

definition
  "bernpoly n = (\<lambda>x. \<Sum>k \<le> n. (n choose k) * bernoulli k * x ^ (n - k))"

subsection \<open>Basic Observations on Bernoulli Polynomials\<close>

lemma bernpoly_0: "bernpoly n 0 = bernoulli n"
proof (cases n)
  case 0
  then show "bernpoly n 0 = bernoulli n"
    unfolding bernpoly_def bernoulli.simps by auto
next
  case (Suc n')
  have "(\<Sum>k\<le>n'. real (Suc n' choose k) * bernoulli k * 0 ^ (Suc n' - k)) = 0"
    by (rule sum.neutral) auto
  with Suc show ?thesis
    unfolding bernpoly_def by simp
qed

lemma sum_binomial_times_bernoulli:
  "(\<Sum>k\<le>n. ((Suc n) choose k) * bernoulli k) = (if n = 0 then 1 else 0)"
proof (cases n)
  case 0
  then show ?thesis by (simp add: bernoulli.simps)
next
  case Suc
  then show ?thesis
  by (simp add: bernoulli.simps)
    (simp add: field_simps add_2_eq_Suc'[symmetric] del: add_2_eq_Suc add_2_eq_Suc')
qed

subsection \<open>Sum of Powers with Bernoulli Polynomials\<close>

lemma bernpoly_derivative [derivative_intros]:
  "(bernpoly (Suc n) has_real_derivative ((n + 1) * bernpoly n x)) (at x)"
proof -
  have "(bernpoly (Suc n) has_real_derivative (\<Sum>k\<le>n. real (Suc n - k) * x ^ (n - k) * (real (Suc n choose k) * bernoulli k))) (at x)"
    unfolding bernpoly_def by (rule DERIV_cong) (fast intro!: derivative_intros, simp)
  moreover have "(\<Sum>k\<le>n. real (Suc n - k) * x ^ (n - k) * (real (Suc n choose k) * bernoulli k)) = (n + 1) * bernpoly n x"
    unfolding bernpoly_def
    by (auto intro: sum.cong simp add: sum_distrib_left real_binomial_eq_mult_binomial_Suc[of _ n] Suc_eq_plus1 of_nat_diff)
  ultimately show ?thesis by auto
qed

lemma diff_bernpoly:
  "bernpoly n (x + 1) - bernpoly n x = n * x ^ (n - 1)"
proof (induct n arbitrary: x)
  case 0
  show ?case unfolding bernpoly_def by auto
next
  case (Suc n)
  have "bernpoly (Suc n) (0 + 1) - bernpoly (Suc n) 0 = (Suc n) * 0 ^ n"
    unfolding bernpoly_0 unfolding bernpoly_def by (simp add: sum_binomial_times_bernoulli zero_power)
  then have const: "bernpoly (Suc n) (0 + 1) - bernpoly (Suc n) 0 = real (Suc n) * 0 ^ n" by (simp add: power_0_left)
  have hyps': "\<And>x. (real n + 1) * bernpoly n (x + 1) - (real n + 1) * bernpoly n x = real n * x ^ (n - Suc 0) * real (Suc n)"
    unfolding right_diff_distrib[symmetric] by (simp add: Suc.hyps One_nat_def)
  note [derivative_intros] = DERIV_chain'[where f = "\<lambda>x::real. x + 1" and g = "bernpoly (Suc n)" and s="UNIV"]
  have derivative: "\<And>x. ((%x. bernpoly (Suc n) (x + 1) - bernpoly (Suc n) x - real (Suc n) * x ^ n) has_real_derivative 0) (at x)"
    by (rule DERIV_cong) (fast intro!: derivative_intros, simp add: hyps')
  from integrals_eq[OF const derivative] show ?case by simp
qed

lemma sum_of_powers: "(\<Sum>k\<le>n::nat. (real k) ^ m) = (bernpoly (Suc m) (n + 1) - bernpoly (Suc m) 0) / (m + 1)"
proof -
  from diff_bernpoly[of "Suc m", simplified] have "(m + (1::real)) * (\<Sum>k\<le>n. (real k) ^ m) = (\<Sum>k\<le>n. bernpoly (Suc m) (real k + 1) - bernpoly (Suc m) (real k))"
    by (auto simp add: sum_distrib_left intro!: sum.cong)
  also have "... = (\<Sum>k\<le>n. bernpoly (Suc m) (real (k + 1)) - bernpoly (Suc m) (real k))"
    by simp
  also have "... = bernpoly (Suc m) (n + 1) - bernpoly (Suc m) 0"
    by (simp only: sum_diff[where f="\<lambda>k. bernpoly (Suc m) (real k)"]) simp
  finally show ?thesis by (auto simp add: field_simps intro!: eq_divide_imp)
qed

subsection \<open>Instances for Square And Cubic Numbers\<close>

lemma binomial_unroll:
  "n > 0 \<Longrightarrow> (n choose k) = (if k = 0 then 1 else (n - 1) choose (k - 1) + ((n - 1) choose k))"
  by (auto simp add: gr0_conv_Suc)

lemma sum_unroll:
  "(\<Sum>k\<le>n::nat. f k) = (if n = 0 then f 0 else f n + (\<Sum>k\<le>n - 1. f k))"
by auto (metis One_nat_def Suc_pred add.commute sum.atMost_Suc)

lemma bernoulli_unroll:
  "n > 0 \<Longrightarrow> bernoulli n = - 1 / (real n + 1) * (\<Sum>k\<le>n - 1. real (n + 1 choose k) * bernoulli k)"
by (cases n) (simp add: bernoulli.simps One_nat_def)+

lemmas unroll = binomial_unroll
  bernoulli.simps(1) bernoulli_unroll sum_unroll bernpoly_def

lemma sum_of_squares: "(\<Sum>k\<le>n::nat. k ^ 2) = (2 * n ^ 3 + 3 * n ^ 2 + n) / 6"
proof -
  have "real (\<Sum>k\<le>n::nat. k ^ 2) = (\<Sum>k\<le>n::nat. (real k) ^ 2)" by simp
  also have "... = (bernpoly 3 (real (n + 1)) - bernpoly 3 0) / real (3 :: nat)"
    by (auto simp add: sum_of_powers)
  also have "... = (2 * n ^ 3 + 3 * n ^ 2 + n) / 6"
    by (simp add: unroll algebra_simps power2_eq_square power3_eq_cube One_nat_def[symmetric])
  finally show ?thesis by simp
qed

lemma sum_of_squares_nat: "(\<Sum>k\<le>n::nat. k ^ 2) = (2 * n ^ 3 + 3 * n ^ 2 + n) div 6"
proof -
  from sum_of_squares have "real (6 * (\<Sum>k\<le>n. k ^ 2)) = real (2 * n ^ 3 + 3 * n ^ 2 + n)"
    by (auto simp add: field_simps)
  then have "6 * (\<Sum>k\<le>n. k ^ 2) = 2 * n ^ 3 + 3 * n ^ 2 + n"
    using of_nat_eq_iff by blast
  then show ?thesis by auto
qed

lemma sum_of_cubes: "(\<Sum>k\<le>n::nat. k ^ 3) = (n ^ 2 + n) ^ 2 / 4"
proof -
  have two_plus_two: "2 + 2 = 4" by simp
  have power4_eq: "\<And>x::real. x ^ 4 = x * x * x * x"
    by (simp only: two_plus_two[symmetric] power_add power2_eq_square)
  have "real (\<Sum>k\<le>n::nat. k ^ 3) = (\<Sum>k\<le>n::nat. (real k) ^ 3)" by simp
  also have "... = ((bernpoly 4 (n + 1) - bernpoly 4 0)) / (real (4 :: nat))"
    by (auto simp add: sum_of_powers)
  also have "... = ((n ^ 2 + n) / 2) ^ 2"
    by (simp add: unroll algebra_simps power2_eq_square power4_eq power3_eq_cube)
  finally show ?thesis by (simp add: power_divide)
qed

lemma sum_of_cubes_nat: "(\<Sum>k\<le>n::nat. k ^ 3) = (n ^ 2 + n) ^ 2 div 4"
proof -
  from sum_of_cubes have "real (4 * (\<Sum>k\<le>n. k ^ 3)) = real ((n ^ 2 + n) ^ 2)"
    by (auto simp add: field_simps)
  then have "4 * (\<Sum>k\<le>n. k ^ 3) = (n ^ 2 + n) ^ 2"
    using of_nat_eq_iff by blast
  then show ?thesis by auto
qed

end


(*
Title: Aristotle's Assertoric Syllogistic
Author: Angeliki Koutsoukou-Argyraki, University of Cambridge.
October 2019

We formalise with Isabelle/HOL some basic elements of Aristotle's assertoric syllogistic following
the article from the Stanford Encyclopedia of Philosophy by Robin Smith:
https://plato.stanford.edu/entries/aristotle-logic/.
To this end, we use a set theoretic formulation (covering both individual and general predication).
In particular, we formalise the deductions in the Figures and after that we present Aristotle's
metatheoretical observation that all deductions in the Figures can in fact be reduced to either
Barbara or Celarent. As the formal proofs prove to be straightforward, the interest of this entry
lies in illustrating the functionality of Isabelle and high efficiency of Sledgehammer for simple
exercises in philosophy.*)

section\<open>Aristotle's Assertoric Syllogistic\<close>

theory AristotlesAssertoric
  imports Main
begin

subsection\<open>Aristotelean Categorical Sentences\<close>

text\<open> Aristotle's universal, particular and indefinite predications (affirmations and denials)
are expressed here using a set theoretic formulation.
Aristotle handles in the same way individual and general predications i.e.
he gives the same logical analysis to "Socrates is an animal" and "humans are animals".
Here we define the general predication i.e. predications are defined as relations between sets.
This has the benefit that individual predication can also be expressed as set membership (e.g. see
the lemma SocratesMortal). \<close>

definition universal_affirmation :: "'a set  \<Rightarrow>'a set  \<Rightarrow> bool"  (infixr "Q" 80)
  where "A Q B \<equiv> \<forall> b \<in> B . b \<in> A "

definition universal_denial ::  "'a set  \<Rightarrow>'a set   \<Rightarrow> bool"  (infixr "E" 80)
  where "A E B \<equiv> \<forall> b \<in> B. ( b \<notin> A)  "

definition particular_affirmation ::  " 'a set  \<Rightarrow>'a set  \<Rightarrow> bool"  (infixr "I" 80)
  where "A I B \<equiv> \<exists> b \<in> B. ( b \<in> A) "

definition particular_denial ::  "'a set  \<Rightarrow>'a set \<Rightarrow> bool"  (infixr "Z" 80)
  where "A Z B \<equiv> \<exists> b \<in> B. ( b \<notin> A) "

text\<open> The above four definitions are known as the "square of opposition".\<close>

definition indefinite_affirmation ::  " 'a set \<Rightarrow>'a set \<Rightarrow> bool"  (infixr "QI" 80)
  where "A QI B \<equiv>(( \<forall> b \<in> B. (b \<in> A)) \<or>  (\<exists> b \<in> B. (b \<in> A))) "

definition indefinite_denial ::  "'a set  \<Rightarrow>'a set \<Rightarrow> bool"  (infixr "EZ" 80)
  where "A EZ  B \<equiv> (( \<forall> b \<in> B. (b \<notin> A)) \<or> (\<exists> b \<in> B. (b \<notin> A)))  "

lemma aristo_conversion1 :
  assumes "A E B" shows "B E A"
  using assms universal_denial_def by blast

lemma aristo_conversion2 :
  assumes "A I B" shows "B I A"
  using assms unfolding  particular_affirmation_def
  by blast

lemma aristo_conversion3 : assumes "A Q B" and "B \<noteq>{} "  shows "B I A"
  using assms
  unfolding universal_affirmation_def particular_affirmation_def by blast

text\<open>Remark: Aristotle in general supposes that sets have to be nonempty. Indeed, we observe that
 in many instances it is necessary to assume that the sets are nonempty,
 otherwise Isabelle's automation finds counterexamples.\<close>

subsection\<open>The Deductions in the Figures ("Moods")\<close>

text\<open>The medieval mnemonic names are used.\<close>

subsubsection\<open>First Figure\<close>

lemma Barbara:
  assumes "A Q B " and "B Q C" shows "A Q C"
by (meson assms universal_affirmation_def)

lemma Celarent:
  assumes "A E B " and "B Q C" shows "A E C"
by (meson assms universal_affirmation_def universal_denial_def)

lemma Darii:
  assumes  "A Q B" and "B I C" shows "A I C"
by (meson assms particular_affirmation_def universal_affirmation_def)

lemma Ferio:
  assumes  "A E B" and "B I C" shows "A Z C"
by (meson assms particular_affirmation_def particular_denial_def universal_denial_def)

subsubsection\<open>Second Figure\<close>

lemma Cesare:
  assumes  "A E B " and "A Q C" shows "B E C"
using Celarent aristo_conversion1 assms by blast

lemma Camestres:
  assumes  "A Q B " and "A E C" shows "B E C "
using Cesare aristo_conversion1 assms by blast

lemma Festino:
  assumes  "A E B " and "A I C" shows "B Z C "
using Ferio aristo_conversion1 assms by blast

lemma Baroco:
  assumes  "A Q B " and "A Z C" shows "B Z C   "
by (meson assms particular_denial_def universal_affirmation_def)

subsubsection\<open>Third Figure\<close>

lemma Darapti:
  assumes  "A Q C " and "B Q C" and "C \<noteq>{}"   shows "A I B "
  using Darii assms unfolding  universal_affirmation_def particular_affirmation_def
  by blast

lemma Felapton:
  assumes  "A E C" and "B Q C"  and  "C \<noteq>{}"   shows "A Z B"
 using Festino aristo_conversion1 aristo_conversion3 assms by blast

lemma Disamis:
  assumes  "A I C" and "B Q C" shows "A I B"
  using Darii aristo_conversion2 assms by blast

lemma Datisi:
  assumes  "A Q C" and "B I C" shows "A I B"
  using Disamis aristo_conversion2 assms by blast

lemma Bocardo:
  assumes  "A Z C" and "B Q C" shows "A Z B"
 by (meson assms particular_denial_def universal_affirmation_def)

lemma Ferison:
  assumes  "A E C " and "B I C" shows "A Z B   "
using Ferio aristo_conversion2 assms by blast

subsubsection\<open>Examples\<close>

text\<open>Example of a deduction with general predication.\<close>

lemma GreekMortal :
  assumes  "Mortal Q Human" and "Human Q Greek "
  shows " Mortal Q Greek "
using assms Barbara by auto

text\<open>Example of a deduction with individual predication.\<close>

lemma SocratesMortal:
  assumes "Socrates \<in> Human " and "Mortal Q Human"
  shows "Socrates \<in> Mortal "
using assms by (simp add: universal_affirmation_def)

subsection\<open>Metatheoretical comments\<close>

text\<open>The following are presented to demonstrate one of Aristotle's metatheoretical
explorations. Namely, Aristotle's metatheorem that:
"All deductions in all three Figures can eventually be reduced to either Barbara or Celarent"
is demonstrated by the proofs below and by considering the proofs from the previous subsection. \<close>

lemma Darii_reducedto_Camestres:
  assumes "A Q B " and "B I C" and "A E C  " (*assms, concl. of Darii  and A E C *)
  shows "A I C"
proof-
  have "B E C" using Camestres \<open> A Q B   \<close>  \<open>A E C\<close>    by blast
  show ?thesis using \<open> B I C \<close>   \<open>B E C\<close>
    by (simp add: particular_affirmation_def universal_denial_def)
qed

text\<open>It is already evident from the proofs in the previous subsection that:

Camestres can be reduced to Cesare.

Cesare can be reduced to Celarent.

Festino can be reduced to Ferio.\<close>

lemma Ferio_reducedto_Cesare:  assumes
  "A E B " and "B I C" and "A Q C  " (*assms, concl. of Ferio  and A Q C *)
shows "A Z C"
 proof-
  have "B E C" using Cesare \<open>A E B \<close>  \<open>A Q C\<close>  by blast
  show ?thesis using  \<open>B I C \<close>  \<open>B E C\<close>
    by (simp add: particular_affirmation_def universal_denial_def)
qed

lemma Baroco_reducedto_Barbara :
  assumes "A Q B " and " A Z C  " and " B Q C "
  shows "B Z C" (*assms , concl. of Baroco and  B Q C *)
proof-
  have "A Q C" using  \<open>A Q B \<close>  \<open> B Q C \<close> Barbara by blast
  show ?thesis using  \<open>A Q C\<close>  \<open> A Z C \<close>
    by (simp add: particular_denial_def universal_affirmation_def)
qed

lemma Bocardo_reducedto_Barbara :
  assumes " A Z C" and "B Q C" and "A Q B"
  shows "A Z B" (*assms, concl of Bocardo and A Q B *)
proof-
  have "A Q C" using  \<open>B Q C\<close>  \<open> A Q B\<close> using Barbara by blast
  show ?thesis using  \<open>A Q C\<close> \<open> A Z C\<close>
    by (simp add: particular_denial_def universal_affirmation_def)
qed

text\<open>Finally, it is already evident from the proofs in the previous subsection that :

 Darapti can be reduced to Darii.

 Felapton can be reduced to Festino.

 Disamis can be reduced to Darii.

 Datisi can be reduced to Disamis.

 Ferison can be reduced to Ferio. \<close>

text\<open>In conclusion, the aforementioned deductions have thus been shown to be reduced to either
Barbara or Celarent as follows:

Baroco  $\Rightarrow$ Barbara

Bocardo $\Rightarrow$ Barbara

Felapton $\Rightarrow$ Festino $\Rightarrow$ Ferio $\Rightarrow$ Cesare $\Rightarrow$ Celarent

Datisi $\Rightarrow$ Disamis $\Rightarrow$ Darii $\Rightarrow$ Camestres $\Rightarrow$ Cesare

Darapti $\Rightarrow$ Darii

Ferison $\Rightarrow$ Ferio
\<close>

subsection\<open>Acknowledgements\<close>

text\<open>A.K.-A. was supported by the ERC Advanced Grant ALEXANDRIA (Project 742178)
 funded by the European Research Council and led by Professor Lawrence Paulson
 at the University of Cambridge, UK. Thanks to Wenda Li.\<close>

subsection\<open>Bibliography\<close>
text\<open>Smith, Robin, "Aristotle’s Logic",
The Stanford Encyclopedia of Philosophy (Summer 2019 Edition),
Edward N. Zalta (ed.), URL = @{url "https://plato.stanford.edu/archives/sum2019/entries/aristotle-logic/"}
\<close>

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_19
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

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 = Z"
| "t2 (S z) (Z) = S z"
| "t2 (S z) (S x2) = t2 z x2"

theorem property0 :
  "((len (drop n xs)) = (t2 (len xs) n))"
  apply(induct xs arbitrary:n)(*This "arbitrary:n" is mandatory.*)
   apply clarsimp(*This clarsimp is optional.*)
   apply(induct_tac n)(*"induct_tac" instead of "induct" because of "\<And>n"*)
    apply fastforce+
  apply clarsimp(*This clarsimp is optional.*)
  apply(induct_tac n)(*"induct_tac" instead of "induct" because of "\<And>n"*)
   apply fastforce+
  done

(*It is also a valid choice to start with induction on n.*)
theorem property0' :
  "((len (drop n xs)) = (t2 (len xs) n))"
  apply(induct n arbitrary:xs)(*This "arbitrary:xs" is mandatory.*)
   apply clarsimp(*This clarsimp is optional.*)
   apply(induct_tac xs)(*"induct_tac" instead of "induct" because of "\<And>n"*)
    apply fastforce+
  apply(induct_tac xs)(*"induct_tac" instead of "induct" because of "\<And>n"*)
   apply fastforce+
  done

end


theory Tut01
  imports Main
begin

value "2 + (2::nat)"
value "(2::nat) * (5 + 3)"
value "(3::nat) * 4 - 2 * (7 + 1)"

lemma comm: "(a::nat) + b = b + a"
  by simp

lemma assoc: "(a::nat) + (b + c) = (a + b) + c"
  by simp

fun count :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
  "count [] v = 0" |
  "count (x#xs) v = (if x = v then 1 else 0) + count xs v"

lemma "x \<notin> set xs \<Longrightarrow> count xs x = 0"
  apply(induction xs) by auto

lemma "count (x#xs) x = 1 + count xs x"
  apply(induction xs) by auto

theorem "count xs x \<le> length xs"
  apply(induction xs) by auto

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "snoc [] c = [c]" |
  "snoc (x#xs) c = x # (snoc xs c)"

lemma "snoc [] c = [c]"
  by simp

lemma snoc_is_append[simp]: "snoc xs x = xs @ [x]"
  apply(induction xs) by auto

fun reverse :: "'a list \<Rightarrow> 'a list" where
  "reverse [] = []" |
  "reverse (x#xs) = snoc (reverse xs) x"

lemma reverse_is_rev[simp]: "reverse xs = rev xs"
  apply(induction xs) by auto

theorem "reverse (reverse xs) = xs"
  apply(induction xs) by auto

end


theory trivia imports ZF
begin

lemma In_sound_right : \<open>x\<in>A \<Longrightarrow> A=B \<Longrightarrow> x\<in>B\<close>
  apply (erule subst[where b=B])
  apply assumption
  done

lemma UnE :
  assumes \<open>x \<in> (a \<union> b)\<close>
  shows \<open>x \<in> a \<or> x \<in> b\<close>
proof -
  from \<open>x\<in>(a\<union>b)\<close> have \<open>x \<in> \<Union>(Upair(a, b))\<close> by (unfold Un_def)
  from \<open>x \<in> \<Union>(Upair(a, b))\<close> obtain B
    where p1:\<open>x \<in> B\<close> and p2:\<open>B \<in> Upair(a, b)\<close>
    by (erule UnionE)
  from \<open>B \<in> Upair(a, b)\<close> have \<open>B = a \<or> B = b\<close> by (rule UpairE, auto)
  from p1 have l1:\<open>B = a \<Longrightarrow> x \<in> a\<close> by (rule In_sound_right)
  from p1 have l2:\<open>B = b \<Longrightarrow> x \<in> b\<close> by (rule In_sound_right)
  from \<open>B = a \<or> B = b\<close> and l1 and l2
  show \<open>x \<in> a \<or> x \<in> b\<close> by (rule disj_imp_disj)
qed

lemma SuccE :
  fixes xa and k
  assumes \<open>xa \<in> succ(k)\<close>
  shows \<open>xa = k \<or> xa \<in> k\<close>
proof -
  from \<open>xa \<in> succ(k)\<close> have \<open>xa \<in> cons(k, k)\<close> by (unfold succ_def)
  hence \<open>xa \<in> (Upair(k,k) \<union> k)\<close> by (unfold cons_def)
  hence \<open>xa \<in> Upair(k,k) \<or> xa \<in> k\<close> by (rule UnE)
  thus \<open>xa = k \<or> xa \<in> k\<close>
  proof (rule disjE)
    show \<open>xa \<in> k \<Longrightarrow> xa = k \<or> xa \<in> k\<close> by (rule disjI2)
  next
    assume \<open>xa \<in> Upair(k, k)\<close>
    hence \<open>xa = k\<close> by (rule upair.UpairE)
    thus \<open>xa = k \<or> xa \<in> k\<close> by (rule disjI1)
  qed
qed

lemma AeqUPA:\<open>A = \<Union>Pow(A)\<close>
proof (rule equalityI)
  have \<open>\<And>x. x \<in> \<Union>Pow(A) \<Longrightarrow> x \<in> A\<close>
  proof -
    fix x
    assume \<open>x \<in> \<Union>Pow(A)\<close>
    from \<open>x \<in> \<Union>Pow(A)\<close> obtain B
      where p1:\<open>x \<in> B\<close> and p2:\<open>B \<in> Pow(A)\<close>
      by (erule UnionE)
    from \<open>B \<in> Pow(A)\<close> have \<open>B \<subseteq> A\<close> by (rule PowD)
    from \<open>x \<in> B\<close> and \<open>B \<subseteq> A\<close> show \<open>x \<in> A\<close> by (rule rev_subsetD)
  qed
  then show \<open>\<Union>Pow(A) \<subseteq> A\<close>
    by (rule subsetI)
next
  have \<open>\<And>x. x \<in> A \<Longrightarrow> x \<in> \<Union>Pow(A)\<close>
  proof -
    fix x
    assume \<open>x \<in> A\<close>
    have \<open>A \<in> Pow(A)\<close> by auto
    from \<open>A \<in> Pow(A)\<close> and \<open>x \<in> A\<close>
    show \<open>x \<in> \<Union>Pow(A)\<close> by (rule UnionI)
  qed
  then show \<open>A \<subseteq> \<Union>Pow(A)\<close> by (rule subsetI)
qed

end