section\<open>Filters and Congruences\<close>

theory PseudoHoopFilters
imports PseudoHoops
begin

context pseudo_hoop_algebra
begin
definition
  "filters = {F . F \<noteq> {} \<and> (\<forall> a b . a \<in> F \<and> b \<in> F \<longrightarrow> a * b \<in> F) \<and> (\<forall> a b . a \<in> F \<and> a \<le> b \<longrightarrow> b \<in> F)}"

definition
  "properfilters = {F . F \<in> filters \<and> F \<noteq> UNIV}"

definition
  "maximalfilters = {F . F \<in> filters \<and> (\<forall> A . A \<in> filters \<and> F \<subseteq> A \<longrightarrow> A = F \<or> A = UNIV)}"

definition
  "ultrafilters = properfilters \<inter> maximalfilters"

lemma filter_i: "F \<in> filters \<Longrightarrow> a \<in> F \<Longrightarrow> b \<in> F \<Longrightarrow> a * b \<in> F"
  by (simp add: filters_def)

lemma filter_ii: "F \<in> filters \<Longrightarrow> a \<in> F \<Longrightarrow> a \<le> b \<Longrightarrow> b \<in> F"
 by (simp add: filters_def)

lemma filter_iii [simp]: "F \<in> filters \<Longrightarrow> 1 \<in> F"
  by (auto simp add: filters_def)

lemma filter_left_impl:
  "(F \<in> filters) = ((1 \<in> F) \<and> (\<forall> a b . a \<in> F \<and> a l\<rightarrow> b \<in> F \<longrightarrow> b \<in> F))"
  apply safe
  apply simp
  apply (frule_tac a = "a l\<rightarrow> b" and b = a in filter_i)
  apply simp
  apply simp
  apply (rule_tac a = "(a l\<rightarrow> b) * a" in filter_ii)
  apply simp
  apply simp
  apply (simp add: inf_l_def [THEN sym])
  apply (subst filters_def)
  apply safe
  apply (subgoal_tac "a l\<rightarrow> (b l\<rightarrow> a * b) \<in> F")
  apply blast
  apply (subst left_impl_ded [THEN sym])
  apply (subst left_impl_one)
  apply safe
  apply (subst (asm) left_lesseq)
  by blast

lemma filter_right_impl:
  "(F \<in> filters) = ((1 \<in> F) \<and> (\<forall> a b . a \<in> F \<and> a r\<rightarrow> b \<in> F \<longrightarrow> b \<in> F))"
  apply safe
  apply simp
  apply (frule_tac a = a and b = "a r\<rightarrow> b" in filter_i)
  apply simp
  apply simp
  apply (rule_tac a = "a * (a r\<rightarrow> b)" in filter_ii)
  apply simp
  apply simp
  apply (simp add: inf_r_def [THEN sym])
  apply (subst filters_def)
  apply safe
  apply (subgoal_tac "b r\<rightarrow> (a r\<rightarrow> a * b) \<in> F")
  apply blast
  apply (subst right_impl_ded [THEN sym])
  apply (subst right_impl_one)
  apply safe
  apply (subst (asm) right_lesseq)
  by blast

definition
  "filterof X = \<Inter> {F . F \<in> filters \<and> X \<subseteq> F}"

lemma [simp]: "filterof X \<in> filters"
  by (auto simp add: filterof_def)

lemma times_le_mono [simp]: "x \<le> y \<Longrightarrow> u \<le> v \<Longrightarrow> x * u \<le> y * v"
  apply (rule_tac y = "x * v" in order_trans)
  by (simp_all add: mult_left_mono mult_right_mono)

lemma prop_3_2_i:
  "filterof X = {a . \<exists> n x . x \<in> X *^ n \<and> x \<le> a}"
  apply safe
  apply (subgoal_tac "{a . \<exists> n x . x \<in> X *^ n \<and> x \<le> a} \<in> filters")
  apply (simp add: filterof_def)
  apply (drule_tac x = "{a::'a. \<exists>(n::nat) x::'a. x \<in> X *^ n \<and> x \<le> a}" in spec)
  apply safe
  apply (rule_tac x = "1::nat" in exI)
  apply (rule_tac x = "xa" in exI)
  apply (simp add: times_set_def)
  apply (drule drop_assumption)
  apply (simp add: filters_def)
  apply safe
  apply (rule_tac x = "1" in exI)
  apply (rule_tac x = "0" in exI)
  apply (rule_tac x = "1" in exI)
  apply simp
  apply (rule_tac x = "n + na" in exI)
  apply (rule_tac x = "x * xa" in exI)
  apply safe
  apply (simp add: power_set_add times_set_def)
  apply blast
  apply simp
  apply (rule_tac x = "n" in exI)
  apply (rule_tac x = "x" in exI)
  apply simp
  apply (simp add: filterof_def)
  apply safe
  apply (rule filter_ii)
  apply simp_all
  apply (subgoal_tac "\<forall>x . x \<in> X *^ n \<longrightarrow> x \<in> xb")
  apply simp
  apply (induct_tac n)
  apply (simp add: power_set_0)
  apply (simp add: power_set_Suc times_set_def)
  apply safe
  apply (rule filter_i)
  apply simp_all
  by blast

lemma ultrafilter_union:
  "ultrafilters = {F . F \<in> filters \<and> F \<noteq> UNIV \<and> (\<forall> x . x \<notin> F \<longrightarrow> filterof (F \<union> {x}) = UNIV)}"
  apply (simp add: ultrafilters_def maximalfilters_def properfilters_def filterof_def)
  by auto

lemma filterof_sub: "F \<in> filters \<Longrightarrow> X \<subseteq> F \<Longrightarrow> filterof X \<subseteq> F"
  apply (simp add: filterof_def)
  by blast

lemma filterof_elem [simp]: "x \<in> X \<Longrightarrow> x \<in>  filterof X"
  apply (simp add: filterof_def)
  by blast

lemma [simp]: "filterof X \<in> filters"
  apply (simp add: filters_def  prop_3_2_i)
  apply safe
  apply (rule_tac x = 1 in exI)
  apply (rule_tac x = 0 in exI)
  apply (rule_tac x = 1 in exI)
  apply auto [1]
  apply (rule_tac x = "n + na" in exI)
  apply (rule_tac x = "x * xa" in exI)
  apply safe
  apply (unfold power_set_add)
  apply (simp add: times_set_def)
  apply auto [1]
  apply (rule_tac y = "x * b" in order_trans)
  apply (rule mult_left_mono)
  apply simp
  apply (simp add: mult_right_mono)
  apply (rule_tac x = n in exI)
  apply (rule_tac x = x in exI)
  by simp

lemma singleton_power [simp]: "{a} *^ n = {b . b = a ^ n}"
  apply (induct_tac n)
  apply auto [1]
  by (simp add: times_set_def)

lemma power_pair: "x \<in> {a, b} *^ n \<Longrightarrow> \<exists> i j . i + j = n \<and> x \<le> a ^ i \<and> x \<le> b ^ j"
  apply (subgoal_tac "\<forall> x . x \<in> {a, b} *^ n \<longrightarrow> (\<exists> i j . i + j = n \<and> x \<le> a ^ i \<and> x \<le> b ^ j)")
  apply auto[1]
  apply (drule drop_assumption)
  apply (induct_tac n)
  apply auto [1]
  apply safe
  apply (simp add: times_set_def)
  apply safe
  apply (drule_tac x = y in spec)
  apply safe
  apply (rule_tac x = "i + 1" in exI)
  apply (rule_tac x = "j" in exI)
  apply simp
  apply (rule_tac y = y in order_trans)
  apply simp_all
  apply (drule_tac x = y in spec)
  apply safe
  apply (rule_tac x = "i" in exI)
  apply (rule_tac x = "j+1" in exI)
  apply simp
  apply (rule_tac y = y in order_trans)
  by simp_all

lemma filterof_supremum:
  "c \<in> supremum {a, b} \<Longrightarrow> filterof {c} = filterof {a} \<inter> filterof {b}"
  apply safe
  apply (cut_tac X = "{c}" and F = "filterof {a}" in filterof_sub)
  apply simp_all
  apply (simp add: supremum_def upper_bound_def)
  apply safe
  apply (rule_tac  a = a in filter_ii)
  apply simp_all
  apply blast
  apply (cut_tac X = "{c}" and F = "filterof {b}" in filterof_sub)
  apply simp_all
  apply (simp add: supremum_def upper_bound_def)
  apply safe
  apply (rule_tac  a = b in filter_ii)
  apply simp_all
  apply blast
  apply (subst (asm) prop_3_2_i)
  apply simp
  apply (subst (asm) prop_3_2_i)
  apply simp
  apply safe
  apply (cut_tac A = "{a, b}" and a = c and b = x and n = "n + na" in  lemma_2_8_ii1)
  apply simp
  apply (subst prop_3_2_i)
  apply simp
  apply (rule_tac x = "n + na" in exI)
  apply (subgoal_tac "infimum ((\<lambda>xa::'a. xa r\<rightarrow> x) ` ({a, b} *^ (n + na))) = {1}")
  apply simp
  apply (simp add: right_lesseq)
  apply (subst infimum_unique)
  apply (subst infimum_def lower_bound_def)
  apply (subst lower_bound_def)
  apply safe
  apply simp_all
  apply (drule power_pair)
  apply safe
  apply (subst right_residual [THEN sym])
  apply simp
  apply (case_tac "n \<le> i")
  apply (rule_tac y = "a ^ n" in order_trans)
  apply (rule_tac y = "a ^ i" in order_trans)
  apply simp_all
  apply (subgoal_tac "na \<le> j")
  apply (rule_tac y = "b ^ na" in order_trans)
  apply (rule_tac y = "b ^ j" in order_trans)
  by simp_all

definition "d1 a b = (a l\<rightarrow> b) * (b l\<rightarrow> a)"
definition "d2 a b = (a r\<rightarrow> b) * (b r\<rightarrow> a)"

definition "d3 a b = d1 b a"
definition "d4 a b = d2 b a"

lemma [simp]: "(a * b = 1) = (a = 1 \<and> b = 1)"
  apply (rule iffI)
  apply (rule conjI)
  apply (rule antisym)
  apply simp
  apply (rule_tac y = "a*b" in order_trans)
  apply simp
  apply (drule drop_assumption)
  apply simp
  apply (rule antisym)
  apply simp
  apply (rule_tac y = "a*b" in order_trans)
  apply simp
  apply (drule drop_assumption)
  apply simp
  by simp

lemma lemma_3_5_i_1: "(d1 a b = 1) = (a = b)"
  apply (simp add: d1_def left_lesseq [THEN sym])
  by auto

lemma lemma_3_5_i_2: "(d2 a b = 1) = (a = b)"
  apply (simp add: d2_def right_lesseq [THEN sym])
  by auto

lemma lemma_3_5_i_3: "(d3 a b = 1) = (a = b)"
  apply (simp add: d3_def lemma_3_5_i_1)
  by auto

lemma lemma_3_5_i_4: "(d4 a b = 1) = (a = b)"
  apply (simp add: d4_def lemma_3_5_i_2)
  by auto

lemma lemma_3_5_ii_1 [simp]: "d1 a a = 1"
  apply (subst lemma_3_5_i_1)
  by simp

lemma lemma_3_5_ii_2 [simp]: "d2 a a = 1"
  apply (subst lemma_3_5_i_2)
  by simp

lemma lemma_3_5_ii_3 [simp]: "d3 a a = 1"
  apply (subst lemma_3_5_i_3)
  by simp

lemma lemma_3_5_ii_4 [simp]: "d4 a a = 1"
  apply (subst lemma_3_5_i_4)
  by simp

lemma [simp]: "(a l\<rightarrow> 1) = 1"
  by (simp add: left_lesseq [THEN sym])

end

context pseudo_hoop_algebra begin

lemma [simp]: "(a r\<rightarrow> 1) = 1"
  by simp

lemma lemma_3_5_iii_1 [simp]: "d1 a 1 = a"
  by (simp add: d1_def)

lemma lemma_3_5_iii_2 [simp]: "d2 a 1 = a"
  by (simp add: d2_def)

lemma lemma_3_5_iii_3 [simp]: "d3 a 1 = a"
  by (simp add: d3_def d1_def)

lemma lemma_3_5_iii_4 [simp]: "d4 a 1 = a"
  by (simp add: d4_def d2_def)

lemma lemma_3_5_iv_1: "(d1 b c) * (d1 a b) * (d1 b c) \<le> d1 a c"
  apply (simp add: d1_def)
  apply (subgoal_tac "(b l\<rightarrow> c) * (c l\<rightarrow> b) * ((a l\<rightarrow> b) * (b l\<rightarrow> a)) * ((b l\<rightarrow> c) * (c l\<rightarrow> b)) =
    ((b l\<rightarrow> c) * (c l\<rightarrow> b) * (a l\<rightarrow> b)) * ((b l\<rightarrow> a) * (b l\<rightarrow> c) * (c l\<rightarrow> b))")
  apply simp
  apply (rule mult_mono)
  apply (rule_tac y = "(b l\<rightarrow> c) * (a l\<rightarrow> b)" in order_trans)
  apply (rule mult_right_mono)
  apply simp
  apply (simp add: lemma_2_5_14)
  apply (rule_tac y = "(b l\<rightarrow> a) * (c l\<rightarrow> b)" in order_trans)
  apply (rule mult_right_mono)
  apply simp
  apply (simp add: lemma_2_5_14)
  by (simp add: mult.assoc)

lemma lemma_3_5_iv_2: "(d2 a b) * (d2 b c) * (d2 a b) \<le> d2 a c"
  apply (simp add: d2_def)
  apply (subgoal_tac "(a r\<rightarrow> b) * (b r\<rightarrow> a) * ((b r\<rightarrow> c) * (c r\<rightarrow> b)) * ((a r\<rightarrow> b) * (b r\<rightarrow> a)) =
    ((a r\<rightarrow> b) * (b r\<rightarrow> a) * (b r\<rightarrow> c)) * ((c r\<rightarrow> b) * (a r\<rightarrow> b) * (b r\<rightarrow> a))")
  apply simp
  apply (rule mult_mono)
  apply (rule_tac y = "(a r\<rightarrow> b) * (b r\<rightarrow> c)" in order_trans)
  apply (rule mult_right_mono)
  apply simp
  apply (simp add: lemma_2_5_15)
  apply (rule_tac y = "(c r\<rightarrow> b) * (b r\<rightarrow> a)" in order_trans)
  apply (rule mult_right_mono)
  apply simp
  apply (simp add: lemma_2_5_15)
  by (simp add: mult.assoc)

lemma lemma_3_5_iv_3: "(d3 a b) * (d3 b c) * (d3 a b) \<le> d3 a c"
  by (simp add: d3_def lemma_3_5_iv_1)

lemma lemma_3_5_iv_4: "(d4 b c) * (d4 a b) * (d4 b c) \<le> d4 a c"
  by (simp add: d4_def lemma_3_5_iv_2)

definition
  "cong_r F a b \<equiv> d1 a b \<in> F"

definition
  "cong_l F a b \<equiv> d2 a b \<in> F"

lemma cong_r_filter: "F \<in> filters \<Longrightarrow> (cong_r F a b) = (a l\<rightarrow> b \<in> F \<and> b l\<rightarrow> a \<in> F)"
  apply (simp add: cong_r_def d1_def)
  apply safe
  apply (rule filter_ii)
  apply simp_all
  apply simp
  apply (rule filter_ii)
  apply simp_all
  apply simp
  by (simp add: filter_i)

lemma cong_r_symmetric: "F \<in> filters \<Longrightarrow> (cong_r F a b) = (cong_r F b a)"
  apply (simp add: cong_r_filter)
  by blast

lemma cong_r_d3: "F \<in> filters \<Longrightarrow> (cong_r F a b) = (d3 a b \<in> F)"
  apply (simp add: d3_def)
  apply (subst cong_r_symmetric)
  by (simp_all add: cong_r_def)

lemma cong_l_filter: "F \<in> filters \<Longrightarrow> (cong_l F a b) = (a r\<rightarrow> b \<in> F \<and> b r\<rightarrow> a \<in> F)"
  apply (simp add: cong_l_def d2_def)
  apply safe
  apply (rule filter_ii)
  apply simp_all
  apply simp
  apply (rule filter_ii)
  apply simp_all
  apply simp
  by (simp add: filter_i)

lemma cong_l_d4: "F \<in> filters \<Longrightarrow> (cong_l F a b) = (d4 a b \<in> F)"
  apply (simp add: d4_def)
  apply (subst cong_l_symmetric)
  by (simp_all add: cong_l_def)

lemma cong_r_reflexive: "F \<in> filters \<Longrightarrow> cong_r F a a"
  by (simp add: cong_r_def)

lemma cong_r_transitive: "F \<in> filters \<Longrightarrow> cong_r F a b \<Longrightarrow> cong_r F b c \<Longrightarrow> cong_r F a c"
  apply (simp add: cong_r_filter)
  apply safe
  apply (rule_tac a = "(b l\<rightarrow> c) * (a l\<rightarrow> b)" in filter_ii)
  apply simp_all
  apply (rule filter_i)
  apply simp_all
  apply (simp add: lemma_2_5_14)
  apply (rule_tac a = "(b l\<rightarrow> a) * (c l\<rightarrow> b)" in filter_ii)
  apply simp_all
  apply (rule filter_i)
  apply simp_all
  by (simp add: lemma_2_5_14)

lemma cong_l_reflexive: "F \<in> filters \<Longrightarrow> cong_l F a a"
  by (simp add: cong_l_def)

lemma cong_l_transitive: "F \<in> filters \<Longrightarrow> cong_l F a b \<Longrightarrow> cong_l F b c \<Longrightarrow> cong_l F a c"
  apply (simp add: cong_l_filter)
  apply safe
  apply (rule_tac a = "(a r\<rightarrow> b) * (b r\<rightarrow> c)" in filter_ii)
  apply simp_all
  apply (rule filter_i)
  apply simp_all
  apply (simp add: lemma_2_5_15)
  apply (rule_tac a = "(c r\<rightarrow> b) * (b r\<rightarrow> a)" in filter_ii)
  apply simp_all
  apply (rule filter_i)
  apply simp_all
  by (simp add: lemma_2_5_15)

lemma lemma_3_7_i: "F \<in> filters \<Longrightarrow> F = {a . cong_r F a 1}"
  by (simp add: cong_r_def)

lemma lemma_3_7_ii: "F \<in> filters \<Longrightarrow> F = {a . cong_l F a 1}"
  by (simp add: cong_l_def)

lemma lemma_3_8_i: "F \<in> filters \<Longrightarrow> (cong_r F a b) = (\<exists> x y . x \<in> F \<and> y \<in> F \<and> x * a = y * b)"
  apply (subst cong_r_filter)
  apply safe
  apply (rule_tac x = "a l\<rightarrow> b" in exI)
  apply (rule_tac x = "b l\<rightarrow> a" in exI)
  apply (simp add: left_impl_times)
  apply (subgoal_tac "x \<le> a l\<rightarrow> b")
  apply (simp add: filter_ii)
  apply (simp add: left_residual [THEN sym])
  apply (subgoal_tac "y \<le> b l\<rightarrow> a")
  apply (simp add: filter_ii)
  apply (simp add: left_residual [THEN sym])
  apply (subgoal_tac "y * b = x * a")
  by simp_all

lemma lemma_3_8_ii: "F \<in> filters \<Longrightarrow> (cong_l F a b) = (\<exists> x y . x \<in> F \<and> y \<in> F \<and> a * x = b * y)"
  apply (subst cong_l_filter)
  apply safe
  apply (rule_tac x = "a r\<rightarrow> b" in exI)
  apply (rule_tac x = "b r\<rightarrow> a" in exI)
  apply (simp add: right_impl_times)
  apply (subgoal_tac "x \<le> a r\<rightarrow> b")
  apply (simp add: filter_ii)
  apply (simp add: right_residual [THEN sym])
  apply (subgoal_tac "y \<le> b r\<rightarrow> a")
  apply (simp add: filter_ii)
  apply (simp add: right_residual [THEN sym])
  apply (subgoal_tac "b * y = a * x")
  by simp_all

lemma lemma_3_9_i: "F \<in> filters \<Longrightarrow> cong_r F a b  \<Longrightarrow> cong_r F c d \<Longrightarrow> (a l\<rightarrow> c \<in> F) = (b l\<rightarrow> d \<in> F)"
  apply (simp add: cong_r_filter)
  apply safe
  apply (rule_tac a = "(a l\<rightarrow> d) * (b l\<rightarrow> a)" in filter_ii)
  apply (simp_all add: lemma_2_5_14)
  apply (rule_tac a = "((c l\<rightarrow> d) * (a l\<rightarrow> c)) * (b l\<rightarrow> a)" in filter_ii)
  apply simp_all
  apply (simp add: filter_i)
  apply (rule mult_right_mono)
  apply (simp_all add: lemma_2_5_14)

  apply (rule_tac a = "(b l\<rightarrow> c) * (a l\<rightarrow> b)" in filter_ii)
  apply (simp_all add: lemma_2_5_14)
  apply (rule_tac a = "((d l\<rightarrow> c) * (b l\<rightarrow> d)) * (a l\<rightarrow> b)" in filter_ii)
  apply simp_all
  apply (simp add: filter_i)
  apply (rule mult_right_mono)
  by (simp_all add: lemma_2_5_14)

lemma lemma_3_9_ii: "F \<in> filters \<Longrightarrow> cong_l F a b  \<Longrightarrow> cong_l F c d \<Longrightarrow> (a r\<rightarrow> c \<in> F) = (b r\<rightarrow> d \<in> F)"
  apply (simp add: cong_l_filter)
  apply safe
  apply (rule_tac a = "(b r\<rightarrow> a) * (a r\<rightarrow> d)" in filter_ii)
  apply (simp_all add: lemma_2_5_15)
  apply (rule_tac a = "(b r\<rightarrow> a) * ((a r\<rightarrow> c) * (c r\<rightarrow> d))" in filter_ii)
  apply simp_all
  apply (simp add: filter_i)
  apply (rule mult_left_mono)
  apply (simp_all add: lemma_2_5_15)

  apply (rule_tac a = "(a r\<rightarrow> b) * (b r\<rightarrow> c)" in filter_ii)
  apply (simp_all add: lemma_2_5_15)
  apply (rule_tac a = "(a r\<rightarrow> b) * ((b r\<rightarrow> d) * (d r\<rightarrow> c))" in filter_ii)
  apply simp_all
  apply (simp add: filter_i)
  apply (rule mult_left_mono)
  by (simp_all add: lemma_2_5_15)

definition
  "normalfilters = {F . F \<in> filters \<and> (\<forall> a b . (a l\<rightarrow> b \<in> F) = (a r\<rightarrow> b \<in> F))}"

lemma normalfilter_i:
  "H \<in> normalfilters \<Longrightarrow> a l\<rightarrow> b \<in> H \<Longrightarrow> a r\<rightarrow> b \<in> H"
  by (simp add: normalfilters_def)

lemma normalfilter_ii:
  "H \<in> normalfilters \<Longrightarrow> a r\<rightarrow> b \<in> H \<Longrightarrow> a l\<rightarrow> b \<in> H"
  by (simp add: normalfilters_def)

lemma [simp]: "H \<in> normalfilters \<Longrightarrow> H \<in> filters"
  by (simp add: normalfilters_def)

lemma lemma_3_10_i_ii:
  "H \<in> normalfilters \<Longrightarrow> {a} ** H = H ** {a}"
  apply (simp add: times_set_def)
  apply safe
  apply simp
  apply (rule_tac x = "a l\<rightarrow> a * y" in bexI)
  apply (simp add: inf_l_def [THEN sym])
  apply (rule antisym)
  apply simp
  apply simp
  apply (rule normalfilter_ii)
  apply simp_all
  apply (rule_tac a = "y" in filter_ii)
  apply simp_all
  apply (simp add: right_residual [THEN sym])

  apply (rule_tac x = "a r\<rightarrow> xa * a" in bexI)
  apply (simp add: inf_r_def [THEN sym])
  apply (rule antisym)
  apply simp
  apply simp
  apply (rule normalfilter_i)
  apply simp_all
  apply (rule_tac a = "xa" in filter_ii)
  apply simp_all
  by (simp add: left_residual [THEN sym])

lemma lemma_3_10_ii_iii:
  "H \<in> filters \<Longrightarrow> (\<forall> a . {a} ** H = H ** {a}) \<Longrightarrow> cong_r H = cong_l H"
  apply (subst fun_eq_iff)
  apply (subst fun_eq_iff)
  apply safe
  apply (subst (asm) lemma_3_8_i)
  apply simp_all
  apply safe
  apply (subst lemma_3_8_ii)
  apply simp_all
  apply (subgoal_tac "xb * x \<in> {x} ** H")
  apply (subgoal_tac "y * xa \<in> {xa} ** H")
  apply (drule drop_assumption)
  apply (drule drop_assumption)
  apply (simp add: times_set_def)
  apply safe
  apply (rule_tac x = ya in exI)
  apply simp
  apply (rule_tac x = yb in exI)
  apply simp
  apply (drule_tac x = xa in spec)
  apply (simp add: times_set_def)
  apply auto[1]
  apply (drule_tac x = x in spec)
  apply simp
  apply (simp add: times_set_def)
  apply (rule_tac x = xb in bexI)
  apply simp_all

  apply (subst (asm) lemma_3_8_ii)
  apply simp_all
  apply safe
  apply (subst lemma_3_8_i)
  apply simp_all
  apply (subgoal_tac "x * xb \<in> H ** {x}")
  apply (subgoal_tac "xa * y \<in> H ** {xa}")
  apply (drule drop_assumption)
  apply (drule drop_assumption)
  apply (simp add: times_set_def)
  apply safe
  apply (rule_tac x = xc in exI)
  apply simp
  apply (rule_tac x = xd in exI)
  apply simp
  apply (drule_tac x = xa in spec)
  apply (simp add: times_set_def)
  apply auto[1]
  apply (drule_tac x = x in spec)
  apply (subgoal_tac "x * xb \<in> {x} ** H")
  apply simp
  apply (subst times_set_def)
  by blast

lemma lemma_3_10_i_iii:
  "H \<in> normalfilters \<Longrightarrow> cong_r H = cong_l H"
  by (simp add: lemma_3_10_i_ii lemma_3_10_ii_iii)

lemma order_impl_l [simp]: "a \<le> b \<Longrightarrow> a l\<rightarrow> b = 1"
  by (simp add: left_lesseq)

end

context pseudo_hoop_algebra begin

lemma impl_l_d1: "(a l\<rightarrow> b) = d1 a (a \<sqinter> b)"
  by (simp add: d1_def lemma_2_6_20_a )

lemma impl_r_d2: "(a r\<rightarrow> b) = d2 a (a \<sqinter> b)"
  by (simp add: d2_def lemma_2_6_21_a)

lemma lemma_3_10_iii_i:
  "H \<in> filters \<Longrightarrow> cong_r H = cong_l H \<Longrightarrow> H \<in> normalfilters"
  apply (unfold normalfilters_def)
  apply (simp add: impl_l_d1 impl_r_d2)
  apply safe
  apply (subgoal_tac  "cong_r H a (a \<sqinter> b)")
  apply simp
  apply (subst (asm) cong_l_def)
  apply simp
  apply (subst cong_r_def)
  apply simp
  apply (subgoal_tac  "cong_r H a (a \<sqinter> b)")
  apply (subst (asm) cong_r_def)
  apply simp
  apply simp
  apply (subst cong_l_def)
  by simp

lemma lemma_3_10_ii_i:
  "H \<in> filters \<Longrightarrow>  (\<forall> a . {a} ** H = H ** {a}) \<Longrightarrow> H \<in> normalfilters"
  apply (rule lemma_3_10_iii_i)
  apply simp
  apply (rule lemma_3_10_ii_iii)
  by simp_all

definition
  "allpowers x n = {y . \<exists> i. i < n \<and> y = x ^ i}"

lemma times_set_in: "a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> c = a * b \<Longrightarrow> c \<in> A ** B"
  apply (simp add: times_set_def)
  by auto

lemma power_set_power: "a \<in> A \<Longrightarrow> a ^ n \<in> A *^ n"
  apply (induct_tac n)
  apply simp
  apply simp
  apply (rule_tac a = a and b = "a ^ n" in times_set_in)
  by simp_all

lemma normal_filter_union: "H \<in> normalfilters \<Longrightarrow> (H \<union> {x}) *^ n = (H ** (allpowers x n)) \<union> {x ^ n} "
  apply (induct_tac n)
  apply (simp add: times_set_def allpowers_def)
  apply safe
  apply simp
  apply (simp add:  times_set_def)
  apply safe
  apply (simp add:  allpowers_def)
  apply safe
  apply (subgoal_tac "x * xa \<in> H ** {x}")
  apply (simp add: times_set_def)
  apply safe
  apply (drule_tac x = "xb" in bspec)
  apply simp
  apply (drule_tac x = "x ^ (i + 1)" in spec)
  apply simp
  apply safe
  apply (erule notE)
  apply (rule_tac x = "i + 1" in exI)
  apply simp
  apply (erule notE)
  apply (simp add: mult.assoc [THEN sym])
  apply (drule_tac a = x in lemma_3_10_i_ii)
  apply (subgoal_tac "H ** {x} = {x} ** H")
  apply simp
  apply (simp add: times_set_def)
  apply auto[1]
  apply simp
  apply (drule_tac x = "xaa" in bspec)
  apply simp
  apply (drule_tac x = "x ^ n" in bspec)
  apply (simp add: allpowers_def)
  apply blast
  apply simp
  apply (drule_tac x = "xaa * xb" in bspec)
  apply (simp add: filter_i)
  apply (simp add: mult.assoc)
  apply (drule_tac x = "ya" in bspec)
  apply (simp add: allpowers_def)
  apply safe
  apply (rule_tac x = i in exI)
  apply simp
  apply simp
  apply (subst (asm)  times_set_def)
  apply (subst (asm)  times_set_def)
  apply simp
  apply safe
  apply (subst (asm) allpowers_def)
  apply (subst (asm) allpowers_def)
  apply safe
  apply (case_tac "i = 0")
  apply simp
  apply (rule_tac a = xa and b = 1 in times_set_in)
  apply blast
  apply (simp add: allpowers_def times_set_def)
  apply safe
  apply simp
  apply (drule_tac x = 1 in bspec)
  apply simp
  apply (drule_tac x = 1 in spec)
  apply simp
  apply (drule_tac x = 0 in spec)
  apply auto[1]
  apply simp
  apply (rule_tac a = xaa and b = "x ^ i" in times_set_in)
  apply blast
  apply (case_tac "i = n")
  apply simp
  apply (simp add: allpowers_def)
  apply safe
  apply (subgoal_tac "x ^ i \<in>  H ** {y . \<exists>i<n. y = x ^ i}")
  apply simp
  apply (rule_tac a = 1 and b = "x ^ i" in times_set_in)
  apply simp
  apply simp
  apply (rule_tac x = i in exI)
  apply simp
  apply simp
  apply (rule power_set_power)
  by simp

lemma lemma_3_11_ii: "H \<in> normalfilters \<Longrightarrow> filterof (H \<union> {x}) = {a . \<exists> n h . h \<in> H \<and> (x ^ n) * h \<le> a}"
  apply (subst lemma_3_11_i)
  apply simp_all
  apply safe
  apply (rule_tac x = n in exI)
  apply (subgoal_tac "h * x ^ n \<in> {x ^ n} ** H")
  apply (simp add: times_set_def)
  apply auto[1]
  apply (drule_tac a = "x ^ n" in lemma_3_10_i_ii)
  apply simp
  apply (simp add: times_set_def)
  apply auto[1]
  apply (rule_tac x = n in exI)
  apply (subgoal_tac "(x ^ n) * h \<in> H ** {x ^ n}")
  apply (simp add: times_set_def)
  apply auto[1]
  apply (drule_tac a = "x ^ n" in lemma_3_10_i_ii)
  apply (drule_tac sym)
  apply simp
  apply (simp add: times_set_def)
  by auto

lemma lemma_3_12_i_ii:
  "H \<in> normalfilters \<Longrightarrow> H \<in> ultrafilters \<Longrightarrow> x \<notin> H \<Longrightarrow> (\<exists> n . x ^ n l\<rightarrow> a \<in> H)"
  apply (subst (asm) ultrafilter_union)
  apply clarify
  apply (drule_tac x = x in spec)
  apply clarify
  apply (subst (asm) lemma_3_11_i)
  apply assumption
  apply (subgoal_tac "a \<in> {a::'a. \<exists>(n::nat) h::'a. h \<in> H \<and> h * x ^ n \<le> a}")
  apply clarify
  apply (rule_tac x = n in exI)
  apply (simp add: left_residual)
  apply (rule filter_ii)
  by simp_all

lemma lemma_3_12_ii_i:
  "H \<in> normalfilters \<Longrightarrow> H \<in> properfilters \<Longrightarrow> (\<forall> x a . x \<notin> H \<longrightarrow> (\<exists> n . x ^ n l\<rightarrow> a \<in> H)) \<Longrightarrow> H \<in> maximalfilters"
  apply (subgoal_tac "H \<in> ultrafilters")
  apply (simp add: ultrafilters_def)
  apply (subst ultrafilter_union)
  apply clarify
  apply (subst (asm) properfilters_def)
  apply clarify
  apply (subst lemma_3_11_i)
  apply simp_all
  apply safe
  apply simp_all
  apply (drule_tac x = x in spec)
  apply clarify
  apply (drule_tac x = xb in spec)
  apply clarify
  apply (rule_tac x = n in exI)
  apply (rule_tac x = "x ^ n l\<rightarrow> xb" in exI)
  apply clarify
  apply (subst inf_l_def [THEN sym])
  by simp

lemma lemma_3_12_i_iii:
  "H \<in> normalfilters \<Longrightarrow> H \<in> ultrafilters \<Longrightarrow> x \<notin> H \<Longrightarrow> (\<exists> n . x ^ n r\<rightarrow> a \<in> H)"
  apply (subst (asm) ultrafilter_union)
  apply clarify
  apply (drule_tac x = x in spec)
  apply clarify
  apply (subst (asm) lemma_3_11_ii)
  apply assumption
  apply (subgoal_tac "a \<in> {a::'a. \<exists>(n::nat) h::'a. h \<in> H \<and> (x ^ n) * h \<le> a}")
  apply clarify
  apply (rule_tac x = n in exI)
  apply (simp add: right_residual)
  apply (rule filter_ii)
  by simp_all

lemma lemma_3_12_iii_i:
  "H \<in> normalfilters \<Longrightarrow> H \<in> properfilters \<Longrightarrow> (\<forall> x a . x \<notin> H \<longrightarrow> (\<exists> n . x ^ n r\<rightarrow> a \<in> H)) \<Longrightarrow> H \<in> maximalfilters"
  apply (subgoal_tac "H \<in> ultrafilters")
  apply (simp add: ultrafilters_def)
  apply (subst ultrafilter_union)
  apply clarify
  apply (subst (asm) properfilters_def)
  apply clarify
  apply (subst lemma_3_11_ii)
  apply simp_all
  apply safe
  apply simp_all
  apply (drule_tac x = x in spec)
  apply clarify
  apply (drule_tac x = xb in spec)
  apply clarify
  apply (rule_tac x = n in exI)
  apply (rule_tac x = "x ^ n r\<rightarrow> xb" in exI)
  apply clarify
  apply (subst inf_r_def [THEN sym])
  by simp

definition
  "cong H = (\<lambda> x y . cong_l H x y \<and> cong_r H x y)"

definition
  "congruences = {R . equivp R \<and> (\<forall> a b c d . R a b \<and> R c d \<longrightarrow> R (a * c) (b * d) \<and>  R (a l\<rightarrow> c) (b l\<rightarrow> d) \<and>  R (a r\<rightarrow> c) (b r\<rightarrow> d))}"

lemma cong_l: "H \<in> normalfilters \<Longrightarrow> cong H = cong_l H"
  by (simp add: cong_def lemma_3_10_i_iii)

lemma cong_r: "H \<in> normalfilters \<Longrightarrow> cong H = cong_r H"
  by (simp add: cong_def lemma_3_10_i_iii)

lemma cong_equiv: "H \<in> normalfilters \<Longrightarrow> equivp (cong H)"
  apply (simp add: cong_l)
  apply (simp add: equivp_reflp_symp_transp reflp_def refl_on_def cong_l_reflexive cong_l_symmetric symp_def sym_def transp_def trans_def)
  apply safe
  apply (rule cong_l_transitive)
  by simp_all

lemma cong_trans: "H \<in> normalfilters \<Longrightarrow> cong H x y \<Longrightarrow> cong H y z \<Longrightarrow> cong H x z"
  apply (drule cong_equiv)
  apply (drule equivp_transp)
  by simp_all

lemma lemma_3_13 [simp]:
  "H \<in> normalfilters \<Longrightarrow> cong H \<in> congruences"
  apply (subst congruences_def)
  apply safe
  apply (simp add: cong_equiv)
  apply (rule_tac y = "b * c" in cong_trans)
  apply simp_all
  apply (simp add: cong_r lemma_3_8_i)
  apply safe
  apply (rule_tac x = x in exI)
  apply simp
  apply (rule_tac x = y in exI)
  apply (simp add: mult.assoc [THEN sym])
  apply (simp add: cong_l lemma_3_8_ii)
  apply safe
  apply (rule_tac x = xa in exI)
  apply simp
  apply (rule_tac x = ya in exI)
  apply (simp add: mult.assoc)
  apply (rule_tac y = "a l\<rightarrow> d" in cong_trans)
  apply simp
  apply (simp add: cong_r cong_r_filter)
  apply safe
  apply (rule_tac a = "c l\<rightarrow> d" in filter_ii)
  apply simp_all
  apply (subst left_residual [THEN sym])
  apply (simp add: lemma_2_5_14)
  apply (rule_tac a = "d l\<rightarrow> c" in filter_ii)
  apply simp_all
  apply (subst left_residual [THEN sym])
  apply (simp add: lemma_2_5_14)
  apply (subst cong_l)
  apply simp
  apply (simp add: cong_r cong_r_filter cong_l_filter)
  apply safe
  apply (rule_tac a = "b l\<rightarrow> a" in filter_ii)
  apply simp_all
  apply (subst right_residual [THEN sym])
  apply (simp add: lemma_2_5_14)
  apply (rule_tac a = "a l\<rightarrow> b" in filter_ii)
  apply simp_all
  apply (subst right_residual [THEN sym])
  apply (simp add: lemma_2_5_14)

  apply (rule_tac y = "a r\<rightarrow> d" in cong_trans)
  apply simp
  apply (simp add: cong_l cong_l_filter)
  apply safe
  apply (rule_tac a = "c r\<rightarrow> d" in filter_ii)
  apply simp_all
  apply (subst right_residual [THEN sym])
  apply (simp add: lemma_2_5_15)
  apply (rule_tac a = "d r\<rightarrow> c" in filter_ii)
  apply simp_all
  apply (subst right_residual [THEN sym])
  apply (simp add: lemma_2_5_15)

  apply (subst cong_r)
  apply simp
  apply (simp add: cong_l cong_l_filter cong_r_filter)
  apply safe
  apply (rule_tac a = "b r\<rightarrow> a" in filter_ii)
  apply simp_all
  apply (subst left_residual [THEN sym])
  apply (simp add: lemma_2_5_15)
  apply (rule_tac a = "a r\<rightarrow> b" in filter_ii)
  apply simp_all
  apply (subst left_residual [THEN sym])
  by (simp add: lemma_2_5_15)

lemma cong_times: "R \<in> congruences \<Longrightarrow> R a b \<Longrightarrow> R c d \<Longrightarrow> R (a * c) (b * d)"
  by (simp add: congruences_def)

lemma cong_impl_l: "R \<in> congruences \<Longrightarrow> R a b \<Longrightarrow> R c d \<Longrightarrow> R (a l\<rightarrow> c) (b l\<rightarrow> d)"
  by (simp add: congruences_def)

lemma cong_impl_r: "R \<in> congruences \<Longrightarrow> R a b \<Longrightarrow> R c d \<Longrightarrow> R (a r\<rightarrow> c) (b r\<rightarrow> d)"
  by (simp add: congruences_def)

lemma cong_refl [simp]: "R \<in> congruences \<Longrightarrow> R a a"
  by (simp add: congruences_def equivp_reflp)

lemma cong_trans_a: "R \<in> congruences \<Longrightarrow> R a b \<Longrightarrow> R b c \<Longrightarrow> R a c"
  apply (simp add: congruences_def)
  apply (rule_tac y = b in equivp_transp)
  by simp_all

lemma cong_sym: "R \<in> congruences \<Longrightarrow> R a b \<Longrightarrow> R b a"
  by (simp add: congruences_def equivp_symp)

definition
  "normalfilter R = {a . R a 1}"

lemma lemma_3_14 [simp]:
  "R \<in> congruences \<Longrightarrow> (normalfilter R) \<in> normalfilters"
  apply (unfold normalfilters_def)
  apply safe
  apply (simp add: filters_def)
  apply safe
  apply (simp add: normalfilter_def)
  apply (drule_tac x = 1 in spec)
  apply (simp add: congruences_def  equivp_reflp)
  apply (simp add: normalfilter_def)
  apply (drule_tac a = a and c = b and b = 1 and d = 1 and R = R in cong_times)
  apply simp_all
  apply (simp add: normalfilter_def)
  apply (simp add: left_lesseq)
  apply (cut_tac R = R and a = a and b = 1 and c = b and d = b in cong_impl_l)
  apply simp_all
  apply (simp add: cong_sym)
  apply (simp_all add: normalfilter_def)
  apply (cut_tac R = R and a = "a l\<rightarrow> b" and b = 1 and c = a and d = a in cong_times)
  apply simp_all
  apply (simp add: inf_l_def [THEN sym])
  apply (cut_tac R = R and a = a and b = "a \<sqinter> b" and c = b and d = b in cong_impl_r)
  apply simp_all
  apply (simp add: cong_sym)
  apply (cut_tac R = R and c = "a r\<rightarrow> b" and d = 1 and a = a and b = a in cong_times)
  apply simp_all
  apply (simp add: inf_r_def [THEN sym])
  apply (cut_tac R = R and a = a and b = "a \<sqinter> b" and c = b and d = b in cong_impl_l)
  apply simp_all
  by (simp add: cong_sym)

lemma lemma_3_15_ii:
  "R \<in> congruences \<Longrightarrow> cong (normalfilter R) = R"
  apply (simp add: fun_eq_iff cong_r cong_r_filter)
  apply (simp add: normalfilter_def)
  apply safe
  apply (cut_tac R = R and a = "x l\<rightarrow> xa" and b = 1 and c = x and d = x in cong_times)
  apply simp_all
  apply (cut_tac R = R and a = "xa l\<rightarrow> x" and b = 1 and c = xa and d = xa in cong_times)
  apply simp_all
  apply (simp add: inf_l_def [THEN sym])
  apply (rule_tac b = "x \<sqinter> xa" in cong_trans_a)
  apply simp_all
  apply (subst cong_sym)
  apply simp_all
  apply (subst inf.commute)
  apply simp_all
  apply (cut_tac R = R and a = x and b = xa and c = xa and d = xa in cong_impl_l)
  apply simp_all
  apply (cut_tac R = R and a = xa and b = xa and c = x and d = xa in cong_impl_l)
  by simp_all

lemma lemma_3_15_iii: "H1 \<in> normalfilters \<Longrightarrow> H2 \<in> normalfilters \<Longrightarrow> (H1 \<subseteq> H2) = (cong H1 \<le> cong H2)"
  apply safe
  apply (simp add: cong_l cong_l_filter)
  apply blast
  apply (subgoal_tac "cong H2 x 1")
  apply (simp add: cong_l cong_l_def)
  apply (subgoal_tac "cong H1 x 1")
  apply blast
  by (simp add: cong_l cong_l_def)

definition
  "p x y z = ((x l\<rightarrow> y) r\<rightarrow> z) \<sqinter> ((z l\<rightarrow> y) r\<rightarrow> x)"

lemma lemma_3_16_i: "p x x y = y \<and> p x y y = x"
  apply safe
  apply (simp_all add: p_def)
  apply (rule antisym)
  apply (simp_all add: lemma_2_10_24)
  apply (rule antisym)
  by (simp_all add: lemma_2_10_24)

definition "M x y z = ((y l\<rightarrow> x) r\<rightarrow> x) \<sqinter> ((z l\<rightarrow> y) r\<rightarrow> y) \<sqinter> ((x l\<rightarrow> z) r\<rightarrow> z)"

lemma "M x x y = x \<and> M x y x = x \<and> M y x x = x"
  apply (simp add: M_def)
  apply safe
  apply (rule antisym)
  apply (simp_all add: lemma_2_10_24 lemma_2_5_9_b)
  apply (rule antisym)
  apply (simp_all add: lemma_2_10_24 lemma_2_5_9_b)
  apply (rule antisym)
  by (simp_all add: lemma_2_10_24 lemma_2_5_9_b)
end

end


theory Higher_Derivative
imports "~~/src/HOL/Multivariate_Analysis/Multivariate_Analysis" "../ODE_Auxiliarities"
begin

subsection {* Approachability (for differentiability) *}

text {* TODO: move to @{thm frechet_derivative_unique_within} *}
definition approachable_at::"('a::euclidean_space) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "approachable_at x G = (\<forall>i\<in>Basis. \<forall>e>0. \<exists>d. 0 < abs(d) \<and> abs(d) < e \<and> (x + d *\<^sub>R i) \<in> G)"

lemma frechet_derivative_unique_within_approach:
  assumes "approachable_at x s"
  assumes "(f has_derivative f') (at x within s)"
  assumes "(f has_derivative f'') (at x within s)"
  shows "f' = f''"
  using frechet_derivative_unique_within[OF assms(2,3)] assms(1)
  by (simp add: approachable_at_def)

lemma frechet_derivative_within:
  shows "approachable_at x G \<Longrightarrow> (f has_derivative f') (at x within G) \<Longrightarrow>
    (f' = frechet_derivative f (at x within G))"
  by (rule frechet_derivative_unique_within)
    (auto simp: frechet_derivative_works[THEN sym] approachable_at_def intro: differentiableI)

lemma approachableI:
  assumes "\<And>i e. i \<in> Basis \<Longrightarrow> e > 0 \<Longrightarrow> \<exists>d. 0 < abs(d) \<and> abs(d) < e \<and> (x + d *\<^sub>R i) \<in> G"
  shows "approachable_at x G"
  using assms by (auto simp: approachable_at_def)

lemma approachableE:
  assumes "approachable_at x G"
  assumes "i \<in> Basis" "e > 0"
  obtains d where "0 < abs d" "abs d < e" "x + d *\<^sub>R i \<in> G"
  using assms by (auto simp: approachable_at_def)

lemma open_approachable[intro, simp]:
  assumes "open G" "x \<in> G"
  shows "approachable_at x G"
proof (rule approachableI)
  fix i::'a and e::real
  assume "i \<in> Basis" "e > 0"
  from assms `x \<in> G`
  obtain d' where d': "d' > 0" "\<And>y. dist y x < d' \<Longrightarrow> y \<in> G" using open_dist by blast
  def d \<equiv> "(min (d'/(norm i+1)) e)/2"
  have "d \<ge> 0" using `e > 0` `d' > 0`
    by (auto simp: d_def)
  have "dist (x + d *\<^sub>R i) x = norm (d *\<^sub>R i)" by (simp add: dist_norm)
  also have "\<dots> \<le> d * (norm i + 1)" using `d \<ge> 0` by (auto intro!: mult_left_mono)
  also have "\<dots> < d'" using `0 < d'` `0 < e`
    by (auto simp add: pos_divide_less_eq pos_less_divide_eq[symmetric] add_nonneg_pos d_def
      add_nonneg_eq_0_iff intro: min.strict_coboundedI1)
  finally have "x + d *\<^sub>R i \<in> G" by (rule d')
  moreover have "0 < abs d" using `d \<ge> 0` `d' > 0` `e > 0`
    by (auto simp add: d_def intro!: divide_pos_pos add_nonneg_pos)
  moreover have "abs d < e" using `0 < d'` `0 < e` `0 \<le> d`
    by (auto simp: d_def)
  ultimately show "\<exists>d. 0 < \<bar>d\<bar> \<and> \<bar>d\<bar> < e \<and> x + d *\<^sub>R i \<in> G" by blast
qed

lemma approachable_at_cball:
  assumes "e > 0"
  shows "approachable_at x (cball x e)"
  using assms
  apply (intro approachableI)
  apply (rule_tac x = "(min (ea/2) e)" in exI)
  apply (auto simp: dist_norm)
  done

text {* TODO: this is @{thm frechet_derivative_unique_within_closed_interval} *}
lemma closed_ivl_approachable[intro, simp]:
  fixes a b::"'a::ordered_euclidean_space"
  assumes lt: "\<And>i. i \<in> Basis \<Longrightarrow> a\<bullet>i < b\<bullet>i" and x: "x \<in> {a .. b}"
  shows "approachable_at x {a .. b}"
proof (rule approachableI)
  fix e::real and i :: 'a assume "e>0" and i:"i\<in>Basis"
  thus "\<exists>d. 0 < \<bar>d\<bar> \<and> \<bar>d\<bar> < e \<and> x + d *\<^sub>R i \<in> {a .. b}"
  proof(cases "x\<bullet>i=a\<bullet>i")
    case True thus ?thesis
      apply(rule_tac x="(min (b\<bullet>i - a\<bullet>i)  e) / 2" in exI)
      using lt[OF i] and `e>0` and x
      unfolding interval_cbox mem_box
      using i by (auto simp add: field_simps inner_simps inner_Basis)
  next
    note * = x[unfolded interval_cbox mem_box, THEN bspec, OF i]
    case False moreover have "a \<bullet> i < x \<bullet> i" using False * by auto
    moreover {
      have "a \<bullet> i * 2 + min (x \<bullet> i - a \<bullet> i) e \<le> a\<bullet>i *2 + x\<bullet>i - a\<bullet>i"
        by auto
      also have "\<dots> = a\<bullet>i + x\<bullet>i" by auto
      also have "\<dots> \<le> 2 * (x\<bullet>i)" using * by auto
      finally have "a \<bullet> i * 2 + min (x \<bullet> i - a \<bullet> i) e \<le> x \<bullet> i * 2" by auto
    }
    moreover have "min (x \<bullet> i - a \<bullet> i) e \<ge> 0" using * and `e>0` by auto
    hence "x \<bullet> i * 2 \<le> b \<bullet> i * 2 + min (x \<bullet> i - a \<bullet> i) e" using * by auto
    ultimately show ?thesis
      apply(rule_tac x="- (min (x\<bullet>i - a\<bullet>i) e) / 2" in exI)
      using lt[OF i] and `e>0` and x
      unfolding interval_cbox mem_box
      using i by (auto simp add: field_simps inner_simps inner_Basis)
  qed
qed

lemma approachable_product[intro]:
  "x \<in> X \<Longrightarrow> y \<in> Y \<Longrightarrow> approachable_at x X \<Longrightarrow> approachable_at y Y \<Longrightarrow>
    approachable_at (x, y) (X \<times> Y)"
  by (auto simp: Basis_prod_def approachable_at_def)

subsection {* Higher directional derivatives *}

lemmas norm_triangle_sub_le = order_trans[OF norm_triangle_ineq4]

locale approachable_on = fixes G
  assumes approachable: "\<And>a. a \<in> G \<Longrightarrow> approachable_at a G"

locale higher_derivative = approachable_on G for G::"'a::euclidean_space set" +
  fixes f::"'a\<Rightarrow>'b::real_normed_vector" and n
  fixes Ds::"'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b"
  assumes Ds_0[derivative_intros]: "a \<in> G \<Longrightarrow> (f has_derivative Ds [] a) (at a within G)"
  assumes Ds_Suc[derivative_intros]:
    "a \<in> G \<Longrightarrow> length ds < n \<Longrightarrow> ((\<lambda>a. Ds ds a d) has_derivative (\<lambda>i. Ds (d#ds) a i)) (at a within G)"
begin

lemma linear_Ds: "\<And>a. n \<ge> length ds \<Longrightarrow> a \<in> G \<Longrightarrow> linear (Ds ds a)"
  by (cases ds) (auto intro!: has_derivative_linear derivative_intros)

end

lemma continuous_imp_tendsto_compose:
  assumes "continuous (at x0) f"
    and "(g ---> x0) F"
  shows "((\<lambda>x. f (g x)) ---> (f x0)) F"
  using tendsto_compose assms
  by (auto simp: continuous_at)

lemma convex_left_scaling:
  assumes "convex s"
  shows"convex ((\<lambda>x. x *\<^sub>R a) ` s)"
proof (rule convexI, safe)
  fix u v x y::real
  assume "u + v = 1" "0 \<le> u" "0 \<le> v" "x \<in> s" "y \<in> s"
  with assms show "u *\<^sub>R (x *\<^sub>R a) + v *\<^sub>R (y *\<^sub>R a) \<in> ((\<lambda>x. x *\<^sub>R a) ` s)"
    by (auto dest!: mem_convex_alt[of s x y u v] intro!: image_eqI[where x="u * x + v * y"]
      convex_bound_le simp: algebra_simps)
qed

lemma
  differentiable_bound_line:
  fixes f::"'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
  assumes "\<And>t. t \<in> {0..1} \<Longrightarrow> x0 + t *\<^sub>R a \<in> G"
  assumes f': "\<And>x. x \<in> G \<Longrightarrow> (f has_derivative f' x) (at x within G)"
  assumes B: "\<forall>x\<in>{0..1}. onorm (f' (x0 + x *\<^sub>R a)) \<le> B"
  shows "norm (f (x0 + a) - f x0) \<le> norm a * B"
proof -
  let ?G = "(\<lambda>x. x0 + x *\<^sub>R a) ` {0..1}"
  have "?G = op + x0 ` (\<lambda>x. x *\<^sub>R a) ` {0..1}" by auto
  also have "convex \<dots>" by (intro convex_translation convex_left_scaling convex_closed_interval)
  finally have "convex ?G" .
  moreover have "?G \<subseteq> G" "x0 \<in> ?G" "x0 + a \<in> ?G" using assms by (auto intro: image_eqI[where x=1])
  ultimately show ?thesis
    using has_derivative_subset[OF f' `?G \<subseteq> G`] B
      differentiable_bound[of "(\<lambda>x. x0 + x *\<^sub>R a) ` {0..1}" f f' B "x0 + a" x0]
    by (auto simp: ac_simps)
qed

lemma differentiable_bound_derivative:
  fixes f::"'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
  assumes "\<And>t. t \<in> {0..1} \<Longrightarrow> a + t *\<^sub>R (b - a) \<in> S"
  assumes f'[derivative_intros]: "\<And>x. x \<in> S \<Longrightarrow> (f has_derivative f' x) (at x within S)"
  assumes B: "\<forall>x\<in>S. onorm (f' x - f' x0) \<le> B"
  assumes "x0 \<in> S"
  shows "norm (f b - f a - f' x0 (b - a)) \<le> norm (b - a) * B"
proof -
  def g \<equiv> "\<lambda>x. f x - f' x0 x"
  have g: "\<And>x. x \<in> S \<Longrightarrow> (g has_derivative (\<lambda>i. f' x i - f' x0 i)) (at x within S)"
    unfolding g_def using assms
    by (auto intro!: derivative_eq_intros bounded_linear.has_derivative[OF has_derivative_bounded_linear, OF f'])
  from B have B: "\<forall>x\<in>{0..1}. onorm (\<lambda>i. f' (a + x *\<^sub>R (b - a)) i - f' x0 i) \<le> B"
     using assms by (auto simp: fun_diff_def)
  from differentiable_bound_line[OF assms(1) g B] `x0 \<in> S`
  show ?thesis by (simp add: g_def field_simps linear_sub[OF has_derivative_linear[OF f']])
qed

locale higher_continuous_derivative = higher_derivative +
  assumes continuous_Ds:
    "a \<in> G \<Longrightarrow> length ds \<le> n \<Longrightarrow> continuous (at a within G) (\<lambda>a. Ds ds a y)"

locale second_derivative =
  approachable_on G for G +
  fixes f::"'a::euclidean_space\<Rightarrow>'b::euclidean_space" and f' f''
  assumes first_fderiv[derivative_intros]: "\<And>a. a \<in> G \<Longrightarrow> (f has_derivative f' a) (at a within G)"
  assumes second_fderiv[derivative_intros]: "\<And>a i. a \<in> G \<Longrightarrow> ((\<lambda>a. f' a i) has_derivative f'' a i) (at a within G)"
begin

lemma continuous_on_first: "\<And>i. continuous_on G (\<lambda>a. f' a i)"
  by (metis (full_types) Derivative.differentiableI differentiable_imp_continuous_on
    differentiable_on_def second_fderiv)

lemmas linear_first = has_derivative_linear[OF first_fderiv]

lemmas first_linear_simps [simp] =
  linear_add[OF linear_first]
  linear_sub[OF linear_first]
  linear_neg[OF linear_first]
  linear_cmul[OF linear_first]
  linear_0[OF linear_first]
  linear_setsum[OF linear_first]

lemma second_unique:
  "((\<lambda>a. f' a i) has_derivative F'') (at a within G) \<Longrightarrow> a \<in> G \<Longrightarrow> f'' a i = F''"
  using frechet_derivative_unique_within_approach[OF approachable _ second_fderiv] by simp

lemma bilinear_second: assumes "a \<in> G" shows "bilinear (f'' a)"
  unfolding bilinear_def
proof safe
  fix j
  show "linear (f'' a j)" by (rule has_derivative_linear[OF second_fderiv, OF `a \<in> G`])
  have "\<And>i1 i2. (\<lambda>j. f'' a (i1 + i2) j) = (\<lambda>j. f'' a i1 j + f'' a i2 j)"
    using `a \<in> G`  by (intro second_unique[OF has_derivative_transform]) (auto intro!: derivative_intros)
  moreover have "\<And>c i1. f'' a (c *\<^sub>R i1) = (\<lambda>j. c *\<^sub>R f'' a i1 j)"
    using `a \<in> G`  by (intro second_unique[OF has_derivative_transform]) (auto intro!: derivative_intros)
  ultimately show "linear (\<lambda>i. f'' a i j)" by (intro linearI) simp_all
qed

lemmas second_bilinear_simps[simp] =
  bilinear_ladd[OF bilinear_second]
  bilinear_radd[OF bilinear_second]
  bilinear_lsub[OF bilinear_second]
  bilinear_rsub[OF bilinear_second]
  bilinear_lneg[OF bilinear_second]
  bilinear_rneg[OF bilinear_second]
  bilinear_lmul[OF bilinear_second]
  bilinear_rmul[OF bilinear_second]
  bilinear_rzero[OF bilinear_second]
  bilinear_lzero[OF bilinear_second]
  bilinear_setsum[OF bilinear_second]

lemma symmetric_second_derivative_aux:
  fixes i j::"'a::euclidean_space"
  assumes "i \<noteq> j" "i \<noteq> 0" "j \<noteq> 0"
  assumes "a \<in> G"
  assumes "\<And>s t. s \<in> {0..1} \<Longrightarrow> t \<in> {0..1} \<Longrightarrow> a + s *\<^sub>R i + t *\<^sub>R j \<in> G"
  shows "f'' a i j = f'' a j i"
proof -
  let ?F = "at_right (0::real)"
  def B \<equiv> "\<lambda>i j. {a + s *\<^sub>R i + t *\<^sub>R j |s t. s \<in> {0..1} \<and> t \<in> {0..1}}"
  have "B i j \<subseteq> G" using assms by (auto simp: B_def)
  {
    fix e::real and i j::'a
    assume "e > 0"
    assume "i \<noteq> j" "i \<noteq> 0" "j \<noteq> 0"
    assume "B i j \<subseteq> G"
    let ?ij' = "\<lambda>s t. \<lambda>u. a + (s * u) *\<^sub>R i + (t * u) *\<^sub>R j"
    let ?ij = "\<lambda>t. \<lambda>u. a + (t * u) *\<^sub>R i + u *\<^sub>R j"
    let ?i = "\<lambda>t. \<lambda>u. a + (t * u) *\<^sub>R i"
    let ?g = "\<lambda>u t. f (?ij t u) - f (?i t u)"
    have filter_ij'I: "\<And>P. P a \<Longrightarrow> eventually P (at a within G) \<Longrightarrow>
      eventually (\<lambda>x. \<forall>s\<in>{0..1}. \<forall>t\<in>{0..1}. P (?ij' s t x)) ?F"
    proof -
      fix P
      assume "P a"
      assume "eventually P (at a within G)"
      hence "eventually P (at a within B i j)" by (rule filter_leD[OF at_le[OF `B i j \<subseteq> G`]])
      then obtain d where d: "d > 0" and "\<And>x d2. x \<in> B i j \<Longrightarrow> x \<noteq> a \<Longrightarrow> dist x a < d \<Longrightarrow> P x"
        by (auto simp: eventually_at)
      with `P a` have P: "\<And>x d2. x \<in> B i j \<Longrightarrow> dist x a < d \<Longrightarrow> P x" by (case_tac "x = a") auto
      let ?d = "min (min (d/norm i) (d/norm j) / 2) 1"
      show "eventually (\<lambda>x. \<forall>s\<in>{0..1}. \<forall>t\<in>{0..1}. P (?ij' s t x)) (at_right 0)"
        unfolding eventually_at
      proof (rule exI[where x="?d"], safe)
        show "0 < ?d" using `0 < d` `i \<noteq> 0` `j \<noteq> 0` by simp
        fix x s t :: real assume *: "s \<in> {0..1}" "t \<in> {0..1}" "0 < x" "dist x 0 < ?d"
        show "P (?ij' s t x)"
        proof (rule P)
          have "\<And>x y::real. x \<in> {0..1} \<Longrightarrow> y \<in> {0..1} \<Longrightarrow> x * y \<in> {0..1}"
            by (auto intro!: order_trans[OF mult_left_le_one_le])
          hence "s * x \<in> {0..1}" "t * x \<in> {0..1}" using * by (auto simp: dist_norm)
          thus "?ij' s t x \<in> B i j" by (auto simp: B_def)
          have "norm (s *\<^sub>R x *\<^sub>R i + t *\<^sub>R x *\<^sub>R j) \<le> norm (s *\<^sub>R x *\<^sub>R i) + norm (t *\<^sub>R x *\<^sub>R j)"
            by (rule norm_triangle_ineq)
          also have "\<dots> < d / 2 + d / 2" using * `i \<noteq> 0` `j \<noteq> 0`
            by (intro add_strict_mono) (auto simp: ac_simps dist_norm
              pos_less_divide_eq le_less_trans[OF mult_left_le_one_le])
          finally show "dist (?ij' s t x) a < d" by (simp add: dist_norm)
        qed
      qed
    qed
    {
      fix P
      assume "P a" "eventually P (at a within G)"
      from filter_ij'I[OF this] have "eventually (\<lambda>x. \<forall>t\<in>{0..1}. P (?ij t x)) ?F"
        by eventually_elim (force dest: bspec[where x=1])
    } note filter_ijI = this
    {
      fix P assume "P a" "eventually P (at a within G)"
      from filter_ij'I[OF this] have "eventually (\<lambda>x. \<forall>t\<in>{0..1}. P (?i t x)) ?F"
        by eventually_elim force
    } note filter_iI = this
    {
      from second_fderiv[OF `a \<in> G`, of i, simplified has_derivative_iff_norm, THEN conjunct2,
        THEN tendstoD, OF `0 < e`]
      have "eventually (\<lambda>x. norm (f' x i - f' a i - f'' a i (x - a)) / norm (x - a) \<le> e)
          (at a within G)"
        by eventually_elim (simp add: dist_norm)
      from filter_ijI[OF _ this] filter_iI[OF _ this] `0 < e`
      have
        "eventually (\<lambda>ij. \<forall>t\<in>{0..1}. norm (f' (?ij t ij) i - f' a i - f'' a i (?ij t ij - a)) /
          norm (?ij t ij - a) \<le> e) ?F"
        "eventually (\<lambda>ij. \<forall>t\<in>{0..1}. norm (f' (?i t ij) i - f' a i - f'' a i (?i t ij - a)) /
          norm (?i t ij - a) \<le> e) ?F"
        by auto
      moreover
      have "eventually (\<lambda>x. x \<in> G) (at a within G)" unfolding eventually_at_filter by simp
      hence eventually_in_ij: "eventually (\<lambda>x. \<forall>t\<in>{0..1}. ?ij t x \<in> G) ?F" and
        eventually_in_i: "eventually (\<lambda>x. \<forall>t\<in>{0..1}. ?i t x \<in> G) ?F"
        using `a \<in> G` by (auto dest: filter_ijI filter_iI)
      ultimately
      have "eventually (\<lambda>u. norm (?g u 1 - ?g u 0 - (u * u) *\<^sub>R f'' a i j) \<le>
          u * u * e * (2 * norm i + 3 * norm j)) ?F"
      proof eventually_elim
        case elim
        hence ijsub: "(\<lambda>t. ?ij t u) ` {0..1} \<subseteq> G" and isub: "(\<lambda>t. ?i t u) ` {0..1} \<subseteq> G" by auto
        note has_derivative_subset[OF _ ijsub, derivative_intros]
        note has_derivative_subset[OF _ isub, derivative_intros]
        let ?g' = "\<lambda>t. (\<lambda>ua. u *\<^sub>R ua *\<^sub>R (f' (?ij t u) i - (f' (?i t u) i)))"
        {
          fix t::real assume "t \<in> {0..1}"
          with elim have linear_f': "\<And>c x. f' (?ij t u) (c *\<^sub>R x) = c *\<^sub>R f' (?ij t u) x"
              "\<And>c x. f' (?i t u) (c *\<^sub>R x) = c *\<^sub>R f' (?i t u) x"
            using linear_cmul[OF has_derivative_linear, OF first_fderiv] by auto
          have "((?g u) has_derivative ?g' t) (at t within {0..1})"
            using elim `t \<in> {0..1}`
            by (auto intro!: derivative_eq_intros has_derivative_in_compose[of  "\<lambda>t. ?ij t u" _ _ _ f]
                has_derivative_in_compose[of  "\<lambda>t. ?i t u" _ _ _ f]
              simp: linear_f' scaleR_diff_right mult.commute)
        } note g' = this
        from elim(1) `i \<noteq> 0` `j \<noteq> 0` `0 < e` have f'ij: "\<And>t. t \<in> {0..1} \<Longrightarrow>
            norm (f' (a + (t * u) *\<^sub>R i + u *\<^sub>R j) i - f' a i - f'' a i ((t * u) *\<^sub>R i + u *\<^sub>R j)) \<le>
            e * norm ((t * u) *\<^sub>R i + u *\<^sub>R j)"
          using  linear_0[OF has_derivative_linear, OF second_fderiv, OF `a \<in> G`]
          by (case_tac "u *\<^sub>R j + (t * u) *\<^sub>R i = 0") (auto simp: field_simps
            simp del: pos_divide_le_eq simp add: pos_divide_le_eq[symmetric])
        from elim(2) have f'i: "\<And>t. t \<in> {0..1} \<Longrightarrow> norm (f' (a + (t * u) *\<^sub>R i) i - f' a i -
          f'' a i ((t * u) *\<^sub>R i)) \<le> e * abs (t * u) * norm i"
          using `i \<noteq> 0` `j \<noteq> 0` linear_0[OF has_derivative_linear, OF second_fderiv, OF `a \<in> G`]
          by (case_tac "t * u = 0") (auto simp: field_simps simp del: pos_divide_le_eq
            simp add: pos_divide_le_eq[symmetric])
        have "norm (?g u 1 - ?g u 0 - (u * u) *\<^sub>R f'' a i j) =
          norm ((?g u 1 - ?g u 0 - u *\<^sub>R (f' (a + u *\<^sub>R j) i - (f' a i)))
            + u *\<^sub>R (f' (a + u *\<^sub>R j) i - f' a i - u *\<^sub>R f'' a i j))"
            (is "_ = norm (?g10 + ?f'i)")
          by (simp add: algebra_simps linear_cmul[OF has_derivative_linear, OF second_fderiv,
              OF `a \<in> G`]
            linear_add[OF has_derivative_linear, OF second_fderiv, OF `a \<in> G`])
        also have "\<dots> \<le> norm ?g10 + norm ?f'i"
          by (blast intro: order_trans add_mono norm_triangle_le)
        also
        have "0 \<in> {0..1::real}" by simp
        have "\<forall>t \<in> {0..1}. onorm ((\<lambda>ua. (u * ua) *\<^sub>R (f' (?ij t u) i - f' (?i t u) i)) -
              (\<lambda>ua. (u * ua) *\<^sub>R (f' (a + u *\<^sub>R j) i - f' a i)))
            \<le> 2 * u * u * e * (norm i + norm j)" (is "\<forall>t \<in> _. onorm (?d t) \<le> _")
        proof
          fix t::real assume "t \<in> {0..1}"
          show "onorm (?d t) \<le> 2 * u * u * e * (norm i + norm j)"
          proof (rule onorm_le)
            fix x
            have "norm (?d t x) =
                norm ((u * x) *\<^sub>R (f' (?ij t u) i - f' (?i t u) i - f' (a + u *\<^sub>R j) i + f' a i))"
              by (simp add: algebra_simps)
            also have "\<dots> =
                abs (u * x) * norm (f' (?ij t u) i - f' (?i t u) i - f' (a + u *\<^sub>R j) i + f' a i)"
              by simp
            also have "\<dots> = abs (u * x) * norm (
                 f' (?ij t u) i - f' a i - f'' a i ((t * u) *\<^sub>R i + u *\<^sub>R j)
               - (f' (?i t u) i - f' a i - f'' a i ((t * u) *\<^sub>R i))
               - (f' (a + u *\<^sub>R j) i - f' a i - f'' a i (u *\<^sub>R j)))"
               (is "_ = _ * norm (?dij - ?di - ?dj)")
              using `a \<in> G` by (simp add: algebra_simps)
            also have "\<dots> \<le> abs (u * x) * (norm ?dij + norm ?di + norm ?dj)"
              by (rule mult_left_mono[OF _ abs_ge_zero]) norm
            also have "\<dots> \<le> abs (u * x) *
              (e * norm ((t * u) *\<^sub>R i + u *\<^sub>R j) + e * abs (t * u) * norm i + e * (\<bar>u\<bar> * norm j))"
              using f'ij f'i f'ij[OF `0 \<in> {0..1}`] `t \<in> {0..1}`
              by (auto intro!: add_mono mult_left_mono)
            also have "\<dots> = abs u * abs x * abs u *
              (e * norm (t *\<^sub>R i + j) + e * norm (t *\<^sub>R i) + e * (norm j))"
              by (simp add: algebra_simps norm_scaleR[symmetric] abs_mult del: norm_scaleR)
            also have "\<dots> =
                u * u * abs x * (e * norm (t *\<^sub>R i + j) + e * norm (t *\<^sub>R i) + e * (norm j))"
              by (simp add: ac_simps)
            also have "\<dots> = u * u * e * abs x * (norm (t *\<^sub>R i + j) + norm (t *\<^sub>R i) + norm j)"
              by (simp add: algebra_simps)
            also have "\<dots> \<le> u * u * e * abs x * ((norm (1 *\<^sub>R i) + norm j) + norm (1 *\<^sub>R i) + norm j)"
              using `t \<in> {0..1}` `0 < e`
              by (intro mult_left_mono add_mono) (auto intro!: norm_triangle_le add_right_mono
                mult_left_le_one_le zero_le_square)
            finally show "norm (?d t x) \<le> 2 * u * u * e * (norm i + norm j) * norm x"
              by (simp add: ac_simps)
          qed
        qed
        with differentiable_bound_derivative[where f="?g u" and f'="?g'", of 0 1 _ 0, OF _ g']
        have "norm ?g10 \<le> 2 * u * u * e * (norm i + norm j)" by simp
        also have "norm ?f'i \<le> abs u *
          norm ((f' (a + (u) *\<^sub>R j) i - f' a i - f'' a i ((u) *\<^sub>R j)))"
          using linear_cmul[OF has_derivative_linear, OF second_fderiv, OF `a \<in> G`]
          by simp
        also have "\<dots> \<le> abs u * (e * norm ((u) *\<^sub>R j))"
          using f'ij[OF `0 \<in> {0..1}`] by (auto intro: mult_left_mono)
        also have "\<dots> = u * u * e * norm j" by (simp add: algebra_simps abs_mult)
        finally show ?case by (simp add: algebra_simps)
      qed
    }
  } note wlog = this
  {
    fix e t::real
    assume "0 < e"
    have "B i j = B j i" using `i \<noteq> j` by (force simp: B_def)+
    with assms `B i j \<subseteq> G` have "j \<noteq> i" "B j i \<subseteq> G" by (auto simp:)
    from wlog[OF `0 < e` `i \<noteq> j` `i \<noteq> 0` `j \<noteq> 0` `B i j \<subseteq> G`]
         wlog[OF `0 < e` `j \<noteq> i` `j \<noteq> 0` `i \<noteq> 0` `B j i \<subseteq> G`]
    have "eventually (\<lambda>u. norm ((u * u) *\<^sub>R f'' a i j - (u * u) *\<^sub>R f'' a j i)
         \<le> u * u * e * (5 * norm j + 5 * norm i)) ?F"
    proof eventually_elim
      case elim
      have "norm ((u * u) *\<^sub>R f'' a i j - (u * u) *\<^sub>R f'' a j i) =
        norm (f (a + u *\<^sub>R j + u *\<^sub>R i) - f (a + u *\<^sub>R j) -
         (f (a + u *\<^sub>R i) - f a) - (u * u) *\<^sub>R f'' a j i
         - (f (a + u *\<^sub>R i + u *\<^sub>R j) - f (a + u *\<^sub>R i) -
         (f (a + u *\<^sub>R j) - f a) -
         (u * u) *\<^sub>R f'' a i j))" by (simp add: field_simps)
      also have "\<dots> \<le> u * u * e * (2 * norm j + 3 * norm i) + u * u * e * (3 * norm j + 2 * norm i)"
        using elim by (intro norm_triangle_sub_le) (auto simp: ac_simps intro: add_mono)
      finally show ?case by (simp add: algebra_simps)
    qed
    hence "eventually (\<lambda>u. norm ((u * u) *\<^sub>R (f'' a i j - f'' a j i)) \<le>
        u * u * e * (5 * norm j + 5 * norm i)) ?F"
      by (simp add: algebra_simps)
    hence "eventually (\<lambda>u. (u * u) * norm ((f'' a i j - f'' a j i)) \<le>
        (u * u) * (e * (5 * norm j + 5 * norm i))) ?F"
      by (simp add: ac_simps)
    hence "eventually (\<lambda>u. norm ((f'' a i j - f'' a j i)) \<le> e * (5 * norm j + 5 * norm i)) ?F"
      unfolding mult_le_cancel_left eventually_at_filter
      by eventually_elim auto
    hence "norm (f'' a i j - f'' a j i) \<le> e * (5 * norm j + 5 * norm i)"
      unfolding eventually_at
      apply safe
      apply (drule_tac x="d/2" in bspec)
      apply (auto simp add: dist_norm)
      done
  } note e' = this
  {
    fix e::real assume "0 < e"
    let ?e = "e/2/(5 * norm j + 5 * norm i)"
    have "?e > 0" using `0 < e` `i \<noteq> 0` `j \<noteq> 0` by (auto intro!: divide_pos_pos add_pos_pos)
    from e'[OF this] have "norm (f'' a i j - f'' a j i) \<le> ?e * (5 * norm j + 5 * norm i)" .
    also have "\<dots> = e / 2" using `i \<noteq> 0` `j \<noteq> 0` by (auto simp: ac_simps add_nonneg_eq_0_iff)
    also have "\<dots> < e" using `0 < e` by simp
    finally have "norm (f'' a i j - f'' a j i) < e" .
  } note e = this
  have "norm (f'' a i j - f'' a j i) = 0"
  proof (rule ccontr)
    assume "norm (f'' a i j - f'' a j i) \<noteq> 0"
    hence "norm (f'' a i j - f'' a j i) > 0" by simp
    from e[OF this] show False by simp
  qed
  thus ?thesis by simp
qed

end

locale local_rect = fixes G
  assumes ex_local_rect: "\<And>a. a \<in> G \<Longrightarrow> \<exists>s\<in>Basis\<rightarrow>{x. x \<noteq> 0}. \<forall>x.
    (\<forall>i \<in> Basis. min (a \<bullet> i) (a \<bullet> i + s i) \<le> x \<bullet> i \<and> x \<bullet> i \<le> max (a \<bullet> i) (a \<bullet> i + s i)) \<longrightarrow> x \<in> G"
begin

lemma local_rectE:
  assumes "a \<in> G"
  obtains s where "\<And>i. i \<in> Basis \<Longrightarrow> s i \<noteq> 0"
    "\<And>x. (\<And>i. i \<in> Basis \<Longrightarrow>
      a \<bullet> i \<le> x \<bullet> i \<and> x \<bullet> i \<le> a \<bullet> i + s i \<or> a \<bullet> i + s i \<le> x \<bullet> i \<and> x \<bullet> i \<le> a \<bullet> i) \<Longrightarrow> x \<in> G"
proof atomize_elim
  from ex_local_rect[OF `a \<in> G`] guess s .. note in_GI = this
  then show "\<exists>s. (\<forall>i. i \<in> Basis \<longrightarrow> s i \<noteq> 0) \<and> (\<forall>x. (\<forall>i. i \<in> Basis \<longrightarrow>
      a \<bullet> i \<le> x \<bullet> i \<and> x \<bullet> i \<le> a \<bullet> i + s i \<or> a \<bullet> i + s i \<le> x \<bullet> i \<and> x \<bullet> i \<le> a \<bullet> i) \<longrightarrow> x \<in> G)"
    by (force intro!: exI[where x=s])
qed

lemma
  local_rect_BasisE:
  assumes "a \<in> G"
  obtains s where "\<And>i. i \<in> Basis \<Longrightarrow> s i \<noteq> 0"
    "\<And>t. t \<in> Basis\<rightarrow>{0..1} \<Longrightarrow> a + (\<Sum>i\<in>Basis. (t i * s i) *\<^sub>R i) \<in> G"
proof atomize_elim
  from local_rectE[OF `a \<in> G`] guess s . note GI = this
  show "\<exists>s. (\<forall>i. i \<in> Basis \<longrightarrow> s i \<noteq> 0) \<and>
        (\<forall>t. t \<in> Basis \<rightarrow> {0..1} \<longrightarrow> a + (\<Sum>i\<in>Basis. (t i * s i) *\<^sub>R i) \<in> G)"
    by (rule exI[where x=s]) (force intro!: GI
      simp: algebra_simps inner_Basis mult_less_cancel_right2 zero_less_mult_iff Pi_iff not_le)
qed

end

sublocale local_rect < approachable_on
proof (unfold_locales, rule approachableI)
  fix a i::'a and e::real assume "a \<in> G" "i \<in> Basis" "0 < e"
  from local_rect_BasisE[OF `a \<in> G`] guess s . note nz=this(1) and in_GI = this(2)
  let ?i = "min (e / abs (s i) / 2) 1"
  have "a + (?i * s i) *\<^sub>R i = a + (\<Sum>ia\<in>Basis. ((if ia = i then ?i else 0) * s ia) *\<^sub>R ia)"
    using `i \<in> Basis`
    by (auto simp add: Pi_iff setsum.mono_neutral_cong_right[of Basis "{i}"] min_def)
  also have "\<dots> \<in> G"
    using `0 < e` by (intro in_GI[of "\<lambda>k. if k = i then ?i else 0"])
      (auto simp: Pi_iff)
  finally have "a + (?i * s i) *\<^sub>R i \<in> G" .
  moreover have "0 < abs (?i * s i)" using `e > 0` nz `i \<in> Basis` by (simp add: min_def)
  moreover have "abs (?i * s i) < e" using `e > 0` by (simp add: min_def abs_mult)
  ultimately show "\<exists>d. 0 < \<bar>d\<bar> \<and> \<bar>d\<bar> < e \<and> a + d *\<^sub>R i \<in> G" by blast
qed

lemma sqrt_le_rsquare:
  assumes "\<bar>x\<bar> \<le> sqrt y"
  shows "x\<^sup>2 \<le> y"
  using assms real_sqrt_le_iff[of "x\<^sup>2"] by simp

lemma cube_in_cball:
  fixes x y :: "'a::euclidean_space"
  assumes "r > 0"
  assumes "\<And>i. i \<in> Basis \<Longrightarrow> dist (x \<bullet> i) (y \<bullet> i) \<le> r / sqrt(DIM('a))"
  shows "y \<in> cball x r"
  unfolding mem_cball euclidean_dist_l2[of x] setL2_def
proof -
  have "(\<Sum>i\<in>Basis. (dist (x \<bullet> i) (y \<bullet> i))\<^sup>2) \<le> (\<Sum>(i::'a)\<in>Basis. (r / sqrt(DIM('a)))\<^sup>2)"
    using assms by (intro setsum_mono) (auto intro: sqrt_le_rsquare)
  moreover have "... \<le> r\<^sup>2" by (simp add: power_divide real_eq_of_nat)
  ultimately show "sqrt (\<Sum>i\<in>Basis. (dist (x \<bullet> i) (y \<bullet> i))\<^sup>2) \<le> r"
    using `r > 0` by (auto intro!: real_le_lsqrt setsum_nonneg)
qed

lemma local_rect_openI:
  assumes "open G"
  shows "local_rect G"
proof
  fix a
  assume "a \<in> G"
  with `open G` open_contains_cball
  obtain e where e: "e > 0" and in_GI: "\<And>x. x \<in> cball a e \<Longrightarrow> x \<in> G" by force
  show "\<exists>s\<in>Basis \<rightarrow> {x. x \<noteq> 0}. \<forall>x.
    (\<forall>i\<in>Basis. min (a \<bullet> i) (a \<bullet> i + s i) \<le> x \<bullet> i \<and> x \<bullet> i \<le> max (a \<bullet> i) (a \<bullet> i + s i)) \<longrightarrow> x \<in> G"
    using e
    apply (intro bexI[where x="\<lambda>_. e/sqrt(DIM('a))"])
    apply (simp add: min_def max_def)
    apply (auto simp add: dist_real_def min_def max_def field_simps simp del: mem_cball
      intro!: cube_in_cball in_GI)
    done
qed

lemma local_rect_intervalI:
  fixes a b::"'a::ordered_euclidean_space"
  assumes "\<And>i. i \<in> Basis \<Longrightarrow> b \<bullet> i < c \<bullet> i"
  shows "local_rect {b..c}"
proof
  fix a
  assume "a \<in> {b..c}"
  show "\<exists>s\<in>Basis \<rightarrow> {x. x \<noteq> 0}.
      \<forall>x. (\<forall>i\<in>Basis. min (a \<bullet> i) (a \<bullet> i + s i) \<le> x \<bullet> i \<and> x \<bullet> i \<le> max (a \<bullet> i) (a \<bullet> i + s i)) \<longrightarrow>
      x \<in> {b..c}"
    using assms `a \<in> {b..c}`
    apply (intro bexI[where x="\<lambda>i. if c \<bullet> i = a \<bullet> i then b \<bullet> i - a \<bullet> i else c \<bullet> i - a \<bullet> i"])
    apply (auto simp: algebra_simps min_def max_def eucl_le[of b] eucl_le[of _ c] not_le
        split: split_if_asm)
    apply (metis le_less_trans not_le)
    apply metis
    by (metis less_irrefl)
qed

locale second_derivative_lrect = second_derivative G f f' f'' + local_rect G for G f f' f''
begin

end

locale higher_derivative_lrect = higher_derivative G f n Ds + local_rect G
  for G and f::"'a::euclidean_space \<Rightarrow> 'b::euclidean_space" and n Ds
begin

lemma
  symmetric_higher_derivative:
  assumes "length ds < n"
  assumes "a \<in> G"
  shows "Ds (i#ds) a j = Ds (j#ds) a i"
  using assms(1)
proof (induct ds arbitrary: i j)
  case Nil
  interpret second_derivative_lrect G f "Ds []" "\<lambda>x i. Ds [i] x"
    by unfold_locales (auto intro!: derivative_intros Nil)
  show ?case by (rule symmetric_second_derivative[OF `a \<in> G`])
next
  case (Cons e es k j)
  then interpret second_derivative_lrect G "\<lambda>x. Ds es x i" "Ds (i#es)" "\<lambda>x j.  Ds (j # i # es) x" for i
    by unfold_locales (auto intro!: derivative_eq_intros Cons approachable)
  show ?case by (rule symmetric_second_derivative[OF `a \<in> G`])
qed

end

locale traj_with_higher_derivatives = higher_derivative _ _ _ Ds
  for Ds :: "(real*'a::euclidean_space) list \<Rightarrow> (real*'a) \<Rightarrow> (real*'a) \<Rightarrow> 'a::euclidean_space" +
  fixes x::"real \<Rightarrow> ('a::euclidean_space)"
  assumes domain_notempty: "G \<noteq> {}"
  assumes x': "\<And>s. s \<in> {t..u} \<Longrightarrow> (x has_vector_derivative f (s, x s)) (at s within {t..u})"
begin

lemma has_derivativex[derivative_intros]: "\<And>s. s \<in> {t..u} \<Longrightarrow> (x has_derivative (\<lambda>xa. xa *\<^sub>R f (s, x s))) (at s within {t..u})"
  using x'
  by (auto intro!: derivative_eq_intros simp: has_vector_derivative_def)

lemma
  assumes x_in: "\<And>s. s \<in> {t..u} \<Longrightarrow> (s, x s) \<in> G"
  shows "\<And>s. s \<in> {t..u} \<Longrightarrow> ((\<lambda>s. f (s, x s)) has_vector_derivative
    Ds [] (s, x s) (1, f (s, x s))) (at s within {t..u})"
  apply (auto intro!: derivative_eq_intros simp: has_vector_derivative_def)
  apply (rule has_derivative_eq_rhs)
  apply (rule has_derivative_in_compose[where g=f])
  apply (rule derivative_eq_intros refl)+
  apply simp
  apply (rule refl)+
  apply (rule has_derivative_subset)
  apply (rule Ds_0)
  apply (rule x_in)
  apply simp
  apply rule
  apply (auto intro!: x_in)
  apply rule
  using linear.scaleR[OF linear_Ds[OF _ x_in], of "[]", symmetric, simplified]
  apply simp
  done

end

end


theory Chap2_4
imports Main
begin

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

lemma itrev_rev: "itrev xs ys = rev xs @ ys"
  apply (induction xs arbitrary: ys)
  by auto
lemma "itrev xs [] = rev xs"
  by (simp add: itrev_rev)

fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"itadd 0 n = n"
| "itadd (Suc m) n = itadd m (Suc n)"

lemma "itadd m n = m + n"
  apply (induction m arbitrary: n)
  by auto

end


(*
    $Id: sol.thy,v 1.4 2011/06/28 18:11:37 webertj Exp $
    Author: Tobias Nipkow
*)

header {* Tries *}

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

text {*
  Section~3.4.4 of the Isabelle/HOL tutorial is a case study about so-called
  \emph{tries}, a data structure for fast indexing with strings.  Read that
  section.

  The data type of tries over the alphabet type @{typ 'a} und the value type
  @{typ 'v} is defined as follows:
*}

datatype ('a, 'v) trie = Trie "'v option" "('a * ('a,'v) trie) list"

text {*
  A trie consists of an optional value and an association list that maps
  letters of the alphabet to subtrees.  Type @{typ "'a option"} is defined in
  Section~2.5.3 of the Isabelle/HOL tutorial.

  There are also two selector functions @{term value} and @{term alist}:
*}

primrec "value" :: "('a, 'v) trie \<Rightarrow> 'v option" where
"value (Trie ov al) = ov"

primrec alist :: "('a, 'v) trie \<Rightarrow> ('a * ('a,'v) trie) list" where
"alist (Trie ov al) = al"

text {*
  Furthermore there is a function @{term lookup} on tries defined with the help
  of the generic search function @{term assoc} on association lists:
*}

primrec assoc ::  "('key * 'val)list \<Rightarrow> 'key \<Rightarrow> 'val option" where
  "assoc []     x = None"
| "assoc (p#ps) x =
           (let (a, b) = p in if a = x then Some b else assoc ps x)"

primrec lookup :: "('a, 'v) trie \<Rightarrow> 'a list \<Rightarrow> 'v option" where
  "lookup t []     = value t"
| "lookup t (a#as) = (case assoc (alist t) a of
                          None \<Rightarrow> None
                        | Some at \<Rightarrow> lookup at as)"

text {*
  Finally, @{term update} updates the value associated with some string with a
  new value, overwriting the old one:
*}

primrec update :: "('a, 'v) trie \<Rightarrow> 'a list \<Rightarrow> 'v \<Rightarrow> ('a, 'v) trie" where
  "update t []     v = Trie (Some v) (alist t)"
| "update t (a#as) v =
     (let tt = (case assoc (alist t) a of
                  None \<Rightarrow> Trie None []
                | Some at \<Rightarrow> at)
      in Trie (value t) ((a, update tt as v) # alist t))"

text {*
  The following theorem tells us that @{term update} behaves as expected:
*}

declare Let_def[simp] option.split[split]

theorem [simp]: "\<forall>t v bs. lookup (update t as v) bs =
                    (if as = bs then Some v else lookup t bs)"
  apply (induct_tac as, auto)
  apply (case_tac[!] bs, auto)
done

text {*
  As a warm-up exercise, define a function

  @{text "modify :: ('a, 'v) trie \<Rightarrow> 'a list \<Rightarrow> 'v option \<Rightarrow> ('a, 'v) trie"}

  for inserting as well as deleting elements from a trie.  Show that @{term
  modify} satisfies a suitably modified version of the correctness theorem for
  @{term update}.
*}

primrec modify :: "('a, 'v) trie \<Rightarrow> 'a list \<Rightarrow> 'v option \<Rightarrow> ('a, 'v) trie" where
  "modify t []     vo = Trie vo (alist t)"
| "modify t (a#as) vo =
     (let tt = (case assoc (alist t) a of
                  None \<Rightarrow> Trie None []
                | Some at \<Rightarrow> at)
      in Trie (value t) ((a, modify tt as vo) # alist t))"

theorem [simp]: "\<forall>t v bs. lookup (modify t as v) bs =
                    (if as = bs then v else lookup t bs)"
  apply (induct_tac as, auto)
  apply (case_tac[!] bs, auto)
done

text {*
  The above definition of @{term update} has the disadvantage that it often
  creates junk: each association list it passes through is extended at the left
  end with a new (letter,value) pair without removing any old association of
  that letter which may already be present.  Logically, such cleaning up is
  unnecessary because @{term assoc} always searches the list from the left.
  However, it constitutes a space leak: the old associations cannot be garbage
  collected because physically they are still reachable.  This problem can be
  solved by means of a function

  @{text "overwrite :: 'a \<Rightarrow> 'b \<Rightarrow> ('a * 'b) list \<Rightarrow> ('a * 'b) list"}

  that does not just add new pairs at the front but replaces old associations
  by new pairs if possible.

  Define @{term overwrite}, modify @{term modify} to employ @{term overwrite},
  and show the same relationship between @{term modify} and @{term lookup} as
  before.
*}

primrec overwrite :: "'a \<Rightarrow> 'b \<Rightarrow> ('a * 'b) list \<Rightarrow> ('a * 'b) list" where
  "overwrite a v []     = [(a,v)]"
| "overwrite a v (p#ps) = (let (b, u ) = p in (if a=b then (a,v)#ps else (b,u) # overwrite a v ps))"

lemma [simp]: "\<forall> a v b. assoc (overwrite a v ps) b = assoc ((a,v)#ps) b"
  by (induct_tac ps, auto)

primrec modify2 :: "('a, 'v) trie \<Rightarrow> 'a list \<Rightarrow> 'v option \<Rightarrow> ('a, 'v) trie" where
  "modify2 t []     vo = Trie vo (alist t)"
| "modify2 t (a#as) vo =
     (let tt = (case assoc (alist t) a of
                  None \<Rightarrow> Trie None []
                | Some at \<Rightarrow> at)
      in Trie (value t) (overwrite a (modify2 tt as vo) (alist t)))"

theorem "\<forall>t v bs. lookup (modify2 t as vo) bs =
                    (if as = bs then vo else lookup t bs)"
  apply (induct_tac as, auto)
  apply (case_tac[!] bs, auto)
done

text {*
  Instead of association lists we can also use partial functions that map
  letters to subtrees.  Partiality can be modelled with the help of type @{typ
  "'a option"}: if @{term f} is a function of type \mbox{@{typ "'a
  \<Rightarrow> 'b option"}}, let @{term "f a = Some b"} if @{term a} should be
  mapped to some @{term b}, and let @{term "f a = None"} otherwise.
*}

datatype ('a, 'v) trieP = TrieP "'v option" "'a \<Rightarrow> ('a,'v) trieP option"

text {*
  Modify the definitions of @{term lookup} and @{term modify} accordingly and
  show the same correctness theorem as above.
*}

primrec value3 :: "('a, 'v) trieP \<Rightarrow> 'v option" where
"value3 (TrieP ov m) = ov"

primrec mapping3 :: "('a,'v) trieP \<Rightarrow> 'a \<Rightarrow> ('a, 'v) trieP option" where
"mapping3 (TrieP ov m) = m"

primrec lookup3 :: "('a,'v) trieP \<Rightarrow> 'a list \<Rightarrow> 'v option" where
  "lookup3 t [] = value3 t"
| "lookup3 t (a#as) = (case mapping3 t a of
                        None \<Rightarrow> None
                      | Some at \<Rightarrow> lookup3 at as)"

lemma [simp]: "lookup3 (TrieP None (\<lambda>c. None)) as = None"
  by (case_tac as, simp_all)

primrec modify3 :: "('a,'v) trieP \<Rightarrow> 'a list \<Rightarrow> 'v option \<Rightarrow> ('a,'v) trieP" where
  "modify3 t []     vo = TrieP vo (mapping3 t)"
| "modify3 t (a#as) vo =
     (let tt = (case mapping3 t a of
                  None \<Rightarrow> TrieP None (\<lambda>c. None)
                | Some at \<Rightarrow> at)
      in TrieP (value3 t)
              (\<lambda>c. if c = a then Some (modify3 tt as vo) else mapping3 t c))"

theorem "\<forall>t v bs. lookup3 (modify3 t as vo) bs =
                    (if as = bs then vo else lookup3 t bs)"
  apply (induct_tac as, auto)
  apply (case_tac[!] bs, auto)
done

(*<*) end (*>*)


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory LexordList imports
  Main
  Eisbach_Methods (* for tests *)
begin

text \<open>
  Wrapper for lexicographic string comparisons.
  We need this to define search trees with string keys, etc.

  This is mostly copied from HOL/Library/List_lexord, but we add
  the wrapper type lexord_list to avoid clashing with the existing
  prefix ordering on lists (HOL/Library/Prefix_Order).
\<close>

datatype 'a lexord_list = lexord_list "'a list"
primrec dest_lexord_list where
  "dest_lexord_list (lexord_list xs) = xs"

instantiation lexord_list :: (ord) ord
begin

definition
  lexord_list_less_def: "xs < ys \<longleftrightarrow> (dest_lexord_list xs, dest_lexord_list ys) \<in> lexord {(u, v). u < v}"

definition
  lexord_list_le_def: "(xs :: _ lexord_list) \<le> ys \<longleftrightarrow> xs < ys \<or> xs = ys"

instance ..

end

instance lexord_list :: (order) order
proof
  fix xs :: "'a lexord_list"
  show "xs \<le> xs" by (simp add: lexord_list_le_def)
next
  fix xs ys zs :: "'a lexord_list"
  assume "xs \<le> ys" and "ys \<le> zs"
  then show "xs \<le> zs"
    apply (auto simp add: lexord_list_le_def lexord_list_less_def)
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
next
  fix xs ys :: "'a lexord_list"
  assume "xs \<le> ys" and "ys \<le> xs"
  then show "xs = ys"
    apply (auto simp add: lexord_list_le_def lexord_list_less_def)
    apply (rule lexord_irreflexive [THEN notE])
    defer
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
next
  fix xs ys :: "'a lexord_list"
  show "xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs"
    apply (auto simp add: lexord_list_less_def lexord_list_le_def)
    defer
    apply (rule lexord_irreflexive [THEN notE])
    apply auto
    apply (rule lexord_irreflexive [THEN notE])
    defer
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
qed

instance lexord_list :: (linorder) linorder
proof
  fix xs ys :: "'a lexord_list"
  have "(dest_lexord_list xs, dest_lexord_list ys) \<in> lexord {(u, v). u < v} \<or>
        dest_lexord_list xs = dest_lexord_list ys \<or>
        (dest_lexord_list ys, dest_lexord_list xs) \<in> lexord {(u, v). u < v}"
    by (rule lexord_linear) auto
  then show "xs \<le> ys \<or> ys \<le> xs"
    apply (case_tac xs)
    apply (case_tac ys)
    apply (auto simp add: lexord_list_le_def lexord_list_less_def)
    done
qed

instantiation lexord_list :: (linorder) distrib_lattice
begin

definition inf_lexord_list_def: "(inf :: 'a lexord_list \<Rightarrow> _) = min"

definition sup_lexord_list_def: "(sup :: 'a lexord_list \<Rightarrow> _) = max"

instance
  by standard (auto simp add: inf_lexord_list_def sup_lexord_list_def max_min_distrib2)

end

lemma lexord_not_less_Nil [simp]: "\<not> x < lexord_list []"
  by (simp add: lexord_list_less_def)

lemma lexord_Nil_less_Cons [simp]: "lexord_list [] < lexord_list (a # x)"
  by (simp add: lexord_list_less_def)

lemma lexord_Cons_less_Cons [simp]: "lexord_list (a # x) < lexord_list (b # y) \<longleftrightarrow> a < b \<or> a = b \<and> lexord_list x < lexord_list y"
  by (simp add: lexord_list_less_def)

lemma lexord_le_Nil [simp]: "x \<le> lexord_list [] \<longleftrightarrow> x = lexord_list []"
  unfolding lexord_list_le_def by (cases x) auto

lemma lexord_Nil_le_Cons [simp]: "lexord_list [] \<le> x"
  unfolding lexord_list_le_def
  apply (cases x, rename_tac x', case_tac x')
  by auto

lemma lexord_Cons_le_Cons [simp]: "lexord_list (a # x) \<le> lexord_list (b # y) \<longleftrightarrow> a < b \<or> a = b \<and> lexord_list x \<le> lexord_list y"
  unfolding lexord_list_le_def by auto

instantiation lexord_list :: (order) order_bot
begin

definition bot_lexord_list_def: "bot = lexord_list []"

instance
  by standard (simp add: bot_lexord_list_def)

end

lemma lexord_less_list_code [code]:
  "xs < lexord_list ([]::'a::{equal, order} list) \<longleftrightarrow> False"
  "lexord_list [] < lexord_list ((x::'a::{equal, order}) # xs') \<longleftrightarrow> True"
  "lexord_list ((x::'a::{equal, order}) # xs') < lexord_list (y # ys') \<longleftrightarrow> x < y \<or> x = y \<and> lexord_list xs' < lexord_list ys'"
  by simp_all

lemma lexord_less_eq_list_code [code]:
  "lexord_list (x # xs') \<le> lexord_list ([]::'a::{equal, order} list) \<longleftrightarrow> False"
  "lexord_list [] \<le> (xs::'a::{equal, order} lexord_list) \<longleftrightarrow> True"
  "lexord_list ((x::'a::{equal, order}) # xs') \<le> lexord_list (y # ys') \<longleftrightarrow> x < y \<or> x = y \<and> lexord_list xs' \<le> lexord_list ys'"
  by simp_all

text \<open>
  Some basic tests.
\<close>
experiment begin
  value "lexord_list [1, 2, 3, 4] < lexord_list [1, 2, 3, 5 :: int]"

  lemma "lexord_list [1, 2, 3, 4] < lexord_list [1, 2, 3, 5 :: int]"
    by simp
  lemma "\<not> (lexord_list [1, 2, 3, 5] < lexord_list [1, 2, 3, 4, 5 :: int])"
    by simp
  lemma "lexord_list [1, 2, 3, 4] \<le> lexord_list [1, 2, 3, 5 :: int]"
    by simp
end

text \<open>
  Minimal simpset for efficient lexord_list evaluation.
\<close>

lemmas lexord_list_simps =
  simp_thms
  lexord_list.inject list.distinct list.inject \<comment> \<open>eq\<close>
  lexord_not_less_Nil lexord_Nil_less_Cons lexord_Cons_less_Cons \<comment> \<open>less\<close>
  lexord_le_Nil lexord_Nil_le_Cons lexord_Cons_le_Cons \<comment> \<open>le\<close>

experiment begin
  lemma "lexord_list [1, 2, 3] < lexord_list [1, 3 :: nat]"
    apply (fails \<open>solves \<open>simp only: lexord_list_simps\<close>\<close>)
    apply (fails \<open>solves \<open>simp only: rel_simps\<close>\<close>)
    by (simp only: lexord_list_simps rel_simps)

  lemma "lexord_list [1, 2, 3] \<le> lexord_list [1, 3 :: nat]"
    apply (fails \<open>solves \<open>simp only: lexord_list_simps\<close>\<close>)
    apply (fails \<open>solves \<open>simp only: rel_simps\<close>\<close>)
    by (simp only: lexord_list_simps rel_simps)

  lemma "lexord_list [1, 2, 3] \<le> lexord_list [1, 2, 3 :: nat]"
    by (simp only: lexord_list_simps)

  lemma "\<not> (lexord_list [1, 2, 3] < lexord_list [1, 2, 3 :: nat])"
    by (simp only: lexord_list_simps rel_simps)
end

end


(*<*)theory Axioms imports Overloading Setup begin(*>*)

subsection {* Axioms *}

text {* Attaching axioms to our classes lets us reason on the level of
classes.  The results will be applicable to all types in a class, just
as in axiomatic mathematics.

\begin{warn}
Proofs in this section use structured \emph{Isar} proofs, which are not
covered in this tutorial; but see @{cite "Nipkow-TYPES02"}.%
\end{warn} *}

subsubsection {* Semigroups *}

text{* We specify \emph{semigroups} as subclass of @{class plus}: *}

class semigroup = plus +
  assumes assoc: "(x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"

text {* \noindent This @{command class} specification requires that
all instances of @{class semigroup} obey @{fact "assoc:"}~@{prop
[source] "\<And>x y z :: 'a::semigroup. (x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"}.

We can use this class axiom to derive further abstract theorems
relative to class @{class semigroup}: *}

lemma assoc_left:
  fixes x y z :: "'a::semigroup"
  shows "x \<oplus> (y \<oplus> z) = (x \<oplus> y) \<oplus> z"
  using assoc by (rule sym)

text {* \noindent The @{class semigroup} constraint on type @{typ
"'a"} restricts instantiations of @{typ "'a"} to types of class
@{class semigroup} and during the proof enables us to use the fact
@{fact assoc} whose type parameter is itself constrained to class
@{class semigroup}.  The main advantage of classes is that theorems
can be proved in the abstract and freely reused for each instance.

On instantiation, we have to give a proof that the given operations
obey the class axioms: *}

instantiation nat :: semigroup
begin

instance proof

txt {* \noindent The proof opens with a default proof step, which for
instance judgements invokes method @{method intro_classes}. *}

  fix m n q :: nat
  show "(m \<oplus> n) \<oplus> q = m \<oplus> (n \<oplus> q)"
    by (induct m) simp_all
qed

end

text {* \noindent Again, the interesting things enter the stage with
parametric types: *}

instantiation prod :: (semigroup, semigroup) semigroup
begin

instance proof
  fix p\<^sub>1 p\<^sub>2 p\<^sub>3 :: "'a::semigroup \<times> 'b::semigroup"
  show "p\<^sub>1 \<oplus> p\<^sub>2 \<oplus> p\<^sub>3 = p\<^sub>1 \<oplus> (p\<^sub>2 \<oplus> p\<^sub>3)"
    by (cases p\<^sub>1, cases p\<^sub>2, cases p\<^sub>3) (simp add: assoc)

txt {* \noindent Associativity of product semigroups is established
using the hypothetical associativity @{fact assoc} of the type
components, which holds due to the @{class semigroup} constraints
imposed on the type components by the @{command instance} proposition.
Indeed, this pattern often occurs with parametric types and type
classes. *}

qed

end

subsubsection {* Monoids *}

text {* We define a subclass @{text monoidl} (a semigroup with a
left-hand neutral) by extending @{class semigroup} with one additional
parameter @{text neutral} together with its property: *}

class monoidl = semigroup +
  fixes neutral :: "'a" ("\<zero>")
  assumes neutl: "\<zero> \<oplus> x = x"

text {* \noindent Again, we prove some instances, by providing
suitable parameter definitions and proofs for the additional
specifications. *}

instantiation nat :: monoidl
begin

definition
  neutral_nat_def: "\<zero> = (0::nat)"

instance proof
  fix n :: nat
  show "\<zero> \<oplus> n = n"
    unfolding neutral_nat_def by simp
qed

end

text {* \noindent In contrast to the examples above, we here have both
specification of class operations and a non-trivial instance proof.

This covers products as well:
*}

instantiation prod :: (monoidl, monoidl) monoidl
begin

definition
  neutral_prod_def: "\<zero> = (\<zero>, \<zero>)"

instance proof
  fix p :: "'a::monoidl \<times> 'b::monoidl"
  show "\<zero> \<oplus> p = p"
    by (cases p) (simp add: neutral_prod_def neutl)
qed

end

text {* \noindent Fully-fledged monoids are modelled by another
subclass which does not add new parameters but tightens the
specification: *}

class monoid = monoidl +
  assumes neutr: "x \<oplus> \<zero> = x"

text {* \noindent Corresponding instances for @{typ nat} and products
are left as an exercise to the reader. *}

subsubsection {* Groups *}

text {* \noindent To finish our small algebra example, we add a @{text
group} class: *}

class group = monoidl +
  fixes inv :: "'a \<Rightarrow> 'a" ("\<div> _" [81] 80)
  assumes invl: "\<div> x \<oplus> x = \<zero>"

text {* \noindent We continue with a further example for abstract
proofs relative to type classes: *}

lemma left_cancel:
  fixes x y z :: "'a::group"
  shows "x \<oplus> y = x \<oplus> z \<longleftrightarrow> y = z"
proof
  assume "x \<oplus> y = x \<oplus> z"
  then have "\<div> x \<oplus> (x \<oplus> y) = \<div> x \<oplus> (x \<oplus> z)" by simp
  then have "(\<div> x \<oplus> x) \<oplus> y = (\<div> x \<oplus> x) \<oplus> z" by (simp add: assoc)
  then show "y = z" by (simp add: invl neutl)
next
  assume "y = z"
  then show "x \<oplus> y = x \<oplus> z" by simp
qed

text {* \noindent Any @{text "group"} is also a @{text "monoid"}; this
can be made explicit by claiming an additional subclass relation,
together with a proof of the logical difference: *}

instance group \<subseteq> monoid
proof
  fix x
  from invl have "\<div> x \<oplus> x = \<zero>" .
  then have "\<div> x \<oplus> (x \<oplus> \<zero>) = \<div> x \<oplus> x"
    by (simp add: neutl invl assoc [symmetric])
  then show "x \<oplus> \<zero> = x" by (simp add: left_cancel)
qed

text {* \noindent The proof result is propagated to the type system,
making @{text group} an instance of @{text monoid} by adding an
additional edge to the graph of subclass relation; see also
Figure~\ref{fig:subclass}.

\begin{figure}[htbp]
 \begin{center}
   \small
   \unitlength 0.6mm
   \begin{picture}(40,60)(0,0)
     \put(20,60){\makebox(0,0){@{text semigroup}}}
     \put(20,40){\makebox(0,0){@{text monoidl}}}
     \put(00,20){\makebox(0,0){@{text monoid}}}
     \put(40,00){\makebox(0,0){@{text group}}}
     \put(20,55){\vector(0,-1){10}}
     \put(15,35){\vector(-1,-1){10}}
     \put(25,35){\vector(1,-3){10}}
   \end{picture}
   \hspace{8em}
   \begin{picture}(40,60)(0,0)
     \put(20,60){\makebox(0,0){@{text semigroup}}}
     \put(20,40){\makebox(0,0){@{text monoidl}}}
     \put(00,20){\makebox(0,0){@{text monoid}}}
     \put(40,00){\makebox(0,0){@{text group}}}
     \put(20,55){\vector(0,-1){10}}
     \put(15,35){\vector(-1,-1){10}}
     \put(05,15){\vector(3,-1){30}}
   \end{picture}
   \caption{Subclass relationship of monoids and groups:
      before and after establishing the relationship
      @{text "group \<subseteq> monoid"};  transitive edges are left out.}
   \label{fig:subclass}
 \end{center}
\end{figure}
*}

subsubsection {* Inconsistencies *}

text {* The reader may be wondering what happens if we attach an
inconsistent set of axioms to a class. So far we have always avoided
to add new axioms to HOL for fear of inconsistencies and suddenly it
seems that we are throwing all caution to the wind. So why is there no
problem?

The point is that by construction, all type variables in the axioms of
a \isacommand{class} are automatically constrained with the class
being defined (as shown for axiom @{thm[source]refl} above). These
constraints are always carried around and Isabelle takes care that
they are never lost, unless the type variable is instantiated with a
type that has been shown to belong to that class. Thus you may be able
to prove @{prop False} from your axioms, but Isabelle will remind you
that this theorem has the hidden hypothesis that the class is
non-empty.

Even if each individual class is consistent, intersections of
(unrelated) classes readily become inconsistent in practice. Now we
know this need not worry us. *}

subsubsection{* Syntactic Classes and Predefined Overloading *}

text {* In our algebra example, we have started with a \emph{syntactic
class} @{class plus} which only specifies operations but no axioms; it
would have been also possible to start immediately with class @{class
semigroup}, specifying the @{text "\<oplus>"} operation and associativity at
the same time.

Which approach is more appropriate depends.  Usually it is more
convenient to introduce operations and axioms in the same class: then
the type checker will automatically insert the corresponding class
constraints whenever the operations occur, reducing the need of manual
annotations.  However, when operations are decorated with popular
syntax, syntactic classes can be an option to re-use the syntax in
different contexts; this is indeed the way most overloaded constants
in HOL are introduced, of which the most important are listed in
Table~\ref{tab:overloading} in the appendix.  Section
\ref{sec:numeric-classes} covers a range of corresponding classes
\emph{with} axioms.

Further note that classes may contain axioms but \emph{no} operations.
An example is class @{class finite} from theory @{theory Finite_Set}
which specifies a type to be finite: @{lemma [source] "finite (UNIV :: 'a::finite
set)" by (fact finite_UNIV)}. *}

(*<*)end(*>*)


theory AteDefs
imports "../HOModel"
begin

section \<open>Verification of the \ate{} Consensus algorithm\<close>

text \<open>
  Algorithm \ate{} is presented in~\cite{biely:tolerating}. Like \ute{},
  it is an uncoordinated algorithm that tolerates value faults, and it
  is parameterized by values $T$, $E$, and $\alpha$ that serve a similar
  function as in \ute{}, allowing the algorithm to be adapted to the
  characteristics of different systems. \ate{} can be understood as a
  variant of \emph{OneThirdRule} tolerating Byzantine faults.

  We formalize in Isabelle the correctness proof of the algorithm that
  appears in~\cite{biely:tolerating}, using the framework of theory
  \<open>HOModel\<close>.
\<close>

subsection \<open>Model of the Algorithm\<close>

text \<open>
  We begin by introducing an anonymous type of processes of finite
  cardinality that will instantiate the type variable \<open>'proc\<close>
  of the generic HO model.
\<close>

typedecl Proc \<comment> \<open>the set of processes\<close>
axiomatization where Proc_finite: "OFCLASS(Proc, finite_class)"
instance Proc :: finite by (rule Proc_finite)

abbreviation
  "N \<equiv> card (UNIV::Proc set)"   \<comment> \<open>number of processes\<close>

text \<open>The following record models the local state of a process.\<close>

record 'val pstate =
  x :: "'val"              \<comment> \<open>current value held by process\<close>
  decide :: "'val option"  \<comment> \<open>value the process has decided on, if any\<close>

text \<open>
  The \<open>x\<close> field of the initial state is unconstrained, but no
  decision has yet been taken.
\<close>

definition Ate_initState where
  "Ate_initState p st \<equiv> (decide st = None)"

text \<open>
  The following locale introduces the parameters used for the \ate{}
  algorithm and their constraints~\cite{biely:tolerating}.
\<close>

locale ate_parameters =
  fixes \<alpha>::nat and T::nat and E::nat
  assumes TNaE:"T \<ge> 2*(N + 2*\<alpha> - E)"
      and TltN:"T < N"
      and EltN:"E < N"

begin

text \<open>The following are consequences of the assumptions on the parameters.\<close>

lemma majE: "2 * (E - \<alpha>) \<ge> N"
using TNaE TltN by auto

lemma Egta: "E > \<alpha>"
using majE EltN by auto

lemma Tge2a: "T \<ge> 2 * \<alpha>"
using TNaE EltN by auto

text \<open>
  At every round, each process sends its current \<open>x\<close>.
  If it received more than \<open>T\<close> messages, it selects the smallest value
  and store it in \<open>x\<close>. As in algorithm \emph{OneThirdRule}, we
  therefore require values to be linearly ordered.

  If more than \<open>E\<close> messages holding the same value are received,
  the process decides that value.
\<close>

definition mostOftenRcvd where
  "mostOftenRcvd (msgs::Proc \<Rightarrow> 'val option) \<equiv>
   {v. \<forall>w. card {qq. msgs qq = Some w} \<le> card {qq. msgs qq = Some v}}"

definition
  Ate_sendMsg :: "nat \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> 'val"
where
  "Ate_sendMsg r p q st \<equiv> x st"

definition
  Ate_nextState :: "nat \<Rightarrow> Proc \<Rightarrow> ('val::linorder) pstate \<Rightarrow> (Proc \<Rightarrow> 'val option)
                        \<Rightarrow> 'val pstate \<Rightarrow> bool"
where
  "Ate_nextState r p st msgs st' \<equiv>
     (if card {q. msgs q \<noteq> None} > T
      then x st' = Min (mostOftenRcvd msgs)
      else x st' = x st)
   \<and> (   (\<exists>v. card {q. msgs q = Some v} > E  \<and> decide st' = Some v)
       \<or> \<not> (\<exists>v. card {q. msgs q = Some v} > E)
         \<and> decide st' = decide st)"

subsection \<open>Communication Predicate for \ate{}\<close>

text \<open>
  Following~\cite{biely:tolerating}, we now define the communication
  predicate for the \ate{} algorithm. The round-by-round predicate
  requires that no process may receive more than \<open>\<alpha>\<close> corrupted
  messages at any round.
\<close>
definition Ate_commPerRd where
  "Ate_commPerRd HOrs SHOrs \<equiv>
   \<forall>p. card (HOrs p - SHOrs p) \<le> \<alpha>"

text \<open>
  The global communication predicate stipulates the three following
  conditions:
  \begin{itemize}
  \item for every process \<open>p\<close> there are infinitely many rounds
    where \<open>p\<close> receives more than \<open>T\<close> messages,
  \item for every process \<open>p\<close> there are infinitely many rounds
    where \<open>p\<close> receives more than \<open>E\<close> uncorrupted messages,
  \item and there are infinitely many rounds in which more than
    \<open>E - \<alpha>\<close> processes receive uncorrupted messages from the
    same set of processes, which contains more than \<open>T\<close> processes.
  \end{itemize}
\<close>
definition
  Ate_commGlobal where
  "Ate_commGlobal HOs SHOs \<equiv>
     (\<forall>r p. \<exists>r' > r. card (HOs r' p) > T)
   \<and> (\<forall>r p.  \<exists>r' > r. card (SHOs r' p \<inter> HOs r' p) > E)
   \<and> (\<forall>r. \<exists>r' > r. \<exists>\<pi>1 \<pi>2.
        card \<pi>1 > E - \<alpha>
      \<and> card \<pi>2 > T
      \<and> (\<forall>p \<in> \<pi>1. HOs r' p = \<pi>2 \<and> SHOs r' p \<inter> HOs r' p = \<pi>2))"

subsection \<open>The \ate{} Heard-Of Machine\<close>

text \<open>
  We now define the non-coordinated SHO machine for the \ate{} algorithm
  by assembling the algorithm definition and its communication-predicate.
\<close>

definition Ate_SHOMachine where
  "Ate_SHOMachine = \<lparr>
    CinitState =  (\<lambda> p st crd. Ate_initState p (st::('val::linorder) pstate)),
    sendMsg =  Ate_sendMsg,
    CnextState = (\<lambda> r p st msgs crd st'. Ate_nextState r p st msgs st'),
    SHOcommPerRd = (Ate_commPerRd:: Proc HO \<Rightarrow> Proc HO \<Rightarrow> bool),
    SHOcommGlobal = Ate_commGlobal
   \<rparr>"

abbreviation
  "Ate_M \<equiv> (Ate_SHOMachine::(Proc, 'val::linorder pstate, 'val) SHOMachine)"

end   \<comment> \<open>locale @{text "ate_parameters"}\<close>

end   (* theory AteDefs *)


theory Disjoint_Sets
imports
  "HOL-Library.Finite_Map"
begin

lemma disjnt_insert: "x \<notin> N \<Longrightarrow> disjnt M N \<Longrightarrow> disjnt (insert x M) N"
unfolding disjnt_def by simp

lemma disjnt_ge_max:
  assumes "finite Y" "\<And>x. x \<in> X \<Longrightarrow> x > Max Y"
  shows "disjnt X Y"
unfolding disjnt_def
by (meson Int_emptyI Max.coboundedI assms(1) assms(2) leD)

context
  includes fset.lifting
begin

lift_definition fdisjnt :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" is disjnt .

lemma fdisjnt_alt_def: "fdisjnt M N \<longleftrightarrow> (M |\<inter>| N = {||})"
by transfer (simp add: disjnt_def)

lemma fdisjnt_insert: "x |\<notin>| N \<Longrightarrow> fdisjnt M N \<Longrightarrow> fdisjnt (finsert x M) N"
by transfer' (rule disjnt_insert)

lemma fdisjnt_subset_right: "N' |\<subseteq>| N \<Longrightarrow> fdisjnt M N \<Longrightarrow> fdisjnt M N'"
unfolding fdisjnt_alt_def by auto

lemma fdisjnt_subset_left: "N' |\<subseteq>| N \<Longrightarrow> fdisjnt N M \<Longrightarrow> fdisjnt N' M"
unfolding fdisjnt_alt_def by auto

lemma fdisjnt_union_right: "fdisjnt M A \<Longrightarrow> fdisjnt M B \<Longrightarrow> fdisjnt M (A |\<union>| B)"
unfolding fdisjnt_alt_def by auto

lemma fdisjnt_union_left: "fdisjnt A M \<Longrightarrow> fdisjnt B M \<Longrightarrow> fdisjnt (A |\<union>| B) M"
unfolding fdisjnt_alt_def by auto

lemma fdisjnt_swap: "fdisjnt M N \<Longrightarrow> fdisjnt N M"
including fset.lifting by transfer' (auto simp: disjnt_def)

lemma distinct_append_fset:
  assumes "distinct xs" "distinct ys" "fdisjnt (fset_of_list xs) (fset_of_list ys)"
  shows "distinct (xs @ ys)"
using assms
by transfer' (simp add: disjnt_def)

lemma fdisjnt_contrI:
  assumes "\<And>x. x |\<in>| M \<Longrightarrow> x |\<in>| N \<Longrightarrow> False"
  shows "fdisjnt M N"
using assms
by transfer' (auto simp: disjnt_def)

lemma fdisjnt_Union_left: "fdisjnt (ffUnion S) T \<longleftrightarrow> fBall S (\<lambda>S. fdisjnt S T)"
by transfer' (auto simp: disjnt_def)

lemma fdisjnt_Union_right: "fdisjnt T (ffUnion S) \<longleftrightarrow> fBall S (\<lambda>S. fdisjnt T S)"
by transfer' (auto simp: disjnt_def)

lemma fdisjnt_ge_max: "fBall X (\<lambda>x. x > fMax Y) \<Longrightarrow> fdisjnt X Y"
by transfer (auto intro: disjnt_ge_max)

end

(* FIXME should be provable without lifting *)
lemma fmadd_disjnt: "fdisjnt (fmdom m) (fmdom n) \<Longrightarrow> m ++\<^sub>f n = n ++\<^sub>f m"
unfolding fdisjnt_alt_def
including fset.lifting fmap.lifting
apply transfer
apply (rule ext)
apply (auto simp: map_add_def split: option.splits)
done

end