theory Rose_Tree
imports Main "HOL-Library.Sublist"
begin

text \<open>For theory \<open>Incredible_Trees\<close> we need rose trees; this theory contains
the generally useful part of that development.\<close>

subsubsection \<open>The rose tree data type\<close>

datatype 'a rose_tree = RNode (root: 'a) (children:  "'a rose_tree list")

subsubsection \<open>The set of paths in a rose tree\<close>

text \<open>Too bad that @{command inductive_set} does not allow for varying parameters...\<close>

inductive it_pathsP :: "'a rose_tree \<Rightarrow> nat list \<Rightarrow> bool"  where
   it_paths_Nil: "it_pathsP t []"
 | it_paths_Cons: "i < length (children t) \<Longrightarrow> children t ! i = t' \<Longrightarrow> it_pathsP t' is \<Longrightarrow> it_pathsP t (i#is)"

inductive_cases it_pathP_ConsE: "it_pathsP t (i#is)"

inductive_cases it_pathP_RNodeE: "it_pathsP (RNode r ants) is"

definition it_paths:: "'a rose_tree \<Rightarrow> nat list set"  where
  "it_paths t = Collect (it_pathsP t)"

lemma it_paths_eq [pred_set_conv]: "it_pathsP t = (\<lambda>x. x \<in> it_paths t)"
 by(simp add: it_paths_def)

lemmas it_paths_intros [intro?] = it_pathsP.intros[to_set]
lemmas it_paths_induct [consumes 1, induct set: it_paths] = it_pathsP.induct[to_set]
lemmas it_paths_cases [consumes 1, cases set: it_paths] = it_pathsP.cases[to_set]
lemmas it_paths_ConsE = it_pathP_ConsE[to_set]
lemmas it_paths_RNodeE = it_pathP_RNodeE[to_set]
lemmas it_paths_simps = it_pathsP.simps[to_set]

lemmas it_paths_intros(1)[simp]

lemma it_paths_Union: "it_paths t \<subseteq> insert [] (Union (((\<lambda> (i,t). ((#) i) ` it_paths t) ` set (List.enumerate (0::nat) (children t)))))"
  apply (rule)
  apply (erule it_paths_cases)
  apply (auto intro!: bexI simp add: in_set_enumerate_eq)
  done

lemma finite_it_paths[simp]: "finite (it_paths t)"
  by (induction t) (auto intro!:  finite_subset[OF it_paths_Union]  simp add: in_set_enumerate_eq)

subsubsection \<open>Indexing into a rose tree\<close>

fun tree_at :: "'a rose_tree \<Rightarrow> nat list \<Rightarrow> 'a rose_tree" where
  "tree_at t [] = t"
| "tree_at t (i#is) = tree_at (children t ! i) is"

lemma it_paths_SnocE[elim_format]:
  assumes "is @ [i] \<in> it_paths t"
  shows "is \<in> it_paths t \<and> i < length (children (tree_at t is))"
using assms
by (induction "is" arbitrary: t)(auto intro!: it_paths_intros elim!: it_paths_ConsE)

lemma it_paths_strict_prefix:
  assumes "is \<in> it_paths t"
  assumes "strict_prefix is' is"
  shows "is' \<in> it_paths t"
proof-
  from assms(2)
  obtain is'' where "is = is' @ is''" using strict_prefixE' by blast
  from assms(1)[unfolded this]
  show ?thesis
    by(induction is' arbitrary: t) (auto elim!: it_paths_ConsE intro!: it_paths_intros)
qed

lemma it_paths_prefix:
  assumes "is \<in> it_paths t"
  assumes "prefix is' is"
  shows "is' \<in> it_paths t"
using assms it_paths_strict_prefix strict_prefixI by fastforce

lemma it_paths_butlast:
  assumes "is \<in> it_paths t"
  shows "butlast is \<in> it_paths t"
using assms prefixeq_butlast by (rule it_paths_prefix)

lemma it_path_SnocI:
  assumes "is \<in> it_paths t"
  assumes "i < length (children (tree_at t is))"
  shows "is @ [i] \<in> it_paths t"
  using assms
  by (induction t arbitrary: "is" i)
     (auto 4 4  elim!: it_paths_RNodeE intro: it_paths_intros)

end


theory MoreLogic
imports Main Prop
begin

section {* MoreLogic *}
subsection {* Existential Quantification *}

inductive ex :: "('a \<Rightarrow> bool) \<Rightarrow> bool" for P :: "'a \<Rightarrow> bool" where
  ex_intro: "P witness \<Longrightarrow> ex P"

(*
Notation "'exists' x , p" := (ex (fun x \<Rightarrow> p))
  (at level 200, x ident, right associativity) : type_scope.
*)

lemma exists_example_1: "ex (\<lambda>n :: nat. n + (n * n) = 6)"
apply (rule ex_intro [of _ 2]) by simp

theorem exists_example_2: "ex (\<lambda>m. n = 4 + m) \<Longrightarrow> ex (\<lambda>l. n = 2 + l)"
proof (erule ex.inducts)
  fix witness assume "n = 4 + witness"
  thus "ex (\<lambda>l. n = 2 + l)"
    apply (rule_tac ex_intro [of _ "2 + witness"]) by simp
qed

lemma exists_example_3: "ex (\<lambda>n :: nat. even n & beautiful n)"
apply (rule ex_intro [of _ 8]) by (simp add: eight_is_beautiful)

(* Exercise: 1 star, optional (english_exists) *)
(* Exercise: 1 star (dist_not_exists) *)
theorem dist_not_exists: "(\<forall>x. P x) \<Longrightarrow> \<not> (ex (\<lambda>x. \<not> P x))"
by (auto, simp add: ex.simps)

(* Exercise: 3 stars, optional (not_exists_dist) *)
abbreviation "excluded_middle P \<equiv> \<forall>x. P x \<or> \<not> P x"

theorem not_exists_dist: "excluded_middle P \<Longrightarrow> \<not> (ex (\<lambda>x. \<not> P x)) \<longrightarrow> (\<forall>x. P x)"
by (auto, simp add: ex.simps)

(* Exercise: 2 stars (dist_exists_or) *)
theorem dist_exists_or: "ex (\<lambda>x. P x \<or> Q x) \<longleftrightarrow> ex (\<lambda>x. P x) \<or> ex (\<lambda>x. Q x)"
by (auto simp add: ex.simps)

subsection {* Evidence-carrying booleans. *}

inductive sumbool where
  left: "A \<Longrightarrow> sumbool A _"
  | right: "B \<Longrightarrow> sumbool _ B"

notation
  sumbool ("{_} \<bar> {_}")

theorem eq_nat_dec: "\<And>n :: nat. {n = m} \<bar> {n \<noteq> m}"
apply (induct m)
  apply (case_tac n)
    apply (rule left, simp)
    apply (rule right, simp)
  apply (case_tac n)
    apply (rule right, simp)
    apply (simp)
done

(* In Isabelle, we only use the boolean type to decide whether a prop is true or not *)
fun eq_nat_dec where
  "eq_nat_dec n m = (n = m)"

fun override' where
  "override' f k x = (\<lambda>(k' :: nat). if eq_nat_dec k k' then x else f k')"

theorem override_same': "f k1 = x1 \<Longrightarrow> (override' f k1 x1) k2 = f k2"
by auto

(* Exercise: 1 star (override_shadow') *)
theorem override_shadow': "override' (override' f k1 x2) k1 x1 k2 = (override' f k1 x1 k2)"
by simp

subsection {* Additional Exercises *}

(* Exercise: 3 stars (all_forallb) *)
inductive all for P where
  all_nil: "all P []"
  | all_cons: "\<lbrakk> all P xs; P x \<rbrakk> \<Longrightarrow> all P (x # xs)"

fun forallb :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "forallb test [] = True"
  | "forallb test (x # xs) = (test x \<and> forallb test xs)"

theorem forallb_all: "forallb test xs \<longleftrightarrow> all test xs"
apply (auto)
  apply (induct xs, rule, simp, rule all_cons, simp, simp)
  apply (erule all.inducts, simp, simp)
done

(* Exercise: 4 stars, advanced (filter_challenge) *)
inductive in_order_merge :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  in_order_xs_nil: "in_order_merge [] [] []"
  | in_order_cons_r: "in_order_merge xs ys zs \<Longrightarrow> in_order_merge xs (x # ys) (x # zs)"
  | in_order_cons_l: "in_order_merge xs ys zs \<Longrightarrow> in_order_merge (x # xs) ys (x # zs)"

lemma in_order_merge_ex1: "in_order_merge [1,6,2] [4,3] [1,4,6,2,3]"
by (rule+)

theorem filter_challenge:
  "\<And>l1 l2. \<lbrakk> in_order_merge l1 l2 l; forallb test l1; forallb (\<lambda>x. \<not> test x) l2 \<rbrakk> \<Longrightarrow> filter test l = l1"
apply (induct l, simp)
  apply (erule in_order_merge.cases, simp, simp, simp)
  apply (erule in_order_merge.cases, simp, simp, simp)
done

(* Exercise: 5 stars, advanced, optional (filter_challenge_2) *)
lemma forallt_filter: "forallb test m \<Longrightarrow> filter test m = m"
by (induct m, auto)

lemma subseq_length: "m {subseq of} l \<Longrightarrow> length m \<le> length l"
by (erule subseq.induct, simp, simp, simp)

lemma subseq_filter: "m {subseq of} l \<Longrightarrow> (filter test m) {subseq of} (filter test l)"
apply (erule subseq.induct, simp, rule subseq_nil)
apply (simp add: subseq_cons)
apply (simp add: subseq_cons_both)
done

theorem filter_challenge_2 : "m {subseq of} l \<Longrightarrow> forallb test m \<Longrightarrow> length m \<le> length (filter test l)"
proof -
  assume "m {subseq of} l" "forallb test m"
  have "(filter test m) {subseq of} (filter test l)" by (rule subseq_filter, simp add: `m {subseq of} l`)
  hence "m {subseq of} (filter test l)" by (simp add: `forallb test m` forallt_filter)
  thus "length m \<le> length (filter test l)" by (rule subseq_length)
qed

(* Exercise: 4 stars, advanced (no_repeats) *)
inductive appears_in where
  ai_here: "appears_in a (a # l)"
  | ai_later: "appears_in a l \<Longrightarrow> appears_in a (b # l)"

lemma appears_in_app: "\<And>ys. appears_in x (xs @ ys) \<Longrightarrow> appears_in x xs \<or> appears_in x ys"
apply (induct xs, simp, simp)
apply (erule appears_in.cases)
proof (simp add: ai_here, simp)
  fix a :: "'a" and xs :: "'a list" and ys aa l b
  assume hyp: "(\<And>ys. appears_in aa (xs @ ys) \<Longrightarrow> appears_in aa xs \<or> appears_in aa ys)"
  and assms: "a = b \<and> xs @ ys = l" "appears_in aa l"
  have "appears_in aa xs \<or> appears_in aa ys"
    by (rule hyp, simp add: assms)
  thus "appears_in aa (b # xs) \<or> appears_in aa ys"
    using ai_later [of aa xs b] by auto
qed

lemma ai_later_app: "appears_in x xs \<Longrightarrow> appears_in x (ys @ xs)"
by (induct ys, simp, simp, rule, simp)

lemma app_appears_in: "appears_in x xs \<or> appears_in x ys \<Longrightarrow> appears_in x (xs @ ys)"
apply auto
apply (erule appears_in.inducts, simp add: ai_here, simp add: ai_later)
apply (simp add: ai_later_app)
done

fun disjoint where
  "disjoint l1 l2 = (\<forall>x. appears_in x l1 \<longrightarrow> \<not> appears_in x l2)"

inductive no_repeat where
  no_repeat_nil: "no_repeat []"
  | no_repeat_cons: "\<lbrakk> no_repeat l; \<not> appears_in x l \<rbrakk> \<Longrightarrow> no_repeat (x # l)"

theorem no_repeat_disjoint_app: "\<lbrakk> no_repeat xs; no_repeat ys; disjoint xs ys \<rbrakk> \<Longrightarrow> no_repeat (xs @ ys)"
apply (induct xs, simp, simp)
by (metis ai_here ai_later appears_in_app list.distinct(1) list.sel(1) list.sel(3) no_repeat.simps)

(* Exercise: 3 stars (nostutter) *)
inductive nostutter where
  nostutter_nil: "nostutter []"
  | nostutter_singleton: "nostutter [x]"
  | nostutter_cons: "\<lbrakk> nostutter (x # xs); x \<noteq> y \<rbrakk> \<Longrightarrow> nostutter (y # x # xs)"

lemma test_nostutter_1: "nostutter [(3::nat),1,4,1,5,6]"
apply rule+ by auto

lemma test_nostutter_2: "nostutter []" by rule
lemma test_nostutter_3: "nostutter [5]" by rule

lemma test_nostutter_4: "\<not> (nostutter [3 :: nat,1,1,4])"
by (rule, erule nostutter.cases, auto, erule nostutter.cases, auto)

(* Exercise: 4 stars, advanced (pigeonhole principle) *)
lemma app_length: "length (l1 @ l2) = length l1 + length l2" by simp

lemma appears_in_app_split: "appears_in x l \<Longrightarrow> \<exists>l1. \<exists>l2. l = l1 @ (x # l2)"
apply (induct l)
  apply (erule appears_in.cases, simp, simp)
  apply (erule appears_in.cases, auto)
proof -
  fix b l1 l2
  show "\<exists>l1a l2a. b # l1 @ x # l2 = l1a @ x # l2a"
    using exI [of _ "b # l1"] exI [of _ l2] by simp
qed

inductive repeats where
  repeats_appear: "appears_in x xs \<Longrightarrow> repeats (x # xs)"
  | repeats_cons: "repeats xs \<Longrightarrow> repeats (x # xs)"

(*
theorem pigeonhole_principle: "\<And>l2. (\<And>x. appears_in x l1 \<Longrightarrow> appears_in x l2) \<Longrightarrow> length l2 < length l1 \<Longrightarrow> repeats l1"
sorry
*)

(*
using excluded_middle, induction by l1 ?
*)

end


(*  Title:      HOL/ex/LocaleTest2.thy
    Author:     Clemens Ballarin
    Copyright (c) 2007 by Clemens Ballarin

More regression tests for locales.
Definitions are less natural in FOL, since there is no selection operator.
Hence we do them here in HOL, not in the main test suite for locales,
which is FOL/ex/LocaleTest.thy
*)

section \<open>Test of Locale Interpretation\<close>

theory LocaleTest2
imports Main
begin

section \<open>Interpretation of Defined Concepts\<close>

text \<open>Naming convention for global objects: prefixes D and d\<close>

subsection \<open>Lattices\<close>

text \<open>Much of the lattice proofs are from HOL/Lattice.\<close>

subsubsection \<open>Definitions\<close>

locale dpo =
  fixes le :: "['a, 'a] => bool" (infixl "\<sqsubseteq>" 50)
  assumes refl [intro, simp]: "x \<sqsubseteq> x"
    and antisym [intro]: "[| x \<sqsubseteq> y; y \<sqsubseteq> x |] ==> x = y"
    and trans [trans]: "[| x \<sqsubseteq> y; y \<sqsubseteq> z |] ==> x \<sqsubseteq> z"

begin

theorem circular:
  "[| x \<sqsubseteq> y; y \<sqsubseteq> z; z \<sqsubseteq> x |] ==> x = y & y = z"
  by (blast intro: trans)

definition
  less :: "['a, 'a] => bool" (infixl "\<sqsubset>" 50)
  where "(x \<sqsubset> y) = (x \<sqsubseteq> y & x ~= y)"

theorem abs_test:
  "(\<sqsubset>) = (\<lambda>x y. x \<sqsubset> y)"
  by simp

definition
  is_inf :: "['a, 'a, 'a] => bool"
  where "is_inf x y i = (i \<sqsubseteq> x \<and> i \<sqsubseteq> y \<and> (\<forall>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> i))"

definition
  is_sup :: "['a, 'a, 'a] => bool"
  where "is_sup x y s = (x \<sqsubseteq> s \<and> y \<sqsubseteq> s \<and> (\<forall>z. x \<sqsubseteq> z \<and> y \<sqsubseteq> z \<longrightarrow> s \<sqsubseteq> z))"

end

locale dlat = dpo +
  assumes ex_inf: "\<exists>inf. dpo.is_inf le x y inf"
    and ex_sup: "\<exists>sup. dpo.is_sup le x y sup"

begin

definition
  meet :: "['a, 'a] => 'a" (infixl "\<sqinter>" 70)
  where "x \<sqinter> y = (THE inf. is_inf x y inf)"

definition
  join :: "['a, 'a] => 'a" (infixl "\<squnion>" 65)
  where "x \<squnion> y = (THE sup. is_sup x y sup)"

lemma is_infI [intro?]: "i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow>
    (\<And>z. z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i) \<Longrightarrow> is_inf x y i"
  by (unfold is_inf_def) blast

lemma is_inf_lower [elim?]:
  "is_inf x y i \<Longrightarrow> (i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow> C) \<Longrightarrow> C"
  by (unfold is_inf_def) blast

lemma is_inf_greatest [elim?]:
    "is_inf x y i \<Longrightarrow> z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i"
  by (unfold is_inf_def) blast

theorem is_inf_uniq: "is_inf x y i \<Longrightarrow> is_inf x y i' \<Longrightarrow> i = i'"
proof -
  assume inf: "is_inf x y i"
  assume inf': "is_inf x y i'"
  show ?thesis
  proof (rule antisym)
    from inf' show "i \<sqsubseteq> i'"
    proof (rule is_inf_greatest)
      from inf show "i \<sqsubseteq> x" ..
      from inf show "i \<sqsubseteq> y" ..
    qed
    from inf show "i' \<sqsubseteq> i"
    proof (rule is_inf_greatest)
      from inf' show "i' \<sqsubseteq> x" ..
      from inf' show "i' \<sqsubseteq> y" ..
    qed
  qed
qed

theorem is_inf_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> is_inf x y x"
proof -
  assume "x \<sqsubseteq> y"
  show ?thesis
  proof
    show "x \<sqsubseteq> x" ..
    show "x \<sqsubseteq> y" by fact
    fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y" show "z \<sqsubseteq> x" by fact
  qed
qed

lemma meet_equality [elim?]: "is_inf x y i \<Longrightarrow> x \<sqinter> y = i"
proof (unfold meet_def)
  assume "is_inf x y i"
  then show "(THE i. is_inf x y i) = i"
    by (rule the_equality) (rule is_inf_uniq [OF _ \<open>is_inf x y i\<close>])
qed

lemma meetI [intro?]:
    "i \<sqsubseteq> x \<Longrightarrow> i \<sqsubseteq> y \<Longrightarrow> (\<And>z. z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> i) \<Longrightarrow> x \<sqinter> y = i"
  by (rule meet_equality, rule is_infI) blast+

lemma is_inf_meet [intro?]: "is_inf x y (x \<sqinter> y)"
proof (unfold meet_def)
  from ex_inf obtain i where "is_inf x y i" ..
  then show "is_inf x y (THE i. is_inf x y i)"
    by (rule theI) (rule is_inf_uniq [OF _ \<open>is_inf x y i\<close>])
qed

lemma meet_left [intro?]:
  "x \<sqinter> y \<sqsubseteq> x"
  by (rule is_inf_lower) (rule is_inf_meet)

lemma meet_right [intro?]:
  "x \<sqinter> y \<sqsubseteq> y"
  by (rule is_inf_lower) (rule is_inf_meet)

lemma meet_le [intro?]:
  "[| z \<sqsubseteq> x; z \<sqsubseteq> y |] ==> z \<sqsubseteq> x \<sqinter> y"
  by (rule is_inf_greatest) (rule is_inf_meet)

lemma is_supI [intro?]: "x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow>
    (\<And>z. x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z) \<Longrightarrow> is_sup x y s"
  by (unfold is_sup_def) blast

lemma is_sup_least [elim?]:
    "is_sup x y s \<Longrightarrow> x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z"
  by (unfold is_sup_def) blast

lemma is_sup_upper [elim?]:
    "is_sup x y s \<Longrightarrow> (x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow> C) \<Longrightarrow> C"
  by (unfold is_sup_def) blast

theorem is_sup_uniq: "is_sup x y s \<Longrightarrow> is_sup x y s' \<Longrightarrow> s = s'"
proof -
  assume sup: "is_sup x y s"
  assume sup': "is_sup x y s'"
  show ?thesis
  proof (rule antisym)
    from sup show "s \<sqsubseteq> s'"
    proof (rule is_sup_least)
      from sup' show "x \<sqsubseteq> s'" ..
      from sup' show "y \<sqsubseteq> s'" ..
    qed
    from sup' show "s' \<sqsubseteq> s"
    proof (rule is_sup_least)
      from sup show "x \<sqsubseteq> s" ..
      from sup show "y \<sqsubseteq> s" ..
    qed
  qed
qed

theorem is_sup_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> is_sup x y y"
proof -
  assume "x \<sqsubseteq> y"
  show ?thesis
  proof
    show "x \<sqsubseteq> y" by fact
    show "y \<sqsubseteq> y" ..
    fix z assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
    show "y \<sqsubseteq> z" by fact
  qed
qed

lemma join_equality [elim?]: "is_sup x y s \<Longrightarrow> x \<squnion> y = s"
proof (unfold join_def)
  assume "is_sup x y s"
  then show "(THE s. is_sup x y s) = s"
    by (rule the_equality) (rule is_sup_uniq [OF _ \<open>is_sup x y s\<close>])
qed

lemma joinI [intro?]: "x \<sqsubseteq> s \<Longrightarrow> y \<sqsubseteq> s \<Longrightarrow>
    (\<And>z. x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> s \<sqsubseteq> z) \<Longrightarrow> x \<squnion> y = s"
  by (rule join_equality, rule is_supI) blast+

lemma is_sup_join [intro?]: "is_sup x y (x \<squnion> y)"
proof (unfold join_def)
  from ex_sup obtain s where "is_sup x y s" ..
  then show "is_sup x y (THE s. is_sup x y s)"
    by (rule theI) (rule is_sup_uniq [OF _ \<open>is_sup x y s\<close>])
qed

lemma join_left [intro?]:
  "x \<sqsubseteq> x \<squnion> y"
  by (rule is_sup_upper) (rule is_sup_join)

lemma join_right [intro?]:
  "y \<sqsubseteq> x \<squnion> y"
  by (rule is_sup_upper) (rule is_sup_join)

lemma join_le [intro?]:
  "[| x \<sqsubseteq> z; y \<sqsubseteq> z |] ==> x \<squnion> y \<sqsubseteq> z"
  by (rule is_sup_least) (rule is_sup_join)

theorem meet_assoc: "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
proof (rule meetI)
  show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> x \<sqinter> y"
  proof
    show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> x" ..
    show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y"
    proof -
      have "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y \<sqinter> z" ..
      also have "\<dots> \<sqsubseteq> y" ..
      finally show ?thesis .
    qed
  qed
  show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> z"
  proof -
    have "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> y \<sqinter> z" ..
    also have "\<dots> \<sqsubseteq> z" ..
    finally show ?thesis .
  qed
  fix w assume "w \<sqsubseteq> x \<sqinter> y" and "w \<sqsubseteq> z"
  show "w \<sqsubseteq> x \<sqinter> (y \<sqinter> z)"
  proof
    show "w \<sqsubseteq> x"
    proof -
      have "w \<sqsubseteq> x \<sqinter> y" by fact
      also have "\<dots> \<sqsubseteq> x" ..
      finally show ?thesis .
    qed
    show "w \<sqsubseteq> y \<sqinter> z"
    proof
      show "w \<sqsubseteq> y"
      proof -
        have "w \<sqsubseteq> x \<sqinter> y" by fact
        also have "\<dots> \<sqsubseteq> y" ..
        finally show ?thesis .
      qed
      show "w \<sqsubseteq> z" by fact
    qed
  qed
qed

theorem meet_commute: "x \<sqinter> y = y \<sqinter> x"
proof (rule meetI)
  show "y \<sqinter> x \<sqsubseteq> x" ..
  show "y \<sqinter> x \<sqsubseteq> y" ..
  fix z assume "z \<sqsubseteq> y" and "z \<sqsubseteq> x"
  then show "z \<sqsubseteq> y \<sqinter> x" ..
qed

theorem meet_join_absorb: "x \<sqinter> (x \<squnion> y) = x"
proof (rule meetI)
  show "x \<sqsubseteq> x" ..
  show "x \<sqsubseteq> x \<squnion> y" ..
  fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> x \<squnion> y"
  show "z \<sqsubseteq> x" by fact
qed

theorem join_assoc: "(x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
proof (rule joinI)
  show "x \<squnion> y \<sqsubseteq> x \<squnion> (y \<squnion> z)"
  proof
    show "x \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
    show "y \<sqsubseteq> x \<squnion> (y \<squnion> z)"
    proof -
      have "y \<sqsubseteq> y \<squnion> z" ..
      also have "... \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
      finally show ?thesis .
    qed
  qed
  show "z \<sqsubseteq> x \<squnion> (y \<squnion> z)"
  proof -
    have "z \<sqsubseteq> y \<squnion> z"  ..
    also have "... \<sqsubseteq> x \<squnion> (y \<squnion> z)" ..
    finally show ?thesis .
  qed
  fix w assume "x \<squnion> y \<sqsubseteq> w" and "z \<sqsubseteq> w"
  show "x \<squnion> (y \<squnion> z) \<sqsubseteq> w"
  proof
    show "x \<sqsubseteq> w"
    proof -
      have "x \<sqsubseteq> x \<squnion> y" ..
      also have "\<dots> \<sqsubseteq> w" by fact
      finally show ?thesis .
    qed
    show "y \<squnion> z \<sqsubseteq> w"
    proof
      show "y \<sqsubseteq> w"
      proof -
        have "y \<sqsubseteq> x \<squnion> y" ..
        also have "... \<sqsubseteq> w" by fact
        finally show ?thesis .
      qed
      show "z \<sqsubseteq> w" by fact
    qed
  qed
qed

theorem join_commute: "x \<squnion> y = y \<squnion> x"
proof (rule joinI)
  show "x \<sqsubseteq> y \<squnion> x" ..
  show "y \<sqsubseteq> y \<squnion> x" ..
  fix z assume "y \<sqsubseteq> z" and "x \<sqsubseteq> z"
  then show "y \<squnion> x \<sqsubseteq> z" ..
qed

theorem join_meet_absorb: "x \<squnion> (x \<sqinter> y) = x"
proof (rule joinI)
  show "x \<sqsubseteq> x" ..
  show "x \<sqinter> y \<sqsubseteq> x" ..
  fix z assume "x \<sqsubseteq> z" and "x \<sqinter> y \<sqsubseteq> z"
  show "x \<sqsubseteq> z" by fact
qed

theorem meet_idem: "x \<sqinter> x = x"
proof -
  have "x \<sqinter> (x \<squnion> (x \<sqinter> x)) = x" by (rule meet_join_absorb)
  also have "x \<squnion> (x \<sqinter> x) = x" by (rule join_meet_absorb)
  finally show ?thesis .
qed

theorem meet_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> x \<sqinter> y = x"
proof (rule meetI)
  assume "x \<sqsubseteq> y"
  show "x \<sqsubseteq> x" ..
  show "x \<sqsubseteq> y" by fact
  fix z assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y"
  show "z \<sqsubseteq> x" by fact
qed

theorem meet_related2 [elim?]: "y \<sqsubseteq> x \<Longrightarrow> x \<sqinter> y = y"
  by (drule meet_related) (simp add: meet_commute)

theorem join_related [elim?]: "x \<sqsubseteq> y \<Longrightarrow> x \<squnion> y = y"
proof (rule joinI)
  assume "x \<sqsubseteq> y"
  show "y \<sqsubseteq> y" ..
  show "x \<sqsubseteq> y" by fact
  fix z assume "x \<sqsubseteq> z" and "y \<sqsubseteq> z"
  show "y \<sqsubseteq> z" by fact
qed

theorem join_related2 [elim?]: "y \<sqsubseteq> x \<Longrightarrow> x \<squnion> y = x"
  by (drule join_related) (simp add: join_commute)

text \<open>Additional theorems\<close>

theorem meet_connection: "(x \<sqsubseteq> y) = (x \<sqinter> y = x)"
proof
  assume "x \<sqsubseteq> y"
  then have "is_inf x y x" ..
  then show "x \<sqinter> y = x" ..
next
  have "x \<sqinter> y \<sqsubseteq> y" ..
  also assume "x \<sqinter> y = x"
  finally show "x \<sqsubseteq> y" .
qed

theorem meet_connection2: "(x \<sqsubseteq> y) = (y \<sqinter> x = x)"
  using meet_commute meet_connection by simp

theorem join_connection: "(x \<sqsubseteq> y) = (x \<squnion> y = y)"
proof
  assume "x \<sqsubseteq> y"
  then have "is_sup x y y" ..
  then show "x \<squnion> y = y" ..
next
  have "x \<sqsubseteq> x \<squnion> y" ..
  also assume "x \<squnion> y = y"
  finally show "x \<sqsubseteq> y" .
qed

theorem join_connection2: "(x \<sqsubseteq> y) = (x \<squnion> y = y)"
  using join_commute join_connection by simp

text \<open>Naming according to Jacobson I, p.\ 459.\<close>

lemmas L1 = join_commute meet_commute
lemmas L2 = join_assoc meet_assoc
(*lemmas L3 = join_idem meet_idem*)
lemmas L4 = join_meet_absorb meet_join_absorb

end

locale ddlat = dlat +
  assumes meet_distr:
    "dlat.meet le x (dlat.join le y z) =
    dlat.join le (dlat.meet le x y) (dlat.meet le x z)"

begin

lemma join_distr:
  "x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
  txt \<open>Jacobson I, p.\ 462\<close>
proof -
  have "x \<squnion> (y \<sqinter> z) = (x \<squnion> (x \<sqinter> z)) \<squnion> (y \<sqinter> z)" by (simp add: L4)
  also have "... = x \<squnion> ((x \<sqinter> z) \<squnion> (y \<sqinter> z))" by (simp add: L2)
  also have "... = x \<squnion> ((x \<squnion> y) \<sqinter> z)" by (simp add: L1 meet_distr)
  also have "... = ((x \<squnion> y) \<sqinter> x) \<squnion> ((x \<squnion> y) \<sqinter> z)" by (simp add: L1 L4)
  also have "... = (x \<squnion> y) \<sqinter> (x \<squnion> z)" by (simp add: meet_distr)
  finally show ?thesis .
qed

end

locale dlo = dpo +
  assumes total: "x \<sqsubseteq> y | y \<sqsubseteq> x"

begin

lemma less_total: "x \<sqsubset> y | x = y | y \<sqsubset> x"
  using total
  by (unfold less_def) blast

end

sublocale dlo < dlat
proof
  fix x y
  from total have "is_inf x y (if x \<sqsubseteq> y then x else y)" by (auto simp: is_inf_def)
  then show "\<exists>inf. is_inf x y inf" by blast
next
  fix x y
  from total have "is_sup x y (if x \<sqsubseteq> y then y else x)" by (auto simp: is_sup_def)
  then show "\<exists>sup. is_sup x y sup" by blast
qed

sublocale dlo < ddlat
proof
  fix x y z
  show "x \<sqinter> (y \<squnion> z) = x \<sqinter> y \<squnion> x \<sqinter> z" (is "?l = ?r")
    txt \<open>Jacobson I, p.\ 462\<close>
  proof -
    { assume c: "y \<sqsubseteq> x" "z \<sqsubseteq> x"
      from c have "?l = y \<squnion> z"
        by (metis c (*join_commute*) join_connection2 join_related2 (*meet_commute*) meet_connection meet_related2 total)
      also from c have "... = ?r" by (metis (*c*) (*join_commute*) meet_related2)
      finally have "?l = ?r" . }
    moreover
    { assume c: "x \<sqsubseteq> y | x \<sqsubseteq> z"
      from c have "?l = x"
        by (metis (*antisym*) (*c*) (*circular*) (*join_assoc*)(* join_commute *) join_connection2 (*join_left*) join_related2 meet_connection(* meet_related2*) total trans)
      also from c have "... = ?r"
        by (metis join_commute join_related2 meet_connection meet_related2 total)
      finally have "?l = ?r" . }
    moreover note total
    ultimately show ?thesis by blast
  qed
qed

subsubsection \<open>Total order \<open><=\<close> on \<^typ>\<open>int\<close>\<close>

interpretation int: dpo "(<=) :: [int, int] => bool"
  rewrites "(dpo.less (<=) (x::int) y) = (x < y)"
  txt \<open>We give interpretation for less, but not \<open>is_inf\<close> and \<open>is_sub\<close>.\<close>
proof -
  show "dpo ((<=) :: [int, int] => bool)"
    proof qed auto
  then interpret int: dpo "(<=) :: [int, int] => bool" .
    txt \<open>Gives interpreted version of \<open>less_def\<close> (without condition).\<close>
  show "(dpo.less (<=) (x::int) y) = (x < y)"
    by (unfold int.less_def) auto
qed

thm int.circular
lemma "\<lbrakk> (x::int) \<le> y; y \<le> z; z \<le> x\<rbrakk> \<Longrightarrow> x = y \<and> y = z"
  apply (rule int.circular) apply assumption apply assumption apply assumption done
thm int.abs_test
lemma "((<) :: [int, int] => bool) = (<)"
  apply (rule int.abs_test) done

interpretation int: dlat "(<=) :: [int, int] => bool"
  rewrites meet_eq: "dlat.meet (<=) (x::int) y = min x y"
    and join_eq: "dlat.join (<=) (x::int) y = max x y"
proof -
  show "dlat ((<=) :: [int, int] => bool)"
    apply unfold_locales
    apply (unfold int.is_inf_def int.is_sup_def)
    apply arith+
    done
  then interpret int: dlat "(<=) :: [int, int] => bool" .
  txt \<open>Interpretation to ease use of definitions, which are
    conditional in general but unconditional after interpretation.\<close>
  show "dlat.meet (<=) (x::int) y = min x y"
    apply (unfold int.meet_def)
    apply (rule the_equality)
    apply (unfold int.is_inf_def)
    by auto
  show "dlat.join (<=) (x::int) y = max x y"
    apply (unfold int.join_def)
    apply (rule the_equality)
    apply (unfold int.is_sup_def)
    by auto
qed

interpretation int: dlo "(<=) :: [int, int] => bool"
  proof qed arith

text \<open>Interpreted theorems from the locales, involving defined terms.\<close>

thm int.less_def text \<open>from dpo\<close>
thm int.meet_left text \<open>from dlat\<close>
thm int.meet_distr text \<open>from ddlat\<close>
thm int.less_total text \<open>from dlo\<close>

subsubsection \<open>Total order \<open><=\<close> on \<^typ>\<open>nat\<close>\<close>

interpretation nat: dpo "(<=) :: [nat, nat] => bool"
  rewrites "dpo.less (<=) (x::nat) y = (x < y)"
  txt \<open>We give interpretation for less, but not \<open>is_inf\<close> and \<open>is_sub\<close>.\<close>
proof -
  show "dpo ((<=) :: [nat, nat] => bool)"
    proof qed auto
  then interpret nat: dpo "(<=) :: [nat, nat] => bool" .
    txt \<open>Gives interpreted version of \<open>less_def\<close> (without condition).\<close>
  show "dpo.less (<=) (x::nat) y = (x < y)"
    apply (unfold nat.less_def)
    apply auto
    done
qed

interpretation nat: dlat "(<=) :: [nat, nat] => bool"
  rewrites "dlat.meet (<=) (x::nat) y = min x y"
    and "dlat.join (<=) (x::nat) y = max x y"
proof -
  show "dlat ((<=) :: [nat, nat] => bool)"
    apply unfold_locales
    apply (unfold nat.is_inf_def nat.is_sup_def)
    apply arith+
    done
  then interpret nat: dlat "(<=) :: [nat, nat] => bool" .
  txt \<open>Interpretation to ease use of definitions, which are
    conditional in general but unconditional after interpretation.\<close>
  show "dlat.meet (<=) (x::nat) y = min x y"
    apply (unfold nat.meet_def)
    apply (rule the_equality)
    apply (unfold nat.is_inf_def)
    by auto
  show "dlat.join (<=) (x::nat) y = max x y"
    apply (unfold nat.join_def)
    apply (rule the_equality)
    apply (unfold nat.is_sup_def)
    by auto
qed

interpretation nat: dlo "(<=) :: [nat, nat] => bool"
  proof qed arith

text \<open>Interpreted theorems from the locales, involving defined terms.\<close>

thm nat.less_def text \<open>from dpo\<close>
thm nat.meet_left text \<open>from dlat\<close>
thm nat.meet_distr text \<open>from ddlat\<close>
thm nat.less_total text \<open>from ldo\<close>

subsubsection \<open>Lattice \<open>dvd\<close> on \<^typ>\<open>nat\<close>\<close>

interpretation nat_dvd: dpo "(dvd) :: [nat, nat] => bool"
  rewrites "dpo.less (dvd) (x::nat) y = (x dvd y & x ~= y)"
  txt \<open>We give interpretation for less, but not \<open>is_inf\<close> and \<open>is_sub\<close>.\<close>
proof -
  show "dpo ((dvd) :: [nat, nat] => bool)"
    proof qed (auto simp: dvd_def)
  then interpret nat_dvd: dpo "(dvd) :: [nat, nat] => bool" .
    txt \<open>Gives interpreted version of \<open>less_def\<close> (without condition).\<close>
  show "dpo.less (dvd) (x::nat) y = (x dvd y & x ~= y)"
    apply (unfold nat_dvd.less_def)
    apply auto
    done
qed

interpretation nat_dvd: dlat "(dvd) :: [nat, nat] => bool"
  rewrites "dlat.meet (dvd) (x::nat) y = gcd x y"
    and "dlat.join (dvd) (x::nat) y = lcm x y"
proof -
  show "dlat ((dvd) :: [nat, nat] => bool)"
    apply unfold_locales
    apply (unfold nat_dvd.is_inf_def nat_dvd.is_sup_def)
    apply (rule_tac x = "gcd x y" in exI)
    apply auto [1]
    apply (rule_tac x = "lcm x y" in exI)
    apply (auto intro: dvd_lcm1 dvd_lcm2 lcm_least)
    done
  then interpret nat_dvd: dlat "(dvd) :: [nat, nat] => bool" .
  txt \<open>Interpretation to ease use of definitions, which are
    conditional in general but unconditional after interpretation.\<close>
  show "dlat.meet (dvd) (x::nat) y = gcd x y"
    apply (unfold nat_dvd.meet_def)
    apply (rule the_equality)
    apply (unfold nat_dvd.is_inf_def)
    by auto
  show "dlat.join (dvd) (x::nat) y = lcm x y"
    apply (unfold nat_dvd.join_def)
    apply (rule the_equality)
    apply (unfold nat_dvd.is_sup_def)
    by (auto intro: dvd_lcm1 dvd_lcm2 lcm_least)
qed

text \<open>Interpreted theorems from the locales, involving defined terms.\<close>

thm nat_dvd.less_def text \<open>from dpo\<close>
lemma "((x::nat) dvd y & x ~= y) = (x dvd y & x ~= y)"
  apply (rule nat_dvd.less_def) done
thm nat_dvd.meet_left text \<open>from dlat\<close>
lemma "gcd x y dvd (x::nat)"
  apply (rule nat_dvd.meet_left) done

subsection \<open>Group example with defined operations \<open>inv\<close> and \<open>unit\<close>\<close>

subsubsection \<open>Locale declarations and lemmas\<close>

locale Dsemi =
  fixes prod (infixl "**" 65)
  assumes assoc: "(x ** y) ** z = x ** (y ** z)"

locale Dmonoid = Dsemi +
  fixes one
  assumes l_one [simp]: "one ** x = x"
    and r_one [simp]: "x ** one = x"

begin

definition
  inv where "inv x = (THE y. x ** y = one & y ** x = one)"
definition
  unit where "unit x = (\<exists>y. x ** y = one  & y ** x = one)"

lemma inv_unique:
  assumes eq: "y ** x = one" "x ** y' = one"
  shows "y = y'"
proof -
  from eq have "y = y ** (x ** y')" by (simp add: r_one)
  also have "... = (y ** x) ** y'" by (simp add: assoc)
  also from eq have "... = y'" by (simp add: l_one)
  finally show ?thesis .
qed

lemma unit_one [intro, simp]:
  "unit one"
  by (unfold unit_def) auto

lemma unit_l_inv_ex:
  "unit x ==> \<exists>y. y ** x = one"
  by (unfold unit_def) auto

lemma unit_r_inv_ex:
  "unit x ==> \<exists>y. x ** y = one"
  by (unfold unit_def) auto

lemma unit_l_inv:
  "unit x ==> inv x ** x = one"
  apply (simp add: unit_def inv_def) apply (erule exE)
  apply (rule theI2, fast)
  apply (rule inv_unique)
  apply fast+
  done

lemma unit_r_inv:
  "unit x ==> x ** inv x = one"
  apply (simp add: unit_def inv_def) apply (erule exE)
  apply (rule theI2, fast)
  apply (rule inv_unique)
  apply fast+
  done

lemma unit_inv_unit [intro, simp]:
  "unit x ==> unit (inv x)"
proof -
  assume x: "unit x"
  show "unit (inv x)"
    by (auto simp add: unit_def
      intro: unit_l_inv unit_r_inv x)
qed

lemma unit_l_cancel [simp]:
  "unit x ==> (x ** y = x ** z) = (y = z)"
proof
  assume eq: "x ** y = x ** z"
    and G: "unit x"
  then have "(inv x ** x) ** y = (inv x ** x) ** z"
    by (simp add: assoc)
  with G show "y = z" by (simp add: unit_l_inv)
next
  assume eq: "y = z"
    and G: "unit x"
  then show "x ** y = x ** z" by simp
qed

lemma unit_inv_inv [simp]:
  "unit x ==> inv (inv x) = x"
proof -
  assume x: "unit x"
  then have "inv x ** inv (inv x) = inv x ** x"
    by (simp add: unit_l_inv unit_r_inv)
  with x show ?thesis by simp
qed

lemma inv_inj_on_unit:
  "inj_on inv {x. unit x}"
proof (rule inj_onI, simp)
  fix x y
  assume G: "unit x"  "unit y" and eq: "inv x = inv y"
  then have "inv (inv x) = inv (inv y)" by simp
  with G show "x = y" by simp
qed

lemma unit_inv_comm:
  assumes inv: "x ** y = one"
    and G: "unit x"  "unit y"
  shows "y ** x = one"
proof -
  from G have "x ** y ** x = x ** one" by (auto simp add: inv)
  with G show ?thesis by (simp del: r_one add: assoc)
qed

end

locale Dgrp = Dmonoid +
  assumes unit [intro, simp]: "Dmonoid.unit ((**)) one x"

begin

lemma l_inv_ex [simp]:
  "\<exists>y. y ** x = one"
  using unit_l_inv_ex by simp

lemma r_inv_ex [simp]:
  "\<exists>y. x ** y = one"
  using unit_r_inv_ex by simp

lemma l_inv [simp]:
  "inv x ** x = one"
  using unit_l_inv by simp

lemma l_cancel [simp]:
  "(x ** y = x ** z) = (y = z)"
  using unit_l_inv by simp

lemma r_inv [simp]:
  "x ** inv x = one"
proof -
  have "inv x ** (x ** inv x) = inv x ** one"
    by (simp add: assoc [symmetric] l_inv)
  then show ?thesis by (simp del: r_one)
qed

lemma r_cancel [simp]:
  "(y ** x = z ** x) = (y = z)"
proof
  assume eq: "y ** x = z ** x"
  then have "y ** (x ** inv x) = z ** (x ** inv x)"
    by (simp add: assoc [symmetric] del: r_inv)
  then show "y = z" by simp
qed simp

lemma inv_one [simp]:
  "inv one = one"
proof -
  have "inv one = one ** (inv one)" by (simp del: r_inv)
  moreover have "... = one" by simp
  finally show ?thesis .
qed

lemma inv_inv [simp]:
  "inv (inv x) = x"
  using unit_inv_inv by simp

lemma inv_inj:
  "inj_on inv UNIV"
  using inv_inj_on_unit by simp

lemma inv_mult_group:
  "inv (x ** y) = inv y ** inv x"
proof -
  have "inv (x ** y) ** (x ** y) = (inv y ** inv x) ** (x ** y)"
    by (simp add: assoc l_inv) (simp add: assoc [symmetric])
  then show ?thesis by (simp del: l_inv)
qed

lemma inv_comm:
  "x ** y = one ==> y ** x = one"
  by (rule unit_inv_comm) auto

lemma inv_equality:
     "y ** x = one ==> inv x = y"
  apply (simp add: inv_def)
  apply (rule the_equality)
   apply (simp add: inv_comm [of y x])
  apply (rule r_cancel [THEN iffD1], auto)
  done

end

locale Dhom = prod: Dgrp prod one + sum: Dgrp sum zero
    for prod (infixl "**" 65) and one and sum (infixl "+++" 60) and zero +
  fixes hom
  assumes hom_mult [simp]: "hom (x ** y) = hom x +++ hom y"

begin

lemma hom_one [simp]:
  "hom one = zero"
proof -
  have "hom one +++ zero = hom one +++ hom one"
    by (simp add: hom_mult [symmetric] del: hom_mult)
  then show ?thesis by (simp del: sum.r_one)
qed

end

subsubsection \<open>Interpretation of Functions\<close>

interpretation Dfun: Dmonoid "(o)" "id :: 'a => 'a"
  rewrites "Dmonoid.unit (o) id f = bij (f::'a => 'a)"
(*    and "Dmonoid.inv (o) id" = "inv :: ('a => 'a) => ('a => 'a)" *)
proof -
  show "Dmonoid (o) (id :: 'a => 'a)" proof qed (simp_all add: o_assoc)
  note Dmonoid = this
(*
  from this interpret Dmonoid "(o)" "id :: 'a => 'a" .
*)
  show "Dmonoid.unit (o) (id :: 'a => 'a) f = bij f"
    apply (unfold Dmonoid.unit_def [OF Dmonoid])
    apply rule apply clarify
  proof -
    fix f g
    assume id1: "f o g = id" and id2: "g o f = id"
    show "bij f"
    proof (rule bijI)
      show "inj f"
      proof (rule inj_onI)
        fix x y
        assume "f x = f y"
        then have "(g o f) x = (g o f) y" by simp
        with id2 show "x = y" by simp
      qed
    next
      show "surj f"
      proof (rule surjI)
        fix x
        from id1 have "(f o g) x = x" by simp
        then show "f (g x) = x" by simp
      qed
    qed
  next
    fix f
    assume bij: "bij f"
    then
    have inv: "f o Hilbert_Choice.inv f = id & Hilbert_Choice.inv f o f = id"
      by (simp add: bij_def surj_iff inj_iff)
    show "\<exists>g. f \<circ> g = id \<and> g \<circ> f = id" by rule (rule inv)
  qed
qed

thm Dmonoid.unit_def Dfun.unit_def

thm Dmonoid.inv_inj_on_unit Dfun.inv_inj_on_unit

lemma unit_id:
  "(f :: unit => unit) = id"
  by rule simp

interpretation Dfun: Dgrp "(o)" "id :: unit => unit"
  rewrites "Dmonoid.inv (o) id f = inv (f :: unit => unit)"
proof -
  have "Dmonoid (o) (id :: 'a => 'a)" ..
  note Dmonoid = this

  show "Dgrp (o) (id :: unit => unit)"
apply unfold_locales
apply (unfold Dmonoid.unit_def [OF Dmonoid])
apply (insert unit_id)
apply simp
done
  show "Dmonoid.inv (o) id f = inv (f :: unit \<Rightarrow> unit)"
apply (unfold Dmonoid.inv_def [OF Dmonoid])
apply (insert unit_id)
apply simp
apply (rule the_equality)
apply rule
apply rule
apply simp
done
qed

thm Dfun.unit_l_inv Dfun.l_inv

thm Dfun.inv_equality
thm Dfun.inv_equality

end


theory Reg_Exp_Example
imports
  "~~/src/HOL/Library/Predicate_Compile_Quickcheck"
  "~~/src/HOL/Library/Code_Prolog"
begin

text {* An example from the experiments from SmallCheck (@{url "http://www.cs.york.ac.uk/fp/smallcheck/"}) *}
text {* The example (original in Haskell) was imported with Haskabelle and
  manually slightly adapted.
*}

datatype Nat = Zer
             | Suc Nat

fun sub :: "Nat \<Rightarrow> Nat \<Rightarrow> Nat"
where
  "sub x y = (case y of
                 Zer \<Rightarrow> x
               | Suc y' \<Rightarrow> case x of
                                         Zer \<Rightarrow> Zer
                                       | Suc x' \<Rightarrow> sub x' y')"

datatype Sym = N0
             | N1 Sym

datatype RE = Sym Sym
            | Or RE RE
            | Seq RE RE
            | And RE RE
            | Star RE
            | Empty

function accepts :: "RE \<Rightarrow> Sym list \<Rightarrow> bool" and
    seqSplit :: "RE \<Rightarrow> RE \<Rightarrow> Sym list \<Rightarrow> Sym list \<Rightarrow> bool" and
    seqSplit'' :: "RE \<Rightarrow> RE \<Rightarrow> Sym list \<Rightarrow> Sym list \<Rightarrow> bool" and
    seqSplit' :: "RE \<Rightarrow> RE \<Rightarrow> Sym list \<Rightarrow> Sym list \<Rightarrow> bool"
where
  "accepts re ss = (case re of
                       Sym n \<Rightarrow> case ss of
                                              Nil \<Rightarrow> False
                                            | (n' # ss') \<Rightarrow> n = n' & List.null ss'
                     | Or re1 re2 \<Rightarrow> accepts re1 ss | accepts re2 ss
                     | Seq re1 re2 \<Rightarrow> seqSplit re1 re2 Nil ss
                     | And re1 re2 \<Rightarrow> accepts re1 ss & accepts re2 ss
                     | Star re' \<Rightarrow> case ss of
                                                 Nil \<Rightarrow> True
                                               | (s # ss') \<Rightarrow> seqSplit re' re [s] ss'
                     | Empty \<Rightarrow> List.null ss)"
| "seqSplit re1 re2 ss2 ss = (seqSplit'' re1 re2 ss2 ss | seqSplit' re1 re2 ss2 ss)"
| "seqSplit'' re1 re2 ss2 ss = (accepts re1 ss2 & accepts re2 ss)"
| "seqSplit' re1 re2 ss2 ss = (case ss of
                                  Nil \<Rightarrow> False
                                | (n # ss') \<Rightarrow> seqSplit re1 re2 (ss2 @ [n]) ss')"
by pat_completeness auto

termination
  sorry

fun rep :: "Nat \<Rightarrow> RE \<Rightarrow> RE"
where
  "rep n re = (case n of
                  Zer \<Rightarrow> Empty
                | Suc n' \<Rightarrow> Seq re (rep n' re))"

fun repMax :: "Nat \<Rightarrow> RE \<Rightarrow> RE"
where
  "repMax n re = (case n of
                     Zer \<Rightarrow> Empty
                   | Suc n' \<Rightarrow> Or (rep n re) (repMax n' re))"

fun repInt' :: "Nat \<Rightarrow> Nat \<Rightarrow> RE \<Rightarrow> RE"
where
  "repInt' n k re = (case k of
                        Zer \<Rightarrow> rep n re
                      | Suc k' \<Rightarrow> Or (rep n re) (repInt' (Suc n) k' re))"

fun repInt :: "Nat \<Rightarrow> Nat \<Rightarrow> RE \<Rightarrow> RE"
where
  "repInt n k re = repInt' n (sub k n) re"

fun prop_regex :: "Nat * Nat * RE * RE * Sym list \<Rightarrow> bool"
where
  "prop_regex (n, (k, (p, (q, s)))) =
    ((accepts (repInt n k (And p q)) s) = (accepts (And (repInt n k p) (repInt n k q)) s))"

lemma "accepts (repInt n k (And p q)) s --> accepts (And (repInt n k p) (repInt n k q)) s"
(*nitpick
quickcheck[tester = random, iterations = 10000]
quickcheck[tester = predicate_compile_wo_ff]
quickcheck[tester = predicate_compile_ff_fs]*)
oops

setup {*
  Context.theory_map
    (Quickcheck.add_tester ("prolog", (Code_Prolog.active, Code_Prolog.test_goals)))
*}

setup {* Code_Prolog.map_code_options (K
  {ensure_groundness = true,
   limit_globally = NONE,
   limited_types = [(@{typ Sym}, 0), (@{typ "Sym list"}, 2), (@{typ RE}, 6)],
   limited_predicates = [(["repIntPa"], 2), (["repP"], 2), (["subP"], 0),
    (["accepts", "acceptsaux", "seqSplit", "seqSplita", "seqSplitaux", "seqSplitb"], 25)],
   replacing =
     [(("repP", "limited_repP"), "lim_repIntPa"),
      (("subP", "limited_subP"), "repIntP"),
      (("repIntPa", "limited_repIntPa"), "repIntP"),
      (("accepts", "limited_accepts"), "quickcheck")],
   manual_reorder = []}) *}

text {* Finding the counterexample still seems out of reach for the
 prolog-style generation. *}

lemma "accepts (And (repInt n k p) (repInt n k q)) s --> accepts (repInt n k (And p q)) s"
quickcheck[exhaustive]
quickcheck[tester = random, iterations = 1000]
(*quickcheck[tester = predicate_compile_wo_ff]*)
(*quickcheck[tester = predicate_compile_ff_fs, iterations = 1]*)
(*quickcheck[tester = prolog, iterations = 1, size = 1]*)
oops

section {* Given a partial solution *}

lemma
(*  assumes "n = Zer"
  assumes "k = Suc (Suc Zer)"*)
  assumes "p = Sym N0"
  assumes "q = Seq (Sym N0) (Sym N0)"
(*  assumes "s = [N0, N0]"*)
  shows "accepts (And (repInt n k p) (repInt n k q)) s --> accepts (repInt n k (And p q)) s"
(*quickcheck[tester = predicate_compile_wo_ff, iterations = 1]*)
quickcheck[tester = prolog, iterations = 1, size = 1]
oops

section {* Checking the counterexample *}

definition a_sol
where
  "a_sol = (Zer, (Suc (Suc Zer), (Sym N0, (Seq (Sym N0) (Sym N0), [N0, N0]))))"

lemma
  assumes "n = Zer"
  assumes "k = Suc (Suc Zer)"
  assumes "p = Sym N0"
  assumes "q = Seq (Sym N0) (Sym N0)"
  assumes "s = [N0, N0]"
  shows "accepts (repInt n k (And p q)) s --> accepts (And (repInt n k p) (repInt n k q)) s"
(*quickcheck[tester = predicate_compile_wo_ff]*)
oops

lemma
  assumes "n = Zer"
  assumes "k = Suc (Suc Zer)"
  assumes "p = Sym N0"
  assumes "q = Seq (Sym N0) (Sym N0)"
  assumes "s = [N0, N0]"
  shows "accepts (And (repInt n k p) (repInt n k q)) s --> accepts (repInt n k (And p q)) s"
(*quickcheck[tester = predicate_compile_wo_ff, iterations = 1, expect = counterexample]*)
quickcheck[tester = prolog, iterations = 1, size = 1]
oops

lemma
  assumes "n = Zer"
  assumes "k = Suc (Suc Zer)"
  assumes "p = Sym N0"
  assumes "q = Seq (Sym N0) (Sym N0)"
  assumes "s = [N0, N0]"
shows "prop_regex (n, (k, (p, (q, s))))"
quickcheck[tester = smart_exhaustive, depth = 30]
quickcheck[tester = prolog]
oops

lemma "prop_regex a_sol"
quickcheck[tester = random]
quickcheck[tester = smart_exhaustive]
oops

value "prop_regex a_sol"

end


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

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

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

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "((elem x xs) ==> ((isPermutation xs ys) ==> (elem x ys)))"
  oops

end


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

header {* Binary Decision Diagrams *}

(*<*) theory sol 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

  @{text "eval :: (nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bdd \<Rightarrow> bool"}

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

primrec eval :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bdd \<Rightarrow> bool" where
  "eval e i (Leaf x) = x"
| "eval e i (Branch b1 b2) =
     (if e i then eval e (Suc i) b2 else eval e (Suc i) b1)"

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

  @{text "bdd_unop :: (bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd"}\\
  @{text "bdd_binop :: (bool \<Rightarrow> bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd \<Rightarrow> bdd"}

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

primrec bdd_unop :: "(bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd" where
  "bdd_unop f (Leaf x) = Leaf (f x)"
| "bdd_unop f (Branch b1 b2) = Branch (bdd_unop f b1) (bdd_unop f b2)"

primrec bdd_binop :: "(bool \<Rightarrow> bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd \<Rightarrow> bdd" where
  "bdd_binop f (Leaf x) b = bdd_unop (f x) b"
| "bdd_binop f (Branch b1 b2) b = (case b of
       Leaf x \<Rightarrow> Branch (bdd_binop f b1 (Leaf x)) (bdd_binop f b2 (Leaf x))
     | Branch b1' b2' \<Rightarrow> Branch (bdd_binop f b1 b1') (bdd_binop f b2 b2'))"

theorem bdd_unop_correct:
  "\<forall>i. eval e i (bdd_unop f b) = f (eval e i b)"
  apply (induct b)
  apply auto
done

theorem bdd_binop_correct:
  "\<forall>i b2. eval e i (bdd_binop f b1 b2) = f (eval e i b1) (eval e i b2)"
  apply (induct b1)
  apply (auto simp add: bdd_unop_correct)
  apply (case_tac b2)
  apply auto
  apply (case_tac b2)
  apply auto
  apply (case_tac b2)
  apply auto
  apply (case_tac b2)
  apply auto
done

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.
*}

defs
  bdd_and_def: "bdd_and \<equiv> bdd_binop op \<and>"
  bdd_or_def: "bdd_or \<equiv> bdd_binop op \<or>"
  bdd_not_def: "bdd_not \<equiv> bdd_unop Not"
  bdd_xor_def: "bdd_xor b1 b2 == (bdd_or
     (bdd_and (bdd_not b1) b2) (bdd_and b1 (bdd_not b2)))"

theorem bdd_and_correct:
  "eval e i (bdd_and b1 b2) = (eval e i b1 \<and> eval e i b2)"
  apply (auto simp add: bdd_and_def bdd_binop_correct)
done

theorem bdd_or_correct:
  "eval e i (bdd_or b1 b2) = (eval e i b1 \<or> eval e i b2)"
  apply (auto simp add: bdd_or_def bdd_binop_correct)
done

theorem bdd_not_correct: "eval e i (bdd_not b) = (\<not> eval e i b)"
  apply (auto simp add: bdd_not_def bdd_unop_correct)
done

text {*
Finally, define a function

  @{text "bdd_var :: nat \<Rightarrow> bdd"}

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]*}

primrec bdd_var :: "nat \<Rightarrow> bdd" where
  "bdd_var 0 = Branch (Leaf False) (Leaf True)"
| "bdd_var (Suc i) = Branch (bdd_var i) (bdd_var i)"

theorem bdd_var_correct: "\<forall>j. eval e j (bdd_var i) = e (i+j)"
  apply (induct i)
  apply auto
done

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

  @{text "mk_bdd :: form \<Rightarrow> bdd"}

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 (*>*)

primrec mk_bdd :: "form \<Rightarrow> bdd" where
  "mk_bdd T = Leaf True"
| "mk_bdd (Var i) = bdd_var i"
| "mk_bdd (And f1 f2) = bdd_and (mk_bdd f1) (mk_bdd f2)"
| "mk_bdd (Xor f1 f2) = bdd_xor (mk_bdd f1) (mk_bdd f2)"

theorem mk_bdd_correct: "eval e 0 (mk_bdd f) = evalf e f"
  apply (induct f)
  apply (auto simp add: bdd_var_correct
    bdd_and_correct bdd_or_correct bdd_not_correct bdd_xor_def xor_def)
done

(*<*) end (*>*)


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

section \<open>Frontier Algebra\<close>

(**The closure of a set A @{text "\<C>(A)"} can be seen as the set A augmented by (i) its boundary points,
or (ii) its accumulation/limit points. In this section we explore the first variant by drawing on the notion
of a frontier algebra, defined in an analogous fashion as the well-known closure and interior algebras.*)

(**Declares a primitive (unconstrained) frontier (aka. boundary) operation and defines others from it.*)
consts \<F>::"\<sigma>\<Rightarrow>\<sigma>"
abbreviation "\<I> \<equiv> \<I>\<^sub>F \<F>" (**interior*)
abbreviation "\<C> \<equiv> \<C>\<^sub>F \<F>" (**closure*)
abbreviation "\<B> \<equiv> \<B>\<^sub>F \<F>" (**border*)

subsection \<open>Basic properties\<close>

(**Verifies minimal conditions under which operators resulting from conversion functions coincide.*)
lemma ICdual: "Fr_2 \<F> \<Longrightarrow> \<I> \<^bold>\<equiv> \<C>\<^sup>d" by (simp add: Cl_fr_def Fr_2_def Int_fr_def dual_def equal_op_def conn)
lemma ICdual': "Fr_2 \<F> \<Longrightarrow> \<C> \<^bold>\<equiv> \<I>\<^sup>d" by (simp add: Cl_fr_def Fr_2_def Int_fr_def dual_def equal_op_def conn)

(**Fixed-point and other operators are interestingly related.*)
lemma fp1: "\<I>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B>\<^sup>c" using Br_fr_def Int_fr_def unfolding equal_op_def conn by auto
lemma fp2: "\<B>\<^sup>f\<^sup>p \<^bold>\<equiv> \<I>\<^sup>c" using Br_fr_def Int_fr_def unfolding equal_op_def conn by auto
lemma fp3: "Fr_2 \<F> \<Longrightarrow> \<C>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B>\<^sup>d" using Br_fr_def Cl_fr_def Fr_2_def dual_def equal_op_def conn by fastforce
lemma fp4: "Fr_2 \<F> \<Longrightarrow> (\<B>\<^sup>d)\<^sup>f\<^sup>p \<^bold>\<equiv> \<C>" by (smt dimp_def equal_op_def fp3)
lemma fp5: "\<F>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B> \<^bold>\<squnion> (\<C>\<^sup>c)" using Br_fr_def Cl_fr_def unfolding equal_op_def conn by auto

(**Different inter-relations (some redundant ones are kept to help the provers).*)
lemma monI: "Fr_1b \<F> \<Longrightarrow> MONO(\<I>)" by (simp add: IF1a MONO_MULTa)
lemma monC: "Fr_6 \<F> \<Longrightarrow> MONO(\<C>)" by (simp add: Cl_fr_def Fr_6_def MONO_def conn)
lemma pB1: "\<forall>A. \<B> A \<^bold>\<approx> A \<^bold>\<leftharpoonup> \<I> A" using Br_fr_def fp1 unfolding conn equal_op_def by metis
lemma pB2: "\<forall>A. \<B> A \<^bold>\<approx> A \<^bold>\<and> \<F> A" by (simp add: Br_fr_def)
lemma pB3: "Fr_2 \<F> \<Longrightarrow> \<forall>A. \<B>(\<^bold>\<midarrow>A) \<^bold>\<approx> \<^bold>\<midarrow>A \<^bold>\<and> \<F> A" by (simp add: Fr_2_def pB2 conn)
lemma pB4: "Fr_2 \<F> \<Longrightarrow> \<forall>A. \<B>(\<^bold>\<midarrow>A) \<^bold>\<approx> \<^bold>\<midarrow>A \<^bold>\<and> \<C> A" using CB_rel Cl_br_def pB3 unfolding conn equal_op_def by metis
lemma pB5: "Fr_1b \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> \<forall>A. \<B>(\<C> A) \<^bold>\<preceq> (\<B> A) \<^bold>\<or> \<B>(\<^bold>\<midarrow>A)"  by (smt BC_rel Br_cl_def Cl_fr_def Fr_6_def PF6 equal_op_def conn)
lemma pF1: "\<forall>A. \<F> A \<^bold>\<approx> \<C> A \<^bold>\<leftharpoonup> \<I> A"  using Cl_fr_def Int_fr_def conn by auto
lemma pF2: "Fr_2 \<F> \<Longrightarrow> \<forall>A. \<F> A \<^bold>\<approx> \<C> A \<^bold>\<and> \<C>(\<^bold>\<midarrow>A)" using Cl_fr_def Fr_2_def conn by auto
lemma pF3: "Fr_2 \<F> \<Longrightarrow> \<forall>A. \<F> A \<^bold>\<approx> \<B> A \<^bold>\<or> \<B>(\<^bold>\<midarrow>A)" using Br_fr_def Fr_2_def conn by auto
lemma pF4: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4(\<F>) \<Longrightarrow> \<forall>A. \<F>(\<I> A) \<^bold>\<preceq> \<F> A" by (smt IDEMa_def IF2 IF4 Int_fr_def MONO_def PF1 PF6 PI4 diff_def monC pF1)
lemma pF5: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>A. \<F>(\<C> A) \<^bold>\<preceq> \<F> A" by (metis Br_fr_def CF4 Cl_fr_def IDEM_def PF1 join_def meet_def pB5 pF3)
lemma pA1: "\<forall>A. A \<^bold>\<approx> \<I> A \<^bold>\<or> \<B> A" using Br_fr_def Int_fr_def unfolding conn by auto
lemma pA2: "Fr_2 \<F> \<Longrightarrow> \<forall>A. A \<^bold>\<approx> \<C> A \<^bold>\<leftharpoonup> \<B>(\<^bold>\<midarrow>A)" using pB1 dual_def fp3 unfolding equal_op_def conn by smt
lemma pC1: "Fr_2 \<F> \<Longrightarrow> \<forall>A. \<C> A \<^bold>\<approx> A \<^bold>\<or> \<B>(\<^bold>\<midarrow>A)" using Cl_fr_def pB4 conn by auto
lemma pC2: "\<forall>A. \<C> A \<^bold>\<approx> A \<^bold>\<or> \<F> A" using Cl_fr_def by auto
lemma pI1: "\<forall>A. \<I> A \<^bold>\<approx> A \<^bold>\<leftharpoonup> \<B> A" using pA1 pB1 conn by auto
lemma pI2: "\<forall>A. \<I> A \<^bold>\<approx> A \<^bold>\<leftharpoonup> \<F> A" by (simp add: Int_fr_def)

lemma IC_imp: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>A B. \<I>(A \<^bold>\<rightarrow> B) \<^bold>\<preceq> \<C> A \<^bold>\<rightarrow> \<C> B" proof -
  assume fr1: "Fr_1 \<F>" and fr2: "Fr_2 \<F>" and fr3: "Fr_3 \<F>"
  { fix a b
    have "(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>b \<^bold>\<rightarrow> \<^bold>\<midarrow>a = \<^bold>\<top>" unfolding conn by auto
    hence "\<I>((a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>b \<^bold>\<rightarrow> \<^bold>\<midarrow>a) \<^bold>\<approx> \<I>(\<^bold>\<top>)" by simp
    hence "\<I>((a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>b \<^bold>\<rightarrow> \<^bold>\<midarrow>a) \<^bold>\<approx> \<^bold>\<top>" using fr3 IF3 dNOR_def fr2 by auto
    moreover have "let A=(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>b; B=\<^bold>\<midarrow>a in \<I>(A \<^bold>\<rightarrow> B) \<^bold>\<preceq> \<I>(A) \<^bold>\<rightarrow> \<I>(B)" using fr1 IF1 PI7 Int_7_def by metis
    ultimately have "\<I>((a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>b) \<^bold>\<rightarrow> \<I>(\<^bold>\<midarrow>a) \<^bold>\<approx> \<^bold>\<top>" unfolding conn by simp
    moreover have "let A=a \<^bold>\<rightarrow> b; B=\<^bold>\<midarrow>b in \<I>(A \<^bold>\<and> B) \<^bold>\<approx> \<I>(A) \<^bold>\<and> \<I>(B)" using fr1 IF1 MULT_def by simp
    ultimately have "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<I>(\<^bold>\<midarrow>b) \<^bold>\<rightarrow> \<I>(\<^bold>\<midarrow>a) \<^bold>\<approx> \<^bold>\<top>" unfolding conn by simp
    moreover have "\<forall>A. \<I>(\<^bold>\<midarrow>A) \<^bold>\<approx> \<^bold>\<midarrow>\<C>(A)" using Cl_fr_def Fr_2_def Int_fr_def fr2  unfolding conn by auto
    ultimately have "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>\<C>(b) \<^bold>\<rightarrow> \<^bold>\<midarrow>\<C>(a) \<^bold>\<approx> \<^bold>\<top>" unfolding conn by simp
    hence "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<^bold>\<midarrow>\<C>(b) \<^bold>\<preceq> \<^bold>\<midarrow>\<C>(a)" unfolding conn by simp
    hence "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<and> \<C> a \<^bold>\<preceq> \<C> b" unfolding conn by metis
  } thus ?thesis unfolding conn by simp
qed

(**Defines some fixed-point predicates and prove some properties.*)
abbreviation openset ("Op") where "Op A \<equiv> fp \<I> A"
abbreviation closedset ("Cl") where "Cl A \<equiv> fp \<C> A"
abbreviation borderset ("Br") where "Br A \<equiv> fp \<B> A"
abbreviation frontierset ("Fr") where "Fr A \<equiv> fp \<F> A"

lemma Int_Open: "Fr_1a \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>A. Op(\<I> A)" using IF4 IDEM_def by blast
lemma Cl_Closed: "Fr_1a \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>A. Cl(\<C> A)" using CF4 IDEM_def by blast
lemma Br_Border: "Fr_1b \<F> \<Longrightarrow> \<forall>A. Br(\<B> A)" using Br_fr_def Fr_1b_def conn by auto
(**In contrast, there is no analogous fixed-point result for frontier:*)
lemma "\<FF> \<F> \<Longrightarrow> \<forall>A. Fr(\<F> A)" nitpick oops (*counterexample even if assuming all frontier conditions*)

lemma OpCldual: "Fr_2 \<F> \<Longrightarrow> \<forall>A. Cl A \<longleftrightarrow> Op(\<^bold>\<midarrow>A)" using Cl_fr_def Fr_2_def Int_fr_def conn by auto
lemma ClOpdual: "Fr_2 \<F> \<Longrightarrow> \<forall>A. Op A \<longleftrightarrow> Cl(\<^bold>\<midarrow>A)" using ICdual dual_def unfolding equal_op_def conn by auto
lemma Fr_ClBr: "\<forall>A. Fr(A) = (Cl(A) \<and> Br(A))" using Br_fr_def Cl_fr_def join_def meet_def by auto
lemma Cl_F: "Fr_4 \<F> \<Longrightarrow> \<forall>A. Cl(\<F> A)" using Cl_fr_def Fr_4_def conn by auto

subsection \<open>Further properties\<close>

(**The definitions and theorems below are well known in the literature (cf. @{cite Kuratowski-2}).
Here we uncover the minimal conditions under which they hold (taking frontier operation as primitive).*)
lemma Cl_Bzero: "Fr_2 \<F> \<Longrightarrow> \<forall>A. Cl A \<longleftrightarrow> \<B>(\<^bold>\<midarrow>A) \<^bold>\<approx> \<^bold>\<bottom>" using pA2 pC1 unfolding conn by metis
lemma Op_Bzero: "\<forall>A. Op A \<longleftrightarrow> (\<B> A) \<^bold>\<approx> \<^bold>\<bottom>" using pB1 pI1 unfolding conn by metis
lemma Br_boundary: "Fr_2 \<F> \<Longrightarrow> \<forall>A. Br(A) \<longleftrightarrow> \<I> A \<^bold>\<approx> \<^bold>\<bottom>" by (metis Br_fr_def Int_fr_def bottom_def diff_def meet_def)
lemma Fr_nowhereDense: "Fr_2 \<F> \<Longrightarrow> \<forall>A. Fr(A) \<longrightarrow> \<I>(\<C> A) \<^bold>\<approx> \<^bold>\<bottom>" using Fr_ClBr Br_boundary eq_ext by metis
lemma Cl_FB: "\<forall>A. Cl A \<longleftrightarrow> \<F> A \<^bold>\<approx> \<B> A" using Br_fr_def Cl_fr_def unfolding conn by auto
lemma Op_FB: "Fr_2 \<F> \<Longrightarrow> \<forall>A. Op A \<longleftrightarrow> \<F> A \<^bold>\<approx> \<B>(\<^bold>\<midarrow>A)" using Br_fr_def Fr_2_def Int_fr_def unfolding conn by auto
lemma Clopen_Fzero: "\<forall>A. Cl A \<and> Op A \<longleftrightarrow> \<F> A \<^bold>\<approx> \<^bold>\<bottom>" using Cl_fr_def Int_fr_def unfolding conn by auto

lemma Int_sup_closed: "Fr_1b \<F> \<Longrightarrow> supremum_closed (\<lambda>A. Op A)" by (smt IF1a Int_fr_def MONO_def MONO_MULTa sup_char conn)

(**Introduces a predicate for indicating that A and B are disjoint and proves some properties.*)
abbreviation "Disj A B \<equiv> A \<^bold>\<and> B \<^bold>\<approx> \<^bold>\<bottom>"

lemma Disj_comm: "\<forall>A B. Disj A B \<longrightarrow> Disj B A" unfolding conn by fastforce
lemma Disj_IF: "\<forall>A. Disj (\<I> A) (\<F> A)" by (simp add: Int_fr_def conn)
lemma Disj_B: "\<forall>A. Disj (\<B> A) (\<B>(\<^bold>\<midarrow>A))" using Br_fr_def unfolding conn by auto
lemma Disj_I: "\<forall>A. Disj (\<I> A) (\<^bold>\<midarrow>A)" by (simp add: Int_fr_def conn)
lemma Disj_BCI: "Fr_2 \<F> \<Longrightarrow> \<forall>A. Disj (\<B>(\<C> A)) (\<I>(\<^bold>\<midarrow>A))" using Br_fr_def Cl_fr_def Fr_2_def Int_fr_def conn by metis
lemma Disj_CBI: "Fr_6 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>A. Disj (\<C>(\<B>(\<^bold>\<midarrow>A))) (\<I>(\<^bold>\<midarrow>A))" by (metis Br_fr_def Cl_F IB_rel Int_br_def MONO_MULTa MULT_a_def eq_ext' monC conn)

(**Introduces a predicate for indicating that A and B are separated and proves some properties.*)
definition "Sep A B \<equiv> Disj (\<C> A) B \<and> Disj (\<C> B) A"

lemma Sep_comm: "\<forall>A B. Sep A B \<longrightarrow> Sep B A" by (simp add: Sep_def)
lemma Sep_disj: "\<forall>A B. Sep A B \<longrightarrow> Disj A B" using Cl_fr_def Sep_def conn by fastforce
lemma Sep_I: "Fr_1(\<F>) \<Longrightarrow> Fr_2(\<F>) \<Longrightarrow> Fr_4(\<F>) \<Longrightarrow> \<forall>A. Sep (\<I> A) (\<I> (\<^bold>\<midarrow>A))" using Cl_fr_def pF4 Fr_2_def Int_fr_def unfolding Sep_def conn by metis
lemma Sep_sub: "Fr_6 \<F>  \<Longrightarrow> \<forall>A B C D. Sep A B \<and> C \<^bold>\<preceq> A \<and> D \<^bold>\<preceq> B \<longrightarrow> Sep C D" using MONO_def monC unfolding Sep_def conn by smt
lemma Sep_Cl_diff: "Fr_6 \<F> \<Longrightarrow> \<forall>A B. Cl(A) \<and> Cl(B) \<longrightarrow> Sep (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" using Fr_6_def pC2 unfolding Sep_def conn by smt
lemma Sep_Op_diff: "Fr_1b \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> \<forall>A B. Op(A) \<and> Op(B) \<longrightarrow> Sep (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" proof -
  assume fr1b:"Fr_1b \<F>" and fr2:"Fr_2 \<F>"
  { fix A B
    from fr1b fr2 have aux: "let M=\<^bold>\<midarrow>A ; N=\<^bold>\<midarrow>B in (Cl(M) \<and> Cl(N) \<longrightarrow> Sep (M \<^bold>\<leftharpoonup> N) (N \<^bold>\<leftharpoonup> M))" using PF6 Sep_Cl_diff by simp
    { assume "Op(A) \<and> Op(B)"
      hence "Cl(\<^bold>\<midarrow>A) \<and> Cl(\<^bold>\<midarrow>B)" using fr2 ClOpdual by simp
      hence "Sep (\<^bold>\<midarrow>A \<^bold>\<leftharpoonup> \<^bold>\<midarrow>B) (\<^bold>\<midarrow>B \<^bold>\<leftharpoonup> \<^bold>\<midarrow>A)" using fr1b fr2 aux unfolding conn by simp
      moreover have "(\<^bold>\<midarrow>A \<^bold>\<leftharpoonup> \<^bold>\<midarrow>B) \<^bold>\<approx> (B \<^bold>\<leftharpoonup> A)" unfolding conn by auto
      moreover have "(\<^bold>\<midarrow>B \<^bold>\<leftharpoonup> \<^bold>\<midarrow>A) \<^bold>\<approx> (A \<^bold>\<leftharpoonup> B)" unfolding conn by auto
      ultimately have "Sep (B \<^bold>\<leftharpoonup> A) (A \<^bold>\<leftharpoonup> B)" unfolding conn by simp
      hence "Sep (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" using Sep_comm by simp
    } hence "Op(A) \<and> Op(B) \<longrightarrow> Sep (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" by (rule impI)
  } thus ?thesis by simp
qed
lemma Sep_Cl: "\<forall>A B. Cl(A) \<and> Cl(B) \<and> Disj A B \<longrightarrow> Sep A B" unfolding Sep_def conn by blast
lemma Sep_Op: "Fr_1b \<F> \<Longrightarrow> Fr_2 \<F>  \<Longrightarrow> \<forall>A B. Op(A) \<and> Op(B) \<and> Disj A B \<longrightarrow> Sep A B" proof -
  assume fr1b:"Fr_1b \<F>" and fr2:"Fr_2 \<F>"
  { fix A B
    from fr1b fr2 have aux: "Op(A) \<and> Op(B) \<longrightarrow> Sep (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" using Sep_Op_diff by simp
    { assume op: "Op(A) \<and> Op(B)" and disj: "Disj A B"
      hence "(A \<^bold>\<leftharpoonup> B) \<^bold>\<approx> A \<and> (B \<^bold>\<leftharpoonup> A) \<^bold>\<approx> B" unfolding conn by blast
      hence "Sep A B" using op aux unfolding conn by simp
    } hence "Op(A) \<and> Op(B) \<and> Disj A B \<longrightarrow> Sep A B" by simp
  } thus ?thesis by simp
qed
lemma "Fr_1a \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> \<forall>A B C. Sep A B \<and> Sep A C \<longrightarrow> Sep A (B \<^bold>\<or> C)" using CF1a ADDI_a_def unfolding Sep_def conn by metis

(**Verifies a neighborhood-based definition of closure.*)
definition "nbhd A p \<equiv> \<exists>E. E \<^bold>\<preceq> A \<and> Op(E) \<and> (E p)"
lemma nbhd_def2: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>A p. (nbhd A p) = (\<I> A p)" using pF4 MONO_def PF1 monI pI2 unfolding nbhd_def conn by smt

lemma C_def_lr: "Fr_1b \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>A p. (\<C> A p) \<longrightarrow> (\<forall>E. (nbhd E p) \<longrightarrow> \<not>(Disj E A))" using Cl_fr_def Fr_2_def Fr_6_def PF6 pF1 unfolding nbhd_def conn by smt
lemma C_def_rl: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>A p. (\<C> A p) \<longleftarrow> (\<forall>E. (nbhd E p) \<longrightarrow> \<not>(Disj E A))" using Cl_fr_def pF5 pA1 pB4 unfolding nbhd_def conn by smt
lemma C_def: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> \<forall>A p. (\<C> A p) \<longleftrightarrow> (\<forall>E. (nbhd E p) \<longrightarrow> \<not>(Disj E A))" using C_def_lr C_def_rl PF1 by blast

(**Explore the Barcan and converse Barcan formulas.*)
lemma Barcan_I: "Fr_inf \<F> \<Longrightarrow> \<forall>P. (\<^bold>\<forall>x. \<I>(P x)) \<^bold>\<preceq> \<I>(\<^bold>\<forall>x. P x)" using IF_inf Barcan1 by auto
lemma Barcan_C: "Fr_2 \<F> \<Longrightarrow> Fr_inf \<F> \<Longrightarrow> \<forall>P. \<C>(\<^bold>\<exists>x. P x) \<^bold>\<preceq> (\<^bold>\<exists>x. \<C>(P x))" using Fr_2_def CF_inf Barcan2 by metis
lemma CBarcan_I: "Fr_1b \<F> \<Longrightarrow> \<forall>P. \<I>(\<^bold>\<forall>x. P x)  \<^bold>\<preceq> (\<^bold>\<forall>x. \<I>(P x))" by (metis (mono_tags, lifting) MONO_def monI)
lemma CBarcan_C: "Fr_6 \<F> \<Longrightarrow> \<forall>P. (\<^bold>\<exists>x. \<C>(P x)) \<^bold>\<preceq> \<C>(\<^bold>\<exists>x. P x)"  by (metis (mono_tags, lifting) MONO_def monC)

end

github-repos/isabelle/davfuenmayor-topological-semantics/topological-semantics-770a84ffa2cf8498bd5f60853d11be4d77fc8cd3/old-stuff (to migrate from old version)/TBA/frontier_algebra.thy


(*
  Author:   Benedikt Seidl
  License:  GPL-3.0-or-later
*)

theory Matroid
  imports Main Graph
begin

locale independence_system =
  fixes
    E :: "'a set"
  fixes
    I :: "'a set set"
  assumes
    finite: "finite E"
  assumes
    subset: "I \<subseteq> Pow E"
  assumes
    nonempty: "I \<noteq> {}"
  assumes
    1: "B \<in> I \<Longrightarrow> A \<subseteq> B \<Longrightarrow> A \<in> I"
begin

  lemma "{} \<in> I"
    using nonempty 1 by blast

end

locale matroid = independence_system +
  assumes
    2: "\<forall>A \<in> I. \<forall>B \<in> I. card A < card B \<longrightarrow> (\<exists>e \<in> B - A. A \<union> {e} \<in> I)"
begin

end

lemma card_subset: "n \<le> card B \<Longrightarrow> \<exists>B' \<subseteq> B. card B' = n"
proof (induction n)
  case 0
  have "{} \<subseteq> B"
    by blast
  then show ?case
    using 0 by fastforce
next
  case (Suc n)
  hence "n < card B"
    by simp

  with Suc obtain B' where "B' \<subseteq> B" and "card B' = n"
    by auto

  with \<open>n < card B\<close> have "B' \<subset> B"
    by auto
  then obtain e where "e \<in> B - B'"
    by auto
  hence "e \<notin> B'" and "e \<in> B"
    by auto

  from \<open>n < card B\<close> have "0 < card B"
    by simp
  hence "finite B"
    using card_infinite by fastforce
  hence "finite B'"
    using \<open>B' \<subset> B\<close> finite_subset by auto

  with \<open>card B' = n\<close> \<open>e \<notin> B'\<close> have "card (B' \<union> {e}) = Suc n"
    by simp
  with \<open>B' \<subseteq> B\<close> \<open>e \<in> B\<close> have "(B' \<union> {e}) \<subseteq> B \<and> card (B' \<union> {e}) = Suc n"
    by simp
  thus ?case
    by blast
qed

lemma matroid_2':
  assumes "independence_system E I"
  shows "matroid E I \<longleftrightarrow> (\<forall>A \<in> I. \<forall>B \<in> I. card A + 1 = card B \<longrightarrow> (\<exists>e \<in> B - A. A \<union> {e} \<in> I))"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs

  hence 2: "\<forall>A \<in> I. \<forall>B \<in> I. card A < card B \<longrightarrow> (\<exists>e \<in> B - A. A \<union> {e} \<in> I)"
    using "matroid.2" by blast

  show ?rhs
  proof safe
    fix A B assume "A \<in> I" and "B \<in> I" and "card A + 1 = card B"
    thus "\<exists>e \<in> B - A. A \<union> {e} \<in> I" using 2 by simp
  qed
next
  assume ?rhs

  have "\<forall>A \<in> I. \<forall>B \<in> I. card A < card B \<longrightarrow> (\<exists>e \<in> B - A. A \<union> {e} \<in> I)"
  proof safe
    fix A B assume "A \<in> I" and "B \<in> I" and "card A < card B"
    then obtain n where "n = card A + 1"
      by blast
    hence "n \<le> card B"
      using \<open>card A < card B\<close> by fastforce
    then obtain B' where "B' \<subseteq> B" and "card B' = n"
      using card_subset by auto
    hence "\<exists>e \<in> B' - A. A \<union> {e} \<in> I"
      by (metis "independence_system.1" \<open>A \<in> I\<close> \<open>B \<in> I\<close> \<open>?rhs\<close> \<open>n = card A + 1\<close> assms)

    then show "\<exists>e \<in> B - A. A \<union> {e} \<in> I" using \<open>B' \<subseteq> B\<close> by blast
  qed

  thus ?lhs using assms matroid_def matroid_axioms_def by blast
qed

lemma
  fixes
    V :: "'a set"
  fixes
    E :: "'a set set"
  assumes
    g: "graph (V, E)"
  defines
    i: "I \<equiv> {F. F \<subseteq> E \<and> graph.acyclic (V, F)}"
  shows
    "matroid E I"
proof
  show "finite E"
    using g graph.finite_edges by fastforce
next
  show "I \<subseteq> Pow E"
    using i by auto
next
  thm graph.nonempty_vertices
  thm graph.acyclic_def
  thm empty_edges
  thm graph.subgraph_def

  have "graph (V, {})"
    using g graph.finite_vertices graph.nonempty_vertices empty_edges
    by fastforce

  have "\<forall>H. H \<subseteq>\<^sub>G (V, {}) \<longrightarrow> \<not> graph.circle H"
    proof safe
      fix W F assume s: "(W, F) \<subseteq>\<^sub>G (V, {})" and c: "graph.circle (W, F)"

      hence "graph (W, F) \<and> W \<subseteq> V \<and> F \<subseteq> {}"
        using \<open>graph (V, {})\<close> graph.subgraph_def by auto
      hence "graph (W, F)" and "F = {}"
        by simp+

      with c obtain n where "n \<ge> 3" and "(W, F) \<sim>\<^sub>G (C\<^sub>G n)"
        using graph.circle_def by blast

      hence "card F = card (snd (C\<^sub>G n))"
        using \<open>graph (W, F)\<close> isomorphic_card sorry

      hence "snd (C\<^sub>G n) = {}" using \<open>F = {}\<close> sorry

      thm \<open>F = {}\<close>

      show False sorry
    qed

  hence "graph.acyclic (V, {})"
    using \<open>graph (V, {})\<close> by (subst graph.acyclic_def)

  hence "{} \<in> I"
    using i by simp

  thus "I \<noteq> {}"
    by auto
next
  fix A
  show "A \<in> I" sorry
next
  show "\<forall>A\<in>I. \<forall>B\<in>I. card A < card B \<longrightarrow> (\<exists>e\<in>B - A. A \<union> {e} \<in> I)"
  proof safe
    fix A B
    show "\<exists>e\<in>B - A. A \<union> {e} \<in> I" sorry
  qed
qed

end


theory Concave
imports Complex_Main
begin

lemma linorder_wlog':
  fixes   x :: "'a :: linorder"
  assumes "\<And>x y. x < y \<Longrightarrow> P x y"
  assumes "\<And>x. P x x"
  assumes "\<And>x y. P x y \<Longrightarrow> P y x"
  shows   "P x y"
  by (cases x y rule: linorder_cases) (auto intro: assms)

lemma
  "(x::real) > 0 \<Longrightarrow> y > 0 \<Longrightarrow> log 2 x + log 2 y + 2 \<le> 2 * log 2 (x + y)"
proof (induction rule: linorder_wlog'[of _ x y])
  fix x y :: real
  assume xy: "x > 0" "y > 0" "x < y"
  from xy have "\<exists>\<xi>. \<xi> > x \<and> \<xi> < x + y \<and> log 2 (x + y) - log 2 x = ((x + y) - x) * (1 / (ln 2 * \<xi>))"
    by (intro MVT2) (auto intro: derivative_eq_intros)
  then obtain \<xi> where \<xi>: "\<xi> > x" "\<xi> < x + y" "log 2 (x + y) = log 2 x + y / ln 2 / \<xi>" by auto
  from xy
    have "\<exists>\<eta>. \<eta> > y \<and> \<eta> < x + y \<and> log 2 (x + y) - log 2 y = ((x + y) - y) * (1 / (ln 2 * \<eta>))"
    by (intro MVT2) (auto intro: derivative_eq_intros)
  then obtain \<eta> where \<eta>: "\<eta> > y" "\<eta> < x + y" "log 2 (x + y) = log 2 y + x / ln 2 / \<eta>" by auto

  have "log 2 (x + y) + log 2 (x + y) = log 2 x + log 2 y + x / ln 2 / \<eta> + y / ln 2 / \<xi>"
    by (subst \<xi>(3), subst \<eta>(3)) simp

  note \<xi>(3)
  also have
qed (auto simp: algebra_simps log_mult)
find_theorems "log _ (_ * _)"

lemma connected_contains_Icc:
  assumes "connected (A :: ('a :: {linorder_topology}) set)" "a \<in> A" "b \<in> A"
  shows   "{a..b} \<subseteq> A"
proof
  fix x assume "x \<in> {a..b}"
  hence "x = a \<or> x = b \<or> x \<in> {a<..<b}" by auto
  thus "x \<in> A" using assms connected_contains_Ioo[of A a b] by auto
qed

definition concave_on :: "(_ :: {ordered_ring, comm_monoid_mult}) set \<Rightarrow> _" where
  "concave_on A f = (\<forall>t\<in>{0..1}. \<forall>x\<in>A. \<forall>y\<in>A. f ((1 - t) * x + t * y) \<ge> (1 - t) * f x + t * f y)"

lemma concave_onI [intro?]:
  assumes "\<And>t x y. t > 0 \<Longrightarrow> t < 1 \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow>
             f ((1 - t) * x + t * y) \<ge> (1 - t) * f x + t * f y"
  shows   "concave_on A f"
  unfolding concave_on_def
proof clarify
  case (goal1 t x y)
  with assms show ?case by (cases "t = 0 \<or> t = 1") auto
qed

lemma concave_on_linorderI [intro?]:
  fixes A :: "('a::{linordered_ring,comm_monoid_mult}) set"
  assumes "\<And>t x y. t > 0 \<Longrightarrow> t < 1 \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x < y \<Longrightarrow>
             f ((1 - t) * x + t * y) \<ge> (1 - t) * f x + t * f y"
  shows   "concave_on A f"
proof
  case (goal1 t x y)
  with goal1 assms[of t x y] assms[of "1 - t" y x]
    show ?case by (cases x y rule: linorder_cases) (auto simp: algebra_simps)
qed

lemma concave_onD:
  assumes "concave_on A f"
  shows   "\<And>t x y. t \<ge> 0 \<Longrightarrow> t \<le> 1 \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow>
             f ((1 - t) * x + t * y) \<ge> (1 - t) * f x + t * f y"
  using assms unfolding concave_on_def by auto

lemma concave_on_realI:
  assumes "connected A"
  assumes "\<And>x. x \<in> A \<Longrightarrow> (f has_real_derivative f' x) (at x)"
  assumes "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<le> y \<Longrightarrow> f' x \<ge> f' y"
  shows   "concave_on A f"
proof (rule concave_on_linorderI)
  fix t x y :: real
  assume t: "t > 0" "t < 1" and xy: "x \<in> A" "y \<in> A" "x < y"
  def z \<equiv> "(1 - t) * x + t * y"
  with `connected A` and xy have ivl: "{x..y} \<subseteq> A" using connected_contains_Icc by blast

  from xy t have xz: "z > x" by (simp add: z_def algebra_simps)
  have "y - z = (1 - t) * (y - x)" by (simp add: z_def algebra_simps)
  also from xy t have "... > 0" by (intro mult_pos_pos) simp_all
  finally have yz: "z < y" by simp

  from assms xz yz ivl t have "\<exists>\<xi>. \<xi> > x \<and> \<xi> < z \<and> f z - f x = (z - x) * f' \<xi>"
    by (intro MVT2) (auto intro!: assms(2))
  then obtain \<xi> where \<xi>: "\<xi> > x" "\<xi> < z" "f' \<xi> = (f z - f x) / (z - x)" by auto
  from assms xz yz ivl t have "\<exists>\<eta>. \<eta> > z \<and> \<eta> < y \<and> f y - f z = (y - z) * f' \<eta>"
    by (intro MVT2) (auto intro!: assms(2))
  then obtain \<eta> where \<eta>: "\<eta> > z" "\<eta> < y" "f' \<eta> = (f y - f z) / (y - z)" by auto

  from \<eta>(3) have "(f y - f z) / (y - z) = f' \<eta>" ..
  also from \<xi> \<eta> ivl have "\<xi> \<in> A" "\<eta> \<in> A" by auto
  with \<xi> \<eta> have "f' \<eta> \<le> f' \<xi>" by (intro assms(3)) auto
  also from \<xi>(3) have "f' \<xi> = (f z - f x) / (z - x)" .
  finally have "(f y - f z) * (z - x) \<le> (f z - f x) * (y - z)"
    using xz yz by (simp add: field_simps)
  also have "z - x = t * (y - x)" by (simp add: z_def algebra_simps)
  also have "y - z = (1 - t) * (y - x)" by (simp add: z_def algebra_simps)
  finally have "(f y - f z) * t \<le> (f z - f x) * (1 - t)" using xy by simp
  thus "(1 - t) * f x + t * f y \<le> f ((1 - t) * x + t * y)"
    by (simp add: z_def algebra_simps)
qed

lemma concave_ln: "concave_on {0<..} (ln :: real \<Rightarrow> real)"
  by (rule concave_on_realI) (auto intro: derivative_intros simp: field_simps)

lemma concave_log: "b > 1 \<Longrightarrow> concave_on {0<..} (log b :: real \<Rightarrow> real)"
  by (intro concave_on_realI) (auto intro: derivative_intros simp: field_simps)

lemma
  "(x::real) > 0 \<Longrightarrow> y > 0 \<Longrightarrow> log 2 x + log 2 y + 2 \<le> 2 * log 2 (x + y)"
  using concave_onD[OF concave_log, of 2 "1/2" x y] by (simp add: field_simps log_divide)

end


(* Title:      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>
*)

header {* Matrices *}

theory Matrix
imports "~~/src/HOL/Word/Word" Dioid
begin

text {* In this section we formalise a perhaps more natural version of
matrices of fixed dimension ($m \times n$-matrices). It is well known
that such matrices over a Kleene algebra form a Kleene
algebra~\cite{conway71regular}. *}

subsection {* Type Definition *}

typedef 'a atMost = "{..<len_of TYPE('a::len)}"
by auto

declare Rep_atMost_inject [simp]

lemma UNIV_atMost:
  "(UNIV::'a atMost set) = Abs_atMost ` {..<len_of TYPE('a::len)}"
 apply auto
 apply (rule Abs_atMost_induct)
 apply auto
done

lemma finite_UNIV_atMost [simp]: "finite (UNIV::('a::len) atMost set)"
  by (simp add: UNIV_atMost)

text {* Our matrix type is similar to \mbox{@{text "'a^'n^'m"}} from
{\em HOL/Multivariate\_Analysis/Finite\_Cartesian\_Product.thy}, but
(i)~we explicitly define a type constructor for matrices and square
matrices, and (ii)~in the definition of operations, e.g., matrix
multiplication, we impose weaker sort requirements on the element
type. *}

datatype ('a,'m,'n) matrix = Matrix "'m atMost \<Rightarrow> 'n atMost \<Rightarrow> 'a"

datatype ('a,'m) sqmatrix = SqMatrix "'m atMost \<Rightarrow> 'm atMost \<Rightarrow> 'a"

fun sqmatrix_of_matrix where
  "sqmatrix_of_matrix (Matrix A) = SqMatrix A"

fun matrix_of_sqmatrix where
  "matrix_of_sqmatrix (SqMatrix A) = Matrix A"

subsection {* 0 and 1 *}

instantiation matrix :: (zero,type,type) zero
begin
  definition zero_matrix_def: "0 \<equiv> Matrix (\<lambda>i j. 0)"
  instance ..
end

instantiation sqmatrix :: (zero,type) zero
begin
  definition zero_sqmatrix_def: "0 \<equiv> SqMatrix (\<lambda>i j. 0)"
  instance ..
end

text {* Tricky sort issues: compare @{term one_matrix} with @{term
one_sqmatrix} \dots *}

instantiation matrix :: ("{zero,one}",len,len) one
begin
  definition one_matrix_def:
    "1 \<equiv> Matrix (\<lambda>i j. if Rep_atMost i = Rep_atMost j then 1 else 0)"
  instance ..
end

instantiation sqmatrix :: ("{zero,one}",type) one
begin
  definition one_sqmatrix_def:
    "1 \<equiv> SqMatrix (\<lambda>i j. if i = j then 1 else 0)"
  instance ..
end

subsection {* Matrix Addition *}

fun matrix_plus where
  "matrix_plus (Matrix A) (Matrix B) = Matrix (\<lambda>i j. A i j + B i j)"

instantiation matrix :: (plus,type,type) plus
begin
  definition plus_matrix_def: "A + B \<equiv> matrix_plus A B"
  instance ..
end

lemma plus_matrix_def' [simp]:
  "Matrix A + Matrix B = Matrix (\<lambda>i j. A i j + B i j)"
  by (simp add: plus_matrix_def)

instantiation sqmatrix :: (plus,type) plus
begin
  definition plus_sqmatrix_def:
    "A + B \<equiv> sqmatrix_of_matrix (matrix_of_sqmatrix A + matrix_of_sqmatrix B)"
  instance ..
end

lemma plus_sqmatrix_def' [simp]:
  "SqMatrix A + SqMatrix B = SqMatrix (\<lambda>i j. A i j + B i j)"
  by (simp add: plus_sqmatrix_def)

lemma matrix_add_0_right [simp]:
  "A + 0 = (A::('a::monoid_add,'m,'n) matrix)"
  by (cases A, simp add: zero_matrix_def)

lemma matrix_add_0_left [simp]:
  "0 + A = (A::('a::monoid_add,'m,'n) matrix)"
  by (cases A, simp add: zero_matrix_def)

lemma matrix_add_commute [simp]:
  "(A::('a::ab_semigroup_add,'m,'n) matrix) + B = B + A"
  by (cases A, cases B, simp add: add.commute)

lemma matrix_add_assoc:
  "(A::('a::semigroup_add,'m,'n) matrix) + B + C = A + (B + C)"
  by (cases A, cases B, cases C, simp add: add.assoc)

lemma matrix_add_left_commute [simp]:
  "(A::('a::ab_semigroup_add,'m,'n) matrix) + (B + C) = B + (A + C)"
  by (metis matrix_add_assoc matrix_add_commute)

lemma sqmatrix_add_0_right [simp]:
  "A + 0 = (A::('a::monoid_add,'m) sqmatrix)"
  by (cases A, simp add: zero_sqmatrix_def)

lemma sqmatrix_add_0_left [simp]:
  "0 + A = (A::('a::monoid_add,'m) sqmatrix)"
  by (cases A, simp add: zero_sqmatrix_def)

lemma sqmatrix_add_commute [simp]:
  "(A::('a::ab_semigroup_add,'m) sqmatrix) + B = B + A"
  by (cases A, cases B, simp add: add.commute)

lemma sqmatrix_add_assoc:
  "(A::('a::semigroup_add,'m) sqmatrix) + B + C = A + (B + C)"
  by (cases A, cases B, cases C, simp add: add.assoc)

lemma sqmatrix_add_left_commute [simp]:
  "(A::('a::ab_semigroup_add,'m) sqmatrix) + (B + C) = B + (A + C)"
  by (metis sqmatrix_add_commute sqmatrix_add_assoc)

subsection {* Order (via Addition) *}

instantiation matrix :: (plus,type,type) plus_ord
begin
  definition less_eq_matrix_def:
    "(A::('a, 'b, 'c) matrix) \<le> B \<equiv> A + B = B"
  definition less_matrix_def:
    "(A::('a, 'b, 'c) matrix) < B \<equiv> A \<le> B \<and> A \<noteq> B"

  instance
  proof
    fix A B :: "('a, 'b, 'c) matrix"
    show "A \<le> B \<longleftrightarrow> A + B = B"
      by (metis less_eq_matrix_def)
    show "A < B \<longleftrightarrow> A \<le> B \<and> A \<noteq> B"
      by (metis less_matrix_def)
  qed
end

instantiation sqmatrix :: (plus,type) plus_ord
begin
  definition less_eq_sqmatrix_def:
    "(A::('a, 'b) sqmatrix) \<le> B \<equiv> A + B = B"
  definition less_sqmatrix_def:
    "(A::('a, 'b) sqmatrix) < B \<equiv> A \<le> B \<and> A \<noteq> B"

  instance
  proof
    fix A B :: "('a, 'b) sqmatrix"
    show "A \<le> B \<longleftrightarrow> A + B = B"
      by (metis less_eq_sqmatrix_def)
    show "A < B \<longleftrightarrow> A \<le> B \<and> A \<noteq> B"
      by (metis less_sqmatrix_def)
  qed
end

subsection {* Matrix Multiplication *}

fun matrix_times :: "('a::{comm_monoid_add,times},'m,'k) matrix \<Rightarrow> ('a,'k,'n) matrix \<Rightarrow> ('a,'m,'n) matrix" where
  "matrix_times (Matrix A) (Matrix B) = Matrix (\<lambda>i j. setsum (\<lambda>k. A i k * B k j) (UNIV::'k atMost set))"

notation matrix_times (infixl "*\<^sub>M" 70)

instantiation sqmatrix :: ("{comm_monoid_add,times}",type) times
begin
  definition times_sqmatrix_def:
    "A * B = sqmatrix_of_matrix (matrix_of_sqmatrix A *\<^sub>M matrix_of_sqmatrix B)"
  instance ..
end

lemma times_sqmatrix_def' [simp]:
  "SqMatrix A * SqMatrix B = SqMatrix (\<lambda>i j. setsum (\<lambda>k. A i k * B k j) (UNIV::'k atMost set))"
  by (simp add: times_sqmatrix_def)

lemma matrix_mult_0_right [simp]:
  "(A::('a::{comm_monoid_add,mult_zero},'m,'n) matrix) *\<^sub>M 0 = 0"
  by (cases A, simp add: zero_matrix_def)

lemma matrix_mult_0_left [simp]:
  "0 *\<^sub>M (A::('a::{comm_monoid_add,mult_zero},'m,'n) matrix) = 0"
  by (cases A, simp add: zero_matrix_def)

lemma setsum_delta_r_0 [simp]:
  "\<lbrakk> finite S; j \<notin> S \<rbrakk> \<Longrightarrow> (\<Sum>k\<in>S. f k * (if k = j then 1 else (0::'b::{semiring_0,monoid_mult}))) = 0"
  by (induct S rule: finite_induct, auto)

lemma setsum_delta_r_1 [simp]:
  "\<lbrakk> finite S; j \<in> S \<rbrakk> \<Longrightarrow> (\<Sum>k\<in>S. f k * (if k = j then 1 else (0::'b::{semiring_0,monoid_mult}))) = f j"
  by (induct S rule: finite_induct, auto)

lemma matrix_mult_1_right [simp]:
  "(A::('a::{semiring_0,monoid_mult},'m::len,'n::len) matrix) *\<^sub>M 1 = A"
  by (cases A, simp add: one_matrix_def)

lemma setsum_delta_l_0 [simp]:
  "\<lbrakk> finite S; i \<notin> S \<rbrakk> \<Longrightarrow> (\<Sum>k\<in>S. (if i = k then 1 else (0::'b::{semiring_0,monoid_mult})) * f k j) = 0"
  by (induct S rule: finite_induct, auto)

lemma setsum_delta_l_1 [simp]:
  "\<lbrakk> finite S; i \<in> S \<rbrakk> \<Longrightarrow> (\<Sum>k\<in>S. (if i = k then 1 else (0::'b::{semiring_0,monoid_mult})) * f k j) = f i j"
  by (induct S rule: finite_induct, auto)

lemma matrix_mult_1_left [simp]:
  "1 *\<^sub>M (A::('a::{semiring_0,monoid_mult},'m::len,'n::len) matrix) = A"
  by (cases A, simp add: one_matrix_def)

lemma matrix_mult_assoc:
  "(A::('a::semiring_0,'m,'n) matrix) *\<^sub>M B *\<^sub>M C = A *\<^sub>M (B *\<^sub>M C)"
 apply (cases A)
 apply (cases B)
 apply (cases C)
 apply (simp add: setsum_left_distrib setsum_right_distrib mult.assoc)
 apply (subst setsum.commute)
 apply (rule refl)
done

lemma matrix_mult_distrib_left:
  "(A::('a::{comm_monoid_add,semiring},'m,'n::len) matrix) *\<^sub>M (B + C) = A *\<^sub>M B + A *\<^sub>M C"
  by (cases A, cases B, cases C, simp add: distrib_left setsum.distrib)

lemma matrix_mult_distrib_right:
  "((A::('a::{comm_monoid_add,semiring},'m,'n::len) matrix) + B) *\<^sub>M C = A *\<^sub>M C + B *\<^sub>M C"
  by (cases A, cases B, cases C, simp add: distrib_right setsum.distrib)

lemma sqmatrix_mult_0_right [simp]:
  "(A::('a::{comm_monoid_add,mult_zero},'m) sqmatrix) * 0 = 0"
  by (cases A, simp add: zero_sqmatrix_def)

lemma sqmatrix_mult_0_left [simp]:
  "0 * (A::('a::{comm_monoid_add,mult_zero},'m) sqmatrix) = 0"
  by (cases A, simp add: zero_sqmatrix_def)

lemma sqmatrix_mult_1_right [simp]:
  "(A::('a::{semiring_0,monoid_mult},'m::len) sqmatrix) * 1 = A"
  by (cases A, simp add: one_sqmatrix_def)

lemma sqmatrix_mult_1_left [simp]:
  "1 * (A::('a::{semiring_0,monoid_mult},'m::len) sqmatrix) = A"
  by (cases A, simp add: one_sqmatrix_def)

lemma sqmatrix_mult_assoc:
  "(A::('a::{semiring_0,monoid_mult},'m) sqmatrix) * B * C = A * (B * C)"
 apply (cases A)
 apply (cases B)
 apply (cases C)
 apply (simp add: setsum_left_distrib setsum_right_distrib mult.assoc)
 apply (subst setsum.commute)
 apply (rule refl)
done

lemma sqmatrix_mult_distrib_left:
  "(A::('a::{comm_monoid_add,semiring},'m::len) sqmatrix) * (B + C) = A * B + A * C"
  by (cases A, cases B, cases C, simp add: distrib_left setsum.distrib)

lemma sqmatrix_mult_distrib_right:
  "((A::('a::{comm_monoid_add,semiring},'m::len) sqmatrix) + B) * C = A * C + B * C"
  by (cases A, cases B, cases C, simp add: distrib_right setsum.distrib)

subsection {* Square-Matrix Model of Dioids *}

text {* The following subclass proofs are necessary to connect parts
of our algebraic hierarchy to the hierarchy found in the Isabelle/HOL
library. *}

subclass (in ab_near_semiring_one_zerol) comm_monoid_add
proof
  fix a :: 'a
  show "0 + a = a"
    by (fact add_zerol)
qed

subclass (in semiring_one_zero) semiring_0
proof
  fix a :: 'a
  show "0 * a = 0"
    by (fact annil)
  show "a * 0 = 0"
    by (fact annir)
qed

subclass (in ab_near_semiring_one) monoid_mult ..

instantiation sqmatrix :: (dioid_one_zero,len) dioid_one_zero
begin
  instance
  proof
    fix A B C :: "('a, 'b) sqmatrix"
    show "A + B + C = A + (B + C)"
      by (fact sqmatrix_add_assoc)
    show "A + B = B + A"
      by (fact sqmatrix_add_commute)
    show "A * B * C = A * (B * C)"
      by (fact sqmatrix_mult_assoc)
    show "(A + B) * C = A * C + B * C"
      by (fact sqmatrix_mult_distrib_right)
    show "1 * A = A"
      by (fact sqmatrix_mult_1_left)
    show "A * 1 = A"
      by (fact sqmatrix_mult_1_right)
    show "0 + A = A"
      by (fact sqmatrix_add_0_left)
    show "0 * A = 0"
      by (fact sqmatrix_mult_0_left)
    show "A * 0 = 0"
      by (fact sqmatrix_mult_0_right)
    show "A + A = A"
      by (cases A, simp)
    show "A * (B + C) = A * B + A * C"
      by (fact sqmatrix_mult_distrib_left)
  qed
end

subsection {* Kleene Star for Matrices *}

text {* We currently do not implement the Kleene star of matrices,
since this is complicated. *}

end


theory SINVAR_BLPstrict
imports "../TopoS_Helper"
begin

subsection {* Stricter Bell LaPadula SecurityInvariant *}
text{* All unclassified data sources must be labeled, default assumption: all is secret.

Warning: This is considered here an access control strategy.
By default, everything is secret and one explicitly prohibits sending to non-secret hosts.*}

datatype security_level = Unclassified | Confidential | Secret

(*total order*)
instantiation security_level :: linorder
  begin
  fun less_eq_security_level :: "security_level \<Rightarrow> security_level \<Rightarrow> bool" where
    "(Unclassified \<le> Unclassified) = True" |
    "(Confidential \<le> Confidential) = True" |
    "(Secret \<le> Secret) = True" |
    "(Unclassified \<le> Confidential) = True" |
    "(Confidential \<le> Secret) = True"  |
    "(Unclassified \<le> Secret) = True"  |
    "(Secret \<le> Confidential) = False"  |
    "(Confidential \<le> Unclassified) = False"  |
    "(Secret \<le> Unclassified) = False"

  fun less_security_level :: "security_level \<Rightarrow> security_level \<Rightarrow> bool" where
    "(Unclassified < Unclassified) = False" |
    "(Confidential < Confidential) = False" |
    "(Secret < Secret) = False" |
    "(Unclassified < Confidential) = True" |
    "(Confidential < Secret) = True"  |
    "(Unclassified < Secret) = True"  |
    "(Secret < Confidential) = False"  |
    "(Confidential < Unclassified) = False"  |
    "(Secret < Unclassified) = False"
  instance
    apply(intro_classes)
    apply(case_tac [!] x)
    apply(simp_all)
    apply(case_tac  [!] y)
    apply(simp_all)
    apply(case_tac  [!] z)
    apply(simp_all)
    done
  end

definition default_node_properties :: "security_level"
  where  "default_node_properties \<equiv> Secret"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> security_level) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. (nP e1) \<le> (nP e2))"

definition receiver_violation :: "bool" where "receiver_violation \<equiv> False"

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF wf_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto)[6]
   apply(auto simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops)[1]
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
 done

subsection {*ENF*}
  lemma secret_default_candidate: "\<And> (nP::('v \<Rightarrow> security_level)) e1 e2. \<not> (nP e1) \<le> (nP e2) \<Longrightarrow> \<not> Secret \<le> (nP e2)"
    apply(case_tac "nP e1")
    apply(simp_all)
    apply(case_tac [!] "nP e2")
    apply(simp_all)
    done
  lemma BLP_ENF: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form sinvar (op \<le>)"
    unfolding SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_def
    by simp
  lemma BLP_ENF_refl: "SecurityInvariant_withOffendingFlows.ENF_refl sinvar (op \<le>)"
    unfolding SecurityInvariant_withOffendingFlows.ENF_refl_def
    apply(rule conjI)
     apply(simp add: BLP_ENF)
    apply(simp)
  done

  definition BLP_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> security_level) \<Rightarrow> ('v \<times> 'v) set set" where
  "BLP_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> (nP e1) > (nP e2)} })"
  lemma BLP_offending_set: "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    apply(simp only: fun_eq_iff SecurityInvariant_withOffendingFlows.ENF_offending_set[OF BLP_ENF] BLP_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto)
  done

  interpretation BLPstrict: SecurityInvariant_ACS sinvar default_node_properties
  (*TODO: why is there a where and no "rewrites" in the afp?*)
  rewrites "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = BLP_offending_set"
    unfolding default_node_properties_def
    apply(unfold_locales)
      apply(rule ballI)
      apply(rule SecurityInvariant_withOffendingFlows.ENF_fsts_refl_instance[OF BLP_ENF_refl])
         apply(simp_all add: BLP_ENF BLP_ENF_refl)[3]
      apply(simp add: secret_default_candidate; fail)
     apply(erule default_uniqueness_by_counterexample_ACS)
     apply(rule_tac x="\<lparr> nodes=set [vertex_1,vertex_2], edges = set [(vertex_1,vertex_2)] \<rparr>" in exI, simp)
     apply(simp add: BLP_offending_set graph_ops wf_graph_def)
     apply(rule_tac x="(\<lambda> x. Secret)(vertex_1 := Secret, vertex_2 := Confidential)" in exI, simp)
     apply(rule_tac x="vertex_1" in exI, simp)
     apply(rule_tac x="set [(vertex_1,vertex_2)]" in exI, simp)
     apply(simp add: BLP_offending_set_def)
     apply(rule conjI)
      apply fastforce
     apply (case_tac otherbot, simp_all)
    apply(fact BLP_offending_set)
   done

  lemma TopoS_BLPstrict: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_fact (open) sinvar_mono

hide_const (open) sinvar receiver_violation default_node_properties

end