(*  Title:      SetInterval2.thy
    Date:       Oct 2006
    Author:     David Trachtenherz
*)

section \<open>Sets of natural numbers\<close>

theory SetInterval2
imports
  "HOL-Library.Infinite_Set"
  Util_Set
  "../CommonArith/Util_MinMax"
  "../CommonArith/Util_NatInf"
  "../CommonArith/Util_Div"
begin

subsection \<open>Auxiliary results for monotonic, injective and surjective functions over sets\<close>

subsubsection \<open>Monotonicity\<close>

definition mono_on :: "('a::order \<Rightarrow> 'b::order) \<Rightarrow> 'a set \<Rightarrow> bool"
  where "mono_on f A \<equiv> \<forall>a\<in>A. \<forall>b\<in>A. a \<le> b \<longrightarrow> f a \<le> f b"

definition strict_mono_on :: "('a::order \<Rightarrow> 'b::order) \<Rightarrow> 'a set \<Rightarrow> bool"
  where "strict_mono_on f A \<equiv> \<forall>a\<in>A. \<forall>b\<in>A. a < b \<longrightarrow> f a < f b"

lemma mono_on_subset: "\<lbrakk> mono_on f A ; B \<subseteq> A \<rbrakk> \<Longrightarrow> mono_on f B"
unfolding mono_on_def by blast

lemma strict_mono_on_subset: "\<lbrakk> strict_mono_on f A ; B \<subseteq> A \<rbrakk> \<Longrightarrow> strict_mono_on f B"
unfolding strict_mono_on_def by blast

lemma mono_on_UNIV_mono_conv: "mono_on f UNIV = mono f"
unfolding mono_on_def mono_def by blast
lemma strict_mono_on_UNIV_strict_mono_conv: "
  strict_mono_on f UNIV = strict_mono f"
unfolding strict_mono_on_def strict_mono_def by blast

lemma mono_imp_mono_on: "mono f \<Longrightarrow> mono_on f A"
unfolding mono_on_def mono_def by blast
lemma strict_mono_imp_strict_mono_on: "strict_mono f \<Longrightarrow> strict_mono_on f A"
unfolding strict_mono_on_def strict_mono_def by blast

lemma strict_mono_on_imp_mono_on: "strict_mono_on f A \<Longrightarrow> mono_on f A"
apply (unfold strict_mono_on_def mono_on_def)
apply (fastforce simp: order_le_less)
done

subsubsection \<open>Injectivity\<close>

lemma inj_imp_inj_on: "inj f \<Longrightarrow> inj_on f A"
unfolding inj_on_def by blast

lemma strict_mono_imp_inj: "strict_mono (f::('a::linorder \<Rightarrow> 'b::order)) \<Longrightarrow> inj f"
by (rule strict_mono_imp_inj_on)

lemma strict_mono_on_mono_on_conv: "
  strict_mono_on f (A::'a::linorder set) = (mono_on f A \<and> inj_on f A)"
apply (rule iffI)
 apply (frule strict_mono_on_imp_mono_on)
 apply (frule strict_mono_on_imp_inj_on)
 apply blast
apply (erule conjE)
apply (unfold inj_on_def mono_on_def strict_mono_on_def, clarify)
apply fastforce
done

corollary strict_mono_mono_conv: "
  strict_mono (f::('a::linorder \<Rightarrow> 'b::order)) = (mono f \<and> inj f)"
by (simp only: strict_mono_on_UNIV_strict_mono_conv[symmetric]
  mono_on_UNIV_mono_conv[symmetric] strict_mono_on_mono_on_conv)

lemma inj_on_image_mem_iff: "
  \<lbrakk> inj_on f A; B \<subseteq> A; a \<in> A \<rbrakk> \<Longrightarrow> (f a \<in> f ` B) = (a \<in> B)"
unfolding inj_on_def by blast

corollary inj_on_union_image_Int: "
  inj_on f (A \<union> B) \<Longrightarrow> f ` (A \<inter> B) = f ` A \<inter> f ` B"
by (rule inj_on_image_Int[OF _ Un_upper1 Un_upper2])

subsubsection \<open>Surjectivity\<close>

definition surj_on :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> bool"
  where "surj_on f A B \<equiv> \<forall>b\<in>B. \<exists>a\<in>A. b = f a"

lemma surj_on_conv: "(surj_on f A B) = (\<forall>b\<in>B. \<exists>a\<in>A. b = f a)"
unfolding surj_on_def ..

lemma surj_on_id: "surj_on id A A"
unfolding id_def surj_on_conv by blast

lemma
  surj_onI: "\<lbrakk> \<forall>b \<in> B. \<exists>a\<in>A. b = f a \<rbrakk> \<Longrightarrow> surj_on f A B" and
  surj_onD2: "surj_on f A B \<Longrightarrow> \<forall>b \<in> B. \<exists>a\<in>A. b = f a" and
  surj_onD: "\<lbrakk> surj_on f A B; b \<in> B \<rbrakk> \<Longrightarrow> \<exists>a\<in>A. b = f a"
unfolding surj_on_conv
by blast+

lemma comp_surj_on: "
  \<lbrakk> surj_on f A B; surj_on g B C \<rbrakk> \<Longrightarrow> surj_on (g \<circ> f) A C"
unfolding comp_def surj_on_image_conv by blast

lemma surj_on_Un_right: "surj_on f A (B1 \<union> B2) = (surj_on f A B1 \<and> surj_on f A B2)"
unfolding surj_on_image_conv
by blast

lemma surj_on_Un_left: "
  surj_on f (A1 \<union> A2) B =
  (\<exists>B1. \<exists>B2. B \<subseteq> B1 \<union> B2 \<and> surj_on f A1 B1 \<and> surj_on f A2 B2)"
unfolding surj_on_image_conv
apply (rule iffI)
 apply (rule_tac x="f ` A1" in exI)
 apply (rule_tac x="f ` A2" in exI)
 apply blast
apply blast
done

lemma surj_on_diff_right: "surj_on f A B \<Longrightarrow> surj_on f A (B - B')"
unfolding surj_on_conv by blast

lemma surj_on_empty_right: "surj_on f A {}"
unfolding surj_on_conv by blast

lemma surj_on_empty_left: "surj_on f {} B = (B = {})"
unfolding surj_on_conv by blast

lemma surj_on_imageI: "surj_on (g \<circ> f) A B \<Longrightarrow> surj_on g (f ` A) B"
unfolding surj_on_conv by fastforce

lemma surj_on_insert_right: "surj_on f A (insert b B) = (surj_on f A B \<and> surj_on f A {b})"
unfolding surj_on_conv by blast

lemma surj_on_insert_left: "surj_on f (insert a A) B = (surj_on f A (B - {f a}))"
unfolding surj_on_conv by blast

lemma surj_on_subset_right: "\<lbrakk> surj_on f A B; B' \<subseteq> B \<rbrakk> \<Longrightarrow> surj_on f A B'"
unfolding surj_on_conv by blast

lemma surj_on_subset_left: "\<lbrakk> surj_on f A B; A \<subseteq> A' \<rbrakk> \<Longrightarrow> surj_on f A' B"
unfolding surj_on_conv by blast

lemma bij_betw_imp_surj_on: "bij_betw f A B \<Longrightarrow> surj_on f A B"
unfolding bij_betw_def surj_on_image_conv by simp

lemma bij_betw_inj_on_surj_on_conv: "
  bij_betw f A B = (inj_on f A \<and> surj_on f A B \<and> f ` A \<subseteq> B)"
unfolding bij_betw_def surj_on_image_conv by blast

subsubsection \<open>Induction over natural sets\<close>

lemma image_nat_induct: "
  \<lbrakk> P (f 0); \<And>n. P (f n) \<Longrightarrow> P (f (Suc n)); surj_on f UNIV I; a \<in> I \<rbrakk> \<Longrightarrow> P a"
proof -
  assume as_P0: "P (f 0)"
    and  as_IA: "\<And>n. P (f n) \<Longrightarrow> P (f (Suc n))"
    and  as_surj_f: "surj_on f UNIV I"
    and  as_a: "a \<in> I"
  have P_n:"\<And>n. P (f n)"
    apply (induct_tac n)
    apply (simp only: as_P0)
    apply (simp only: as_IA)
    done
  have "\<forall>x\<in>I. \<exists>n. x = f n"
    using as_surj_f
    by (unfold surj_on_conv, blast)
  hence "\<exists>n. a = f n"
    using as_a by blast
  thus "P a"
    using P_n by blast
qed

lemma nat_induct'[rule_format]: "
  \<lbrakk> P n0; \<And>n. \<lbrakk> n0 \<le> n;  P n \<rbrakk> \<Longrightarrow> P (Suc n); n0 \<le> n \<rbrakk> \<Longrightarrow> P n"
by (insert nat_induct[where n="n-n0" and P="\<lambda>n. P (n0+n)"], simp)

lemma enat_induct: "
  \<lbrakk> P 0; P \<infinity>; \<And>n. P n \<Longrightarrow> P (eSuc n)\<rbrakk> \<Longrightarrow> P n"
apply (case_tac n)
 prefer 2
 apply simp
apply (simp only: enat_defs)
apply (rename_tac n1)
apply (induct_tac n1)
apply (simp add: enat.splits)+
done

lemma eSuc_imp_Suc_aux_0:
  "\<lbrakk> \<And>n. P n \<Longrightarrow> P (eSuc n); n0' \<le> n'; P (enat n')\<rbrakk> \<Longrightarrow> P (enat (Suc n'))"
by (simp only: enat_defs enat.splits)

lemma eSuc_imp_Suc_aux_n0:
  "\<lbrakk> \<And>n. \<lbrakk>enat n0' \<le> n; P n\<rbrakk> \<Longrightarrow> P (eSuc n); n0' \<le> n'; P (enat n')\<rbrakk> \<Longrightarrow> P (enat (Suc n'))"
proof -
  assume IA: "\<And>n. \<lbrakk>enat n0' \<le> n; P n\<rbrakk> \<Longrightarrow> P (eSuc n)"
    and n0_n: "n0' \<le> n'"
    and Pn: "P (enat n')"
  from n0_n
  have "(enat n0' \<le> enat n')" by simp
  with Pn IA
  have "P (eSuc (enat n'))" by blast
  thus "P (enat (Suc n'))" by (simp only: eSuc_enat)
qed

lemma enat_induct': "
  \<lbrakk> P (n0::enat); P \<infinity>; \<And>n. \<lbrakk> n0 \<le> n;  P n \<rbrakk> \<Longrightarrow> P (eSuc n); n0 \<le> n \<rbrakk> \<Longrightarrow> P n"
apply (case_tac n)
 prefer 2 apply simp
apply (case_tac n0)
 prefer 2 apply simp
apply (rename_tac n' n0', simp)
apply (rule_tac ?n0.0="n0'" and n=n' and P="\<lambda>n. P (enat n)" in nat_induct')
  apply simp
 apply (simp add: eSuc_enat[symmetric])
apply simp
done

lemma interval_induct: "
  \<lbrakk> \<And>x. \<forall>y. (x\<in>(I::nat set) \<and> y \<in> I \<and> y < x \<longrightarrow> P y) \<Longrightarrow> P x \<rbrakk>
  \<Longrightarrow> P a"
  (is "\<lbrakk> \<And>x. \<forall>y. ?IA x y \<Longrightarrow> P x \<rbrakk> \<Longrightarrow> P a")
apply (rule_tac r="{ (x,y). x \<in> I \<and> y \<in> I \<and> x < y }" in wf_induct)
apply (rule wf_less_interval)
apply simp
done

corollary interval_induct_rule:"
  \<lbrakk> \<And>x. (\<And>y. (x\<in>(I::nat set) \<and> y \<in> I \<and> y < x \<Longrightarrow> P y)) \<Longrightarrow> P x \<rbrakk>
  \<Longrightarrow> P a"
by (blast intro: interval_induct)

subsubsection \<open>Monotonicity and injectivity of artithmetic operators\<close>

lemma add_left_inj: "inj (\<lambda>x. n + (x::'a::cancel_ab_semigroup_add))"
by (simp add: inj_on_def)

lemma add_right_inj: "inj (\<lambda>x. x + (n::'a::cancel_ab_semigroup_add))"
by (simp add: inj_on_def)

lemma mult_left_inj: "0 < n \<Longrightarrow> inj (\<lambda>x. (n::nat) * x)"
by (simp add: inj_on_def)

lemma mult_right_inj: "0 < n \<Longrightarrow> inj (\<lambda>x. x * (n::nat))"
by (simp add: inj_on_def)

lemma sub_left_inj_on: "inj_on (\<lambda>x. (x::nat) - k) {k..}"
by (rule inj_onI, simp)

lemma sub_right_inj_on: "inj_on (\<lambda>x. k - (x::nat)) {..k}"
by (rule inj_onI, simp)

lemma add_left_strict_mono: "strict_mono (\<lambda>x. n + (x::'a::ordered_cancel_ab_semigroup_add))"
by (unfold strict_mono_def, clarify, rule add_strict_left_mono)

lemma add_right_strict_mono: "strict_mono (\<lambda>x. x + (n::'a::ordered_cancel_ab_semigroup_add))"
by (unfold strict_mono_def, clarify, rule add_strict_right_mono)

lemma mult_left_strict_mono: "0 < n \<Longrightarrow> strict_mono (\<lambda>x. n * (x::nat))"
by (unfold strict_mono_def, clarify, simp)

lemma mult_right_strict_mono: "0 < n \<Longrightarrow> strict_mono (\<lambda>x. x * (n::nat))"
by (unfold strict_mono_def, clarify, simp)

lemma div_right_strict_mono_on: "
  \<lbrakk> 0 < (k::nat); \<forall>x\<in>I. \<forall>y\<in>I. x < y \<longrightarrow> x + k \<le> y \<rbrakk> \<Longrightarrow>
  strict_mono_on (\<lambda>x. x div k) I"
apply (unfold strict_mono_on_def, clarify)
apply (fastforce dest: div_le_mono[of _ _ k])
done

corollary div_right_inj_on: "
  \<lbrakk> 0 < (k::nat); \<forall>x\<in>I. \<forall>y\<in>I. x < y \<longrightarrow> x + k \<le> y \<rbrakk> \<Longrightarrow>
  inj_on (\<lambda>x. x div k) I"
by (rule strict_mono_on_imp_inj_on[OF div_right_strict_mono_on])

corollary mod_eq_imp_div_right_inj_on: "
  \<lbrakk> 0 < (k::nat); \<forall>x\<in>I. \<forall>y\<in>I. x mod k = y mod k \<rbrakk> \<Longrightarrow>
  inj_on (\<lambda>x. x div k) I"
by (rule strict_mono_on_imp_inj_on[OF mod_eq_div_right_strict_mono_on])

subsection \<open>\<open>Min\<close> and \<open>Max\<close> elements of a set\<close>

text \<open>A special minimum operator is required for dealing with infinite wellordered sets
  because the standard operator @{term "Min"} is usable only with finite sets.\<close>

definition iMin :: "'a::wellorder set \<Rightarrow> 'a"
  where "iMin I \<equiv> LEAST x. x \<in> I"

subsubsection \<open>Basic results, as for \<open>Least\<close>\<close>

lemma iMinI: "k \<in> I \<Longrightarrow> iMin I \<in> I"
unfolding iMin_def
by (rule_tac k=k in LeastI)

lemma iMinI_ex: "\<exists>x. x \<in> I \<Longrightarrow> iMin I \<in> I"
by (blast intro: iMinI)

corollary  iMinI_ex2: "I \<noteq> {} \<Longrightarrow> iMin I \<in> I"
by (blast intro: iMinI_ex)

lemma iMinI2: "\<lbrakk> k \<in> I; \<And>x. x \<in> I \<Longrightarrow> P x \<rbrakk> \<Longrightarrow> P (iMin I)"
by (blast intro: iMinI)

lemma iMinI2_ex: "\<lbrakk> \<exists>x. x \<in> I; \<And>x. x \<in> I \<Longrightarrow> P x \<rbrakk> \<Longrightarrow> P (iMin I)"
by (blast intro: iMinI_ex)

lemma iMinI2_ex2: "\<lbrakk> I \<noteq> {} ; \<And>x. x \<in> I \<Longrightarrow> P x \<rbrakk> \<Longrightarrow> P (iMin I)"
by (blast intro: iMinI_ex2)

lemma iMin_le[dest]: "k \<in> I \<Longrightarrow> iMin I \<le> k"
by (simp only: iMin_def Least_le)

lemma iMin_neq_imp_greater[dest]: "\<lbrakk> k \<in> I; k \<noteq> iMin I \<rbrakk> \<Longrightarrow> iMin I < k"
by (rule order_neq_le_trans[OF not_sym iMin_le])

lemma iMin_mono: "
  \<lbrakk> mono f; \<exists>x. x \<in> I \<rbrakk> \<Longrightarrow> iMin (f ` I) = f (iMin I)"
apply (unfold iMin_def)
apply (rule Least_mono[of f I], simp)
apply (rule_tac x="iMin I" in bexI)
 apply (simp add: iMin_le)
apply (simp add: iMinI_ex)
done

corollary iMin_mono2: "
  \<lbrakk> mono f; I \<noteq> {} \<rbrakk> \<Longrightarrow> iMin (f ` I) = f (iMin I)"
by (blast intro: iMin_mono)

lemma not_less_iMin: "k < iMin I \<Longrightarrow> k \<notin> I"
unfolding iMin_def
by (rule not_less_Least)

lemma Collect_not_less_iMin: "k < iMin {x. P x} \<Longrightarrow> \<not> P k"
by (drule not_less_iMin, blast)

lemma Collect_iMin_le: "P k \<Longrightarrow> iMin {x. P x} \<le> k"
by (rule iMin_le, blast)

lemma Collect_minI: "\<lbrakk> k \<in> I; P (k::('a::wellorder)) \<rbrakk> \<Longrightarrow> \<exists>x\<in>I. P x \<and> (\<forall>y\<in>I. y < x \<longrightarrow> \<not> P y)"
apply (rule_tac x="iMin {y \<in> I. P y}" in bexI)
 prefer 2
 apply (rule subsetD[OF _ iMinI, OF Collect_is_subset], blast)
apply (rule conjI)
 apply (blast intro: iMinI2)
apply (blast dest: not_less_iMin)
done

corollary Collect_minI_ex: "\<exists>k\<in>I. P (k::('a::wellorder)) \<Longrightarrow> \<exists>x\<in>I. P x \<and> (\<forall>y\<in>I. y < x \<longrightarrow> \<not> P y)"
by (erule bexE, rule Collect_minI)

corollary Collect_minI_ex2: "{k\<in>I. P (k::('a::wellorder))} \<noteq> {} \<Longrightarrow> \<exists>x\<in>I. P x \<and> (\<forall>y\<in>I. y < x \<longrightarrow> \<not> P y)"
by (drule ex_in_conv[THEN iffD2], blast intro: Collect_minI)

lemma iMin_the:  "iMin I = (THE x. x \<in> I \<and> (\<forall>y. y \<in> I \<longrightarrow> x \<le> y))"
by (simp add: iMin_def Least_def)

lemma iMin_the2: "iMin I = (THE x. x \<in> I \<and> (\<forall>y\<in>I. x \<le> y))"
apply (simp add: iMin_the)
apply (subgoal_tac "\<And>x. (\<forall>y \<in> I. x \<le> y) = (\<forall>y. y \<in> I \<longrightarrow> x \<le> y) ")
 prefer 2 apply blast
apply simp
done

lemma iMin_equality: "
  \<lbrakk> k \<in> I; \<And>x. x \<in> I \<Longrightarrow> k \<le> x \<rbrakk> \<Longrightarrow> iMin I = k"
unfolding iMin_def
by (blast intro: Least_equality)

lemma iMin_mono_on: "
  \<lbrakk> mono_on f I; \<exists>x. x \<in> I \<rbrakk> \<Longrightarrow> iMin (f ` I) = f (iMin I)"
apply (unfold mono_on_def)
apply (rule iMin_equality)
apply (blast intro: iMinI_ex)+
done

lemma iMin_mono_on2: "
  \<lbrakk> mono_on f I; I \<noteq> {} \<rbrakk> \<Longrightarrow> iMin (f ` I) = f (iMin I)"
by (rule iMin_mono_on, blast+)

lemma wellorder_iMin_lemma: "
  k \<in> I \<Longrightarrow> iMin I \<in> I \<and> iMin I \<le> k"
by (blast intro: iMinI iMin_le)

lemma iMin_Min_conv: "
  \<lbrakk> finite I; I \<noteq> {} \<rbrakk> \<Longrightarrow> iMin I = Min I"
apply (rule order_antisym)
apply (rule Min_ge_iff[THEN iffD2], assumption+)
apply blast
apply (rule Min_le_iff[THEN iffD2], assumption+)
apply (blast intro: iMinI_ex2)
done

lemma Min_neq_imp_greater[dest]: "\<lbrakk> finite I; k \<in> I; k \<noteq> Min I \<rbrakk> \<Longrightarrow> Min I < k"
by (rule order_neq_le_trans[OF not_sym Min_le])

lemma Max_neq_imp_less[dest]: "\<lbrakk> finite I; k \<in> I; k \<noteq> Max I \<rbrakk> \<Longrightarrow> k < Max I"
by (rule order_neq_le_trans[OF _ Max_ge])

lemma nat_Least_mono: "
  \<lbrakk> A \<noteq> {}; mono (f::(nat\<Rightarrow>nat)) \<rbrakk> \<Longrightarrow>
  (LEAST x. x \<in> f ` A) = f (LEAST x. x \<in> A)"
unfolding iMin_def[symmetric]
by (blast intro: iMin_mono2)

lemma Least_disj: "
  \<lbrakk> \<exists>x. P x; \<exists>x. Q x \<rbrakk> \<Longrightarrow>
  (LEAST (x::'a::wellorder). (P x \<or> Q x)) = min (LEAST x. P x) (LEAST x. Q x)"
apply (elim exE, rename_tac x1 x2)
apply (subgoal_tac "\<And>x1 x2 P Q. \<lbrakk>P x1; Q x2; Least P \<le> Least Q\<rbrakk> \<Longrightarrow> (LEAST x. P x \<or> Q x) = Least P")
 prefer 2
 apply (rule Least_equality)
  apply (blast intro: LeastI Least_le)
  apply (erule disjE)
   apply (rule Least_le, assumption)
  apply (rule order_trans, assumption)
  apply (rule Least_le, assumption)
apply (unfold min_def, split if_split, safe)
 apply blast
apply (subst disj_commute)
apply (fastforce simp: linorder_not_le)
done

lemma Least_imp_le: "
  \<lbrakk> \<exists>x. P x; \<And>x. P x \<Longrightarrow> Q x \<rbrakk> \<Longrightarrow>
  (LEAST (x::'a::wellorder). Q x) \<le> (LEAST x. P x)"
by (blast intro: Least_le LeastI2_ex)

lemma Least_imp_disj_eq: "
  \<lbrakk> \<exists>x. P x; \<And>x. P x \<Longrightarrow> Q x \<rbrakk> \<Longrightarrow>
  (LEAST (x::'a::wellorder). P x \<or> Q x) = (LEAST x. Q x)"
apply (subst Least_disj, assumption, blast)
apply (subst min.commute)
apply (rule min.absorb_iff1[THEN iffD1])
apply (rule Least_imp_le, assumption, blast)
done

lemma Least_le_imp_le: "
  \<lbrakk> \<exists>x. P x; \<exists>x. Q x; \<And>x y. \<lbrakk> P x; Q y \<rbrakk> \<Longrightarrow> x \<le> y \<rbrakk> \<Longrightarrow>
  (LEAST (x::'a::wellorder). P x) \<le> (LEAST (x::'a::wellorder). Q x)"
by (blast intro: LeastI)
lemma Least_le_imp_le_disj: "
  \<lbrakk> \<exists>x. P x; \<And>x y. \<lbrakk> P x; Q y \<rbrakk> \<Longrightarrow> x \<le> y \<rbrakk> \<Longrightarrow>
  (LEAST (x::'a::wellorder). P x \<or> Q x) = (LEAST (x::'a::wellorder). P x)"
apply (case_tac "\<exists>x. Q x")
 apply (simp only: Least_disj min.absorb_iff1[THEN iffD1, OF Least_le_imp_le])
apply simp
done

lemma Max_equality: "\<lbrakk> (k::'a::linorder) \<in> A; finite A; \<And>x. x \<in> A \<Longrightarrow> x \<le> k \<rbrakk> \<Longrightarrow>
  Max A = k"
by (rule Max_eqI)

lemma not_greater_Max: "\<lbrakk> finite A; Max A < k \<rbrakk>  \<Longrightarrow> k \<notin> A"
apply (rule ccontr, simp)
apply (frule Max_ge[of A k], blast)
apply (frule order_le_less_trans[of _ _ k], blast)
apply blast
done

lemma Collect_not_greater_Max: "\<lbrakk> finite {x. P x}; Max {x. P x} < k \<rbrakk> \<Longrightarrow> \<not> P k"
by (drule not_greater_Max, assumption, drule Collect_not_in_imp_not)

lemma Collect_Max_ge: "\<lbrakk> finite {x. P x}; P k \<rbrakk> \<Longrightarrow> k \<le> Max {x. P x}"
by (rule Max_ge, assumption, rule CollectI)

lemma MaxI: "\<lbrakk> k \<in> A; finite A \<rbrakk> \<Longrightarrow> Max A \<in> A"
by (case_tac "A = {}", simp_all)

lemma MaxI_ex: "\<lbrakk> \<exists>x. x \<in> A; finite A \<rbrakk> \<Longrightarrow> Max A \<in> A"
by (blast intro: MaxI)

lemma MaxI_ex2: "\<lbrakk> A \<noteq> {}; finite A \<rbrakk> \<Longrightarrow> Max A \<in> A"
by (blast intro: MaxI)

lemma MaxI2_ex:"\<lbrakk> \<exists>x. x \<in> A; \<And>x. x \<in> A \<Longrightarrow> P x; finite A \<rbrakk> \<Longrightarrow> P (Max A)"
by (blast intro: MaxI2)

lemma MaxI2_ex2:"\<lbrakk> A \<noteq> {}; \<And>x. x \<in> A \<Longrightarrow> P x; finite A \<rbrakk> \<Longrightarrow> P (Max A)"
by (blast intro: MaxI2)

lemma Max_mono: "\<lbrakk> mono f; \<exists>x. x \<in> A; finite A \<rbrakk> \<Longrightarrow> Max (f ` A) = f (Max A)"
apply (unfold mono_def)
apply clarify
apply (frule Max_in, blast)
apply (rule Max_equality, clarsimp+)
done

lemma Max_mono2:"\<lbrakk> mono f; A \<noteq> {}; finite A \<rbrakk> \<Longrightarrow> Max (f ` A) = f (Max A)"
by (blast intro: Max_mono)

lemma Max_mono_on: "\<lbrakk> mono_on f A; \<exists>x. x \<in> A; finite A \<rbrakk> \<Longrightarrow> Max (f ` A) = f (Max A)"
apply (unfold mono_on_def)
apply (rule Max_equality)
  apply (blast intro: Max_in)
 apply (rule finite_imageI, assumption)
apply (blast intro: Max_in Max_ge)
done

lemma Max_mono_on2: "
  \<lbrakk> mono_on f A; A \<noteq> {}; finite A \<rbrakk> \<Longrightarrow> Max (f ` A) = f (Max A)"
by (rule Max_mono_on, blast+)

lemma Max_the: "
  \<lbrakk> A \<noteq> {}; finite A \<rbrakk> \<Longrightarrow>
  Max A = (THE x. x \<in> A \<and> (\<forall>y. y \<in> A \<longrightarrow> y \<le> x))"
apply (rule iffD1[OF eq_commute])
apply (rule the_equality, simp)
apply (rule sym)
apply (rule Max_equality)
apply blast+
done

lemma Max_the2: "\<lbrakk> A \<noteq> {}; finite A \<rbrakk> \<Longrightarrow>
  Max A = (THE x. x \<in> A \<and> (\<forall>y\<in>A. y \<le> x))"
apply (simp add: Max_the)
apply (subgoal_tac "\<And>x. (\<forall>y\<in>A. y \<le> x) = (\<forall>y. y \<in> A \<longrightarrow> y \<le> x) ")
 prefer 2
 apply blast
apply simp
done

lemma wellorder_Max_lemma: "\<lbrakk> k \<in> A; finite A \<rbrakk> \<Longrightarrow> Max A \<in> A \<and> k \<le> Max A"
by (case_tac "A = {}", simp_all)

lemma MaxI2_order: "\<lbrakk> k \<in> A; finite A; \<And>y. y \<in> A \<Longrightarrow> y \<le> k;
  \<And>x. \<lbrakk> x \<in> A; \<forall>y\<in>A. y \<le> x \<rbrakk> \<Longrightarrow> P x \<rbrakk>
  \<Longrightarrow> P (Max A)"
by (simp add: Max_equality)

lemma Min_le_Max: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> Min A \<le> Max A"
by (rule Max_ge[OF _ Min_in])

lemma iMin_le_Max: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> iMin A \<le> Max A"
by (rule ssubst[OF iMin_Min_conv], assumption+, rule Min_le_Max)

subsubsection \<open>\<open>Max\<close> for sets over \<open>enat\<close>\<close>

definition iMax :: "nat set \<Rightarrow> enat"
  where "iMax i \<equiv> if (finite i) then (enat (Max i)) else \<infinity>"

lemma iMax_finite_conv: "finite I = (iMax I \<noteq> \<infinity>)"
by (simp add: iMax_def)

lemma iMax_infinite_conv: "infinite I = (iMax I = \<infinity>)"
by (simp add: iMax_def)

lemma "class.distrib_lattice (min::('a::linorder \<Rightarrow> 'a \<Rightarrow> 'a)) (\<le>) (<) max"
apply (subgoal_tac "class.order (\<le>) (<)")
 prefer 2
 apply (rule class.order.intro)
  apply (rule class.preorder.intro)
  apply (rule less_le_not_le)
  apply (rule order_refl)
  apply (rule order_trans, assumption+)
 apply (rule class.order_axioms.intro)
 apply (rule order_antisym, assumption+)
apply (subgoal_tac "class.linorder (\<le>) (<)")
 prefer 2
 apply (rule class.linorder.intro, assumption)
 apply (rule class.linorder_axioms.intro)
 apply (rule linorder_class.linear)
apply (rule class.distrib_lattice.intro)
 apply (rule class.lattice.intro)
  apply (rule class.semilattice_inf.intro, assumption)
  apply (rule class.semilattice_inf_axioms.intro)
    apply (rule le_minI1)
   apply (rule le_minI2)
  apply (rule conj_le_imp_min, assumption+)
 apply (rule class.semilattice_sup.intro, assumption)
 apply (rule class.semilattice_sup_axioms.intro)
   apply (rule max.cobounded1)
  apply (rule max.cobounded2)
 apply (rule conj_le_imp_max, assumption+)
apply (rule class.distrib_lattice_axioms.intro)
apply (rule max_min_distrib2)
done

print_locale Lattices.distrib_lattice

lemma max_Min_eq_Min_max[rule_format]: "
  finite A \<Longrightarrow>
  A \<noteq> {} \<longrightarrow>
  max x (Min A) = Min {max x a |a. a \<in> A}"
apply (rule finite.induct[of A], simp_all del: insert_iff)
apply (rename_tac A1 a)
apply (case_tac "A1 = {}", simp)
apply (rule_tac
  t="{max x b |b. b \<in> insert a A1}" and
  s="insert (max x a) {max x b |b. b \<in> A1}"
  in subst)
 apply blast
apply (subst Min_insert, simp_all)
apply (case_tac "a \<le> Min A1")
 apply (frule max_le_monoR[where x=x])
 apply (simp only: min_eqL)
apply (simp only: linorder_not_le)
apply (frule max_le_monoR[where x=x, OF less_imp_le])
apply (simp only: min_eqR)
done

lemma max_iMin_eq_iMin_max: "
  \<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow>
  max x (iMin A) = iMin {max x a |a. a \<in> A}"
apply (simp add: iMin_Min_conv)
apply (insert iMin_Min_conv[of "{max x a |a. a \<in> A}"], simp)
apply (subgoal_tac "finite {max x a |a. a \<in> A}")
 prefer 2
 apply simp
apply (simp add: max_Min_eq_Min_max)
done

lemma "\<lbrakk> finite A; A \<noteq>{} \<rbrakk> \<Longrightarrow> \<forall>x\<in>A. x \<le> Max A"
by simp

subsubsection \<open>\<open>Min\<close> and \<open>Max\<close> for set operations\<close>

lemma iMin_subset: "\<lbrakk> A \<noteq> {}; A \<subseteq> B \<rbrakk> \<Longrightarrow> iMin B \<le> iMin A"
by (blast intro: iMin_le iMinI_ex2)

lemma Max_subset: "\<lbrakk> A \<noteq> {}; A \<subseteq> B; finite B \<rbrakk> \<Longrightarrow> Max A \<le> Max B"
by (rule linorder_class.Max_mono)

lemma Min_subset: "\<lbrakk> A \<noteq> {}; A \<subseteq> B; finite B \<rbrakk> \<Longrightarrow> Min B \<le> Min A"
by (rule linorder_class.Min_antimono)

lemma iMin_Int_ge1: "(A \<inter> B) \<noteq> {} \<Longrightarrow> iMin A \<le> iMin (A \<inter> B)"
by (rule iMin_subset[OF _ Int_lower1])

lemma iMin_Int_ge2: "(A \<inter> B) \<noteq> {} \<Longrightarrow> iMin B \<le> iMin (A \<inter> B)"
by (rule iMin_subset[OF _ Int_lower2])

lemma iMin_Int_ge: "(A \<inter> B) \<noteq> {} \<Longrightarrow> max (iMin A) (iMin B) \<le> iMin (A \<inter> B)"
apply (rule conj_le_imp_max)
apply (rule iMin_Int_ge1, assumption)
apply (rule iMin_Int_ge2, assumption)
done

lemma Max_Int_le1: "\<lbrakk> (A \<inter> B) \<noteq> {}; finite A \<rbrakk> \<Longrightarrow> Max (A \<inter> B) \<le> Max A"
by (rule Max_subset[OF _ Int_lower1])

lemma Max_Int_le2: "\<lbrakk> (A \<inter> B) \<noteq> {}; finite B \<rbrakk> \<Longrightarrow> Max (A \<inter> B) \<le> Max B"
by (rule Max_subset[OF _ Int_lower2])

lemma Max_Int_le: "\<lbrakk> (A \<inter> B) \<noteq> {}; finite A; finite B \<rbrakk> \<Longrightarrow>
  Max (A \<inter> B) \<le> min (Max A) (Max B)"
apply (rule conj_le_imp_min)
apply (rule Max_Int_le1, assumption+)
apply (rule Max_Int_le2, assumption+)
done

lemma iMin_Un[rule_format]: "
  \<lbrakk> A \<noteq> {}; B \<noteq> {} \<rbrakk> \<Longrightarrow>
  iMin (A \<union> B) = min (iMin A) (iMin B)"
apply (rule order_antisym)
 apply simp
 apply (blast intro: iMin_subset)
apply (simp add: min_le_iff_disj)
apply (insert iMinI_ex2[of "A\<union>B"])
apply (blast intro: iMin_le)
done

lemma iMin_singleton[simp]: "iMin {a} = a"
by (rule singletonI[THEN iMinI, THEN singletonD])

lemma iMax_singleton[simp]: "iMax {a} = enat a"
by (simp add: iMax_def)

lemma Max_le_Min_imp_singleton: "
  \<lbrakk> finite A; A \<noteq> {}; Max A \<le> Min A \<rbrakk> \<Longrightarrow> A = {Min A}"
apply (frule Max_le_iff[THEN iffD1, of _ "Min A"], assumption+)
apply (frule Min_ge_iff[THEN iffD1, of _ "Min A"], assumption, simp)
apply (rule set_eqI)
apply (unfold Ball_def)
apply (erule_tac x=x in allE, erule_tac x=x in allE)
apply (blast intro: order_antisym Min_in)
done
lemma Max_le_Min_conv_singleton: "
  \<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> (Max A \<le> Min A) = (\<exists>x. A = {x})"
apply (rule iffI)
 apply (rule_tac x="Min A" in exI)
 apply (rule Max_le_Min_imp_singleton, assumption+)
apply fastforce
done

lemma Max_le_iMin_imp_le: "
  \<lbrakk> finite A; Max A \<le> iMin B; a \<in> A; b \<in> B \<rbrakk> \<Longrightarrow> a \<le> b"
by (blast dest: Max_ge intro: order_trans)

lemma le_imp_Max_le_iMin: "
  \<lbrakk> finite A; A \<noteq> {}; B \<noteq> {}; \<forall>a\<in>A. \<forall>b\<in>B. a \<le> b \<rbrakk> \<Longrightarrow> Max A \<le> iMin B"
by (blast intro: Max_in iMinI_ex2)

lemma Max_le_iMin_conv_le: "
  \<lbrakk> finite A; A \<noteq> {}; B \<noteq> {} \<rbrakk> \<Longrightarrow> (Max A \<le> iMin B) = (\<forall>a\<in>A. \<forall>b\<in>B. a \<le> b)"
by (blast intro: Max_le_iMin_imp_le le_imp_Max_le_iMin)

lemma Max_less_iMin_imp_less: "
  \<lbrakk> finite A; Max A < iMin B; a \<in> A; b \<in> B \<rbrakk> \<Longrightarrow> a < b"
by (blast dest: Max_less_iff intro: order_less_le_trans iMin_le)

lemma less_imp_Max_less_iMin: "
  \<lbrakk> finite A; A \<noteq> {}; B \<noteq> {}; \<forall>a\<in>A. \<forall>b\<in>B. a < b \<rbrakk> \<Longrightarrow> Max A < iMin B"
by (blast intro: Max_in iMinI_ex2)

lemma Max_less_iMin_conv_less: "
  \<lbrakk> finite A; A \<noteq> {}; B \<noteq> {} \<rbrakk> \<Longrightarrow> (Max A < iMin B) = (\<forall>a\<in>A. \<forall>b\<in>B. a < b)"
by (blast intro: Max_less_iMin_imp_less less_imp_Max_less_iMin)

lemma Max_less_iMin_imp_disjoint: "
  \<lbrakk> finite A; Max A < iMin B \<rbrakk> \<Longrightarrow> A \<inter> B = {}"
apply (case_tac "A = {}", simp)
apply (case_tac "B = {}", simp)
apply (rule disjoint_iff_not_equal[THEN iffD2])
apply (intro ballI)
apply (rule less_imp_neq)
by (rule Max_less_iMin_imp_less)

lemma iMin_in_idem: "n \<in> I \<Longrightarrow> min n (iMin I) = iMin I"
by (simp add: iMin_le min_eqR)

lemma iMin_insert: "I \<noteq> {} \<Longrightarrow> iMin (insert n I) = min n (iMin I)"
apply (subst insert_is_Un)
apply (subst iMin_Un)
apply simp_all
done

lemma iMin_insert_remove: "
  iMin (insert n I) =
  (if I - {n} = {} then n else min n (iMin (I - {n})))"
by (metis iMin_insert iMin_singleton insert_Diff_single)

lemma iMin_remove: "n \<in> I \<Longrightarrow> iMin I = (if I - {n} = {} then n else min n (iMin (I - {n})))"
by (metis iMin_insert_remove insert_absorb)

lemma iMin_subset_idem: "\<lbrakk> B \<noteq> {}; B \<subseteq> A \<rbrakk> \<Longrightarrow> min (iMin B) (iMin A) = iMin A"
by (metis iMin_subset min.absorb2)

lemma iMin_union_inter: "A \<inter> B \<noteq> {} \<Longrightarrow> min (iMin (A \<union> B)) (iMin (A \<inter> B)) = min (iMin A) (iMin B)"
by (metis Int_empty_left Int_lower2 Un_absorb2 Un_assoc Un_empty iMin_Un)

lemma iMin_ge_iff: "I \<noteq> {} \<Longrightarrow> (n \<le> iMin I) = (\<forall>a\<in>I. n \<le> a)"
by (metis Collect_iMin_le Collect_mem_eq iMinI_ex2 order_trans)

lemma iMin_gr_iff: "I \<noteq> {} \<Longrightarrow> (n < iMin I) = (\<forall>a\<in>I. n < a)"
by (metis iMinI_ex2 iMin_neq_imp_greater order_less_trans)

lemma iMin_le_iff: "I \<noteq> {} \<Longrightarrow> (iMin I \<le> n) = (\<exists>a\<in>I. a \<le> n)"
by (metis Collect_iMin_le Collect_mem_eq iMinI_ex2 order_trans)

lemma iMin_less_iff: "I \<noteq> {} \<Longrightarrow> (iMin I < n) = (\<exists>a\<in>I. a < n)"
by (metis iMinI_ex2 iMin_neq_imp_greater order_less_trans)

lemma hom_iMin_commute: "\<lbrakk> \<And>x y. h (min x y) = min (h x) (h y); I \<noteq> {} \<rbrakk> \<Longrightarrow> iMin (h ` I) = h (iMin I)"
apply (rule iMin_equality)
 apply (blast intro: iMinI_ex2)
apply (rename_tac y)
apply (drule_tac x="iMin I" in meta_spec)
apply (clarsimp simp: image_iff, rename_tac x)
apply (drule_tac x=x in meta_spec)
apply (rule_tac t="h (iMin I)" and s="min (h (iMin I)) (h x)" in subst)
 apply (simp add: min_eqL[OF iMin_le])
apply simp
done

text \<open>Synonyms for similarity with theorem names for @{term Min}"\<close>

lemmas iMin_eqI = iMin_equality

lemmas iMin_in = iMinI_ex2

subsection \<open>Some auxiliary results for set operations\<close>

subsubsection \<open>Some additional abbreviations for relations\<close>

text \<open>Abbreviations for \<open>refl\<close>, \<open>sym\<close>, \<open>equiv\<close>, \<open>refl\<close>, \<open>trans\<close>\<close>

abbreviation (input) reflP :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "reflP r \<equiv> refl {(x, y). r x y}"

abbreviation (input) symP :: "('a => 'a => bool) => bool" where
  "symP r == sym {(x, y). r x y}"

abbreviation (input) transP :: "('a => 'a => bool) => bool" where
  "transP r == trans {(x, y). r x y}"

abbreviation (input) equivP :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "equivP r \<equiv> reflP r \<and> symP r \<and> transp r"

abbreviation (input) irreflP :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "irreflP r \<equiv> irrefl {(x, y). r x y}"

text \<open>Example for \<open>reflP\<close>\<close>
lemma "reflP ((\<le>)::('a::preorder \<Rightarrow> 'a \<Rightarrow> bool))"
by (simp add: refl_on_def)

text \<open>Example for \<open>symP\<close>\<close>
lemma "symP (=)"
by (simp add: sym_def)

text \<open>Example for \<open>equivP\<close>\<close>
lemma "equivP (=)"
by (simp add: trans_def refl_on_def sym_def)

text \<open>Example for \<open>irreflP\<close>\<close>
lemma "irreflP ((<)::('a::preorder \<Rightarrow> 'a \<Rightarrow> bool))"
by (simp add: irrefl_def)

subsubsection \<open>Auxiliary results for \<open>singletons\<close>\<close>

lemma singleton_not_empty: "{a} \<noteq> {}" by blast
lemma singleton_finite: "finite {a}" by blast

lemma singleton_ball: "(\<forall>x\<in>{a}. P x) = P a" by blast
lemma singleton_bex: "(\<exists>x\<in>{a}. P x) = P a" by blast

lemma subset_singleton_conv: "(A \<subseteq> {a}) = (A = {} \<or> A = {a})" by blast
lemma singleton_subset_conv: "({a} \<subseteq> A) = (a \<in> A)" by blast

lemma singleton_eq_conv: "({a} = {b}) = (a = b)" by blast
lemma singleton_subset_singleton_conv: "({a} \<subseteq> {b}) = (a = b)" by blast

lemma singleton_Int1_if: "{a} \<inter> A = (if a \<in> A then {a} else {})"
by (split if_split, blast)

lemma singleton_Int2_if: "A \<inter> {a} = (if a \<in> A then {a} else {})"
by (split if_split, blast)

lemma singleton_image: "f ` {a} = {f a}" by blast
lemma inj_on_singleton: "inj_on f {a}" by blast
lemma strict_mono_on_singleton: "strict_mono_on f {a}"
unfolding strict_mono_on_def by blast

subsubsection \<open>Auxiliary results for \<open>finite\<close> and \<open>infinite\<close> sets\<close>

lemma infinite_imp_not_singleton: "infinite A \<Longrightarrow> \<not> (\<exists>a. A = {a})" by blast

lemma infinite_insert: "infinite (insert a A) = infinite A"
by simp

lemma infinite_Diff_insert: "infinite (A - insert a B) = infinite (A - B)"
by simp

lemma subset_finite_imp_finite: "\<lbrakk> finite A; B \<subseteq> A \<rbrakk> \<Longrightarrow> finite B"
by (rule finite_subset)

lemma infinite_not_subset_finite: "\<lbrakk> infinite A; finite B \<rbrakk> \<Longrightarrow> \<not> A \<subseteq> B"
by (blast intro: subset_finite_imp_finite)

lemma Un_infinite_right: "infinite T \<Longrightarrow> infinite (S \<union> T)" by blast
lemma Un_infinite_iff: "infinite (S \<union> T) = (infinite S \<or> infinite T)" by blast

text \<open>Give own name to the lemma about finiteness of the integer image of a nat set\<close>
corollary finite_A_int_A_conv: "finite A = finite (int ` A)"
proof -
  have "inj_on int A"
    by (auto intro: inj_onI)
  then show ?thesis
    by (simp add: finite_image_iff)
qed

text \<open>Corresponding fact fo infinite sets\<close>
corollary infinite_A_int_A_conv: "infinite A = infinite (int ` A)"
by (simp only: finite_A_int_A_conv)

lemma cartesian_product_infiniteL_imp_infinite: "\<lbrakk> infinite A; B \<noteq> {} \<rbrakk> \<Longrightarrow> infinite (A \<times> B)"
by (blast dest: finite_cartesian_productD1)

lemma cartesian_product_infiniteR_imp_infinite: "\<lbrakk> infinite B; A \<noteq> {} \<rbrakk> \<Longrightarrow> infinite (A \<times> B)"
by (blast dest: finite_cartesian_productD2)

lemma finite_nat_iff_bounded2: "
  finite S = (\<exists>(k::nat).\<forall>n\<in>S. n < k)"
by (simp only: finite_nat_iff_bounded, blast)

lemma finite_nat_iff_bounded_le2: "
  finite S = (\<exists>(k::nat).\<forall>n\<in>S. n \<le> k)"
by (simp only: finite_nat_iff_bounded_le, blast)

lemma nat_asc_chain_imp_unbounded: "
  \<lbrakk> S \<noteq> {}; (\<forall>m\<in>S. \<exists>n\<in>S. m < (n::nat)) \<rbrakk> \<Longrightarrow> \<forall>m. \<exists>n\<in>S. m \<le> n"
apply (rule allI)
apply (induct_tac m)
 apply blast
apply (erule bexE)
apply (rename_tac n1)
apply (erule_tac x=n1 in ballE)
  prefer 2
  apply simp
apply (clarify, rename_tac x, rule_tac x=x in bexI)
apply simp_all
done

lemma infinite_nat_iff_asc_chain: "
  S \<noteq> {} \<Longrightarrow> infinite S = (\<forall>m\<in>S. \<exists>n\<in>S. m < (n::nat))"
by (metis Max_in infinite_nat_iff_unbounded not_greater_Max)

lemma infinite_imp_asc_chain: "infinite S \<Longrightarrow> \<forall>m\<in>S. \<exists>n\<in>S. m < (n::nat)"
by (rule infinite_nat_iff_asc_chain[THEN iffD1, OF infinite_imp_nonempty])

lemma infinite_image_imp_infinite: "infinite (f ` A) \<Longrightarrow> infinite A"
by fastforce

lemma inj_on_imp_infinite_image: "\<lbrakk> infinite A; inj_on f A \<rbrakk> \<Longrightarrow> infinite (f ` A)"
apply (frule card_image)
apply (fastforce simp: card_eq_0_iff)
done

lemma inj_on_infinite_image_iff: "inj_on f A \<Longrightarrow> infinite (f ` A) = infinite A"
apply (rule iffI)
 apply (rule ccontr, simp)
apply (rule inj_on_imp_infinite_image, assumption+)
done

lemma inj_on_finite_image_iff: "inj_on f A \<Longrightarrow> finite (f ` A) = finite A"
by (drule inj_on_infinite_image_iff, simp)

lemma nat_ex_greater_finite_Max_conv: "
  A \<noteq> {} \<Longrightarrow> (\<exists>x\<in>A. (n::nat) < x) = (finite A \<longrightarrow> n < Max A)"
apply (rule iffI)
 apply (blast intro: order_less_le_trans Max_ge)
apply (case_tac "finite A")
 apply (blast intro: Max_in)
apply (drule infinite_nat_iff_unbounded[THEN iffD1, rule_format, of _ n])
apply blast
done

corollary nat_ex_greater_infinite_finite_Max_conv': "
  (\<exists>x\<in>A. (n::nat) < x) = (finite A \<and> A \<noteq> {} \<and> n < Max A \<or> infinite A)"
apply (case_tac "A = {}", blast)
apply (drule nat_ex_greater_finite_Max_conv[of _ n])
apply blast
done

subsubsection \<open>Some auxiliary results for disjoint sets\<close>

lemma disjoint_iff_in_not_in1: "(A \<inter> B = {}) = (\<forall>x\<in>A. x \<notin> B)" by blast
lemma disjoint_iff_in_not_in2: "(A \<inter> B = {}) = (\<forall>x\<in>B. x \<notin> A)" by blast

lemma disjoint_in_Un: "
  \<lbrakk> A \<inter> B = {}; x \<in> A \<union> B \<rbrakk> \<Longrightarrow> x \<notin> A \<or> x \<notin> B"
by (blast intro: disjoint_iff_in_not_in1[THEN iffD1])+

lemma partition_Union: "A \<subseteq> \<Union>C \<Longrightarrow> (\<Union>c\<in>C. A \<inter> c) = A" by blast

lemma disjoint_partition_Int: "
  \<forall>c1\<in>C. \<forall>c2\<in>C. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {} \<Longrightarrow>
  \<forall>a1\<in>{A \<inter> c| c. c \<in> C}. \<forall>a2\<in>{A \<inter> c| c. c \<in> C}.
    a1 \<noteq> a2 \<longrightarrow> a1 \<inter> a2 = {}"
by blast

lemma "{f x |x. x \<in> A} = (\<Union>x\<in>A. {f x})"
by fastforce

text \<open>This lemma version drops the superfluous precondition @{term "finite (\<Union>C)"}
  (and turns the resulting equation to the sensible order \<open>card .. = k * card ..\<close>).\<close>
lemma card_partition: "
  \<lbrakk> finite C; \<And>c. c \<in> C \<Longrightarrow> card c = k; \<And>c1 c2. \<lbrakk>c1 \<in> C; c2 \<in> C; c1 \<noteq> c2\<rbrakk> \<Longrightarrow> c1 \<inter> c2 = {} \<rbrakk> \<Longrightarrow>
  card (\<Union>C) = k * card C"
by (metis card_infinite card_partition finite_Union mult_eq_if)

subsubsection \<open>Some auxiliary results for subset relation\<close>

lemma subset_image_Int: "A \<subseteq> B \<Longrightarrow> f ` (A \<inter> B) = f ` A \<inter> f ` B"
by (simp only: Int_absorb2 image_mono)

lemma image_diff_disjoint_image_Int: "
  \<lbrakk> f ` (A - B) \<inter> f ` B = {} \<rbrakk> \<Longrightarrow>
  f ` (A \<inter> B) = f ` A \<inter> f ` B"
apply (rule set_eqI)
apply (simp add: image_iff)
apply blast
done

lemma subset_imp_Int_subset1: "A \<subseteq> C \<Longrightarrow> A \<inter> B \<subseteq> C"
by (rule subset_trans[of _ "C \<inter> B", OF Int_mono, OF _ subset_refl Int_lower1])

lemma subset_imp_Int_subset2: "B \<subseteq> C \<Longrightarrow> A \<inter> B \<subseteq> C"
by (simp only: Int_commute[of A], rule subset_imp_Int_subset1)

subsubsection \<open>Auxiliary results for intervals from \<open>SetInterval\<close>\<close>

lemmas set_interval_defs =
  lessThan_def atMost_def
  greaterThan_def atLeast_def
  greaterThanLessThan_def atLeastLessThan_def
  greaterThanAtMost_def atLeastAtMost_def

lemma image_add_atLeast:
  "(\<lambda>n::nat. n+k) ` {i..} = {i+k..}" (is "?A = ?B")
proof
  show "?A \<subseteq> ?B" by fastforce
next
  show "?B \<subseteq> ?A"
  proof
    fix n assume a: "n : ?B"
    hence "n - k \<in> {i..}" by simp
    moreover have "n = (n - k) + k" using a by fastforce
    ultimately show "n \<in> ?A" by blast
  qed
qed

lemma image_add_atMost:
  "(\<lambda>n::nat. n+k) ` {..i} = {k..i+k}" (is "?A = ?B")

proof -
  have s1: "{..i} = {0..i}"
    by (simp add: set_interval_defs)
  then show "?A = ?B"
    by simp
qed

corollary image_Suc_atLeast: "Suc ` {i..} = {Suc i..}"
by (insert image_add_atLeast[of "Suc 0"], simp)

corollary image_Suc_atMost: "Suc ` {..i} = {Suc 0..Suc i}"
by (insert image_add_atMost[of "Suc 0"], simp)

lemmas image_add_lemmas =
  image_add_atLeastAtMost
  image_add_atLeast
  image_add_atMost
lemmas image_Suc_lemmas =
  image_Suc_atLeastAtMost
  image_Suc_atLeast
  image_Suc_atMost

lemma atMost_atLeastAtMost_0_conv: "{..i::nat} = {0..i}"
by (simp add: set_interval_defs)

lemma atLeastAtMost_subset_atMost: "(k::'a::order) \<le> k' \<Longrightarrow> {l..k} \<subseteq> {..k'}"
by (simp)

lemma lessThan_insert: "insert (n::'a::order) {..<n} = {..n}"
apply (rule set_eqI)
apply (clarsimp simp add: order_le_less)
apply blast
done

lemma atMost_remove: "{..n} - {(n::'a::order)} = {..<n}"
apply (simp only: lessThan_insert[symmetric])
apply (rule Diff_insert_absorb)
apply simp
done

lemma atMost_lessThan_conv: "{..n} = {..<Suc n}"
by (simp only: atMost_def lessThan_def less_Suc_eq_le)

lemma atLeastAtMost_atLeastLessThan_conv: "{l..u} = {l..<Suc u}"
by (simp only: atLeastAtMost_def atLeastLessThan_def atMost_lessThan_conv)

lemma atLeast_greaterThan_conv: "{Suc n..} = {n<..}"
by (simp only: atLeast_def greaterThan_def Suc_le_eq)

lemma atLeastAtMost_greaterThanAtMost_conv: "{Suc l..u} = {l<..u}"
by (simp only: greaterThanAtMost_def atLeastAtMost_def atLeast_greaterThan_conv)

lemma finite_subset_atLeastAtMost: "finite A \<Longrightarrow> A \<subseteq> {Min A..Max A}"
by (simp add: subset_eq)

lemma Max_le_imp_subset_atMost: "
  \<lbrakk> finite A;  Max A \<le> n \<rbrakk> \<Longrightarrow> A \<subseteq> {..n}"
by (rule subset_trans[OF finite_subset_atLeastAtMost atLeastAtMost_subset_atMost])

lemma subset_atMost_imp_Max_le:"
  \<lbrakk> finite A; A \<noteq> {}; A \<subseteq> {..n} \<rbrakk> \<Longrightarrow> Max A \<le> n"
by (simp add: subset_iff)

lemma subset_atMost_Max_le_conv: "
  \<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> (A \<subseteq> {..n}) = (Max A \<le> n)"
apply (rule iffI)
 apply (blast intro: subset_atMost_imp_Max_le)
apply (rule Max_le_imp_subset_atMost, assumption+)
done

lemma iMin_greaterThan: "iMin {n<..} = Suc n"
by (simp only: atLeast_Suc_greaterThan[symmetric] iMin_atLeast)

lemma iMin_atMost: "iMin {..(n::nat)} = 0"
by (rule iMin_equality, simp_all)

lemma iMin_lessThan: "0 < n \<Longrightarrow> iMin {..<(n::nat)} = 0"
by (rule iMin_equality, simp_all)

lemma Max_atMost: "Max {..(n::nat)} = n"
by (rule Max_equality[OF _ finite_atMost], simp_all)

lemma Max_lessThan: "0 < n \<Longrightarrow> Max {..<n} = n - Suc 0"
by (rule Max_equality[OF _ finite_lessThan], simp_all)

lemma iMin_atLeastLessThan: "m < n \<Longrightarrow> iMin {m..<n} = m"
by (rule iMin_equality, simp_all)

lemma Max_atLeastLessThan: "m < n \<Longrightarrow> Max {m..<n} = n - Suc 0"
by (rule Max_equality[OF _ finite_atLeastLessThan], simp_all add: less_imp_le_pred)

lemma iMin_greaterThanLessThan: "Suc m < n \<Longrightarrow> iMin {m<..<n} = Suc m"
by (simp only: atLeastSucLessThan_greaterThanLessThan[symmetric] iMin_atLeastLessThan)

lemma Max_greaterThanLessThan: "Suc m < n \<Longrightarrow> Max {m<..<n} = n - Suc 0"
by (simp only: atLeastSucLessThan_greaterThanLessThan[symmetric] Max_atLeastLessThan)

lemma iMin_greaterThanAtMost: "m < n \<Longrightarrow> iMin {m<..n} = Suc m"
by (simp only: atLeastSucAtMost_greaterThanAtMost[symmetric] atLeastLessThanSuc_atLeastAtMost[symmetric] iMin_atLeastLessThan)

lemma Max_greaterThanAtMost: "m < n \<Longrightarrow> Max {m<..(n::nat)} = n"
by (simp add: atLeastSucAtMost_greaterThanAtMost[symmetric] atLeastLessThanSuc_atLeastAtMost[symmetric] Max_atLeastLessThan)

lemma iMin_atLeastAtMost: "m \<le> n \<Longrightarrow> iMin {m..n} = m"
by (rule iMin_equality, simp_all)

lemma Max_atLeastAtMost: "m \<le> n \<Longrightarrow> Max {m..(n::nat)} = n"
by (rule Max_equality[OF _ finite_atLeastAtMost], simp_all)

lemma infinite_atLeast: "infinite {(n::nat)..}"
by (rule unbounded_k_infinite[of n], fastforce)

lemma infinite_greaterThan: "infinite {(n::nat)<..}"
by (simp add: atLeast_Suc_greaterThan[symmetric] infinite_atLeast)

lemma infinite_atLeast_int: "infinite {(n::int)..}"
apply (rule_tac f="\<lambda>x. nat (x - n)" in inj_on_infinite_image_iff[THEN iffD1, rule_format])
 apply (fastforce simp: inj_on_def)
apply (rule_tac t="((\<lambda>x. nat (x - n)) ` {n..})" and s="{0..}" in subst)
 apply (simp add: set_eq_iff image_iff Bex_def)
 apply (clarify, rename_tac n1)
 apply (rule_tac x="n + int n1" in exI)
apply simp_all
done

lemma infinite_greaterThan_int: "infinite {(n::int)<..}"
apply (simp only: atLeast_remove[symmetric])
apply (rule Diff_infinite_finite[OF singleton_finite])
apply (rule infinite_atLeast_int)
done

lemma infinite_atMost_int: "infinite {..(n::int)}"
apply (rule_tac f="\<lambda>x. n - x" in inj_on_infinite_image_iff[THEN iffD1, rule_format])
 apply (simp add: inj_on_def)
apply (rule_tac t="((-) n ` {..n})" and s="{0..}" in subst)
 apply (simp add: set_eq_iff image_iff Bex_def)
apply (rule infinite_atLeast_int)
done

lemma infinite_lessThan_int: "infinite {..<(n::int)}"
apply (simp only: atMost_remove[symmetric])
apply (rule Diff_infinite_finite[OF singleton_finite])
apply (rule infinite_atMost_int)
done

subsubsection \<open>Auxiliary results for @{term card}\<close>

lemma sum_singleton: "(\<Sum>x\<in>{a}. f x) = f a"
by simp

lemma card_singleton: "card {a} = Suc 0"
by simp

lemma card_cartesian_product_singleton_right: "card (A \<times> {x}) = card A"
by (simp add: card_cartesian_product)

lemma card_1_imp_singleton: "card A = Suc 0 \<Longrightarrow> (\<exists>a. A = {a})"
by (metis card_eq_SucD)

lemma card_1_singleton_conv: "(card A = Suc 0) = (\<exists>a. A = {a})"
apply (rule iffI)
apply (simp add: card_1_imp_singleton)
apply fastforce
done

lemma card_gr0_imp_finite: "0 < card A \<Longrightarrow> finite A"
by (rule ccontr, simp)
lemma card_gr0_imp_not_empty: "(0 < card A) \<Longrightarrow> A \<noteq> {}"
by (rule ccontr, simp)
lemma not_empty_card_gr0_conv: "finite A \<Longrightarrow> (A \<noteq> {}) = (0 < card A)"
by fastforce

lemma nat_card_le_Max: "card (A::nat set) \<le> Suc (Max A)"
apply (case_tac "finite A")
 prefer 2
 apply simp
apply (cut_tac card_mono[OF finite_atMost, of A "Max A"])
 apply simp
apply fastforce
done

lemma Int_card1: "finite A \<Longrightarrow> card (A \<inter> B) \<le> card A"
by (rule card_mono, simp_all)
lemma Int_card2: "finite B \<Longrightarrow> card (A \<inter> B) \<le> card B"
by (simp only: Int_commute[of A], rule Int_card1)
lemma Un_card1: "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> card A \<le> card (A \<union> B)"
by (rule card_mono, simp_all)
lemma Un_card2: "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> card B \<le> card (A \<union> B)"
by (simp only: Un_commute[of A], rule Un_card1)

lemma card_Un_conv: "
  \<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow>
  card (A \<union> B) = card A + card B - card (A \<inter> B)"
by (simp only: card_Un_Int diff_add_inverse2)
lemma card_Int_conv: "
  \<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow>
  card (A \<inter> B) = card A + card B - card (A \<union> B)"
by (simp only: card_Un_Int diff_add_inverse)

text \<open>Pigeonhole principle, dirichlet's box principle\<close>
lemma pigeonhole_principle[rule_format]: "
  card (f ` A) < card A \<longrightarrow> (\<exists>x\<in>A. \<exists>y\<in>A. x \<noteq> y \<and> f x = f y)"
apply (case_tac "finite A")
 prefer 2
 apply simp
apply (rule finite.induct[of A])
apply simp_all
apply (clarsimp, rename_tac A1 a)
apply (case_tac "a \<in> A1", force simp: insert_absorb)
apply (case_tac "f a \<in> f ` A1", fastforce+)
done

corollary pigeonhole_principle_linorder[rule_format]: "
  card (f ` A) < card (A::'a::linorder set) \<Longrightarrow> (\<exists>x\<in>A. \<exists>y\<in>A. x < y \<and> f x = f y)"
apply (drule pigeonhole_principle, clarify)
apply (drule neq_iff[THEN iffD1])
apply fastforce
done

corollary pigeonhole_mod: "
  \<lbrakk> 0 < m; m < card A \<rbrakk> \<Longrightarrow> \<exists>x\<in>A. \<exists>y\<in>A. x < y \<and> x mod m = y mod m"
apply (rule pigeonhole_principle_linorder)
apply (rule le_less_trans[of _ "card {..<m}"])
apply (rule card_mono)
apply fastforce+
done

corollary pigeonhole_mod2: "
  \<lbrakk> (0::nat) < m; m \<le> c; inj_on f {..c} \<rbrakk> \<Longrightarrow> \<exists>x\<le>c. \<exists>y\<le>c. x < y \<and> f x mod m = f y mod m"
apply (insert pigeonhole_mod[of m "f ` {..c}"])
apply (clarsimp simp add: card_image, rename_tac x y)
apply (subgoal_tac "x \<noteq> y")
 prefer 2
 apply blast
apply (drule neq_iff[THEN iffD1], safe)
 apply blast
apply (blast intro: eq_commute[THEN iffD1])
done

end


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

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

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

fun pairs :: "'t list => (('t, 't) pair) list" where
"pairs (nil2) = nil2"
| "pairs (cons2 y (nil2)) = nil2"
| "pairs (cons2 y (cons2 y2 xs)) = cons2 (pair2 y y2) (pairs xs)"

fun map :: "('a => 'b) => 'a list => 'b list" where
"map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

function evens :: "'a list => 'a list"
         and odds :: "'a list => 'a list" where
"evens (nil2) = nil2"
| "evens (cons2 y xs) = cons2 y (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 y xs) = evens xs"
by pat_completeness auto

theorem property0 :
  "((map
       (% (x :: ('a, 'a) pair) => (case x of pair2 y z => z))
       (pairs xs)) =
      (odds xs))"
  oops

end


(*
  File: Pelletier.thy
  Author: Bohua Zhan

  Pelletier's problems. From the paper "Seventy-five problems for testing
  automatic theorem provers" by Francis Jeffry Pelletier.
*)

theory Pelletier
  imports Logic_FOL
begin

theorem p1: "(p \<longrightarrow> q) \<longleftrightarrow> (\<not>q \<longrightarrow> \<not>p)" by auto2

theorem p2: "(\<not>\<not>p) \<longleftrightarrow> p" by auto2

theorem p3: "\<not>(p \<longrightarrow> q) \<Longrightarrow> q \<longrightarrow> p" by auto2

theorem p4: "(\<not>p \<longrightarrow> q) \<longleftrightarrow> (\<not>q \<longrightarrow> p)" by auto2

theorem p5: "(p \<or> q) \<longrightarrow> (p \<or> r) \<Longrightarrow> p \<or> (q \<longrightarrow> r)" by auto2

theorem p6: "p \<or> \<not>p" by auto2

theorem p7: "p \<or> \<not>\<not>\<not>p" by auto2

theorem p8: "((p \<longrightarrow> q) \<longrightarrow> p) \<Longrightarrow> p" by auto2

theorem p9: "(p \<or> q) \<and> (\<not>p \<or> q) \<and> (p \<or> \<not>q) \<Longrightarrow> \<not>(\<not>p \<or> \<not>q)" by auto2

theorem p10: "q \<longrightarrow> r \<Longrightarrow> r \<longrightarrow> p \<and> q \<Longrightarrow> p \<longrightarrow> q \<or> r \<Longrightarrow> p \<longleftrightarrow> q" by auto2

theorem p12: "((p \<longleftrightarrow> q) \<longleftrightarrow> r) \<longleftrightarrow> (p \<longleftrightarrow> (q \<longleftrightarrow> r))"
@proof
  @case "p"
  @case "q"
@qed

theorem p13: "p \<or> (q \<and> r) \<longleftrightarrow> (p \<or> q) \<and> (p \<or> r)" by auto2

theorem p14: "(p \<longleftrightarrow> q) \<longleftrightarrow> ((q \<or> \<not>p) \<and> (\<not>q \<or> p))" by auto2

theorem p15: "(p \<longrightarrow> q) \<longleftrightarrow> (\<not>p \<or> q)" by auto2

theorem p16: "(p \<longrightarrow> q) \<or> (q \<longrightarrow> p)" by auto2

theorem p17: "(p \<and> (q \<longrightarrow> r) \<longrightarrow> s) \<longleftrightarrow> (\<not>p \<or> q \<or> s) \<and> (\<not>p \<or> \<not>r \<or> s)" by auto2

theorem p18: "\<exists>y::'a. \<forall>x. F(y) \<longrightarrow> F(x)"
@proof
  @case "\<forall>x. F(x)" @with
    @obtain "y::'a" where "y = y" @have "\<forall>x. F(y) \<longrightarrow> F(x)"
  @end
  @obtain y where "\<not>F(y)" @have "\<forall>x. F(y) \<longrightarrow> F(x)"
@qed

theorem p19: "\<exists>x::'a. \<forall>y z. (P(y) \<longrightarrow> Q(z)) \<longrightarrow> (P(x) \<longrightarrow> Q(x))"
@proof
  @case "\<exists>x. P(x) \<longrightarrow> Q(x)" @with
    @obtain x where "P(x) \<longrightarrow> Q(x)"
    @have "\<forall>y z. (P(y) \<longrightarrow> Q(z)) \<longrightarrow> (P(x) \<longrightarrow> Q(x))"
  @end
  @obtain "x::'a" where "x = x"
  @have "\<forall>y z. (P(y) \<longrightarrow> Q(z)) \<longrightarrow> (P(x) \<longrightarrow> Q(x))"
@qed

theorem p20: "\<forall>x y. \<exists>z. \<forall>w. P(x) \<and> Q(y) \<longrightarrow> R(z) \<and> S(w) \<Longrightarrow>
  \<exists>x y. P(x) \<and> Q(y) \<Longrightarrow> \<exists>z. R(z)"
@proof
  @obtain x y where "P(x)" "Q(y)"
  @obtain z where "\<forall>w. P(x) \<and> Q(y) \<longrightarrow> R(z) \<and> S(w)"
@qed

theorem p21: "\<exists>x. p \<longrightarrow> F(x) \<Longrightarrow> \<exists>x. F(x) \<longrightarrow> p \<Longrightarrow> \<exists>x. p \<longleftrightarrow> F(x)"
@proof
  @case "p" @with @obtain x where "F(x)" @have "p \<longleftrightarrow> F(x)" @end
  @case "\<not>p" @with @obtain x where "\<not>F(x)" @have "p \<longleftrightarrow> F(x)" @end
@qed

theorem p22: "\<forall>x::'a. p \<longleftrightarrow> F(x) \<Longrightarrow> p \<longleftrightarrow> (\<forall>x. F(x))"
@proof
  @case "p" @obtain "x::'a" where "x = x"
@qed

theorem p23: "(\<forall>x::'a. p \<or> F(x)) \<longleftrightarrow> (p \<or> (\<forall>x. F(x)))" by auto2

theorem p29: "\<exists>x. F(x) \<Longrightarrow> \<exists>x. G(x) \<Longrightarrow>
  ((\<forall>x. F(x) \<longrightarrow> H(x)) \<and> (\<forall>x. G(x) \<longrightarrow> J(x))) \<longleftrightarrow>
  (\<forall>x y. F(x) \<and> G(y) \<longrightarrow> H(x) \<and> J(y))"
@proof
  @obtain a b where "F(a)" "G(b)"
  @case "\<forall>x y. F(x) \<and> G(y) \<longrightarrow> H(x) \<and> J(y)" @with
    @have "\<forall>x. F(x) \<longrightarrow> H(x)" @with @have "F(x) \<and> G(b)" @end
    @have "\<forall>y. G(y) \<longrightarrow> J(y)" @with @have "F(a) \<and> G(y)" @end
  @end
@qed

theorem p30: "\<forall>x. F(x) \<or> G(x) \<longrightarrow> \<not>H(x) \<Longrightarrow>
  \<forall>x. (G(x) \<longrightarrow> \<not>I(x)) \<longrightarrow> F(x) \<and> H(x) \<Longrightarrow> \<forall>x. I(x)"
@proof
  @have "\<forall>x. I(x)" @with @case "F(x)" @end
@qed

theorem p31: "\<not>(\<exists>x. F(x) \<and> (G(x) \<or> H(x))) \<Longrightarrow> \<exists>x. I(x) \<and> F(x) \<Longrightarrow> \<forall>x. \<not>H(x) \<longrightarrow> J(x) \<Longrightarrow>
  \<exists>x. I(x) \<and> J(x)" by auto2

theorem p32: "\<forall>x. (F(x) \<and> (G(x) \<or> H(x))) \<longrightarrow> I(x) \<Longrightarrow> \<forall>x. I(x) \<and> H(x) \<longrightarrow> J(x) \<Longrightarrow>
  \<forall>x. K(x) \<longrightarrow> H(x) \<Longrightarrow> \<forall>x. F(x) \<and> K(x) \<longrightarrow> J(x)" by auto2

theorem p33: "(\<forall>x. p(a) \<and> (p(x) \<longrightarrow> p(b)) \<longrightarrow> p(c)) \<longleftrightarrow>
  (\<forall>x. (\<not>p(a) \<or> p(x) \<or> p(c)) \<and> (\<not>p(a) \<or> \<not>p(b) \<or> p(c)))" by auto2

theorem p35: "\<exists>(x::'a) (y::'b). P(x,y) \<longrightarrow> (\<forall>x y. P(x,y))" by auto2

theorem p39: "\<not>(\<exists>x. \<forall>y. F(y,x) \<longleftrightarrow> \<not>F(y,y))"
@proof
  @contradiction
  @obtain x where "\<forall>y. F(y,x) \<longleftrightarrow> \<not>F(y,y)"
  @case "F(x,x)"
@qed

(* Note there is a typo in the original text. *)
theorem p40: "\<exists>y. \<forall>x. F(x,y) \<longleftrightarrow> F(x,x) \<Longrightarrow> \<not>(\<forall>x. \<exists>y. \<forall>z. F(z,y) \<longleftrightarrow> \<not>F(z,x))"
@proof
  @obtain A where "\<forall>x. F(x,A) \<longleftrightarrow> F(x,x)"
  @have "\<not>(\<exists>y. \<forall>z. F(z,y) \<longleftrightarrow> \<not>F(z,A))" @with
    @have (@rule) "\<forall>y. \<not>(\<forall>z. F(z,y) \<longleftrightarrow> \<not>F(z,A))" @with
      @have "\<not>(F(y,y) \<longleftrightarrow> \<not>F(y,A))" @with @case "F(y,y)" @end
    @end
  @end
@qed

theorem p42: "\<not>(\<exists>y. \<forall>x. F(x,y) \<longleftrightarrow> \<not>(\<exists>z. F(x,z) \<and> F(z,x)))"
@proof
  @contradiction
  @obtain y where "\<forall>x. F(x,y) \<longleftrightarrow> \<not>(\<exists>z. F(x,z) \<and> F(z,x))"
  @case "F(y,y)"
@qed

theorem p43: "\<forall>x y. Q(x,y) \<longleftrightarrow> (\<forall>z. F(z,x) \<longleftrightarrow> F(z,y)) \<Longrightarrow>
  \<forall>x y. Q(x,y) \<longleftrightarrow> Q(y,x)" by auto2

theorem p47:
  "(\<forall>x. P1(x) \<longrightarrow> P0(x)) \<and> (\<exists>x. P1(x)) \<Longrightarrow>
   (\<forall>x. P2(x) \<longrightarrow> P0(x)) \<and> (\<exists>x. P2(x)) \<Longrightarrow>
   (\<forall>x. P3(x) \<longrightarrow> P0(x)) \<and> (\<exists>x. P3(x)) \<Longrightarrow>
   (\<forall>x. P4(x) \<longrightarrow> P0(x)) \<and> (\<exists>x. P4(x)) \<Longrightarrow>
   (\<forall>x. P5(x) \<longrightarrow> P0(x)) \<and> (\<exists>x. P5(x)) \<Longrightarrow>
   (\<exists>x. Q1(x)) \<and> (\<forall>x. Q1(x) \<longrightarrow> Q0(x)) \<Longrightarrow>
   \<forall>x. P0(x) \<longrightarrow> ((\<forall>y. Q0(y) \<longrightarrow> R(x,y)) \<or>
                   (\<forall>y. P0(y) \<and> S(y,x) \<and> (\<exists>z. Q0(z) \<and> R(y,z)) \<longrightarrow> R(x,y))) \<Longrightarrow>
   \<forall>x y. P3(y) \<and> (P5(x) \<or> P4(x)) \<longrightarrow> S(x,y) \<Longrightarrow>
   \<forall>x y. P3(x) \<and> P2(y) \<longrightarrow> S(x,y) \<Longrightarrow>
   \<forall>x y. P2(x) \<and> P1(y) \<longrightarrow> S(x,y) \<Longrightarrow>
   \<forall>x y. P1(x) \<and> (P2(y) \<or> Q1(y)) \<longrightarrow> \<not>R(x,y) \<Longrightarrow>
   \<forall>x y. P3(x) \<and> P4(y) \<longrightarrow> R(x,y) \<Longrightarrow>
   \<forall>x y. P3(x) \<and> P5(y) \<longrightarrow> \<not>R(x,y) \<Longrightarrow>
   \<forall>x. P4(x) \<or> P5(x) \<longrightarrow> (\<exists>y. Q0(y) \<and> R(x,y)) \<Longrightarrow>
   \<exists>x y. P0(x) \<and> P0(y) \<and> (\<exists>z. Q1(z) \<and> R(y,z) \<and> R(x,y))"
@proof
  @obtain x1 x2 x3 x4 x5 where "P1(x1)" "P2(x2)" "P3(x3)" "P4(x4)" "P5(x5)"
  @have "S(x3,x2)" @have "S(x2,x1)" @have "R(x3,x4)" @have "\<not>R(x3,x5)"
@qed

theorem p48: "a = b \<or> c = d \<Longrightarrow> a = c \<or> b = d \<Longrightarrow> a = d \<or> b = c" by auto2

theorem p49: "\<exists>x y. \<forall>(z::'a). z = x \<or> z = y \<Longrightarrow> P(a) \<and> P(b) \<Longrightarrow> (a::'a) \<noteq> b \<Longrightarrow> \<forall>x. P(x)"
@proof
  @obtain x y where "\<forall>(z::'a). z = x \<or> z = y"
  @have "b \<noteq> a" @have "a = x \<or> b = x"
  @have "\<forall>c. P(c)" @with @have "c = a \<or> c = b" @end
@qed

theorem p50: "\<forall>x. F(a,x) \<or> (\<forall>y. F(x,y)) \<Longrightarrow> \<exists>x. \<forall>y. F(x,y)"
@proof
  @case "\<forall>y. F(a,y)"
  @obtain y where "\<not>F(a,y)"
  @have (@rule) "\<forall>z. F(a,y) \<or> F(y,z)"
@qed

theorem p51: "\<exists>z w. \<forall>x y. F(x,y) \<longleftrightarrow> x = z \<and> y = w \<Longrightarrow>
  \<exists>z. \<forall>x. (\<exists>w. \<forall>y. F(x,y) \<longleftrightarrow> y = w) \<longleftrightarrow> x = z"
@proof
  @obtain z w where "\<forall>x y. F(x,y) \<longleftrightarrow> x = z \<and> y = w"
  @have "\<forall>x. (\<exists>w. \<forall>y. F(x,y) \<longleftrightarrow> y = w) \<longleftrightarrow> x = z" @with
    @case "x = z" @with @have "\<forall>y. F(x,y) \<longleftrightarrow> y = w" @end
  @end
@qed

theorem p52: "\<exists>z w. \<forall>x y. F(x,y) \<longleftrightarrow> x = z \<and> y = w \<Longrightarrow>
  \<exists>w. \<forall>y. (\<exists>z. \<forall>x. F(x,y) \<longleftrightarrow> x = z) \<longleftrightarrow> y = w"
@proof
  @obtain z w where "\<forall>x y. F(x,y) \<longleftrightarrow> x = z \<and> y = w"
  @have"\<forall>y. (\<exists>z. \<forall>x. F(x,y) \<longleftrightarrow> x = z) \<longleftrightarrow> y = w" @with
    @case "y = w" @with @have "\<forall>x. F(x,y) \<longleftrightarrow> x = z" @end
  @end
@qed

theorem p55:
  "\<exists>x. L(x) \<and> K(x,a) \<Longrightarrow>
   L(a) \<and> L(b) \<and> L(c) \<Longrightarrow>
   \<forall>x. L(x) \<longrightarrow> x = a \<or> x = b \<or> x = c \<Longrightarrow>
   \<forall>y x. K(x,y) \<longrightarrow> H(x,y) \<Longrightarrow>
   \<forall>x y. K(x,y) \<longrightarrow> \<not>R(x,y) \<Longrightarrow>
   \<forall>x. H(a,x) \<longrightarrow> \<not>H(c,x) \<Longrightarrow>
   \<forall>x. x \<noteq> b \<longrightarrow> H(a,x) \<Longrightarrow>
   \<forall>x. \<not>R(x,a) \<longrightarrow> H(b,x) \<Longrightarrow>
   \<forall>x. H(a,x) \<longrightarrow> H(b,x) \<Longrightarrow>
   \<forall>x. \<exists>y. \<not>H(x,y) \<Longrightarrow>
   a \<noteq> b \<Longrightarrow>
   K(a,a)" (* typo in text *)
@proof
  @case "K(b,a)" @with @have "\<forall>x. H(b,x)" @end
@qed

theorem p56: "(\<forall>x. (\<exists>y. F(y) \<and> x = f(y)) \<longrightarrow> F(x)) \<longleftrightarrow> (\<forall>x. F(x) \<longrightarrow> F(f(x)))" by auto2

theorem p57: "F(f(a,b),f(b,c)) \<Longrightarrow> F(f(b,c),f(a,c)) \<Longrightarrow>
  \<forall>x y z. F(x,y) \<and> F(y,z) \<longrightarrow> F(x,z) \<Longrightarrow> F(f(a,b),f(a,c))" by auto2

theorem p58: "\<forall>x y. f(x) = g(y) \<Longrightarrow> \<forall>x y. f(f(x)) = f(g(y))"
@proof
  @have "\<forall>x y. f(f(x)) = f(g(y))" @with
    @have "f(x) = g(y)"
  @end
@qed

theorem p59: "\<forall>x::'a. F(x) \<longleftrightarrow> \<not>F(f(x)) \<Longrightarrow> \<exists>x. F(x) \<and> \<not>F(f(x))"
@proof
  @obtain "x::'a" where "x = x" @case "F(x)"
@qed

theorem p60: "\<forall>x. F(x,f(x)) \<longleftrightarrow> (\<exists>y. (\<forall>z. F(z,y) \<longrightarrow> F(z,f(x))) \<and> F(x,y))" by auto2

theorem p61: "\<forall>x y z. f(x,f(y,z)) = f(f(x,y),z) \<Longrightarrow> \<forall>x y z w. f(x,f(y,f(z,w))) = f(f(f(x,y),z),w)"
  by auto2

end


theory sort_HSortPermutes
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

datatype 'a Heap = Node "'a Heap" "'a" "'a Heap" | Nil2

fun toHeap2 :: "int list => (int Heap) list" where
"toHeap2 (Nil2) = Nil2"
| "toHeap2 (Cons2 y z) = Cons2 (Node (Nil2) y (Nil2)) (toHeap2 z)"

fun hmerge :: "int Heap => int Heap => int Heap" where
"hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if x2 <= x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil2) = Node z x2 x3"
| "hmerge (Nil2) y = y"

fun hpairwise :: "(int Heap) list => (int Heap) list" where
"hpairwise (Nil2) = Nil2"
| "hpairwise (Cons2 q (Nil2)) = Cons2 q (Nil2)"
| "hpairwise (Cons2 q (Cons2 q2 qs)) =
     Cons2 (hmerge q q2) (hpairwise qs)"

fun hmerging :: "(int Heap) list => int Heap" where
"hmerging (Nil2) = Nil2"
| "hmerging (Cons2 q (Nil2)) = q"
| "hmerging (Cons2 q (Cons2 z x2)) =
     hmerging (hpairwise (Cons2 q (Cons2 z x2)))"

fun toHeap :: "int list => int Heap" where
"toHeap x = hmerging (toHeap2 x)"

fun toList :: "int Heap => int list" where
"toList (Node q y q2) = Cons2 y (toList (hmerge q q2))"
| "toList (Nil2) = Nil2"

fun dot :: "('b => 'c) => ('a => 'b) => 'a => 'c" where
"dot x y z = x (y z)"

fun hsort :: "int list => int list" where
"hsort x =
   dot
     (% (y :: int Heap) => toList y) (% (z :: int list) => toHeap z) x"

fun count :: "int => int list => Nat" where
"count x (Nil2) = Z"
| "count x (Cons2 z xs) =
     (if x = z then S (count x xs) else count x xs)"

(*hipster toHeap2
          hmerge
          hpairwise
          hmerging
          toHeap
          toList
          dot
          hsort
          count *)

theorem x0 :
  "!! (x :: int) (y :: int list) . (count x (hsort y)) = (count x y)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory IsPrime
imports
  "../../AutoCorres"
  "~~/src/HOL/Number_Theory/Number_Theory"
begin

(* Parse the input file. *)
install_C_file "is_prime.c"

(* Abstract the input file. *)
autocorres [ ts_rules = nondet, unsigned_word_abs = is_prime_linear is_prime ] "is_prime.c"

context is_prime begin

definition
  "partial_prime p (n :: nat) \<equiv>
        (1 < p \<and> (\<forall>i \<in> {2 ..< min p n}. \<not> i dvd p))"

lemma partial_prime_ge [simp]:
     "\<lbrakk> p' \<ge> p \<rbrakk> \<Longrightarrow> partial_prime p p' = prime p"
  by (clarsimp simp: partial_prime_def prime_nat_simp min_def)

lemma divide_self_plus_one [simp]: "(x dvd Suc x) = (x = 1)"
  apply (case_tac "x = 0", simp)
  apply (case_tac "x = 1", simp)
  apply (clarsimp simp: dvd_def)
  apply (case_tac "k = 0", simp)
  apply (case_tac "k = 1", simp)
  apply (subgoal_tac "x * 2 \<le> x * k")
   apply (subgoal_tac "Suc x < x * 2")
    apply simp
   apply clarsimp
  apply clarsimp
  done

lemma partial_prime_Suc [simp]:
  "partial_prime p (Suc n)
              = (partial_prime p n \<and> (1 < n \<and> Suc n < p \<longrightarrow> \<not> n dvd p))"
   apply (clarsimp simp: partial_prime_def min_def atLeastLessThanSuc not_le)
  apply (case_tac "p = Suc n")
   apply (clarsimp simp: atLeastLessThanSuc)
  apply fastforce
  done

lemma mod_to_dvd:
   "(n mod i \<noteq> 0) = (\<not> i dvd (n :: nat))"
  by (clarsimp simp: dvd_eq_mod_eq_0)

lemma prime_of_product [simp]: "prime ((a::nat) * b) = ((a = 1 \<and> prime b) \<or> (prime a \<and> b = 1))"
  using prime_product by force

lemma partial_prime_2 [simp]: "(partial_prime a 2) = (a > 1)"
  by (clarsimp simp: partial_prime_def)

definition [simp]:
  "is_prime_linear_inv n i s \<equiv> (1 < i \<and> 1 < n \<and> i \<le> n \<and> partial_prime n i)"

theorem is_prime_correct:
    "\<lbrace> \<lambda>s. n \<le> UINT_MAX \<rbrace> is_prime_linear' n \<lbrace> \<lambda>r s. (r \<noteq> 0) \<longleftrightarrow> prime n \<rbrace>!"
  apply (rule validNF_assume_pre)
  apply (case_tac "n = 0")
   apply (clarsimp simp: is_prime_linear'_def, wp, simp)[1]
  apply (case_tac "n = 1")
   apply (clarsimp simp: is_prime_linear'_def, wp, simp)[1]
  apply (unfold is_prime_linear'_def)
  apply (subst whileLoopE_add_inv [
      where I="\<lambda>r s. is_prime_linear_inv n r s"
                  and M="(\<lambda>(r, s). n - r)"])
  apply (wp, auto simp: mod_to_dvd [simplified])
  done

lemma not_prime:
    "\<lbrakk> \<not> prime (a :: nat); a > 1 \<rbrakk> \<Longrightarrow> \<exists>x y. x * y = a \<and> 1 < x \<and> 1 < y \<and> x * x \<le> a"
  apply (clarsimp simp: prime_nat_iff dvd_def)
  apply (case_tac "m > k")
   apply (metis Suc_lessD Suc_lessI less_imp_le_nat mult.commute nat_0_less_mult_iff nat_mult_less_cancel_disj)
  apply fastforce
  done

lemma sqrt_prime:
  "\<lbrakk> a * a > n; \<forall>x<a. (x dvd n) = (x = Suc 0 \<or> x = n); 1 < n \<rbrakk> \<Longrightarrow> prime n"
  apply (rule ccontr)
  apply (drule not_prime)
   apply clarsimp
  apply (metis dvd_triv_right less_le_trans mult.commute mult_le_cancel2
           One_nat_def less_eq_nat.simps(1) less_not_refl2
           mult_eq_self_implies_10 not_less)
  done

lemma partial_prime_sqr:
     "\<lbrakk> n * n > p \<rbrakk> \<Longrightarrow> partial_prime p n = prime p"
  apply (case_tac "n \<ge> p")
   apply (clarsimp simp: partial_prime_ge)
  apply (case_tac "partial_prime p n")
   apply clarsimp
   apply (erule sqrt_prime)
    apply (clarsimp simp: partial_prime_def)
    apply (case_tac "x = 0", simp)
    apply (case_tac "x = 1", simp)
    apply (frule_tac x=x in bspec)
     apply (clarsimp simp: min_def)
    apply clarsimp
   apply (clarsimp simp: not_le partial_prime_def)
  apply (case_tac "p = 0", simp)
  apply (case_tac "p = 1", simp)
  apply (auto simp: not_le partial_prime_def min_def prime_nat_simp)
  done

definition "SQRT_UINT_MAX \<equiv> 65536 :: nat"

lemma uint_max_factor [simp]:
  "UINT_MAX = SQRT_UINT_MAX * SQRT_UINT_MAX - 1"
  by (clarsimp simp: UINT_MAX_def SQRT_UINT_MAX_def)

lemma prime_dvd:
    "\<lbrakk> prime (p::nat) \<rbrakk> \<Longrightarrow> (r dvd p) = (r = 1 \<or> r = p)"
  by (fastforce simp: prime_nat_iff)

definition is_prime_inv
  where [simp]: "is_prime_inv n i s \<equiv> (1 < i \<and> i \<le> n \<and> i \<le> SQRT_UINT_MAX \<and> i * i \<le> SQRT_UINT_MAX * SQRT_UINT_MAX \<and> partial_prime n i)"

lemma nat_leE: "\<lbrakk> (a::nat) \<le> b; a < b \<Longrightarrow> R; a = b \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  apply atomize_elim
    apply clarsimp
  done

lemma sqr_less_mono [simp]:
    "((i::nat) * i < j * j) = (i < j)"
  by (metis (full_types) le0 less_not_refl3 linorder_neqE_nat
        mult_strict_mono' order.strict_trans)

declare mult_le_mono [intro]

lemma sqr_le_sqr_minus_1 [simp]:
    "\<lbrakk> b \<noteq> 0 \<rbrakk> \<Longrightarrow> (a * a \<le> b * b - Suc 0) = (a < b)"
  by (metis gr0I is_prime.sqr_less_mono nat_0_less_mult_iff nat_le_Suc_less)

theorem is_prime_faster_correct:
  notes times_nat.simps(2) [simp del] mult_Suc_right [simp del]
  shows "\<lbrace> \<lambda>s. n \<le> UINT_MAX \<rbrace> is_prime' n \<lbrace> \<lambda>r s. (r \<noteq> 0) \<longleftrightarrow> prime n \<rbrace>!"
  apply (rule validNF_assume_pre)
  apply (case_tac "n = 0")
   apply (clarsimp simp: is_prime'_def, wp, simp)[1]
  apply (case_tac "n = 1")
   apply (clarsimp simp: is_prime'_def, wp, simp)[1]
  apply (unfold is_prime'_def dvd_eq_mod_eq_0 [symmetric] SQRT_UINT_MAX_def [symmetric])
  apply (subst whileLoopE_add_inv [
      where I="\<lambda>r s. is_prime_inv n r s"
      and M="(\<lambda>(r, s). (Suc n) * (Suc n) - r * r)"])
   apply wp
    apply (fastforce elim: nat_leE simp: partial_prime_sqr prime_dvd)+
  apply (clarsimp simp: SQRT_UINT_MAX_def)
  done

end

end


(* Author: Peter Lammich
           Tobias Nipkow (tuning)
*)

section \<open>Binomial Heap\<close>

theory Binomial_Heap
imports
  "HOL-Library.Pattern_Aliases"
  Complex_Main
  Priority_Queue_Specs
begin

text \<open>
  We formalize the binomial heap presentation from Okasaki's book.
  We show the functional correctness and complexity of all operations.

  The presentation is engineered for simplicity, and most
  proofs are straightforward and automatic.
\<close>

subsection \<open>Binomial Tree and Heap Datatype\<close>

datatype 'a tree = Node (rank: nat) (root: 'a) (children: "'a tree list")

type_synonym 'a heap = "'a tree list"

subsubsection \<open>Multiset of elements\<close>

fun mset_tree :: "'a::linorder tree \<Rightarrow> 'a multiset" where
  "mset_tree (Node _ a ts) = {#a#} + (\<Sum>t\<in>#mset ts. mset_tree t)"

definition mset_heap :: "'a::linorder heap \<Rightarrow> 'a multiset" where
  "mset_heap ts = (\<Sum>t\<in>#mset ts. mset_tree t)"

lemma mset_tree_simp_alt[simp]:
  "mset_tree (Node r a ts) = {#a#} + mset_heap ts"
  unfolding mset_heap_def by auto
declare mset_tree.simps[simp del]

lemma mset_tree_nonempty[simp]: "mset_tree t \<noteq> {#}"
by (cases t) auto

lemma mset_heap_Nil[simp]:
  "mset_heap [] = {#}"
by (auto simp: mset_heap_def)

lemma mset_heap_Cons[simp]: "mset_heap (t#ts) = mset_tree t + mset_heap ts"
by (auto simp: mset_heap_def)

lemma mset_heap_empty_iff[simp]: "mset_heap ts = {#} \<longleftrightarrow> ts=[]"
by (auto simp: mset_heap_def)

lemma root_in_mset[simp]: "root t \<in># mset_tree t"
by (cases t) auto

lemma mset_heap_rev_eq[simp]: "mset_heap (rev ts) = mset_heap ts"
by (auto simp: mset_heap_def)

subsubsection \<open>Invariants\<close>

text \<open>Binomial invariant\<close>
fun invar_btree :: "'a::linorder tree \<Rightarrow> bool" where
"invar_btree (Node r x ts) \<longleftrightarrow>
   (\<forall>t\<in>set ts. invar_btree t) \<and> map rank ts = rev [0..<r]"

definition invar_bheap :: "'a::linorder heap \<Rightarrow> bool" where
"invar_bheap ts
  \<longleftrightarrow> (\<forall>t\<in>set ts. invar_btree t) \<and> (sorted_wrt (<) (map rank ts))"

text \<open>Ordering (heap) invariant\<close>
fun invar_otree :: "'a::linorder tree \<Rightarrow> bool" where
"invar_otree (Node _ x ts) \<longleftrightarrow> (\<forall>t\<in>set ts. invar_otree t \<and> x \<le> root t)"

definition invar_oheap :: "'a::linorder heap \<Rightarrow> bool" where
"invar_oheap ts \<longleftrightarrow> (\<forall>t\<in>set ts. invar_otree t)"

definition invar :: "'a::linorder heap \<Rightarrow> bool" where
"invar ts \<longleftrightarrow> invar_bheap ts \<and> invar_oheap ts"

text \<open>The children of a node are a valid heap\<close>
lemma invar_oheap_children:
  "invar_otree (Node r v ts) \<Longrightarrow> invar_oheap (rev ts)"
by (auto simp: invar_oheap_def)

lemma invar_bheap_children:
  "invar_btree (Node r v ts) \<Longrightarrow> invar_bheap (rev ts)"
by (auto simp: invar_bheap_def rev_map[symmetric])

subsection \<open>Operations and Their Functional Correctness\<close>

subsubsection \<open>\<open>link\<close>\<close>

context
includes pattern_aliases
begin

fun link :: "('a::linorder) tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
  "link (Node r x\<^sub>1 ts\<^sub>1 =: t\<^sub>1) (Node r' x\<^sub>2 ts\<^sub>2 =: t\<^sub>2) =
    (if x\<^sub>1\<le>x\<^sub>2 then Node (r+1) x\<^sub>1 (t\<^sub>2#ts\<^sub>1) else Node (r+1) x\<^sub>2 (t\<^sub>1#ts\<^sub>2))"

end

lemma invar_btree_link:
  assumes "invar_btree t\<^sub>1"
  assumes "invar_btree t\<^sub>2"
  assumes "rank t\<^sub>1 = rank t\<^sub>2"
  shows "invar_btree (link t\<^sub>1 t\<^sub>2)"
using assms
by (cases "(t\<^sub>1, t\<^sub>2)" rule: link.cases) simp

lemma invar_link_otree:
  assumes "invar_otree t\<^sub>1"
  assumes "invar_otree t\<^sub>2"
  shows "invar_otree (link t\<^sub>1 t\<^sub>2)"
using assms
by (cases "(t\<^sub>1, t\<^sub>2)" rule: link.cases) auto

lemma rank_link[simp]: "rank (link t\<^sub>1 t\<^sub>2) = rank t\<^sub>1 + 1"
by (cases "(t\<^sub>1, t\<^sub>2)" rule: link.cases) simp

lemma mset_link[simp]: "mset_tree (link t\<^sub>1 t\<^sub>2) = mset_tree t\<^sub>1 + mset_tree t\<^sub>2"
by (cases "(t\<^sub>1, t\<^sub>2)" rule: link.cases) simp

subsubsection \<open>\<open>ins_tree\<close>\<close>

fun ins_tree :: "'a::linorder tree \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
  "ins_tree t [] = [t]"
| "ins_tree t\<^sub>1 (t\<^sub>2#ts) =
  (if rank t\<^sub>1 < rank t\<^sub>2 then t\<^sub>1#t\<^sub>2#ts else ins_tree (link t\<^sub>1 t\<^sub>2) ts)"

lemma invar_bheap_Cons[simp]:
  "invar_bheap (t#ts)
  \<longleftrightarrow> invar_btree t \<and> invar_bheap ts \<and> (\<forall>t'\<in>set ts. rank t < rank t')"
by (auto simp: invar_bheap_def)

lemma invar_btree_ins_tree:
  assumes "invar_btree t"
  assumes "invar_bheap ts"
  assumes "\<forall>t'\<in>set ts. rank t \<le> rank t'"
  shows "invar_bheap (ins_tree t ts)"
using assms
by (induction t ts rule: ins_tree.induct) (auto simp: invar_btree_link less_eq_Suc_le[symmetric])

lemma invar_oheap_Cons[simp]:
  "invar_oheap (t#ts) \<longleftrightarrow> invar_otree t \<and> invar_oheap ts"
by (auto simp: invar_oheap_def)

lemma invar_oheap_ins_tree:
  assumes "invar_otree t"
  assumes "invar_oheap ts"
  shows "invar_oheap (ins_tree t ts)"
using assms
by (induction t ts rule: ins_tree.induct) (auto simp: invar_link_otree)

lemma mset_heap_ins_tree[simp]:
  "mset_heap (ins_tree t ts) = mset_tree t + mset_heap ts"
by (induction t ts rule: ins_tree.induct) auto

lemma ins_tree_rank_bound:
  assumes "t' \<in> set (ins_tree t ts)"
  assumes "\<forall>t'\<in>set ts. rank t\<^sub>0 < rank t'"
  assumes "rank t\<^sub>0 < rank t"
  shows "rank t\<^sub>0 < rank t'"
using assms
by (induction t ts rule: ins_tree.induct) (auto split: if_splits)

subsubsection \<open>\<open>insert\<close>\<close>

hide_const (open) insert

definition insert :: "'a::linorder \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
"insert x ts = ins_tree (Node 0 x []) ts"

lemma invar_insert[simp]: "invar t \<Longrightarrow> invar (insert x t)"
by (auto intro!: invar_btree_ins_tree simp: invar_oheap_ins_tree insert_def invar_def)

lemma mset_heap_insert[simp]: "mset_heap (insert x t) = {#x#} + mset_heap t"
by(auto simp: insert_def)

subsubsection \<open>\<open>merge\<close>\<close>

context
includes pattern_aliases
begin

fun merge :: "'a::linorder heap \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
  "merge ts\<^sub>1 [] = ts\<^sub>1"
| "merge [] ts\<^sub>2 = ts\<^sub>2"
| "merge (t\<^sub>1#ts\<^sub>1 =: h\<^sub>1) (t\<^sub>2#ts\<^sub>2 =: h\<^sub>2) = (
    if rank t\<^sub>1 < rank t\<^sub>2 then t\<^sub>1 # merge ts\<^sub>1 h\<^sub>2 else
    if rank t\<^sub>2 < rank t\<^sub>1 then t\<^sub>2 # merge h\<^sub>1 ts\<^sub>2
    else ins_tree (link t\<^sub>1 t\<^sub>2) (merge ts\<^sub>1 ts\<^sub>2)
  )"

end

lemma merge_simp2[simp]: "merge [] ts\<^sub>2 = ts\<^sub>2"
by (cases ts\<^sub>2) auto

lemma merge_rank_bound:
  assumes "t' \<in> set (merge ts\<^sub>1 ts\<^sub>2)"
  assumes "\<forall>t\<^sub>1\<in>set ts\<^sub>1. rank t < rank t\<^sub>1"
  assumes "\<forall>t\<^sub>2\<in>set ts\<^sub>2. rank t < rank t\<^sub>2"
  shows "rank t < rank t'"
using assms
by (induction ts\<^sub>1 ts\<^sub>2 arbitrary: t' rule: merge.induct)
   (auto split: if_splits simp: ins_tree_rank_bound)

lemma invar_bheap_merge:
  assumes "invar_bheap ts\<^sub>1"
  assumes "invar_bheap ts\<^sub>2"
  shows "invar_bheap (merge ts\<^sub>1 ts\<^sub>2)"
  using assms
proof (induction ts\<^sub>1 ts\<^sub>2 rule: merge.induct)
  case (3 t\<^sub>1 ts\<^sub>1 t\<^sub>2 ts\<^sub>2)

  from "3.prems" have [simp]: "invar_btree t\<^sub>1" "invar_btree t\<^sub>2"
    by auto

  consider (LT) "rank t\<^sub>1 < rank t\<^sub>2"
         | (GT) "rank t\<^sub>1 > rank t\<^sub>2"
         | (EQ) "rank t\<^sub>1 = rank t\<^sub>2"
    using antisym_conv3 by blast
  then show ?case proof cases
    case LT
    then show ?thesis using 3
      by (force elim!: merge_rank_bound)
  next
    case GT
    then show ?thesis using 3
      by (force elim!: merge_rank_bound)
  next
    case [simp]: EQ

    from "3.IH"(3) "3.prems" have [simp]: "invar_bheap (merge ts\<^sub>1 ts\<^sub>2)"
      by auto

    have "rank t\<^sub>2 < rank t'" if "t' \<in> set (merge ts\<^sub>1 ts\<^sub>2)" for t'
      using that
      apply (rule merge_rank_bound)
      using "3.prems" by auto
    with EQ show ?thesis
      by (auto simp: Suc_le_eq invar_btree_ins_tree invar_btree_link)
  qed
qed simp_all

lemma invar_oheap_merge:
  assumes "invar_oheap ts\<^sub>1"
  assumes "invar_oheap ts\<^sub>2"
  shows "invar_oheap (merge ts\<^sub>1 ts\<^sub>2)"
using assms
by (induction ts\<^sub>1 ts\<^sub>2 rule: merge.induct)
   (auto simp: invar_oheap_ins_tree invar_link_otree)

lemma invar_merge[simp]: "\<lbrakk> invar ts\<^sub>1; invar ts\<^sub>2 \<rbrakk> \<Longrightarrow> invar (merge ts\<^sub>1 ts\<^sub>2)"
by (auto simp: invar_def invar_bheap_merge invar_oheap_merge)

lemma mset_heap_merge[simp]:
  "mset_heap (merge ts\<^sub>1 ts\<^sub>2) = mset_heap ts\<^sub>1 + mset_heap ts\<^sub>2"
by (induction ts\<^sub>1 ts\<^sub>2 rule: merge.induct) auto

subsubsection \<open>\<open>get_min\<close>\<close>

fun get_min :: "'a::linorder heap \<Rightarrow> 'a" where
  "get_min [t] = root t"
| "get_min (t#ts) = min (root t) (get_min ts)"

lemma invar_otree_root_min:
  assumes "invar_otree t"
  assumes "x \<in># mset_tree t"
  shows "root t \<le> x"
using assms
by (induction t arbitrary: x rule: mset_tree.induct) (fastforce simp: mset_heap_def)

lemma get_min_mset_aux:
  assumes "ts\<noteq>[]"
  assumes "invar_oheap ts"
  assumes "x \<in># mset_heap ts"
  shows "get_min ts \<le> x"
  using assms
apply (induction ts arbitrary: x rule: get_min.induct)
apply (auto
      simp: invar_otree_root_min min_def intro: order_trans;
      meson linear order_trans invar_otree_root_min
      )+
done

lemma get_min_mset:
  assumes "ts\<noteq>[]"
  assumes "invar ts"
  assumes "x \<in># mset_heap ts"
  shows "get_min ts \<le> x"
using assms by (auto simp: invar_def get_min_mset_aux)

lemma get_min_member:
  "ts\<noteq>[] \<Longrightarrow> get_min ts \<in># mset_heap ts"
by (induction ts rule: get_min.induct) (auto simp: min_def)

lemma get_min:
  assumes "mset_heap ts \<noteq> {#}"
  assumes "invar ts"
  shows "get_min ts = Min_mset (mset_heap ts)"
using assms get_min_member get_min_mset
by (auto simp: eq_Min_iff)

subsubsection \<open>\<open>get_min_rest\<close>\<close>

fun get_min_rest :: "'a::linorder heap \<Rightarrow> 'a tree \<times> 'a heap" where
  "get_min_rest [t] = (t,[])"
| "get_min_rest (t#ts) = (let (t',ts') = get_min_rest ts
                     in if root t \<le> root t' then (t,ts) else (t',t#ts'))"

lemma get_min_rest_get_min_same_root:
  assumes "ts\<noteq>[]"
  assumes "get_min_rest ts = (t',ts')"
  shows "root t' = get_min ts"
using assms
by (induction ts arbitrary: t' ts' rule: get_min.induct) (auto simp: min_def split: prod.splits)

lemma mset_get_min_rest:
  assumes "get_min_rest ts = (t',ts')"
  assumes "ts\<noteq>[]"
  shows "mset ts = {#t'#} + mset ts'"
using assms
by (induction ts arbitrary: t' ts' rule: get_min.induct) (auto split: prod.splits if_splits)

lemma set_get_min_rest:
  assumes "get_min_rest ts = (t', ts')"
  assumes "ts\<noteq>[]"
  shows "set ts = Set.insert t' (set ts')"
using mset_get_min_rest[OF assms, THEN arg_cong[where f=set_mset]]
by auto

lemma invar_bheap_get_min_rest:
  assumes "get_min_rest ts = (t',ts')"
  assumes "ts\<noteq>[]"
  assumes "invar_bheap ts"
  shows "invar_btree t'" and "invar_bheap ts'"
proof -
  have "invar_btree t' \<and> invar_bheap ts'"
    using assms
    proof (induction ts arbitrary: t' ts' rule: get_min.induct)
      case (2 t v va)
      then show ?case
        apply (clarsimp split: prod.splits if_splits)
        apply (drule set_get_min_rest; fastforce)
        done
    qed auto
  thus "invar_btree t'" and "invar_bheap ts'" by auto
qed

lemma invar_oheap_get_min_rest:
  assumes "get_min_rest ts = (t',ts')"
  assumes "ts\<noteq>[]"
  assumes "invar_oheap ts"
  shows "invar_otree t'" and "invar_oheap ts'"
using assms
by (induction ts arbitrary: t' ts' rule: get_min.induct) (auto split: prod.splits if_splits)

subsubsection \<open>\<open>del_min\<close>\<close>

definition del_min :: "'a::linorder heap \<Rightarrow> 'a::linorder heap" where
"del_min ts = (case get_min_rest ts of
   (Node r x ts\<^sub>1, ts\<^sub>2) \<Rightarrow> merge (rev ts\<^sub>1) ts\<^sub>2)"

lemma invar_del_min[simp]:
  assumes "ts \<noteq> []"
  assumes "invar ts"
  shows "invar (del_min ts)"
using assms
unfolding invar_def del_min_def
by (auto
      split: prod.split tree.split
      intro!: invar_bheap_merge invar_oheap_merge
      dest: invar_bheap_get_min_rest invar_oheap_get_min_rest
      intro!: invar_oheap_children invar_bheap_children
    )

lemma mset_heap_del_min:
  assumes "ts \<noteq> []"
  shows "mset_heap ts = mset_heap (del_min ts) + {# get_min ts #}"
using assms
unfolding del_min_def
apply (clarsimp split: tree.split prod.split)
apply (frule (1) get_min_rest_get_min_same_root)
apply (frule (1) mset_get_min_rest)
apply (auto simp: mset_heap_def)
done

subsubsection \<open>Instantiating the Priority Queue Locale\<close>

text \<open>Last step of functional correctness proof: combine all the above lemmas
to show that binomial heaps satisfy the specification of priority queues with merge.\<close>

interpretation binheap: Priority_Queue_Merge
  where empty = "[]" and is_empty = "(=) []" and insert = insert
  and get_min = get_min and del_min = del_min and merge = merge
  and invar = invar and mset = mset_heap
proof (unfold_locales, goal_cases)
  case 1 thus ?case by simp
next
  case 2 thus ?case by auto
next
  case 3 thus ?case by auto
next
  case (4 q)
  thus ?case using mset_heap_del_min[of q] get_min[OF _ \<open>invar q\<close>]
    by (auto simp: union_single_eq_diff)
next
  case (5 q) thus ?case using get_min[of q] by auto
next
  case 6 thus ?case by (auto simp add: invar_def invar_bheap_def invar_oheap_def)
next
  case 7 thus ?case by simp
next
  case 8 thus ?case by simp
next
  case 9 thus ?case by simp
next
  case 10 thus ?case by simp
qed

subsection \<open>Complexity\<close>

text \<open>The size of a binomial tree is determined by its rank\<close>
lemma size_mset_btree:
  assumes "invar_btree t"
  shows "size (mset_tree t) = 2^rank t"
  using assms
proof (induction t)
  case (Node r v ts)
  hence IH: "size (mset_tree t) = 2^rank t" if "t \<in> set ts" for t
    using that by auto

  from Node have COMPL: "map rank ts = rev [0..<r]" by auto

  have "size (mset_heap ts) = (\<Sum>t\<leftarrow>ts. size (mset_tree t))"
    by (induction ts) auto
  also have "\<dots> = (\<Sum>t\<leftarrow>ts. 2^rank t)" using IH
    by (auto cong: map_cong)
  also have "\<dots> = (\<Sum>r\<leftarrow>map rank ts. 2^r)"
    by (induction ts) auto
  also have "\<dots> = (\<Sum>i\<in>{0..<r}. 2^i)"
    unfolding COMPL
    by (auto simp: rev_map[symmetric] interv_sum_list_conv_sum_set_nat)
  also have "\<dots> = 2^r - 1"
    by (induction r) auto
  finally show ?case
    by (simp)
qed

text \<open>The length of a binomial heap is bounded by the number of its elements\<close>
lemma size_mset_bheap:
  assumes "invar_bheap ts"
  shows "2^length ts \<le> size (mset_heap ts) + 1"
proof -
  from \<open>invar_bheap ts\<close> have
    ASC: "sorted_wrt (<) (map rank ts)" and
    TINV: "\<forall>t\<in>set ts. invar_btree t"
    unfolding invar_bheap_def by auto

  have "(2::nat)^length ts = (\<Sum>i\<in>{0..<length ts}. 2^i) + 1"
    by (simp add: sum_power2)
  also have "\<dots> \<le> (\<Sum>t\<leftarrow>ts. 2^rank t) + 1"
    using sorted_wrt_less_sum_mono_lowerbound[OF _ ASC, of "(^) (2::nat)"]
    using power_increasing[where a="2::nat"]
    by (auto simp: o_def)
  also have "\<dots> = (\<Sum>t\<leftarrow>ts. size (mset_tree t)) + 1" using TINV
    by (auto cong: map_cong simp: size_mset_btree)
  also have "\<dots> = size (mset_heap ts) + 1"
    unfolding mset_heap_def by (induction ts) auto
  finally show ?thesis .
qed

subsubsection \<open>Timing Functions\<close>

text \<open>
  We define timing functions for each operation, and provide
  estimations of their complexity.
\<close>
definition t_link :: "'a::linorder tree \<Rightarrow> 'a tree \<Rightarrow> nat" where
[simp]: "t_link _ _ = 1"

fun t_ins_tree :: "'a::linorder tree \<Rightarrow> 'a heap \<Rightarrow> nat" where
  "t_ins_tree t [] = 1"
| "t_ins_tree t\<^sub>1 (t\<^sub>2 # rest) = (
    (if rank t\<^sub>1 < rank t\<^sub>2 then 1
     else t_link t\<^sub>1 t\<^sub>2 + t_ins_tree (link t\<^sub>1 t\<^sub>2) rest)
  )"

definition t_insert :: "'a::linorder \<Rightarrow> 'a heap \<Rightarrow> nat" where
"t_insert x ts = t_ins_tree (Node 0 x []) ts"

lemma t_ins_tree_simple_bound: "t_ins_tree t ts \<le> length ts + 1"
by (induction t ts rule: t_ins_tree.induct) auto

subsubsection \<open>\<open>t_insert\<close>\<close>

lemma t_insert_bound:
  assumes "invar ts"
  shows "t_insert x ts \<le> log 2 (size (mset_heap ts) + 1) + 1"
proof -

  have 1: "t_insert x ts \<le> length ts + 1"
    unfolding t_insert_def by (rule t_ins_tree_simple_bound)
  also have "\<dots> \<le> log 2 (2 * (size (mset_heap ts) + 1))"
  proof -
    from size_mset_bheap[of ts] assms
    have "2 ^ length ts \<le> size (mset_heap ts) + 1"
      unfolding invar_def by auto
    hence "2 ^ (length ts + 1) \<le> 2 * (size (mset_heap ts) + 1)" by auto
    thus ?thesis using le_log2_of_power by blast
  qed
  finally show ?thesis
    by (simp only: log_mult of_nat_mult) auto
qed

subsubsection \<open>\<open>t_merge\<close>\<close>

context
includes pattern_aliases
begin

fun t_merge :: "'a::linorder heap \<Rightarrow> 'a heap \<Rightarrow> nat" where
  "t_merge ts\<^sub>1 [] = 1"
| "t_merge [] ts\<^sub>2 = 1"
| "t_merge (t\<^sub>1#ts\<^sub>1 =: h\<^sub>1) (t\<^sub>2#ts\<^sub>2 =: h\<^sub>2) = 1 + (
    if rank t\<^sub>1 < rank t\<^sub>2 then t_merge ts\<^sub>1 h\<^sub>2
    else if rank t\<^sub>2 < rank t\<^sub>1 then t_merge h\<^sub>1 ts\<^sub>2
    else t_ins_tree (link t\<^sub>1 t\<^sub>2) (merge ts\<^sub>1 ts\<^sub>2) + t_merge ts\<^sub>1 ts\<^sub>2
  )"

end

text \<open>A crucial idea is to estimate the time in correlation with the
  result length, as each carry reduces the length of the result.\<close>

lemma t_ins_tree_length:
  "t_ins_tree t ts + length (ins_tree t ts) = 2 + length ts"
by (induction t ts rule: ins_tree.induct) auto

lemma t_merge_length:
  "length (merge ts\<^sub>1 ts\<^sub>2) + t_merge ts\<^sub>1 ts\<^sub>2 \<le> 2 * (length ts\<^sub>1 + length ts\<^sub>2) + 1"
by (induction ts\<^sub>1 ts\<^sub>2 rule: t_merge.induct)
   (auto simp: t_ins_tree_length algebra_simps)

text \<open>Finally, we get the desired logarithmic bound\<close>
lemma t_merge_bound_aux:
  fixes ts\<^sub>1 ts\<^sub>2
  defines "n\<^sub>1 \<equiv> size (mset_heap ts\<^sub>1)"
  defines "n\<^sub>2 \<equiv> size (mset_heap ts\<^sub>2)"
  assumes BINVARS: "invar_bheap ts\<^sub>1" "invar_bheap ts\<^sub>2"
  shows "t_merge ts\<^sub>1 ts\<^sub>2 \<le> 4*log 2 (n\<^sub>1 + n\<^sub>2 + 1) + 2"
proof -
  define n where "n = n\<^sub>1 + n\<^sub>2"

  from t_merge_length[of ts\<^sub>1 ts\<^sub>2]
  have "t_merge ts\<^sub>1 ts\<^sub>2 \<le> 2 * (length ts\<^sub>1 + length ts\<^sub>2) + 1" by auto
  hence "(2::nat)^t_merge ts\<^sub>1 ts\<^sub>2 \<le> 2^(2 * (length ts\<^sub>1 + length ts\<^sub>2) + 1)"
    by (rule power_increasing) auto
  also have "\<dots> = 2*(2^length ts\<^sub>1)\<^sup>2*(2^length ts\<^sub>2)\<^sup>2"
    by (auto simp: algebra_simps power_add power_mult)
  also note BINVARS(1)[THEN size_mset_bheap]
  also note BINVARS(2)[THEN size_mset_bheap]
  finally have "2 ^ t_merge ts\<^sub>1 ts\<^sub>2 \<le> 2 * (n\<^sub>1 + 1)\<^sup>2 * (n\<^sub>2 + 1)\<^sup>2"
    by (auto simp: power2_nat_le_eq_le n\<^sub>1_def n\<^sub>2_def)
  from le_log2_of_power[OF this] have "t_merge ts\<^sub>1 ts\<^sub>2 \<le> log 2 \<dots>"
    by simp
  also have "\<dots> = log 2 2 + 2*log 2 (n\<^sub>1 + 1) + 2*log 2 (n\<^sub>2 + 1)"
    by (simp add: log_mult log_nat_power)
  also have "n\<^sub>2 \<le> n" by (auto simp: n_def)
  finally have "t_merge ts\<^sub>1 ts\<^sub>2 \<le> log 2 2 + 2*log 2 (n\<^sub>1 + 1) + 2*log 2 (n + 1)"
    by auto
  also have "n\<^sub>1 \<le> n" by (auto simp: n_def)
  finally have "t_merge ts\<^sub>1 ts\<^sub>2 \<le> log 2 2 + 4*log 2 (n + 1)"
    by auto
  also have "log 2 2 \<le> 2" by auto
  finally have "t_merge ts\<^sub>1 ts\<^sub>2 \<le> 4*log 2 (n + 1) + 2" by auto
  thus ?thesis unfolding n_def by (auto simp: algebra_simps)
qed

lemma t_merge_bound:
  fixes ts\<^sub>1 ts\<^sub>2
  defines "n\<^sub>1 \<equiv> size (mset_heap ts\<^sub>1)"
  defines "n\<^sub>2 \<equiv> size (mset_heap ts\<^sub>2)"
  assumes "invar ts\<^sub>1" "invar ts\<^sub>2"
  shows "t_merge ts\<^sub>1 ts\<^sub>2 \<le> 4*log 2 (n\<^sub>1 + n\<^sub>2 + 1) + 2"
using assms t_merge_bound_aux unfolding invar_def by blast

subsubsection \<open>\<open>t_get_min\<close>\<close>

fun t_get_min :: "'a::linorder heap \<Rightarrow> nat" where
  "t_get_min [t] = 1"
| "t_get_min (t#ts) = 1 + t_get_min ts"

lemma t_get_min_estimate: "ts\<noteq>[] \<Longrightarrow> t_get_min ts = length ts"
by (induction ts rule: t_get_min.induct) auto

lemma t_get_min_bound:
  assumes "invar ts"
  assumes "ts\<noteq>[]"
  shows "t_get_min ts \<le> log 2 (size (mset_heap ts) + 1)"
proof -
  have 1: "t_get_min ts = length ts" using assms t_get_min_estimate by auto
  also have "\<dots> \<le> log 2 (size (mset_heap ts) + 1)"
  proof -
    from size_mset_bheap[of ts] assms have "2 ^ length ts \<le> size (mset_heap ts) + 1"
      unfolding invar_def by auto
    thus ?thesis using le_log2_of_power by blast
  qed
  finally show ?thesis by auto
qed

subsubsection \<open>\<open>t_del_min\<close>\<close>

fun t_get_min_rest :: "'a::linorder heap \<Rightarrow> nat" where
  "t_get_min_rest [t] = 1"
| "t_get_min_rest (t#ts) = 1 + t_get_min_rest ts"

lemma t_get_min_rest_estimate: "ts\<noteq>[] \<Longrightarrow> t_get_min_rest ts = length ts"
  by (induction ts rule: t_get_min_rest.induct) auto

lemma t_get_min_rest_bound_aux:
  assumes "invar_bheap ts"
  assumes "ts\<noteq>[]"
  shows "t_get_min_rest ts \<le> log 2 (size (mset_heap ts) + 1)"
proof -
  have 1: "t_get_min_rest ts = length ts" using assms t_get_min_rest_estimate by auto
  also have "\<dots> \<le> log 2 (size (mset_heap ts) + 1)"
  proof -
    from size_mset_bheap[of ts] assms have "2 ^ length ts \<le> size (mset_heap ts) + 1"
      by auto
    thus ?thesis using le_log2_of_power by blast
  qed
  finally show ?thesis by auto
qed

lemma t_get_min_rest_bound:
  assumes "invar ts"
  assumes "ts\<noteq>[]"
  shows "t_get_min_rest ts \<le> log 2 (size (mset_heap ts) + 1)"
using assms t_get_min_rest_bound_aux unfolding invar_def by blast

text\<open>Note that although the definition of function \<^const>\<open>rev\<close> has quadratic complexity,
it can and is implemented (via suitable code lemmas) as a linear time function.
Thus the following definition is justified:\<close>

definition "t_rev xs = length xs + 1"

definition t_del_min :: "'a::linorder heap \<Rightarrow> nat" where
  "t_del_min ts = t_get_min_rest ts + (case get_min_rest ts of (Node _ x ts\<^sub>1, ts\<^sub>2)
                    \<Rightarrow> t_rev ts\<^sub>1 + t_merge (rev ts\<^sub>1) ts\<^sub>2
  )"

lemma t_rev_ts1_bound_aux:
  fixes ts
  defines "n \<equiv> size (mset_heap ts)"
  assumes BINVAR: "invar_bheap (rev ts)"
  shows "t_rev ts \<le> 1 + log 2 (n+1)"
proof -
  have "t_rev ts = length ts + 1" by (auto simp: t_rev_def)
  hence "2^t_rev ts = 2*2^length ts" by auto
  also have "\<dots> \<le> 2*n+2" using size_mset_bheap[OF BINVAR] by (auto simp: n_def)
  finally have "2 ^ t_rev ts \<le> 2 * n + 2" .
  from le_log2_of_power[OF this] have "t_rev ts \<le> log 2 (2 * (n + 1))"
    by auto
  also have "\<dots> = 1 + log 2 (n+1)"
    by (simp only: of_nat_mult log_mult) auto
  finally show ?thesis by (auto simp: algebra_simps)
qed

lemma t_del_min_bound_aux:
  fixes ts
  defines "n \<equiv> size (mset_heap ts)"
  assumes BINVAR: "invar_bheap ts"
  assumes "ts\<noteq>[]"
  shows "t_del_min ts \<le> 6 * log 2 (n+1) + 3"
proof -
  obtain r x ts\<^sub>1 ts\<^sub>2 where GM: "get_min_rest ts = (Node r x ts\<^sub>1, ts\<^sub>2)"
    by (metis surj_pair tree.exhaust_sel)

  note BINVAR' = invar_bheap_get_min_rest[OF GM \<open>ts\<noteq>[]\<close> BINVAR]
  hence BINVAR1: "invar_bheap (rev ts\<^sub>1)" by (blast intro: invar_bheap_children)

  define n\<^sub>1 where "n\<^sub>1 = size (mset_heap ts\<^sub>1)"
  define n\<^sub>2 where "n\<^sub>2 = size (mset_heap ts\<^sub>2)"

  have t_rev_ts1_bound: "t_rev ts\<^sub>1 \<le> 1 + log 2 (n+1)"
  proof -
    note t_rev_ts1_bound_aux[OF BINVAR1, simplified, folded n\<^sub>1_def]
    also have "n\<^sub>1 \<le> n"
      unfolding n\<^sub>1_def n_def
      using mset_get_min_rest[OF GM \<open>ts\<noteq>[]\<close>]
      by (auto simp: mset_heap_def)
    finally show ?thesis by (auto simp: algebra_simps)
  qed

  have "t_del_min ts = t_get_min_rest ts + t_rev ts\<^sub>1 + t_merge (rev ts\<^sub>1) ts\<^sub>2"
    unfolding t_del_min_def by (simp add: GM)
  also have "\<dots> \<le> log 2 (n+1) + t_rev ts\<^sub>1 + t_merge (rev ts\<^sub>1) ts\<^sub>2"
    using t_get_min_rest_bound_aux[OF assms(2-)] by (auto simp: n_def)
  also have "\<dots> \<le> 2*log 2 (n+1) + t_merge (rev ts\<^sub>1) ts\<^sub>2 + 1"
    using t_rev_ts1_bound by auto
  also have "\<dots> \<le> 2*log 2 (n+1) + 4 * log 2 (n\<^sub>1 + n\<^sub>2 + 1) + 3"
    using t_merge_bound_aux[OF \<open>invar_bheap (rev ts\<^sub>1)\<close> \<open>invar_bheap ts\<^sub>2\<close>]
    by (auto simp: n\<^sub>1_def n\<^sub>2_def algebra_simps)
  also have "n\<^sub>1 + n\<^sub>2 \<le> n"
    unfolding n\<^sub>1_def n\<^sub>2_def n_def
    using mset_get_min_rest[OF GM \<open>ts\<noteq>[]\<close>]
    by (auto simp: mset_heap_def)
  finally have "t_del_min ts \<le> 6 * log 2 (n+1) + 3"
    by auto
  thus ?thesis by (simp add: algebra_simps)
qed

lemma t_del_min_bound:
  fixes ts
  defines "n \<equiv> size (mset_heap ts)"
  assumes "invar ts"
  assumes "ts\<noteq>[]"
  shows "t_del_min ts \<le> 6 * log 2 (n+1) + 3"
using assms t_del_min_bound_aux unfolding invar_def by blast

end