(*  Title:      HOL/Library/BigO.thy
    Authors:    Jeremy Avigad and Kevin Donnelly
*)

section \<open>Big O notation\<close>

theory BigO
  imports
    Complex_MainRLT
    Function_Algebras
    Set_Algebras
begin

text \<open>
  This library is designed to support asymptotic ``big O'' calculations,
  i.e.~reasoning with expressions of the form \<open>f = O(g)\<close> and \<open>f = g + O(h)\<close>.
  An earlier version of this library is described in detail in @{cite
  "Avigad-Donnelly"}.

  The main changes in this version are as follows:

    \<^item> We have eliminated the \<open>O\<close> operator on sets. (Most uses of this seem
      to be inessential.)
    \<^item> We no longer use \<open>+\<close> as output syntax for \<open>+o\<close>
    \<^item> Lemmas involving \<open>sumr\<close> have been replaced by more general lemmas
      involving `\<open>sum\<close>.
    \<^item> The library has been expanded, with e.g.~support for expressions of
      the form \<open>f < g + O(h)\<close>.

  Note also since the Big O library includes rules that demonstrate set
  inclusion, to use the automated reasoners effectively with the library one
  should redeclare the theorem \<open>subsetI\<close> as an intro rule, rather than as an
  \<open>intro!\<close> rule, for example, using \<^theory_text>\<open>declare subsetI [del, intro]\<close>.
\<close>

subsection \<open>Definitions\<close>

definition bigo :: "('a \<Rightarrow> 'b::linordered_idom) \<Rightarrow> ('a \<Rightarrow> 'b) set"  ("(1O'(_'))")
  where "O(f:: 'a \<Rightarrow> 'b) = {h. \<exists>c. \<forall>x. \<bar>h x\<bar> \<le> c * \<bar>f x\<bar>}"

lemma bigo_pos_const:
  "(\<exists>c::'a::linordered_idom. \<forall>x. \<bar>h x\<bar> \<le> c * \<bar>f x\<bar>) \<longleftrightarrow>
    (\<exists>c. 0 < c \<and> (\<forall>x. \<bar>h x\<bar> \<le> c * \<bar>f x\<bar>))"
  apply auto
  apply (case_tac "c = 0")
   apply simp
   apply (rule_tac x = "1" in exI)
   apply simp
  apply (rule_tac x = "\<bar>c\<bar>" in exI)
  apply auto
  apply (subgoal_tac "c * \<bar>f x\<bar> \<le> \<bar>c\<bar> * \<bar>f x\<bar>")
   apply (erule_tac x = x in allE)
   apply force
  apply (rule mult_right_mono)
   apply (rule abs_ge_self)
  apply (rule abs_ge_zero)
  done

lemma bigo_alt_def: "O(f) = {h. \<exists>c. 0 < c \<and> (\<forall>x. \<bar>h x\<bar> \<le> c * \<bar>f x\<bar>)}"
  by (auto simp add: bigo_def bigo_pos_const)

lemma bigo_elt_subset [intro]: "f \<in> O(g) \<Longrightarrow> O(f) \<le> O(g)"
  apply (auto simp add: bigo_alt_def)
  apply (rule_tac x = "ca * c" in exI)
  apply (rule conjI)
   apply simp
  apply (rule allI)
  apply (drule_tac x = "xa" in spec)+
  apply (subgoal_tac "ca * \<bar>f xa\<bar> \<le> ca * (c * \<bar>g xa\<bar>)")
   apply (erule order_trans)
   apply (simp add: ac_simps)
  apply (rule mult_left_mono, assumption)
  apply (rule order_less_imp_le, assumption)
  done

lemma bigo_refl [intro]: "f \<in> O(f)"
  apply (auto simp add: bigo_def)
  apply (rule_tac x = 1 in exI)
  apply simp
  done

lemma bigo_zero: "0 \<in> O(g)"
  apply (auto simp add: bigo_def func_zero)
  apply (rule_tac x = 0 in exI)
  apply auto
  done

lemma bigo_zero2: "O(\<lambda>x. 0) = {\<lambda>x. 0}"
  by (auto simp add: bigo_def)

lemma bigo_plus_self_subset [intro]: "O(f) + O(f) \<subseteq> O(f)"
  apply (auto simp add: bigo_alt_def set_plus_def)
  apply (rule_tac x = "c + ca" in exI)
  apply auto
  apply (simp add: ring_distribs func_plus)
  apply (rule order_trans)
   apply (rule abs_triangle_ineq)
  apply (rule add_mono)
   apply force
  apply force
  done

lemma bigo_plus_idemp [simp]: "O(f) + O(f) = O(f)"
  apply (rule equalityI)
   apply (rule bigo_plus_self_subset)
  apply (rule set_zero_plus2)
  apply (rule bigo_zero)
  done

lemma bigo_plus_subset [intro]: "O(f + g) \<subseteq> O(f) + O(g)"
  apply (rule subsetI)
  apply (auto simp add: bigo_def bigo_pos_const func_plus set_plus_def)
  apply (subst bigo_pos_const [symmetric])+
  apply (rule_tac x = "\<lambda>n. if \<bar>g n\<bar> \<le> \<bar>f n\<bar> then x n else 0" in exI)
  apply (rule conjI)
   apply (rule_tac x = "c + c" in exI)
   apply (clarsimp)
   apply (subgoal_tac "c * \<bar>f xa + g xa\<bar> \<le> (c + c) * \<bar>f xa\<bar>")
    apply (erule_tac x = xa in allE)
    apply (erule order_trans)
    apply (simp)
   apply (subgoal_tac "c * \<bar>f xa + g xa\<bar> \<le> c * (\<bar>f xa\<bar> + \<bar>g xa\<bar>)")
    apply (erule order_trans)
    apply (simp add: ring_distribs)
   apply (rule mult_left_mono)
    apply (simp add: abs_triangle_ineq)
   apply (simp add: order_less_le)
  apply (rule_tac x = "\<lambda>n. if \<bar>f n\<bar> < \<bar>g n\<bar> then x n else 0" in exI)
  apply (rule conjI)
   apply (rule_tac x = "c + c" in exI)
   apply auto
  apply (subgoal_tac "c * \<bar>f xa + g xa\<bar> \<le> (c + c) * \<bar>g xa\<bar>")
   apply (erule_tac x = xa in allE)
   apply (erule order_trans)
   apply simp
  apply (subgoal_tac "c * \<bar>f xa + g xa\<bar> \<le> c * (\<bar>f xa\<bar> + \<bar>g xa\<bar>)")
   apply (erule order_trans)
   apply (simp add: ring_distribs)
  apply (rule mult_left_mono)
   apply (rule abs_triangle_ineq)
  apply (simp add: order_less_le)
  done

lemma bigo_plus_subset2 [intro]: "A \<subseteq> O(f) \<Longrightarrow> B \<subseteq> O(f) \<Longrightarrow> A + B \<subseteq> O(f)"
  apply (subgoal_tac "A + B \<subseteq> O(f) + O(f)")
   apply (erule order_trans)
   apply simp
  apply (auto del: subsetI simp del: bigo_plus_idemp)
  done

lemma bigo_plus_eq: "\<forall>x. 0 \<le> f x \<Longrightarrow> \<forall>x. 0 \<le> g x \<Longrightarrow> O(f + g) = O(f) + O(g)"
  apply (rule equalityI)
   apply (rule bigo_plus_subset)
  apply (simp add: bigo_alt_def set_plus_def func_plus)
  apply clarify
  apply (rule_tac x = "max c ca" in exI)
  apply (rule conjI)
   apply (subgoal_tac "c \<le> max c ca")
    apply (erule order_less_le_trans)
    apply assumption
   apply (rule max.cobounded1)
  apply clarify
  apply (drule_tac x = "xa" in spec)+
  apply (subgoal_tac "0 \<le> f xa + g xa")
   apply (simp add: ring_distribs)
   apply (subgoal_tac "\<bar>a xa + b xa\<bar> \<le> \<bar>a xa\<bar> + \<bar>b xa\<bar>")
    apply (subgoal_tac "\<bar>a xa\<bar> + \<bar>b xa\<bar> \<le> max c ca * f xa + max c ca * g xa")
     apply force
    apply (rule add_mono)
     apply (subgoal_tac "c * f xa \<le> max c ca * f xa")
      apply force
     apply (rule mult_right_mono)
      apply (rule max.cobounded1)
     apply assumption
    apply (subgoal_tac "ca * g xa \<le> max c ca * g xa")
     apply force
    apply (rule mult_right_mono)
     apply (rule max.cobounded2)
    apply assumption
   apply (rule abs_triangle_ineq)
  apply (rule add_nonneg_nonneg)
   apply assumption+
  done

lemma bigo_bounded_alt: "\<forall>x. 0 \<le> f x \<Longrightarrow> \<forall>x. f x \<le> c * g x \<Longrightarrow> f \<in> O(g)"
  apply (auto simp add: bigo_def)
  apply (rule_tac x = "\<bar>c\<bar>" in exI)
  apply auto
  apply (drule_tac x = x in spec)+
  apply (simp flip: abs_mult)
  done

lemma bigo_bounded: "\<forall>x. 0 \<le> f x \<Longrightarrow> \<forall>x. f x \<le> g x \<Longrightarrow> f \<in> O(g)"
  apply (erule bigo_bounded_alt [of f 1 g])
  apply simp
  done

lemma bigo_bounded2: "\<forall>x. lb x \<le> f x \<Longrightarrow> \<forall>x. f x \<le> lb x + g x \<Longrightarrow> f \<in> lb +o O(g)"
  apply (rule set_minus_imp_plus)
  apply (rule bigo_bounded)
   apply (auto simp add: fun_Compl_def func_plus)
  apply (drule_tac x = x in spec)+
  apply force
  done

lemma bigo_abs: "(\<lambda>x. \<bar>f x\<bar>) =o O(f)"
  apply (unfold bigo_def)
  apply auto
  apply (rule_tac x = 1 in exI)
  apply auto
  done

lemma bigo_abs2: "f =o O(\<lambda>x. \<bar>f x\<bar>)"
  apply (unfold bigo_def)
  apply auto
  apply (rule_tac x = 1 in exI)
  apply auto
  done

lemma bigo_abs3: "O(f) = O(\<lambda>x. \<bar>f x\<bar>)"
  apply (rule equalityI)
   apply (rule bigo_elt_subset)
   apply (rule bigo_abs2)
  apply (rule bigo_elt_subset)
  apply (rule bigo_abs)
  done

lemma bigo_abs4: "f =o g +o O(h) \<Longrightarrow> (\<lambda>x. \<bar>f x\<bar>) =o (\<lambda>x. \<bar>g x\<bar>) +o O(h)"
  apply (drule set_plus_imp_minus)
  apply (rule set_minus_imp_plus)
  apply (subst fun_diff_def)
proof -
  assume *: "f - g \<in> O(h)"
  have "(\<lambda>x. \<bar>f x\<bar> - \<bar>g x\<bar>) =o O(\<lambda>x. \<bar>\<bar>f x\<bar> - \<bar>g x\<bar>\<bar>)"
    by (rule bigo_abs2)
  also have "\<dots> \<subseteq> O(\<lambda>x. \<bar>f x - g x\<bar>)"
    apply (rule bigo_elt_subset)
    apply (rule bigo_bounded)
     apply force
    apply (rule allI)
    apply (rule abs_triangle_ineq3)
    done
  also have "\<dots> \<subseteq> O(f - g)"
    apply (rule bigo_elt_subset)
    apply (subst fun_diff_def)
    apply (rule bigo_abs)
    done
  also from * have "\<dots> \<subseteq> O(h)"
    by (rule bigo_elt_subset)
  finally show "(\<lambda>x. \<bar>f x\<bar> - \<bar>g x\<bar>) \<in> O(h)".
qed

lemma bigo_abs5: "f =o O(g) \<Longrightarrow> (\<lambda>x. \<bar>f x\<bar>) =o O(g)"
  by (auto simp: bigo_def)

lemma bigo_elt_subset2 [intro]:
  assumes *: "f \<in> g +o O(h)"
  shows "O(f) \<subseteq> O(g) + O(h)"
proof -
  note *
  also have "g +o O(h) \<subseteq> O(g) + O(h)"
    by (auto del: subsetI)
  also have "\<dots> = O(\<lambda>x. \<bar>g x\<bar>) + O(\<lambda>x. \<bar>h x\<bar>)"
    by (subst bigo_abs3 [symmetric])+ (rule refl)
  also have "\<dots> = O((\<lambda>x. \<bar>g x\<bar>) + (\<lambda>x. \<bar>h x\<bar>))"
    by (rule bigo_plus_eq [symmetric]) auto
  finally have "f \<in> \<dots>" .
  then have "O(f) \<subseteq> \<dots>"
    by (elim bigo_elt_subset)
  also have "\<dots> = O(\<lambda>x. \<bar>g x\<bar>) + O(\<lambda>x. \<bar>h x\<bar>)"
    by (rule bigo_plus_eq, auto)
  finally show ?thesis
    by (simp flip: bigo_abs3)
qed

lemma bigo_mult [intro]: "O(f)*O(g) \<subseteq> O(f * g)"
  apply (rule subsetI)
  apply (subst bigo_def)
  apply (auto simp add: bigo_alt_def set_times_def func_times)
  apply (rule_tac x = "c * ca" in exI)
  apply (rule allI)
  apply (erule_tac x = x in allE)+
  apply (subgoal_tac "c * ca * \<bar>f x * g x\<bar> = (c * \<bar>f x\<bar>) * (ca * \<bar>g x\<bar>)")
   apply (erule ssubst)
   apply (subst abs_mult)
   apply (rule mult_mono)
      apply assumption+
    apply auto
  apply (simp add: ac_simps abs_mult)
  done

lemma bigo_mult2 [intro]: "f *o O(g) \<subseteq> O(f * g)"
  apply (auto simp add: bigo_def elt_set_times_def func_times abs_mult)
  apply (rule_tac x = c in exI)
  apply auto
  apply (drule_tac x = x in spec)
  apply (subgoal_tac "\<bar>f x\<bar> * \<bar>b x\<bar> \<le> \<bar>f x\<bar> * (c * \<bar>g x\<bar>)")
   apply (force simp add: ac_simps)
  apply (rule mult_left_mono, assumption)
  apply (rule abs_ge_zero)
  done

lemma bigo_mult3: "f \<in> O(h) \<Longrightarrow> g \<in> O(j) \<Longrightarrow> f * g \<in> O(h * j)"
  apply (rule subsetD)
   apply (rule bigo_mult)
  apply (erule set_times_intro, assumption)
  done

lemma bigo_mult4 [intro]: "f \<in> k +o O(h) \<Longrightarrow> g * f \<in> (g * k) +o O(g * h)"
  apply (drule set_plus_imp_minus)
  apply (rule set_minus_imp_plus)
  apply (drule bigo_mult3 [where g = g and j = g])
   apply (auto simp add: algebra_simps)
  done

lemma bigo_mult5:
  fixes f :: "'a \<Rightarrow> 'b::linordered_field"
  assumes "\<forall>x. f x \<noteq> 0"
  shows "O(f * g) \<subseteq> f *o O(g)"
proof
  fix h
  assume "h \<in> O(f * g)"
  then have "(\<lambda>x. 1 / (f x)) * h \<in> (\<lambda>x. 1 / f x) *o O(f * g)"
    by auto
  also have "\<dots> \<subseteq> O((\<lambda>x. 1 / f x) * (f * g))"
    by (rule bigo_mult2)
  also have "(\<lambda>x. 1 / f x) * (f * g) = g"
    apply (simp add: func_times)
    apply (rule ext)
    apply (simp add: assms nonzero_divide_eq_eq ac_simps)
    done
  finally have "(\<lambda>x. (1::'b) / f x) * h \<in> O(g)" .
  then have "f * ((\<lambda>x. (1::'b) / f x) * h) \<in> f *o O(g)"
    by auto
  also have "f * ((\<lambda>x. (1::'b) / f x) * h) = h"
    apply (simp add: func_times)
    apply (rule ext)
    apply (simp add: assms nonzero_divide_eq_eq ac_simps)
    done
  finally show "h \<in> f *o O(g)" .
qed

lemma bigo_mult6: "\<forall>x. f x \<noteq> 0 \<Longrightarrow> O(f * g) = f *o O(g)"
  for f :: "'a \<Rightarrow> 'b::linordered_field"
  apply (rule equalityI)
   apply (erule bigo_mult5)
  apply (rule bigo_mult2)
  done

lemma bigo_mult7: "\<forall>x. f x \<noteq> 0 \<Longrightarrow> O(f * g) \<subseteq> O(f) * O(g)"
  for f :: "'a \<Rightarrow> 'b::linordered_field"
  apply (subst bigo_mult6)
   apply assumption
  apply (rule set_times_mono3)
  apply (rule bigo_refl)
  done

lemma bigo_mult8: "\<forall>x. f x \<noteq> 0 \<Longrightarrow> O(f * g) = O(f) * O(g)"
  for f :: "'a \<Rightarrow> 'b::linordered_field"
  apply (rule equalityI)
   apply (erule bigo_mult7)
  apply (rule bigo_mult)
  done

lemma bigo_minus [intro]: "f \<in> O(g) \<Longrightarrow> - f \<in> O(g)"
  by (auto simp add: bigo_def fun_Compl_def)

lemma bigo_minus2: "f \<in> g +o O(h) \<Longrightarrow> - f \<in> -g +o O(h)"
  apply (rule set_minus_imp_plus)
  apply (drule set_plus_imp_minus)
  apply (drule bigo_minus)
  apply simp
  done

lemma bigo_minus3: "O(- f) = O(f)"
  by (auto simp add: bigo_def fun_Compl_def)

lemma bigo_plus_absorb_lemma1:
  assumes *: "f \<in> O(g)"
  shows "f +o O(g) \<subseteq> O(g)"
proof -
  have "f \<in> O(f)" by auto
  then have "f +o O(g) \<subseteq> O(f) + O(g)"
    by (auto del: subsetI)
  also have "\<dots> \<subseteq> O(g) + O(g)"
  proof -
    from * have "O(f) \<subseteq> O(g)"
      by (auto del: subsetI)
    then show ?thesis
      by (auto del: subsetI)
  qed
  also have "\<dots> \<subseteq> O(g)" by simp
  finally show ?thesis .
qed

lemma bigo_plus_absorb_lemma2:
  assumes *: "f \<in> O(g)"
  shows "O(g) \<subseteq> f +o O(g)"
proof -
  from * have "- f \<in> O(g)"
    by auto
  then have "- f +o O(g) \<subseteq> O(g)"
    by (elim bigo_plus_absorb_lemma1)
  then have "f +o (- f +o O(g)) \<subseteq> f +o O(g)"
    by auto
  also have "f +o (- f +o O(g)) = O(g)"
    by (simp add: set_plus_rearranges)
  finally show ?thesis .
qed

lemma bigo_plus_absorb [simp]: "f \<in> O(g) \<Longrightarrow> f +o O(g) = O(g)"
  apply (rule equalityI)
   apply (erule bigo_plus_absorb_lemma1)
  apply (erule bigo_plus_absorb_lemma2)
  done

lemma bigo_plus_absorb2 [intro]: "f \<in> O(g) \<Longrightarrow> A \<subseteq> O(g) \<Longrightarrow> f +o A \<subseteq> O(g)"
  apply (subgoal_tac "f +o A \<subseteq> f +o O(g)")
   apply force+
  done

lemma bigo_add_commute_imp: "f \<in> g +o O(h) \<Longrightarrow> g \<in> f +o O(h)"
  apply (subst set_minus_plus [symmetric])
  apply (subgoal_tac "g - f = - (f - g)")
   apply (erule ssubst)
   apply (rule bigo_minus)
   apply (subst set_minus_plus)
   apply assumption
  apply (simp add: ac_simps)
  done

lemma bigo_add_commute: "f \<in> g +o O(h) \<longleftrightarrow> g \<in> f +o O(h)"
  apply (rule iffI)
   apply (erule bigo_add_commute_imp)+
  done

lemma bigo_const1: "(\<lambda>x. c) \<in> O(\<lambda>x. 1)"
  by (auto simp add: bigo_def ac_simps)

lemma bigo_const2 [intro]: "O(\<lambda>x. c) \<subseteq> O(\<lambda>x. 1)"
  apply (rule bigo_elt_subset)
  apply (rule bigo_const1)
  done

lemma bigo_const3: "c \<noteq> 0 \<Longrightarrow> (\<lambda>x. 1) \<in> O(\<lambda>x. c)"
  for c :: "'a::linordered_field"
  apply (simp add: bigo_def)
  apply (rule_tac x = "\<bar>inverse c\<bar>" in exI)
  apply (simp flip: abs_mult)
  done

lemma bigo_const4: "c \<noteq> 0 \<Longrightarrow> O(\<lambda>x. 1) \<subseteq> O(\<lambda>x. c)"
  for c :: "'a::linordered_field"
  apply (rule bigo_elt_subset)
  apply (rule bigo_const3)
  apply assumption
  done

lemma bigo_const [simp]: "c \<noteq> 0 \<Longrightarrow> O(\<lambda>x. c) = O(\<lambda>x. 1)"
  for c :: "'a::linordered_field"
  apply (rule equalityI)
   apply (rule bigo_const2)
  apply (rule bigo_const4)
  apply assumption
  done

lemma bigo_const_mult1: "(\<lambda>x. c * f x) \<in> O(f)"
  apply (simp add: bigo_def)
  apply (rule_tac x = "\<bar>c\<bar>" in exI)
  apply (auto simp flip: abs_mult)
  done

lemma bigo_const_mult2: "O(\<lambda>x. c * f x) \<subseteq> O(f)"
  apply (rule bigo_elt_subset)
  apply (rule bigo_const_mult1)
  done

lemma bigo_const_mult3: "c \<noteq> 0 \<Longrightarrow> f \<in> O(\<lambda>x. c * f x)"
  for c :: "'a::linordered_field"
  apply (simp add: bigo_def)
  apply (rule_tac x = "\<bar>inverse c\<bar>" in exI)
  apply (simp add: abs_mult mult.assoc [symmetric])
  done

lemma bigo_const_mult4: "c \<noteq> 0 \<Longrightarrow> O(f) \<subseteq> O(\<lambda>x. c * f x)"
  for c :: "'a::linordered_field"
  apply (rule bigo_elt_subset)
  apply (rule bigo_const_mult3)
  apply assumption
  done

lemma bigo_const_mult [simp]: "c \<noteq> 0 \<Longrightarrow> O(\<lambda>x. c * f x) = O(f)"
  for c :: "'a::linordered_field"
  apply (rule equalityI)
   apply (rule bigo_const_mult2)
  apply (erule bigo_const_mult4)
  done

lemma bigo_const_mult5 [simp]: "c \<noteq> 0 \<Longrightarrow> (\<lambda>x. c) *o O(f) = O(f)"
  for c :: "'a::linordered_field"
  apply (auto del: subsetI)
   apply (rule order_trans)
    apply (rule bigo_mult2)
   apply (simp add: func_times)
  apply (auto intro!: simp add: bigo_def elt_set_times_def func_times)
  apply (rule_tac x = "\<lambda>y. inverse c * x y" in exI)
  apply (simp add: mult.assoc [symmetric] abs_mult)
  apply (rule_tac x = "\<bar>inverse c\<bar> * ca" in exI)
  apply auto
  done

lemma bigo_const_mult6 [intro]: "(\<lambda>x. c) *o O(f) \<subseteq> O(f)"
  apply (auto intro!: simp add: bigo_def elt_set_times_def func_times)
  apply (rule_tac x = "ca * \<bar>c\<bar>" in exI)
  apply (rule allI)
  apply (subgoal_tac "ca * \<bar>c\<bar> * \<bar>f x\<bar> = \<bar>c\<bar> * (ca * \<bar>f x\<bar>)")
   apply (erule ssubst)
   apply (subst abs_mult)
   apply (rule mult_left_mono)
    apply (erule spec)
   apply simp
  apply (simp add: ac_simps)
  done

lemma bigo_const_mult7 [intro]:
  assumes *: "f =o O(g)"
  shows "(\<lambda>x. c * f x) =o O(g)"
proof -
  from * have "(\<lambda>x. c) * f =o (\<lambda>x. c) *o O(g)"
    by auto
  also have "(\<lambda>x. c) * f = (\<lambda>x. c * f x)"
    by (simp add: func_times)
  also have "(\<lambda>x. c) *o O(g) \<subseteq> O(g)"
    by (auto del: subsetI)
  finally show ?thesis .
qed

lemma bigo_compose1: "f =o O(g) \<Longrightarrow> (\<lambda>x. f (k x)) =o O(\<lambda>x. g (k x))"
  by (auto simp: bigo_def)

lemma bigo_compose2: "f =o g +o O(h) \<Longrightarrow> (\<lambda>x. f (k x)) =o (\<lambda>x. g (k x)) +o O(\<lambda>x. h(k x))"
  apply (simp only: set_minus_plus [symmetric] fun_Compl_def func_plus)
  apply (drule bigo_compose1)
  apply (simp add: fun_diff_def)
  done

subsection \<open>Sum\<close>

lemma bigo_sum_main: "\<forall>x. \<forall>y \<in> A x. 0 \<le> h x y \<Longrightarrow>
    \<exists>c. \<forall>x. \<forall>y \<in> A x. \<bar>f x y\<bar> \<le> c * h x y \<Longrightarrow>
      (\<lambda>x. \<Sum>y \<in> A x. f x y) =o O(\<lambda>x. \<Sum>y \<in> A x. h x y)"
  apply (auto simp add: bigo_def)
  apply (rule_tac x = "\<bar>c\<bar>" in exI)
  apply (subst abs_of_nonneg) back back
   apply (rule sum_nonneg)
   apply force
  apply (subst sum_distrib_left)
  apply (rule allI)
  apply (rule order_trans)
   apply (rule sum_abs)
  apply (rule sum_mono)
  apply (rule order_trans)
   apply (drule spec)+
   apply (drule bspec)+
     apply assumption+
   apply (drule bspec)
    apply assumption+
  apply (rule mult_right_mono)
   apply (rule abs_ge_self)
  apply force
  done

lemma bigo_sum1: "\<forall>x y. 0 \<le> h x y \<Longrightarrow>
    \<exists>c. \<forall>x y. \<bar>f x y\<bar> \<le> c * h x y \<Longrightarrow>
      (\<lambda>x. \<Sum>y \<in> A x. f x y) =o O(\<lambda>x. \<Sum>y \<in> A x. h x y)"
  apply (rule bigo_sum_main)
   apply force
  apply clarsimp
  apply (rule_tac x = c in exI)
  apply force
  done

lemma bigo_sum2: "\<forall>y. 0 \<le> h y \<Longrightarrow>
    \<exists>c. \<forall>y. \<bar>f y\<bar> \<le> c * (h y) \<Longrightarrow>
      (\<lambda>x. \<Sum>y \<in> A x. f y) =o O(\<lambda>x. \<Sum>y \<in> A x. h y)"
  by (rule bigo_sum1) auto

lemma bigo_sum3: "f =o O(h) \<Longrightarrow>
    (\<lambda>x. \<Sum>y \<in> A x. l x y * f (k x y)) =o O(\<lambda>x. \<Sum>y \<in> A x. \<bar>l x y * h (k x y)\<bar>)"
  apply (rule bigo_sum1)
   apply (rule allI)+
   apply (rule abs_ge_zero)
  apply (unfold bigo_def)
  apply auto
  apply (rule_tac x = c in exI)
  apply (rule allI)+
  apply (subst abs_mult)+
  apply (subst mult.left_commute)
  apply (rule mult_left_mono)
   apply (erule spec)
  apply (rule abs_ge_zero)
  done

lemma bigo_sum4: "f =o g +o O(h) \<Longrightarrow>
    (\<lambda>x. \<Sum>y \<in> A x. l x y * f (k x y)) =o
      (\<lambda>x. \<Sum>y \<in> A x. l x y * g (k x y)) +o
        O(\<lambda>x. \<Sum>y \<in> A x. \<bar>l x y * h (k x y)\<bar>)"
  apply (rule set_minus_imp_plus)
  apply (subst fun_diff_def)
  apply (subst sum_subtractf [symmetric])
  apply (subst right_diff_distrib [symmetric])
  apply (rule bigo_sum3)
  apply (subst fun_diff_def [symmetric])
  apply (erule set_plus_imp_minus)
  done

lemma bigo_sum5: "f =o O(h) \<Longrightarrow> \<forall>x y. 0 \<le> l x y \<Longrightarrow>
    \<forall>x. 0 \<le> h x \<Longrightarrow>
      (\<lambda>x. \<Sum>y \<in> A x. l x y * f (k x y)) =o
        O(\<lambda>x. \<Sum>y \<in> A x. l x y * h (k x y))"
  apply (subgoal_tac "(\<lambda>x. \<Sum>y \<in> A x. l x y * h (k x y)) =
      (\<lambda>x. \<Sum>y \<in> A x. \<bar>l x y * h (k x y)\<bar>)")
   apply (erule ssubst)
   apply (erule bigo_sum3)
  apply (rule ext)
  apply (rule sum.cong)
   apply (rule refl)
  apply (subst abs_of_nonneg)
   apply auto
  done

lemma bigo_sum6: "f =o g +o O(h) \<Longrightarrow> \<forall>x y. 0 \<le> l x y \<Longrightarrow>
    \<forall>x. 0 \<le> h x \<Longrightarrow>
      (\<lambda>x. \<Sum>y \<in> A x. l x y * f (k x y)) =o
        (\<lambda>x. \<Sum>y \<in> A x. l x y * g (k x y)) +o
          O(\<lambda>x. \<Sum>y \<in> A x. l x y * h (k x y))"
  apply (rule set_minus_imp_plus)
  apply (subst fun_diff_def)
  apply (subst sum_subtractf [symmetric])
  apply (subst right_diff_distrib [symmetric])
  apply (rule bigo_sum5)
    apply (subst fun_diff_def [symmetric])
    apply (drule set_plus_imp_minus)
    apply auto
  done

subsection \<open>Misc useful stuff\<close>

lemma bigo_useful_intro: "A \<subseteq> O(f) \<Longrightarrow> B \<subseteq> O(f) \<Longrightarrow> A + B \<subseteq> O(f)"
  apply (subst bigo_plus_idemp [symmetric])
  apply (rule set_plus_mono2)
   apply assumption+
  done

lemma bigo_useful_add: "f =o O(h) \<Longrightarrow> g =o O(h) \<Longrightarrow> f + g =o O(h)"
  apply (subst bigo_plus_idemp [symmetric])
  apply (rule set_plus_intro)
   apply assumption+
  done

lemma bigo_useful_const_mult: "c \<noteq> 0 \<Longrightarrow> (\<lambda>x. c) * f =o O(h) \<Longrightarrow> f =o O(h)"
  for c :: "'a::linordered_field"
  apply (rule subsetD)
   apply (subgoal_tac "(\<lambda>x. 1 / c) *o O(h) \<subseteq> O(h)")
    apply assumption
   apply (rule bigo_const_mult6)
  apply (subgoal_tac "f = (\<lambda>x. 1 / c) * ((\<lambda>x. c) * f)")
   apply (erule ssubst)
   apply (erule set_times_intro2)
  apply (simp add: func_times)
  done

lemma bigo_fix: "(\<lambda>x::nat. f (x + 1)) =o O(\<lambda>x. h (x + 1)) \<Longrightarrow> f 0 = 0 \<Longrightarrow> f =o O(h)"
  apply (simp add: bigo_alt_def)
  apply auto
  apply (rule_tac x = c in exI)
  apply auto
  apply (case_tac "x = 0")
   apply simp
  apply (subgoal_tac "x = Suc (x - 1)")
   apply (erule ssubst) back
   apply (erule spec)
  apply simp
  done

lemma bigo_fix2:
    "(\<lambda>x. f ((x::nat) + 1)) =o (\<lambda>x. g(x + 1)) +o O(\<lambda>x. h(x + 1)) \<Longrightarrow>
       f 0 = g 0 \<Longrightarrow> f =o g +o O(h)"
  apply (rule set_minus_imp_plus)
  apply (rule bigo_fix)
   apply (subst fun_diff_def)
   apply (subst fun_diff_def [symmetric])
   apply (rule set_plus_imp_minus)
   apply simp
  apply (simp add: fun_diff_def)
  done

subsection \<open>Less than or equal to\<close>

definition lesso :: "('a \<Rightarrow> 'b::linordered_idom) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"  (infixl "<o" 70)
  where "f <o g = (\<lambda>x. max (f x - g x) 0)"

lemma bigo_lesseq1: "f =o O(h) \<Longrightarrow> \<forall>x. \<bar>g x\<bar> \<le> \<bar>f x\<bar> \<Longrightarrow> g =o O(h)"
  apply (unfold bigo_def)
  apply clarsimp
  apply (rule_tac x = c in exI)
  apply (rule allI)
  apply (rule order_trans)
   apply (erule spec)+
  done

lemma bigo_lesseq2: "f =o O(h) \<Longrightarrow> \<forall>x. \<bar>g x\<bar> \<le> f x \<Longrightarrow> g =o O(h)"
  apply (erule bigo_lesseq1)
  apply (rule allI)
  apply (drule_tac x = x in spec)
  apply (rule order_trans)
   apply assumption
  apply (rule abs_ge_self)
  done

lemma bigo_lesseq3: "f =o O(h) \<Longrightarrow> \<forall>x. 0 \<le> g x \<Longrightarrow> \<forall>x. g x \<le> f x \<Longrightarrow> g =o O(h)"
  apply (erule bigo_lesseq2)
  apply (rule allI)
  apply (subst abs_of_nonneg)
   apply (erule spec)+
  done

lemma bigo_lesseq4: "f =o O(h) \<Longrightarrow>
    \<forall>x. 0 \<le> g x \<Longrightarrow> \<forall>x. g x \<le> \<bar>f x\<bar> \<Longrightarrow> g =o O(h)"
  apply (erule bigo_lesseq1)
  apply (rule allI)
  apply (subst abs_of_nonneg)
   apply (erule spec)+
  done

lemma bigo_lesso1: "\<forall>x. f x \<le> g x \<Longrightarrow> f <o g =o O(h)"
  apply (unfold lesso_def)
  apply (subgoal_tac "(\<lambda>x. max (f x - g x) 0) = 0")
   apply (erule ssubst)
   apply (rule bigo_zero)
  apply (unfold func_zero)
  apply (rule ext)
  apply (simp split: split_max)
  done

lemma bigo_lesso2: "f =o g +o O(h) \<Longrightarrow> \<forall>x. 0 \<le> k x \<Longrightarrow> \<forall>x. k x \<le> f x \<Longrightarrow> k <o g =o O(h)"
  apply (unfold lesso_def)
  apply (rule bigo_lesseq4)
    apply (erule set_plus_imp_minus)
   apply (rule allI)
   apply (rule max.cobounded2)
  apply (rule allI)
  apply (subst fun_diff_def)
  apply (case_tac "0 \<le> k x - g x")
   apply simp
   apply (subst abs_of_nonneg)
    apply (drule_tac x = x in spec) back
    apply (simp add: algebra_simps)
   apply (subst diff_conv_add_uminus)+
   apply (rule add_right_mono)
   apply (erule spec)
  apply (rule order_trans)
   prefer 2
   apply (rule abs_ge_zero)
  apply (simp add: algebra_simps)
  done

lemma bigo_lesso3: "f =o g +o O(h) \<Longrightarrow> \<forall>x. 0 \<le> k x \<Longrightarrow> \<forall>x. g x \<le> k x \<Longrightarrow> f <o k =o O(h)"
  apply (unfold lesso_def)
  apply (rule bigo_lesseq4)
    apply (erule set_plus_imp_minus)
   apply (rule allI)
   apply (rule max.cobounded2)
  apply (rule allI)
  apply (subst fun_diff_def)
  apply (case_tac "0 \<le> f x - k x")
   apply simp
   apply (subst abs_of_nonneg)
    apply (drule_tac x = x in spec) back
    apply (simp add: algebra_simps)
   apply (subst diff_conv_add_uminus)+
   apply (rule add_left_mono)
   apply (rule le_imp_neg_le)
   apply (erule spec)
  apply (rule order_trans)
   prefer 2
   apply (rule abs_ge_zero)
  apply (simp add: algebra_simps)
  done

lemma bigo_lesso4: "f <o g =o O(k) \<Longrightarrow> g =o h +o O(k) \<Longrightarrow> f <o h =o O(k)"
  for k :: "'a \<Rightarrow> 'b::linordered_field"
  apply (unfold lesso_def)
  apply (drule set_plus_imp_minus)
  apply (drule bigo_abs5) back
  apply (simp add: fun_diff_def)
  apply (drule bigo_useful_add)
   apply assumption
  apply (erule bigo_lesseq2) back
  apply (rule allI)
  apply (auto simp add: func_plus fun_diff_def algebra_simps split: split_max abs_split)
  done

lemma bigo_lesso5: "f <o g =o O(h) \<Longrightarrow> \<exists>C. \<forall>x. f x \<le> g x + C * \<bar>h x\<bar>"
  apply (simp only: lesso_def bigo_alt_def)
  apply clarsimp
  apply (rule_tac x = c in exI)
  apply (rule allI)
  apply (drule_tac x = x in spec)
  apply (subgoal_tac "\<bar>max (f x - g x) 0\<bar> = max (f x - g x) 0")
   apply (clarsimp simp add: algebra_simps)
  apply (rule abs_of_nonneg)
  apply (rule max.cobounded2)
  done

lemma lesso_add: "f <o g =o O(h) \<Longrightarrow> k <o l =o O(h) \<Longrightarrow> (f + k) <o (g + l) =o O(h)"
  apply (unfold lesso_def)
  apply (rule bigo_lesseq3)
    apply (erule bigo_useful_add)
    apply assumption
   apply (force split: split_max)
  apply (auto split: split_max simp add: func_plus)
  done

lemma bigo_LIMSEQ1: "f =o O(g) \<Longrightarrow> g \<longlonglongrightarrow> 0 \<Longrightarrow> f \<longlonglongrightarrow> 0"
  for f g :: "nat \<Rightarrow> real"
  apply (simp add: LIMSEQ_iff bigo_alt_def)
  apply clarify
  apply (drule_tac x = "r / c" in spec)
  apply (drule mp)
   apply simp
  apply clarify
  apply (rule_tac x = no in exI)
  apply (rule allI)
  apply (drule_tac x = n in spec)+
  apply (rule impI)
  apply (drule mp)
   apply assumption
  apply (rule order_le_less_trans)
   apply assumption
  apply (rule order_less_le_trans)
   apply (subgoal_tac "c * \<bar>g n\<bar> < c * (r / c)")
    apply assumption
   apply (erule mult_strict_left_mono)
   apply assumption
  apply simp
  done

lemma bigo_LIMSEQ2: "f =o g +o O(h) \<Longrightarrow> h \<longlonglongrightarrow> 0 \<Longrightarrow> f \<longlonglongrightarrow> a \<Longrightarrow> g \<longlonglongrightarrow> a"
  for f g h :: "nat \<Rightarrow> real"
  apply (drule set_plus_imp_minus)
  apply (drule bigo_LIMSEQ1)
   apply assumption
  apply (simp only: fun_diff_def)
  apply (erule Lim_transform2)
  apply assumption
  done

end


section \<open>Arithmetic Expressions\<close>
text\<open>
This theory defines a language of arithmetic expressions over variables and literal values. Here,
values are limited to integers and strings. Variables may be either inputs or registers. We also
limit ourselves to a simple arithmetic of addition, subtraction, and multiplication as a proof of
concept.
\<close>

theory AExp
  imports Value_Lexorder VName FinFun.FinFun "HOL-Library.Option_ord"
begin

declare One_nat_def [simp del]
unbundle finfun_syntax

type_synonym registers = "nat \<Rightarrow>f value option"
type_synonym 'a datastate = "'a \<Rightarrow> value option"

text_raw\<open>\snip{aexptype}{1}{2}{%\<close>
datatype 'a aexp = L "value" | V 'a | Plus "'a aexp" "'a aexp" | Minus "'a aexp" "'a aexp" | Times "'a aexp" "'a aexp"
text_raw\<open>}%endsnip\<close>

fun is_lit :: "'a aexp \<Rightarrow> bool" where
  "is_lit (L _) = True" |
  "is_lit _ = False"

lemma aexp_induct_separate_V_cases  [case_names L I R Plus Minus Times]:
  "(\<And>x. P (L x)) \<Longrightarrow>
   (\<And>x. P (V (I x))) \<Longrightarrow>
   (\<And>x. P (V (R x))) \<Longrightarrow>
   (\<And>x1a x2a. P x1a \<Longrightarrow> P x2a \<Longrightarrow> P (Plus x1a x2a)) \<Longrightarrow>
   (\<And>x1a x2a. P x1a \<Longrightarrow> P x2a \<Longrightarrow> P (Minus x1a x2a)) \<Longrightarrow>
   (\<And>x1a x2a. P x1a \<Longrightarrow> P x2a \<Longrightarrow> P (Times x1a x2a)) \<Longrightarrow>
   P a"
  by (metis aexp.induct vname.exhaust)

fun aval :: "'a aexp \<Rightarrow> 'a datastate \<Rightarrow> value option" where
  "aval (L x) s = Some x" |
  "aval (V x) s = s x" |
  "aval (Plus a1 a2) s = value_plus (aval a1 s)(aval a2 s)" |
  "aval (Minus a1 a2) s = value_minus (aval a1 s) (aval a2 s)" |
  "aval (Times a1 a2) s = value_times (aval a1 s) (aval a2 s)"

lemma aval_plus_symmetry: "aval (Plus x y) s = aval (Plus y x) s"
  by (simp add: value_plus_symmetry)

text \<open>A little syntax magic to write larger states compactly:\<close>
definition null_state ("<>") where
  "null_state \<equiv> (K$ bot)"

no_notation finfun_update ("_'(_ $:= _')" [1000, 0, 0] 1000)
nonterminal fupdbinds and fupdbind

syntax
  "_fupdbind" :: "'a \<Rightarrow> 'a \<Rightarrow> fupdbind"             ("(2_ $:=/ _)")
  ""         :: "fupdbind \<Rightarrow> fupdbinds"             ("_")
  "_fupdbinds":: "fupdbind \<Rightarrow> fupdbinds \<Rightarrow> fupdbinds" ("_,/ _")
  "_fUpdate"  :: "'a \<Rightarrow> fupdbinds \<Rightarrow> 'a"            ("_/'((_)')" [1000, 0] 900)
  "_State" :: "fupdbinds => 'a" ("<_>")

translations
  "_fUpdate f (_fupdbinds b bs)" \<rightleftharpoons> "_fUpdate (_fUpdate f b) bs"
  "f(x$:=y)" \<rightleftharpoons> "CONST finfun_update f x y"
  "_State ms" == "_fUpdate <> ms"
  "_State (_updbinds b bs)" <= "_fUpdate (_State b) bs"

lemma empty_None: "<> = (K$ None)"
  by (simp add: null_state_def bot_option_def)

lemma apply_empty_None [simp]: "<> $ x2 = None"
  by (simp add: null_state_def bot_option_def)

definition input2state :: "value list \<Rightarrow> registers" where
  "input2state n = fold (\<lambda>(k, v) f. f(k $:= Some v)) (enumerate 0 n) (K$ None)"

primrec input2state_prim :: "value list \<Rightarrow> nat \<Rightarrow> registers" where
  "input2state_prim [] _ = (K$ None)" |
  "input2state_prim (v#t) k = (input2state_prim t (k+1))(k $:= Some v)"

lemma input2state_append:
  "input2state (i @ [a]) = (input2state i)(length i $:= Some a)"
  apply (simp add: eq_finfun_All_ext finfun_All_def finfun_All_except_def)
  apply clarify
  by (simp add: input2state_def enumerate_eq_zip)

lemma input2state_out_of_bounds:
  "i \<ge> length ia \<Longrightarrow> input2state ia $ i = None"
proof(induct ia rule: rev_induct)
  case Nil
  then show ?case
    by (simp add: input2state_def)
next
  case (snoc a as)
  then show ?case
    by (simp add: input2state_def enumerate_eq_zip)
qed

lemma input2state_within_bounds:
  "input2state i $ x = Some a \<Longrightarrow> x < length i"
  by (metis input2state_out_of_bounds not_le_imp_less option.distinct(1))

lemma input2state_empty: "input2state [] $ x1 = None"
  by (simp add: input2state_out_of_bounds)

lemma input2state_some:
  "i < length ia \<Longrightarrow>
   ia ! i = x \<Longrightarrow>
   input2state ia $ i = Some x"
  by (simp add: input2state_nth)

lemma input2state_take: "x1 < A \<Longrightarrow>
   A \<le> length i \<Longrightarrow>
   x = vname.I x1 \<Longrightarrow>
   input2state i $ x1 = input2state (take A i) $ x1"
proof(induct i)
  case Nil
  then show ?case
    by simp
next
  case (Cons a i)
  then show ?case
    by (simp add: input2state_nth)
qed

lemma input2state_not_None:
  "(input2state i $ x \<noteq> None) \<Longrightarrow> (x < length i)"
  using input2state_within_bounds by blast

lemma input2state_Some:
  "(\<exists>v. input2state i $ x = Some v) = (x < length i)"
  apply standard
  using input2state_within_bounds apply blast
  by (simp add: input2state_nth)

lemma input2state_cons: "x1 > 0 \<Longrightarrow>
   x1 < length ia \<Longrightarrow>
   input2state (a # ia) $ x1 = input2state ia $ (x1-1)"
  by (simp add: input2state_nth)

lemma input2state_cons_shift:
  "input2state i $ x1 = Some a \<Longrightarrow> input2state (b # i) $ (Suc x1) = Some a"
proof(induct i rule: rev_induct)
  case Nil
  then show ?case
    by (simp add: input2state_def)
next
  case (snoc x xs)
  then show ?case
    using input2state_within_bounds[of xs x1 a]
    using input2state_cons[of "Suc x1" "xs @ [x]" b]
    apply simp
    apply (case_tac "x1 < length xs")
     apply simp
    by (metis finfun_upd_apply input2state_append input2state_nth length_Cons length_append_singleton lessI list.sel(3) nth_tl)
qed

lemma input2state_exists: "\<exists>i. input2state i $ x1 = Some a"
proof(induct x1)
  case 0
  then show ?case
    apply (rule_tac x="[a]" in exI)
    by (simp add: input2state_def)
next
  case (Suc x1)
  then show ?case
    apply clarify
    apply (rule_tac x="a#i" in exI)
    by (simp add: input2state_cons_shift)
qed

primrec repeat :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "repeat 0 _ = []" |
  "repeat (Suc m) a = a#(repeat m a)"

lemma length_repeat: "length (repeat n a) = n"
proof(induct n)
  case 0
  then show ?case
    by simp
next
  case (Suc a)
  then show ?case
    by simp
qed

lemma length_append_repeat: "length (i@(repeat a y)) \<ge> length i"
  by simp

lemma length_input2state_repeat:
  "input2state i $ x = Some a \<Longrightarrow> y < length (i @ repeat y a)"
  by (metis append.simps(1) append_eq_append_conv input2state_within_bounds length_append length_repeat list.size(3) neqE not_add_less2 zero_order(3))

lemma input2state_double_exists:
  "\<exists>i. input2state i $ x = Some a \<and> input2state i $ y = Some a"
  apply (insert input2state_exists[of x a])
  apply clarify
  apply (case_tac "x \<ge> y")
  apply (rule_tac x="list_update i y a" in exI)
  apply (metis (no_types, lifting) input2state_within_bounds input2state_nth input2state_out_of_bounds le_trans length_list_update not_le_imp_less nth_list_update_eq nth_list_update_neq)
  apply (rule_tac x="list_update (i@(repeat y a)) y a" in exI)
  apply (simp add: not_le)
  by (metis length_input2state_repeat input2state_nth input2state_out_of_bounds le_trans length_append_repeat length_list_update not_le_imp_less nth_append nth_list_update_eq nth_list_update_neq option.distinct(1))

lemma input2state_double_exists_2:
  "x \<noteq> y \<Longrightarrow> \<exists>i. input2state i $ x = Some a \<and> input2state i $ y = Some a'"
  apply (insert input2state_exists[of x a])
  apply clarify
  apply (case_tac "x \<ge> y")
  apply (rule_tac x="list_update i y a'" in exI)
  apply (metis (no_types, lifting) input2state_within_bounds input2state_nth input2state_out_of_bounds le_trans length_list_update not_le_imp_less nth_list_update_eq nth_list_update_neq)
  apply (rule_tac x="list_update (i@(repeat y a')) y a'" in exI)
  apply (simp add: not_le)
  apply standard
  apply (metis input2state_nth input2state_within_bounds le_trans length_append_repeat length_list_update linorder_not_le nth_append nth_list_update_neq order_refl)
  by (metis input2state_nth length_append length_input2state_repeat length_list_update length_repeat nth_list_update_eq)

definition join_ir :: "value list \<Rightarrow> registers \<Rightarrow> vname datastate" where
  "join_ir i r \<equiv> (\<lambda>x. case x of
    R n \<Rightarrow> r $ n |
    I n \<Rightarrow> (input2state i) $ n
  )"

lemmas datastate = join_ir_def input2state_def

lemma join_ir_empty [simp]: "join_ir [] <> = (\<lambda>x. None)"
  apply (rule ext)
  apply (simp add: join_ir_def)
  apply (case_tac x)
   apply (simp add: input2state_def)
  by (simp add: empty_None)

lemma join_ir_R [simp]: "(join_ir i r) (R n) = r $ n"
  by (simp add: join_ir_def)

lemma join_ir_double_exists:
  "\<exists>i r. join_ir i r v = Some a \<and> join_ir i r v' = Some a"
proof(cases v)
  case (I x1)
  then show ?thesis
    apply (simp add: join_ir_def)
    apply (cases v')
     apply (simp add: input2state_double_exists input2state_exists)
    using input2state_exists by auto
next
  case (R x2)
  then show ?thesis
    apply (simp add: join_ir_def)
    apply (cases v')
    using input2state_exists apply force
    using input2state_double_exists by fastforce
qed

lemma join_ir_double_exists_2:
  "v \<noteq> v' \<Longrightarrow> \<exists>i r. join_ir i r v = Some a \<and> join_ir i r v' = Some a'"
proof(cases v)
  case (I x1)
  assume "v \<noteq> v'"
  then show ?thesis using I input2state_exists
    by (cases v', auto simp add: join_ir_def input2state_double_exists_2)
next
  case (R x2)
  assume "v \<noteq> v'"
  then show ?thesis
    apply (simp add: join_ir_def)
    apply (cases v')
     apply simp
    using R input2state_exists apply auto[1]
    apply (simp add: R)
    apply (rule_tac x="<x2 $:= Some a,x2a $:= Some a'>" in exI)
    by simp
qed

lemma exists_join_ir_ext: "\<exists>i r. join_ir i r v = s v"
  apply (simp add: join_ir_def)
  apply (case_tac "s v")
   apply (cases v)
    apply (rule_tac x="[]" in exI)
    apply (simp add: input2state_out_of_bounds)
   apply simp
   apply (rule_tac x="<>" in exI)
   apply simp
  apply simp
  apply (cases v)
   apply simp
   apply (simp add: input2state_exists)
  apply simp
  apply (rule_tac x="<x2 $:= Some a>" in exI)
  apply simp
  done

lemma join_ir_nth [simp]:
  "i < length is \<Longrightarrow> join_ir is r (I i) = Some (is ! i)"
  by (simp add: join_ir_def input2state_nth)

fun aexp_constrains :: "'a aexp \<Rightarrow> 'a aexp \<Rightarrow> bool" where
  "aexp_constrains (L l) a = (L l = a)" |
  "aexp_constrains (V v) v' = (V v = v')" |
  "aexp_constrains (Plus a1 a2) v = ((Plus a1 a2) = v \<or> (Plus a1 a2) = v \<or> (aexp_constrains a1 v \<or> aexp_constrains a2 v))" |
  "aexp_constrains (Minus a1 a2) v = ((Minus a1 a2) = v \<or> (aexp_constrains a1 v \<or> aexp_constrains a2 v))" |
  "aexp_constrains (Times a1 a2) v = ((Times a1 a2) = v \<or> (aexp_constrains a1 v \<or> aexp_constrains a2 v))"

fun aexp_same_structure :: "'a aexp \<Rightarrow> 'a aexp \<Rightarrow> bool" where
  "aexp_same_structure (L v) (L v') = True" |
  "aexp_same_structure (V v) (V v') = True" |
  "aexp_same_structure (Plus a1 a2) (Plus a1' a2') = (aexp_same_structure a1 a1' \<and> aexp_same_structure a2 a2')" |
  "aexp_same_structure (Minus a1 a2) (Minus a1' a2') = (aexp_same_structure a1 a1' \<and> aexp_same_structure a2 a2')" |
  "aexp_same_structure _ _ = False"

fun enumerate_aexp_inputs :: "vname aexp \<Rightarrow> nat set" where
  "enumerate_aexp_inputs (L _) = {}" |
  "enumerate_aexp_inputs (V (I n)) = {n}" |
  "enumerate_aexp_inputs (V (R n)) = {}" |
  "enumerate_aexp_inputs (Plus v va) = enumerate_aexp_inputs v \<union> enumerate_aexp_inputs va" |
  "enumerate_aexp_inputs (Minus v va) = enumerate_aexp_inputs v \<union> enumerate_aexp_inputs va" |
  "enumerate_aexp_inputs (Times v va) = enumerate_aexp_inputs v \<union> enumerate_aexp_inputs va"

lemma enumerate_aexp_inputs_list: "\<exists>l. enumerate_aexp_inputs a = set l"
proof(induct a)
  case (L x)
  then show ?case
    by simp
next
  case (V x)
  then show ?case
    apply (cases x)
     apply (metis empty_set enumerate_aexp_inputs.simps(2) list.simps(15))
    by simp
next
  case (Plus a1 a2)
  then show ?case
    by (metis enumerate_aexp_inputs.simps(4) set_append)
next
  case (Minus a1 a2)
  then show ?case
    by (metis enumerate_aexp_inputs.simps(5) set_append)
next
  case (Times a1 a2)
  then show ?case
    by (metis enumerate_aexp_inputs.simps(6) set_append)
qed

fun enumerate_regs :: "vname aexp \<Rightarrow> nat set" where
  "enumerate_regs (L _) = {}" |
  "enumerate_regs (V (R n)) = {n}" |
  "enumerate_regs (V (I _)) = {}" |
  "enumerate_regs (Plus v va) = enumerate_regs v \<union> enumerate_regs va" |
  "enumerate_regs (Minus v va) = enumerate_regs v \<union> enumerate_regs va" |
  "enumerate_regs (Times v va) = enumerate_regs v \<union> enumerate_regs va"

lemma finite_enumerate_regs: "finite (enumerate_regs a)"
  by(induct a rule: aexp_induct_separate_V_cases, auto)

lemma no_variables_aval: "enumerate_aexp_inputs a = {} \<Longrightarrow>
   enumerate_regs a = {} \<Longrightarrow>
   aval a s = aval a s'"
  by (induct a rule: aexp_induct_separate_V_cases, auto)

lemma enumerate_aexp_inputs_not_empty:
  "(enumerate_aexp_inputs a \<noteq> {}) = (\<exists>b c. enumerate_aexp_inputs a = set (b#c))"
  using enumerate_aexp_inputs_list by fastforce

lemma aval_ir_take: "A \<le> length i \<Longrightarrow>
  enumerate_regs a = {} \<Longrightarrow>
  enumerate_aexp_inputs a \<noteq> {} \<Longrightarrow>
  Max (enumerate_aexp_inputs a) < A \<Longrightarrow>
  aval a (join_ir (take A i) r) = aval a (join_ir i ra)"
proof(induct a)
  case (L x)
  then show ?case
    by simp
next
  case (V x)
  then show ?case
    apply (cases x)
     apply (simp add: join_ir_def input2state_nth)
    by simp
next
  case (Plus a1 a2)
  then show ?case
    apply (simp only: enumerate_aexp_inputs_not_empty[of "Plus a1 a2"])
    apply (erule exE)+
    apply (simp only: neq_Nil_conv List.linorder_class.Max.set_eq_fold)
    apply (case_tac "fold max c b \<le> length i")
     apply simp
     apply (metis List.finite_set Max.union Plus.prems(4) enumerate_aexp_inputs.simps(4) enumerate_aexp_inputs_not_empty max_less_iff_conj no_variables_aval sup_bot.left_neutral sup_bot.right_neutral)
    by simp
next
  case (Minus a1 a2)
  then show ?case
    apply (simp only: enumerate_aexp_inputs_not_empty[of "Minus a1 a2"])
    apply (erule exE)+
    apply (simp only: neq_Nil_conv List.linorder_class.Max.set_eq_fold)
    apply (case_tac "fold max c b \<le> length i")
     apply simp
    apply (metis List.finite_set Max.union Minus.prems(4) enumerate_aexp_inputs.simps(5) enumerate_aexp_inputs_not_empty max_less_iff_conj no_variables_aval sup_bot.left_neutral sup_bot.right_neutral)
    by simp
next
  case (Times a1 a2)
  then show ?case
    apply (simp only: enumerate_aexp_inputs_not_empty[of "Times a1 a2"])
    apply (erule exE)+
    apply (simp only: neq_Nil_conv List.linorder_class.Max.set_eq_fold)
    apply (case_tac "fold max c b \<le> length i")
     apply simp
    apply (metis List.finite_set Max.union Times.prems(4) enumerate_aexp_inputs.simps(6) enumerate_aexp_inputs_not_empty max_less_iff_conj no_variables_aval sup_bot.left_neutral sup_bot.right_neutral)
    by simp
qed

definition max_input :: "vname aexp \<Rightarrow> nat option" where
  "max_input g = (let inputs = (enumerate_aexp_inputs g) in if inputs = {} then None else Some (Max inputs))"

definition max_reg :: "vname aexp \<Rightarrow> nat option" where
  "max_reg g = (let regs = (enumerate_regs g) in if regs = {} then None else Some (Max regs))"

lemma max_reg_V_I: "max_reg (V (I n)) = None"
  by (simp add: max_reg_def)

lemma max_reg_V_R: "max_reg (V (R n)) = Some n"
  by (simp add: max_reg_def)

lemmas max_reg_V = max_reg_V_I max_reg_V_R

lemma max_reg_Plus: "max_reg (Plus a1 a2) = max (max_reg a1) (max_reg a2)"
  apply (simp add: max_reg_def Let_def max_absorb2)
  by (metis Max.union bot_option_def finite_enumerate_regs max_bot2 sup_Some sup_max)

lemma max_reg_Minus: "max_reg (Minus a1 a2) = max (max_reg a1) (max_reg a2)"
  apply (simp add: max_reg_def Let_def max_absorb2)
  by (metis Max.union bot_option_def finite_enumerate_regs max_bot2 sup_Some sup_max)

lemma max_reg_Times: "max_reg (Times a1 a2) = max (max_reg a1) (max_reg a2)"
  apply (simp add: max_reg_def Let_def max_absorb2)
  by (metis Max.union bot_option_def finite_enumerate_regs max_bot2 sup_Some sup_max)

lemma no_reg_aval_swap_regs:
  "max_reg a = None \<Longrightarrow> aval a (join_ir i r) = aval a (join_ir i r')"
proof(induct a)
  case (V x)
  then show ?case
    apply (cases x)
     apply (simp add: join_ir_def)
    by (simp add: join_ir_def max_reg_def)
next
  case (Plus a1 a2)
  then show ?case
    by (metis (no_types, lifting) aval.simps(3) max.absorb2 max.cobounded2 max_reg_Plus sup_None_2 sup_max)
next
  case (Minus a1 a2)
  then show ?case
    by (metis (no_types, lifting) aval.simps(4) max.cobounded2 max_def_raw max_reg_Minus sup_None_2 sup_max)
next
  case (Times a1 a2)
  then show ?case
  proof -
    have "bot = max_reg a2"
      by (metis (no_types) Times.prems bot_option_def max.left_commute max_bot2 max_def_raw max_reg_Times)
    then show ?thesis
      by (metis Times.hyps(1) Times.hyps(2) Times.prems aval.simps(5) bot_option_def max_bot2 max_reg_Times)
  qed
qed auto

lemma aval_reg_some_superset:
"\<forall>a. (r $ a  \<noteq> None) \<longrightarrow> r $ a = r' $ a \<Longrightarrow>
 aval a (join_ir i r) = Some v \<Longrightarrow>
 aval a (join_ir i r') = Some v"
proof(induct a arbitrary: v rule: aexp_induct_separate_V_cases)
  case (I x)
  then show ?case
    by (simp add: join_ir_def)
next
  case (Plus x1a x2a)
  then show ?case
    apply simp
    by (metis maybe_arith_int_not_None option.simps(3) value_plus_def)
next
  case (Minus x1a x2a)
  then show ?case
    apply simp
    by (metis maybe_arith_int_not_None option.simps(3) value_minus_def)
next
  case (Times x1a x2a)
  then show ?case
    apply simp
    by (metis maybe_arith_int_not_None option.simps(3) value_times_def)
qed auto

lemma aval_reg_none_superset:
"\<forall>a. (r $ a  \<noteq> None) \<longrightarrow> r $ a = r' $ a \<Longrightarrow>
 aval a (join_ir i r') = None \<Longrightarrow>
 aval a (join_ir i r) = None"
proof(induct a)
  case (V x)
  then show ?case
    apply (cases x)
     apply (simp add: join_ir_def)
    by auto
next
  case (Plus a1 a2)
  then show ?case
    apply simp
    by (metis (no_types, lifting) maybe_arith_int_None Plus.prems(1) aval_reg_some_superset value_plus_def)
next
  case (Minus a1 a2)
  then show ?case
    apply simp
    by (metis (no_types, lifting) maybe_arith_int_None Minus.prems(1) aval_reg_some_superset value_minus_def)
next
  case (Times a1 a2)
  then show ?case
    apply simp
    by (metis (no_types, lifting) maybe_arith_int_None Times.prems(1) aval_reg_some_superset value_times_def)
qed auto

lemma enumerate_regs_empty_reg_unconstrained:
  "enumerate_regs a = {} \<Longrightarrow> \<forall>r. \<not> aexp_constrains a (V (R r))"
  by (induct a rule: aexp_induct_separate_V_cases, auto)

lemma enumerate_aexp_inputs_empty_input_unconstrained:
  "enumerate_aexp_inputs a = {} \<Longrightarrow> \<forall>r. \<not> aexp_constrains a (V (I r))"
  by (induct a rule: aexp_induct_separate_V_cases, auto)

lemma input_unconstrained_aval_input_swap:
  "\<forall>i. \<not> aexp_constrains a (V (I i)) \<Longrightarrow>
   aval a (join_ir i r) = aval a (join_ir i' r)"
  using join_ir_def
  by (induct a rule: aexp_induct_separate_V_cases, auto)

lemma input_unconstrained_aval_register_swap:
  "\<forall>i. \<not> aexp_constrains a (V (R i)) \<Longrightarrow>
   aval a (join_ir i r) = aval a (join_ir i r')"
  using join_ir_def
  by (induct a rule: aexp_induct_separate_V_cases, auto)

lemma unconstrained_variable_swap_aval:
  "\<forall>i. \<not> aexp_constrains a (V (I i)) \<Longrightarrow>
   \<forall>r. \<not> aexp_constrains a (V (R r)) \<Longrightarrow>
   aval a s = aval a s'"
  by (induct a rule: aexp_induct_separate_V_cases, auto)

lemma max_input_I: "max_input (V (vname.I i)) = Some i"
  by (simp add: max_input_def)

lemma max_input_Plus:
  "max_input (Plus a1 a2) = max (max_input a1) (max_input a2)"
  apply (simp add: max_input_def Let_def max.commute max_absorb2)
  by (metis List.finite_set Max.union enumerate_aexp_inputs_list sup_Some sup_max)

lemma max_input_Minus:
  "max_input (Minus a1 a2) = max (max_input a1) (max_input a2)"
  apply (simp add: max_input_def Let_def max.commute max_absorb2)
  by (metis List.finite_set Max.union enumerate_aexp_inputs_list sup_Some sup_max)

lemma max_input_Times:
  "max_input (Times a1 a2) = max (max_input a1) (max_input a2)"
  apply (simp add: max_input_def Let_def max.commute max_absorb2)
  by (metis List.finite_set Max.union enumerate_aexp_inputs_list sup_Some sup_max)

lemma aval_take:
  "max_input x < Some a \<Longrightarrow>
   aval x (join_ir i r) = aval x (join_ir (take a i) r)"
proof(induct x rule: aexp_induct_separate_V_cases)
  case (I x)
  then show ?case
    by (metis aval.simps(2) input2state_take join_ir_def le_cases less_option_Some max_input_I take_all vname.simps(5))
next
  case (R x)
  then show ?case
    by (simp add: join_ir_def)
next
  case (Plus x1a x2a)
  then show ?case
    by (simp add: max_input_Plus)
next
  case (Minus x1a x2a)
  then show ?case
    by (simp add: max_input_Minus)
next
  case (Times x1a x2a)
  then show ?case
    by (simp add: max_input_Times)
qed auto

lemma aval_no_reg_swap_regs: "max_input x < Some a \<Longrightarrow>
   max_reg x = None \<Longrightarrow>
   aval x (join_ir i ra) = aval x (join_ir (take a i) r)"
proof(induct x)
  case (V x)
  then show ?case
    apply (cases x)
     apply (metis aval_take enumerate_regs.simps(3) enumerate_regs_empty_reg_unconstrained input_unconstrained_aval_register_swap)
    by (simp add: max_reg_def)
next
  case (Plus x1 x2)
  then show ?case
    by (metis aval_take no_reg_aval_swap_regs)
next
  case (Minus x1 x2)
  then show ?case
    by (metis aval_take no_reg_aval_swap_regs)
next
  case (Times x1 x2)
  then show ?case
    by (metis aval_take no_reg_aval_swap_regs)
qed auto

fun enumerate_aexp_strings :: "'a aexp \<Rightarrow> String.literal set" where
  "enumerate_aexp_strings (L (Str s)) = {s}" |
  "enumerate_aexp_strings (L (Num s)) = {}" |
  "enumerate_aexp_strings (V _) = {}" |
  "enumerate_aexp_strings (Plus a1 a2) = enumerate_aexp_strings a1 \<union> enumerate_aexp_strings a2" |
  "enumerate_aexp_strings (Minus a1 a2) = enumerate_aexp_strings a1 \<union> enumerate_aexp_strings a2" |
  "enumerate_aexp_strings (Times a1 a2) = enumerate_aexp_strings a1 \<union> enumerate_aexp_strings a2"

fun enumerate_aexp_ints :: "'a aexp \<Rightarrow> int set" where
  "enumerate_aexp_ints (L (Str s)) = {}" |
  "enumerate_aexp_ints (L (Num s)) = {s}" |
  "enumerate_aexp_ints (V _) = {}" |
  "enumerate_aexp_ints (Plus a1 a2) = enumerate_aexp_ints a1 \<union> enumerate_aexp_ints a2" |
  "enumerate_aexp_ints (Minus a1 a2) = enumerate_aexp_ints a1 \<union> enumerate_aexp_ints a2" |
  "enumerate_aexp_ints (Times a1 a2) = enumerate_aexp_ints a1 \<union> enumerate_aexp_ints a2"

definition enumerate_vars :: "vname aexp \<Rightarrow> vname set" where
  "enumerate_vars a = (image I (enumerate_aexp_inputs a)) \<union> (image R (enumerate_regs a))"

fun rename_regs :: "(nat \<Rightarrow> nat) \<Rightarrow> vname aexp \<Rightarrow> vname aexp" where
  "rename_regs _ (L l) = (L l)" |
  "rename_regs f (V (R r)) = (V (R (f r)))" |
  "rename_regs _ (V v) = (V v)" |
  "rename_regs f (Plus a b) = Plus (rename_regs f a) (rename_regs f b)" |
  "rename_regs f (Minus a b) = Minus (rename_regs f a) (rename_regs f b)" |
  "rename_regs f (Times a b) = Times (rename_regs f a) (rename_regs f b)"

definition eq_upto_rename :: "vname aexp \<Rightarrow> vname aexp \<Rightarrow> bool" where
  "eq_upto_rename a1 a2 = (\<exists>f. bij f \<and> rename_regs f a1 = a2)"

end


subsection \<open>Noar Pinkas OT\<close>

text\<open>Here we prove security for the Noar Pinkas OT from \cite{DBLP:conf/soda/NaorP01}.\<close>

theory Noar_Pinkas_OT imports
  Cyclic_Group_Ext
  Game_Based_Crypto.Diffie_Hellman
  OT_Functionalities
  Semi_Honest
  Uniform_Sampling
begin

locale np_base =
  fixes \<G> :: "'grp cyclic_group" (structure)
  assumes or_gt_0: "0 < order \<G>"
    and prime_order: "prime (order \<G>)"
begin

fun valid_inputs_np_ot12 where "valid_inputs_np_ot12 [M2 (m0,m1), C1 \<sigma>] = (m0 \<in> carrier \<G> \<and> m1 \<in> carrier \<G>)"

lemma prime_field: "a < (order \<G>) \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> coprime a (order \<G>)"
  by(metis dvd_imp_le neq0_conv not_le prime_imp_coprime prime_order coprime_commute)

lemma weight_sample_uniform_units: "weight_spmf (sample_uniform_units (order \<G>)) = 1"
  using  lossless_spmf_def lossless_sample_uniform_units prime_order  prime_gt_1_nat by auto

fun protocol :: "'grp inputs_ot12 list \<Rightarrow> ('grp outputs_ot12 list) spmf"
  where "protocol [M2 (m0,m1), C1 \<sigma>] = do {
    a :: nat \<leftarrow> sample_uniform (order \<G>);
    b :: nat \<leftarrow> sample_uniform (order \<G>);
    let c\<^sub>v = (a*b) mod (order \<G>);
    c\<^sub>v' :: nat \<leftarrow> sample_uniform (order \<G>);
    r0 :: nat \<leftarrow> sample_uniform_units (order \<G>);
    s0 :: nat \<leftarrow> sample_uniform_units (order \<G>);
    let w0 = (\<^bold>g [^] a) [^] s0 \<otimes> \<^bold>g [^] r0;
    let z0' = ((\<^bold>g [^] (if \<sigma> then c\<^sub>v' else c\<^sub>v)) [^] s0) \<otimes> ((\<^bold>g [^] b) [^] r0);
    r1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
    s1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
    let w1 = (\<^bold>g [^] a) [^] s1 \<otimes> \<^bold>g [^] r1;
    let z1' = ((\<^bold>g [^] ((if \<sigma> then c\<^sub>v else c\<^sub>v'))) [^] s1) \<otimes> ((\<^bold>g [^] b) [^] r1);
    let enc_m0 = z0' \<otimes> m0;
    let enc_m1 = z1' \<otimes> m1;
    let out_2 = (if \<sigma> then enc_m1 \<otimes> inv (w1 [^] b) else enc_m0 \<otimes> inv (w0 [^] b));
    return_spmf [U_ot12 (), P_ot12 out_2]}"

lemma lossless_protocol: "lossless_spmf (protocol [M2 (m0,m1), C1 \<sigma>])"
  apply(auto simp add: Let_def split_def lossless_sample_uniform_units or_gt_0)
  using prime_order prime_gt_1_nat lossless_sample_uniform_units by simp

type_synonym 'grp' view1 = "(('grp' \<times> 'grp' \<times> 'grp' \<times> 'grp')) spmf"

type_synonym 'grp' dist_adversary = "('grp' inputs_ot12 \<times> 'grp' \<times> 'grp' \<times> 'grp' \<times> 'grp') \<Rightarrow> bool spmf"

fun R1 :: "'grp inputs_ot12 list \<Rightarrow> 'grp view1"
  where "R1 [M2 (m0,m1), C1 \<sigma>] = do {
    a \<leftarrow> sample_uniform (order \<G>);
    b \<leftarrow> sample_uniform (order \<G>);
    let c\<^sub>\<sigma> = a*b;
    c\<^sub>\<sigma>' \<leftarrow> sample_uniform (order \<G>);
    return_spmf ((\<^bold>g [^] a, \<^bold>g [^] b, (if \<sigma> then \<^bold>g [^] c\<^sub>\<sigma>' else \<^bold>g [^] c\<^sub>\<sigma>), (if \<sigma> then \<^bold>g [^] c\<^sub>\<sigma> else \<^bold>g [^] c\<^sub>\<sigma>')))}"

fun inter :: "'grp inputs_ot12 \<Rightarrow> ('grp inputs_ot12 \<times> 'grp \<times> 'grp \<times> 'grp \<times> 'grp)  spmf"
  where "inter (M2 (m0,m1)) = do {
    a \<leftarrow> sample_uniform (order \<G>);
    b \<leftarrow> sample_uniform (order \<G>);
    c \<leftarrow> sample_uniform (order \<G>);
    d \<leftarrow> sample_uniform (order \<G>);
    return_spmf (M2 (m0,m1), \<^bold>g [^] a, \<^bold>g [^] b, \<^bold>g [^] c, \<^bold>g [^] d)}"

fun S1 :: "'grp inputs_ot12 \<Rightarrow> 'grp outputs_ot12 \<Rightarrow> 'grp view1"
  where "S1 (M2 (m0,m1)) (U_ot12 ()) = do {
    a \<leftarrow> sample_uniform (order \<G>);
    b \<leftarrow> sample_uniform (order \<G>);
    c \<leftarrow> sample_uniform (order \<G>);
    return_spmf ((\<^bold>g [^] a, \<^bold>g [^] b, \<^bold>g [^] c, \<^bold>g [^] (a*b)))}"

lemma lossless_S1: "lossless_spmf (S1 (M2 (m0,m1)) (U_ot12 ()))"
  by(simp add: Let_def lossless_sample_uniform_units or_gt_0)

fun R1_inter_adversary :: "'grp dist_adversary \<Rightarrow> 'grp inputs_ot12 \<Rightarrow> 'grp \<Rightarrow> 'grp \<Rightarrow> 'grp \<Rightarrow> bool spmf"
  where "R1_inter_adversary \<A> msgs \<alpha> \<beta> \<gamma> = do {
    c \<leftarrow> sample_uniform (order \<G>);
    \<A> (msgs, \<alpha>, \<beta>, \<gamma>, \<^bold>g [^] c)}"

fun inter_S1_adversary :: "'grp dist_adversary \<Rightarrow>  'grp inputs_ot12 \<Rightarrow> 'grp \<Rightarrow> 'grp \<Rightarrow> 'grp \<Rightarrow> bool spmf"
  where "inter_S1_adversary \<A> msgs \<alpha> \<beta> \<gamma> = do {
    c \<leftarrow> sample_uniform (order \<G>);
    \<A> (msgs, \<alpha>, \<beta>, \<^bold>g [^] c, \<gamma>)}"

sublocale ddh: ddh \<G> .

fun R2 :: " 'grp inputs_ot12 list \<Rightarrow> ('grp \<times> 'grp \<times>  'grp \<times> 'grp \<times> 'grp \<times> 'grp \<times> 'grp) spmf"
  where "R2 [M2 (m0,m1), C1 \<sigma>]  = do {
  a :: nat \<leftarrow> sample_uniform (order \<G>);
  b :: nat \<leftarrow> sample_uniform (order \<G>);
  let c\<^sub>v = (a*b) mod (order \<G>);
  c\<^sub>v' :: nat \<leftarrow> sample_uniform (order \<G>);
  r0 :: nat \<leftarrow> sample_uniform_units (order \<G>);
  s0 :: nat \<leftarrow> sample_uniform_units (order \<G>);
  let w0 = (\<^bold>g [^] a) [^] s0 \<otimes> \<^bold>g [^] r0;
  let z = ((\<^bold>g [^] c\<^sub>v') [^] s0) \<otimes> ((\<^bold>g [^] b) [^] r0);
  r1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
  s1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
  let w1 = (\<^bold>g [^] a) [^] s1 \<otimes> \<^bold>g [^] r1;
  let z' = ((\<^bold>g [^] (c\<^sub>v)) [^] s1) \<otimes> ((\<^bold>g [^] b) [^] r1);
  let enc_m = z \<otimes> (if \<sigma> then m0 else m1);
  let enc_m' = z' \<otimes> (if \<sigma> then m1 else m0) ;
  return_spmf(\<^bold>g [^] a, \<^bold>g [^] b, \<^bold>g [^] c\<^sub>v, w0, enc_m, w1, enc_m')}"

lemma lossless_R2: "lossless_spmf (R2 [M2 (m0,m1), C1 \<sigma>])"
  apply(simp add: Let_def split_def lossless_sample_uniform_units or_gt_0)
  using prime_order prime_gt_1_nat lossless_sample_uniform_units by simp

fun S2 :: "'grp inputs_ot12 \<Rightarrow> 'grp outputs_ot12 \<Rightarrow> ('grp \<times> 'grp \<times> 'grp \<times> 'grp \<times> 'grp \<times> 'grp \<times> 'grp) spmf"
  where "S2 (C1 \<sigma>) (P_ot12 m) =  do {
  a :: nat \<leftarrow> sample_uniform (order \<G>);
  b :: nat \<leftarrow> sample_uniform (order \<G>);
  let c\<^sub>v = (a*b) mod (order \<G>);
  r0 :: nat \<leftarrow> sample_uniform_units (order \<G>);
  s0 :: nat \<leftarrow> sample_uniform_units (order \<G>);
  let w0 = (\<^bold>g [^] a) [^] s0 \<otimes> \<^bold>g [^] r0;
  r1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
  s1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
  let w1 = (\<^bold>g [^] a) [^] s1 \<otimes> \<^bold>g [^] r1;
  let z' = ((\<^bold>g [^] (c\<^sub>v)) [^] s1) \<otimes> ((\<^bold>g [^] b) [^] r1);
  s' \<leftarrow> sample_uniform (order \<G>);
  let enc_m =  \<^bold>g [^] s';
  let enc_m' = z' \<otimes> m ;
  return_spmf(\<^bold>g [^] a, \<^bold>g [^] b, \<^bold>g [^] c\<^sub>v, w0, enc_m, w1, enc_m')}"

lemma lossless_S2: "lossless_spmf (S2 (C1 \<sigma>) (P_ot12 m))"
  apply(simp add: Let_def lossless_sample_uniform_units or_gt_0)
  using prime_order prime_gt_1_nat lossless_sample_uniform_units by simp

sublocale np_correct: semi_honest_det_correctness f_ot12 protocol valid_inputs_np_ot12 .

sublocale np_P1: semi_honest_det_security f_ot12 protocol valid_inputs_np_ot12 0 R1 S1 .

sublocale np_P2: semi_honest_det_security f_ot12 protocol valid_inputs_np_ot12 1 R2 S2 .

end

locale np = np_base + cyclic_group \<G>
begin

lemma protocol_inverse:
  assumes "m0 \<in> carrier \<G>" "m1 \<in> carrier \<G>"
  shows" ((\<^bold>g [^] ((a*b) mod (order \<G>))) [^] (s1 :: nat)) \<otimes> ((\<^bold>g [^] b) [^] (r1::nat)) \<otimes> (if v then m0 else m1) \<otimes> inv (((\<^bold>g [^] a) [^] s1 \<otimes> \<^bold>g [^] r1) [^] b)
        = (if v then m0 else m1)"
(is "?lhs = ?rhs")
proof-
  have  1: "(a*b)*(s1) + b*r1 =((a::nat)*(s1) + r1)*b " using mult.commute mult.assoc  add_mult_distrib by auto
  have "?lhs =
 ((\<^bold>g [^] (a*b)) [^] s1) \<otimes> ((\<^bold>g [^] b) [^] r1) \<otimes> (if v then m0 else m1) \<otimes> inv (((\<^bold>g [^] a) [^] s1 \<otimes> \<^bold>g [^] r1) [^] b)"
    by(simp add: pow_generator_mod)
  also have "... = (\<^bold>g [^] ((a*b)*(s1))) \<otimes> ((\<^bold>g [^] (b*r1))) \<otimes> ((if v then m0 else m1) \<otimes> inv (((\<^bold>g [^] ((a*(s1) + r1)*b)))))"
    by(auto simp add: nat_pow_pow nat_pow_mult assms cyclic_group_assoc)
  also have "... = \<^bold>g [^] ((a*b)*(s1)) \<otimes> \<^bold>g [^] (b*r1) \<otimes> ((inv (((\<^bold>g [^] ((a*(s1) + r1)*b))))) \<otimes> (if v then m0 else m1))"
    by(simp add: nat_pow_mult cyclic_group_commute assms)
  also have "... = (\<^bold>g [^] ((a*b)*(s1) + b*r1) \<otimes> inv (((\<^bold>g [^] ((a*(s1) + r1)*b))))) \<otimes> (if v then m0 else m1)"
    by(simp add: nat_pow_mult cyclic_group_assoc assms)
  also have "... = (\<^bold>g [^] ((a*b)*(s1) + b*r1) \<otimes> inv (((\<^bold>g [^] (((a*b)*(s1) + r1*b)))))) \<otimes> (if v then m0 else m1)"
    using 1 by (simp add: mult.commute)
  ultimately show ?thesis
    using l_cancel_inv assms  by (simp add: mult.commute)
qed

lemma correctness:
  assumes "m0 \<in> carrier \<G>" "m1 \<in> carrier \<G>"
  shows  "protocol [M2 (m0,m1), C1 \<sigma>] = return_spmf (f_ot12 [M2 (m0,m1), C1 \<sigma>])"
proof-
  have "protocol [M2 (m0,m1), C1 \<sigma>] = do {
    a :: nat \<leftarrow> sample_uniform (order \<G>);
    b :: nat \<leftarrow> sample_uniform (order \<G>);
    r1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
    s1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
    let out_2 = ((\<^bold>g [^] ((a*b) mod (order \<G>))) [^] s1) \<otimes> ((\<^bold>g [^] b) [^] r1) \<otimes> (if \<sigma> then m1 else m0) \<otimes> inv (((\<^bold>g [^] a) [^] s1 \<otimes> \<^bold>g [^] r1) [^] b);
    return_spmf [U_ot12 (), P_ot12 out_2]}"
    by(simp add: lossless_sample_uniform_units bind_spmf_const weight_sample_uniform_units or_gt_0)
  also have "... = do {
    let out_2 = (if \<sigma> then m1 else m0);
    return_spmf [U_ot12 (), P_ot12 out_2]}"
    by(simp add: protocol_inverse assms lossless_sample_uniform_units bind_spmf_const weight_sample_uniform_units or_gt_0)
  ultimately show ?thesis by(simp add: Let_def)
qed

theorem correct_np: "np_correct.correctness [M2 (m0,m1), C1 \<sigma>]"
  unfolding np_correct.correctness_def using correctness by simp

lemma security_P1:
  shows "np_P1.advantage [M2 (m0,m1), C1 \<sigma>] D
            \<le> ddh.advantage (R1_inter_adversary D (M2 (m0,m1)))
                + ddh.advantage (inter_S1_adversary D (M2 (m0,m1)))"
    (is "?lhs \<le> ?rhs")
proof(cases \<sigma>)
  case True
  have "R1 [M2 (m0,m1), C1 \<sigma>] = S1 (M2 (m0,m1)) (U_ot12 ())" for out1
    by(simp add: True)
  then have "np_P1.advantage [M2 (m0,m1), C1 \<sigma>] D = 0"
    by(simp add: np_P1.advantage_def  Let_def np_P1.real_view_def np_P1.ideal_view_def)
  also have "ddh.advantage A \<ge> 0" for A using ddh.advantage_def by simp
  ultimately show ?thesis by simp
next
  case False
  have bounded_advantage: "\<bar>(a :: real) - b\<bar> = e1 \<Longrightarrow> \<bar>b - c\<bar> = e2 \<Longrightarrow> \<bar>a - c\<bar> \<le> e1 + e2"
    for a b e1 c e2 by simp
  also have R1_inter_dist: "\<bar>spmf (np_P1.real_view [M2 (m0,m1), C1 False] \<bind> D) True - spmf ((inter (M2 (m0,m1))) \<bind> D) True\<bar> = ddh.advantage (R1_inter_adversary D (M2 (m0,m1)))"
    unfolding ddh.advantage_def ddh.ddh_0_def ddh.ddh_1_def Let_def split_def np_P1.real_view_def by simp
  also  have inter_S1_dist: "\<bar>spmf ((inter (M2 (m0,m1))) \<bind> D) True - spmf (np_P1.ideal_view (M2 (m0,m1)) (U_ot12 ()) \<bind> D) True\<bar> = ddh.advantage (inter_S1_adversary D (M2 (m0,m1)))"
    including monad_normalisation
    by(simp add: ddh.advantage_def ddh.ddh_0_def ddh.ddh_1_def np_P1.ideal_view_def)
  ultimately have "\<bar>spmf (np_P1.real_view [M2 (m0,m1), C1 False] \<bind> (\<lambda>view. D view)) True - spmf (np_P1.ideal_view (M2 (m0,m1)) (U_ot12 ()) \<bind> (\<lambda>view. D view)) True\<bar> \<le> ?rhs"
    using R1_inter_dist by auto
  thus ?thesis by(simp add: np_P1.advantage_def False)
qed

lemma add_mult_one_time_pad:
  assumes "s0 < order \<G>"
    and "s0 \<noteq> 0"
  shows "map_spmf (\<lambda> c\<^sub>v'. (((b* r0) + (s0 * c\<^sub>v')) mod(order \<G>))) (sample_uniform (order \<G>)) = sample_uniform (order \<G>)"
proof-
  have "gcd s0 (order \<G>) = 1"
    using assms prime_field by simp
  thus ?thesis
    using add_mult_one_time_pad by force
qed

lemma security_P2:
  assumes "m0 \<in> carrier \<G>" "m1 \<in> carrier \<G>"
  shows "R2 [M2 (m0,m1), C1 \<sigma>] = S2 (C1 \<sigma>) (if \<sigma> then (P_ot12 m1) else (P_ot12 m0))"
  including monad_normalisation
proof-
  have "R2 [M2 (m0,m1), C1 \<sigma>] = do {
      a :: nat \<leftarrow> sample_uniform (order \<G>);
      b :: nat \<leftarrow> sample_uniform (order \<G>);
      let c\<^sub>v = (a*b) mod (order \<G>);
      c\<^sub>v' :: nat \<leftarrow> sample_uniform (order \<G>);
      r0 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      s0 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      let w0 = (\<^bold>g [^] a) [^] s0 \<otimes> \<^bold>g [^] r0;
      let s' = (((b* r0) + ((c\<^sub>v')*(s0))) mod(order \<G>));
      let z = \<^bold>g [^] s' ;
      r1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      s1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      let w1 = (\<^bold>g [^] a) [^] s1 \<otimes> \<^bold>g [^] r1;
      let z' = ((\<^bold>g [^] (c\<^sub>v)) [^] s1) \<otimes> ((\<^bold>g [^] b) [^] r1);
      let enc_m = z \<otimes> (if \<sigma> then m0 else m1);
      let enc_m' = z' \<otimes> (if \<sigma> then m1 else m0) ;
      return_spmf(\<^bold>g [^] a, \<^bold>g [^] b, \<^bold>g [^] c\<^sub>v, w0, enc_m, w1, enc_m')}"
    by(simp add: nat_pow_pow nat_pow_mult pow_generator_mod add.commute)
  also have "... =  do {
      a :: nat \<leftarrow> sample_uniform (order \<G>);
      b :: nat \<leftarrow> sample_uniform (order \<G>);
      let c\<^sub>v = (a*b) mod (order \<G>);
      r0 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      s0 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      let w0 = (\<^bold>g [^] a) [^] s0 \<otimes> \<^bold>g [^] r0;
      s' \<leftarrow> map_spmf (\<lambda> c\<^sub>v'. (((b* r0) + ((c\<^sub>v')*(s0))) mod(order \<G>))) (sample_uniform (order \<G>));
      let z = \<^bold>g [^] s';
      r1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      s1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      let w1 = (\<^bold>g [^] a) [^] s1 \<otimes> \<^bold>g [^] r1;
      let z' = ((\<^bold>g [^] (c\<^sub>v)) [^] s1) \<otimes> ((\<^bold>g [^] b) [^] r1);
      let enc_m = z \<otimes> (if \<sigma> then m0 else m1);
      let enc_m' = z' \<otimes> (if \<sigma> then m1 else m0) ;
      return_spmf(\<^bold>g [^] a, \<^bold>g [^] b, \<^bold>g [^] c\<^sub>v, w0, enc_m, w1, enc_m')}"
    by(simp add: bind_map_spmf o_def Let_def)
  also have "... =  do {
      a :: nat \<leftarrow> sample_uniform (order \<G>);
      b :: nat \<leftarrow> sample_uniform (order \<G>);
      let c\<^sub>v = (a*b) mod (order \<G>);
      r0 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      s0 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      let w0 = (\<^bold>g [^] a) [^] s0 \<otimes> \<^bold>g [^] r0;
      s' \<leftarrow>  (sample_uniform (order \<G>));
      let z = \<^bold>g [^] s';
      r1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      s1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      let w1 = (\<^bold>g [^] a) [^] s1 \<otimes> \<^bold>g [^] r1;
      let z' = ((\<^bold>g [^] (c\<^sub>v)) [^] s1) \<otimes> ((\<^bold>g [^] b) [^] r1);
      let enc_m = z \<otimes> (if \<sigma> then m0 else m1);
      let enc_m' = z' \<otimes> (if \<sigma> then m1 else m0) ;
      return_spmf(\<^bold>g [^] a, \<^bold>g [^] b, \<^bold>g [^] c\<^sub>v, w0, enc_m, w1, enc_m')}"
    by(simp add: add_mult_one_time_pad Let_def mult.commute cong: bind_spmf_cong_simp)
  also have "... =  do {
      a :: nat \<leftarrow> sample_uniform (order \<G>);
      b :: nat \<leftarrow> sample_uniform (order \<G>);
      let c\<^sub>v = (a*b) mod (order \<G>);
      r0 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      s0 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      let w0 = (\<^bold>g [^] a) [^] s0 \<otimes> \<^bold>g [^] r0;
      r1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      s1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      let w1 = (\<^bold>g [^] a) [^] s1 \<otimes> \<^bold>g [^] r1;
      let z' = ((\<^bold>g [^] (c\<^sub>v)) [^] s1) \<otimes> ((\<^bold>g [^] b) [^] r1);
      enc_m \<leftarrow> map_spmf (\<lambda> s'.  \<^bold>g [^] s' \<otimes> (if \<sigma> then m0 else m1)) (sample_uniform (order \<G>));
      let enc_m' = z' \<otimes> (if \<sigma> then m1 else m0) ;
      return_spmf(\<^bold>g [^] a, \<^bold>g [^] b, \<^bold>g [^] c\<^sub>v, w0, enc_m, w1, enc_m')}"
    by(simp add: bind_map_spmf o_def Let_def)
  also have "... =  do {
      a :: nat \<leftarrow> sample_uniform (order \<G>);
      b :: nat \<leftarrow> sample_uniform (order \<G>);
      let c\<^sub>v = (a*b) mod (order \<G>);
      r0 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      s0 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      let w0 = (\<^bold>g [^] a) [^] s0 \<otimes> \<^bold>g [^] r0;
      r1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      s1 :: nat \<leftarrow> sample_uniform_units (order \<G>);
      let w1 = (\<^bold>g [^] a) [^] s1 \<otimes> \<^bold>g [^] r1;
      let z' = ((\<^bold>g [^] (c\<^sub>v)) [^] s1) \<otimes> ((\<^bold>g [^] b) [^] r1);
      enc_m \<leftarrow> map_spmf (\<lambda> s'.  \<^bold>g [^] s') (sample_uniform (order \<G>));
      let enc_m' = z' \<otimes> (if \<sigma> then m1 else m0) ;
      return_spmf(\<^bold>g [^] a, \<^bold>g [^] b, \<^bold>g [^] c\<^sub>v, w0, enc_m, w1, enc_m')}"
    by(simp add: sample_uniform_one_time_pad assms)
  ultimately show ?thesis by(simp add: Let_def bind_map_spmf o_def)
qed

theorem np_perfect_security_P2:
  shows "np_P2.perfect_security [M2 (m0,m1), C1 \<sigma>]"
  unfolding np_P2.perfect_security_def np_P2.real_view_def np_P2.ideal_view_def using security_P2 by auto

end

locale np_asymp =
  fixes \<G> :: "security \<Rightarrow> 'grp cyclic_group"
  assumes np: "\<And>\<eta>. np (\<G> \<eta>)"
begin

sublocale np "\<G> \<eta>" for \<eta> by(simp add: np)

theorem correctness_asymp:
  shows "np_correct.correctness \<eta> [M2 (m0,m1), C1 \<sigma>]"
  by(rule correct_np)

theorem security_P1_asymp:
  assumes "negligible (\<lambda> \<eta>. ddh.advantage \<eta> (inter_S1_adversary \<eta> D (M2 (m0,m1))))"
    and "negligible (\<lambda> \<eta>. ddh.advantage \<eta> (R1_inter_adversary \<eta>  D (M2 (m0,m1))))"
  shows "negligible (\<lambda> \<eta>. np_P1.advantage \<eta> [M2 (m0,m1), C1 \<sigma>] D)"
proof-
  have "np_P1.advantage \<eta> [M2 (m0,m1), C1 \<sigma>] D \<le> ddh.advantage \<eta> (R1_inter_adversary \<eta>  D (M2 (m0,m1))) + ddh.advantage \<eta> (inter_S1_adversary \<eta> D (M2 (m0,m1)))"
    for \<eta>
    using security_P1 by simp
  moreover have "negligible (\<lambda> \<eta>. ddh.advantage \<eta> (R1_inter_adversary \<eta>  D (M2 (m0,m1))) + ddh.advantage \<eta> (inter_S1_adversary \<eta> D (M2 (m0,m1))))"
    using assms
    by (simp add: negligible_plus)
  ultimately show ?thesis
    using negligible_le np_P1.advantage_def by auto
qed

theorem np_perfect_security_asymp:
  shows "np_P2.perfect_security \<eta> [M2 (m0,m1), C1 \<sigma>]"
  using np_perfect_security_P2 by simp

end

end


theory prop_10
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun rev :: "'a list => 'a list" where
  "rev (Nil2) = Nil2"
  | "rev (Cons2 y xs) = append (rev xs) (Cons2 y (Nil2))"
  (*hipster append rev *)

(*hipster rev*)
lemma lemma_a [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes rev.simps)

lemma lemma_aa [thy_expl]: "append (append x2 y2) z2 = append x2 (append y2 z2)"
by (hipster_induct_schemes rev.simps)

lemma lemma_ab [thy_expl]: "append (rev x5) (rev y5) = rev (append y5 x5)"
by (hipster_induct_schemes rev.simps)

lemma unknown [thy_expl]: "rev (rev x) = x"
oops

  theorem x0 :
    "(rev (rev x)) = x"
    by(hipster_induct_schemes rev.simps append.simps)
    (* by (tactic {* Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1 *})*)
end


theory sort_MSortTDPermutes
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

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

datatype Nat = Z | S "Nat"

fun ztake :: "int => 'a list => 'a list" where
"ztake x y =
   (if x = 0 then Nil2 else
      case y of
        | Nil2 => y
        | Cons2 z xs => Cons2 z (ztake (x - 1) xs)
      end)"

fun zlength :: "'a list => int" where
"zlength (Nil2) = 0"
| "zlength (Cons2 y xs) = 1 + (zlength xs)"

fun zdrop :: "int => 'a list => 'a list" where
"zdrop x y =
   (if x = 0 then y else
      case y of
        | Nil2 => y
        | Cons2 z xs => zdrop (x - 1) xs
      end)"

fun lmerge :: "int list => int list => int list" where
"lmerge (Nil2) y = y"
| "lmerge (Cons2 z x2) (Nil2) = Cons2 z x2"
| "lmerge (Cons2 z x2) (Cons2 x3 x4) =
     (if z <= x3 then Cons2 z (lmerge x2 (Cons2 x3 x4)) else
        Cons2 x3 (lmerge (Cons2 z x2) x4))"

fun msorttd :: "int list => int list" where
"msorttd (Nil2) = Nil2"
| "msorttd (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "msorttd (Cons2 y (Cons2 x2 x3)) =
     lmerge
       (msorttd
          (ztake
             (div (zlength (Cons2 y (Cons2 x2 x3))) 2) (Cons2 y (Cons2 x2 x3))))
       (msorttd
          (zdrop
             (div (zlength (Cons2 y (Cons2 x2 x3))) 2)
             (Cons2 y (Cons2 x2 x3))))"

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

(*hipster ztake zlength zdrop lmerge msorttd count *)

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

end


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

(*
  Author: Jeremy Dawson and Gerwin Klein, NICTA

  Consequences of type definition theorems, and of extended type definition.
*)

section \<open>Type Definition Theorems\<close>

theory Typedef_Morphisms
  imports Main "HOL-Library.Word" Bit_Comprehension Bits_Int
begin

subsection "More lemmas about normal type definitions"

lemma tdD1: "type_definition Rep Abs A \<Longrightarrow> \<forall>x. Rep x \<in> A"
  and tdD2: "type_definition Rep Abs A \<Longrightarrow> \<forall>x. Abs (Rep x) = x"
  and tdD3: "type_definition Rep Abs A \<Longrightarrow> \<forall>y. y \<in> A \<longrightarrow> Rep (Abs y) = y"
  by (auto simp: type_definition_def)

lemma td_nat_int: "type_definition int nat (Collect ((\<le>) 0))"
  unfolding type_definition_def by auto

context type_definition
begin

declare Rep [iff] Rep_inverse [simp] Rep_inject [simp]

lemma Abs_eqD: "Abs x = Abs y \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x = y"
  by (simp add: Abs_inject)

lemma Abs_inverse': "r \<in> A \<Longrightarrow> Abs r = a \<Longrightarrow> Rep a = r"
  by (safe elim!: Abs_inverse)

lemma Rep_comp_inverse: "Rep \<circ> f = g \<Longrightarrow> Abs \<circ> g = f"
  using Rep_inverse by auto

lemma Rep_eqD [elim!]: "Rep x = Rep y \<Longrightarrow> x = y"
  by simp

lemma Rep_inverse': "Rep a = r \<Longrightarrow> Abs r = a"
  by (safe intro!: Rep_inverse)

lemma comp_Abs_inverse: "f \<circ> Abs = g \<Longrightarrow> g \<circ> Rep = f"
  using Rep_inverse by auto

lemma set_Rep: "A = range Rep"
proof (rule set_eqI)
  show "x \<in> A \<longleftrightarrow> x \<in> range Rep" for x
    by (auto dest: Abs_inverse [of x, symmetric])
qed

lemma set_Rep_Abs: "A = range (Rep \<circ> Abs)"
proof (rule set_eqI)
  show "x \<in> A \<longleftrightarrow> x \<in> range (Rep \<circ> Abs)" for x
    by (auto dest: Abs_inverse [of x, symmetric])
qed

lemma Abs_inj_on: "inj_on Abs A"
  unfolding inj_on_def
  by (auto dest: Abs_inject [THEN iffD1])

lemma image: "Abs ` A = UNIV"
  by (fact Abs_image)

lemmas td_thm = type_definition_axioms

lemma fns1: "Rep \<circ> fa = fr \<circ> Rep \<or> fa \<circ> Abs = Abs \<circ> fr \<Longrightarrow> Abs \<circ> fr \<circ> Rep = fa"
  by (auto dest: Rep_comp_inverse elim: comp_Abs_inverse simp: o_assoc)

lemmas fns1a = disjI1 [THEN fns1]
lemmas fns1b = disjI2 [THEN fns1]

lemma fns4: "Rep \<circ> fa \<circ> Abs = fr \<Longrightarrow> Rep \<circ> fa = fr \<circ> Rep \<and> fa \<circ> Abs = Abs \<circ> fr"
  by auto

end

interpretation nat_int: type_definition int nat "Collect ((\<le>) 0)"
  by (rule td_nat_int)

declare
  nat_int.Rep_cases [cases del]
  nat_int.Abs_cases [cases del]
  nat_int.Rep_induct [induct del]
  nat_int.Abs_induct [induct del]

subsection "Extended form of type definition predicate"

lemma td_conds:
  "norm \<circ> norm = norm \<Longrightarrow>
    fr \<circ> norm = norm \<circ> fr \<longleftrightarrow> norm \<circ> fr \<circ> norm = fr \<circ> norm \<and> norm \<circ> fr \<circ> norm = norm \<circ> fr"
  apply safe
    apply (simp_all add: comp_assoc)
   apply (simp_all add: o_assoc)
  done

lemma fn_comm_power: "fa \<circ> tr = tr \<circ> fr \<Longrightarrow> fa ^^ n \<circ> tr = tr \<circ> fr ^^ n"
  apply (rule ext)
  apply (induct n)
   apply (auto dest: fun_cong)
  done

lemmas fn_comm_power' =
  ext [THEN fn_comm_power, THEN fun_cong, unfolded o_def]

locale td_ext = type_definition +
  fixes norm
  assumes eq_norm: "\<And>x. Rep (Abs x) = norm x"
begin

lemma Abs_norm [simp]: "Abs (norm x) = Abs x"
  using eq_norm [of x] by (auto elim: Rep_inverse')

lemma td_th: "g \<circ> Abs = f \<Longrightarrow> f (Rep x) = g x"
  by (drule comp_Abs_inverse [symmetric]) simp

lemma eq_norm': "Rep \<circ> Abs = norm"
  by (auto simp: eq_norm)

lemma norm_Rep [simp]: "norm (Rep x) = Rep x"
  by (auto simp: eq_norm' intro: td_th)

lemmas td = td_thm

lemma set_iff_norm: "w \<in> A \<longleftrightarrow> w = norm w"
  by (auto simp: set_Rep_Abs eq_norm' eq_norm [symmetric])

lemma inverse_norm: "Abs n = w \<longleftrightarrow> Rep w = norm n"
  apply (rule iffI)
   apply (clarsimp simp add: eq_norm)
  apply (simp add: eq_norm' [symmetric])
  done

lemma norm_eq_iff: "norm x = norm y \<longleftrightarrow> Abs x = Abs y"
  by (simp add: eq_norm' [symmetric])

lemma norm_comps:
  "Abs \<circ> norm = Abs"
  "norm \<circ> Rep = Rep"
  "norm \<circ> norm = norm"
  by (auto simp: eq_norm' [symmetric] o_def)

lemmas norm_norm [simp] = norm_comps

lemma fns5: "Rep \<circ> fa \<circ> Abs = fr \<Longrightarrow> fr \<circ> norm = fr \<and> norm \<circ> fr = fr"
  by (fold eq_norm') auto

text \<open>
  following give conditions for converses to \<open>td_fns1\<close>
  \<^item> the condition \<open>norm \<circ> fr \<circ> norm = fr \<circ> norm\<close> says that
    \<open>fr\<close> takes normalised arguments to normalised results
  \<^item> \<open>norm \<circ> fr \<circ> norm = norm \<circ> fr\<close> says that \<open>fr\<close>
    takes norm-equivalent arguments to norm-equivalent results
  \<^item> \<open>fr \<circ> norm = fr\<close> says that \<open>fr\<close>
    takes norm-equivalent arguments to the same result
  \<^item> \<open>norm \<circ> fr = fr\<close> says that \<open>fr\<close> takes any argument to a normalised result
\<close>
lemma fns2: "Abs \<circ> fr \<circ> Rep = fa \<Longrightarrow> norm \<circ> fr \<circ> norm = fr \<circ> norm \<longleftrightarrow> Rep \<circ> fa = fr \<circ> Rep"
  apply (fold eq_norm')
  apply safe
   prefer 2
   apply (simp add: o_assoc)
  apply (rule ext)
  apply (drule_tac x="Rep x" in fun_cong)
  apply auto
  done

lemma fns3: "Abs \<circ> fr \<circ> Rep = fa \<Longrightarrow> norm \<circ> fr \<circ> norm = norm \<circ> fr \<longleftrightarrow> fa \<circ> Abs = Abs \<circ> fr"
  apply (fold eq_norm')
  apply safe
   prefer 2
   apply (simp add: comp_assoc)
  apply (rule ext)
  apply (drule_tac f="a \<circ> b" for a b in fun_cong)
  apply simp
  done

lemma fns: "fr \<circ> norm = norm \<circ> fr \<Longrightarrow> fa \<circ> Abs = Abs \<circ> fr \<longleftrightarrow> Rep \<circ> fa = fr \<circ> Rep"
  apply safe
   apply (frule fns1b)
   prefer 2
   apply (frule fns1a)
   apply (rule fns3 [THEN iffD1])
     prefer 3
     apply (rule fns2 [THEN iffD1])
       apply (simp_all add: comp_assoc)
   apply (simp_all add: o_assoc)
  done

lemma range_norm: "range (Rep \<circ> Abs) = A"
  by (simp add: set_Rep_Abs)

end

lemmas td_ext_def' =
  td_ext_def [unfolded type_definition_def td_ext_axioms_def]

subsection \<open>Type-definition locale instantiations\<close>

definition uints :: "nat \<Rightarrow> int set"
  \<comment> \<open>the sets of integers representing the words\<close>
  where "uints n = range (take_bit n)"

definition sints :: "nat \<Rightarrow> int set"
  where "sints n = range (signed_take_bit (n - 1))"

lemma uints_num: "uints n = {i. 0 \<le> i \<and> i < 2 ^ n}"
  by (simp add: uints_def range_bintrunc)

lemma sints_num: "sints n = {i. - (2 ^ (n - 1)) \<le> i \<and> i < 2 ^ (n - 1)}"
  by (simp add: sints_def range_sbintrunc)

definition unats :: "nat \<Rightarrow> nat set"
  where "unats n = {i. i < 2 ^ n}"

\<comment> \<open>naturals\<close>
lemma uints_unats: "uints n = int ` unats n"
  apply (unfold unats_def uints_num)
  apply safe
    apply (rule_tac image_eqI)
     apply (erule_tac nat_0_le [symmetric])
  by auto

lemma unats_uints: "unats n = nat ` uints n"
  by (auto simp: uints_unats image_iff)

lemma td_ext_uint:
  "td_ext (uint :: 'a word \<Rightarrow> int) word_of_int (uints (LENGTH('a::len)))
    (\<lambda>w::int. w mod 2 ^ LENGTH('a))"
  apply (unfold td_ext_def')
  apply transfer
  apply (simp add: uints_num take_bit_eq_mod)
  done

interpretation word_uint:
  td_ext
    "uint::'a::len word \<Rightarrow> int"
    word_of_int
    "uints (LENGTH('a::len))"
    "\<lambda>w. w mod 2 ^ LENGTH('a::len)"
  by (fact td_ext_uint)

lemmas td_uint = word_uint.td_thm
lemmas int_word_uint = word_uint.eq_norm

lemma td_ext_ubin:
  "td_ext (uint :: 'a word \<Rightarrow> int) word_of_int (uints (LENGTH('a::len)))
    (take_bit (LENGTH('a)))"
  apply standard
  apply transfer
  apply simp
  done

interpretation word_ubin:
  td_ext
    "uint::'a::len word \<Rightarrow> int"
    word_of_int
    "uints (LENGTH('a::len))"
    "take_bit (LENGTH('a::len))"
  by (fact td_ext_ubin)

lemma td_ext_unat [OF refl]:
  "n = LENGTH('a::len) \<Longrightarrow>
    td_ext (unat :: 'a word \<Rightarrow> nat) of_nat (unats n) (\<lambda>i. i mod 2 ^ n)"
  apply (standard; transfer)
     apply (simp_all add: unats_def take_bit_of_nat take_bit_nat_eq_self_iff
      flip: take_bit_eq_mod)
  done

lemmas unat_of_nat = td_ext_unat [THEN td_ext.eq_norm]

interpretation word_unat:
  td_ext
    "unat::'a::len word \<Rightarrow> nat"
    of_nat
    "unats (LENGTH('a::len))"
    "\<lambda>i. i mod 2 ^ LENGTH('a::len)"
  by (rule td_ext_unat)

lemmas td_unat = word_unat.td_thm

lemma unat_le: "y \<le> unat z \<Longrightarrow> y \<in> unats (LENGTH('a))"
  for z :: "'a::len word"
  apply (unfold unats_def)
  apply clarsimp
  apply (metis le_unat_uoi unsigned_less)
  done

lemma td_ext_sbin:
  "td_ext (sint :: 'a word \<Rightarrow> int) word_of_int (sints (LENGTH('a::len)))
    (signed_take_bit (LENGTH('a) - 1))"
  by (standard; transfer) (auto simp add: sints_def)

lemma td_ext_sint:
  "td_ext (sint :: 'a word \<Rightarrow> int) word_of_int (sints (LENGTH('a::len)))
     (\<lambda>w. (w + 2 ^ (LENGTH('a) - 1)) mod 2 ^ LENGTH('a) -
         2 ^ (LENGTH('a) - 1))"
  using td_ext_sbin [where ?'a = 'a] by (simp add: no_sbintr_alt2)

text \<open>
  We do \<open>sint\<close> before \<open>sbin\<close>, before \<open>sint\<close> is the user version
  and interpretations do not produce thm duplicates. I.e.
  we get the name \<open>word_sint.Rep_eqD\<close>, but not \<open>word_sbin.Req_eqD\<close>,
  because the latter is the same thm as the former.
\<close>
interpretation word_sint:
  td_ext
    "sint ::'a::len word \<Rightarrow> int"
    word_of_int
    "sints (LENGTH('a::len))"
    "\<lambda>w. (w + 2^(LENGTH('a::len) - 1)) mod 2^LENGTH('a::len) -
      2 ^ (LENGTH('a::len) - 1)"
  by (rule td_ext_sint)

interpretation word_sbin:
  td_ext
    "sint ::'a::len word \<Rightarrow> int"
    word_of_int
    "sints (LENGTH('a::len))"
    "signed_take_bit (LENGTH('a::len) - 1)"
  by (rule td_ext_sbin)

lemmas int_word_sint = td_ext_sint [THEN td_ext.eq_norm]

lemmas td_sint = word_sint.td

lemma uints_mod: "uints n = range (\<lambda>w. w mod 2 ^ n)"
  by (fact uints_def [unfolded no_bintr_alt1])

lemmas bintr_num =
  word_ubin.norm_eq_iff [of "numeral a" "numeral b", symmetric, folded word_numeral_alt] for a b
lemmas sbintr_num =
  word_sbin.norm_eq_iff [of "numeral a" "numeral b", symmetric, folded word_numeral_alt] for a b

lemmas uint_div_alt = word_div_def [THEN trans [OF uint_cong int_word_uint]]
lemmas uint_mod_alt = word_mod_def [THEN trans [OF uint_cong int_word_uint]]

interpretation test_bit:
  td_ext
    "bit :: 'a::len word \<Rightarrow> nat \<Rightarrow> bool"
    set_bits
    "{f. \<forall>i. f i \<longrightarrow> i < LENGTH('a::len)}"
    "(\<lambda>h i. h i \<and> i < LENGTH('a::len))"
  by standard (auto simp add: bit_imp_le_length bit_set_bits_word_iff set_bits_bit_eq)

lemmas td_nth = test_bit.td_thm

lemma sints_subset:
  "m \<le> n \<Longrightarrow> sints m \<subseteq> sints n"
  apply (simp add: sints_num)
  apply clarsimp
  apply (rule conjI)
   apply (erule order_trans[rotated])
   apply simp
  apply (erule order_less_le_trans)
  apply simp
  done

lemma uints_mono_iff: "uints l \<subseteq> uints m \<longleftrightarrow> l \<le> m"
  using power_increasing_iff[of "2::int" l m]
  apply (auto simp: uints_num subset_iff simp del: power_increasing_iff)
  apply (meson less_irrefl not_le zero_le_numeral zero_le_power)
  done

lemmas uints_monoI = uints_mono_iff[THEN iffD2]

lemma Bit_in_uints_Suc: "of_bool c + 2 * w \<in> uints (Suc m)" if "w \<in> uints m"
  using that
  by (auto simp: uints_num)

lemma Bit_in_uintsI: "of_bool c + 2 * w \<in> uints m" if "w \<in> uints (m - 1)" "m > 0"
  using Bit_in_uints_Suc[OF that(1)] that(2)
  by auto

lemma bin_cat_in_uintsI:
  \<open>concat_bit n b a \<in> uints m\<close> if \<open>a \<in> uints l\<close> \<open>m \<ge> l + n\<close>
proof -
  from \<open>m \<ge> l + n\<close> obtain q where \<open>m = l + n + q\<close>
    using le_Suc_ex by blast
  then have \<open>(2::int) ^ m = 2 ^ n * 2 ^ (l + q)\<close>
    by (simp add: ac_simps power_add)
  moreover have \<open>a mod 2 ^ (l + q) = a\<close>
    using \<open>a \<in> uints l\<close>
    by (auto simp add: uints_def take_bit_eq_mod power_add Divides.mod_mult2_eq)
  ultimately have \<open>concat_bit n b a = take_bit m (concat_bit n b a)\<close>
    by (simp add: concat_bit_eq take_bit_eq_mod push_bit_eq_mult Divides.mod_mult2_eq)
  then show ?thesis
    by (simp add: uints_def)
qed

end


(* Authors: F. Maric, M. Spasic, R. Thiemann *)
section \<open>Rational Numbers Extended with Infinitesimal Element\<close>
theory QDelta
  imports
    Abstract_Linear_Poly
    Simplex_Algebra
begin

datatype QDelta = QDelta rat rat

primrec qdfst :: "QDelta \<Rightarrow> rat"
  where
    "qdfst (QDelta a b) = a"

primrec qdsnd :: "QDelta \<Rightarrow> rat"
  where
    "qdsnd (QDelta a b) = b"

lemma [simp]: "\<lbrakk>QDelta.qdsnd x = QDelta.qdsnd y; QDelta.qdfst y = QDelta.qdfst x\<rbrakk> \<Longrightarrow> x = y"
  by (cases x) auto

instantiation QDelta :: rational_vector
begin

definition zero_QDelta :: "QDelta"
  where
    "0 = QDelta 0 0"

definition plus_QDelta :: "QDelta \<Rightarrow> QDelta \<Rightarrow> QDelta"
  where
    "qd1 + qd2 = QDelta (qdfst qd1 + qdfst qd2) (qdsnd qd1 + qdsnd qd2)"

definition minus_QDelta :: "QDelta \<Rightarrow> QDelta \<Rightarrow> QDelta"
  where
    "qd1 - qd2 = QDelta (qdfst qd1 - qdfst qd2) (qdsnd qd1 - qdsnd qd2)"

definition uminus_QDelta :: "QDelta \<Rightarrow> QDelta"
  where
    "- qd = QDelta (- (qdfst qd)) (- (qdsnd qd))"

definition scaleRat_QDelta :: "rat \<Rightarrow> QDelta \<Rightarrow> QDelta"
  where
    "r *R qd = QDelta (r*(qdfst qd)) (r*(qdsnd qd))"

instance
proof
qed (auto simp add: plus_QDelta_def zero_QDelta_def uminus_QDelta_def minus_QDelta_def scaleRat_QDelta_def field_simps)
end

instantiation QDelta :: linorder
begin
definition less_eq_QDelta :: "QDelta \<Rightarrow> QDelta \<Rightarrow> bool"
  where
    "qd1 \<le> qd2 \<longleftrightarrow> (qdfst qd1 < qdfst qd2) \<or> (qdfst qd1 = qdfst qd2 \<and> qdsnd qd1 \<le> qdsnd qd2)"

definition less_QDelta :: "QDelta \<Rightarrow> QDelta \<Rightarrow> bool"
  where
    "qd1 < qd2 \<longleftrightarrow> (qdfst qd1 < qdfst qd2) \<or> (qdfst qd1 = qdfst qd2 \<and> qdsnd qd1 < qdsnd qd2)"

instance proof qed (auto simp add: less_QDelta_def less_eq_QDelta_def)
end

instantiation QDelta:: linordered_rational_vector
begin
instance proof qed (auto simp add: plus_QDelta_def less_QDelta_def scaleRat_QDelta_def mult_strict_left_mono mult_strict_left_mono_neg)
end

instantiation QDelta :: lrv
begin
definition one_QDelta where
  "one_QDelta = QDelta 1 0"
instance proof qed (auto simp add: one_QDelta_def zero_QDelta_def)
end

definition \<delta>0 :: "QDelta \<Rightarrow> QDelta \<Rightarrow> rat"
  where
    "\<delta>0 qd1 qd2 ==
    let c1 = qdfst qd1; c2 = qdfst qd2; k1 = qdsnd qd1; k2 = qdsnd qd2 in
      (if (c1 < c2 \<and> k1 > k2) then
              (c2 - c1) / (k1 - k2)
       else
               1
       )
    "

definition val :: "QDelta \<Rightarrow> rat \<Rightarrow> rat"
  where "val qd \<delta> = (qdfst qd) + \<delta> * (qdsnd qd)"

lemma val_plus:
  "val (qd1 + qd2) \<delta> = val qd1 \<delta> + val qd2 \<delta>"
  by (simp add: field_simps val_def plus_QDelta_def)

lemma val_scaleRat:
  "val (c *R qd) \<delta> = c * val qd \<delta>"
  by (simp add: field_simps val_def scaleRat_QDelta_def)

lemma qdfst_setsum:
  "finite A \<Longrightarrow> qdfst (\<Sum>x\<in>A. f x) = (\<Sum>x\<in>A. qdfst (f x))"
  by (induct A rule: finite_induct) (auto simp add: zero_QDelta_def plus_QDelta_def)

lemma qdsnd_setsum:
  "finite A \<Longrightarrow> qdsnd (\<Sum>x\<in>A. f x) = (\<Sum>x\<in>A. qdsnd (f x))"
  by (induct A rule: finite_induct) (auto simp add: zero_QDelta_def plus_QDelta_def)

lemma valuate_valuate_rat:
  "lp \<lbrace>(\<lambda>v. (QDelta (vl v) 0))\<rbrace> = QDelta (lp\<lbrace>vl\<rbrace>) 0"
  using Rep_linear_poly
  by (simp add: valuate_def scaleRat_QDelta_def qdsnd_setsum qdfst_setsum)

lemma valuate_rat_valuate:
  "lp\<lbrace>(\<lambda>v. val (vl v) \<delta>)\<rbrace> = val (lp\<lbrace>vl\<rbrace>) \<delta>"
  unfolding valuate_def val_def
  using rational_vector.scale_sum_right[of \<delta> "\<lambda>x. Rep_linear_poly lp x * qdsnd (vl x)" "{v :: nat. Rep_linear_poly lp v \<noteq> (0 :: rat)}"]
  using Rep_linear_poly
  by (auto simp add: field_simps sum.distrib qdfst_setsum qdsnd_setsum) (auto simp add: scaleRat_QDelta_def)

lemma delta0:
  assumes "qd1 \<le> qd2"
  shows "\<forall> \<epsilon>. \<epsilon> > 0 \<and> \<epsilon> \<le> (\<delta>0 qd1 qd2) \<longrightarrow> val qd1 \<epsilon> \<le> val qd2 \<epsilon>"
proof-
  have "\<And> e c1 c2 k1 k2 :: rat. \<lbrakk>e \<ge> 0; c1 < c2; k1 \<le> k2\<rbrakk> \<Longrightarrow> c1 + e*k1 \<le> c2 + e*k2"
  proof-
    fix e c1 c2 k1 k2 :: rat
    show "\<lbrakk>e \<ge> 0; c1 < c2; k1 \<le> k2\<rbrakk> \<Longrightarrow> c1 + e*k1 \<le> c2 + e*k2"
      using mult_left_mono[of "k1" "k2" "e"]
      using add_less_le_mono[of "c1" "c2" "e*k1" "e*k2"]
      by simp
  qed
  then show ?thesis
    using assms
    by (auto simp add: \<delta>0_def val_def less_eq_QDelta_def Let_def field_simps mult_left_mono)
qed

primrec
  \<delta>_min ::"(QDelta \<times> QDelta) list \<Rightarrow> rat" where
  "\<delta>_min [] = 1" |
  "\<delta>_min (h # t) = min (\<delta>_min t) (\<delta>0 (fst h) (snd h))"

lemma delta_gt_zero:
  "\<delta>_min l > 0"
  by (induct l) (auto simp add: Let_def field_simps \<delta>0_def)

lemma delta_le_one:
  "\<delta>_min l \<le> 1"
  by (induct l, auto)

lemma delta_min_append:
  "\<delta>_min (as @ bs) = min (\<delta>_min as) (\<delta>_min bs)"
  by (induct as, insert delta_le_one[of bs], auto)

lemma delta_min_mono: "set as \<subseteq> set bs \<Longrightarrow> \<delta>_min bs \<le> \<delta>_min as"
proof (induct as)
  case Nil
  then show ?case using delta_le_one by simp
next
  case (Cons a as)
  from Cons(2) have "a \<in> set bs" by auto
  from split_list[OF this]
  obtain bs1 bs2 where bs: "bs = bs1 @ [a] @ bs2" by auto
  have bs: "\<delta>_min bs = \<delta>_min ([a] @ bs)" unfolding bs delta_min_append by auto
  show ?case unfolding bs using Cons(1-2) by auto
qed

lemma delta_min:
  assumes "\<forall> qd1 qd2. (qd1, qd2) \<in> set qd \<longrightarrow> qd1 \<le> qd2"
  shows "\<forall> \<epsilon>. \<epsilon> > 0 \<and> \<epsilon> \<le> \<delta>_min qd \<longrightarrow> (\<forall> qd1 qd2. (qd1, qd2) \<in> set qd \<longrightarrow> val qd1 \<epsilon> \<le> val qd2 \<epsilon>)"
  using assms
  using delta0
  by (induct qd, auto)

lemma QDelta_0_0: "QDelta 0 0 = 0" by code_simp
lemma qdsnd_0: "qdsnd 0 = 0" by code_simp
lemma qdfst_0: "qdfst 0 = 0" by code_simp

end