(*  Title:      Isomorphism Classes of Groups
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
    Maintainer: Jakob von Raumer <jakob.raumer@student.kit.edu>
*)

theory GroupIsoClasses
imports
  "HOL-Algebra.Coset"
begin

section \<open>Isomorphism Classes of Groups\<close>

text \<open>We construct a quotient type for isomorphism classes of groups.\<close>

typedef 'a group = "{G :: 'a monoid. group G}"
proof
  show "\<And>a. \<lparr>carrier = {a}, mult = (\<lambda>x y. x), one = a\<rparr> \<in> {G. group G}"
  unfolding group_def group_axioms_def monoid_def Units_def by auto
qed

definition group_iso_rel :: "'a group \<Rightarrow> 'a group \<Rightarrow> bool"
  where "group_iso_rel G H = (\<exists>\<phi>. \<phi> \<in> iso (Rep_group G) (Rep_group H))"

quotient_type 'a group_iso_class = "'a group" / group_iso_rel
  morphisms Rep_group_iso Abs_group_iso
proof (rule equivpI)
  show "reflp group_iso_rel"
  proof (rule reflpI)
    fix G :: "'b group"
    show "group_iso_rel G G"
      unfolding group_iso_rel_def using iso_set_refl by blast
  qed
next
  show "symp group_iso_rel"
  proof (rule sympI)
    fix G H :: "'b group"
    assume "group_iso_rel G H"
    then obtain \<phi> where "\<phi> \<in> iso (Rep_group G) (Rep_group H)" unfolding group_iso_rel_def by auto
    then obtain \<phi>' where "\<phi>' \<in> iso (Rep_group H) (Rep_group G)" using group.iso_sym Rep_group
      using group.iso_set_sym by blast
    thus "group_iso_rel H G" unfolding group_iso_rel_def by auto
  qed
next
  show "transp group_iso_rel"
  proof (rule transpI)
    fix G H I :: "'b group"
    assume "group_iso_rel G H" "group_iso_rel H I"
    then obtain \<phi> \<psi> where "\<phi> \<in> iso (Rep_group G) (Rep_group H)" "\<psi> \<in> iso (Rep_group H) (Rep_group I)"
      unfolding group_iso_rel_def by auto
    then obtain \<pi> where "\<pi> \<in> iso (Rep_group G) (Rep_group I)"
      using iso_set_trans by blast
    thus "group_iso_rel G I" unfolding group_iso_rel_def by auto
  qed
qed

text \<open>This assigns to a given group the group isomorphism class\<close>

definition (in group) iso_class :: "'a group_iso_class"
  where "iso_class = Abs_group_iso (Abs_group (monoid.truncate G))"

text \<open>Two isomorphic groups do indeed have the same isomorphism class:\<close>

lemma iso_classes_iff:
  assumes "group G"
  assumes "group H"
  shows "(\<exists>\<phi>. \<phi> \<in> iso G H) = (group.iso_class G = group.iso_class H)"
proof -
  from assms(1,2) have groups:"group (monoid.truncate G)" "group (monoid.truncate H)"
    unfolding monoid.truncate_def group_def group_axioms_def Units_def monoid_def by auto
  have "(\<exists>\<phi>. \<phi> \<in> iso G H) = (\<exists>\<phi>. \<phi> \<in> iso (monoid.truncate G) (monoid.truncate H))"
    unfolding iso_def hom_def monoid.truncate_def by auto
  also have "\<dots> = group_iso_rel (Abs_group (monoid.truncate G)) (Abs_group (monoid.truncate H))"
    unfolding group_iso_rel_def using groups group.Abs_group_inverse by (metis mem_Collect_eq)
  also have "\<dots> = (group.iso_class G = group.iso_class H)" using group.iso_class_def assms group_iso_class.abs_eq_iff by metis
  finally show ?thesis.
qed

end


theory Concrete_Semantics_2_4
  imports Main
begin

(* generalize the goal before induction. *)

(*
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)"
*)
(* A linear time version of rev *)

fun itrev :: "'a list => 'a list => 'a list" where
"itrev [] ys = ys" |
"itrev (x # xs) ys = itrev xs (x # ys)"

(* Note that itrev is tail-recursive: it can be
compiled into a loop; no stack is necessary for executing it. *)

(* lemma "itrev xs [] = rev xs" *)
(* The induction hypothesis is too weak, we met the following formula needed to prove:
 \<And> a xs: itrev xs [] = rev xs =) itrev xs [a] = rev xs @ [a] *)
(* heuristic:
    Generalize goals for induction by replacing constants by variables:
        e.g., "itrev xs [] = rev xs" -> "itrev xs ys = rev xs @ ys" *)
(* The induction hypothesis is ttile  weak
  \<And>a xs.
       itrev xs ys = rev xs @ ys \<Longrightarrow>
       itrev xs (a # ys) = app (rev xs) [a] @ ys

we prove the theorem for all ys instead of a fixed one: apply(induction xs ) -> apply(induction xs arbitrary: ys)
*)
lemma "itrev xs ys = rev xs @ ys"
apply(induction xs arbitrary: ys)
apply(auto)
done

(* another heuristic for generalization:
    Generalize induction by generalizing all free variables:
        e.g., apply(induction xs ) -> apply(induction xs arbitrary: ys)
    (except the induction variable itself).
*)

end


theory sample3
  imports Main begin

type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp

type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

term "\<lambda>x::vname. 0::val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
  "aval (N n) s = n" |
  "aval (V x) s = s x" |
  "aval (Plus xs ys) s = aval xs s + aval ys s"

value "aval (Plus (N 3) (V ''x'')) (\<lambda>x. 0)"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
  "asimp_const (N n) =  N n" |
  "asimp_const (V x) =  V x" |
  "asimp_const (Plus xs ys) =
  (case (asimp_const xs, asimp_const ys) of
    (N n, N m) \<Rightarrow> N(n + m) |
    (p, q) \<Rightarrow> Plus p q)"

lemma "aval (asimp_const a) s = aval a s"
  apply (induction a)
  apply (auto split: aexp.split)
  done

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "plus (N x) (N y) = N(x + y)" |
  "plus (N x) a =
    (if x = 0 then
      a
    else
      Plus (N x) a)" |
  "plus a (N x) =
    (if x = 0 then
      a
    else
      Plus a (N x))" |
  "plus x y = Plus x y"

thm plus.induct

lemma aval_plus [simp]: "aval (plus x y) s = aval x s + aval y s"
  apply (induction x y rule: plus.induct)
  apply (auto)
  done

fun asimp :: "aexp \<Rightarrow> aexp" where
  "asimp (N n) = N n" |
  "asimp (V x) = V x" |
  "asimp (Plus x y) =  plus (asimp x) (asimp y)"

lemma "aval (asimp a) s = aval a s"
  apply(induction a)
  apply(auto)
  done

datatype bexp = Bc bool | Not bexp |
  And bexp bexp | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
  "bval (Bc v) s = v" |
  "bval (Not b) s = (\<not> bval b s)" |
  "bval (And x y) s = (bval x s \<and> bval y s)" |
  "bval (Less x y) s = (aval x s < aval y s)"

fun not :: "bexp \<Rightarrow> bexp" where
  "not (Bc True) = Bc False" |
  "not (Bc False) = Bc True" |
  "not b = Not b"

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
  "and (Bc True) b = b" |
  "and b (Bc True) = b" |
  "and (Bc False) b = Bc False" |
  "and b (Bc False) = Bc False" |
  "and x y = And x y"

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "less (N x) (N y) = Bc (x < y)" |
  "less x y = Less x y"

fun bsimp :: "bexp \<Rightarrow> bexp" where
  "bsimp (Bc value) = Bc value" |
  "bsimp (Not b) = not (bsimp b)" |
  "bsimp (And bx by) = and (bsimp bx) (bsimp by)" |
  "bsimp (Less ax ay) = less (asimp ax) (asimp ay)"

lemma "bval (bsimp b) s = bval b s"
  sorry


theory Ex025
  imports Main
begin

lemma "A \<longleftrightarrow> \<not>\<not>A"
proof -
  {
    assume a:A
    {
      assume "\<not>A"
      with a have False by contradiction
    }
    hence "\<not>\<not>A" by (rule notI)
  }
  moreover
  {
    assume "\<not>\<not>A"
    hence A by (rule notnotD)
  }
  ultimately show ?thesis by (rule iffI)
qed

(*without notnotD*)

theorem "A \<longleftrightarrow> \<not>\<not>A"
proof -
 {
    assume a:A
    {
      assume "\<not>A"
      with a have False by contradiction
    }
    hence "\<not>\<not>A" by (rule notI)
  }
  moreover
  {
    assume "\<not>\<not>A"
    {
      assume "\<not>A"
      with \<open>\<not>\<not>A\<close> have False by (rule notE)
      hence A by (rule FalseE)
    }
    hence A by (rule classical)
  }
  ultimately show ?thesis by (rule iffI)
qed


(*  Title:      FOL/ex/Quantifiers_Cla.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section {* First-Order Logic: quantifier examples (classical version) *}

theory Quantifiers_Cla
imports FOL
begin

lemma "(ALL x y. P(x,y))  -->  (ALL y x. P(x,y))"
  by fast

lemma "(EX x y. P(x,y)) --> (EX y x. P(x,y))"
  by fast

-- {* Converse is false *}
lemma "(ALL x. P(x)) | (ALL x. Q(x)) --> (ALL x. P(x) | Q(x))"
  by fast

lemma "(ALL x. P-->Q(x))  <->  (P--> (ALL x. Q(x)))"
  by fast

lemma "(ALL x. P(x)-->Q)  <->  ((EX x. P(x)) --> Q)"
  by fast

text {* Some harder ones *}

lemma "(EX x. P(x) | Q(x)) <-> (EX x. P(x)) | (EX x. Q(x))"
  by fast

-- {* Converse is false *}
lemma "(EX x. P(x)&Q(x)) --> (EX x. P(x))  &  (EX x. Q(x))"
  by fast

text {* Basic test of quantifier reasoning *}

-- {* TRUE *}
lemma "(EX y. ALL x. Q(x,y)) -->  (ALL x. EX y. Q(x,y))"
  by fast

lemma "(ALL x. Q(x))  -->  (EX x. Q(x))"
  by fast

text {* The following should fail, as they are false! *}

lemma "(ALL x. EX y. Q(x,y))  -->  (EX y. ALL x. Q(x,y))"
  apply fast?
  oops

lemma "(EX x. Q(x))  -->  (ALL x. Q(x))"
  apply fast?
  oops

schematic_lemma "P(?a) --> (ALL x. P(x))"
  apply fast?
  oops

schematic_lemma "(P(?a) --> (ALL x. Q(x))) --> (ALL x. P(x) --> Q(x))"
  apply fast?
  oops

text {* Back to things that are provable \dots *}

lemma "(ALL x. P(x)-->Q(x)) & (EX x. P(x)) --> (EX x. Q(x))"
  by fast

-- {* An example of why exI should be delayed as long as possible *}
lemma "(P --> (EX x. Q(x))) & P --> (EX x. Q(x))"
  by fast

schematic_lemma "(ALL x. P(x)-->Q(f(x))) & (ALL x. Q(x)-->R(g(x))) & P(d) --> R(?a)"
  by fast

lemma "(ALL x. Q(x))  -->  (EX x. Q(x))"
  by fast

text {* Some slow ones *}

-- {* Principia Mathematica *11.53 *}
lemma "(ALL x y. P(x) --> Q(y)) <-> ((EX x. P(x)) --> (ALL y. Q(y)))"
  by fast

(*Principia Mathematica *11.55  *)
lemma "(EX x y. P(x) & Q(x,y)) <-> (EX x. P(x) & (EX y. Q(x,y)))"
  by fast

(*Principia Mathematica *11.61  *)
lemma "(EX y. ALL x. P(x) --> Q(x,y)) --> (ALL x. P(x) --> (EX y. Q(x,y)))"
  by fast

end


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

section \<open>Stewart's Theorem and Apollonius' Theorem\<close>

theory Stewart_Apollonius
imports
  Triangle.Triangle
begin

subsection \<open>Stewart's Theorem\<close>

theorem Stewart:
  fixes A B C D :: "'a::euclidean_space"
  assumes "between (B, C) D"
  assumes "a = dist B C"
  assumes "b = dist A C"
  assumes "c = dist B A"
  assumes "d = dist A D"
  assumes "m = dist B D"
  assumes "n = dist C D"
  shows "b\<^sup>2 * m + c\<^sup>2 * n = a * (d\<^sup>2 + m * n)"
proof (cases)
  assume "B \<noteq> D \<and> C \<noteq> D"
  let ?\<theta> = "angle B D A"
  let ?\<theta>' = "angle A D C"
  from \<open>B \<noteq> D \<and> C \<noteq> D\<close> \<open>between _ _\<close> have cos: "cos ?\<theta>' = - cos ?\<theta>"
    by (auto simp add: angle_inverse[of B C D] angle_commute[of A D C])
  from \<open>between _ _\<close> have "m + n = a"
    unfolding \<open>a = _\<close> \<open>m = _\<close> \<open>n = _\<close>
    by (metis (no_types) between dist_commute)
  have "c\<^sup>2 = m\<^sup>2 + d\<^sup>2 - 2 * d * m * cos ?\<theta>"
    unfolding \<open>c = _\<close> \<open>m = _\<close> \<open>d = _\<close>
    by (simp add: cosine_law_triangle[of B A D] dist_commute[of D A] dist_commute[of D B])
  moreover have "b\<^sup>2 = n\<^sup>2 + d\<^sup>2 + 2 * d * n * cos ?\<theta>"
    unfolding \<open>b = _\<close> \<open>n = _\<close> \<open>d = _\<close>
    by (simp add: cosine_law_triangle[of A C D] cos dist_commute[of D A] dist_commute[of D C])
  ultimately have "b\<^sup>2 * m + c\<^sup>2 * n = n * m\<^sup>2 + n\<^sup>2 * m + (m + n) * d\<^sup>2" by algebra
  also have "\<dots> = (m + n) * (m * n + d\<^sup>2)" by algebra
  also from \<open>m + n = a\<close> have "\<dots> = a * (d\<^sup>2 + m * n)" by simp
  finally show ?thesis .
next
  assume "\<not> (B \<noteq> D \<and> C \<noteq> D)"
  from this assms show ?thesis by (auto simp add: dist_commute)
qed

text \<open>
Here is an equivalent formulation that is probably more suitable for further use
in other geometry theories in Isabelle.
\<close>

theorem Stewart':
  fixes A B C D :: "'a::euclidean_space"
  assumes "between (B, C) D"
  shows "(dist A C)\<^sup>2 * dist B D + (dist B A)\<^sup>2 * dist C D = dist B C * ((dist A D)\<^sup>2 + dist B D * dist C D)"
using assms by (auto intro: Stewart)

subsection \<open>Apollonius' Theorem\<close>

text \<open>
Apollonius' theorem is a simple specialisation of Stewart's theorem,
but historically predated Stewart's theorem by many centuries.
\<close>

lemma Apollonius:
  fixes A B C :: "'a::euclidean_space"
  assumes "B \<noteq> C"
  assumes "b = dist A C"
  assumes "c = dist B A"
  assumes "d = dist A (midpoint B C)"
  assumes "m = dist B (midpoint B C)"
  shows "b\<^sup>2 + c\<^sup>2 = 2 * (m\<^sup>2 + d\<^sup>2)"
proof -
  from \<open>B \<noteq> C\<close> have "m \<noteq> 0"
    unfolding \<open>m = _\<close> using midpoint_eq_endpoint(1) by fastforce
  have "between (B, C) (midpoint B C)"
    by (simp add: between_midpoint)
  moreover have "dist C (midpoint B C) = dist B (midpoint B C)"
    by (simp add: dist_midpoint)
  moreover have "dist B C = 2 * dist B (midpoint B C)"
    by (simp add: dist_midpoint)
  moreover note assms(2-5)
  ultimately have "b\<^sup>2 * m + c\<^sup>2 * m = (2 * m) * (m\<^sup>2 + d\<^sup>2)"
    by (auto dest!: Stewart[where a="2 * m"] simp add: power2_eq_square)
  from this have "m * (b\<^sup>2 + c\<^sup>2) = m * (2 * (m\<^sup>2 + d\<^sup>2))"
    by (simp add: distrib_left semiring_normalization_rules(7))
  from this \<open>m \<noteq> 0\<close> show ?thesis by auto
qed

text \<open>
Here is the equivalent formulation that is probably more suitable for further use
in other geometry theories in Isabelle.
\<close>

lemma Apollonius':
  fixes A B C :: "'a::euclidean_space"
  assumes "B \<noteq> C"
  shows "(dist A C)\<^sup>2 + (dist B A)\<^sup>2 = 2 * ((dist B (midpoint B C))\<^sup>2 + (dist A (midpoint B C))\<^sup>2)"
using assms by (rule Apollonius) auto

end


(*
  File: Arrays_Ex.thy
  Author: Bohua Zhan
*)

section \<open>Arrays\<close>

theory Arrays_Ex
  imports "Auto2_HOL.Auto2_Main"
begin

text \<open>Basic examples for arrays.\<close>

subsection \<open>List swap\<close>

definition list_swap :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list" where [rewrite]:
  "list_swap xs i j = xs[i := xs ! j, j := xs ! i]"
setup \<open>register_wellform_data ("list_swap xs i j", ["i < length xs", "j < length xs"])\<close>
setup \<open>add_prfstep_check_req ("list_swap xs i j", "i < length xs \<and> j < length xs")\<close>

lemma list_swap_eval:
  "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow>
   (list_swap xs i j) ! k = (if k = i then xs ! j else if k = j then xs ! i else xs ! k)" by auto2
setup \<open>add_rewrite_rule_cond @{thm list_swap_eval} [with_cond "?k \<noteq> ?i", with_cond "?k \<noteq> ?j"]\<close>

lemma list_swap_eval_triv [rewrite]:
  "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> (list_swap xs i j) ! i = xs ! j"
  "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> (list_swap xs i j) ! j = xs ! i" by auto2+

lemma length_list_swap [rewrite_arg]:
  "length (list_swap xs i j) = length xs" by auto2

lemma mset_list_swap [rewrite]:
  "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> mset (list_swap xs i j) = mset xs" by auto2

subsection \<open>Reverse\<close>

lemma rev_nth [rewrite]:
  "n < length xs \<Longrightarrow> rev xs ! n = xs ! (length xs - 1 - n)"
@proof @induct xs @qed

fun rev_swap :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list" where
  "rev_swap xs i j = (if i < j then rev_swap (list_swap xs i j) (i + 1) (j - 1) else xs)"
setup \<open>register_wellform_data ("rev_swap xs i j", ["j < length xs"])\<close>
setup \<open>add_prfstep_check_req ("rev_swap xs i j", "j < length xs")\<close>

lemma rev_swap_length [rewrite_arg]:
  "j < length xs \<Longrightarrow> length (rev_swap xs i j) = length xs"
@proof @fun_induct "rev_swap xs i j" @unfold "rev_swap xs i j" @qed

lemma rev_swap_eval [rewrite]:
  "j < length xs \<Longrightarrow> (rev_swap xs i j) ! k =
    (if k < i then xs ! k else if k > j then xs ! k else xs ! (j - (k - i)))"
@proof @fun_induct "rev_swap xs i j" @unfold "rev_swap xs i j"
  @case "i < j" @with
    @case "k < i" @case "k > j" @have "j - (k - i) = j - k + i"
  @end
@qed

lemma rev_swap_is_rev [rewrite]:
  "length xs \<ge> 1 \<Longrightarrow> rev_swap xs 0 (length xs - 1) = rev xs" by auto2

subsection \<open>Copy one array to the beginning of another\<close>

fun array_copy :: "'a list \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
  "array_copy xs xs' 0 = xs'"
| "array_copy xs xs' (Suc n) = list_update (array_copy xs xs' n) n (xs ! n)"
setup \<open>fold add_rewrite_rule @{thms array_copy.simps}\<close>
setup \<open>register_wellform_data ("array_copy xs xs' n", ["n \<le> length xs", "n \<le> length xs'"])\<close>
setup \<open>add_prfstep_check_req ("array_copy xs xs' n", "n \<le> length xs \<and> n \<le> length xs'")\<close>

lemma array_copy_length [rewrite_arg]:
  "n \<le> length xs \<Longrightarrow> n \<le> length xs' \<Longrightarrow> length (array_copy xs xs' n) = length xs'"
@proof @induct n @qed

lemma array_copy_ind [rewrite]:
  "n \<le> length xs \<Longrightarrow> n \<le> length xs' \<Longrightarrow> k < n \<Longrightarrow> (array_copy xs xs' n) ! k = xs ! k"
@proof @induct n @qed

lemma array_copy_correct [rewrite]:
  "n \<le> length xs \<Longrightarrow> n \<le> length xs' \<Longrightarrow> take n (array_copy xs xs' n) = take n xs" by auto2

subsection \<open>Sublist\<close>

definition sublist :: "nat \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where [rewrite]:
  "sublist l r xs = drop l (take r xs)"
setup \<open>register_wellform_data ("sublist l r xs", ["l \<le> r", "r \<le> length xs"])\<close>
setup \<open>add_prfstep_check_req ("sublist l r xs", "l \<le> r \<and> r \<le> length xs")\<close>

lemma length_sublist [rewrite_arg]:
  "r \<le> length xs \<Longrightarrow> length (sublist l r xs) = r - l" by auto2

lemma nth_sublist [rewrite]:
  "r \<le> length xs \<Longrightarrow> xs' = sublist l r xs \<Longrightarrow> i < length xs' \<Longrightarrow> xs' ! i = xs ! (i + l)" by auto2

lemma sublist_nil [rewrite]:
  "r \<le> length xs \<Longrightarrow> r \<le> l \<Longrightarrow> sublist l r xs = []" by auto2

lemma sublist_0 [rewrite]:
  "sublist 0 l xs = take l xs" by auto2

lemma sublist_drop [rewrite]:
  "sublist l r (drop n xs) = sublist (l + n) (r + n) xs" by auto2

setup \<open>del_prfstep_thm @{thm sublist_def}\<close>

lemma sublist_single [rewrite]:
  "l + 1 \<le> length xs \<Longrightarrow> sublist l (l + 1) xs = [xs ! l]"
@proof @have "length [xs ! l] = 1" @qed

lemma sublist_append [rewrite]:
  "l \<le> m \<Longrightarrow> m \<le> r \<Longrightarrow> r \<le> length xs \<Longrightarrow> sublist l m xs @ sublist m r xs = sublist l r xs"
@proof
  @let "xs1 = sublist l r xs" "xs2 = sublist l m xs" "xs3 = sublist m r xs"
  @have "length (xs2 @ xs3) = (r - m) + (m - l)"
  @have "\<forall>i<length xs1. xs1 ! i = (xs2 @ xs3) ! i" @with
    @case "i < length xs2"
    @have "i - length xs2 < length xs3"
  @end
@qed

lemma sublist_Cons [rewrite]:
  "r \<le> length xs \<Longrightarrow> l < r \<Longrightarrow> xs ! l # sublist (l + 1) r xs = sublist l r xs"
@proof
  @have "sublist l r xs = sublist l (l + 1) xs @ sublist (l + 1) r xs"
@qed

lemma sublist_equalityI:
  "i \<le> j \<Longrightarrow> j \<le> length xs \<Longrightarrow> length xs = length ys \<Longrightarrow>
   \<forall>k. i \<le> k \<longrightarrow> k < j \<longrightarrow> xs ! k = ys ! k \<Longrightarrow> sublist i j xs = sublist i j ys" by auto2
setup \<open>add_backward2_prfstep_cond @{thm sublist_equalityI} [with_filt (order_filter "xs" "ys")]\<close>

lemma set_sublist [resolve]:
  "j \<le> length xs \<Longrightarrow> x \<in> set (sublist i j xs) \<Longrightarrow> \<exists>k. k \<ge> i \<and> k < j \<and> x = xs ! k"
@proof
  @let "xs' = sublist i j xs"
  @obtain l where "l < length xs'" "xs' ! l = x"
@qed

lemma list_take_sublist_drop_eq [rewrite]:
  "l \<le> r \<Longrightarrow> r \<le> length xs \<Longrightarrow> take l xs @ sublist l r xs @ drop r xs = xs"
@proof
  @have "take l xs = sublist 0 l xs"
  @have "drop r xs = sublist r (length xs) xs"
@qed

subsection \<open>Updating a set of elements in an array\<close>

definition list_update_set :: "(nat \<Rightarrow> bool) \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a list \<Rightarrow> 'a list" where [rewrite]:
  "list_update_set S f xs = list (\<lambda>i. if S i then f i else xs ! i) (length xs)"

lemma list_update_set_length [rewrite_arg]:
  "length (list_update_set S f xs) = length xs" by auto2

lemma list_update_set_nth [rewrite]:
  "xs' = list_update_set S f xs \<Longrightarrow> i < length xs' \<Longrightarrow> xs' ! i = (if S i then f i else xs ! i)" by auto2
setup \<open>del_prfstep_thm @{thm list_update_set_def}\<close>

fun list_update_set_impl :: "(nat \<Rightarrow> bool) \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
  "list_update_set_impl S f xs 0 = xs"
| "list_update_set_impl S f xs (Suc k) =
   (let xs' = list_update_set_impl S f xs k in
      if S k then xs' [k := f k] else xs')"
setup \<open>fold add_rewrite_rule @{thms list_update_set_impl.simps}\<close>
setup \<open>register_wellform_data ("list_update_set_impl S f xs n", ["n \<le> length xs"])\<close>

lemma list_update_set_impl_ind [rewrite]:
  "n \<le> length xs \<Longrightarrow> list_update_set_impl S f xs n =
   list (\<lambda>i. if i < n then if S i then f i else xs ! i else xs ! i) (length xs)"
@proof @induct n arbitrary xs @qed

lemma list_update_set_impl_correct [rewrite]:
  "list_update_set_impl S f xs (length xs) = list_update_set S f xs" by auto2

end


(* Title:      Pseudocomplemented Algebras
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Pseudocomplemented Algebras\<close>

text \<open>
This theory expands lattices with a pseudocomplement operation.
In particular, we consider the following algebraic structures:
\begin{itemize}
\item pseudocomplemented lattices (p-algebras)
\item pseudocomplemented distributive lattices (distributive p-algebras)
\item Stone algebras
\item Heyting semilattices
\item Heyting lattices
\item Heyting algebras
\item Heyting-Stone algebras
\item Brouwer algebras
\item Boolean algebras
\end{itemize}
Most of these structures and many results in this theory are discussed in \<^cite>\<open>"BalbesDwinger1974" and "Birkhoff1967" and "Blyth2005" and "Curry1977" and "Graetzer1971" and "Maddux1996"\<close>.
\<close>

theory P_Algebras

imports Lattice_Basics

begin

subsection \<open>P-Algebras\<close>

text \<open>
In this section we add a pseudocomplement operation to lattices and to distributive lattices.
\<close>

subsubsection \<open>Pseudocomplemented Lattices\<close>

text \<open>
The pseudocomplement of an element \<open>y\<close> is the greatest element whose meet with \<open>y\<close> is the least element of the lattice.
\<close>

class p_algebra = bounded_lattice + uminus +
  assumes pseudo_complement: "x \<sqinter> y = bot \<longleftrightarrow> x \<le> -y"
begin

subclass sup_inf_top_bot_uminus_ord .

text \<open>
Regular elements and dense elements are frequently used in pseudocomplemented algebras.
\<close>

abbreviation "regular x \<equiv> x = --x"
abbreviation "dense x \<equiv> -x = bot"
abbreviation "complemented x \<equiv> \<exists>y . x \<sqinter> y = bot \<and> x \<squnion> y = top"
abbreviation "in_p_image x \<equiv> \<exists>y . x = -y"
abbreviation "selection s x \<equiv> s = --s \<sqinter> x"

abbreviation "dense_elements \<equiv> { x . dense x }"
abbreviation "regular_elements \<equiv> { x . in_p_image x }"

lemma p_bot [simp]:
  "-bot = top"
  using inf_top.left_neutral pseudo_complement top_unique by blast

lemma p_top [simp]:
  "-top = bot"
  by (metis eq_refl inf_top.comm_neutral pseudo_complement)

text \<open>
The pseudocomplement satisfies the following half of the requirements of a complement.
\<close>

lemma inf_p [simp]:
  "x \<sqinter> -x = bot"
  using inf.commute pseudo_complement by fastforce

lemma p_inf [simp]:
  "-x \<sqinter> x = bot"
  by (simp add: inf_commute)

lemma pp_inf_p:
  "--x \<sqinter> -x = bot"
  by simp

text \<open>
The double complement is a closure operation.
\<close>

lemma pp_increasing:
  "x \<le> --x"
  using inf_p pseudo_complement by blast

lemma ppp [simp]:
  "---x = -x"
  by (metis order.antisym inf.commute order_trans pseudo_complement pp_increasing)

lemma pp_idempotent:
  "----x = --x"
  by simp

lemma regular_in_p_image_iff:
  "regular x \<longleftrightarrow> in_p_image x"
  by auto

lemma pseudo_complement_pp:
  "x \<sqinter> y = bot \<longleftrightarrow> --x \<le> -y"
  by (metis inf_commute pseudo_complement ppp)

lemma p_antitone:
  "x \<le> y \<Longrightarrow> -y \<le> -x"
  by (metis inf_commute order_trans pseudo_complement pp_increasing)

lemma p_antitone_sup:
  "-(x \<squnion> y) \<le> -x"
  by (simp add: p_antitone)

lemma p_antitone_inf:
  "-x \<le> -(x \<sqinter> y)"
  by (simp add: p_antitone)

lemma p_antitone_iff:
  "x \<le> -y \<longleftrightarrow> y \<le> -x"
  using order_lesseq_imp p_antitone pp_increasing by blast

lemma pp_isotone:
  "x \<le> y \<Longrightarrow> --x \<le> --y"
  by (simp add: p_antitone)

lemma pp_isotone_sup:
  "--x \<le> --(x \<squnion> y)"
  by (simp add: p_antitone)

lemma pp_isotone_inf:
  "--(x \<sqinter> y) \<le> --x"
  by (simp add: p_antitone)

text \<open>
One of De Morgan's laws holds in pseudocomplemented lattices.
\<close>

lemma p_dist_sup [simp]:
  "-(x \<squnion> y) = -x \<sqinter> -y"
  apply (rule order.antisym)
  apply (simp add: p_antitone)
  using inf_le1 inf_le2 le_sup_iff p_antitone_iff by blast

lemma p_supdist_inf:
  "-x \<squnion> -y \<le> -(x \<sqinter> y)"
  by (simp add: p_antitone)

lemma pp_dist_pp_sup [simp]:
  "--(--x \<squnion> --y) = --(x \<squnion> y)"
  by simp

lemma p_sup_p [simp]:
  "-(x \<squnion> -x) = bot"
  by simp

lemma pp_sup_p [simp]:
  "--(x \<squnion> -x) = top"
  by simp

lemma dense_pp:
  "dense x \<longleftrightarrow> --x = top"
  by (metis p_bot p_top ppp)

lemma dense_sup_p:
  "dense (x \<squnion> -x)"
  by simp

lemma regular_char:
  "regular x \<longleftrightarrow> (\<exists>y . x = -y)"
  by auto

lemma pp_inf_bot_iff:
  "x \<sqinter> y = bot \<longleftrightarrow> --x \<sqinter> y = bot"
  by (simp add: pseudo_complement_pp)

text \<open>
Weak forms of the shunting property hold.
Most require a pseudocomplemented element on the right-hand side.
\<close>

lemma p_shunting_swap:
  "x \<sqinter> y \<le> -z \<longleftrightarrow> x \<sqinter> z \<le> -y"
  by (metis inf_assoc inf_commute pseudo_complement)

lemma pp_inf_below_iff:
  "x \<sqinter> y \<le> -z \<longleftrightarrow> --x \<sqinter> y \<le> -z"
  by (simp add: inf_commute p_shunting_swap)

lemma p_inf_pp [simp]:
  "-(x \<sqinter> --y) = -(x \<sqinter> y)"
  apply (rule order.antisym)
  apply (simp add: inf.coboundedI2 p_antitone pp_increasing)
  using inf_commute p_antitone_iff pp_inf_below_iff by auto

lemma p_inf_pp_pp [simp]:
  "-(--x \<sqinter> --y) = -(x \<sqinter> y)"
  by (simp add: inf_commute)

lemma regular_closed_inf:
  "regular x \<Longrightarrow> regular y \<Longrightarrow> regular (x \<sqinter> y)"
  by (metis p_dist_sup ppp)

lemma regular_closed_p:
  "regular (-x)"
  by simp

lemma regular_closed_pp:
  "regular (--x)"
  by simp

lemma regular_closed_bot:
  "regular bot"
  by simp

lemma regular_closed_top:
  "regular top"
  by simp

lemma pp_dist_inf [simp]:
  "--(x \<sqinter> y) = --x \<sqinter> --y"
  by (metis p_dist_sup p_inf_pp_pp ppp)

lemma inf_import_p [simp]:
  "x \<sqinter> -(x \<sqinter> y) = x \<sqinter> -y"
  apply (rule order.antisym)
  using p_shunting_swap apply fastforce
  using inf.sup_right_isotone p_antitone by auto

text \<open>
Pseudocomplements are unique.
\<close>

lemma p_unique:
  "(\<forall>x . x \<sqinter> y = bot \<longleftrightarrow> x \<le> z) \<Longrightarrow> z = -y"
  using inf.order_eq_iff pseudo_complement by auto

lemma maddux_3_5:
  "x \<squnion> x = x \<squnion> -(y \<squnion> -y)"
  by simp

lemma shunting_1_pp:
  "x \<le> --y \<longleftrightarrow> x \<sqinter> -y = bot"
  by (simp add: pseudo_complement)

lemma pp_pp_inf_bot_iff:
  "x \<sqinter> y = bot \<longleftrightarrow> --x \<sqinter> --y = bot"
  by (simp add: pseudo_complement_pp)

lemma inf_pp_semi_commute:
  "x \<sqinter> --y \<le> --(x \<sqinter> y)"
  using inf.eq_refl p_antitone_iff p_inf_pp by presburger

lemma inf_pp_commute:
  "--(--x \<sqinter> y) = --x \<sqinter> --y"
  by simp

lemma sup_pp_semi_commute:
  "x \<squnion> --y \<le> --(x \<squnion> y)"
  by (simp add: p_antitone_iff)

lemma regular_sup:
  "regular z \<Longrightarrow> (x \<le> z \<and> y \<le> z \<longleftrightarrow> --(x \<squnion> y) \<le> z)"
  apply (rule iffI)
  apply (metis le_supI pp_isotone)
  using dual_order.trans sup_ge2 pp_increasing pp_isotone_sup by blast

lemma dense_closed_inf:
  "dense x \<Longrightarrow> dense y \<Longrightarrow> dense (x \<sqinter> y)"
  by (simp add: dense_pp)

lemma dense_closed_sup:
  "dense x \<Longrightarrow> dense y \<Longrightarrow> dense (x \<squnion> y)"
  by simp

lemma dense_closed_pp:
  "dense x \<Longrightarrow> dense (--x)"
  by simp

lemma dense_up_closed:
  "dense x \<Longrightarrow> x \<le> y \<Longrightarrow> dense y"
  using dense_pp top_le pp_isotone by auto

lemma regular_dense_top:
  "regular x \<Longrightarrow> dense x \<Longrightarrow> x = top"
  using p_bot by blast

lemma selection_char:
  "selection s x \<longleftrightarrow> (\<exists>y . s = -y \<sqinter> x)"
  by (metis inf_import_p inf_commute regular_closed_p)

lemma selection_closed_inf:
  "selection s x \<Longrightarrow> selection t x \<Longrightarrow> selection (s \<sqinter> t) x"
  by (metis inf_assoc inf_commute inf_idem pp_dist_inf)

lemma selection_closed_pp:
  "regular x \<Longrightarrow> selection s x \<Longrightarrow> selection (--s) x"
  by (metis pp_dist_inf)

lemma selection_closed_bot:
  "selection bot x"
  by simp

lemma selection_closed_id:
  "selection x x"
  using inf.le_iff_sup pp_increasing by auto

text \<open>
Conjugates are usually studied for Boolean algebras, however, some of their properties generalise to pseudocomplemented algebras.
\<close>

lemma conjugate_unique_p:
  assumes "conjugate f g"
      and "conjugate f h"
    shows "uminus \<circ> g = uminus \<circ> h"
proof -
  have "\<forall>x y . x \<sqinter> g y = bot \<longleftrightarrow> x \<sqinter> h y = bot"
    using assms conjugate_def inf.commute by simp
  hence "\<forall>x y . x \<le> -(g y) \<longleftrightarrow> x \<le> -(h y)"
    using inf.commute pseudo_complement by simp
  hence "\<forall>y . -(g y) = -(h y)"
    using order.eq_iff by blast
  thus ?thesis
    by auto
qed

lemma conjugate_symmetric:
  "conjugate f g \<Longrightarrow> conjugate g f"
  by (simp add: conjugate_def inf_commute)

lemma additive_isotone:
  "additive f \<Longrightarrow> isotone f"
  by (metis additive_def isotone_def le_iff_sup)

lemma dual_additive_antitone:
  assumes "dual_additive f"
    shows "isotone (uminus \<circ> f)"
proof -
  have "\<forall>x y . f (x \<squnion> y) \<le> f x"
    using assms dual_additive_def by simp
  hence "\<forall>x y . x \<le> y \<longrightarrow> f y \<le> f x"
    by (metis sup_absorb2)
  hence "\<forall>x y . x \<le> y \<longrightarrow> -(f x) \<le> -(f y)"
    by (simp add: p_antitone)
  thus ?thesis
    by (simp add: isotone_def)
qed

lemma conjugate_dual_additive:
  assumes "conjugate f g"
    shows "dual_additive (uminus \<circ> f)"
proof -
  have 1: "\<forall>x y z . -z \<le> -(f (x \<squnion> y)) \<longleftrightarrow> -z \<le> -(f x) \<and> -z \<le> -(f y)"
  proof (intro allI)
    fix x y z
    have "(-z \<le> -(f (x \<squnion> y))) = (f (x \<squnion> y) \<sqinter> -z = bot)"
      by (simp add: p_antitone_iff pseudo_complement)
    also have "... = ((x \<squnion> y) \<sqinter> g(-z) = bot)"
      using assms conjugate_def by auto
    also have "... = (x \<squnion> y \<le> -(g(-z)))"
      by (simp add: pseudo_complement)
    also have "... = (x \<le> -(g(-z)) \<and> y \<le> -(g(-z)))"
      by (simp add: le_sup_iff)
    also have "... = (x \<sqinter> g(-z) = bot \<and> y \<sqinter> g(-z) = bot)"
      by (simp add: pseudo_complement)
    also have "... = (f x \<sqinter> -z = bot \<and> f y \<sqinter> -z = bot)"
      using assms conjugate_def by auto
    also have "... = (-z \<le> -(f x) \<and> -z \<le> -(f y))"
      by (simp add: p_antitone_iff pseudo_complement)
    finally show "-z \<le> -(f (x \<squnion> y)) \<longleftrightarrow> -z \<le> -(f x) \<and> -z \<le> -(f y)"
      by simp
  qed
  have "\<forall>x y . -(f (x \<squnion> y)) = -(f x) \<sqinter> -(f y)"
  proof (intro allI)
    fix x y
    have "-(f x) \<sqinter> -(f y) = --(-(f x) \<sqinter> -(f y))"
      by simp
    hence "-(f x) \<sqinter> -(f y) \<le> -(f (x \<squnion> y))"
      using 1 by (metis inf_le1 inf_le2)
    thus "-(f (x \<squnion> y)) = -(f x) \<sqinter> -(f y)"
      using 1 order.antisym by fastforce
  qed
  thus ?thesis
    using dual_additive_def by simp
qed

lemma conjugate_isotone_pp:
  "conjugate f g \<Longrightarrow> isotone (uminus \<circ> uminus \<circ> f)"
  by (simp add: comp_assoc conjugate_dual_additive dual_additive_antitone)

lemma conjugate_char_1_pp:
  "conjugate f g \<longleftrightarrow> (\<forall>x y . f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x)"
proof
  assume 1: "conjugate f g"
  show "\<forall>x y . f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x"
  proof (intro allI)
    fix x y
    have 2: "f(x \<sqinter> -(g y)) \<le> -y"
      using 1 by (simp add: conjugate_def pseudo_complement)
    have "f(x \<sqinter> -(g y)) \<le> --f(x \<sqinter> -(g y))"
      by (simp add: pp_increasing)
    also have "... \<le> --f x"
      using 1 conjugate_isotone_pp isotone_def by simp
    finally have 3: "f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y"
      using 2 by simp
    have 4: "isotone (uminus \<circ> uminus \<circ> g)"
      using 1 conjugate_isotone_pp conjugate_symmetric by auto
    have 5: "g(y \<sqinter> -(f x)) \<le> -x"
      using 1 by (metis conjugate_def inf.cobounded2 inf_commute pseudo_complement)
    have "g(y \<sqinter> -(f x)) \<le> --g(y \<sqinter> -(f x))"
      by (simp add: pp_increasing)
    also have "... \<le> --g y"
      using 4 isotone_def by auto
    finally have "g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x"
      using 5 by simp
    thus "f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x"
      using 3 by simp
  qed
next
  assume 6: "\<forall>x y . f(x \<sqinter> -(g y)) \<le> --f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> --g y \<sqinter> -x"
  hence 7: "\<forall>x y . f x \<sqinter> y = bot \<longrightarrow> x \<sqinter> g y = bot"
    by (metis inf.le_iff_sup inf.le_sup_iff inf_commute pseudo_complement)
  have "\<forall>x y . x \<sqinter> g y = bot \<longrightarrow> f x \<sqinter> y = bot"
    using 6 by (metis inf.le_iff_sup inf.le_sup_iff inf_commute pseudo_complement)
  thus "conjugate f g"
    using 7 conjugate_def by auto
qed

lemma conjugate_char_1_isotone:
  "conjugate f g \<Longrightarrow> isotone f \<Longrightarrow> isotone g \<Longrightarrow> f(x \<sqinter> -(g y)) \<le> f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> g y \<sqinter> -x"
  by (simp add: conjugate_char_1_pp ord.isotone_def)

lemma dense_lattice_char_1:
  "(\<forall>x y . x \<sqinter> y = bot \<longrightarrow> x = bot \<or> y = bot) \<longleftrightarrow> (\<forall>x . x \<noteq> bot \<longrightarrow> dense x)"
  by (metis inf_top.left_neutral p_bot p_inf pp_inf_bot_iff)

lemma dense_lattice_char_2:
  "(\<forall>x y . x \<sqinter> y = bot \<longrightarrow> x = bot \<or> y = bot) \<longleftrightarrow> (\<forall>x . regular x \<longrightarrow> x = bot \<or> x = top)"
  by (metis dense_lattice_char_1 inf_top.left_neutral p_inf regular_closed_p regular_closed_top)

lemma restrict_below_Rep_eq:
  "x \<sqinter> --y \<le> z \<Longrightarrow> x \<sqinter> y = x \<sqinter> z \<sqinter> y"
  by (metis inf.absorb2 inf.commute inf.left_commute pp_increasing)

(*
lemma p_inf_sup_below: "-x \<sqinter> (x \<squnion> y) \<le> y" nitpick [expect=genuine] oops
lemma complement_p: "x \<sqinter> y = bot \<and> x \<squnion> y = top \<longrightarrow> -x = y" nitpick [expect=genuine] oops
lemma complemented_regular: "complemented x \<longrightarrow> regular x" nitpick [expect=genuine] oops
*)

end

text \<open>
The following class gives equational axioms for the pseudocomplement operation.
\<close>

class p_algebra_eq = bounded_lattice + uminus +
  assumes p_bot_eq: "-bot = top"
      and p_top_eq: "-top = bot"
      and inf_import_p_eq: "x \<sqinter> -(x \<sqinter> y) = x \<sqinter> -y"
begin

lemma inf_p_eq:
  "x \<sqinter> -x = bot"
  by (metis inf_bot_right inf_import_p_eq inf_top_right p_top_eq)

subclass p_algebra
  apply unfold_locales
  apply (rule iffI)
  apply (metis inf.orderI inf_import_p_eq inf_top.right_neutral p_bot_eq)
  by (metis (full_types) inf.left_commute inf.orderE inf_bot_right inf_commute inf_p_eq)

end

subsubsection \<open>Pseudocomplemented Distributive Lattices\<close>

text \<open>
We obtain further properties if we assume that the lattice operations are distributive.
\<close>

class pd_algebra = p_algebra + bounded_distrib_lattice
begin

lemma p_inf_sup_below:
  "-x \<sqinter> (x \<squnion> y) \<le> y"
  by (simp add: inf_sup_distrib1)

lemma pp_inf_sup_p [simp]:
  "--x \<sqinter> (x \<squnion> -x) = x"
  using inf.absorb2 inf_sup_distrib1 pp_increasing by auto

lemma complement_p:
  "x \<sqinter> y = bot \<Longrightarrow> x \<squnion> y = top \<Longrightarrow> -x = y"
  by (metis pseudo_complement inf.commute inf_top.left_neutral sup.absorb_iff1 sup.commute sup_bot.right_neutral sup_inf_distrib2 p_inf)

lemma complemented_regular:
  "complemented x \<Longrightarrow> regular x"
  using complement_p inf.commute sup.commute by fastforce

lemma regular_inf_dense:
  "\<exists>y z . regular y \<and> dense z \<and> x = y \<sqinter> z"
  by (metis pp_inf_sup_p dense_sup_p ppp)

lemma maddux_3_12 [simp]:
  "(x \<squnion> -y) \<sqinter> (x \<squnion> y) = x"
  by (metis p_inf sup_bot_right sup_inf_distrib1)

lemma maddux_3_13 [simp]:
  "(x \<squnion> y) \<sqinter> -x = y \<sqinter> -x"
  by (simp add: inf_sup_distrib2)

lemma maddux_3_20:
  "((v \<sqinter> w) \<squnion> (-v \<sqinter> x)) \<sqinter> -((v \<sqinter> y) \<squnion> (-v \<sqinter> z)) = (v \<sqinter> w \<sqinter> -y) \<squnion> (-v \<sqinter> x \<sqinter> -z)"
proof -
  have "v \<sqinter> w \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z) = v \<sqinter> w \<sqinter> -(v \<sqinter> y)"
    by (meson inf.cobounded1 inf_absorb1 le_infI1 p_antitone_iff)
  also have "... = v \<sqinter> w \<sqinter> -y"
    using inf.sup_relative_same_increasing inf_import_p inf_le1 by blast
  finally have 1: "v \<sqinter> w \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z) = v \<sqinter> w \<sqinter> -y"
    .
  have "-v \<sqinter> x \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z) = -v \<sqinter> x \<sqinter> -(-v \<sqinter> z)"
    by (simp add: inf.absorb1 le_infI1 p_antitone_inf)
  also have "... = -v \<sqinter> x \<sqinter> -z"
    by (simp add: inf.assoc inf_left_commute)
  finally have 2: "-v \<sqinter> x \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z) = -v \<sqinter> x \<sqinter> -z"
    .
  have "((v \<sqinter> w) \<squnion> (-v \<sqinter> x)) \<sqinter> -((v \<sqinter> y) \<squnion> (-v \<sqinter> z)) = (v \<sqinter> w \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z)) \<squnion> (-v \<sqinter> x \<sqinter> -(v \<sqinter> y) \<sqinter> -(-v \<sqinter> z))"
    by (simp add: inf_assoc inf_sup_distrib2)
  also have "... = (v \<sqinter> w \<sqinter> -y) \<squnion> (-v \<sqinter> x \<sqinter> -z)"
    using 1 2 by simp
  finally show ?thesis
    .
qed

lemma order_char_1:
  "x \<le> y \<longleftrightarrow> x \<le> y \<squnion> -x"
  by (metis inf.sup_left_isotone inf_sup_absorb le_supI1 maddux_3_12 sup_commute)

lemma order_char_2:
  "x \<le> y \<longleftrightarrow> x \<squnion> -x \<le> y \<squnion> -x"
  using order_char_1 by auto

lemma half_shunting:
  "x \<le> y \<squnion> z \<Longrightarrow> x \<sqinter> -z \<le> y"
  by (metis inf.sup_right_isotone inf_commute inf_sup_distrib1 sup.boundedE maddux_3_12)

(*
lemma pp_dist_sup [simp]: "--(x \<squnion> y) = --x \<squnion> --y" nitpick [expect=genuine] oops
lemma regular_closed_sup: "regular x \<and> regular y \<longrightarrow> regular (x \<squnion> y)" nitpick [expect=genuine] oops
lemma regular_complemented_iff: "regular x \<longleftrightarrow> complemented x" nitpick [expect=genuine] oops
lemma selection_closed_sup: "selection s x \<and> selection t x \<longrightarrow> selection (s \<squnion> t) x" nitpick [expect=genuine] oops
lemma stone [simp]: "-x \<squnion> --x = top" nitpick [expect=genuine] oops
*)

end

subsection \<open>Stone Algebras\<close>

text \<open>
A Stone algebra is a distributive lattice with a pseudocomplement that satisfies the following equation.
We thus obtain the other half of the requirements of a complement at least for the regular elements.
\<close>

class stone_algebra = pd_algebra +
  assumes stone [simp]: "-x \<squnion> --x = top"
begin

text \<open>
As a consequence, we obtain both De Morgan's laws for all elements.
\<close>

lemma p_dist_inf [simp]:
  "-(x \<sqinter> y) = -x \<squnion> -y"
proof (rule p_unique[THEN sym], rule allI, rule iffI)
  fix w
  assume "w \<sqinter> (x \<sqinter> y) = bot"
  hence "w \<sqinter> --x \<sqinter> y = bot"
    using inf_commute inf_left_commute pseudo_complement by auto
  hence 1: "w \<sqinter> --x \<le> -y"
    by (simp add: pseudo_complement)
  have "w = (w \<sqinter> -x) \<squnion> (w \<sqinter> --x)"
    using distrib_imp2 sup_inf_distrib1 by auto
  thus "w \<le> -x \<squnion> -y"
    using 1 by (metis inf_le2 sup.mono)
next
  fix w
  assume "w \<le> -x \<squnion> -y"
  thus "w \<sqinter> (x \<sqinter> y) = bot"
    using order_trans p_supdist_inf pseudo_complement by blast
qed

lemma pp_dist_sup [simp]:
  "--(x \<squnion> y) = --x \<squnion> --y"
  by simp

lemma regular_closed_sup:
  "regular x \<Longrightarrow> regular y \<Longrightarrow> regular (x \<squnion> y)"
  by simp

text \<open>
The regular elements are precisely the ones having a complement.
\<close>

lemma regular_complemented_iff:
  "regular x \<longleftrightarrow> complemented x"
  by (metis inf_p stone complemented_regular)

lemma selection_closed_sup:
  "selection s x \<Longrightarrow> selection t x \<Longrightarrow> selection (s \<squnion> t) x"
  by (simp add: inf_sup_distrib2)

lemma huntington_3_pp [simp]:
  "-(-x \<squnion> -y) \<squnion> -(-x \<squnion> y) = --x"
  by (metis p_dist_inf p_inf sup.commute sup_bot_left sup_inf_distrib1)

lemma maddux_3_3 [simp]:
  "-(x \<squnion> y) \<squnion> -(x \<squnion> -y) = -x"
  by (simp add: sup_commute sup_inf_distrib1)

lemma maddux_3_11_pp:
  "(x \<sqinter> -y) \<squnion> (x \<sqinter> --y) = x"
  by (metis inf_sup_distrib1 inf_top_right stone)

lemma maddux_3_19_pp:
  "(-x \<sqinter> y) \<squnion> (--x \<sqinter> z) = (--x \<squnion> y) \<sqinter> (-x \<squnion> z)"
proof -
  have "(--x \<squnion> y) \<sqinter> (-x \<squnion> z) = (--x \<sqinter> z) \<squnion> (y \<sqinter> -x) \<squnion> (y \<sqinter> z)"
    by (simp add: inf.commute inf_sup_distrib1 sup.assoc)
  also have "... = (--x \<sqinter> z) \<squnion> (y \<sqinter> -x) \<squnion> (y \<sqinter> z \<sqinter> (-x \<squnion> --x))"
    by simp
  also have "... = (--x \<sqinter> z) \<squnion> ((y \<sqinter> -x) \<squnion> (y \<sqinter> -x \<sqinter> z)) \<squnion> (y \<sqinter> z \<sqinter> --x)"
    using inf_sup_distrib1 sup_assoc inf_commute inf_assoc by presburger
  also have "... = (--x \<sqinter> z) \<squnion> (y \<sqinter> -x) \<squnion> (y \<sqinter> z \<sqinter> --x)"
    by simp
  also have "... = ((--x \<sqinter> z) \<squnion> (--x \<sqinter> z \<sqinter> y)) \<squnion> (y \<sqinter> -x)"
    by (simp add: inf_assoc inf_commute sup.left_commute sup_commute)
  also have "... = (--x \<sqinter> z) \<squnion> (y \<sqinter> -x)"
    by simp
  finally show ?thesis
    by (simp add: inf_commute sup_commute)
qed

lemma compl_inter_eq_pp:
  "--x \<sqinter> y = --x \<sqinter> z \<Longrightarrow> -x \<sqinter> y = -x \<sqinter> z \<Longrightarrow> y = z"
  by (metis inf_commute inf_p inf_sup_distrib1 inf_top.right_neutral p_bot p_dist_inf)

lemma maddux_3_21_pp [simp]:
  "--x \<squnion> (-x \<sqinter> y) = --x \<squnion> y"
  by (simp add: sup.commute sup_inf_distrib1)

lemma shunting_2_pp:
  "x \<le> --y \<longleftrightarrow> -x \<squnion> --y = top"
  by (metis inf_top_left p_bot p_dist_inf pseudo_complement)

lemma shunting_p:
  "x \<sqinter> y \<le> -z \<longleftrightarrow> x \<le> -z \<squnion> -y"
  by (metis inf.assoc p_dist_inf p_shunting_swap pseudo_complement)

text \<open>
The following weak shunting property is interesting as it does not require the element \<open>z\<close> on the right-hand side to be regular.
\<close>

lemma shunting_var_p:
  "x \<sqinter> -y \<le> z \<longleftrightarrow> x \<le> z \<squnion> --y"
proof
  assume "x \<sqinter> -y \<le> z"
  hence "z \<squnion> --y = --y \<squnion> (z \<squnion> x \<sqinter> -y)"
    by (simp add: sup.absorb1 sup.commute)
  thus "x \<le> z \<squnion> --y"
    by (metis inf_commute maddux_3_21_pp sup.commute sup.left_commute sup_left_divisibility)
next
  assume "x \<le> z \<squnion> --y"
  thus "x \<sqinter> -y \<le> z"
    by (metis inf.mono maddux_3_12 sup_ge2)
qed

(* Whether conjugate_char_2_pp can be proved in pd_algebra or in p_algebra is unknown. *)
lemma conjugate_char_2_pp:
  "conjugate f g \<longleftrightarrow> f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x))))"
proof
  assume 1: "conjugate f g"
  hence 2: "dual_additive (uminus \<circ> g)"
    using conjugate_symmetric conjugate_dual_additive by auto
  show "f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x))))"
  proof (intro conjI)
    show "f bot = bot"
      using 1 by (metis conjugate_def inf_idem inf_bot_left)
  next
    show "g bot = bot"
      using 1 by (metis conjugate_def inf_idem inf_bot_right)
  next
    show "\<forall>x y . f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x)))"
    proof (intro allI)
      fix x y
      have 3: "y \<le> -(f(x \<sqinter> -(g y)))"
        using 1 by (simp add: conjugate_def pseudo_complement inf_commute)
      have 4: "x \<le> -(g(y \<sqinter> -(f x)))"
        using 1 conjugate_def inf.commute pseudo_complement by fastforce
      have "y \<sqinter> -(f(x \<sqinter> --(g y))) = y \<sqinter> -(f(x \<sqinter> -(g y))) \<sqinter> -(f(x \<sqinter> --(g y)))"
        using 3 by (simp add: inf.le_iff_sup inf_commute)
      also have "... = y \<sqinter> -(f((x \<sqinter> -(g y)) \<squnion> (x \<sqinter> --(g y))))"
        using 1 conjugate_dual_additive dual_additive_def inf_assoc by auto
      also have "... = y \<sqinter> -(f x)"
        by (simp add: maddux_3_11_pp)
      also have "... \<le> -(f x)"
        by simp
      finally have 5: "f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y)))"
        by (simp add: inf_commute p_shunting_swap)
      have "x \<sqinter> -(g(y \<sqinter> --(f x))) = x \<sqinter> -(g(y \<sqinter> -(f x))) \<sqinter> -(g(y \<sqinter> --(f x)))"
        using 4 by (simp add: inf.le_iff_sup inf_commute)
      also have "... = x \<sqinter> -(g((y \<sqinter> -(f x)) \<squnion> (y \<sqinter> --(f x))))"
        using 2 by (simp add: dual_additive_def inf_assoc)
      also have "... = x \<sqinter> -(g y)"
        by (simp add: maddux_3_11_pp)
      also have "... \<le> -(g y)"
        by simp
      finally have "g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x)))"
        by (simp add: inf_commute p_shunting_swap)
      thus "f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x)))"
        using 5 by simp
    qed
  qed
next
  assume "f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> --(f(x \<sqinter> --(g y))) \<and> g y \<sqinter> x \<le> --(g(y \<sqinter> --(f x))))"
  thus "conjugate f g"
    by (unfold conjugate_def, metis inf_commute le_bot pp_inf_bot_iff regular_closed_bot)
qed

lemma conjugate_char_2_pp_additive:
  assumes "conjugate f g"
      and "additive f"
      and "additive g"
    shows "f x \<sqinter> y \<le> f(x \<sqinter> --(g y)) \<and> g y \<sqinter> x \<le> g(y \<sqinter> --(f x))"
proof -
  have "f x \<sqinter> y = f ((x \<sqinter> --g y) \<squnion> (x \<sqinter> -g y)) \<sqinter> y"
    by (simp add: sup.commute sup_inf_distrib1)
  also have "... = (f (x \<sqinter> --g y) \<sqinter> y) \<squnion> (f (x \<sqinter> -g y) \<sqinter> y)"
    using assms(2) additive_def inf_sup_distrib2 by auto
  also have "... = f (x \<sqinter> --g y) \<sqinter> y"
    by (metis assms(1) conjugate_def inf_le2 pseudo_complement sup_bot.right_neutral)
  finally have 2: "f x \<sqinter> y \<le> f (x \<sqinter> --g y)"
    by simp
  have "g y \<sqinter> x = g ((y \<sqinter> --f x) \<squnion> (y \<sqinter> -f x)) \<sqinter> x"
    by (simp add: sup.commute sup_inf_distrib1)
  also have "... = (g (y \<sqinter> --f x) \<sqinter> x) \<squnion> (g (y \<sqinter> -f x) \<sqinter> x)"
    using assms(3) additive_def inf_sup_distrib2 by auto
  also have "... = g (y \<sqinter> --f x) \<sqinter> x"
    by (metis assms(1) conjugate_def inf.cobounded2 pseudo_complement sup_bot.right_neutral inf_commute)
  finally have "g y \<sqinter> x \<le> g (y \<sqinter> --f x)"
    by simp
  thus ?thesis
    using 2 by simp
qed

(*
lemma compl_le_swap2_iff: "-x \<le> y \<longleftrightarrow> -y \<le> x" nitpick [expect=genuine] oops
lemma huntington_3: "x = -(-x \<squnion> -y) \<squnion> -(-x \<squnion> y)" nitpick [expect=genuine] oops
lemma maddux_3_1: "x \<squnion> -x = y \<squnion> -y" nitpick [expect=genuine] oops
lemma maddux_3_4: "x \<squnion> (y \<squnion> -y) = z \<squnion> -z" nitpick [expect=genuine] oops
lemma maddux_3_11: "x = (x \<sqinter> y) \<squnion> (x \<sqinter> -y)" nitpick [expect=genuine] oops
lemma maddux_3_19: "(-x \<sqinter> y) \<squnion> (x \<sqinter> z) = (x \<squnion> y) \<sqinter> (-x \<squnion> z)" nitpick [expect=genuine] oops
lemma compl_inter_eq: "x \<sqinter> y = x \<sqinter> z \<and> -x \<sqinter> y = -x \<sqinter> z \<longrightarrow> y = z" nitpick [expect=genuine] oops
lemma maddux_3_21: "x \<squnion> y = x \<squnion> (-x \<sqinter> y)" nitpick [expect=genuine] oops
lemma shunting_1: "x \<le> y \<longleftrightarrow> x \<sqinter> -y = bot" nitpick [expect=genuine] oops
lemma shunting_2: "x \<le> y \<longleftrightarrow> -x \<squnion> y = top" nitpick [expect=genuine] oops
lemma conjugate_unique: "conjugate f g \<and> conjugate f h \<longrightarrow> g = h" nitpick [expect=genuine] oops
lemma conjugate_isotone_pp: "conjugate f g \<longrightarrow> isotone f" nitpick [expect=genuine] oops
lemma conjugate_char_1: "conjugate f g \<longleftrightarrow> (\<forall>x y . f(x \<sqinter> -(g y)) \<le> f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> g y \<sqinter> -x)" nitpick [expect=genuine] oops
lemma conjugate_char_2: "conjugate f g \<longleftrightarrow> f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> f(x \<sqinter> g y) \<and> g y \<sqinter> x \<le> g(y \<sqinter> f x))" nitpick [expect=genuine] oops
lemma shunting: "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> z \<squnion> -y" nitpick [expect=genuine] oops
lemma shunting_var: "x \<sqinter> -y \<le> z \<longleftrightarrow> x \<le> z \<squnion> y" nitpick [expect=genuine] oops
lemma sup_compl_top: "x \<squnion> -x = top" nitpick [expect=genuine] oops
lemma selection_closed_p: "selection s x \<longrightarrow> selection (-s) x" nitpick [expect=genuine] oops
lemma selection_closed_pp: "selection s x \<longrightarrow> selection (--s) x" nitpick [expect=genuine] oops
*)

end

abbreviation stone_algebra_isomorphism :: "('a::stone_algebra \<Rightarrow> 'b::stone_algebra) \<Rightarrow> bool"
  where "stone_algebra_isomorphism f \<equiv> sup_inf_top_bot_uminus_isomorphism f"

text \<open>
Every bounded linear order can be expanded to a Stone algebra.
The pseudocomplement takes \<open>bot\<close> to the \<open>top\<close> and every other element to \<open>bot\<close>.
\<close>

class linorder_stone_algebra_expansion = linorder_lattice_expansion + uminus +
  assumes uminus_def [simp]: "-x = (if x = bot then top else bot)"
begin

subclass stone_algebra
  apply unfold_locales
  using bot_unique min_def top_le by auto

text \<open>
The regular elements are the least and greatest elements.
All elements except the least element are dense.
\<close>

lemma regular_bot_top:
  "regular x \<longleftrightarrow> x = bot \<or> x = top"
  by simp

lemma not_bot_dense:
  "x \<noteq> bot \<Longrightarrow> --x = top"
  by simp

end

subsection \<open>Heyting Algebras\<close>

text \<open>
In this section we add a relative pseudocomplement operation to semilattices and to lattices.
\<close>

subsubsection \<open>Heyting Semilattices\<close>

text \<open>
The pseudocomplement of an element \<open>y\<close> relative to an element \<open>z\<close> is the least element whose meet with \<open>y\<close> is below \<open>z\<close>.
This can be stated as a Galois connection.
Specialising \<open>z = bot\<close> gives (non-relative) pseudocomplements.
Many properties can already be shown if the underlying structure is just a semilattice.
\<close>

class implies =
  fixes implies :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<leadsto>" 65)

class heyting_semilattice = semilattice_inf + implies +
  assumes implies_galois: "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> y \<leadsto> z"
begin

lemma implies_below_eq [simp]:
  "y \<sqinter> (x \<leadsto> y) = y"
  using implies_galois inf.absorb_iff1 inf.cobounded1 by blast

lemma implies_increasing:
  "x \<le> y \<leadsto> x"
  by (simp add: inf.orderI)

lemma implies_galois_swap:
  "x \<le> y \<leadsto> z \<longleftrightarrow> y \<le> x \<leadsto> z"
  by (metis implies_galois inf_commute)

lemma implies_galois_var:
  "x \<sqinter> y \<le> z \<longleftrightarrow> y \<le> x \<leadsto> z"
  by (simp add: implies_galois_swap implies_galois)

lemma implies_galois_increasing:
  "x \<le> y \<leadsto> (x \<sqinter> y)"
  using implies_galois by blast

lemma implies_galois_decreasing:
  "(y \<leadsto> x) \<sqinter> y \<le> x"
  using implies_galois by blast

lemma implies_mp_below:
  "x \<sqinter> (x \<leadsto> y) \<le> y"
  using implies_galois_decreasing inf_commute by auto

lemma implies_isotone:
  "x \<le> y \<Longrightarrow> z \<leadsto> x \<le> z \<leadsto> y"
  using implies_galois order_trans by blast

lemma implies_antitone:
  "x \<le> y \<Longrightarrow> y \<leadsto> z \<le> x \<leadsto> z"
  by (meson implies_galois_swap order_lesseq_imp)

lemma implies_isotone_inf:
  "x \<leadsto> (y \<sqinter> z) \<le> x \<leadsto> y"
  by (simp add: implies_isotone)

lemma implies_antitone_inf:
  "x \<leadsto> z \<le> (x \<sqinter> y) \<leadsto> z"
  by (simp add: implies_antitone)

lemma implies_curry:
  "x \<leadsto> (y \<leadsto> z) = (x \<sqinter> y) \<leadsto> z"
  by (metis implies_galois_decreasing implies_galois inf_assoc order.antisym)

lemma implies_curry_flip:
  "x \<leadsto> (y \<leadsto> z) = y \<leadsto> (x \<leadsto> z)"
  by (simp add: implies_curry inf_commute)

lemma triple_implies [simp]:
  "((x \<leadsto> y) \<leadsto> y) \<leadsto> y = x \<leadsto> y"
  using implies_antitone implies_galois_swap order.eq_iff by auto

lemma implies_mp_eq [simp]:
  "x \<sqinter> (x \<leadsto> y) = x \<sqinter> y"
  by (metis implies_below_eq implies_mp_below inf_left_commute inf.absorb2)

lemma implies_dist_implies:
  "x \<leadsto> (y \<leadsto> z) \<le> (x \<leadsto> y) \<leadsto> (x \<leadsto> z)"
  using implies_curry implies_curry_flip by auto

lemma implies_import_inf [simp]:
  "x \<sqinter> ((x \<sqinter> y) \<leadsto> (x \<leadsto> z)) = x \<sqinter> (y \<leadsto> z)"
  by (metis implies_curry implies_mp_eq inf_commute)

lemma implies_dist_inf:
  "x \<leadsto> (y \<sqinter> z) = (x \<leadsto> y) \<sqinter> (x \<leadsto> z)"
proof -
  have "(x \<leadsto> y) \<sqinter> (x \<leadsto> z) \<sqinter> x \<le> y \<sqinter> z"
    by (simp add: implies_galois)
  hence "(x \<leadsto> y) \<sqinter> (x \<leadsto> z) \<le> x \<leadsto> (y \<sqinter> z)"
    using implies_galois by blast
  thus ?thesis
    by (simp add: implies_isotone order.eq_iff)
qed

lemma implies_itself_top:
  "y \<le> x \<leadsto> x"
  by (simp add: implies_galois_swap implies_increasing)

lemma inf_implies_top:
  "z \<le> (x \<sqinter> y) \<leadsto> x"
  using implies_galois_var le_infI1 by blast

lemma inf_inf_implies [simp]:
  "z \<sqinter> ((x \<sqinter> y) \<leadsto> x) = z"
  by (simp add: inf_implies_top inf_absorb1)

lemma le_implies_top:
  "x \<le> y \<Longrightarrow> z \<le> x \<leadsto> y"
  using implies_antitone implies_itself_top order.trans by blast

lemma le_iff_le_implies:
  "x \<le> y \<longleftrightarrow> x \<le> x \<leadsto> y"
  using implies_galois inf_idem by force

lemma implies_inf_isotone:
  "x \<leadsto> y \<le> (x \<sqinter> z) \<leadsto> (y \<sqinter> z)"
  by (metis implies_curry implies_galois_increasing implies_isotone)

lemma implies_transitive:
  "(x \<leadsto> y) \<sqinter> (y \<leadsto> z) \<le> x \<leadsto> z"
  using implies_dist_implies implies_galois_var implies_increasing order_lesseq_imp by blast

lemma implies_inf_absorb [simp]:
  "x \<leadsto> (x \<sqinter> y) = x \<leadsto> y"
  using implies_dist_inf implies_itself_top inf.absorb_iff2 by auto

lemma implies_implies_absorb [simp]:
  "x \<leadsto> (x \<leadsto> y) = x \<leadsto> y"
  by (simp add: implies_curry)

lemma implies_inf_identity:
  "(x \<leadsto> y) \<sqinter> y = y"
  by (simp add: inf_commute)

lemma implies_itself_same:
  "x \<leadsto> x = y \<leadsto> y"
  by (simp add: le_implies_top order.eq_iff)

end

text \<open>
The following class gives equational axioms for the relative pseudocomplement operation (inequalities can be written as equations).
\<close>

class heyting_semilattice_eq = semilattice_inf + implies +
  assumes implies_mp_below: "x \<sqinter> (x \<leadsto> y) \<le> y"
      and implies_galois_increasing: "x \<le> y \<leadsto> (x \<sqinter> y)"
      and implies_isotone_inf: "x \<leadsto> (y \<sqinter> z) \<le> x \<leadsto> y"
begin

subclass heyting_semilattice
  apply unfold_locales
  apply (rule iffI)
  apply (metis implies_galois_increasing implies_isotone_inf inf.absorb2 order_lesseq_imp)
  by (metis implies_mp_below inf_commute order_trans inf_mono order_refl)

end

text \<open>
The following class allows us to explicitly give the pseudocomplement of an element relative to itself.
\<close>

class bounded_heyting_semilattice = bounded_semilattice_inf_top + heyting_semilattice
begin

lemma implies_itself [simp]:
  "x \<leadsto> x = top"
  using implies_galois inf_le2 top_le by blast

lemma implies_order:
  "x \<le> y \<longleftrightarrow> x \<leadsto> y = top"
  by (metis implies_galois inf_top.left_neutral top_unique)

lemma inf_implies [simp]:
  "(x \<sqinter> y) \<leadsto> x = top"
  using implies_order inf_le1 by blast

lemma top_implies [simp]:
  "top \<leadsto> x = x"
  by (metis implies_mp_eq inf_top.left_neutral)

end

subsubsection \<open>Heyting Lattices\<close>

text \<open>
We obtain further properties if the underlying structure is a lattice.
In particular, the lattice operations are automatically distributive in this case.
\<close>

class heyting_lattice = lattice + heyting_semilattice
begin

lemma sup_distrib_inf_le:
  "(x \<squnion> y) \<sqinter> (x \<squnion> z) \<le> x \<squnion> (y \<sqinter> z)"
proof -
  have "x \<squnion> z \<le> y \<leadsto> (x \<squnion> (y \<sqinter> z))"
    using implies_galois_var implies_increasing sup.bounded_iff sup.cobounded2 by blast
  hence "x \<squnion> y \<le> (x \<squnion> z) \<leadsto> (x \<squnion> (y \<sqinter> z))"
    using implies_galois_swap implies_increasing le_sup_iff by blast
  thus ?thesis
    by (simp add: implies_galois)
qed

subclass distrib_lattice
  apply unfold_locales
  using distrib_sup_le order.eq_iff sup_distrib_inf_le by auto

lemma implies_isotone_sup:
  "x \<leadsto> y \<le> x \<leadsto> (y \<squnion> z)"
  by (simp add: implies_isotone)

lemma implies_antitone_sup:
  "(x \<squnion> y) \<leadsto> z \<le> x \<leadsto> z"
  by (simp add: implies_antitone)

lemma implies_sup:
  "x \<leadsto> z \<le> (y \<leadsto> z) \<leadsto> ((x \<squnion> y) \<leadsto> z)"
proof -
  have "(x \<leadsto> z) \<sqinter> (y \<leadsto> z) \<sqinter> y \<le> z"
    by (simp add: implies_galois)
  hence "(x \<leadsto> z) \<sqinter> (y \<leadsto> z) \<sqinter> (x \<squnion> y) \<le> z"
    using implies_galois_swap implies_galois_var by fastforce
  thus ?thesis
    by (simp add: implies_galois)
qed

lemma implies_dist_sup:
  "(x \<squnion> y) \<leadsto> z = (x \<leadsto> z) \<sqinter> (y \<leadsto> z)"
  apply (rule order.antisym)
  apply (simp add: implies_antitone)
  by (simp add: implies_sup implies_galois)

lemma implies_antitone_isotone:
  "(x \<squnion> y) \<leadsto> (x \<sqinter> y) \<le> x \<leadsto> y"
  by (simp add: implies_antitone_sup implies_dist_inf le_infI2)

lemma implies_antisymmetry:
  "(x \<leadsto> y) \<sqinter> (y \<leadsto> x) = (x \<squnion> y) \<leadsto> (x \<sqinter> y)"
  by (metis implies_dist_sup implies_inf_absorb inf.commute)

lemma sup_inf_implies [simp]:
  "(x \<squnion> y) \<sqinter> (x \<leadsto> y) = y"
  by (simp add: inf_sup_distrib2 sup.absorb2)

lemma implies_subdist_sup:
  "(x \<leadsto> y) \<squnion> (x \<leadsto> z) \<le> x \<leadsto> (y \<squnion> z)"
  by (simp add: implies_isotone)

lemma implies_subdist_inf:
  "(x \<leadsto> z) \<squnion> (y \<leadsto> z) \<le> (x \<sqinter> y) \<leadsto> z"
  by (simp add: implies_antitone)

lemma implies_sup_absorb:
  "(x \<leadsto> y) \<squnion> z \<le> (x \<squnion> z) \<leadsto> (y \<squnion> z)"
  by (metis implies_dist_sup implies_isotone_sup implies_increasing inf_inf_implies le_sup_iff sup_inf_implies)

lemma sup_below_implies_implies:
  "x \<squnion> y \<le> (x \<leadsto> y) \<leadsto> y"
  by (simp add: implies_dist_sup implies_galois_swap implies_increasing)

end

class bounded_heyting_lattice = bounded_lattice + heyting_lattice
begin

subclass bounded_heyting_semilattice ..

lemma implies_bot [simp]:
  "bot \<leadsto> x = top"
  using implies_galois top_unique by fastforce

end

subsubsection \<open>Heyting Algebras\<close>

text \<open>
The pseudocomplement operation can be defined in Heyting algebras, but it is typically not part of their signature.
We add the definition as an axiom so that we can use the class hierarchy, for example, to inherit results from the class \<open>pd_algebra\<close>.
\<close>

class heyting_algebra = bounded_heyting_lattice + uminus +
  assumes uminus_eq: "-x = x \<leadsto> bot"
begin

subclass pd_algebra
  apply unfold_locales
  using bot_unique implies_galois uminus_eq by auto

lemma boolean_implies_below:
  "-x \<squnion> y \<le> x \<leadsto> y"
  by (simp add: implies_increasing implies_isotone uminus_eq)

lemma negation_implies:
  "-(x \<leadsto> y) = --x \<sqinter> -y"
proof (rule order.antisym)
  show "-(x \<leadsto> y) \<le> --x \<sqinter> -y"
    using boolean_implies_below p_antitone by auto
next
  have "x \<sqinter> -y \<sqinter> (x \<leadsto> y) = bot"
    by (metis implies_mp_eq inf_p inf_bot_left inf_commute inf_left_commute)
  hence "--x \<sqinter> -y \<sqinter> (x \<leadsto> y) = bot"
    using pp_inf_bot_iff inf_assoc by auto
  thus "--x \<sqinter> -y \<le> -(x \<leadsto> y)"
    by (simp add: pseudo_complement)
qed

lemma double_negation_dist_implies:
  "--(x \<leadsto> y) = --x \<leadsto> --y"
  apply (rule order.antisym)
  apply (metis pp_inf_below_iff implies_galois_decreasing implies_galois negation_implies ppp)
  by (simp add: p_antitone_iff negation_implies)

(*
lemma stone: "-x \<squnion> --x = top" nitpick [expect=genuine] oops
*)

end

text \<open>
The following class gives equational axioms for Heyting algebras.
\<close>

class heyting_algebra_eq = bounded_lattice + implies + uminus +
  assumes implies_mp_eq: "x \<sqinter> (x \<leadsto> y) = x \<sqinter> y"
      and implies_import_inf: "x \<sqinter> ((x \<sqinter> y) \<leadsto> (x \<leadsto> z)) = x \<sqinter> (y \<leadsto> z)"
      and inf_inf_implies: "z \<sqinter> ((x \<sqinter> y) \<leadsto> x) = z"
      and uminus_eq_eq: "-x = x \<leadsto> bot"
begin

subclass heyting_algebra
  apply unfold_locales
  apply (rule iffI)
  apply (metis implies_import_inf inf.sup_left_divisibility inf_inf_implies le_iff_inf)
  apply (metis implies_mp_eq inf.commute inf.le_sup_iff inf.sup_right_isotone)
  by (simp add: uminus_eq_eq)

end

text \<open>
A relative pseudocomplement is not enough to obtain the Stone equation, so we add it in the following class.
\<close>

class heyting_stone_algebra = heyting_algebra +
  assumes heyting_stone: "-x \<squnion> --x = top"
begin

subclass stone_algebra
  by unfold_locales (simp add: heyting_stone)

(*
lemma pre_linear: "(x \<leadsto> y) \<squnion> (y \<leadsto> x) = top" nitpick [expect=genuine] oops
*)

end

subsubsection \<open>Brouwer Algebras\<close>

text \<open>
Brouwer algebras are dual to Heyting algebras.
The dual pseudocomplement of an element \<open>y\<close> relative to an element \<open>x\<close> is the least element whose join with \<open>y\<close> is above \<open>x\<close>.
We can now use the binary operation provided by Boolean algebras in Isabelle/HOL because it is compatible with dual relative pseudocomplements (not relative pseudocomplements).
\<close>

class brouwer_algebra = bounded_lattice + minus + uminus +
  assumes minus_galois: "x \<le> y \<squnion> z \<longleftrightarrow> x - y \<le> z"
      and uminus_eq_minus: "-x = top - x"
begin

sublocale brouwer: heyting_algebra where inf = sup and less_eq = greater_eq and less = greater and sup = inf and bot = top and top = bot and implies = "\<lambda>x y . y - x"
  apply unfold_locales
  apply simp
  apply simp
  apply simp
  apply simp
  apply (metis minus_galois sup_commute)
  by (simp add: uminus_eq_minus)

lemma curry_minus:
  "x - (y \<squnion> z) = (x - y) - z"
  by (simp add: brouwer.implies_curry sup_commute)

lemma minus_subdist_sup:
  "(x - z) \<squnion> (y - z) \<le> (x \<squnion> y) - z"
  by (simp add: brouwer.implies_dist_inf)

lemma inf_sup_minus:
  "(x \<sqinter> y) \<squnion> (x - y) = x"
  by (simp add: inf.absorb1 brouwer.inf_sup_distrib2)

end

subsection \<open>Boolean Algebras\<close>

text \<open>
This section integrates Boolean algebras in the above hierarchy.
In particular, we strengthen several results shown above.
\<close>

context boolean_algebra
begin

text \<open>
Every Boolean algebra is a Stone algebra, a Heyting algebra and a Brouwer algebra.
\<close>

subclass stone_algebra
  apply unfold_locales
  apply (rule iffI)
  apply (metis compl_sup_top inf.orderI inf_bot_right inf_sup_distrib1 inf_top_right sup_inf_absorb)
  using inf.commute inf.sup_right_divisibility apply fastforce
  by simp

sublocale heyting: heyting_algebra where implies = "\<lambda>x y . -x \<squnion> y"
  apply unfold_locales
  apply (rule iffI)
  using shunting_var_p sup_commute apply fastforce
  using shunting_var_p sup_commute apply force
  by simp

subclass brouwer_algebra
  apply unfold_locales
  apply (simp add: diff_eq shunting_var_p sup.commute)
  by (simp add: diff_eq)

lemma huntington_3 [simp]:
  "-(-x \<squnion> -y) \<squnion> -(-x \<squnion> y) = x"
  using huntington_3_pp by auto

lemma maddux_3_1:
  "x \<squnion> -x = y \<squnion> -y"
  by simp

lemma maddux_3_4:
  "x \<squnion> (y \<squnion> -y) = z \<squnion> -z"
  by simp

lemma maddux_3_11 [simp]:
  "(x \<sqinter> y) \<squnion> (x \<sqinter> -y) = x"
  using brouwer.maddux_3_12 sup.commute by auto

lemma maddux_3_19:
  "(-x \<sqinter> y) \<squnion> (x \<sqinter> z) = (x \<squnion> y) \<sqinter> (-x \<squnion> z)"
  using maddux_3_19_pp by auto

lemma compl_inter_eq:
  "x \<sqinter> y = x \<sqinter> z \<Longrightarrow> -x \<sqinter> y = -x \<sqinter> z \<Longrightarrow> y = z"
  by (metis inf_commute maddux_3_11)

lemma maddux_3_21 [simp]:
  "x \<squnion> (-x \<sqinter> y) = x \<squnion> y"
  by (simp add: sup_inf_distrib1)

lemma shunting_1:
  "x \<le> y \<longleftrightarrow> x \<sqinter> -y = bot"
  by (simp add: pseudo_complement)

lemma uminus_involutive:
  "uminus \<circ> uminus = id"
  by auto

lemma uminus_injective:
  "uminus \<circ> f = uminus \<circ> g \<Longrightarrow> f = g"
  by (metis comp_assoc id_o minus_comp_minus)

lemma conjugate_unique:
  "conjugate f g \<Longrightarrow> conjugate f h \<Longrightarrow> g = h"
  using conjugate_unique_p uminus_injective by blast

lemma dual_additive_additive:
  "dual_additive (uminus \<circ> f) \<Longrightarrow> additive f"
  by (metis additive_def compl_eq_compl_iff dual_additive_def p_dist_sup o_def)

lemma conjugate_additive:
  "conjugate f g \<Longrightarrow> additive f"
  by (simp add: conjugate_dual_additive dual_additive_additive)

lemma conjugate_isotone:
  "conjugate f g \<Longrightarrow> isotone f"
  by (simp add: conjugate_additive additive_isotone)

lemma conjugate_char_1:
  "conjugate f g \<longleftrightarrow> (\<forall>x y . f(x \<sqinter> -(g y)) \<le> f x \<sqinter> -y \<and> g(y \<sqinter> -(f x)) \<le> g y \<sqinter> -x)"
  by (simp add: conjugate_char_1_pp)

lemma conjugate_char_2:
  "conjugate f g \<longleftrightarrow> f bot = bot \<and> g bot = bot \<and> (\<forall>x y . f x \<sqinter> y \<le> f(x \<sqinter> g y) \<and> g y \<sqinter> x \<le> g(y \<sqinter> f x))"
  by (simp add: conjugate_char_2_pp)

lemma shunting:
  "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> z \<squnion> -y"
  by (simp add: heyting.implies_galois sup.commute)

lemma shunting_var:
  "x \<sqinter> -y \<le> z \<longleftrightarrow> x \<le> z \<squnion> y"
  by (simp add: shunting)

end

class non_trivial_stone_algebra = non_trivial_bounded_order + stone_algebra

class non_trivial_boolean_algebra = non_trivial_stone_algebra + boolean_algebra

end


theory DInduction
imports Main BDatatypes
begin

(* Section 3.2 *)

(* Rules of thumb (ROT) for generalizing the goal before induction *)

(* Linear-time, tail-recursive version of rev with accumulator *)
primrec itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"itrev []       ys = ys" |
"itrev (x # xs) ys = itrev xs (x # ys)"

(*
lemma "itrev xs [] = rev xs"
apply (induct_tac xs)
apply simp_all (* Does not include the induction hypothesis *)
*)

(* ROT: Generalize goals for induction by replacing constants with variables *)

(*
lemma "itrev xs ys = rev xs @ ys"
apply (induct_tac xs)
apply simp_all (* Requires specific ys but should be for all ys *)
*)

(* We're not doing induction on ys, so they should be quantified over. *)

(* ROT: Generalize goals for induction by universally quantifying over all free
   variables, except the induction variable itself. *)

lemma "\<forall>ys. itrev xs ys = rev xs @ ys"
apply (induct_tac xs)
apply simp_all
done

(* ROT: The rhs of an equation should be (in some sense) simpler than the lhs. *)

(* What happens if the lhs is simpler that the rhs? *)
(*
lemma "\<forall>ys. rev xs @ ys = itrev xs ys"
apply (induct_tac xs)
apply simp_all
(* What to do here? *)
*)

(* Exercise 3.2.1 *)
primrec add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add m 0       = m" |
"add m (Suc n) = add (Suc m) n"

lemma "\<forall>m. add m n = m + n"
apply (induct_tac n)
apply simp_all
done

(* Exercise 3.2.2 *)
primrec flatten\<^sub>2 :: "'a tree \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"flatten\<^sub>2 Tip           ys = ys" |
"flatten\<^sub>2 (Node t\<^sub>1 x t\<^sub>2) ys = flatten\<^sub>2 t\<^sub>1 (x # flatten\<^sub>2 t\<^sub>2 ys)"

lemma "\<forall>ys. flatten\<^sub>2 t ys = flatten t @ ys"
apply (induct_tac t)
apply simp_all
done

end


theory Exercise5p5
imports Main
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
    refl: "star r x x"
  | step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
    zero: "iter r 0 x x"
  | step: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

lemma "iter r n x y \<Longrightarrow> star r x y"
proof (induction rule: iter.induct)
  case zero
  fix x
  show "star r x x" by (simp add: star.refl star.step)
next
  case step
  fix x n y z
  assume "r x y"
     and "star r y z"
  then show "star r x z" by (simp add: star.step)
qed

end


(*  Title:      Shattering.thy
    Author:     Ata Keskin, TU München
*)

section \<open>Definitions and lemmas about shattering\<close>

text \<open>In this section, we introduce the predicate @{term "shatters"} and the term for the family of sets that a family shatters @{term "shattered_by"}.\<close>

theory Shattering
  imports Main
begin

subsection \<open>Intersection of a family of sets with a set\<close>

abbreviation IntF :: "'a set set \<Rightarrow> 'a set \<Rightarrow> 'a set set" (infixl "\<inter>*" 60)
  where "F \<inter>* S \<equiv> ((\<inter>) S) ` F"

lemma idem_IntF:
  assumes "\<Union>A \<subseteq> Y"
  shows "A \<inter>* Y = A"
proof -
  from assms have "A \<subseteq> A \<inter>* Y" by blast
  thus ?thesis by fastforce
qed

lemma subset_IntF:
  assumes "A \<subseteq> B"
  shows "A \<inter>* X \<subseteq> B \<inter>* X"
  using assms by (rule image_mono)

lemma Int_IntF: "(A \<inter>* Y) \<inter>* X = A \<inter>* (Y \<inter> X)"
proof
  show "A \<inter>* Y \<inter>* X \<subseteq> A \<inter>* (Y \<inter> X)"
  proof
    fix S
    assume "S \<in> A \<inter>* Y \<inter>* X"
    then obtain a_y where A_Y0: "a_y \<in> A \<inter>* Y" and A_Y1: "a_y \<inter> X = S" by blast
    from A_Y0 obtain a where A0: "a \<in> A" and A1: "a \<inter> Y = a_y" by blast
    from A_Y1 A1 have "a \<inter> (Y \<inter> X) = S" by fast
    with A0 show "S \<in> A \<inter>* (Y \<inter> X)" by blast
  qed
next
  show "A \<inter>* (Y \<inter> X) \<subseteq> A \<inter>* Y \<inter>* X"
  proof
    fix S
    assume "S \<in> A \<inter>* (Y \<inter> X)"
    then obtain a where A0: "a \<in> A" and A1: "a \<inter> (Y \<inter> X) = S" by blast
    from A0 have "a \<inter> Y \<in> A \<inter>* Y" by blast
    with A1 show "S \<in> (A \<inter>* Y) \<inter>* X" by blast
  qed
qed

text \<open>@{term insert} distributes over @{term IntF}\<close>
lemma insert_IntF:
  shows "insert x ` (H \<inter>* S) = (insert x ` H) \<inter>* (insert x S)"
proof
  show "insert x ` (H \<inter>* S) \<subseteq> (insert x ` H) \<inter>* (insert x S)"
  proof
    fix y_x
    assume "y_x \<in> insert x ` (H \<inter>* S)"
    then obtain y where 0: "y \<in> (H \<inter>* S)" and 1: "y_x = y \<union> {x}" by blast
    from 0 obtain yh where 2: "yh \<in> H" and 3: "y = yh \<inter> S" by blast
    from 1 3 have "y_x = (yh \<union> {x}) \<inter> (S \<union> {x})" by simp
    with 2 show "y_x \<in> (insert x ` H) \<inter>* (insert x S)" by blast
  qed
next
  show "insert x ` H \<inter>* (insert x S) \<subseteq> insert x ` (H \<inter>* S)"
  proof
    fix y_x
    assume "y_x \<in> insert x ` H \<inter>* (insert x S)"
    then obtain yh_x where 0: "yh_x \<in> (\<lambda>Y. Y \<union> {x}) ` H" and 1: "y_x = yh_x \<inter> (S \<union> {x})" by blast
    from 0 obtain yh where 2: "yh \<in> H" and 3: "yh_x = yh \<union> {x}" by blast
    from 1 3 have "y_x = (yh \<inter> S) \<union> {x}" by simp
    with 2 show "y_x \<in> insert x ` (H \<inter>* S)" by blast
  qed
qed

subsection \<open>Definition of @{term shatters}, @{term VC_dim} and @{term shattered_by}\<close>

abbreviation shatters :: "'a set set \<Rightarrow> 'a set \<Rightarrow> bool" (infixl "shatters" 70)
  where "H shatters A \<equiv> H \<inter>* A = Pow A"

definition VC_dim :: "'a set set \<Rightarrow> nat"
  where "VC_dim F = Sup {card S | S. F shatters S}"

definition shattered_by :: "'a set set \<Rightarrow> 'a set set"
  where "shattered_by F \<equiv> {A. F shatters A}"

lemma shattered_by_in_Pow:
  shows "shattered_by F \<subseteq> Pow (\<Union> F)"
  unfolding shattered_by_def by blast

lemma subset_shatters:
  assumes "A \<subseteq> B" and "A shatters X"
  shows "B shatters X"
proof -
  from assms(1) have "A \<inter>* X \<subseteq> B \<inter>* X" by blast
  with assms(2) have "Pow X \<subseteq> B \<inter>* X"  by presburger
  thus ?thesis by blast
qed

lemma supset_shatters:
  assumes "Y \<subseteq> X" and "A shatters X"
  shows "A shatters Y"
proof -
  have h: "\<Union>(Pow Y) \<subseteq> Y" by simp
  from assms have 0: "Pow Y \<subseteq> A \<inter>* X" by auto
  from subset_IntF[OF 0, of Y] Int_IntF[of Y X A] idem_IntF[OF h] have "Pow Y \<subseteq> A \<inter>* (X \<inter> Y)" by argo
  with Int_absorb2[OF assms(1)] Int_commute[of X Y] have "Pow Y \<subseteq> A \<inter>* Y" by presburger
  then show ?thesis by fast
qed

lemma shatters_empty:
  assumes "F \<noteq> {}"
  shows "F shatters {}"
using assms by fastforce

lemma subset_shattered_by:
  assumes "A \<subseteq> B"
  shows "shattered_by A \<subseteq> shattered_by B"
unfolding shattered_by_def using subset_shatters[OF assms] by force

lemma finite_shattered_by:
  assumes "finite (\<Union> F)"
  shows "finite (shattered_by F)"
  using assms rev_finite_subset[OF _ shattered_by_in_Pow, of F] by fast

text \<open>The following example shows that requiring finiteness of a family of sets is not enough, to ensure that @{term "shattered_by"} also stays finite.\<close>

lemma "\<exists>F::nat set set. finite F \<and> infinite (shattered_by F)"
proof -
  let ?F = "{odd -` {True}, odd -` {False}}"
  have 0: "finite ?F" by simp

  let ?f = "\<lambda>n::nat. {n}"
  let ?N = "range ?f"
  have "inj (\<lambda>n. {n})" by simp
  with infinite_iff_countable_subset[of ?N] have infinite_N: "infinite ?N" by blast
  have F_shatters_any_singleton: "?F shatters {n::nat}" for n
  proof -
    have Pow_n: "Pow {n} = {{n}, {}}" by blast
    have 1: "Pow {n} \<subseteq> ?F \<inter>* {n}"
    proof (cases "odd n")
      case True
      from True have "(odd -` {False}) \<inter> {n} = {}" by blast
      hence 0: "{} \<in> ?F \<inter>* {n}"  by blast
      from True have "(odd -` {True}) \<inter> {n} = {n}" by blast
      hence 1: "{n} \<in> ?F \<inter>* {n}"  by blast
      from 0 1 Pow_n show ?thesis by simp
    next
      case False
      from False have "(odd -` {True}) \<inter> {n} = {}" by blast
      hence 0: "{} \<in> ?F \<inter>* {n}" by blast
      from False have "(odd -` {False}) \<inter> {n} = {n}" by blast
      hence 1: "{n} \<in> ?F \<inter>* {n}" by blast
      from 0 1 Pow_n show ?thesis by simp
    qed
    thus ?thesis by fastforce
  qed
  then have "?N \<subseteq> shattered_by ?F" unfolding shattered_by_def by force
  from 0 infinite_super[OF this infinite_N] show ?thesis by blast
qed

end