header{*Attic*}
theory attic
imports Main "Lib/FiniteGraph"
begin

text{*old lemma, mainly unused. *}

lemma exists_x1x2_x1notoffending_natLeq:
  fixes
    G::"'v graph" and
    f and
    p::"'v \<Rightarrow> nat"
  assumes
    "valid_graph G"
    "\<exists>(e1, e2)\<in>(edges G). \<not> (p e1 \<le> p e2)" and
    "f \<subseteq> edges G \<and> (\<forall>(e1, e2)\<in>f. \<not> p e1 \<le> p e2)" and
    "\<forall>(e1, e2)\<in>(edges G) - f. p e1 \<le> p e2"
  shows "\<exists> x1 x2. (x1,x2)\<in>(edges G) \<and> (x1,x2)\<in> f \<and> x1 \<in> fst ` f \<and> x1 \<notin> snd ` f \<and> ((p x1) = Max (p`fst` f))"
proof -
   from assms have a2: "\<exists>x\<in>(edges G). \<not> (case x of (e1, e2) \<Rightarrow> p e1 \<le> p e2)" by auto
   from assms have a3: "f \<subseteq>(edges G) \<and> (\<forall>(e1, e2)\<in>f. \<not> p e1 \<le> p e2)" by simp
   from assms have a4: "\<forall>(e1, e2)\<in>(edges G) - f. p e1 \<le> p e2" by simp
   from assms(1) have finiteE: "finite (edges G)" using valid_graph.finiteE by fast
   from finiteE conjunct1[OF a3] have  finiteF: "finite f" by (metis rev_finite_subset)

   -- "Find a suitable x1, it is the Max of the firsts"
   from finiteF have x12: "\<forall> x \<in> f. Max (p`fst` f) \<ge> p (fst x)" by (metis Max_ge finite_imageI image_eqI)
   from a2 a4 have x14: "\<exists> x1. (p x1) \<in> p`fst` f \<and> x1 \<in> fst` f" by fast
   from finiteF have "(p`fst` f) \<noteq> {} \<Longrightarrow> Max (p`fst` f) \<in> (p`fst` f)" by simp
   hence x15: "Max (p`fst` f) \<in> (p`fst` f)" using x14 by fastforce
   hence "\<exists> x1. ((p x1) = Max (p`fst` f)) \<and> x1 \<in> fst` f" by force
   from this x14 obtain x1 where x1Cond: "((p x1) = Max (p`fst` f)) \<and> x1 \<in> fst` f" by blast

   -- "Thus x1 is not in the seconds, not offending"
   from x1Cond x15 have x1ImportantProp3: "(p x1) \<in> p`fst` f" by presburger
   from x1Cond conjunct2[OF a3] x12 have "\<forall>(e1, e2) \<in> f. p x1 > p e2" by fastforce

   from x1Cond this a2 a3 a4 have x1ImportantProp1: "(p x1) \<notin> p`snd` f" by force
   hence x1ImportantProp2: "x1 \<notin> snd` f" by blast

   -- "Obtain x2"
   from x1ImportantProp3 x1Cond have x1ImportantProp4: "x1 \<in> fst` f" by presburger
   from this x1ImportantProp2 have  "\<exists> x1 x2. (x1,x2) \<in> f \<and> x1 \<notin> snd` f" by fastforce
   from this x1Cond x1ImportantProp2 obtain x2 where x2Cond:"(x1,x2) \<in> f \<and> x1 \<notin> snd` f" by force

   from a3 have "\<And> x. x \<in> f \<Longrightarrow> x \<in> (edges G)" by blast
   from this x2Cond have x1x2Cond: "(x1,x2) \<in> (edges G)" by blast

   from x1x2Cond x2Cond x1Cond show ?thesis by auto
qed

lemma exCasePairSimp: "(\<exists>x. x \<in> A \<and> (case x of (e1, e2) \<Rightarrow> P e1 e2)) = (\<exists>(e1, e2) \<in> A. (P e1 e2))"
  thm Pair_eq splitE splitI2
  by auto

lemma exCasePairNotSimp: "(\<exists>x. x \<in> A \<and> \<not> (case x of (e1, e2) \<Rightarrow> P e1 e2)) = (\<exists>(e1, e2) \<in> A. \<not> (P e1 e2))"
  by auto

(* moved here from FiniteGraph.thy. Currently unused *)
subsection {* Paths *}
  text {* A path is represented by a list of adjacent edges. *}
  type_synonym 'v path = "('v \<times> 'v) list"

  context valid_graph
  begin
    text {* The following predicate describes a valid path:*}
    (* is-path src [src, ...., dst] dst *)
    fun is_path :: "'v \<Rightarrow> 'v path \<Rightarrow> 'v \<Rightarrow> bool" where
      "is_path v [] v' \<longleftrightarrow> v=v' \<and> v'\<in>V" |
      "is_path v ((v1,v2)#p) v' \<longleftrightarrow> v=v1 \<and> (v1,v2)\<in>E \<and> is_path v2 p v'"

    lemma is_path_simps[simp, intro!]:
      "is_path v [] v \<longleftrightarrow> v\<in>V"
      "is_path v [(v,v')] v' \<longleftrightarrow> (v,v')\<in>E"
      by (auto dest: E_validD)

    lemma is_path_memb[simp]:
      "is_path v p v' \<Longrightarrow> v\<in>V \<and> v'\<in>V"
      apply (induction p arbitrary: v)
       apply (auto dest: E_validD)
      done

    lemma is_path_split:
      "is_path v (p1@p2) v' \<longleftrightarrow> (\<exists>u. is_path v p1 u \<and> is_path u p2 v')"
      by (induct p1 arbitrary: v) auto

    lemma is_path_split'[simp]:
      "is_path v (p1@(u,u')#p2) v'
        \<longleftrightarrow> is_path v p1 u \<and> (u,u')\<in>E \<and> is_path u' p2 v'"
      by (auto simp add: is_path_split)
  end

  text {* Set of intermediate vertices of a path. These are all vertices but
    the last one. Note that, if the last vertex also occurs earlier on the path,
    it is contained in @{text "int_vertices"}. *}
  definition int_vertices :: "'v path \<Rightarrow> 'v set" where
    "int_vertices p \<equiv> set (map fst p)"

  lemma int_vertices_simps[simp]:
    "int_vertices [] = {}"
    "int_vertices (vv#p) = insert (fst vv) (int_vertices p)"
    "int_vertices (p1@p2) = int_vertices p1 \<union> int_vertices p2"
    by (auto simp add: int_vertices_def)

  lemma (in valid_graph) int_vertices_subset:
    "is_path v p v' \<Longrightarrow> int_vertices p \<subseteq> V"
    apply (induct p arbitrary: v)
     apply (simp)
    apply (force dest: E_validD)
    done

  lemma int_vertices_empty[simp]: "int_vertices p = {} \<longleftrightarrow> p=[]"
    by (cases p) auto

subsubsection {* Splitting Paths *}
  text {*Split a path at the point where it first leaves the set @{text W}: *}
  lemma (in valid_graph) path_split_set:
    assumes "is_path v p v'" and "v\<in>W" and "v'\<notin>W"
    obtains p1 p2 u w u' where
    "p=p1@(u,u')#p2" and
    "int_vertices p1 \<subseteq> W" and "u\<in>W" and "u'\<notin>W"
    using assms
  proof (induct p arbitrary: v thesis)
    case Nil thus ?case by auto
  next
    case (Cons vv p)
    note [simp, intro!] = `v\<in>W` `v'\<notin>W`
    from Cons.prems obtain u' where
      [simp]: "vv=(v,u')" and
        REST: "is_path u' p v'"
      by (cases vv) auto

    txt {* Distinguish wether the second node @{text u'} of the path is
      in @{text W}. If yes, the proposition follows by the
      induction hypothesis, otherwise it is straightforward, as
      the split takes place at the first edge of the path. *}
    {
      assume A [simp, intro!]: "u'\<in>W"
      from Cons.hyps[OF _ REST] obtain p1 uu uu' p2 where
        "p=p1@(uu,uu')#p2" "int_vertices p1 \<subseteq> W" "uu \<in> W" "uu' \<notin> W"
        by blast
      with Cons.prems(1)[of "vv#p1" uu uu' p2] have thesis by auto
    } moreover {
      assume "u'\<notin>W"
      with Cons.prems(1)[of "[]" v u' p] have thesis by auto
    } ultimately show thesis by blast
  qed

  text {*Split a path at the point where it first enters the set @{text W}:*}
  lemma (in valid_graph) path_split_set':
    assumes "is_path v p v'" and "v'\<in>W"
    obtains p1 p2 u where
    "p=p1@p2" and
    "is_path v p1 u" and
    "is_path u p2 v'" and
    "int_vertices p1 \<subseteq> -W" and "u\<in>W"
    using assms
  proof (cases "v\<in>W")
    case True with that[of "[]" p] assms show ?thesis
      by auto
  next
    case False with assms that show ?thesis
    proof (induct p arbitrary: v thesis)
      case Nil thus ?case by auto
    next
      case (Cons vv p)
      note [simp, intro!] = `v'\<in>W` `v\<notin>W`
      from Cons.prems obtain u' where
        [simp]: "vv=(v,u')" and [simp]: "(v,u')\<in>E" and
          REST: "is_path u' p v'"
        by (cases vv) auto

      txt {* Distinguish wether the second node @{text u'} of the path is
        in @{text W}. If yes, the proposition is straightforward, otherwise,
        it follows by the induction hypothesis.
        *}
      {
        assume A [simp, intro!]: "u'\<in>W"
        from Cons.prems(3)[of "[vv]" p u'] REST have ?case by auto
      } moreover {
        assume [simp, intro!]: "u'\<notin>W"
        from Cons.hyps[OF REST] obtain p1 p2 u'' where
          [simp]: "p=p1@p2" and
            "is_path u' p1 u''" and
            "is_path u'' p2 v'" and
            "int_vertices p1 \<subseteq> -W" and
            "u''\<in>W" by blast
        with Cons.prems(3)[of "vv#p1"] have ?case by auto
      } ultimately show ?case by blast
    qed
  qed

  text {* Split a path at the point where a given vertex is first visited: *}
  lemma (in valid_graph) path_split_vertex:
    assumes "is_path v p v'" and "u\<in>int_vertices p"
    obtains p1 p2 where
    "p=p1@p2" and
    "is_path v p1 u" and
    "u \<notin> int_vertices p1"
    using assms
  proof (induct p arbitrary: v thesis)
    case Nil thus ?case by auto
  next
    case (Cons vv p)
    from Cons.prems obtain u' where
      [simp]: "vv=(v,u')" "v\<in>V" "(v,u')\<in>E" and
        REST: "is_path u' p v'"
      by (cases vv) auto

    {
      assume "u=v"
      with Cons.prems(1)[of "[]" "vv#p"] have thesis by auto
    } moreover {
      assume [simp]: "u\<noteq>v"
      with Cons.hyps(1)[OF _ REST] Cons.prems(3) obtain p1 p2 where
        "p=p1@p2" "is_path u' p1 u" "u\<notin>int_vertices p1"
        by auto
      with Cons.prems(1)[of "vv#p1" p2] have thesis
        by auto
    } ultimately show ?case by blast
  qed

end


(*<*)
theory Optimized_Join
  imports "Generic_Join_Devel.Generic_Join_Correctness"
begin
(*>*)

section \<open>Optimized relational join\<close>

subsection \<open>Binary join\<close>

definition join_mask :: "nat \<Rightarrow> nat set \<Rightarrow> bool list" where
  "join_mask n X = map (\<lambda>i. i \<in> X) [0..<n]"

fun proj_tuple :: "bool list \<Rightarrow> 'a tuple \<Rightarrow> 'a tuple" where
  "proj_tuple [] [] = []"
| "proj_tuple (True # bs) (a # as) = a # proj_tuple bs as"
| "proj_tuple (False # bs) (a # as) = None # proj_tuple bs as"
| "proj_tuple (b # bs) [] = []"
| "proj_tuple [] (a # as) = []"

lemma proj_tuple_replicate: "(\<And>i. i \<in> set bs \<Longrightarrow> \<not>i) \<Longrightarrow> length bs = length as \<Longrightarrow>
  proj_tuple bs as = replicate (length bs) None"
  by (induction bs as rule: proj_tuple.induct) fastforce+

lemma proj_tuple_join_mask_empty: "length as = n \<Longrightarrow>
  proj_tuple (join_mask n {}) as = replicate n None"
  using proj_tuple_replicate[of "join_mask n {}"] by (auto simp add: join_mask_def)

lemma proj_tuple_alt: "proj_tuple bs as = map2 (\<lambda>b a. if b then a else None) bs as"
  by (induction bs as rule: proj_tuple.induct) auto

lemma map2_map: "map2 f (map g [0..<length as]) as = map (\<lambda>i. f (g i) (as ! i)) [0..<length as]"
  by (rule nth_equalityI) auto

lemma proj_tuple_join_mask_restrict: "length as = n \<Longrightarrow>
  proj_tuple (join_mask n X) as = restrict X as"
  by (auto simp add: restrict_def proj_tuple_alt join_mask_def map2_map)

lemma wf_tuple_proj_idle:
  assumes wf: "wf_tuple n X as"
  shows "proj_tuple (join_mask n X) as = as"
  using proj_tuple_join_mask_restrict[of as n X, unfolded restrict_idle[OF wf]] wf
  by (auto simp add: wf_tuple_def)

lemma wf_tuple_change_base:
  assumes wf: "wf_tuple n X as"
  and mask: "join_mask n X = join_mask n Y"
  shows "wf_tuple n Y as"
  using wf mask by (auto simp add: wf_tuple_def join_mask_def)

definition proj_tuple_in_join :: "bool \<Rightarrow> bool list \<Rightarrow> 'a tuple \<Rightarrow> 'a table \<Rightarrow> bool" where
  "proj_tuple_in_join pos bs as t = (if pos then proj_tuple bs as \<in> t else proj_tuple bs as \<notin> t)"

abbreviation "join_cond pos t \<equiv> (\<lambda>as. if pos then as \<in> t else as \<notin> t)"

abbreviation "join_filter_cond pos t \<equiv> (\<lambda>as _. join_cond pos t as)"

lemma proj_tuple_in_join_mask_idle:
  assumes wf: "wf_tuple n X as"
  shows "proj_tuple_in_join pos (join_mask n X) as t \<longleftrightarrow> join_cond pos t as"
  using wf_tuple_proj_idle[OF wf] by (auto simp add: proj_tuple_in_join_def)

lemma join_sub:
  assumes "L \<subseteq> R" "table n L t1" "table n R t2"
  shows "join t2 pos t1 = {as \<in> t2. proj_tuple_in_join pos (join_mask n L) as t1}"
  using assms proj_tuple_join_mask_restrict[of _ n L] join_restrict[of t2 n R t1 L pos]
    wf_tuple_length restrict_idle
  by (auto simp add: table_def proj_tuple_in_join_def sup.absorb1) fastforce+

lemma join_sub':
  assumes "R \<subseteq> L" "table n L t1" "table n R t2"
  shows "join t2 True t1 = {as \<in> t1. proj_tuple_in_join True (join_mask n R) as t2}"
  using assms proj_tuple_join_mask_restrict[of _ n R] join_restrict[of t2 n R t1 L True]
    wf_tuple_length restrict_idle
  by (auto simp add: table_def proj_tuple_in_join_def sup.absorb1 Un_absorb1) fastforce+

lemma join_eq:
  assumes tab: "table n R t1" "table n R t2"
  shows "join t2 pos t1 = (if pos then t2 \<inter> t1 else t2 - t1)"
  using join_sub[OF _ tab, of pos] tab(2) proj_tuple_in_join_mask_idle[of n R _ pos t1]
  by (auto simp add: table_def)

lemma join_no_cols:
  assumes tab: "table n {} t1" "table n R t2"
  shows "join t2 pos t1 = (if (pos \<longleftrightarrow> replicate n None \<in> t1) then t2 else {})"
  using join_sub[OF _ tab, of pos] tab(2)
  by (auto simp add: table_def proj_tuple_in_join_def wf_tuple_length proj_tuple_join_mask_empty)

lemma join_empty_left: "join {} pos t = {}"
  by (auto simp add: join_def)

lemma join_empty_right: "join t pos {} = (if pos then {} else t)"
  by (auto simp add: join_def)

fun bin_join :: "nat \<Rightarrow> nat set \<Rightarrow> 'a table \<Rightarrow> bool \<Rightarrow> nat set \<Rightarrow> 'a table \<Rightarrow> 'a table" where
  "bin_join n A t pos A' t' =
    (if t = {} then {}
    else if t' = {} then (if pos then {} else t)
    else if A' = {} then (if (pos \<longleftrightarrow> replicate n None \<in> t') then t else {})
    else if A' = A then (if pos then t \<inter> t' else t - t')
    else if A' \<subseteq> A then {as \<in> t. proj_tuple_in_join pos (join_mask n A') as t'}
    else if A \<subseteq> A' \<and> pos then {as \<in> t'. proj_tuple_in_join pos (join_mask n A) as t}
    else join t pos t')"

lemma bin_join_table:
  assumes tab: "table n A t" "table n A' t'"
  shows "bin_join n A t pos A' t' = join t pos t'"
  using assms join_empty_left[of pos t'] join_empty_right[of t pos]
    join_no_cols[OF _ assms(1), of t' pos] join_eq[of n A t' t pos] join_sub[OF _ assms(2,1)]
    join_sub'[OF _ assms(2,1)]
  by auto+

subsection \<open>Multi-way join\<close>

fun mmulti_join' :: "(nat set list \<Rightarrow> nat set list \<Rightarrow> 'a table list \<Rightarrow> 'a table)" where
  "mmulti_join' A_pos A_neg L = (
    let Q = set (zip A_pos L) in
    let Q_neg = set (zip A_neg (drop (length A_pos) L)) in
    New_max_getIJ_wrapperGenericJoin Q Q_neg)"

lemma mmulti_join'_correct:
  assumes "A_pos \<noteq> []"
      and "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A) (A_pos @ A_neg) L"
  shows "z \<in> mmulti_join' A_pos A_neg L \<longleftrightarrow> wf_tuple n (\<Union>A\<in>set A_pos. A) z \<and>
    list_all2 (\<lambda>A X. restrict A z \<in> X) A_pos (take (length A_pos) L) \<and>
    list_all2 (\<lambda>A X. restrict A z \<notin> X) A_neg (drop (length A_pos) L)"
proof -
  define Q where "Q = set (zip A_pos L)"
  have Q_alt: "Q = set (zip A_pos (take (length A_pos) L))"
    unfolding Q_def by (fastforce simp: in_set_zip)
  define Q_neg where "Q_neg = set (zip A_neg (drop (length A_pos) L))"
  let ?r = "mmulti_join' A_pos A_neg L"
  have "?r = New_max_getIJ_wrapperGenericJoin Q Q_neg"
    unfolding Q_def Q_neg_def by (simp del: New_max.wrapperGenericJoin.simps)
  moreover have "card Q \<ge> 1"
    unfolding Q_def using assms(1,2)
    by (auto simp: Suc_le_eq card_gt_0_iff zip_eq_Nil_iff)
  moreover have "\<forall>(A, X)\<in>(Q \<union> Q_neg). table n A X \<and> wf_set n A"
    unfolding Q_alt Q_neg_def using assms(2) by (simp add: zip_append1 list_all2_iff)
  ultimately have "z \<in> ?r \<longleftrightarrow> wf_tuple n (\<Union>(A, X)\<in>Q. A) z \<and>
      (\<forall>(A, X)\<in>Q. restrict A z \<in> X) \<and> (\<forall>(A, X)\<in>Q_neg. restrict A z \<notin> X)"
    using New_max.wrapper_correctness case_prod_beta' by blast
  moreover have "(\<Union>A\<in>set A_pos. A) = (\<Union>(A, X)\<in>Q. A)" proof -
    from assms(2) have "length A_pos \<le> length L" by (auto dest!: list_all2_lengthD)
    then show ?thesis
      unfolding Q_alt
      by (auto elim: in_set_impl_in_set_zip1[rotated, where ys="take (length A_pos) L"]
          dest: set_zip_leftD)
  qed
  moreover have "\<And>z. (\<forall>(A, X)\<in>Q. restrict A z \<in> X) \<longleftrightarrow>
    list_all2 (\<lambda>A X. restrict A z \<in> X) A_pos (take (length A_pos) L)"
    unfolding Q_alt using assms(2) by (auto simp add: list_all2_iff)
  moreover have "\<And>z. (\<forall>(A, X)\<in>Q_neg. restrict A z \<notin> X) \<longleftrightarrow>
    list_all2 (\<lambda>A X. restrict A z \<notin> X) A_neg (drop (length A_pos) L)"
    unfolding Q_neg_def using assms(2) by (auto simp add: list_all2_iff)
  ultimately show ?thesis
    unfolding Q_def Q_neg_def using assms(2) by simp
qed

lemmas restrict_nested = New_max.restrict_nested

lemma list_all2_opt_True:
  assumes "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A) ((A_zs @ A_x # A_xs @ A_y # A_ys) @ A_neg)
    ((zs @ x # xs @ y # ys) @ L_neg)"
    "length A_xs = length xs" "length A_ys = length ys" "length A_zs = length zs"
  shows "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
    ((A_zs @ (A_x \<union> A_y) # A_xs @ A_ys) @ A_neg) ((zs @ join x True y # xs @ ys) @ L_neg)"
proof -
  have assms_dest: "table n A_x x" "table n A_y y" "wf_set n A_x" "wf_set n A_y"
    using assms
    by (auto simp del: mmulti_join'.simps simp add: list_all2_append1 dest: list_all2_lengthD)
  then have tabs: "table n (A_x \<union> A_y) (join x True y)" "wf_set n (A_x \<union> A_y)"
    using join_table[of n A_x x A_y y True "A_x \<union> A_y", OF assms_dest(1,2)] assms_dest(3,4)
    by (auto simp add: wf_set_def)
  then show "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
    ((A_zs @ (A_x \<union> A_y) # A_xs @ A_ys) @ A_neg) ((zs @ join x True y # xs @ ys) @ L_neg)"
    using assms
    by (auto simp del: mmulti_join'.simps simp add: list_all2_append1 list_all2_append2
        list_all2_Cons1 list_all2_Cons2 dest: list_all2_lengthD) fastforce
qed

lemma mmulti_join'_opt_True:
  assumes "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A) ((A_zs @ A_x # A_xs @ A_y # A_ys) @ A_neg)
    ((zs @ x # xs @ y # ys) @ L_neg)"
    "length A_xs = length xs" "length A_ys = length ys" "length A_zs = length zs"
  shows "mmulti_join' (A_zs @ A_x # A_xs @ A_y # A_ys) A_neg ((zs @ x # xs @ y # ys) @ L_neg) =
    mmulti_join' (A_zs @ (A_x \<union> A_y) # A_xs @ A_ys) A_neg
    ((zs @ join x True y # xs @ ys) @ L_neg)"
proof -
  have assms_dest: "table n A_x x" "table n A_y y" "wf_set n A_x" "wf_set n A_y"
    using assms
    by (auto simp del: mmulti_join'.simps simp add: list_all2_append1 dest: list_all2_lengthD)
  then have tabs: "table n (A_x \<union> A_y) (join x True y)" "wf_set n (A_x \<union> A_y)"
    using join_table[of n A_x x A_y y True "A_x \<union> A_y", OF assms_dest(1,2)] assms_dest(3,4)
    by (auto simp add: wf_set_def)
  then have list_all2': "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
    ((A_zs @ (A_x \<union> A_y) # A_xs @ A_ys) @ A_neg) ((zs @ join x True y # xs @ ys) @ L_neg)"
    using assms
    by (auto simp del: mmulti_join'.simps simp add: list_all2_append1 list_all2_append2
        list_all2_Cons1 list_all2_Cons2 dest: list_all2_lengthD) fastforce
  have res: "\<And>z Z. wf_tuple n Z z \<Longrightarrow> A_x \<union> A_y \<subseteq> Z \<Longrightarrow>
    restrict (A_x \<union> A_y) z \<in> join x True y \<longleftrightarrow> restrict A_x z \<in> x \<and> restrict A_y z \<in> y"
    using join_restrict[of x n A_x y A_y True] wf_tuple_restrict_simple[of n _ _ "A_x \<union> A_y"]
      assms_dest(1,2)
    by (auto simp add: table_def restrict_nested Int_absorb2)
  show ?thesis
  proof (rule set_eqI, rule iffI)
    fix z
    assume "z \<in> mmulti_join' (A_zs @ A_x # A_xs @ A_y # A_ys) A_neg
      ((zs @ x # xs @ y # ys) @ L_neg)"
    then have z_in_dest: "wf_tuple n (\<Union>(set (A_zs @ A_x # A_xs @ A_y # A_ys))) z"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_zs zs"
      "restrict A_x z \<in> x"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_ys ys"
      "restrict A_y z \<in> y"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_xs xs"
      "list_all2 (\<lambda>A. (\<notin>) (restrict A z)) A_neg L_neg"
      using mmulti_join'_correct[OF _ assms(1), of z]
      by (auto simp del: mmulti_join'.simps simp add: assms list_all2_append1
          dest: list_all2_lengthD)
    then show "z \<in> mmulti_join' (A_zs @ (A_x \<union> A_y) # A_xs @ A_ys) A_neg
      ((zs @ join x True y # xs @ ys) @ L_neg)"
      using mmulti_join'_correct[OF _ list_all2', of z] res[OF z_in_dest(1)]
      by (auto simp add: assms list_all2_appendI le_supI2 Un_assoc simp del: mmulti_join'.simps
          dest: list_all2_lengthD)
  next
    fix z
    assume "z \<in> mmulti_join' (A_zs @ (A_x \<union> A_y) # A_xs @ A_ys) A_neg
      ((zs @ join x True y # xs @ ys) @ L_neg)"
    then have z_in_dest: "wf_tuple n (\<Union>(set (A_zs @ A_x # A_xs @ A_y # A_ys))) z"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_zs zs"
      "restrict (A_x \<union> A_y) z \<in> join x True y"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_ys ys"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_xs xs"
      "list_all2 (\<lambda>A. (\<notin>) (restrict A z)) A_neg L_neg"
      using mmulti_join'_correct[OF _ list_all2', of z]
      by (auto simp del: mmulti_join'.simps simp add: assms list_all2_append Un_assoc
          dest: list_all2_lengthD)
    then show "z \<in> mmulti_join' (A_zs @ A_x # A_xs @ A_y # A_ys) A_neg
      ((zs @ x # xs @ y # ys) @ L_neg)"
      using mmulti_join'_correct[OF _ assms(1), of z] res[OF z_in_dest(1)]
      by (auto simp add: assms list_all2_appendI le_supI2 Un_assoc simp del: mmulti_join'.simps
          dest: list_all2_lengthD)
  qed
qed

lemma list_all2_opt_False:
  assumes "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
    ((A_zs @ A_x # A_xs) @ (A_ws @ A_y # A_ys)) ((zs @ x # xs) @ (ws @ y # ys))"
    "length A_ws = length ws" "length A_xs = length xs"
    "length A_ys = length ys" "length A_zs = length zs"
    "A_y \<subseteq> A_x"
  shows "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
    ((A_zs @ A_x # A_xs) @ (A_ws @ A_ys)) ((zs @ join x False y # xs) @ (ws @ ys))"
proof -
  have assms_dest: "table n A_x x" "table n A_y y" "wf_set n A_x" "wf_set n A_y"
    using assms
    by (auto simp del: mmulti_join'.simps simp add: list_all2_append dest: list_all2_lengthD)
  have tabs: "table n A_x (join x False y)"
    using join_table[of n A_x x A_y y False A_x, OF assms_dest(1,2) assms(6)] assms(6) by auto
  then show "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
    ((A_zs @ A_x # A_xs) @ (A_ws @ A_ys)) ((zs @ join x False y # xs) @ (ws @ ys))"
    using assms assms_dest(3)
    by (auto simp del: mmulti_join'.simps simp add: list_all2_append1 list_all2_append2
        list_all2_Cons1 list_all2_Cons2 dest: list_all2_lengthD) fastforce
qed

lemma mmulti_join'_opt_False:
  assumes "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
    ((A_zs @ A_x # A_xs) @ (A_ws @ A_y # A_ys)) ((zs @ x # xs) @ (ws @ y # ys))"
    "length A_ws = length ws" "length A_xs = length xs"
    "length A_ys = length ys" "length A_zs = length zs"
    "A_y \<subseteq> A_x"
  shows "mmulti_join' (A_zs @ A_x # A_xs) (A_ws @ A_y # A_ys) ((zs @ x # xs) @ (ws @ y # ys)) =
    mmulti_join' (A_zs @ A_x # A_xs) (A_ws @ A_ys) ((zs @ join x False y # xs) @ (ws @ ys))"
proof -
  have assms_dest: "table n A_x x" "table n A_y y" "wf_set n A_x" "wf_set n A_y"
    using assms
    by (auto simp del: mmulti_join'.simps simp add: list_all2_append dest: list_all2_lengthD)
  have tabs: "table n A_x (join x False y)"
    using join_table[of n A_x x A_y y False A_x, OF assms_dest(1,2) assms(6)] assms(6) by auto
  then have list_all2': "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
    ((A_zs @ A_x # A_xs) @ (A_ws @ A_ys)) ((zs @ join x False y # xs) @ (ws @ ys))"
    using assms assms_dest(3)
    by (auto simp del: mmulti_join'.simps simp add: list_all2_append1 list_all2_append2
        list_all2_Cons1 list_all2_Cons2 dest: list_all2_lengthD) fastforce
  have res: "\<And>z. restrict A_x z \<in> join x False y \<longleftrightarrow> restrict A_x z \<in> x \<and> restrict A_y z \<notin> y"
    using join_restrict[of x n A_x y A_y False, OF _ _ assms(6)] assms_dest(1,2) assms(6)
    by (auto simp add: table_def restrict_nested Int_absorb2 Un_absorb2)
  show ?thesis
  proof (rule set_eqI, rule iffI)
    fix z
    assume "z \<in> mmulti_join' (A_zs @ A_x # A_xs) (A_ws @ A_y # A_ys)
      ((zs @ x # xs) @ ws @ y # ys)"
    then have z_in_dest: "wf_tuple n (\<Union>(set (A_zs @ A_x # A_xs))) z"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_zs zs"
      "restrict A_x z \<in> x"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_xs xs"
      "list_all2 (\<lambda>A. (\<notin>) (restrict A z)) A_ws ws"
      "restrict A_y z \<notin> y"
      "list_all2 (\<lambda>A. (\<notin>) (restrict A z)) A_ys ys"
      using mmulti_join'_correct[OF _ assms(1), of z]
      by (auto simp del: mmulti_join'.simps simp add: assms list_all2_append1
          dest: list_all2_lengthD)
    then show "z \<in> mmulti_join' (A_zs @ A_x # A_xs) (A_ws @ A_ys)
      ((zs @ join x False y # xs) @ ws @ ys)"
      using mmulti_join'_correct[OF _ list_all2', of z] res
      by (auto simp add: assms list_all2_appendI Un_assoc simp del: mmulti_join'.simps
          dest: list_all2_lengthD)
  next
    fix z
    assume "z \<in> mmulti_join' (A_zs @ A_x # A_xs) (A_ws @ A_ys)
      ((zs @ join x False y # xs) @ ws @ ys)"
    then have z_in_dest: "wf_tuple n (\<Union>(set (A_zs @ A_x # A_xs))) z"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_zs zs"
      "restrict A_x z \<in> join x False y"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_xs xs"
      "list_all2 (\<lambda>A. (\<notin>) (restrict A z)) A_ws ws"
      "list_all2 (\<lambda>A. (\<notin>) (restrict A z)) A_ys ys"
      using mmulti_join'_correct[OF _ list_all2', of z]
      by (auto simp del: mmulti_join'.simps simp add: assms list_all2_append1
          dest: list_all2_lengthD)
    then show "z \<in> mmulti_join' (A_zs @ A_x # A_xs) (A_ws @ A_y # A_ys)
      ((zs @ x # xs) @ ws @ y # ys)"
      using mmulti_join'_correct[OF _ assms(1), of z] res
      by (auto simp add: assms list_all2_appendI Un_assoc simp del: mmulti_join'.simps
          dest: list_all2_lengthD)
  qed
qed

fun find_sub_in :: "'a set \<Rightarrow> 'a set list \<Rightarrow> bool \<Rightarrow>
  ('a set list \<times> 'a set \<times> 'a set list) option" where
  "find_sub_in X [] b = None"
| "find_sub_in X (x # xs) b = (if (x \<subseteq> X \<or> (b \<and> X \<subseteq> x)) then Some ([], x, xs)
    else (case find_sub_in X xs b of None \<Rightarrow> None | Some (ys, z, zs) \<Rightarrow> Some (x # ys, z, zs)))"

lemma find_sub_in_sound: "find_sub_in X xs b = Some (ys, z, zs) \<Longrightarrow>
  xs = ys @ z # zs \<and> (z \<subseteq> X \<or> (b \<and> X \<subseteq> z))"
  by (induction X xs b arbitrary: ys z zs rule: find_sub_in.induct)
     (fastforce split: if_splits option.splits)+

fun find_sub_True :: "'a set list \<Rightarrow>
  ('a set list \<times> 'a set \<times> 'a set list \<times> 'a set \<times> 'a set list) option" where
  "find_sub_True [] = None"
| "find_sub_True (x # xs) = (case find_sub_in x xs True of None \<Rightarrow>
    (case find_sub_True xs of None \<Rightarrow> None
    | Some (ys, w, ws, z, zs) \<Rightarrow> Some (x # ys, w, ws, z, zs))
  | Some (ys, z, zs) \<Rightarrow> Some ([], x, ys, z, zs))"

lemma find_sub_True_sound: "find_sub_True xs = Some (ys, w, ws, z, zs) \<Longrightarrow>
  xs = ys @ w # ws @ z # zs \<and> (z \<subseteq> w \<or> w \<subseteq> z)"
  using find_sub_in_sound
  by (induction xs arbitrary: ys w ws z zs rule: find_sub_True.induct)
     (fastforce split: option.splits)+

fun find_sub_False :: "'a set list \<Rightarrow> 'a set list \<Rightarrow>
  (('a set list \<times> 'a set \<times> 'a set list) \<times> ('a set list \<times> 'a set \<times> 'a set list)) option" where
  "find_sub_False [] ns = None"
| "find_sub_False (x # xs) ns = (case find_sub_in x ns False of None \<Rightarrow>
    (case find_sub_False xs ns of None \<Rightarrow> None
    | Some ((rs, w, ws), (ys, z, zs)) \<Rightarrow> Some ((x # rs, w, ws), (ys, z, zs)))
  | Some (ys, z, zs) \<Rightarrow> Some (([], x, xs), (ys, z, zs)))"

lemma find_sub_False_sound: "find_sub_False xs ns = Some ((rs, w, ws), (ys, z, zs)) \<Longrightarrow>
  xs = rs @ w # ws \<and> ns = ys @ z # zs \<and> (z \<subseteq> w)"
  using find_sub_in_sound
  by (induction xs ns arbitrary: rs w ws ys z zs rule: find_sub_False.induct)
     (fastforce split: option.splits)+

fun proj_list_3 :: "'a list \<Rightarrow> ('b list \<times> 'b \<times> 'b list) \<Rightarrow> ('a list \<times> 'a \<times> 'a list)" where
  "proj_list_3 xs (ys, z, zs) = (take (length ys) xs, xs ! (length ys),
    take (length zs) (drop (length ys + 1) xs))"

lemma proj_list_3_same:
  assumes "proj_list_3 xs (ys, z, zs) = (ys', z', zs')"
    "length xs = length ys + 1 + length zs"
  shows "xs = ys' @ z' # zs'"
  using assms by (auto simp add: id_take_nth_drop)

lemma proj_list_3_length:
  assumes "proj_list_3 xs (ys, z, zs) = (ys', z', zs')"
    "length xs = length ys + 1 + length zs"
  shows "length ys = length ys'" "length zs = length zs'"
  using assms by auto

fun proj_list_5 :: "'a list \<Rightarrow>
  ('b list \<times> 'b \<times> 'b list \<times> 'b \<times> 'b list) \<Rightarrow>
  ('a list \<times> 'a \<times> 'a list \<times> 'a \<times> 'a list)" where
  "proj_list_5 xs (ys, w, ws, z, zs) = (take (length ys) xs, xs ! (length ys),
    take (length ws) (drop (length ys + 1) xs), xs ! (length ys + 1 + length ws),
    drop (length ys + 1 + length ws + 1) xs)"

lemma proj_list_5_same:
  assumes "proj_list_5 xs (ys, w, ws, z, zs) = (ys', w', ws', z', zs')"
    "length xs = length ys + 1 + length ws + 1 + length zs"
  shows "xs = ys' @ w' # ws' @ z' # zs'"
proof -
  have "xs ! length ys # take (length ws) (drop (Suc (length ys)) xs) = take (Suc (length ws)) (drop (length ys) xs)"
    using assms(2) by (simp add: list_eq_iff_nth_eq nth_Cons split: nat.split)
  moreover have "take (Suc (length ws)) (drop (length ys) xs) @ drop (Suc (length ys + length ws)) xs =
      drop (length ys) xs"
    unfolding Suc_eq_plus1 add.assoc[of _ _ 1] add.commute[of _ "length ws + 1"]
      drop_drop[symmetric, of "length ws + 1"] append_take_drop_id ..
  ultimately show ?thesis
    using assms by (auto simp: Cons_nth_drop_Suc append_Cons[symmetric])
qed

lemma proj_list_5_length:
  assumes "proj_list_5 xs (ys, w, ws, z, zs) = (ys', w', ws', z', zs')"
    "length xs = length ys + 1 + length ws + 1 + length zs"
  shows "length ys = length ys'" "length ws = length ws'"
    "length zs = length zs'"
  using assms by auto

fun dominate_True :: "nat set list \<Rightarrow> 'a table list \<Rightarrow>
  ((nat set list \<times> nat set \<times> nat set list \<times> nat set \<times> nat set list) \<times>
  ('a table list \<times> 'a table \<times> 'a table list \<times> 'a table \<times> 'a table list)) option" where
  "dominate_True A_pos L_pos = (case find_sub_True A_pos of None \<Rightarrow> None
  | Some split \<Rightarrow> Some (split, proj_list_5 L_pos split))"

lemma find_sub_True_proj_list_5_same:
  assumes "find_sub_True xs = Some (ys, w, ws, z, zs)" "length xs = length xs'"
    "proj_list_5 xs' (ys, w, ws, z, zs) = (ys', w', ws', z', zs')"
  shows "xs' = ys' @ w' # ws' @ z' # zs'"
proof -
  have len: "length xs' = length ys + 1 + length ws + 1 + length zs"
    using find_sub_True_sound[OF assms(1)] by (auto simp add: assms(2)[symmetric])
  show ?thesis
    using proj_list_5_same[OF assms(3) len] .
qed

lemma dominate_True_sound:
  assumes "dominate_True A_pos L_pos = Some ((A_zs, A_x, A_xs, A_y, A_ys), (zs, x, xs, y, ys))"
    "length A_pos = length L_pos"
  shows "A_pos = A_zs @ A_x # A_xs @ A_y # A_ys" "L_pos = zs @ x # xs @ y # ys"
    "length A_xs = length xs" "length A_ys = length ys" "length A_zs = length zs"
  using assms find_sub_True_sound find_sub_True_proj_list_5_same find_sub_True_proj_list_5_length
  by (auto simp del: proj_list_5.simps split: option.splits) fast+

fun dominate_False :: "nat set list \<Rightarrow> 'a table list \<Rightarrow> nat set list \<Rightarrow> 'a table list \<Rightarrow>
  (((nat set list \<times> nat set \<times> nat set list) \<times> nat set list \<times> nat set \<times> nat set list) \<times>
  (('a table list \<times> 'a table \<times> 'a table list) \<times>
  'a table list \<times> 'a table \<times> 'a table list)) option" where
  "dominate_False A_pos L_pos A_neg L_neg = (case find_sub_False A_pos A_neg of None \<Rightarrow> None
  | Some (pos_split, neg_split) \<Rightarrow>
    Some ((pos_split, neg_split), (proj_list_3 L_pos pos_split, proj_list_3 L_neg neg_split)))"

lemma find_sub_False_proj_list_3_same_left:
  assumes "find_sub_False xs ns = Some ((rs, w, ws), (ys, z, zs))"
    "length xs = length xs'" "proj_list_3 xs' (rs, w, ws) = (rs', w', ws')"
  shows "xs' = rs' @ w' # ws'"
proof -
  have len: "length xs' = length rs + 1 + length ws"
    using find_sub_False_sound[OF assms(1)] by (auto simp add: assms(2)[symmetric])
  show ?thesis
    using proj_list_3_same[OF assms(3) len] .
qed

lemma find_sub_False_proj_list_3_length_left:
  assumes "find_sub_False xs ns = Some ((rs, w, ws), (ys, z, zs))"
    "length xs = length xs'" "proj_list_3 xs' (rs, w, ws) = (rs', w', ws')"
  shows "length rs = length rs'" "length ws = length ws'"
  using find_sub_False_sound[OF assms(1)] proj_list_3_length[OF assms(3)] assms(2) by auto

lemma find_sub_False_proj_list_3_same_right:
  assumes "find_sub_False xs ns = Some ((rs, w, ws), (ys, z, zs))"
    "length ns = length ns'" "proj_list_3 ns' (ys, z, zs) = (ys', z', zs')"
  shows "ns' = ys' @ z' # zs'"
proof -
  have len: "length ns' = length ys + 1 + length zs"
    using find_sub_False_sound[OF assms(1)] by (auto simp add: assms(2)[symmetric])
  show ?thesis
    using proj_list_3_same[OF assms(3) len] .
qed

lemma find_sub_False_proj_list_3_length_right:
  assumes "find_sub_False xs ns = Some ((rs, w, ws), (ys, z, zs))"
    "length ns = length ns'" "proj_list_3 ns' (ys, z, zs) = (ys', z', zs')"
  shows "length ys = length ys'" "length zs = length zs'"
  using find_sub_False_sound[OF assms(1)] proj_list_3_length[OF assms(3)] assms(2) by auto

lemma dominate_False_sound:
  assumes "dominate_False A_pos L_pos A_neg L_neg =
    Some (((A_zs, A_x, A_xs), A_ws, A_y, A_ys), ((zs, x, xs), ws, y, ys))"
    "length A_pos = length L_pos" "length A_neg = length L_neg"
  shows "A_pos = (A_zs @ A_x # A_xs)" "A_neg = A_ws @ A_y # A_ys"
    "L_pos = (zs @ x # xs)" "L_neg = ws @ y # ys"
    "length A_ws = length ws" "length A_xs = length xs"
    "length A_ys = length ys" "length A_zs = length zs"
    "A_y \<subseteq> A_x"
  using assms find_sub_False_proj_list_3_same_left find_sub_False_proj_list_3_same_right
    find_sub_False_proj_list_3_length_left find_sub_False_proj_list_3_length_right
    find_sub_False_sound
  by (auto simp del: proj_list_3.simps split: option.splits) fast+

function mmulti_join :: "(nat \<Rightarrow> nat set list \<Rightarrow> nat set list \<Rightarrow> 'a table list \<Rightarrow> 'a table)" where
  "mmulti_join n A_pos A_neg L = (if length A_pos + length A_neg \<noteq> length L then {} else
    let L_pos = take (length A_pos) L; L_neg = drop (length A_pos) L in
    (case dominate_True A_pos L_pos of None \<Rightarrow>
      (case dominate_False A_pos L_pos A_neg L_neg of None \<Rightarrow> mmulti_join' A_pos A_neg L
      | Some (((A_zs, A_x, A_xs), A_ws, A_y, A_ys), ((zs, x, xs), ws, y, ys)) \<Rightarrow>
        mmulti_join n (A_zs @ A_x # A_xs) (A_ws @ A_ys)
        ((zs @ bin_join n A_x x False A_y y # xs) @ (ws @ ys)))
    | Some ((A_zs, A_x, A_xs, A_y, A_ys), (zs, x, xs, y, ys)) \<Rightarrow>
      mmulti_join n (A_zs @ (A_x \<union> A_y) # A_xs @ A_ys) A_neg
      ((zs @ bin_join n A_x x True A_y y # xs @ ys) @ L_neg)))"
  by pat_completeness auto
termination
  by (relation "measure (\<lambda>(n, A_pos, A_neg, L). length A_pos + length A_neg)")
    (use find_sub_True_sound find_sub_False_sound in \<open>fastforce split: option.splits\<close>)+

lemma mmulti_join_link:
  assumes "A_pos \<noteq> []"
      and "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A) (A_pos @ A_neg) L"
    shows "mmulti_join n A_pos A_neg L = mmulti_join' A_pos A_neg L"
  using assms
proof (induction A_pos A_neg L rule: mmulti_join.induct)
  case (1 n A_pos A_neg L)
  define L_pos where "L_pos = take (length A_pos) L"
  define L_neg where "L_neg = drop (length A_pos) L"
  have L_def: "L = L_pos @ L_neg"
    using L_pos_def L_neg_def by auto
  have lens_match: "length A_pos = length L_pos" "length A_neg = length L_neg"
    using L_pos_def L_neg_def 1(4)[unfolded L_def] by (auto dest: list_all2_lengthD)
  then have lens_sum: "length A_pos + length A_neg = length L"
    by (auto simp add: L_def)
  show ?case
  proof (cases "dominate_True A_pos L_pos")
    case None
    note dom_True = None
    show ?thesis
    proof (cases "dominate_False A_pos L_pos A_neg L_neg")
      case None
      show ?thesis
        by (subst mmulti_join.simps)
           (simp del: dominate_True.simps dominate_False.simps mmulti_join.simps
            mmulti_join'.simps add: Let_def dom_True L_pos_def[symmetric] None
            L_neg_def[symmetric] lens_sum split: option.splits)
    next
      case (Some a)
      then obtain A_zs A_x A_xs A_ws A_y A_ys zs x xs ws y ys where
        dom_False: "dominate_False A_pos L_pos A_neg L_neg =
        Some (((A_zs, A_x, A_xs), A_ws, A_y, A_ys), ((zs, x, xs), ws, y, ys))"
        by (cases a) auto
      note list_all2 = 1(4)[unfolded L_def dominate_False_sound[OF dom_False lens_match]]
      have lens: "length A_ws = length ws" "length A_xs = length xs"
        "length A_ys = length ys" "length A_zs = length zs"
        using dominate_False_sound[OF dom_False lens_match] by auto
      have sub: "A_y \<subseteq> A_x"
        using dominate_False_sound[OF dom_False lens_match] by auto
      have list_all2': "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
        ((A_zs @ A_x # A_xs) @ (A_ws @ A_ys)) ((zs @ join x False y # xs) @ (ws @ ys))"
        using list_all2_opt_False[OF list_all2 lens sub] .
      have tabs: "table n A_x x" "table n A_y y"
        using list_all2 by (auto simp add: lens list_all2_append)
      have bin_join_conv: "join x False y = bin_join n A_x x False A_y y"
        using bin_join_table[OF tabs, symmetric] .
      have mmulti: "mmulti_join n A_pos A_neg L = mmulti_join n (A_zs @ A_x # A_xs) (A_ws @ A_ys)
        ((zs @ bin_join n A_x x False A_y y # xs) @ (ws @ ys))"
        by (subst mmulti_join.simps)
           (simp del: dominate_True.simps dominate_False.simps mmulti_join.simps
            add: Let_def dom_True L_pos_def[symmetric] L_neg_def[symmetric] dom_False lens_sum)
      show ?thesis
        unfolding mmulti
        unfolding L_def dominate_False_sound[OF dom_False lens_match]
        by (rule 1(1)[OF _ L_pos_def L_neg_def dom_True dom_False,
            OF _ _ _ _ _ _ _ _ _ _ _ _ _ list_all2'[unfolded bin_join_conv],
            unfolded mmulti_join'_opt_False[OF list_all2 lens sub, symmetric,
            unfolded bin_join_conv]])
           (auto simp add: lens_sum)
    qed
  next
    case (Some a)
    then obtain A_zs A_x A_xs A_y A_ys zs x xs y ys where dom_True: "dominate_True A_pos L_pos =
      Some ((A_zs, A_x, A_xs, A_y, A_ys), (zs, x, xs, y, ys))"
      by (cases a) auto
    note list_all2 = 1(4)[unfolded L_def dominate_True_sound[OF dom_True lens_match(1)]]
    have lens: "length A_xs = length xs" "length A_ys = length ys" "length A_zs = length zs"
      using dominate_True_sound[OF dom_True lens_match(1)] by auto
    have list_all2': "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
      ((A_zs @ (A_x \<union> A_y) # A_xs @ A_ys) @ A_neg) ((zs @ join x True y # xs @ ys) @ L_neg)"
      using list_all2_opt_True[OF list_all2 lens] .
    have tabs: "table n A_x x" "table n A_y y"
        using list_all2 by (auto simp add: lens list_all2_append)
    have bin_join_conv: "join x True y = bin_join n A_x x True A_y y"
      using bin_join_table[OF tabs, symmetric] .
    have mmulti: "mmulti_join n A_pos A_neg L = mmulti_join n (A_zs @ (A_x \<union> A_y) # A_xs @ A_ys)
      A_neg ((zs @ bin_join n A_x x True A_y y # xs @ ys) @ L_neg)"
      by (subst mmulti_join.simps)
         (simp del: dominate_True.simps dominate_False.simps mmulti_join.simps
          add: Let_def dom_True L_pos_def[symmetric] L_neg_def lens_sum)
    show ?thesis
      unfolding mmulti
      unfolding L_def dominate_True_sound[OF dom_True lens_match(1)]
      by (rule 1(2)[OF _ L_pos_def L_neg_def dom_True,
          OF _ _ _ _ _ _ _ _ _ _ _ list_all2'[unfolded bin_join_conv],
          unfolded mmulti_join'_opt_True[OF list_all2 lens, symmetric,
          unfolded bin_join_conv]])
         (auto simp add: lens_sum)
  qed
qed

lemma mmulti_join_correct:
  assumes "A_pos \<noteq> []"
      and "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A) (A_pos @ A_neg) L"
  shows "z \<in> mmulti_join n A_pos A_neg L \<longleftrightarrow> wf_tuple n (\<Union>A\<in>set A_pos. A) z \<and>
    list_all2 (\<lambda>A X. restrict A z \<in> X) A_pos (take (length A_pos) L) \<and>
    list_all2 (\<lambda>A X. restrict A z \<notin> X) A_neg (drop (length A_pos) L)"
  unfolding mmulti_join_link[OF assms] using mmulti_join'_correct[OF assms] .

(*<*)
end
(*>*)


section \<open>Charts\<close>
theory Chart
  imports Analysis_More
begin

subsection \<open>Definition\<close>

text \<open>A chart on \<open>M\<close> is a homeomorphism from an open subset of \<open>M\<close> to an open subset
  of some Euclidean space \<open>E\<close>. Here \<open>d\<close> and \<open>d'\<close> are open subsets of \<open>M\<close> and \<open>E\<close>, respectively,
  \<open>f: d \<rightarrow> d'\<close> is the mapping, and \<open>f': d' \<rightarrow> d\<close> is the inverse mapping.\<close>
typedef (overloaded) ('a::topological_space, 'e::euclidean_space) chart =
  "{(d::'a set, d'::'e set, f, f').
    open d \<and> open d' \<and> homeomorphism d d' f f'}"
  by (rule exI[where x="({}, {}, (\<lambda>x. undefined), (\<lambda>x. undefined))"]) simp

setup_lifting type_definition_chart

lift_definition apply_chart::"('a::topological_space, 'e::euclidean_space) chart \<Rightarrow> 'a \<Rightarrow> 'e"
  is "\<lambda>(d, d', f, f'). f" .

declare [[coercion apply_chart]]

lift_definition inv_chart::"('a::topological_space, 'e::euclidean_space) chart \<Rightarrow> 'e \<Rightarrow> 'a"
  is "\<lambda>(d, d', f, f'). f'" .

lift_definition domain::"('a::topological_space, 'e::euclidean_space) chart \<Rightarrow> 'a set"
  is "\<lambda>(d, d', f, f'). d" .

lift_definition codomain::"('a::topological_space, 'e::euclidean_space) chart \<Rightarrow> 'e set"
  is "\<lambda>(d, d', f, f'). d'" .

subsection \<open>Properties\<close>

lemma open_domain[intro, simp]: "open (domain c)"
  and open_codomain[intro, simp]: "open (codomain c)"
  and chart_homeomorphism: "homeomorphism (domain c) (codomain c) c (inv_chart c)"
  by (transfer, auto)+

lemma at_within_domain: "at x within domain c = at x" if "x \<in> domain c"
  by (rule at_within_open[OF that open_domain])

lemma at_within_codomain: "at x within codomain c = at x" if "x \<in> codomain c"
  by (rule at_within_open[OF that open_codomain])

lemma
  chart_in_codomain[intro, simp]: "x \<in> domain c \<Longrightarrow> c x \<in> codomain c"
  and inv_chart_inverse[simp]: "x \<in> domain c \<Longrightarrow> inv_chart c (c x) = x"
  and inv_chart_in_domain[intro, simp]:"y \<in> codomain c \<Longrightarrow> inv_chart c y \<in> domain c"
  and chart_inverse_inv_chart[simp]: "y \<in> codomain c \<Longrightarrow> c (inv_chart c y) = y"
  and image_domain_eq: "c ` (domain c) = codomain c"
  and inv_image_codomain_eq[simp]: "inv_chart c ` (codomain c) = domain c"
  and continuous_on_domain: "continuous_on (domain c) c"
  and continuous_on_codomain: "continuous_on (codomain c) (inv_chart c)"
  using chart_homeomorphism[of c]
  by (auto simp: homeomorphism_def)

lemma chart_eqI: "c = d"
  if "domain c = domain d"
    "codomain c = codomain d"
    "\<And>x. c x = d x"
    "\<And>x. inv_chart c x = inv_chart  d x"
  using that
  by transfer auto

lemmas continuous_on_chart[continuous_intros] =
  continuous_on_compose2[OF continuous_on_domain]
  continuous_on_compose2[OF continuous_on_codomain]

lemma continuous_apply_chart: "continuous (at x within X) c" if "x \<in> domain c"
  apply (rule continuous_at_imp_continuous_within)
  using continuous_on_domain[of c] that at_within_domain[OF that]
  by (auto simp: continuous_on_eq_continuous_within)

lemma continuous_inv_chart: "continuous (at x within X) (inv_chart c)" if "x \<in> codomain c"
  apply (rule continuous_at_imp_continuous_within)
  using continuous_on_codomain[of c] that at_within_codomain[OF that]
  by (auto simp: continuous_on_eq_continuous_within)

lemmas apply_chart_tendsto[tendsto_intros] = isCont_tendsto_compose[OF continuous_apply_chart, rotated]
lemmas inv_chart_tendsto[tendsto_intros] = isCont_tendsto_compose[OF continuous_inv_chart, rotated]

lemma continuous_within_compose2':
  "continuous (at (f x) within t) g \<Longrightarrow> f ` s \<subseteq> t \<Longrightarrow>
    continuous (at x within s) f \<Longrightarrow>
    continuous (at x within s) (\<lambda>x. g (f x))"
  by (simp add: continuous_within_compose2 continuous_within_subset)

lemmas continuous_chart[continuous_intros] =
  continuous_within_compose2'[OF continuous_apply_chart]
  continuous_within_compose2'[OF continuous_inv_chart]

lemma continuous_on_chart_inv:
  assumes "continuous_on s (apply_chart c o f)"
    "f ` s \<subseteq> domain c"
  shows "continuous_on s f"
proof -
  have "continuous_on s (inv_chart c o apply_chart c o f)"
    using assms by (auto intro!: continuous_on_chart(2))
  moreover have "\<And>x. x \<in> s \<Longrightarrow> (inv_chart c o apply_chart c o f) x = f x"
    using assms by auto
  ultimately show ?thesis by auto
qed

lemma continuous_on_chart_inv':
  assumes "continuous_on (apply_chart c ` s) (f o inv_chart c)"
    "s \<subseteq> domain c"
  shows "continuous_on s f"
proof -
  have "continuous_on s (apply_chart c)"
    using assms continuous_on_domain continuous_on_subset by blast
  then have "continuous_on s (f o inv_chart c o apply_chart c)"
    apply (rule continuous_on_compose) using assms by auto
  moreover have "(f o inv_chart c o apply_chart c) x = f x" if "x \<in> s" for x
    using assms that by auto
  ultimately show ?thesis by auto
qed

lemma inj_on_apply_chart: "inj_on (apply_chart f) (domain f)"
  by (auto simp: intro!: inj_on_inverseI[where g="inv_chart f"])

lemma apply_chart_Int: "f ` (X \<inter> Y) = f ` X \<inter> f ` Y" if "X \<subseteq> domain f" "Y \<subseteq> domain f"
  using inj_on_apply_chart that
  by (rule inj_on_image_Int)

lemma chart_image_eq_vimage: "c ` X = inv_chart c -` X \<inter> codomain c"
  if "X \<subseteq> domain c"
  using that
  by force

lemma open_chart_image[simp, intro]: "open (c ` X)"
  if "open X" "X \<subseteq> domain c"
proof -
  have "c ` X = inv_chart c -` X \<inter> codomain c"
    using that(2)
    by (rule chart_image_eq_vimage)
  also have "open \<dots>"
    using that
    by (metis continuous_on_codomain continuous_on_open_vimage open_codomain)
  finally show ?thesis .
qed

lemma open_inv_chart_image[simp, intro]: "open (inv_chart c ` X)"
  if "open X" "X \<subseteq> codomain c"
proof -
  have "inv_chart c ` X = c -` X \<inter> domain c"
    using that(2)
    apply (auto simp: )
    using image_iff by fastforce
  also have "open \<dots>"
    using that
    by (metis continuous_on_domain continuous_on_open_vimage open_domain)
  finally show ?thesis .
qed

lemma homeomorphism_UNIV_imp_open_map:
  "homeomorphism UNIV UNIV p p' \<Longrightarrow> open f' \<Longrightarrow> open (p ` f')"
  by (auto dest: homeomorphism_imp_open_map[where U=f'])

subsection \<open>Restriction\<close>

lemma homeomorphism_restrict:
  "homeomorphism (a \<inter> s) (b \<inter> f' -` s) f f'" if "homeomorphism a b f f'"
  using that
  by (fastforce simp: homeomorphism_def intro: continuous_on_subset intro!: imageI)

lift_definition restrict_chart::"'a set \<Rightarrow> ('a::t2_space, 'e::euclidean_space) chart \<Rightarrow> ('a, 'e) chart"
  is "\<lambda>S. \<lambda>(d, d', f, f'). if open S then (d \<inter> S, d' \<inter> f' -` S, f, f') else ({}, {}, f, f')"
  by (auto simp: split: if_splits intro!: open_continuous_vimage' homeomorphism_restrict
      intro: homeomorphism_cont2 homeomorphism_cont1 )

lemma restrict_chart_restrict_chart:
  "restrict_chart X (restrict_chart Y c) = restrict_chart (X \<inter> Y) c"
  if "open X" "open Y"
  using that
  by transfer auto

lemma domain_restrict_chart[simp]: "open S \<Longrightarrow> domain (restrict_chart S c) = domain c \<inter> S"
  and domain_restrict_chart_if: "domain (restrict_chart S c) = (if open S then domain c \<inter> S else {})"
  and codomain_restrict_chart[simp]: "open S \<Longrightarrow> codomain (restrict_chart S c) = codomain c \<inter> inv_chart c -` S"
  and codomain_restrict_chart_if: "codomain (restrict_chart S c) = (if open S then codomain c \<inter> inv_chart c -` S else {})"
  and apply_chart_restrict_chart[simp]: "apply_chart (restrict_chart S c) = apply_chart c"
  and inv_chart_restrict_chart[simp]: "inv_chart (restrict_chart S c) = inv_chart c"
  by (transfer, auto)+

subsection \<open>Composition\<close>

lift_definition compose_chart::"('e\<Rightarrow>'e) \<Rightarrow> ('e\<Rightarrow>'e) \<Rightarrow>
  ('a::topological_space, 'e::euclidean_space) chart \<Rightarrow> ('a, 'e) chart"
  is "\<lambda>p p'. \<lambda>(d, d', f, f'). if homeomorphism UNIV UNIV p p' then (d, p ` d', p o f, f' o p')
    else ({}, {}, f, f')"
  by (auto split: if_splits)
    (auto intro: homeomorphism_UNIV_imp_open_map homeomorphism_compose homeomorphism_of_subsets)

lemma compose_chart_apply_chart[simp]: "apply_chart (compose_chart p p' c) = p o apply_chart c"
  and compose_chart_inv_chart[simp]: "inv_chart (compose_chart p p' c) = inv_chart c o p'"
  and domain_compose_chart[simp]: "domain (compose_chart p p' c) = domain c"
  and codomain_compose_chart[simp]: "codomain (compose_chart p p' c) = p ` codomain c"
  if "homeomorphism UNIV UNIV p p'"
  using that by (transfer, auto)+

end


theory Ltake_lzip
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

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

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

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

codatatype ENat = is_zero: EZ | ESuc (epred: ENat)

primcorec ltake :: "ENat \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist"
where
  "is_zero n \<or> lnull xs \<Longrightarrow> lnull (ltake n xs)"
| "lhd (ltake n xs) = lhd xs"
| "ltl (ltake n xs) = ltake (epred n) (ltl xs)"

hipster lzip
lemma lemma_a [thy_expl]: "ltake y (ltake y z) = ltake y z"
  apply (coinduction  arbitrary: y z rule: Ltake_lzip.Llist.coinduct_strong)
  apply simp
  by blast

lemma lemma_aa [thy_expl]: "ltl (ltake (ESuc y) z) = ltake y (ltl z)"
apply (coinduction  arbitrary: y z rule: Ltake_lzip.Llist.coinduct_strong)
apply simp
by (metis ENat.discI(2) ENat.sel Llist.sel(2) lnull_def ltake.disc_iff(2) ltake.simps(3) ltake.simps(4))

lemma lemma_ab [thy_expl]: "ltake z (ltake y x2) = ltake y (ltake z x2)"
apply (coinduction  arbitrary: x2 y z rule: Ltake_lzip.Llist.coinduct_strong)
apply simp
by blast

lemma lemma_ac [thy_expl]: "ltake y (ltake (ESuc y) z) = ltake y (ltake y z)"
apply (coinduction  arbitrary: y z rule: Ltake_lzip.Llist.coinduct_strong)
apply simp
by force

lemma lemma_ad [thy_expl]: "ltake (ESuc z) (LCons y x2) = LCons y (ltake z x2)"
apply (coinduction  arbitrary: x2 y z rule: Ltake_lzip.Llist.coinduct_strong)
by simp

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

lemma unknown [thy_expl]: "ltake (ESuc y) (ltl (ltl z)) = ltl (ltl z)"
oops

theorem ltake_lzip: "ltake n (lzip xs ys) = lzip (ltake n xs) (ltake n ys)"
by hipster_coinduct_sledgehammer
end


theory ExF014
  imports Main
begin

lemma "\<not>(\<exists>x. P x) \<longleftrightarrow> (\<forall>x. \<not>P x)"
proof -
  {
    assume "\<not>(\<exists>x. P x)"
    {
      assume "\<not>(\<forall>x. \<not>P x)"
      {
        fix aa
        {
          assume "P aa"
          hence "\<exists>x. P x" by (rule exI)
          with \<open>\<not>(\<exists>x. P x )\<close> have False by contradiction
        }
        hence "\<not>P aa" by (rule notI)
      }
      hence "\<forall>x. \<not>P x" by (rule allI)
      with \<open>\<not>(\<forall>x. \<not>P x)\<close> have False by contradiction
    }
    hence "\<not>\<not>(\<forall>x. \<not>P x)" by (rule notI)
    hence "\<forall>x. \<not>P x" by (rule notnotD)
  }

  moreover
  {
    assume a:"\<forall>x. \<not>P x"
    {
      assume "\<exists>x. P x"
      {
        fix aa
        assume "P aa"
        from \<open>\<forall>x. \<not>P x\<close> have "\<not>P aa" by (rule allE)
        with \<open>P aa\<close> have False by contradiction
      }
      with \<open>\<exists>x. P x\<close> have False by (rule exE)
    }
    hence "\<not>(\<exists>x. P x)" by (rule notI)
  }
  ultimately show ?thesis by (rule iffI)
qed


chapter \<open>Homework 3\<close>
theory Homework3_1
imports Main
begin

  (*
    This file is intended to be viewed within the Isabelle/jEdit IDE.
    In a standard text-editor, it is pretty unreadable!
  *)

  (*
    HOMEWORK #3 PART I/II
    RELEASED: Tue, Aug 26 2017
    DUE:      Wed, Feb 4, 2017, 11:59pm

    To be submitted via canvas.
  *)

section \<open>General Hints\<close>
(*
  The best way to work on this homework is to fill in the missing gaps in this file.

  Try to go for simple function definitions, as simple definitions mean simple proofs!
  In particular, do not go for a more complicated definition only b/c it may be more efficient!

*)

section \<open>Arithmetic Expressions with Side-Effects\<close>

text \<open>Model arithmetic expressions that contain
  constants, variables, addition, and the prefix \<open>++\<close>-operator known from
  C++ and Java. The expression \<open>++x\<close> where \<open>x\<close> must be a variable,
  increments \<open>x\<close> and evaluates to the incremented value of \<open>x\<close>.
\<close>
type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

text {* A little syntax magic to write larger states compactly: *}

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

datatype aexp = N val | V vname | Inc vname | Plus aexp aexp

(* Evaluation now returns a pair of the value and the new state *)
fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val \<times> state" where
  "aval _ _ = undefined" (* Replace by meaningful equations *)

(* The optimizer remains unchanged. There is no optimization for pre-increment. *)
fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"

lemma aval_plus[simp]:
  "aval (plus a1 a2) s = aval (Plus a1 a2) s"
apply(induction a1 a2 rule: plus.induct)
apply simp_all (* just for a change from auto *)
done

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Inc x) = Inc x" |
"asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)"

(* Anyway, the proof will (slightly) change. Do the proof! *)
theorem aval_asimp[simp]:
  "aval (asimp a) s = aval a s"
  oops

section \<open>Compiling with Side-Effect\<close>

(* We use the stack-machine with \<open>STORE x\<close> instruction from the tutorial:*)

datatype instr = LOADI val | LOAD vname | STORE vname | ADD
type_synonym stack = "val list"

fun exec1  :: "instr \<Rightarrow> (state \<times> stack) \<Rightarrow> state \<times> stack" where
  "exec1 (LOADI n) (s, stk)  =  (s, n # stk)"
| "exec1 (LOAD x) (s, stk)  =  (s, s(x) # stk)"
| "exec1 (STORE x) (s, a#stk) = (s(x:=a), stk)"
| "exec1 (STORE _) _ = undefined"
| "exec1 ADD (s, a#b#stk) = (s,(a+b)#stk)"
| "exec1 ADD _ = undefined"

fun exec :: "instr list \<Rightarrow> (state \<times> stack) \<Rightarrow> state \<times> stack" where
"exec [] sxstk = sxstk" |
"exec (i#is) sxstk = exec is (exec1 i sxstk)"

lemma exec_append[simp]:
  "exec (is1@is2) sxstk = exec is2 (exec is1 sxstk)"
apply(induction is1 arbitrary: sxstk)
apply (auto)
done

hide_const (open) comp

(* Implement a compiler! Hint: This is quite similar to the tutorial! *)
fun comp :: "aexp \<Rightarrow> instr list" where
"comp _ = undefined"

(* Prove it correct! Hint: The proof is quite similar to the tutorial! *)
theorem exec_comp:
  "aval a s = (v,s') \<Longrightarrow> exec (comp a) (s,stk) = (s',v#stk)"
  oops

end


(*  Title:      HOL/Conditionally_Complete_Lattices.thy
    Author:     Amine Chaieb and L C Paulson, University of Cambridge
    Author:     Johannes Hölzl, TU München
    Author:     Luke S. Serafin, Carnegie Mellon University
*)

section \<open>Conditionally-complete Lattices\<close>

theory Conditionally_Complete_Lattices
imports Finite_Set Lattices_Big Set_Interval
begin

locale preordering_bdd = preordering
begin

definition bdd :: \<open>'a set \<Rightarrow> bool\<close>
  where unfold: \<open>bdd A \<longleftrightarrow> (\<exists>M. \<forall>x \<in> A. x \<^bold>\<le> M)\<close>

lemma empty [simp, intro]:
  \<open>bdd {}\<close>
  by (simp add: unfold)

lemma I [intro]:
  \<open>bdd A\<close> if \<open>\<And>x. x \<in> A \<Longrightarrow> x \<^bold>\<le> M\<close>
  using that by (auto simp add: unfold)

lemma E:
  assumes \<open>bdd A\<close>
  obtains M where \<open>\<And>x. x \<in> A \<Longrightarrow> x \<^bold>\<le> M\<close>
  using assms that by (auto simp add: unfold)

lemma I2:
  \<open>bdd (f ` A)\<close> if \<open>\<And>x. x \<in> A \<Longrightarrow> f x \<^bold>\<le> M\<close>
  using that by (auto simp add: unfold)

lemma mono:
  \<open>bdd A\<close> if \<open>bdd B\<close> \<open>A \<subseteq> B\<close>
  using that by (auto simp add: unfold)

lemma Int1 [simp]:
  \<open>bdd (A \<inter> B)\<close> if \<open>bdd A\<close>
  using mono that by auto

lemma Int2 [simp]:
  \<open>bdd (A \<inter> B)\<close> if \<open>bdd B\<close>
  using mono that by auto

end

subsection \<open>Preorders\<close>

context preorder
begin

sublocale bdd_above: preordering_bdd \<open>(\<le>)\<close> \<open>(<)\<close>
  defines bdd_above_primitive_def: bdd_above = bdd_above.bdd ..

sublocale bdd_below: preordering_bdd \<open>(\<ge>)\<close> \<open>(>)\<close>
  defines bdd_below_primitive_def: bdd_below = bdd_below.bdd ..

lemma bdd_above_def: \<open>bdd_above A \<longleftrightarrow> (\<exists>M. \<forall>x \<in> A. x \<le> M)\<close>
  by (fact bdd_above.unfold)

lemma bdd_below_def: \<open>bdd_below A \<longleftrightarrow> (\<exists>M. \<forall>x \<in> A. M \<le> x)\<close>
  by (fact bdd_below.unfold)

lemma bdd_aboveI: "(\<And>x. x \<in> A \<Longrightarrow> x \<le> M) \<Longrightarrow> bdd_above A"
  by (fact bdd_above.I)

lemma bdd_belowI: "(\<And>x. x \<in> A \<Longrightarrow> m \<le> x) \<Longrightarrow> bdd_below A"
  by (fact bdd_below.I)

lemma bdd_aboveI2: "(\<And>x. x \<in> A \<Longrightarrow> f x \<le> M) \<Longrightarrow> bdd_above (f`A)"
  by (fact bdd_above.I2)

lemma bdd_belowI2: "(\<And>x. x \<in> A \<Longrightarrow> m \<le> f x) \<Longrightarrow> bdd_below (f`A)"
  by (fact bdd_below.I2)

lemma bdd_above_empty: "bdd_above {}"
  by (fact bdd_above.empty)

lemma bdd_below_empty: "bdd_below {}"
  by (fact bdd_below.empty)

lemma bdd_above_mono: "bdd_above B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> bdd_above A"
  by (fact bdd_above.mono)

lemma bdd_below_mono: "bdd_below B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> bdd_below A"
  by (fact bdd_below.mono)

lemma bdd_above_Int1: "bdd_above A \<Longrightarrow> bdd_above (A \<inter> B)"
  by (fact bdd_above.Int1)

lemma bdd_above_Int2: "bdd_above B \<Longrightarrow> bdd_above (A \<inter> B)"
  by (fact bdd_above.Int2)

lemma bdd_below_Int1: "bdd_below A \<Longrightarrow> bdd_below (A \<inter> B)"
  by (fact bdd_below.Int1)

lemma bdd_below_Int2: "bdd_below B \<Longrightarrow> bdd_below (A \<inter> B)"
  by (fact bdd_below.Int2)

lemma bdd_above_Ioo [simp, intro]: "bdd_above {a <..< b}"
  by (auto simp add: bdd_above_def intro!: exI[of _ b] less_imp_le)

lemma bdd_above_Ico [simp, intro]: "bdd_above {a ..< b}"
  by (auto simp add: bdd_above_def intro!: exI[of _ b] less_imp_le)

lemma bdd_above_Iio [simp, intro]: "bdd_above {..< b}"
  by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)

lemma bdd_above_Ioc [simp, intro]: "bdd_above {a <.. b}"
  by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)

lemma bdd_above_Icc [simp, intro]: "bdd_above {a .. b}"
  by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)

lemma bdd_above_Iic [simp, intro]: "bdd_above {.. b}"
  by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)

lemma bdd_below_Ioo [simp, intro]: "bdd_below {a <..< b}"
  by (auto simp add: bdd_below_def intro!: exI[of _ a] less_imp_le)

lemma bdd_below_Ioc [simp, intro]: "bdd_below {a <.. b}"
  by (auto simp add: bdd_below_def intro!: exI[of _ a] less_imp_le)

lemma bdd_below_Ioi [simp, intro]: "bdd_below {a <..}"
  by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)

lemma bdd_below_Ico [simp, intro]: "bdd_below {a ..< b}"
  by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)

lemma bdd_below_Icc [simp, intro]: "bdd_below {a .. b}"
  by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)

lemma bdd_below_Ici [simp, intro]: "bdd_below {a ..}"
  by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)

end

context order_top
begin

lemma bdd_above_top [simp, intro!]: "bdd_above A"
  by (rule bdd_aboveI [of _ top]) simp

end

context order_bot
begin

lemma bdd_below_bot [simp, intro!]: "bdd_below A"
  by (rule bdd_belowI [of _ bot]) simp

end

lemma bdd_above_image_mono: "mono f \<Longrightarrow> bdd_above A \<Longrightarrow> bdd_above (f`A)"
  by (auto simp: bdd_above_def mono_def)

lemma bdd_below_image_mono: "mono f \<Longrightarrow> bdd_below A \<Longrightarrow> bdd_below (f`A)"
  by (auto simp: bdd_below_def mono_def)

lemma bdd_above_image_antimono: "antimono f \<Longrightarrow> bdd_below A \<Longrightarrow> bdd_above (f`A)"
  by (auto simp: bdd_above_def bdd_below_def antimono_def)

lemma bdd_below_image_antimono: "antimono f \<Longrightarrow> bdd_above A \<Longrightarrow> bdd_below (f`A)"
  by (auto simp: bdd_above_def bdd_below_def antimono_def)

lemma
  fixes X :: "'a::ordered_ab_group_add set"
  shows bdd_above_uminus[simp]: "bdd_above (uminus ` X) \<longleftrightarrow> bdd_below X"
    and bdd_below_uminus[simp]: "bdd_below (uminus ` X) \<longleftrightarrow> bdd_above X"
  using bdd_above_image_antimono[of uminus X] bdd_below_image_antimono[of uminus "uminus`X"]
  using bdd_below_image_antimono[of uminus X] bdd_above_image_antimono[of uminus "uminus`X"]
  by (auto simp: antimono_def image_image)

subsection \<open>Lattices\<close>

context lattice
begin

lemma bdd_above_insert [simp]: "bdd_above (insert a A) = bdd_above A"
  by (auto simp: bdd_above_def intro: le_supI2 sup_ge1)

lemma bdd_below_insert [simp]: "bdd_below (insert a A) = bdd_below A"
  by (auto simp: bdd_below_def intro: le_infI2 inf_le1)

lemma bdd_finite [simp]:
  assumes "finite A" shows bdd_above_finite: "bdd_above A" and bdd_below_finite: "bdd_below A"
  using assms by (induct rule: finite_induct, auto)

lemma bdd_above_Un [simp]: "bdd_above (A \<union> B) = (bdd_above A \<and> bdd_above B)"
proof
  assume "bdd_above (A \<union> B)"
  thus "bdd_above A \<and> bdd_above B" unfolding bdd_above_def by auto
next
  assume "bdd_above A \<and> bdd_above B"
  then obtain a b where "\<forall>x\<in>A. x \<le> a" "\<forall>x\<in>B. x \<le> b" unfolding bdd_above_def by auto
  hence "\<forall>x \<in> A \<union> B. x \<le> sup a b" by (auto intro: Un_iff le_supI1 le_supI2)
  thus "bdd_above (A \<union> B)" unfolding bdd_above_def ..
qed

lemma bdd_below_Un [simp]: "bdd_below (A \<union> B) = (bdd_below A \<and> bdd_below B)"
proof
  assume "bdd_below (A \<union> B)"
  thus "bdd_below A \<and> bdd_below B" unfolding bdd_below_def by auto
next
  assume "bdd_below A \<and> bdd_below B"
  then obtain a b where "\<forall>x\<in>A. a \<le> x" "\<forall>x\<in>B. b \<le> x" unfolding bdd_below_def by auto
  hence "\<forall>x \<in> A \<union> B. inf a b \<le> x" by (auto intro: Un_iff le_infI1 le_infI2)
  thus "bdd_below (A \<union> B)" unfolding bdd_below_def ..
qed

lemma bdd_above_image_sup[simp]:
  "bdd_above ((\<lambda>x. sup (f x) (g x)) ` A) \<longleftrightarrow> bdd_above (f`A) \<and> bdd_above (g`A)"
by (auto simp: bdd_above_def intro: le_supI1 le_supI2)

lemma bdd_below_image_inf[simp]:
  "bdd_below ((\<lambda>x. inf (f x) (g x)) ` A) \<longleftrightarrow> bdd_below (f`A) \<and> bdd_below (g`A)"
by (auto simp: bdd_below_def intro: le_infI1 le_infI2)

lemma bdd_below_UN[simp]: "finite I \<Longrightarrow> bdd_below (\<Union>i\<in>I. A i) = (\<forall>i \<in> I. bdd_below (A i))"
by (induction I rule: finite.induct) auto

lemma bdd_above_UN[simp]: "finite I \<Longrightarrow> bdd_above (\<Union>i\<in>I. A i) = (\<forall>i \<in> I. bdd_above (A i))"
by (induction I rule: finite.induct) auto

end

text \<open>

To avoid name classes with the \<^class>\<open>complete_lattice\<close>-class we prefix \<^const>\<open>Sup\<close> and
\<^const>\<open>Inf\<close> in theorem names with c.

\<close>

subsection \<open>Conditionally complete lattices\<close>

class conditionally_complete_lattice = lattice + Sup + Inf +
  assumes cInf_lower: "x \<in> X \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X \<le> x"
    and cInf_greatest: "X \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> z \<le> Inf X"
  assumes cSup_upper: "x \<in> X \<Longrightarrow> bdd_above X \<Longrightarrow> x \<le> Sup X"
    and cSup_least: "X \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup X \<le> z"
begin

lemma cSup_upper2: "x \<in> X \<Longrightarrow> y \<le> x \<Longrightarrow> bdd_above X \<Longrightarrow> y \<le> Sup X"
  by (metis cSup_upper order_trans)

lemma cInf_lower2: "x \<in> X \<Longrightarrow> x \<le> y \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X \<le> y"
  by (metis cInf_lower order_trans)

lemma cSup_mono: "B \<noteq> {} \<Longrightarrow> bdd_above A \<Longrightarrow> (\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. b \<le> a) \<Longrightarrow> Sup B \<le> Sup A"
  by (metis cSup_least cSup_upper2)

lemma cInf_mono: "B \<noteq> {} \<Longrightarrow> bdd_below A \<Longrightarrow> (\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. a \<le> b) \<Longrightarrow> Inf A \<le> Inf B"
  by (metis cInf_greatest cInf_lower2)

lemma cSup_subset_mono: "A \<noteq> {} \<Longrightarrow> bdd_above B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> Sup A \<le> Sup B"
  by (metis cSup_least cSup_upper subsetD)

lemma cInf_superset_mono: "A \<noteq> {} \<Longrightarrow> bdd_below B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> Inf B \<le> Inf A"
  by (metis cInf_greatest cInf_lower subsetD)

lemma cSup_eq_maximum: "z \<in> X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup X = z"
  by (intro order.antisym cSup_upper[of z X] cSup_least[of X z]) auto

lemma cInf_eq_minimum: "z \<in> X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> Inf X = z"
  by (intro order.antisym cInf_lower[of z X] cInf_greatest[of X z]) auto

lemma cSup_le_iff: "S \<noteq> {} \<Longrightarrow> bdd_above S \<Longrightarrow> Sup S \<le> a \<longleftrightarrow> (\<forall>x\<in>S. x \<le> a)"
  by (metis order_trans cSup_upper cSup_least)

lemma le_cInf_iff: "S \<noteq> {} \<Longrightarrow> bdd_below S \<Longrightarrow> a \<le> Inf S \<longleftrightarrow> (\<forall>x\<in>S. a \<le> x)"
  by (metis order_trans cInf_lower cInf_greatest)

lemma cSup_eq_non_empty:
  assumes 1: "X \<noteq> {}"
  assumes 2: "\<And>x. x \<in> X \<Longrightarrow> x \<le> a"
  assumes 3: "\<And>y. (\<And>x. x \<in> X \<Longrightarrow> x \<le> y) \<Longrightarrow> a \<le> y"
  shows "Sup X = a"
  by (intro 3 1 order.antisym cSup_least) (auto intro: 2 1 cSup_upper)

lemma cInf_eq_non_empty:
  assumes 1: "X \<noteq> {}"
  assumes 2: "\<And>x. x \<in> X \<Longrightarrow> a \<le> x"
  assumes 3: "\<And>y. (\<And>x. x \<in> X \<Longrightarrow> y \<le> x) \<Longrightarrow> y \<le> a"
  shows "Inf X = a"
  by (intro 3 1 order.antisym cInf_greatest) (auto intro: 2 1 cInf_lower)

lemma cInf_cSup: "S \<noteq> {} \<Longrightarrow> bdd_below S \<Longrightarrow> Inf S = Sup {x. \<forall>s\<in>S. x \<le> s}"
  by (rule cInf_eq_non_empty) (auto intro!: cSup_upper cSup_least simp: bdd_below_def)

lemma cSup_cInf: "S \<noteq> {} \<Longrightarrow> bdd_above S \<Longrightarrow> Sup S = Inf {x. \<forall>s\<in>S. s \<le> x}"
  by (rule cSup_eq_non_empty) (auto intro!: cInf_lower cInf_greatest simp: bdd_above_def)

lemma cSup_insert: "X \<noteq> {} \<Longrightarrow> bdd_above X \<Longrightarrow> Sup (insert a X) = sup a (Sup X)"
  by (intro cSup_eq_non_empty) (auto intro: le_supI2 cSup_upper cSup_least)

lemma cInf_insert: "X \<noteq> {} \<Longrightarrow> bdd_below X \<Longrightarrow> Inf (insert a X) = inf a (Inf X)"
  by (intro cInf_eq_non_empty) (auto intro: le_infI2 cInf_lower cInf_greatest)

lemma cSup_singleton [simp]: "Sup {x} = x"
  by (intro cSup_eq_maximum) auto

lemma cInf_singleton [simp]: "Inf {x} = x"
  by (intro cInf_eq_minimum) auto

lemma cSup_insert_If:  "bdd_above X \<Longrightarrow> Sup (insert a X) = (if X = {} then a else sup a (Sup X))"
  using cSup_insert[of X] by simp

lemma cInf_insert_If: "bdd_below X \<Longrightarrow> Inf (insert a X) = (if X = {} then a else inf a (Inf X))"
  using cInf_insert[of X] by simp

lemma le_cSup_finite: "finite X \<Longrightarrow> x \<in> X \<Longrightarrow> x \<le> Sup X"
proof (induct X arbitrary: x rule: finite_induct)
  case (insert x X y) then show ?case
    by (cases "X = {}") (auto simp: cSup_insert intro: le_supI2)
qed simp

lemma cInf_le_finite: "finite X \<Longrightarrow> x \<in> X \<Longrightarrow> Inf X \<le> x"
proof (induct X arbitrary: x rule: finite_induct)
  case (insert x X y) then show ?case
    by (cases "X = {}") (auto simp: cInf_insert intro: le_infI2)
qed simp

lemma cSup_eq_Sup_fin: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Sup X = Sup_fin X"
  by (induct X rule: finite_ne_induct) (simp_all add: cSup_insert)

lemma cInf_eq_Inf_fin: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Inf X = Inf_fin X"
  by (induct X rule: finite_ne_induct) (simp_all add: cInf_insert)

lemma cSup_atMost[simp]: "Sup {..x} = x"
  by (auto intro!: cSup_eq_maximum)

lemma cSup_greaterThanAtMost[simp]: "y < x \<Longrightarrow> Sup {y<..x} = x"
  by (auto intro!: cSup_eq_maximum)

lemma cSup_atLeastAtMost[simp]: "y \<le> x \<Longrightarrow> Sup {y..x} = x"
  by (auto intro!: cSup_eq_maximum)

lemma cInf_atLeast[simp]: "Inf {x..} = x"
  by (auto intro!: cInf_eq_minimum)

lemma cInf_atLeastLessThan[simp]: "y < x \<Longrightarrow> Inf {y..<x} = y"
  by (auto intro!: cInf_eq_minimum)

lemma cInf_atLeastAtMost[simp]: "y \<le> x \<Longrightarrow> Inf {y..x} = y"
  by (auto intro!: cInf_eq_minimum)

lemma cINF_lower: "bdd_below (f ` A) \<Longrightarrow> x \<in> A \<Longrightarrow> \<Sqinter>(f ` A) \<le> f x"
  using cInf_lower [of _ "f ` A"] by simp

lemma cINF_greatest: "A \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> m \<le> f x) \<Longrightarrow> m \<le> \<Sqinter>(f ` A)"
  using cInf_greatest [of "f ` A"] by auto

lemma cSUP_upper: "x \<in> A \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> f x \<le> \<Squnion>(f ` A)"
  using cSup_upper [of _ "f ` A"] by simp

lemma cSUP_least: "A \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<le> M) \<Longrightarrow> \<Squnion>(f ` A) \<le> M"
  using cSup_least [of "f ` A"] by auto

lemma cINF_lower2: "bdd_below (f ` A) \<Longrightarrow> x \<in> A \<Longrightarrow> f x \<le> u \<Longrightarrow> \<Sqinter>(f ` A) \<le> u"
  by (auto intro: cINF_lower order_trans)

lemma cSUP_upper2: "bdd_above (f ` A) \<Longrightarrow> x \<in> A \<Longrightarrow> u \<le> f x \<Longrightarrow> u \<le> \<Squnion>(f ` A)"
  by (auto intro: cSUP_upper order_trans)

lemma cSUP_const [simp]: "A \<noteq> {} \<Longrightarrow> (\<Squnion>x\<in>A. c) = c"
  by (intro order.antisym cSUP_least) (auto intro: cSUP_upper)

lemma cINF_const [simp]: "A \<noteq> {} \<Longrightarrow> (\<Sqinter>x\<in>A. c) = c"
  by (intro order.antisym cINF_greatest) (auto intro: cINF_lower)

lemma le_cINF_iff: "A \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> u \<le> \<Sqinter>(f ` A) \<longleftrightarrow> (\<forall>x\<in>A. u \<le> f x)"
  by (metis cINF_greatest cINF_lower order_trans)

lemma cSUP_le_iff: "A \<noteq> {} \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> \<Squnion>(f ` A) \<le> u \<longleftrightarrow> (\<forall>x\<in>A. f x \<le> u)"
  by (metis cSUP_least cSUP_upper order_trans)

lemma less_cINF_D: "bdd_below (f`A) \<Longrightarrow> y < (\<Sqinter>i\<in>A. f i) \<Longrightarrow> i \<in> A \<Longrightarrow> y < f i"
  by (metis cINF_lower less_le_trans)

lemma cSUP_lessD: "bdd_above (f`A) \<Longrightarrow> (\<Squnion>i\<in>A. f i) < y \<Longrightarrow> i \<in> A \<Longrightarrow> f i < y"
  by (metis cSUP_upper le_less_trans)

lemma cINF_insert: "A \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> \<Sqinter>(f ` insert a A) = inf (f a) (\<Sqinter>(f ` A))"
  by (simp add: cInf_insert)

lemma cSUP_insert: "A \<noteq> {} \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> \<Squnion>(f ` insert a A) = sup (f a) (\<Squnion>(f ` A))"
  by (simp add: cSup_insert)

lemma cINF_mono: "B \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> (\<And>m. m \<in> B \<Longrightarrow> \<exists>n\<in>A. f n \<le> g m) \<Longrightarrow> \<Sqinter>(f ` A) \<le> \<Sqinter>(g ` B)"
  using cInf_mono [of "g ` B" "f ` A"] by auto

lemma cSUP_mono: "A \<noteq> {} \<Longrightarrow> bdd_above (g ` B) \<Longrightarrow> (\<And>n. n \<in> A \<Longrightarrow> \<exists>m\<in>B. f n \<le> g m) \<Longrightarrow> \<Squnion>(f ` A) \<le> \<Squnion>(g ` B)"
  using cSup_mono [of "f ` A" "g ` B"] by auto

lemma cINF_superset_mono: "A \<noteq> {} \<Longrightarrow> bdd_below (g ` B) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> g x \<le> f x) \<Longrightarrow> \<Sqinter>(g ` B) \<le> \<Sqinter>(f ` A)"
  by (rule cINF_mono) auto

lemma cSUP_subset_mono:
  "\<lbrakk>A \<noteq> {}; bdd_above (g ` B); A \<subseteq> B; \<And>x. x \<in> A \<Longrightarrow> f x \<le> g x\<rbrakk> \<Longrightarrow> \<Squnion> (f ` A) \<le> \<Squnion> (g ` B)"
  by (rule cSUP_mono) auto

lemma less_eq_cInf_inter: "bdd_below A \<Longrightarrow> bdd_below B \<Longrightarrow> A \<inter> B \<noteq> {} \<Longrightarrow> inf (Inf A) (Inf B) \<le> Inf (A \<inter> B)"
  by (metis cInf_superset_mono lattice_class.inf_sup_ord(1) le_infI1)

lemma cSup_inter_less_eq: "bdd_above A \<Longrightarrow> bdd_above B \<Longrightarrow> A \<inter> B \<noteq> {} \<Longrightarrow> Sup (A \<inter> B) \<le> sup (Sup A) (Sup B) "
  by (metis cSup_subset_mono lattice_class.inf_sup_ord(1) le_supI1)

lemma cInf_union_distrib: "A \<noteq> {} \<Longrightarrow> bdd_below A \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_below B \<Longrightarrow> Inf (A \<union> B) = inf (Inf A) (Inf B)"
  by (intro order.antisym le_infI cInf_greatest cInf_lower) (auto intro: le_infI1 le_infI2 cInf_lower)

lemma cINF_union: "A \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_below (f ` B) \<Longrightarrow> \<Sqinter> (f ` (A \<union> B)) = \<Sqinter> (f ` A) \<sqinter> \<Sqinter> (f ` B)"
  using cInf_union_distrib [of "f ` A" "f ` B"] by (simp add: image_Un)

lemma cSup_union_distrib: "A \<noteq> {} \<Longrightarrow> bdd_above A \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_above B \<Longrightarrow> Sup (A \<union> B) = sup (Sup A) (Sup B)"
  by (intro order.antisym le_supI cSup_least cSup_upper) (auto intro: le_supI1 le_supI2 cSup_upper)

lemma cSUP_union: "A \<noteq> {} \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_above (f ` B) \<Longrightarrow> \<Squnion> (f ` (A \<union> B)) = \<Squnion> (f ` A) \<squnion> \<Squnion> (f ` B)"
  using cSup_union_distrib [of "f ` A" "f ` B"] by (simp add: image_Un)

lemma cINF_inf_distrib: "A \<noteq> {} \<Longrightarrow> bdd_below (f`A) \<Longrightarrow> bdd_below (g`A) \<Longrightarrow> \<Sqinter> (f ` A) \<sqinter> \<Sqinter> (g ` A) = (\<Sqinter>a\<in>A. inf (f a) (g a))"
  by (intro order.antisym le_infI cINF_greatest cINF_lower2)
     (auto intro: le_infI1 le_infI2 cINF_greatest cINF_lower le_infI)

lemma SUP_sup_distrib: "A \<noteq> {} \<Longrightarrow> bdd_above (f`A) \<Longrightarrow> bdd_above (g`A) \<Longrightarrow> \<Squnion> (f ` A) \<squnion> \<Squnion> (g ` A) = (\<Squnion>a\<in>A. sup (f a) (g a))"
  by (intro order.antisym le_supI cSUP_least cSUP_upper2)
     (auto intro: le_supI1 le_supI2 cSUP_least cSUP_upper le_supI)

lemma cInf_le_cSup:
  "A \<noteq> {} \<Longrightarrow> bdd_above A \<Longrightarrow> bdd_below A \<Longrightarrow> Inf A \<le> Sup A"
  by (auto intro!: cSup_upper2[of "SOME a. a \<in> A"] intro: someI cInf_lower)

  context
    fixes f :: "'a \<Rightarrow> 'b::conditionally_complete_lattice"
    assumes "mono f"
  begin

  lemma mono_cInf: "\<lbrakk>bdd_below A; A\<noteq>{}\<rbrakk> \<Longrightarrow> f (Inf A) \<le> (INF x\<in>A. f x)"
    by (simp add: \<open>mono f\<close> conditionally_complete_lattice_class.cINF_greatest cInf_lower monoD)

  lemma mono_cSup: "\<lbrakk>bdd_above A; A\<noteq>{}\<rbrakk> \<Longrightarrow> (SUP x\<in>A. f x) \<le> f (Sup A)"
    by (simp add: \<open>mono f\<close> conditionally_complete_lattice_class.cSUP_least cSup_upper monoD)

  lemma mono_cINF: "\<lbrakk>bdd_below (A`I); I\<noteq>{}\<rbrakk> \<Longrightarrow> f (INF i\<in>I. A i) \<le> (INF x\<in>I. f (A x))"
    by (simp add: \<open>mono f\<close> conditionally_complete_lattice_class.cINF_greatest cINF_lower monoD)

  lemma mono_cSUP: "\<lbrakk>bdd_above (A`I); I\<noteq>{}\<rbrakk> \<Longrightarrow> (SUP x\<in>I. f (A x)) \<le> f (SUP i\<in>I. A i)"
    by (simp add: \<open>mono f\<close> conditionally_complete_lattice_class.cSUP_least cSUP_upper monoD)

  end

end

text \<open>The special case of well-orderings\<close>

lemma wellorder_InfI:
  fixes k :: "'a::{wellorder,conditionally_complete_lattice}"
  assumes "k \<in> A" shows "Inf A \<in> A"
  using wellorder_class.LeastI [of "\<lambda>x. x \<in> A" k]
  by (simp add: Least_le assms cInf_eq_minimum)

lemma wellorder_Inf_le1:
  fixes k :: "'a::{wellorder,conditionally_complete_lattice}"
  assumes "k \<in> A" shows "Inf A \<le> k"
  by (meson Least_le assms bdd_below.I cInf_lower)

subsection \<open>Complete lattices\<close>

instance complete_lattice \<subseteq> conditionally_complete_lattice
  by standard (auto intro: Sup_upper Sup_least Inf_lower Inf_greatest)

lemma cSup_eq:
  fixes a :: "'a :: {conditionally_complete_lattice, no_bot}"
  assumes upper: "\<And>x. x \<in> X \<Longrightarrow> x \<le> a"
  assumes least: "\<And>y. (\<And>x. x \<in> X \<Longrightarrow> x \<le> y) \<Longrightarrow> a \<le> y"
  shows "Sup X = a"
proof cases
  assume "X = {}" with lt_ex[of a] least show ?thesis by (auto simp: less_le_not_le)
qed (intro cSup_eq_non_empty assms)

lemma cInf_eq:
  fixes a :: "'a :: {conditionally_complete_lattice, no_top}"
  assumes upper: "\<And>x. x \<in> X \<Longrightarrow> a \<le> x"
  assumes least: "\<And>y. (\<And>x. x \<in> X \<Longrightarrow> y \<le> x) \<Longrightarrow> y \<le> a"
  shows "Inf X = a"
proof cases
  assume "X = {}" with gt_ex[of a] least show ?thesis by (auto simp: less_le_not_le)
qed (intro cInf_eq_non_empty assms)

class conditionally_complete_linorder = conditionally_complete_lattice + linorder
begin

lemma less_cSup_iff:
  "X \<noteq> {} \<Longrightarrow> bdd_above X \<Longrightarrow> y < Sup X \<longleftrightarrow> (\<exists>x\<in>X. y < x)"
  by (rule iffI) (metis cSup_least not_less, metis cSup_upper less_le_trans)

lemma cInf_less_iff: "X \<noteq> {} \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X < y \<longleftrightarrow> (\<exists>x\<in>X. x < y)"
  by (rule iffI) (metis cInf_greatest not_less, metis cInf_lower le_less_trans)

lemma cINF_less_iff: "A \<noteq> {} \<Longrightarrow> bdd_below (f`A) \<Longrightarrow> (\<Sqinter>i\<in>A. f i) < a \<longleftrightarrow> (\<exists>x\<in>A. f x < a)"
  using cInf_less_iff[of "f`A"] by auto

lemma less_cSUP_iff: "A \<noteq> {} \<Longrightarrow> bdd_above (f`A) \<Longrightarrow> a < (\<Squnion>i\<in>A. f i) \<longleftrightarrow> (\<exists>x\<in>A. a < f x)"
  using less_cSup_iff[of "f`A"] by auto

lemma less_cSupE:
  assumes "y < Sup X" "X \<noteq> {}" obtains x where "x \<in> X" "y < x"
  by (metis cSup_least assms not_le that)

lemma less_cSupD:
  "X \<noteq> {} \<Longrightarrow> z < Sup X \<Longrightarrow> \<exists>x\<in>X. z < x"
  by (metis less_cSup_iff not_le_imp_less bdd_above_def)

lemma cInf_lessD:
  "X \<noteq> {} \<Longrightarrow> Inf X < z \<Longrightarrow> \<exists>x\<in>X. x < z"
  by (metis cInf_less_iff not_le_imp_less bdd_below_def)

lemma complete_interval:
  assumes "a < b" and "P a" and "\<not> P b"
  shows "\<exists>c. a \<le> c \<and> c \<le> b \<and> (\<forall>x. a \<le> x \<and> x < c \<longrightarrow> P x) \<and>
             (\<forall>d. (\<forall>x. a \<le> x \<and> x < d \<longrightarrow> P x) \<longrightarrow> d \<le> c)"
proof (rule exI [where x = "Sup {d. \<forall>x. a \<le> x \<and> x < d \<longrightarrow> P x}"], safe)
  show "a \<le> Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
    by (rule cSup_upper, auto simp: bdd_above_def)
       (metis \<open>a < b\<close> \<open>\<not> P b\<close> linear less_le)
next
  show "Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c} \<le> b"
    by (rule cSup_least)
       (use \<open>a<b\<close> \<open>\<not> P b\<close> in \<open>auto simp add: less_le_not_le\<close>)
next
  fix x
  assume x: "a \<le> x" and lt: "x < Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
  show "P x"
    by (rule less_cSupE [OF lt]) (use less_le_not_le x in \<open>auto\<close>)
next
  fix d
  assume 0: "\<forall>x. a \<le> x \<and> x < d \<longrightarrow> P x"
  then have "d \<in> {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
    by auto
  moreover have "bdd_above {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
    unfolding bdd_above_def using \<open>a<b\<close> \<open>\<not> P b\<close> linear
    by (simp add: less_le) blast
  ultimately show "d \<le> Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
    by (auto simp: cSup_upper)
qed

end

subsection \<open>Instances\<close>

instance complete_linorder < conditionally_complete_linorder
  ..

lemma cSup_eq_Max: "finite (X::'a::conditionally_complete_linorder set) \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Sup X = Max X"
  using cSup_eq_Sup_fin[of X] by (simp add: Sup_fin_Max)

lemma cInf_eq_Min: "finite (X::'a::conditionally_complete_linorder set) \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Inf X = Min X"
  using cInf_eq_Inf_fin[of X] by (simp add: Inf_fin_Min)

lemma cSup_lessThan[simp]: "Sup {..<x::'a::{conditionally_complete_linorder, no_bot, dense_linorder}} = x"
  by (auto intro!: cSup_eq_non_empty intro: dense_le)

lemma cSup_greaterThanLessThan[simp]: "y < x \<Longrightarrow> Sup {y<..<x::'a::{conditionally_complete_linorder, dense_linorder}} = x"
  by (auto intro!: cSup_eq_non_empty intro: dense_le_bounded)

lemma cSup_atLeastLessThan[simp]: "y < x \<Longrightarrow> Sup {y..<x::'a::{conditionally_complete_linorder, dense_linorder}} = x"
  by (auto intro!: cSup_eq_non_empty intro: dense_le_bounded)

lemma cInf_greaterThan[simp]: "Inf {x::'a::{conditionally_complete_linorder, no_top, dense_linorder} <..} = x"
  by (auto intro!: cInf_eq_non_empty intro: dense_ge)

lemma cInf_greaterThanAtMost[simp]: "y < x \<Longrightarrow> Inf {y<..x::'a::{conditionally_complete_linorder, dense_linorder}} = y"
  by (auto intro!: cInf_eq_non_empty intro: dense_ge_bounded)

lemma cInf_greaterThanLessThan[simp]: "y < x \<Longrightarrow> Inf {y<..<x::'a::{conditionally_complete_linorder, dense_linorder}} = y"
  by (auto intro!: cInf_eq_non_empty intro: dense_ge_bounded)

lemma Inf_insert_finite:
  fixes S :: "'a::conditionally_complete_linorder set"
  shows "finite S \<Longrightarrow> Inf (insert x S) = (if S = {} then x else min x (Inf S))"
  by (simp add: cInf_eq_Min)

lemma Sup_insert_finite:
  fixes S :: "'a::conditionally_complete_linorder set"
  shows "finite S \<Longrightarrow> Sup (insert x S) = (if S = {} then x else max x (Sup S))"
  by (simp add: cSup_insert sup_max)

lemma finite_imp_less_Inf:
  fixes a :: "'a::conditionally_complete_linorder"
  shows "\<lbrakk>finite X; x \<in> X; \<And>x. x\<in>X \<Longrightarrow> a < x\<rbrakk> \<Longrightarrow> a < Inf X"
  by (induction X rule: finite_induct) (simp_all add: cInf_eq_Min Inf_insert_finite)

lemma finite_less_Inf_iff:
  fixes a :: "'a :: conditionally_complete_linorder"
  shows "\<lbrakk>finite X; X \<noteq> {}\<rbrakk> \<Longrightarrow> a < Inf X \<longleftrightarrow> (\<forall>x \<in> X. a < x)"
  by (auto simp: cInf_eq_Min)

lemma finite_imp_Sup_less:
  fixes a :: "'a::conditionally_complete_linorder"
  shows "\<lbrakk>finite X; x \<in> X; \<And>x. x\<in>X \<Longrightarrow> a > x\<rbrakk> \<Longrightarrow> a > Sup X"
  by (induction X rule: finite_induct) (simp_all add: cSup_eq_Max Sup_insert_finite)

lemma finite_Sup_less_iff:
  fixes a :: "'a :: conditionally_complete_linorder"
  shows "\<lbrakk>finite X; X \<noteq> {}\<rbrakk> \<Longrightarrow> a > Sup X \<longleftrightarrow> (\<forall>x \<in> X. a > x)"
  by (auto simp: cSup_eq_Max)

class linear_continuum = conditionally_complete_linorder + dense_linorder +
  assumes UNIV_not_singleton: "\<exists>a b::'a. a \<noteq> b"
begin

lemma ex_gt_or_lt: "\<exists>b. a < b \<or> b < a"
  by (metis UNIV_not_singleton neq_iff)

end

context
  fixes f::"'a \<Rightarrow> 'b::{conditionally_complete_linorder,ordered_ab_group_add}"
begin

lemma bdd_above_uminus_image: "bdd_above ((\<lambda>x. - f x) ` A) \<longleftrightarrow> bdd_below (f ` A)"
  by (metis bdd_above_uminus image_image)

lemma bdd_below_uminus_image: "bdd_below ((\<lambda>x. - f x) ` A) \<longleftrightarrow> bdd_above (f ` A)"
  by (metis bdd_below_uminus image_image)

lemma uminus_cSUP:
  assumes "bdd_above (f ` A)" "A \<noteq> {}"
  shows  "- (SUP x\<in>A. f x) = (INF x\<in>A. - f x)"
proof (rule antisym)
  show "(INF x\<in>A. - f x) \<le> - Sup (f ` A)"
    by (metis cINF_lower cSUP_least bdd_below_uminus_image assms le_minus_iff)
  have *: "\<And>x. x \<in>A \<Longrightarrow> f x \<le> Sup (f ` A)"
    by (simp add: assms cSup_upper)
  then show "- Sup (f ` A) \<le> (INF x\<in>A. - f x)"
    by (simp add: assms cINF_greatest)
qed

end

context
  fixes f::"'a \<Rightarrow> 'b::{conditionally_complete_linorder,ordered_ab_group_add}"
begin

lemma uminus_cINF:
  assumes "bdd_below (f ` A)" "A \<noteq> {}"
  shows  "- (INF x\<in>A. f x) = (SUP x\<in>A. - f x)"
  by (metis (mono_tags, lifting) INF_cong uminus_cSUP assms bdd_above_uminus_image minus_equation_iff)

lemma Sup_add_eq:
  assumes "bdd_above (f ` A)" "A \<noteq> {}"
  shows  "(SUP x\<in>A. a + f x) = a + (SUP x\<in>A. f x)" (is "?L=?R")
proof (rule antisym)
  have bdd: "bdd_above ((\<lambda>x. a + f x) ` A)"
    by (metis assms bdd_above_image_mono image_image mono_add)
  with assms show "?L \<le> ?R"
    by (simp add: assms cSup_le_iff cSUP_upper)
  have "\<And>x. x \<in> A \<Longrightarrow> f x \<le> (SUP x\<in>A. a + f x) - a"
    by (simp add: bdd cSup_upper le_diff_eq)
  with \<open>A \<noteq> {}\<close> have "\<Squnion> (f ` A) \<le> (\<Squnion>x\<in>A. a + f x) - a"
    by (simp add: cSUP_least)
  then show "?R \<le> ?L"
    by (metis add.commute le_diff_eq)
qed

lemma Inf_add_eq: \<comment>\<open>you don't get a shorter proof by duality\<close>
  assumes "bdd_below (f ` A)" "A \<noteq> {}"
  shows  "(INF x\<in>A. a + f x) = a + (INF x\<in>A. f x)" (is "?L=?R")
proof (rule antisym)
  show "?R \<le> ?L"
    using assms mono_add mono_cINF by blast
  have bdd: "bdd_below ((\<lambda>x. a + f x) ` A)"
    by (metis add_left_mono assms(1) bdd_below.E bdd_below.I2 imageI)
  with assms have "\<And>x. x \<in> A \<Longrightarrow> f x \<ge> (INF x\<in>A. a + f x) - a"
    by (simp add: cInf_lower diff_le_eq)
  with \<open>A \<noteq> {}\<close> have "(\<Sqinter>x\<in>A. a + f x) - a \<le> \<Sqinter> (f ` A)"
    by (simp add: cINF_greatest)
  with assms show "?L \<le> ?R"
    by (metis add.commute diff_le_eq)
qed

end

instantiation nat :: conditionally_complete_linorder
begin

definition "Sup (X::nat set) = (if X={} then 0 else Max X)"
definition "Inf (X::nat set) = (LEAST n. n \<in> X)"

lemma bdd_above_nat: "bdd_above X \<longleftrightarrow> finite (X::nat set)"
proof
  assume "bdd_above X"
  then obtain z where "X \<subseteq> {.. z}"
    by (auto simp: bdd_above_def)
  then show "finite X"
    by (rule finite_subset) simp
qed simp

instance
proof
  fix x :: nat
  fix X :: "nat set"
  show "Inf X \<le> x" if "x \<in> X" "bdd_below X"
    using that by (simp add: Inf_nat_def Least_le)
  show "x \<le> Inf X" if "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> x \<le> y"
    using that unfolding Inf_nat_def ex_in_conv[symmetric] by (rule LeastI2_ex)
  show "x \<le> Sup X" if "x \<in> X" "bdd_above X"
    using that by (auto simp add: Sup_nat_def bdd_above_nat)
  show "Sup X \<le> x" if "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> y \<le> x"
  proof -
    from that have "bdd_above X"
      by (auto simp: bdd_above_def)
    with that show ?thesis
      by (simp add: Sup_nat_def bdd_above_nat)
  qed
qed

end

lemma Inf_nat_def1:
  fixes K::"nat set"
  assumes "K \<noteq> {}"
  shows "Inf K \<in> K"
by (auto simp add: Min_def Inf_nat_def) (meson LeastI assms bot.extremum_unique subsetI)

lemma Sup_nat_empty [simp]: "Sup {} = (0::nat)"
  by (auto simp add: Sup_nat_def)

instantiation int :: conditionally_complete_linorder
begin

definition "Sup (X::int set) = (THE x. x \<in> X \<and> (\<forall>y\<in>X. y \<le> x))"
definition "Inf (X::int set) = - (Sup (uminus ` X))"

instance
proof
  { fix x :: int and X :: "int set" assume "X \<noteq> {}" "bdd_above X"
    then obtain x y where "X \<subseteq> {..y}" "x \<in> X"
      by (auto simp: bdd_above_def)
    then have *: "finite (X \<inter> {x..y})" "X \<inter> {x..y} \<noteq> {}" and "x \<le> y"
      by (auto simp: subset_eq)
    have "\<exists>!x\<in>X. (\<forall>y\<in>X. y \<le> x)"
    proof
      { fix z assume "z \<in> X"
        have "z \<le> Max (X \<inter> {x..y})"
        proof cases
          assume "x \<le> z" with \<open>z \<in> X\<close> \<open>X \<subseteq> {..y}\<close> *(1) show ?thesis
            by (auto intro!: Max_ge)
        next
          assume "\<not> x \<le> z"
          then have "z < x" by simp
          also have "x \<le> Max (X \<inter> {x..y})"
            using \<open>x \<in> X\<close> *(1) \<open>x \<le> y\<close> by (intro Max_ge) auto
          finally show ?thesis by simp
        qed }
      note le = this
      with Max_in[OF *] show ex: "Max (X \<inter> {x..y}) \<in> X \<and> (\<forall>z\<in>X. z \<le> Max (X \<inter> {x..y}))" by auto

      fix z assume *: "z \<in> X \<and> (\<forall>y\<in>X. y \<le> z)"
      with le have "z \<le> Max (X \<inter> {x..y})"
        by auto
      moreover have "Max (X \<inter> {x..y}) \<le> z"
        using * ex by auto
      ultimately show "z = Max (X \<inter> {x..y})"
        by auto
    qed
    then have "Sup X \<in> X \<and> (\<forall>y\<in>X. y \<le> Sup X)"
      unfolding Sup_int_def by (rule theI') }
  note Sup_int = this

  { fix x :: int and X :: "int set" assume "x \<in> X" "bdd_above X" then show "x \<le> Sup X"
      using Sup_int[of X] by auto }
  note le_Sup = this
  { fix x :: int and X :: "int set" assume "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> y \<le> x" then show "Sup X \<le> x"
      using Sup_int[of X] by (auto simp: bdd_above_def) }
  note Sup_le = this

  { fix x :: int and X :: "int set" assume "x \<in> X" "bdd_below X" then show "Inf X \<le> x"
      using le_Sup[of "-x" "uminus ` X"] by (auto simp: Inf_int_def) }
  { fix x :: int and X :: "int set" assume "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> x \<le> y" then show "x \<le> Inf X"
      using Sup_le[of "uminus ` X" "-x"] by (force simp: Inf_int_def) }
qed
end

lemma interval_cases:
  fixes S :: "'a :: conditionally_complete_linorder set"
  assumes ivl: "\<And>a b x. a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> x \<in> S"
  shows "\<exists>a b. S = {} \<or>
    S = UNIV \<or>
    S = {..<b} \<or>
    S = {..b} \<or>
    S = {a<..} \<or>
    S = {a..} \<or>
    S = {a<..<b} \<or>
    S = {a<..b} \<or>
    S = {a..<b} \<or>
    S = {a..b}"
proof -
  define lower upper where "lower = {x. \<exists>s\<in>S. s \<le> x}" and "upper = {x. \<exists>s\<in>S. x \<le> s}"
  with ivl have "S = lower \<inter> upper"
    by auto
  moreover
  have "\<exists>a. upper = UNIV \<or> upper = {} \<or> upper = {.. a} \<or> upper = {..< a}"
  proof cases
    assume *: "bdd_above S \<and> S \<noteq> {}"
    from * have "upper \<subseteq> {.. Sup S}"
      by (auto simp: upper_def intro: cSup_upper2)
    moreover from * have "{..< Sup S} \<subseteq> upper"
      by (force simp add: less_cSup_iff upper_def subset_eq Ball_def)
    ultimately have "upper = {.. Sup S} \<or> upper = {..< Sup S}"
      unfolding ivl_disj_un(2)[symmetric] by auto
    then show ?thesis by auto
  next
    assume "\<not> (bdd_above S \<and> S \<noteq> {})"
    then have "upper = UNIV \<or> upper = {}"
      by (auto simp: upper_def bdd_above_def not_le dest: less_imp_le)
    then show ?thesis
      by auto
  qed
  moreover
  have "\<exists>b. lower = UNIV \<or> lower = {} \<or> lower = {b ..} \<or> lower = {b <..}"
  proof cases
    assume *: "bdd_below S \<and> S \<noteq> {}"
    from * have "lower \<subseteq> {Inf S ..}"
      by (auto simp: lower_def intro: cInf_lower2)
    moreover from * have "{Inf S <..} \<subseteq> lower"
      by (force simp add: cInf_less_iff lower_def subset_eq Ball_def)
    ultimately have "lower = {Inf S ..} \<or> lower = {Inf S <..}"
      unfolding ivl_disj_un(1)[symmetric] by auto
    then show ?thesis by auto
  next
    assume "\<not> (bdd_below S \<and> S \<noteq> {})"
    then have "lower = UNIV \<or> lower = {}"
      by (auto simp: lower_def bdd_below_def not_le dest: less_imp_le)
    then show ?thesis
      by auto
  qed
  ultimately show ?thesis
    unfolding greaterThanAtMost_def greaterThanLessThan_def atLeastAtMost_def atLeastLessThan_def
    by (metis inf_bot_left inf_bot_right inf_top.left_neutral inf_top.right_neutral)
qed

lemma cSUP_eq_cINF_D:
  fixes f :: "_ \<Rightarrow> 'b::conditionally_complete_lattice"
  assumes eq: "(\<Squnion>x\<in>A. f x) = (\<Sqinter>x\<in>A. f x)"
     and bdd: "bdd_above (f ` A)" "bdd_below (f ` A)"
     and a: "a \<in> A"
  shows "f a = (\<Sqinter>x\<in>A. f x)"
proof (rule antisym)
  show "f a \<le> \<Sqinter> (f ` A)"
    by (metis a bdd(1) eq cSUP_upper)
  show "\<Sqinter> (f ` A) \<le> f a"
    using a bdd by (auto simp: cINF_lower)
qed

lemma cSUP_UNION:
  fixes f :: "_ \<Rightarrow> 'b::conditionally_complete_lattice"
  assumes ne: "A \<noteq> {}" "\<And>x. x \<in> A \<Longrightarrow> B(x) \<noteq> {}"
      and bdd_UN: "bdd_above (\<Union>x\<in>A. f ` B x)"
  shows "(\<Squnion>z \<in> \<Union>x\<in>A. B x. f z) = (\<Squnion>x\<in>A. \<Squnion>z\<in>B x. f z)"
proof -
  have bdd: "\<And>x. x \<in> A \<Longrightarrow> bdd_above (f ` B x)"
    using bdd_UN by (meson UN_upper bdd_above_mono)
  obtain M where "\<And>x y. x \<in> A \<Longrightarrow> y \<in> B(x) \<Longrightarrow> f y \<le> M"
    using bdd_UN by (auto simp: bdd_above_def)
  then have bdd2: "bdd_above ((\<lambda>x. \<Squnion>z\<in>B x. f z) ` A)"
    unfolding bdd_above_def by (force simp: bdd cSUP_le_iff ne(2))
  have "(\<Squnion>z \<in> \<Union>x\<in>A. B x. f z) \<le> (\<Squnion>x\<in>A. \<Squnion>z\<in>B x. f z)"
    using assms by (fastforce simp add: intro!: cSUP_least intro: cSUP_upper2 simp: bdd2 bdd)
  moreover have "(\<Squnion>x\<in>A. \<Squnion>z\<in>B x. f z) \<le> (\<Squnion> z \<in> \<Union>x\<in>A. B x. f z)"
    using assms by (fastforce simp add: intro!: cSUP_least intro: cSUP_upper simp: image_UN bdd_UN)
  ultimately show ?thesis
    by (rule order_antisym)
qed

lemma cINF_UNION:
  fixes f :: "_ \<Rightarrow> 'b::conditionally_complete_lattice"
  assumes ne: "A \<noteq> {}" "\<And>x. x \<in> A \<Longrightarrow> B(x) \<noteq> {}"
      and bdd_UN: "bdd_below (\<Union>x\<in>A. f ` B x)"
  shows "(\<Sqinter>z \<in> \<Union>x\<in>A. B x. f z) = (\<Sqinter>x\<in>A. \<Sqinter>z\<in>B x. f z)"
proof -
  have bdd: "\<And>x. x \<in> A \<Longrightarrow> bdd_below (f ` B x)"
    using bdd_UN by (meson UN_upper bdd_below_mono)
  obtain M where "\<And>x y. x \<in> A \<Longrightarrow> y \<in> B(x) \<Longrightarrow> f y \<ge> M"
    using bdd_UN by (auto simp: bdd_below_def)
  then have bdd2: "bdd_below ((\<lambda>x. \<Sqinter>z\<in>B x. f z) ` A)"
    unfolding bdd_below_def by (force simp: bdd le_cINF_iff ne(2))
  have "(\<Sqinter>z \<in> \<Union>x\<in>A. B x. f z) \<le> (\<Sqinter>x\<in>A. \<Sqinter>z\<in>B x. f z)"
    using assms by (fastforce simp add: intro!: cINF_greatest intro: cINF_lower simp: bdd2 bdd)
  moreover have "(\<Sqinter>x\<in>A. \<Sqinter>z\<in>B x. f z) \<le> (\<Sqinter>z \<in> \<Union>x\<in>A. B x. f z)"
    using assms  by (fastforce simp add: intro!: cINF_greatest intro: cINF_lower2  simp: bdd bdd_UN bdd2)
  ultimately show ?thesis
    by (rule order_antisym)
qed

lemma cSup_abs_le:
  fixes S :: "('a::{linordered_idom,conditionally_complete_linorder}) set"
  shows "S \<noteq> {} \<Longrightarrow> (\<And>x. x\<in>S \<Longrightarrow> \<bar>x\<bar> \<le> a) \<Longrightarrow> \<bar>Sup S\<bar> \<le> a"
  apply (auto simp add: abs_le_iff intro: cSup_least)
  by (metis bdd_aboveI cSup_upper neg_le_iff_le order_trans)

end