section \<open>Getting Small Representative Polynomials via Factorization\<close>

text \<open>In this theory we import a factorization algorithm for
  integer polynomials to turn a representing polynomial of some algebraic number into
  a list of irreducible polynomials where exactly one list element
  represents the same number. Moreover, we prove
  that the certain polynomial operations preserve irreducibility, so that
  no factorization is required.\<close>

theory Factors_of_Int_Poly
  imports
  Berlekamp_Zassenhaus.Factorize_Int_Poly
  Algebraic_Numbers_Prelim
begin

lemma degree_of_gcd: "degree (gcd q r) \<noteq> 0 \<longleftrightarrow>
 degree (gcd (of_int_poly q :: 'a :: {field_char_0, field_gcd} poly) (of_int_poly r)) \<noteq> 0"
proof -
  let ?r = "of_rat :: rat \<Rightarrow> 'a"
  interpret rpoly: field_hom' ?r
    by (unfold_locales, auto simp: of_rat_add of_rat_mult)
  {
    fix p
    have "of_int_poly p = map_poly (?r o of_int) p" unfolding o_def
      by auto
    also have "\<dots> = map_poly ?r (map_poly of_int p)"
      by (subst map_poly_map_poly, auto)
    finally have "of_int_poly p = map_poly ?r (map_poly of_int p)" .
  } note id = this
  show ?thesis unfolding id by (fold hom_distribs, simp add: gcd_rat_to_gcd_int)
qed

definition factors_of_int_poly :: "int poly \<Rightarrow> int poly list" where
  "factors_of_int_poly p = map (abs_int_poly o fst) (snd (factorize_int_poly p))"

lemma factors_of_int_poly_const: assumes "degree p = 0"
  shows "factors_of_int_poly p = []"
proof -
  from degree0_coeffs[OF assms] obtain a where p: "p = [: a :]" by auto
  show ?thesis unfolding p factors_of_int_poly_def
    factorize_int_poly_generic_def x_split_def
    by (cases "a = 0", auto simp add: Let_def factorize_int_last_nz_poly_def)
qed

lemma factors_of_int_poly:
  defines "rp \<equiv> ipoly :: int poly \<Rightarrow> 'a :: {field_gcd,field_char_0} \<Rightarrow> 'a"
  assumes "factors_of_int_poly p = qs"
  shows "\<And> q. q \<in> set qs \<Longrightarrow> irreducible q \<and> lead_coeff q > 0 \<and> degree q \<le> degree p \<and> degree q \<noteq> 0"
  "p \<noteq> 0 \<Longrightarrow> rp p x = 0 \<longleftrightarrow> (\<exists> q \<in> set qs. rp q x = 0)"
  "p \<noteq> 0 \<Longrightarrow> rp p x = 0 \<Longrightarrow> \<exists>! q \<in> set qs. rp q x = 0"
  "distinct qs"
proof -
  obtain c qis where factt: "factorize_int_poly p = (c,qis)" by force
  from assms[unfolded factors_of_int_poly_def factt]
  have qs: "qs = map (abs_int_poly \<circ> fst) (snd (c, qis))" by auto
  note fact = factorize_int_poly(1)[OF factt]
  note fact_mem = factorize_int_poly(2,3)[OF factt]
  have sqf: "square_free_factorization p (c, qis)" by (rule fact(1))
  note sff = square_free_factorizationD[OF sqf]
  have sff': "p = Polynomial.smult c (\<Prod>(a, i)\<leftarrow> qis. a ^ Suc i)"
    unfolding sff(1) prod.distinct_set_conv_list[OF sff(5)] ..
  {
    fix q
    assume q: "q \<in> set qs"
    then obtain r i where qi: "(r,i) \<in> set qis" and qr: "q = abs_int_poly r" unfolding qs by auto
    from split_list[OF qi] obtain qis1 qis2 where qis: "qis = qis1 @ (r,i) # qis2" by auto
    have dvd: "r dvd p" unfolding sff' qis dvd_def
      by (intro exI[of _ "smult c (r ^ i * (\<Prod>(a, i)\<leftarrow>qis1 @  qis2. a ^ Suc i))"], auto)
    from fact_mem[OF qi] have r0: "r \<noteq> 0" by auto
    from qi factt have p: "p \<noteq> 0" by (cases p, auto)
    with dvd have deg: "degree r \<le> degree p" by (metis dvd_imp_degree_le)
    with fact_mem[OF qi] r0
    show "irreducible q \<and> lead_coeff q > 0 \<and> degree q \<le> degree p \<and> degree q \<noteq> 0"
      unfolding qr lead_coeff_abs_int_poly by auto
  } note * = this
  show "distinct qs" unfolding distinct_conv_nth
  proof (intro allI impI)
    fix i j
    assume "i < length qs" "j < length qs" and diff: "i \<noteq> j"
    hence ij: "i < length qis" "j < length qis"
      and id: "qs ! i = abs_int_poly (fst (qis ! i))" "qs ! j = abs_int_poly (fst (qis ! j))" unfolding qs by auto
    obtain qi I where qi: "qis ! i = (qi, I)" by force
    obtain qj J where qj: "qis ! j = (qj, J)" by force
    from sff(5)[unfolded distinct_conv_nth, rule_format, OF ij diff] qi qj
    have diff: "(qi, I) \<noteq> (qj, J)" by auto
    from ij qi qj have "(qi, I) \<in> set qis" "(qj, J) \<in> set qis" unfolding set_conv_nth by force+
    from sff(3)[OF this diff] sff(2) this
    have cop: "coprime qi qj" "degree qi \<noteq> 0" "degree qj \<noteq> 0" by auto
    note i = cf_pos_poly_main[of qi, unfolded smult_prod monom_0]
    note j = cf_pos_poly_main[of qj, unfolded smult_prod monom_0]
    from cop(2) i have deg: "degree (qs ! i) \<noteq> 0" by (auto simp: id qi)
    have cop: "coprime (qs ! i) (qs ! j)"
      unfolding id qi qj fst_conv
      apply (rule coprime_prod[of "[:sgn (lead_coeff qi):]" "[:sgn (lead_coeff qj):]"])
      using cop
      unfolding i j by (auto simp: sgn_eq_0_iff)
    show "qs ! i \<noteq> qs ! j"
    proof
      assume id: "qs ! i = qs ! j"
      have "degree (gcd (qs ! i) (qs ! j)) = degree (qs ! i)"  unfolding id by simp
      also have "\<dots> \<noteq> 0" using deg by simp
      finally show False using cop by simp
    qed
  qed
  assume p: "p \<noteq> 0"
  from fact(1) p have c: "c \<noteq> 0" using sff(1) by auto
  let ?r = "of_int :: int \<Rightarrow> 'a"
  let ?rp = "map_poly ?r"
  have rp: "\<And> x p. rp p x = 0 \<longleftrightarrow> poly (?rp p) x = 0" unfolding rp_def ..
  have "rp p x = 0 \<longleftrightarrow> rp (\<Prod>(x, y)\<leftarrow>qis. x ^ Suc y) x = 0" unfolding sff'(1)
    unfolding rp hom_distribs using c by simp
  also have "\<dots> = (\<exists> (q,i) \<in>set qis. poly (?rp (q ^ Suc i)) x = 0)"
    unfolding qs rp of_int_poly_hom.hom_prod_list poly_prod_list_zero_iff set_map by fastforce
  also have "\<dots> = (\<exists> (q,i) \<in>set qis. poly (?rp q) x = 0)"
    unfolding of_int_poly_hom.hom_power poly_power_zero_iff by auto
  also have "\<dots> = (\<exists> q \<in> fst ` set qis. poly (?rp q) x = 0)" by force
  also have "\<dots> = (\<exists> q \<in> set qs. rp q x = 0)" unfolding rp qs snd_conv o_def bex_simps set_map
    by simp
  finally show iff: "rp p x = 0 \<longleftrightarrow> (\<exists> q \<in> set qs. rp q x = 0)" by auto
  assume "rp p x = 0"
  with iff obtain q where q: "q \<in> set qs" and rtq: "rp q x = 0" by auto
  then obtain i q' where qi: "(q',i) \<in> set qis" and qq': "q = abs_int_poly q'" unfolding qs by auto
  show "\<exists>! q \<in> set qs. rp q x = 0"
  proof (intro ex1I, intro conjI, rule q, rule rtq, clarify)
    fix r
    assume "r \<in> set qs" and rtr: "rp r x = 0"
    then obtain j r' where rj: "(r',j) \<in> set qis" and rr': "r = abs_int_poly r'" unfolding qs by auto
    from rtr rtq have rtr: "rp r' x = 0" and rtq: "rp q' x = 0"
      unfolding rp rr' qq' by auto
    from rtr rtq have "[:-x,1:] dvd ?rp q'" "[:-x,1:] dvd ?rp r'" unfolding rp
      by (auto simp: poly_eq_0_iff_dvd)
    hence "[:-x,1:] dvd gcd (?rp q') (?rp r')" by simp
    hence "gcd (?rp q') (?rp r') = 0 \<or> degree (gcd (?rp q') (?rp r')) \<noteq> 0"
      by (metis is_unit_gcd_iff is_unit_iff_degree is_unit_pCons_iff one_poly_eq_simps(1))
    hence "gcd q' r' = 0 \<or> degree (gcd q' r') \<noteq> 0"
      unfolding gcd_eq_0_iff degree_of_gcd[of q' r',symmetric] by auto
    hence "\<not> coprime q' r'" by auto
    with sff(3)[OF qi rj] have "q' = r'" by auto
    thus "r = q" unfolding rr' qq' by simp
  qed
qed

lemma factors_int_poly_represents:
  fixes x :: "'a :: {field_char_0,field_gcd}"
  assumes p: "p represents x"
  shows "\<exists> q \<in> set (factors_of_int_poly p).
    q represents x \<and> irreducible q \<and> lead_coeff q > 0  \<and> degree q \<le> degree p"
proof -
  from representsD[OF p] have p: "p \<noteq> 0" and rt: "ipoly p x = 0" by auto
  note fact = factors_of_int_poly[OF refl]
  from fact(2)[OF p, of x] rt obtain q where q: "q \<in> set (factors_of_int_poly p)" and
    rt: "ipoly q x = 0" by auto
  from fact(1)[OF q] rt show ?thesis
    by (intro bexI[OF _ q], auto simp: represents_def irreducible_def)
qed

corollary irreducible_represents_imp_degree:
  fixes x :: "'a :: {field_char_0,field_gcd}"
  assumes "irreducible f" and "f represents x" and "g represents x"
  shows "degree f \<le> degree g"
proof -
  from factors_of_int_poly(1)[OF refl, of _ g] factors_of_int_poly(3)[OF refl, of g x]
     assms(3) obtain h where *: "h represents x" "degree h \<le> degree g" "irreducible h"
    by blast
  let ?af = "abs_int_poly f"
  let ?ah = "abs_int_poly h"
  from assms have af: "irreducible ?af" "?af represents x" "lead_coeff ?af > 0" by fastforce+
  from * have ah: "irreducible ?ah" "?ah represents x" "lead_coeff ?ah > 0" by fastforce+
  from algebraic_imp_represents_unique[of x] af ah have id: "?af = ?ah"
    unfolding algebraic_iff_represents by blast
  show ?thesis using arg_cong[OF id, of degree] \<open>degree h \<le> degree g\<close> by simp
qed

lemma irreducible_preservation:
  fixes x :: "'a :: {field_char_0,field_gcd}"
  assumes irr: "irreducible p"
  and x: "p represents x"
  and y: "q represents y"
  and deg: "degree p \<ge> degree q"
  and f: "\<And> q. q represents y \<Longrightarrow> (f q) represents x \<and> degree (f q) \<le> degree q"
  and pr: "primitive q"
  shows "irreducible q"
proof (rule ccontr)
  define pp where "pp = abs_int_poly p"
  have dp: "degree p \<noteq> 0" using x by (rule represents_degree)
  have dq: "degree q \<noteq> 0" using y by (rule represents_degree)
  from dp have p0: "p \<noteq> 0" by auto
  from x deg irr p0
  have irr: "irreducible pp" and x: "pp represents x" and
    deg: "degree pp \<ge> degree q" and cf_pos: "lead_coeff pp > 0"
    unfolding pp_def lead_coeff_abs_int_poly by (auto intro!: representsI)
  from x have ax: "algebraic x" unfolding algebraic_altdef_ipoly represents_def by blast
  assume "\<not> ?thesis"
  from this irreducible_connect_int[of q] pr have "\<not> irreducible\<^sub>d q" by auto
  from this dq obtain r where
    r: "degree r \<noteq> 0" "degree r < degree q" and "r dvd q" by auto
  then obtain rr where q: "q = r * rr" unfolding dvd_def by auto
  have "degree q = degree r + degree rr" using dq unfolding q
    by (subst degree_mult_eq, auto)
  with r have rr: "degree rr \<noteq> 0" "degree rr < degree q" by auto
  from representsD(2)[OF y, unfolded q hom_distribs]
  have "ipoly r y = 0 \<or> ipoly rr y = 0" by auto
  with r rr have "r represents y \<or> rr represents y" unfolding represents_def by auto
  with r rr obtain r where r: "r represents y" "degree r < degree q" by blast
  from f[OF r(1)] deg r(2) obtain r where r: "r represents x" "degree r < degree pp" by auto
  from factors_int_poly_represents[OF r(1)] r(2) obtain r where
    r: "r represents x" "irreducible r" "lead_coeff r > 0" and deg: "degree r < degree pp" by force
  from algebraic_imp_represents_unique[OF ax] r irr cf_pos x have "r = pp" by auto
  with deg show False by auto
qed

declare irreducible_const_poly_iff [simp]

lemma poly_uminus_irreducible:
  assumes p: "irreducible (p :: int poly)" and deg: "degree p \<noteq> 0"
  shows "irreducible (poly_uminus p)"
proof-
  from deg_nonzero_represents[OF deg] obtain x :: complex where x: "p represents x" by auto
  from represents_uminus[OF x]
  have y: "poly_uminus p represents (- x)" .
  show ?thesis
  proof (rule irreducible_preservation[OF p x y], force)
    from deg irreducible_imp_primitive[OF p] have "primitive p" by auto
    then show "primitive (poly_uminus p)" by simp
    fix q
    assume "q represents (- x)"
    from represents_uminus[OF this] have "(poly_uminus q) represents x" by simp
    thus "(poly_uminus q) represents x \<and> degree (poly_uminus q) \<le> degree q" by auto
  qed
qed

lemma reflect_poly_irreducible:
  fixes x :: "'a :: {field_char_0,field_gcd}"
  assumes p: "irreducible p" and x: "p represents x" and x0: "x \<noteq> 0"
  shows "irreducible (reflect_poly p)"
proof -
  from represents_inverse[OF x0 x]
  have y: "(reflect_poly p) represents (inverse x)" by simp
  from x0 have ix0: "inverse x \<noteq> 0" by auto
  show ?thesis
  proof (rule irreducible_preservation[OF p x y])
    from x irreducible_imp_primitive[OF p]
    show "primitive (reflect_poly p)" by (auto simp: content_reflect_poly)
    fix q
    assume "q represents (inverse x)"
    from represents_inverse[OF ix0 this] have "(reflect_poly q) represents x" by simp
    with degree_reflect_poly_le
    show "(reflect_poly q) represents x \<and> degree (reflect_poly q) \<le> degree q" by auto
  qed (insert p, auto simp: degree_reflect_poly_le)
qed

lemma poly_add_rat_irreducible:
  assumes p: "irreducible p" and deg: "degree p \<noteq> 0"
  shows "irreducible (cf_pos_poly (poly_add_rat r p))"
proof -
  from deg_nonzero_represents[OF deg] obtain x :: complex where x: "p represents x" by auto
  from represents_add_rat[OF x]
  have y: "cf_pos_poly (poly_add_rat r p) represents (of_rat r + x)" by simp
  show ?thesis
  proof (rule irreducible_preservation[OF p x y], force)
    fix q
    assume "q represents (of_rat r + x)"
    from represents_add_rat[OF this, of "- r"] have "(poly_add_rat (- r) q) represents x" by (simp add: of_rat_minus)
    thus "(poly_add_rat (- r) q) represents x \<and> degree (poly_add_rat (- r) q) \<le> degree q" by auto
  qed (insert p, auto)
qed

lemma poly_mult_rat_irreducible:
  assumes p: "irreducible p" and deg: "degree p \<noteq> 0" and r: "r \<noteq> 0"
  shows "irreducible (cf_pos_poly (poly_mult_rat r p))"
proof -
  from deg_nonzero_represents[OF deg] obtain x :: complex where x: "p represents x" by auto
  from represents_mult_rat[OF r x]
  have y: "cf_pos_poly (poly_mult_rat r p) represents (of_rat r * x)" by simp
  show ?thesis
  proof (rule irreducible_preservation[OF p x y], force simp: r)
    fix q
    from r have r': "inverse r \<noteq> 0" by simp
    assume "q represents (of_rat r * x)"
    from represents_mult_rat[OF r' this] have "(poly_mult_rat (inverse r) q) represents x" using r
      by (simp add: of_rat_divide field_simps)
    thus "(poly_mult_rat (inverse r) q) represents x \<and> degree (poly_mult_rat (inverse r) q) \<le> degree q"
      using r by auto
  qed (insert p r, auto)
qed

interpretation coeff_lift_hom:
  factor_preserving_hom "coeff_lift :: 'a :: {comm_semiring_1,semiring_no_zero_divisors} \<Rightarrow> _"
  by (unfold_locales, auto)

end


subsection "Denotational equalities regarding reduction"

theory DenotEqualitiesFSet
  imports DenotCongruenceFSet
begin

theorem eval_prim[simp]: assumes e1:"E e1 = E (ENat n1)" and e2:"E e2 = E (ENat n2)"
  shows "E(EPrim f e1 e2)=E(ENat (f n1 n2))"
    using e1 e2 by auto

theorem eval_app_lam: assumes vv: "is_val v"
  shows "E(EApp (ELam x e) v) = E (subst x v e)"
  apply (rule ext) apply (rule equalityI) apply (rule subsetI)
   apply (subgoal_tac "EApp (ELam x e) v \<longrightarrow> subst x v e") prefer 2 apply (rule beta)
  using vv apply assumption apply (rule subject_reduction) apply assumption apply assumption
  apply (rule subsetI)
  apply (subgoal_tac "EApp (ELam x e) v \<longrightarrow> subst x v e") prefer 2 apply (rule beta)
  using vv apply assumption apply (rule reverse_step_pres_denot) apply assumption
  apply assumption
  done

end


section \<open>Formalized Proof \label{sec:proof}\<close>

theory SortKeys
  imports Data "HOL-Library.List_Lexorder" "HOL-Library.Product_Lexorder"
begin

datatype sort_dir =
  Left |
  Right
derive linorder sort_dir

lemma sort_dir_less_def [simp]: "(x < y) = (x = Left \<and> y = Right)"
  by (cases x, case_tac [!] y, simp_all add:less_sort_dir_def)

datatype '\<I> sort_key =
  NonFinal "('\<I> \<times> sort_dir)" "'\<I> sort_key" |
  Final '\<I>

type_synonym '\<I> position = "'\<I> sort_key extended"

fun embed_dir where "embed_dir (x,Left) = (x, 0)" | "embed_dir (x,Right) = (x, Suc (Suc 0))"

lemma embed_dir_inj [simp]: "(embed_dir x = embed_dir y) = (x = y)"
  by (cases x, cases y, case_tac [!] "snd x", case_tac [!] "snd y", simp+)

lemma embed_dir_mono [simp]: "(embed_dir x < embed_dir y) = (x < y)"
  by (cases x, cases y, case_tac [!] "snd x", case_tac [!] "snd y", (simp add:less_sort_dir_def)+)

fun sort_key_embedding :: "'\<I> sort_key \<Rightarrow> ('\<I> \<times> nat) list"
  where
   "sort_key_embedding (NonFinal x y) = embed_dir x#(sort_key_embedding y)" |
   "sort_key_embedding (Final i) = [(i, Suc 0)]"

lemma sort_key_embedding_injective:
  "sort_key_embedding x = sort_key_embedding y \<Longrightarrow> x = y"
  apply (induct x arbitrary: y)
  apply (metis embed_dir_inj list.distinct(1) list.inject sort_key.exhaust
      sort_key_embedding.simps)
  by (metis fst_conv list.distinct(1) list.inject sort_key.exhaust
      sort_key_embedding.simps)

instantiation sort_key :: (ord) ord
begin
definition sort_key_less_eq_def [simp]:
  "(x :: ('a :: ord) sort_key) \<le> y \<longleftrightarrow>
    (sort_key_embedding x \<le> sort_key_embedding y)"

definition sort_key_less_def [simp]:
  "(x :: ('a :: ord) sort_key) < y \<longleftrightarrow>
    (sort_key_embedding x < sort_key_embedding y)"

instance ..
end

instantiation sort_key :: (order) order
begin
instance by (intro_classes, simp_all add: less_le_not_le sort_key_embedding_injective)
end

instantiation sort_key :: (linorder) linorder
begin
instance by (intro_classes, meson less_imp_le not_le sort_key_less_eq_def)
end

end


theory RC3
imports Main Porder
begin

datatype 'a myTree =
  Leaf 'a |
  Node 'a "'a myTree" "'a myTree"

fun getBottom :: "'a myTree \<Rightarrow> 'a" where
  "getBottom (Leaf x) = x" |
  "getBottom (Node x l r) = x"

context po
begin

fun rc_order :: "'a myTree \<Rightarrow> bool" where
  "rc_order (Leaf x) = True" |
  "rc_order (Node x l r) = (x \<sqsubseteq> (getBottom l) \<and> x \<sqsubseteq> (getBottom r) \<and> rc_order l \<and> rc_order r)"

typedef 'a::po rc = "{t::'a myTree. rc_order t}"
by (metis mem_Collect_eq rc_order.simps(1))

fun getValue :: "'a rc \<Rightarrow> bool list \<Rightarrow> 'a" where
  "getValue (Leaf x) ys  = x" |
  "getValue (Node x l r) [] = x" |
  "getValue (Node x l r) (False # ys) = getValue l ys" |
  "getValue (Node x l r) (True # ys) = getValue r ys"

fun getTree :: "'a rc \<Rightarrow> bool list \<Rightarrow> 'a rc" where
  "getTree (Leaf x) ys = (Leaf x)" |
  "getTree r [] = r" |
  "getTree (Node x l r) (False # ys) = getTree l ys" |
  "getTree (Node x l r) (True # ys) = getTree r ys"

fun fmap :: "('a => 'b) => 'a rc => 'b rc" where
  "fmap f (Leaf x) = Leaf (f x)" |
  "fmap f (Node x l r) = Node (f x) (fmap f l) (fmap f r)"

fun unit :: "'a \<Rightarrow> 'a rc" where
  "unit x = Leaf x"

fun kleisli :: "('a \<Rightarrow> 'b rc) \<Rightarrow> 'a rc \<Rightarrow> bool list \<Rightarrow> 'b rc" where
  "kleisli f (Leaf x) word = getTree (f x) word" |
  "kleisli f (Node x l r) word = Node (getValue (f x) word) (kleisli f l (word @ [False])) (kleisli f r (word @ [True]))"

fun flatMap :: "('a \<Rightarrow> 'b rc) \<Rightarrow> 'a rc \<Rightarrow> 'b rc" where
  "flatMap f x = kleisli f x []"

fun inTree :: "'a rc \<Rightarrow> bool list \<Rightarrow> bool" where
  "inTree t [] = True" |
  "inTree (Leaf x) ys = False" |
  "inTree (Node x l r) (False # ys) = inTree l ys" |
  "inTree (Node x l r) (True # ys) = inTree r ys"

lemma [simp]: "getTree t ys = Leaf a \<Longrightarrow> getTree t (ys @ b) = Leaf a"
  apply (induct t ys rule: getTree.induct)
  apply simp_all
  done

lemma "flatMap f (unit x) = f x"
  by simp

lemma [simp]: "kleisli unit t ys = t"
  apply (induction t arbitrary: ys)
  apply auto
  done

lemma "(flatMap unit) x = x"
  by auto

lemma [simp]: "getValue (k (getValue t [])) [] = getValue (kleisli k t []) []"
  apply (induct t)
  apply auto
  done

lemma "getTree (Node a l r) (b # ys) = getTree (getTree (Node a l r) [b]) ys"
  apply (induct b)
  apply auto
  done

lemma tree: "getTree t (xs @ ys) = getTree (getTree t xs) ys"
  apply (induction t xs rule:getTree.induct)
  apply auto
  done

lemma [simp]: "getTree (getTree t xs) ys = getTree t (xs @ ys)"
  by (metis tree)

lemma tree2: "getTree t (x # ys) = getTree (getTree t [x]) ys"
  apply simp
  done

(*lemma "kleisli k (getTree (Node a t1 t2) (aa # ys)) (aa # ys) =
       getTree (Node (getValue (k a) []) (kleisli k t1 [False]) (kleisli k t2 [True]))
        (aa # ys)"
  apply (induct aa)
  apply auto
  apply (induct t2)
  apply auto*)

(*lemma "kleisli k (getTree (Node a t1 t2) ys) ys =
       getTree (Node (getValue (k a) []) (kleisli k t1 [False]) (kleisli k t2 [True])) ys"
  apply (induct ys)
  apply auto *)

lemma "getValue ((flatMap k) ((flatMap h) t)) []  = getValue ((flatMap (\<lambda>x. (flatMap k) (h x))) t) []"
  apply auto
  apply (induct t)
  apply auto
  done

(*lemma "inTree ((flatMap k) ((flatMap h) t)) ys  = inTree ((flatMap (\<lambda>x. (flatMap k) (h x))) t) ys"
  apply auto
  apply (induct t arbitrary:ys)
  apply auto
  apply (induct ys)
  apply auto

lemma "getValue ((flatMap k) ((flatMap h) t)) ys  = getValue ((flatMap (\<lambda>x. (flatMap k) (h x))) t) ys"
  apply auto
  apply (induct t arbitrary: ys)
  apply auto
  apply (induct ys)
  apply auto

lemma "getValue (kleisli k (getTree t ys) (xs @ ys)) [] = getValue (getTree (kleisli k t xs) ys) []"
  apply (induct t xs rule: getValue.induct)
  apply auto
  apply (induct ys)
  apply auto
*)

lemma list: "xs @ a # ys = (xs @ [a]) @ ys"
  by auto

lemma kleisli: "kleisli k (getTree t ys) (xs @ ys) = getTree (kleisli k t xs) ys"
  apply (induct t ys arbitrary: xs rule:getTree.induct )
  apply auto
  apply (metis list)
  apply (metis list)
  done

(*
lemma "kleisli k (getTree t ys) ys = getTree (kleisli k t []) ys \<Longrightarrow>
            kleisli k (getTree t ys) (x # ys) = getTree (kleisli k t [x]) ys"
  apply (induct x)
  apply (induct ys)
  apply auto

lemma "kleisli k (getTree t ys) ys = getTree (kleisli k t []) ys"
  apply (induct t ys rule: getTree.induct)
  apply auto *)

lemma getValTree: "getValue t (xs @ ys) = getValue (getTree t xs) ys"
  apply (induct t xs rule: getTree.induct)
  apply auto
  done

lemma getValKleisli: "getValue (k (getValue t ys)) (xs @ ys) = getValue (kleisli k t xs) ys"
  apply (induct t ys arbitrary: xs rule:getValue.induct)
  apply auto
  apply (metis getValTree)
  apply (metis append_Cons append_Nil append_assoc)
  apply (metis append_Cons append_Nil append_assoc)
  done

lemma kleisli2: "kleisli k (kleisli h t ys) ys = kleisli (\<lambda>x. kleisli k (h x) []) t ys"
  apply (induct t arbitrary: ys)
  apply auto
  apply (metis append_Nil kleisli)
  apply (metis append_Nil getValKleisli)
  done

lemma "(flatMap k) ((flatMap h) t) = (flatMap (\<lambda>x. (flatMap k) (h x))) t"
  apply auto
  apply (induction t)
  apply auto
  apply (metis kleisli2)
  apply (metis kleisli2)
  done

end


theory simp_expr_unambig1
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Tok = C | D | X | Y | Pl
  datatype E = Plus "E" "E" | Ex | EY
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun lin :: "E => Tok list" where
  "lin (Plus a b) =
     append
       (append
          (append (append (Cons2 C (Nil2)) (lin a)) (Cons2 Pl (Nil2)))
          (lin b))
       (Cons2 D (Nil2))"
  | "lin (Ex) = Cons2 X (Nil2)"
  | "lin (EY) = Cons2 Y (Nil2)"
  (*hipster append lin*)
  theorem x0 :
    "!! (u :: E) (v :: E) . ((lin u) = (lin v)) ==> (u = v)"
    oops
end


section \<open>Frequency Moment $2$\<close>

theory Frequency_Moment_2
  imports
    Universal_Hash_Families.Carter_Wegman_Hash_Family
    Equivalence_Relation_Enumeration.Equivalence_Relation_Enumeration
    Landau_Ext
    Median_Method.Median
    Product_PMF_Ext
    Universal_Hash_Families.Field
    Frequency_Moments
begin

text \<open>This section contains a formalization of the algorithm for the second frequency moment.
It is based on the algorithm described in \<^cite>\<open>\<open>\textsection 2.2\<close> in "alon1999"\<close>.
The only difference is that the algorithm is adapted to work with prime field of odd order, which
greatly reduces the implementation complexity.\<close>

fun f2_hash where
  "f2_hash p h k = (if even (ring.hash (mod_ring p) k h) then int p - 1 else - int p - 1)"

type_synonym f2_state = "nat \<times> nat \<times> nat \<times> (nat \<times> nat \<Rightarrow> nat list) \<times> (nat \<times> nat \<Rightarrow> int)"

fun f2_init :: "rat \<Rightarrow> rat \<Rightarrow> nat \<Rightarrow> f2_state pmf" where
  "f2_init \<delta> \<epsilon> n =
    do {
      let s\<^sub>1 = nat \<lceil>6 / \<delta>\<^sup>2\<rceil>;
      let s\<^sub>2 = nat \<lceil>-(18 * ln (real_of_rat \<epsilon>))\<rceil>;
      let p = prime_above (max n 3);
      h \<leftarrow> prod_pmf ({..<s\<^sub>1} \<times> {..<s\<^sub>2}) (\<lambda>_. pmf_of_set (bounded_degree_polynomials (mod_ring p) 4));
      return_pmf (s\<^sub>1, s\<^sub>2, p, h, (\<lambda>_ \<in> {..<s\<^sub>1} \<times> {..<s\<^sub>2}. (0 :: int)))
    }"

fun f2_update :: "nat \<Rightarrow> f2_state \<Rightarrow> f2_state pmf" where
  "f2_update x (s\<^sub>1, s\<^sub>2, p, h, sketch) =
    return_pmf (s\<^sub>1, s\<^sub>2, p, h, \<lambda>i \<in> {..<s\<^sub>1} \<times> {..<s\<^sub>2}. f2_hash p (h i) x + sketch i)"

fun f2_result :: "f2_state \<Rightarrow> rat pmf" where
  "f2_result (s\<^sub>1, s\<^sub>2, p, h, sketch) =
    return_pmf (median s\<^sub>2 (\<lambda>i\<^sub>2 \<in> {..<s\<^sub>2}.
      (\<Sum>i\<^sub>1\<in>{..<s\<^sub>1} . (rat_of_int (sketch (i\<^sub>1, i\<^sub>2)))\<^sup>2) / (((rat_of_nat p)\<^sup>2-1) * rat_of_nat s\<^sub>1)))"

fun f2_space_usage :: "(nat \<times> nat \<times> rat \<times> rat) \<Rightarrow> real" where
  "f2_space_usage (n, m, \<epsilon>, \<delta>) = (
    let s\<^sub>1 = nat \<lceil>6 / \<delta>\<^sup>2 \<rceil> in
    let s\<^sub>2 = nat \<lceil>-(18 * ln (real_of_rat \<epsilon>))\<rceil> in
    3 +
    2 * log 2 (s\<^sub>1 + 1) +
    2 * log 2 (s\<^sub>2 + 1) +
    2 * log 2 (9 + 2 * real n) +
    s\<^sub>1 * s\<^sub>2 * (5 + 4*log 2 (8 + 2 * real n) + 2 * log 2 (real m * (18 + 4 * real n) + 1 )))"

definition encode_f2_state :: "f2_state \<Rightarrow> bool list option" where
  "encode_f2_state =
    N\<^sub>e \<Join>\<^sub>e (\<lambda>s\<^sub>1.
    N\<^sub>e \<Join>\<^sub>e (\<lambda>s\<^sub>2.
    N\<^sub>e \<Join>\<^sub>e (\<lambda>p.
    (List.product [0..<s\<^sub>1] [0..<s\<^sub>2] \<rightarrow>\<^sub>e P\<^sub>e p 4) \<times>\<^sub>e
    (List.product [0..<s\<^sub>1] [0..<s\<^sub>2] \<rightarrow>\<^sub>e I\<^sub>e))))"

lemma "inj_on encode_f2_state (dom encode_f2_state)"
proof -
  have " is_encoding encode_f2_state"
    unfolding encode_f2_state_def
    by (intro dependent_encoding exp_golomb_encoding fun_encoding list_encoding int_encoding poly_encoding)

  thus ?thesis
    by (rule encoding_imp_inj)
qed

context
  fixes \<epsilon> \<delta> :: rat
  fixes n :: nat
  fixes as :: "nat list"
  fixes result
  assumes \<epsilon>_range: "\<epsilon> \<in> {0<..<1}"
  assumes \<delta>_range: "\<delta> > 0"
  assumes as_range: "set as \<subseteq> {..<n}"
  defines "result \<equiv> fold (\<lambda>a state. state \<bind> f2_update a) as (f2_init \<delta> \<epsilon> n) \<bind> f2_result"
begin

private definition s\<^sub>1 where "s\<^sub>1 = nat \<lceil>6 / \<delta>\<^sup>2\<rceil>"

lemma s1_gt_0: "s\<^sub>1 > 0"
    using \<delta>_range by (simp add:s\<^sub>1_def)

private definition s\<^sub>2 where "s\<^sub>2 = nat \<lceil>-(18* ln (real_of_rat \<epsilon>))\<rceil>"

lemma s2_gt_0: "s\<^sub>2 > 0"
    using \<epsilon>_range by (simp add:s\<^sub>2_def)

private definition p where "p = prime_above (max n 3)"

lemma p_prime: "Factorial_Ring.prime p"
  unfolding p_def using prime_above_prime by blast

lemma p_ge_3: "p \<ge> 3"
    unfolding p_def by (meson max.boundedE prime_above_lower_bound)

lemma p_gt_0: "p > 0" using p_ge_3 by linarith

lemma p_gt_1: "p > 1" using p_ge_3 by simp

lemma p_ge_n: "p \<ge> n" unfolding p_def
  by (meson max.boundedE prime_above_lower_bound )

interpretation carter_wegman_hash_family "mod_ring p" 4
  using carter_wegman_hash_familyI[OF mod_ring_is_field mod_ring_finite]
  using p_prime by auto

definition sketch where "sketch = fold (\<lambda>a state. state \<bind> f2_update a) as (f2_init \<delta> \<epsilon> n)"
private definition \<Omega> where"\<Omega> = prod_pmf ({..<s\<^sub>1} \<times> {..<s\<^sub>2}) (\<lambda>_. pmf_of_set space)"
private definition \<Omega>\<^sub>p where"\<Omega>\<^sub>p = measure_pmf \<Omega>"
private definition sketch_rv where "sketch_rv \<omega> = of_int (sum_list (map (f2_hash p \<omega>) as))^2"
private definition mean_rv where "mean_rv \<omega> = (\<lambda>i\<^sub>2. (\<Sum>i\<^sub>1 = 0..<s\<^sub>1. sketch_rv (\<omega> (i\<^sub>1, i\<^sub>2))) / (((of_nat p)\<^sup>2 - 1) * of_nat s\<^sub>1))"
private definition result_rv where "result_rv \<omega> = median s\<^sub>2 (\<lambda>i\<^sub>2\<in>{..<s\<^sub>2}. mean_rv \<omega> i\<^sub>2)"

lemma mean_rv_alg_sketch:
  "sketch = \<Omega> \<bind> (\<lambda>\<omega>. return_pmf (s\<^sub>1, s\<^sub>2, p, \<omega>, \<lambda>i \<in> {..<s\<^sub>1} \<times> {..<s\<^sub>2}. sum_list (map (f2_hash p (\<omega> i)) as)))"
proof -
  have "sketch =  fold (\<lambda>a state. state \<bind> f2_update a) as (f2_init \<delta> \<epsilon> n)"
    by (simp add:sketch_def)
  also have "... = \<Omega> \<bind> (\<lambda>\<omega>. return_pmf (s\<^sub>1, s\<^sub>2, p, \<omega>,
      \<lambda>i \<in> {..<s\<^sub>1} \<times> {..<s\<^sub>2}. sum_list (map (f2_hash p (\<omega> i)) as)))"
  proof (induction as rule:rev_induct)
    case Nil
    then show ?case
      by (simp add:s\<^sub>1_def s\<^sub>2_def space_def p_def[symmetric] \<Omega>_def restrict_def Let_def)
  next
    case (snoc a as)
    have "fold (\<lambda>a state. state \<bind> f2_update a) (as @ [a]) (f2_init \<delta> \<epsilon> n) = \<Omega> \<bind>
      (\<lambda>\<omega>. return_pmf (s\<^sub>1, s\<^sub>2, p, \<omega>, \<lambda>s \<in> {..<s\<^sub>1} \<times> {..<s\<^sub>2}. (\<Sum>x \<leftarrow> as.  f2_hash p (\<omega> s) x)) \<bind> f2_update a)"
      using snoc by (simp add: bind_assoc_pmf restrict_def del:f2_hash.simps f2_init.simps)
    also have "... =  \<Omega> \<bind> (\<lambda>\<omega>. return_pmf (s\<^sub>1, s\<^sub>2, p, \<omega>, \<lambda>i \<in> {..<s\<^sub>1} \<times> {..<s\<^sub>2}. (\<Sum>x \<leftarrow> as@[a].  f2_hash p (\<omega> i) x)))"
      by (subst bind_return_pmf) (simp add: add.commute del:f2_hash.simps cong:restrict_cong)
    finally show ?case by blast
  qed
  finally show ?thesis by auto
qed

lemma distr:  "result = map_pmf result_rv \<Omega>"
proof -
  have "result = sketch \<bind> f2_result"
    by (simp add:result_def sketch_def)
  also have "... = \<Omega> \<bind> (\<lambda>x. f2_result (s\<^sub>1, s\<^sub>2, p, x, \<lambda>i\<in>{..<s\<^sub>1} \<times> {..<s\<^sub>2}. sum_list (map (f2_hash p (x i)) as)))"
    by (simp add: mean_rv_alg_sketch  bind_assoc_pmf bind_return_pmf)
  also have "... = map_pmf result_rv \<Omega>"
    by (simp add:map_pmf_def result_rv_def mean_rv_def sketch_rv_def lessThan_atLeast0 cong:restrict_cong)
  finally show ?thesis by simp
qed

private lemma f2_hash_pow_exp:
  assumes "k < p"
  shows
    "expectation (\<lambda>\<omega>. real_of_int (f2_hash p \<omega> k) ^m) =
     ((real p - 1) ^ m * (real p + 1) + (- real p - 1) ^ m * (real p - 1)) / (2 * real p)"
proof -

  have "odd p" using p_prime p_ge_3 prime_odd_nat assms by simp
  then obtain t where t_def: "p=2*t+1"
    using oddE by blast

  have "Collect even \<inter> {..<2 * t + 1} \<subseteq> (*) 2 ` {..<t + 1}"
    by (rule in_image_by_witness[where g="\<lambda>x. x div 2"], simp, linarith)
  moreover have " (*) 2 ` {..<t + 1} \<subseteq> Collect even \<inter> {..<2 * t + 1}"
    by (rule image_subsetI, simp)
  ultimately have "card ({k. even k} \<inter> {..<p}) = card ((\<lambda>x. 2*x) ` {..<t+1})"
    unfolding t_def using order_antisym by metis
  also have "... = card {..<t+1}"
    by (rule card_image, simp add: inj_on_mult)
  also have "... =  t+1" by simp
  finally have card_even: "card ({k. even k} \<inter> {..<p}) = t+1" by simp
  hence "card ({k. even k} \<inter> {..<p}) * 2 = (p+1)" by (simp add:t_def)
  hence prob_even: "prob {\<omega>. hash k \<omega> \<in> Collect even} = (real p + 1)/(2*real p)"
    using assms by (subst prob_range, auto simp:frac_eq_eq p_gt_0 mod_ring_def)

  have "p = card {..<p}" by simp
  also have "... = card (({k. odd k} \<inter> {..<p}) \<union> ({k. even k} \<inter> {..<p}))"
    by (rule arg_cong[where f="card"], auto)
  also have "... = card ({k. odd k} \<inter> {..<p}) +  card ({k. even k} \<inter> {..<p})"
    by (rule card_Un_disjoint, simp, simp, blast)
  also have "... = card ({k. odd k} \<inter> {..<p}) + t+1"
    by (simp add:card_even)
  finally have "p = card ({k. odd k} \<inter> {..<p}) + t+1"
    by simp
  hence "card ({k. odd k} \<inter> {..<p}) * 2 = (p-1)"
    by (simp add:t_def)
  hence prob_odd: "prob {\<omega>. hash k \<omega> \<in> Collect odd} = (real p - 1)/(2*real p)"
    using assms by (subst prob_range, auto simp add: frac_eq_eq mod_ring_def)

  have "expectation (\<lambda>x. real_of_int (f2_hash p x k) ^ m) =
    expectation (\<lambda>\<omega>. indicator {\<omega>. even (hash k \<omega>)} \<omega> * (real p - 1)^m +
      indicator {\<omega>. odd (hash k \<omega>)} \<omega> * (-real p - 1)^m)"
    by (rule Bochner_Integration.integral_cong, simp, simp)
  also have "... =
     prob {\<omega>. hash  k \<omega> \<in> Collect even}  * (real p - 1) ^ m  +
     prob {\<omega>. hash  k \<omega> \<in> Collect odd}  * (-real p - 1) ^ m "
    by (simp, simp add:M_def)
  also have "... = (real p + 1) * (real p - 1) ^ m / (2 * real p) + (real p - 1) * (- real p - 1) ^ m / (2 * real p)"
    by (subst prob_even, subst prob_odd, simp)
  also have "... =
    ((real p - 1) ^ m * (real p + 1) + (- real p - 1) ^ m * (real p - 1)) / (2 * real p)"
    by (simp add:add_divide_distrib ac_simps)
  finally show "expectation (\<lambda>x. real_of_int (f2_hash p x k) ^ m) =
    ((real p - 1) ^ m * (real p + 1) + (- real p - 1) ^ m * (real p - 1)) / (2 * real p)" by simp
qed

lemma
  shows var_sketch_rv:"variance sketch_rv \<le> 2*(real_of_rat (F 2 as)^2) * ((real p)\<^sup>2-1)\<^sup>2" (is "?A")
  and exp_sketch_rv:"expectation sketch_rv = real_of_rat (F 2 as) * ((real p)\<^sup>2-1)" (is "?B")
proof -
  define h where "h = (\<lambda>\<omega> x. real_of_int (f2_hash p \<omega> x))"
  define c where "c = (\<lambda>x. real (count_list as x))"
  define r where "r = (\<lambda>(m::nat). ((real p - 1) ^ m * (real p + 1) + (- real p - 1) ^ m * (real p - 1)) / (2 * real p))"
  define h_prod where "h_prod = (\<lambda>as \<omega>. prod_list (map (h \<omega>) as))"

  define exp_h_prod :: "nat list \<Rightarrow> real" where "exp_h_prod = (\<lambda>as. (\<Prod>i \<in> set as. r (count_list as i)))"

  have f_eq: "sketch_rv = (\<lambda>\<omega>. (\<Sum>x \<in> set as. c x * h \<omega> x)^2)"
    by (rule ext, simp add:sketch_rv_def c_def h_def sum_list_eval del:f2_hash.simps)

  have r_one: "r (Suc 0) = 0"
    by (simp add:r_def algebra_simps)

  have r_two: "r 2 = (real p^2-1)"
    using p_gt_0 unfolding r_def power2_eq_square
    by (simp add:nonzero_divide_eq_eq, simp add:algebra_simps)

  have"(real p)^2 \<ge> 2^2"
    by (rule power_mono, use p_gt_1 in linarith, simp)
  hence p_square_ge_4: "(real p)\<^sup>2 \<ge> 4" by simp

  have "r 4 = (real p)^4+2*(real p)\<^sup>2 - 3"
    using p_gt_0 unfolding r_def
    by (subst nonzero_divide_eq_eq, auto simp:power4_eq_xxxx power2_eq_square algebra_simps)
  also have "... \<le> (real p)^4+2*(real p)\<^sup>2 + 3"
    by simp
  also have "... \<le> 3 * r 2 * r 2"
    using p_square_ge_4
    by (simp add:r_two power4_eq_xxxx power2_eq_square algebra_simps mult_left_mono)
  finally have r_four_est: "r 4 \<le> 3 * r 2 * r 2"  by simp

  have exp_h_prod_elim: "exp_h_prod = (\<lambda>as. prod_list (map (r \<circ> count_list as) (remdups as)))"
    by (simp add:exp_h_prod_def prod.set_conv_list[symmetric])

  have exp_h_prod: "\<And>x. set x \<subseteq> set as \<Longrightarrow> length x \<le> 4 \<Longrightarrow> expectation (h_prod x) = exp_h_prod x"
  proof -
    fix x
    assume "set x \<subseteq> set as"
    hence x_sub_p: "set x \<subseteq> {..<p}" using as_range p_ge_n by auto
    hence x_le_p: "\<And>k. k \<in> set x \<Longrightarrow> k < p" by auto
    assume "length x \<le> 4"
    hence card_x: "card (set x) \<le> 4" using card_length dual_order.trans by blast

    have "set x \<subseteq> carrier (mod_ring p) "
      using x_sub_p by (simp add:mod_ring_def)

    hence h_indep: "indep_vars (\<lambda>_. borel) (\<lambda>i \<omega>. h \<omega> i ^ count_list x i) (set x)"
      using k_wise_indep_vars_subset[OF k_wise_indep] card_x as_range h_def
      by (auto intro:indep_vars_compose2[where X="hash" and M'=" (\<lambda>_. discrete)"])

    have "expectation (h_prod x) = expectation (\<lambda>\<omega>. \<Prod> i \<in> set x. h \<omega> i^(count_list x i))"
      by (simp add:h_prod_def prod_list_eval)
    also have "... = (\<Prod>i \<in> set x. expectation (\<lambda>\<omega>. h \<omega> i^(count_list x i)))"
      by (simp add: indep_vars_lebesgue_integral[OF _ h_indep])
    also have "... = (\<Prod>i \<in> set x. r (count_list x i))"
      using f2_hash_pow_exp x_le_p
      by (simp add:h_def r_def M_def[symmetric] del:f2_hash.simps)
    also have "... = exp_h_prod x"
      by (simp add:exp_h_prod_def)
    finally show "expectation (h_prod x) = exp_h_prod x" by simp
  qed

  have "\<And>x y. kernel_of x = kernel_of y \<Longrightarrow> exp_h_prod x = exp_h_prod y"
  proof -
    fix x y :: "nat list"
    assume a:"kernel_of x = kernel_of y"
    then obtain f where b:"bij_betw f (set x) (set y)" and c:"\<And>z. z \<in> set x \<Longrightarrow> count_list x z = count_list y (f z)"
      using kernel_of_eq_imp_bij by blast
    have "exp_h_prod x = prod ( (\<lambda>i. r(count_list y i)) \<circ> f) (set x)"
      by (simp add:exp_h_prod_def c)
    also have "... = (\<Prod>i \<in> f ` (set x). r(count_list y i))"
      by (metis b bij_betw_def prod.reindex)
    also have "... = exp_h_prod y"
      unfolding exp_h_prod_def
      by (rule prod.cong, metis b bij_betw_def) simp
    finally show "exp_h_prod x = exp_h_prod y" by simp
  qed

  hence exp_h_prod_cong: "\<And>p x. of_bool (kernel_of x = kernel_of p) * exp_h_prod p =
    of_bool (kernel_of x = kernel_of p) * exp_h_prod x"
    by (metis (full_types) of_bool_eq_0_iff vector_space_over_itself.scale_zero_left)

  have c:"(\<Sum>p\<leftarrow>enum_rgfs n. of_bool (kernel_of xs = kernel_of p) * r) = r"
    if a:"length xs = n" for xs :: "nat list" and n and r :: real
  proof -
    have "(\<Sum>p\<leftarrow>enum_rgfs n. of_bool (kernel_of xs = kernel_of p) * 1) = (1::real)"
      using equiv_rels_2[OF a[symmetric]] by (simp add:equiv_rels_def comp_def)
    thus "(\<Sum>p\<leftarrow>enum_rgfs n. of_bool (kernel_of xs = kernel_of p) * r) = (r::real)"
      by (simp add:sum_list_mult_const)
  qed

  have "expectation sketch_rv = (\<Sum>i\<in>set as. (\<Sum>j\<in>set as. c i * c j * expectation (h_prod [i,j])))"
    by (simp add:f_eq h_prod_def power2_eq_square sum_distrib_left sum_distrib_right Bochner_Integration.integral_sum algebra_simps)
  also have "... = (\<Sum>i\<in>set as. (\<Sum>j\<in>set as. c i * c j * exp_h_prod [i,j]))"
    by (simp add:exp_h_prod)
  also have "... = (\<Sum>i \<in> set as. (\<Sum>j \<in> set as.
    c i * c j * (sum_list (map (\<lambda>p. of_bool (kernel_of [i,j] = kernel_of p) * exp_h_prod p) (enum_rgfs 2)))))"
    by (subst exp_h_prod_cong, simp add:c)
  also have "... = (\<Sum>i\<in>set as. c i * c i * r 2)"
    by (simp add: numeral_eq_Suc kernel_of_eq All_less_Suc exp_h_prod_elim r_one distrib_left sum.distrib sum_collapse)
  also have "... = real_of_rat (F 2 as) * ((real p)^2-1)"
    by (simp add: sum_distrib_right[symmetric] c_def F_def power2_eq_square of_rat_sum of_rat_mult r_two)
  finally show b:?B by simp

  have "expectation (\<lambda>x. (sketch_rv x)\<^sup>2) = (\<Sum>i1 \<in> set as. (\<Sum>i2 \<in> set as. (\<Sum>i3 \<in> set as. (\<Sum>i4 \<in> set as.
    c i1 * c i2 * c i3 * c i4 * expectation (h_prod [i1, i2, i3, i4])))))"
    by (simp add:f_eq h_prod_def power4_eq_xxxx sum_distrib_left sum_distrib_right Bochner_Integration.integral_sum algebra_simps)
  also have "... = (\<Sum>i1 \<in> set as. (\<Sum>i2 \<in> set as. (\<Sum>i3 \<in> set as. (\<Sum>i4 \<in> set as.
    c i1 * c i2 * c i3 * c i4 * exp_h_prod [i1,i2,i3,i4]))))"
    by (simp add:exp_h_prod)
  also have "... = (\<Sum>i1 \<in> set as. (\<Sum>i2 \<in> set as. (\<Sum>i3 \<in> set as. (\<Sum>i4 \<in> set as.
    c i1 * c i2 * c i3 * c i4 *
    (sum_list (map (\<lambda>p. of_bool (kernel_of [i1,i2,i3,i4] = kernel_of p) * exp_h_prod p) (enum_rgfs 4)))))))"
    by (subst exp_h_prod_cong, simp add:c)
  also have "... =
    3 * (\<Sum>i \<in> set as. (\<Sum>j \<in> set as. c i^2 * c j^2 * r 2 * r 2)) + ((\<Sum> i \<in> set as. c i^4 * r 4) - 3 *  (\<Sum> i \<in> set as. c i ^ 4 * r 2 * r 2))"
    apply (simp add: numeral_eq_Suc exp_h_prod_elim r_one) (* large intermediate terms *)
    apply (simp add: kernel_of_eq All_less_Suc numeral_eq_Suc distrib_left sum.distrib sum_collapse neq_commute of_bool_not_iff)
    apply (simp add: algebra_simps sum_subtractf sum_collapse)
    apply (simp add: sum_distrib_left algebra_simps)
    done
  also have "... = 3 * (\<Sum>i \<in> set as. c i^2 * r 2)^2 + (\<Sum> i \<in> set as. c i ^ 4 * (r 4 - 3 * r 2 * r 2))"
    by (simp add:power2_eq_square sum_distrib_left algebra_simps sum_subtractf)
  also have "... = 3 * (\<Sum>i \<in> set as. c i^2)^2 * (r 2)^2 + (\<Sum>i \<in> set as. c i ^ 4 * (r 4 - 3 * r 2 * r 2))"
    by (simp add:power_mult_distrib sum_distrib_right[symmetric])
  also have "... \<le> 3 * (\<Sum>i \<in> set as. c i^2)^2 * (r 2)^2 + (\<Sum>i \<in> set as. c i ^ 4 * 0)"
    using r_four_est
    by (auto intro!: sum_nonpos simp add:mult_nonneg_nonpos)
  also have "... = 3 * (real_of_rat (F 2 as)^2) * ((real p)\<^sup>2-1)\<^sup>2"
    by (simp add:c_def r_two F_def of_rat_sum of_rat_power)
  finally have "expectation (\<lambda>x. (sketch_rv x)\<^sup>2) \<le> 3 * (real_of_rat (F 2 as)^2) * ((real p)\<^sup>2-1)\<^sup>2"
    by simp

  thus "variance sketch_rv \<le> 2*(real_of_rat (F 2 as)^2) * ((real p)\<^sup>2-1)\<^sup>2"
     by (simp add: variance_eq, simp add:power_mult_distrib b)
qed

lemma space_omega_1 [simp]: "Sigma_Algebra.space \<Omega>\<^sub>p = UNIV"
    by (simp add:\<Omega>\<^sub>p_def)

interpretation \<Omega>: prob_space "\<Omega>\<^sub>p"
  by (simp add:\<Omega>\<^sub>p_def prob_space_measure_pmf)

lemma integrable_\<Omega>:
  fixes f :: "((nat \<times> nat) \<Rightarrow> (nat list)) \<Rightarrow> real"
  shows "integrable \<Omega>\<^sub>p f"
  unfolding \<Omega>\<^sub>p_def \<Omega>_def
  by (rule integrable_measure_pmf_finite, auto intro:finite_PiE simp:set_prod_pmf)

lemma sketch_rv_exp:
  assumes "i\<^sub>2 < s\<^sub>2"
  assumes "i\<^sub>1 \<in> {0..<s\<^sub>1}"
  shows "\<Omega>.expectation (\<lambda>\<omega>. sketch_rv (\<omega> (i\<^sub>1, i\<^sub>2))) = real_of_rat (F 2 as) * ((real p)\<^sup>2 - 1)"
proof -
  have "\<Omega>.expectation (\<lambda>\<omega>.  (sketch_rv (\<omega> (i\<^sub>1, i\<^sub>2))) :: real) = expectation sketch_rv"
    using integrable_\<Omega> integrable_M assms
    unfolding \<Omega>_def \<Omega>\<^sub>p_def M_def
    by (subst expectation_Pi_pmf_slice, auto)
  also have "... = (real_of_rat (F 2 as)) * ((real p)\<^sup>2 - 1)"
    using exp_sketch_rv by simp
  finally show ?thesis by simp
qed

lemma sketch_rv_var:
  assumes "i\<^sub>2 < s\<^sub>2"
  assumes "i\<^sub>1 \<in> {0..<s\<^sub>1}"
  shows "\<Omega>.variance (\<lambda>\<omega>. sketch_rv (\<omega> (i\<^sub>1, i\<^sub>2))) \<le> 2 * (real_of_rat (F 2 as))\<^sup>2 * ((real p)\<^sup>2 - 1)\<^sup>2"
proof -
  have "\<Omega>.variance (\<lambda>\<omega>. (sketch_rv (\<omega> (i\<^sub>1, i\<^sub>2)) :: real)) = variance sketch_rv"
    using integrable_\<Omega> integrable_M assms
    unfolding \<Omega>_def \<Omega>\<^sub>p_def M_def
    by (subst variance_prod_pmf_slice, auto)
  also have "... \<le>  2 * (real_of_rat (F 2 as))\<^sup>2 * ((real p)\<^sup>2 - 1)\<^sup>2"
    using var_sketch_rv by simp
  finally show ?thesis by simp
qed

lemma mean_rv_exp:
  assumes "i < s\<^sub>2"
  shows "\<Omega>.expectation (\<lambda>\<omega>. mean_rv \<omega> i) = real_of_rat (F 2 as)"
proof -
  have a:"(real p)\<^sup>2 > 1" using p_gt_1 by simp

  have "\<Omega>.expectation (\<lambda>\<omega>. mean_rv \<omega> i) = (\<Sum>i\<^sub>1 = 0..<s\<^sub>1. \<Omega>.expectation (\<lambda>\<omega>. sketch_rv (\<omega> (i\<^sub>1, i)))) / (((real p)\<^sup>2 - 1) * real s\<^sub>1)"
    using assms integrable_\<Omega> by (simp add:mean_rv_def)
  also have "... = (\<Sum>i\<^sub>1 = 0..<s\<^sub>1. real_of_rat (F 2 as) * ((real p)\<^sup>2 - 1)) / (((real p)\<^sup>2 - 1) * real s\<^sub>1)"
    using sketch_rv_exp[OF assms] by simp
  also have "... = real_of_rat (F 2 as)"
    using s1_gt_0 a by simp
  finally show ?thesis by simp
qed

lemma mean_rv_var:
  assumes "i < s\<^sub>2"
  shows "\<Omega>.variance (\<lambda>\<omega>. mean_rv \<omega> i) \<le> (real_of_rat (\<delta> * F 2 as))\<^sup>2 / 3"
proof -
  have a: "\<Omega>.indep_vars (\<lambda>_. borel) (\<lambda>i\<^sub>1 x. sketch_rv (x (i\<^sub>1, i))) {0..<s\<^sub>1}"
    using assms
    unfolding \<Omega>\<^sub>p_def \<Omega>_def
    by (intro indep_vars_restrict_intro'[where f="fst"])
     (auto simp add: restrict_dfl_def case_prod_beta lessThan_atLeast0)

  have p_sq_ne_1: "(real p)^2 \<noteq> 1"
    by (metis p_gt_1 less_numeral_extra(4) of_nat_power one_less_power pos2 semiring_char_0_class.of_nat_eq_1_iff)

  have s1_bound: " 6 / (real_of_rat \<delta>)\<^sup>2 \<le> real s\<^sub>1"
    unfolding s\<^sub>1_def
    by  (metis (mono_tags, opaque_lifting) of_rat_ceiling of_rat_divide of_rat_numeral_eq of_rat_power real_nat_ceiling_ge)

  have "\<Omega>.variance (\<lambda>\<omega>. mean_rv \<omega> i) = \<Omega>.variance (\<lambda>\<omega>. \<Sum>i\<^sub>1 = 0..<s\<^sub>1. sketch_rv (\<omega> (i\<^sub>1, i))) / (((real p)\<^sup>2 - 1) * real s\<^sub>1)\<^sup>2"
    unfolding mean_rv_def by (subst \<Omega>.variance_divide[OF integrable_\<Omega>], simp)
  also have "... = (\<Sum>i\<^sub>1 = 0..<s\<^sub>1. \<Omega>.variance (\<lambda>\<omega>. sketch_rv (\<omega> (i\<^sub>1, i)))) / (((real p)\<^sup>2 - 1) * real s\<^sub>1)\<^sup>2"
    by (subst \<Omega>.var_sum_all_indep[OF _ _ integrable_\<Omega> a]) (auto simp: \<Omega>_def \<Omega>\<^sub>p_def)
  also have "... \<le>  (\<Sum>i\<^sub>1 = 0..<s\<^sub>1. 2*(real_of_rat (F 2 as)^2) * ((real p)\<^sup>2-1)\<^sup>2)  / (((real p)\<^sup>2 - 1) * real s\<^sub>1)\<^sup>2"
    by (rule divide_right_mono, rule sum_mono[OF sketch_rv_var[OF assms]], auto)
  also have "... = 2 * (real_of_rat (F 2 as)^2) / real s\<^sub>1"
    using p_sq_ne_1 s1_gt_0 by (subst frac_eq_eq, auto simp:power2_eq_square)
  also have "... \<le> 2 * (real_of_rat (F 2 as)^2) / (6 / (real_of_rat \<delta>)\<^sup>2)"
    using  s1_gt_0 \<delta>_range by (intro divide_left_mono mult_pos_pos s1_bound) auto
  also have "... = (real_of_rat (\<delta> * F 2 as))\<^sup>2 / 3"
    by (simp add:of_rat_mult algebra_simps)
  finally show ?thesis by simp
qed

lemma mean_rv_bounds:
  assumes "i < s\<^sub>2"
  shows "\<Omega>.prob {\<omega>. real_of_rat \<delta> * real_of_rat (F 2 as) < \<bar>mean_rv \<omega> i - real_of_rat (F 2 as)\<bar>} \<le> 1/3"
proof (cases "as = []")
  case True
  then show ?thesis
    using assms by (subst mean_rv_def, subst sketch_rv_def, simp add:F_def)
next
  case False
  hence "F 2 as > 0" using F_gr_0 by auto

  hence a: "0 < real_of_rat (\<delta> * F 2 as)"
    using \<delta>_range by simp
  have [simp]: "(\<lambda>\<omega>. mean_rv \<omega> i) \<in> borel_measurable \<Omega>\<^sub>p"
    by (simp add:\<Omega>_def \<Omega>\<^sub>p_def)
  have "\<Omega>.prob {\<omega>. real_of_rat \<delta> * real_of_rat (F 2 as) < \<bar>mean_rv \<omega> i - real_of_rat (F 2 as)\<bar>} \<le>
      \<Omega>.prob {\<omega>. real_of_rat (\<delta> * F 2 as) \<le> \<bar>mean_rv \<omega> i - real_of_rat (F 2 as)\<bar>}"
    by (rule \<Omega>.pmf_mono[OF \<Omega>\<^sub>p_def], simp add:of_rat_mult)
  also have "... \<le>  \<Omega>.variance (\<lambda>\<omega>. mean_rv \<omega> i) / (real_of_rat (\<delta> * F 2 as))\<^sup>2"
    using \<Omega>.Chebyshev_inequality[where a="real_of_rat (\<delta> * F 2 as)" and f="\<lambda>\<omega>. mean_rv \<omega> i",simplified]
      a prob_space_measure_pmf[where p="\<Omega>"] mean_rv_exp[OF assms] integrable_\<Omega> by simp
  also have "... \<le> ((real_of_rat (\<delta> * F 2 as))\<^sup>2/3) / (real_of_rat (\<delta> * F 2 as))\<^sup>2"
    by (rule divide_right_mono, rule mean_rv_var[OF assms], simp)
  also  have "... = 1/3" using a by force
  finally show ?thesis by blast
qed

lemma f2_alg_correct':
   "\<P>(\<omega> in measure_pmf result. \<bar>\<omega> - F 2 as\<bar> \<le> \<delta> * F 2 as) \<ge> 1-of_rat \<epsilon>"
proof -
  have a: "\<Omega>.indep_vars (\<lambda>_. borel) (\<lambda>i \<omega>. mean_rv \<omega> i) {0..<s\<^sub>2}"
    using s1_gt_0 unfolding \<Omega>\<^sub>p_def \<Omega>_def
    by (intro indep_vars_restrict_intro'[where f="snd"])
      (auto simp: \<Omega>\<^sub>p_def \<Omega>_def mean_rv_def restrict_dfl_def)

  have b: "- 18 * ln (real_of_rat \<epsilon>) \<le> real s\<^sub>2"
    unfolding  s\<^sub>2_def using of_nat_ceiling by auto

  have "1 - of_rat \<epsilon> \<le> \<Omega>.prob {\<omega>.  \<bar>median s\<^sub>2 (mean_rv \<omega>) -  real_of_rat (F 2 as) \<bar> \<le> of_rat \<delta> * of_rat (F 2 as)}"
    using \<epsilon>_range \<Omega>.median_bound_2[OF _ a b, where \<delta>="real_of_rat \<delta> * real_of_rat (F 2 as)"
        and \<mu>="real_of_rat (F 2 as)"] mean_rv_bounds
    by simp
  also have "... = \<Omega>.prob {\<omega>.  \<bar>real_of_rat (result_rv \<omega>) - of_rat (F 2 as) \<bar> \<le> of_rat \<delta> * of_rat (F 2 as)}"
    by (simp add:result_rv_def median_restrict lessThan_atLeast0 median_rat[OF s2_gt_0]
         mean_rv_def sketch_rv_def of_rat_divide of_rat_sum of_rat_mult of_rat_diff of_rat_power)
  also have "... = \<Omega>.prob {\<omega>. \<bar>result_rv \<omega> - F 2 as\<bar> \<le> \<delta> * F 2 as} "
    by (simp add:of_rat_less_eq of_rat_mult[symmetric]  of_rat_diff[symmetric] set_eq_iff)
  finally have "\<Omega>.prob {y. \<bar>result_rv y - F 2 as\<bar> \<le> \<delta> * F 2 as} \<ge> 1-of_rat \<epsilon> " by simp
  thus ?thesis by (simp add: distr \<Omega>\<^sub>p_def)
qed

lemma f2_exact_space_usage':
   "AE \<omega> in sketch . bit_count (encode_f2_state \<omega>) \<le> f2_space_usage (n, length as, \<epsilon>, \<delta>)"
proof -
  have "p \<le> 2 * max n 3 + 2"
    by (subst p_def, rule prime_above_upper_bound)
  also have "... \<le> 2 * n + 8"
    by (cases "n \<le> 2", simp_all)
  finally have p_bound: "p \<le> 2 * n + 8"
    by simp
  have "bit_count (N\<^sub>e p) \<le> ereal (2 * log 2 (real p + 1) + 1)"
    by (rule exp_golomb_bit_count)
  also have "... \<le> ereal (2 * log 2 (2 * real n + 9) + 1)"
    using p_bound by simp
  finally have p_bit_count: "bit_count (N\<^sub>e p) \<le> ereal (2 * log 2 (2 * real n + 9) + 1)"
    by simp

  have a: "bit_count (encode_f2_state (s\<^sub>1, s\<^sub>2, p, y, \<lambda>i\<in>{..<s\<^sub>1} \<times> {..<s\<^sub>2}.
      sum_list (map (f2_hash p (y i)) as))) \<le> ereal (f2_space_usage (n, length as, \<epsilon>, \<delta>))"
    if a:"y\<in>{..<s\<^sub>1} \<times> {..<s\<^sub>2} \<rightarrow>\<^sub>E bounded_degree_polynomials (mod_ring p) 4" for y
  proof -
    have "y \<in> extensional ({..<s\<^sub>1} \<times> {..<s\<^sub>2})" using a PiE_iff by blast
    hence y_ext: "y \<in> extensional (set (List.product [0..<s\<^sub>1] [0..<s\<^sub>2]))"
      by (simp add:lessThan_atLeast0)

    have h_bit_count_aux: "bit_count (P\<^sub>e p 4 (y x)) \<le> ereal (4 + 4 * log 2 (8 + 2 * real n))"
      if b:"x \<in>  set (List.product [0..<s\<^sub>1] [0..<s\<^sub>2])" for x
    proof -
      have "y x \<in> bounded_degree_polynomials (Field.mod_ring p) 4"
        using b a by force
      hence "bit_count (P\<^sub>e p 4 (y x)) \<le> ereal ( real 4 * (log 2 (real p) + 1))"
        by (rule bounded_degree_polynomial_bit_count[OF p_gt_1] )
      also have "... \<le> ereal (real 4 * (log 2 (8 + 2 * real n) + 1) )"
        using p_gt_0 p_bound by simp
      also have "... \<le> ereal (4 + 4 * log 2 (8 + 2 * real n))"
        by simp
      finally show ?thesis
        by blast
    qed

    have h_bit_count:
      "bit_count ((List.product [0..<s\<^sub>1] [0..<s\<^sub>2] \<rightarrow>\<^sub>e P\<^sub>e p 4) y) \<le> ereal (real s\<^sub>1 * real s\<^sub>2 * (4 + 4 * log 2 (8 + 2 * real n)))"
      using fun_bit_count_est[where e="P\<^sub>e p 4", OF y_ext h_bit_count_aux]
      by simp

    have sketch_bit_count_aux:
      "bit_count (I\<^sub>e (sum_list (map (f2_hash p (y x)) as))) \<le> ereal (1 + 2 * log 2 (real (length as) * (18 + 4 * real n) + 1))" (is "?lhs \<le> ?rhs")
      if " x \<in> {0..<s\<^sub>1} \<times> {0..<s\<^sub>2}" for x
    proof -
      have "\<bar>sum_list (map (f2_hash p (y x)) as)\<bar> \<le> sum_list (map (abs \<circ> (f2_hash p (y x))) as)"
        by (subst map_map[symmetric])  (rule sum_list_abs)
      also have "... \<le>  sum_list (map (\<lambda>_. (int p+1)) as)"
        by (rule sum_list_mono) (simp add:p_gt_0)
      also have "... = int (length as) * (int p+1)"
        by (simp add: sum_list_triv)
      also have "... \<le> int (length as) * (9+2*(int n))"
        using p_bound by (intro mult_mono, auto)
      finally  have "\<bar>sum_list (map (f2_hash p (y x)) as)\<bar> \<le> int (length as) * (9 + 2 * int n)" by simp
      hence "?lhs \<le> ereal (2 * log 2 (real_of_int (2* (int (length as) * (9 + 2 * int n)) + 1)) + 1)"
        by (rule int_bit_count_est)
      also have "... = ?rhs" by (simp add:algebra_simps)
      finally show "?thesis" by simp
    qed

    have
      "bit_count ((List.product [0..<s\<^sub>1] [0..<s\<^sub>2] \<rightarrow>\<^sub>e I\<^sub>e) (\<lambda>i\<in>{..<s\<^sub>1} \<times> {..<s\<^sub>2}. sum_list (map (f2_hash p (y i)) as)))
      \<le> ereal (real (length (List.product [0..<s\<^sub>1] [0..<s\<^sub>2]))) * (ereal (1 + 2 * log 2 (real (length as) * (18 + 4 * real n) + 1)))"
      by (intro fun_bit_count_est)
       (simp_all add:extensional_def lessThan_atLeast0 sketch_bit_count_aux del:f2_hash.simps)
    also have "... = ereal (real s\<^sub>1 * real s\<^sub>2 * (1 + 2 * log 2 (real (length as) * (18 + 4 * real n) + 1)))"
      by simp
    finally have sketch_bit_count:
       "bit_count ((List.product [0..<s\<^sub>1] [0..<s\<^sub>2] \<rightarrow>\<^sub>e I\<^sub>e) (\<lambda>i\<in>{..<s\<^sub>1} \<times> {..<s\<^sub>2}. sum_list (map (f2_hash p (y i)) as))) \<le>
      ereal (real s\<^sub>1 * real s\<^sub>2 * (1 + 2 * log 2 (real (length as) * (18 + 4 * real n) + 1)))" by simp

    have "bit_count (encode_f2_state (s\<^sub>1, s\<^sub>2, p, y, \<lambda>i\<in>{..<s\<^sub>1} \<times> {..<s\<^sub>2}. sum_list (map (f2_hash p (y i)) as))) \<le>
      bit_count (N\<^sub>e s\<^sub>1) + bit_count (N\<^sub>e s\<^sub>2) +bit_count (N\<^sub>e p) +
      bit_count ((List.product [0..<s\<^sub>1] [0..<s\<^sub>2] \<rightarrow>\<^sub>e P\<^sub>e p 4) y) +
      bit_count ((List.product [0..<s\<^sub>1] [0..<s\<^sub>2] \<rightarrow>\<^sub>e I\<^sub>e) (\<lambda>i\<in>{..<s\<^sub>1} \<times> {..<s\<^sub>2}. sum_list (map (f2_hash p (y i)) as)))"
      by (simp add:Let_def s\<^sub>1_def s\<^sub>2_def encode_f2_state_def dependent_bit_count add.assoc)
    also have "... \<le> ereal (2 * log 2 (real s\<^sub>1 + 1) + 1) + ereal (2 * log 2 (real s\<^sub>2 + 1) + 1) + ereal (2 * log 2 (2 * real n + 9) + 1) +
      (ereal (real s\<^sub>1 * real s\<^sub>2) * (4 + 4 * log 2 (8 + 2 * real n))) +
      (ereal (real s\<^sub>1 * real s\<^sub>2) * (1 + 2 * log 2 (real (length as) * (18 + 4 * real n) + 1) ))"
      by (intro add_mono exp_golomb_bit_count p_bit_count, auto intro: h_bit_count sketch_bit_count)
    also have "... = ereal (f2_space_usage (n, length as, \<epsilon>, \<delta>))"
      by (simp add:distrib_left add.commute s\<^sub>1_def[symmetric] s\<^sub>2_def[symmetric] Let_def)
    finally show "bit_count (encode_f2_state (s\<^sub>1, s\<^sub>2, p, y, \<lambda>i\<in>{..<s\<^sub>1} \<times> {..<s\<^sub>2}. sum_list (map (f2_hash p (y i)) as))) \<le>
      ereal (f2_space_usage (n, length as, \<epsilon>, \<delta>))"
      by simp
  qed

  have "set_pmf \<Omega> = {..<s\<^sub>1} \<times> {..<s\<^sub>2} \<rightarrow>\<^sub>E bounded_degree_polynomials (Field.mod_ring p) 4"
    by (simp add: \<Omega>_def set_prod_pmf)  (simp add: space_def)
  thus ?thesis
    by (simp  add:mean_rv_alg_sketch AE_measure_pmf_iff del:f2_space_usage.simps, metis a)
qed

end

text \<open>Main results of this section:\<close>

theorem f2_alg_correct:
  assumes "\<epsilon> \<in> {0<..<1}"
  assumes "\<delta> > 0"
  assumes "set as \<subseteq> {..<n}"
  defines "\<Omega> \<equiv> fold (\<lambda>a state. state \<bind> f2_update a) as (f2_init \<delta> \<epsilon> n) \<bind> f2_result"
  shows "\<P>(\<omega> in measure_pmf \<Omega>. \<bar>\<omega> - F 2 as\<bar> \<le> \<delta> * F 2 as) \<ge> 1-of_rat \<epsilon>"
  using f2_alg_correct'[OF assms(1,2,3)] \<Omega>_def by auto

theorem f2_exact_space_usage:
  assumes "\<epsilon> \<in> {0<..<1}"
  assumes "\<delta> > 0"
  assumes "set as \<subseteq> {..<n}"
  defines "M \<equiv> fold (\<lambda>a state. state \<bind> f2_update a) as (f2_init \<delta> \<epsilon> n)"
  shows "AE \<omega> in M. bit_count (encode_f2_state \<omega>) \<le> f2_space_usage (n, length as, \<epsilon>, \<delta>)"
  using f2_exact_space_usage'[OF assms(1,2,3)]
  by (subst (asm) sketch_def[OF assms(1,2,3)], subst M_def, simp)

theorem f2_asymptotic_space_complexity:
  "f2_space_usage \<in> O[at_top \<times>\<^sub>F at_top \<times>\<^sub>F at_right 0 \<times>\<^sub>F at_right 0](\<lambda> (n, m, \<epsilon>, \<delta>).
  (ln (1 / of_rat \<epsilon>)) / (of_rat \<delta>)\<^sup>2 * (ln (real n) + ln (real m)))"
  (is "_ \<in> O[?F](?rhs)")
proof -
  define n_of :: "nat \<times> nat \<times> rat \<times> rat \<Rightarrow> nat" where "n_of = (\<lambda>(n, m, \<epsilon>, \<delta>). n)"
  define m_of :: "nat \<times> nat \<times> rat \<times> rat \<Rightarrow> nat" where "m_of = (\<lambda>(n, m, \<epsilon>, \<delta>). m)"
  define \<epsilon>_of :: "nat \<times> nat \<times> rat \<times> rat \<Rightarrow> rat" where "\<epsilon>_of = (\<lambda>(n, m, \<epsilon>, \<delta>). \<epsilon>)"
  define \<delta>_of :: "nat \<times> nat \<times> rat \<times> rat \<Rightarrow> rat" where "\<delta>_of = (\<lambda>(n, m, \<epsilon>, \<delta>). \<delta>)"

  define g where "g = (\<lambda>x. (1/ (of_rat (\<delta>_of x))\<^sup>2) * (ln (1 / of_rat (\<epsilon>_of x))) * (ln (real (n_of x)) + ln (real (m_of x))))"

  have evt: "(\<And>x.
    0 < real_of_rat (\<delta>_of x) \<and> 0 < real_of_rat (\<epsilon>_of x) \<and>
    1/real_of_rat (\<delta>_of x) \<ge> \<delta> \<and> 1/real_of_rat (\<epsilon>_of x) \<ge> \<epsilon> \<and>
    real (n_of x) \<ge> n \<and> real (m_of x) \<ge> m\<Longrightarrow> P x)
    \<Longrightarrow> eventually P ?F"  (is "(\<And>x. ?prem x \<Longrightarrow> _) \<Longrightarrow> _")
    for \<delta> \<epsilon> n m P
    apply (rule eventually_mono[where P="?prem" and Q="P"])
    apply (simp add:\<epsilon>_of_def case_prod_beta' \<delta>_of_def n_of_def m_of_def)
     apply (intro eventually_conj eventually_prod1' eventually_prod2'
        sequentially_inf eventually_at_right_less inv_at_right_0_inf)
    by (auto simp add:prod_filter_eq_bot)

  have unit_1: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. 1 / (real_of_rat (\<delta>_of x))\<^sup>2)"
    using one_le_power
    by (intro landau_o.big_mono evt[where \<delta>="1"], auto simp add:power_one_over[symmetric])

  have unit_2: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. ln (1 / real_of_rat (\<epsilon>_of x)))"
    by (intro landau_o.big_mono  evt[where \<epsilon>="exp 1"])
     (auto intro!:iffD2[OF ln_ge_iff] simp add:abs_ge_iff)

  have unit_3: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. real (n_of x))"
    by (intro landau_o.big_mono evt, auto)

  have unit_4: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. real (m_of x))"
    by (intro landau_o.big_mono evt, auto)

  have unit_5: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. ln (real (n_of x)))"
    by (auto intro!: landau_o.big_mono evt[where n="exp 1"])
      (metis abs_ge_self linorder_not_le ln_ge_iff not_exp_le_zero order.trans)

  have unit_6: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. ln (real (n_of x)) + ln (real (m_of x)))"
    by (intro landau_sum_1 evt unit_5 iffD2[OF ln_ge_iff], auto)

  have unit_7: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. 1 / real_of_rat (\<epsilon>_of x))"
    by (intro landau_o.big_mono  evt[where \<epsilon>="1"], auto)

  have unit_8: "(\<lambda>_. 1) \<in> O[?F](g)"
    unfolding g_def by (intro landau_o.big_mult_1 unit_1 unit_2 unit_6)

  have unit_9: "(\<lambda>_. 1) \<in> O[?F](\<lambda>x. real (n_of x) * real (m_of x))"
    by (intro landau_o.big_mult_1 unit_3 unit_4)

  have " (\<lambda>x. 6 * (1 / (real_of_rat (\<delta>_of x))\<^sup>2)) \<in> O[?F](\<lambda>x. 1 / (real_of_rat (\<delta>_of x))\<^sup>2)"
    by (subst landau_o.big.cmult_in_iff, simp_all)
  hence l1: "(\<lambda>x. real (nat \<lceil>6 / (\<delta>_of x)\<^sup>2\<rceil>)) \<in> O[?F](\<lambda>x. 1 / (real_of_rat (\<delta>_of x))\<^sup>2)"
    by (intro landau_real_nat  landau_rat_ceil[OF unit_1]) (simp_all add:of_rat_divide of_rat_power)

  have "(\<lambda>x. - ( ln (real_of_rat (\<epsilon>_of x)))) \<in> O[?F](\<lambda>x. ln (1 / real_of_rat (\<epsilon>_of x)))"
    by (intro landau_o.big_mono evt) (subst ln_div, auto)
  hence l2: "(\<lambda>x. real (nat \<lceil>- (18 * ln (real_of_rat (\<epsilon>_of x)))\<rceil>)) \<in> O[?F](\<lambda>x. ln (1 / real_of_rat (\<epsilon>_of x)))"
    by (intro landau_real_nat landau_ceil[OF unit_2], simp)

  have l3_aux: " (\<lambda>x. real (m_of x) * (18 + 4 * real (n_of x)) + 1) \<in> O[?F](\<lambda>x. real (n_of x) * real (m_of x))"
    by (rule sum_in_bigo[OF _unit_9], subst mult.commute)
      (intro landau_o.mult sum_in_bigo, auto simp:unit_3)

  have "(\<lambda>x. ln (real (m_of x) * (18 + 4 * real (n_of x)) + 1)) \<in> O[?F](\<lambda>x. ln (real (n_of x) * real (m_of x)))"
     apply (rule landau_ln_2[where a="2"], simp, simp)
      apply (rule evt[where m="2" and n="1"])
     apply (metis dual_order.trans mult_left_mono mult_of_nat_commute of_nat_0_le_iff verit_prod_simplify(1))
    using l3_aux by simp
  also have "(\<lambda>x. ln (real (n_of x) * real (m_of x))) \<in> O[?F](\<lambda>x. ln (real (n_of x)) + ln(real (m_of x)))"
    by (intro landau_o.big_mono evt[where m="1" and n="1"], auto simp add:ln_mult)
  finally have l3: "(\<lambda>x. ln (real (m_of x) * (18 + 4 * real (n_of x)) + 1)) \<in> O[?F](\<lambda>x. ln (real (n_of x)) + ln (real (m_of x)))"
    using  landau_o.big_trans by simp

  have l4: "(\<lambda>x. ln (8 + 2 * real (n_of x))) \<in> O[?F](\<lambda>x. ln (real (n_of x)) + ln (real (m_of x)))"
    by (intro landau_sum_1  evt[where n="2"] landau_ln_2[where a="2"] iffD2[OF ln_ge_iff])
     (auto intro!: sum_in_bigo simp add:unit_3)

  have l5: "(\<lambda>x. ln (9 + 2 * real (n_of x))) \<in> O[?F](\<lambda>x. ln (real (n_of x)) + ln (real (m_of x)))"
    by (intro landau_sum_1  evt[where n="2"] landau_ln_2[where a="2"] iffD2[OF ln_ge_iff])
     (auto intro!: sum_in_bigo simp add:unit_3)

  have l6: "(\<lambda>x. ln (real (nat \<lceil>6 / (\<delta>_of x)\<^sup>2\<rceil>) + 1)) \<in> O[?F](g)"
    unfolding g_def
    by (intro landau_o.big_mult_1 landau_ln_3 sum_in_bigo unit_6 unit_2 l1 unit_1, simp)

  have l7: "(\<lambda>x. ln (9 + 2 * real (n_of x))) \<in> O[?F](g)"
    unfolding g_def
    by (intro landau_o.big_mult_1' unit_1 unit_2 l5)

  have l8: "(\<lambda>x. ln (real (nat \<lceil>- (18 * ln (real_of_rat (\<epsilon>_of x)))\<rceil>) + 1) ) \<in> O[?F](g)"
    unfolding g_def
    by (intro landau_o.big_mult_1 unit_6 landau_o.big_mult_1' unit_1 landau_ln_3  sum_in_bigo l2 unit_2) simp

  have l9: "(\<lambda>x. 5 + 4 * ln (8 + 2 * real (n_of x)) / ln 2 + 2 * ln (real (m_of x) * (18 + 4 * real (n_of x)) + 1) / ln 2)
      \<in> O[?F](\<lambda>x. ln (real (n_of x)) + ln (real (m_of x)))"
    by (intro sum_in_bigo, auto simp: l3 l4 unit_6)

  have l10: "(\<lambda>x. real (nat \<lceil>6 / (\<delta>_of x)\<^sup>2\<rceil>) * real (nat \<lceil>- (18 * ln (real_of_rat (\<epsilon>_of x)))\<rceil>) *
      (5 + 4 * ln (8 + 2 * real (n_of x)) / ln 2 + 2 * ln(real (m_of x) * (18 + 4 * real (n_of x)) + 1) / ln 2))
      \<in> O[?F](g)"
    unfolding g_def by (intro landau_o.mult, auto simp: l1 l2 l9)

  have "f2_space_usage = (\<lambda>x. f2_space_usage (n_of x, m_of x, \<epsilon>_of x, \<delta>_of x))"
    by (simp add:case_prod_beta' n_of_def \<epsilon>_of_def \<delta>_of_def m_of_def)
  also have "... \<in> O[?F](g)"
    by (auto intro!:sum_in_bigo simp:Let_def log_def l6 l7 l8 l10 unit_8)
  also have "... = O[?F](?rhs)"
    by (simp add:case_prod_beta' g_def n_of_def \<epsilon>_of_def \<delta>_of_def m_of_def)
  finally show ?thesis by simp
qed

end


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

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

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

datatype Nat = Z | S "Nat"

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

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

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) z = z"
| "plus (S z2) z = S (plus z2 z)"

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

(*fun did not finish the proof*)
function third :: "Nat => Nat" where
  "third y =
   (if (y = (S (S Z))) then Z else
      (if (y = (S Z)) then Z else
         (case y of
            Z => Z
            | S z => plus (S Z) (third (minus y (S (S (S Z))))))))"
  by pat_completeness auto

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

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

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge1sort2 :: "Nat list => Nat list"
  and nstoogesort :: "Nat list => Nat list"
  and nstooge1sort1 :: "Nat list => Nat list" where
  "nstooge1sort2 y =
   (case splitAt (third (length y)) (reverse y) of
      pair2 ys2 zs2 => x (nstoogesort zs2) (reverse ys2))"
| "nstoogesort (nil2) = nil2"
| "nstoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge1sort2
       (nstooge1sort1 (nstooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge1sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort zs1))"
  by pat_completeness auto

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

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

theorem property0 :
  "isPermutation (nstoogesort xs) xs"
  oops

end


header {* Abstract Model-Checker *}
theory CAVA_Abstract
imports
  "../CAVA_Automata/CAVA_Base/CAVA_Base"
  "../CAVA_Automata/Automata"
  "../LTL_to_GBA/LTL"
begin
text {*
  This theory defines the abstract version of the cava model checker,
  as well as a generic implementation.
  *}

subsection {* Specification of an LTL Model-Checker *}
text {*
  Abstractly, an LTL model-checker consists of three components:
  \begin{enumerate}
    \item A conversion of LTL-formula to Indexed Generalized Buchi Automata
      (IGBA) over sets of atomic propositions.
    \item An intersection construction, which takes a system and an IGBA, and
      creates an Indexed Generalized Buchi Graph (IGBG) and a projection
      function to project runs of the IGBG back to runs of the system.
    \item An emptiness check for IGBGs.
  \end{enumerate}
*}

text {* Given an LTL formula, the LTL to Buchi conversion
  returns a Generalized Buchi Automaton that accepts the same language. *}
definition ltl_to_gba_spec
  :: "'prop ltlc \<Rightarrow> ('q, 'prop set, _) igba_rec_scheme nres"
  -- {* Conversion of LTL formula to generalized buchi automaton *}
  where "ltl_to_gba_spec \<phi> \<equiv> SPEC (\<lambda>gba.
    igba.lang gba = ltlc_language \<phi> \<and> igba gba)"

definition inter_spec
  :: "('s,'prop set,_) sa_rec_scheme
  \<Rightarrow> ('q,'prop set,_) igba_rec_scheme
  \<Rightarrow> (('prod_state,_) igb_graph_rec_scheme \<times> ('prod_state \<Rightarrow> 's)) nres"
  -- "Intersection of system and IGBA"
  where "\<And>sys ba. inter_spec sys ba \<equiv> do {
    ASSERT (sa sys);
    ASSERT (igba ba);
    SPEC (\<lambda>(G,project). igb_graph G \<and> (\<forall>r.
      (\<exists>r'. igb_graph.is_acc_run G r' \<and> r = project o r')
        \<longleftrightarrow> (fr_graph.is_run sys r \<and> sa_L sys o r \<in> igba.lang ba)))
  }"

definition find_ce_spec
  :: "('q,_) igb_graph_rec_scheme \<Rightarrow> 'q word option option nres"
  -- "Check Generalized Buchi graph for emptiness, with optional counterexample"
  where "find_ce_spec G \<equiv> do {
    ASSERT (igb_graph G);
    SPEC (\<lambda>res. case res of
      None \<Rightarrow> (\<forall>r. \<not>igb_graph.is_acc_run G r)
    | Some None \<Rightarrow> (\<exists>r. igb_graph.is_acc_run G r)
    | Some (Some r) \<Rightarrow> igb_graph.is_acc_run G r
    )}"

text {*
  Using the specifications from above, we can specify the essence
  of the model-checking algorithm: Convert the LTL-formula to a GBA,
  make an intersection with the system and check the result for emptiness.
*}
definition abs_model_check
  :: "'ba_state itself \<Rightarrow> 'ba_more itself
  \<Rightarrow> 'prod_state itself \<Rightarrow> 'prod_more itself
  \<Rightarrow> ('s,'prop set,_) sa_rec_scheme \<Rightarrow> 'prop ltlc
  \<Rightarrow> 's word option option nres"
  where
  "abs_model_check _ _ _ _ sys \<phi> \<equiv> do {
    gba :: ('ba_state,_,'ba_more) igba_rec_scheme
      \<leftarrow> ltl_to_gba_spec (LTLcNeg \<phi>);
    ASSERT (igba gba);
    ASSERT (sa sys);
    (Gprod::('prod_state,'prod_more)igb_graph_rec_scheme, map_state)
      \<leftarrow> inter_spec sys gba;
    ASSERT (igb_graph Gprod);
    ce \<leftarrow> find_ce_spec Gprod;

    case ce of
      None \<Rightarrow> RETURN None
    | Some None \<Rightarrow> RETURN (Some None)
    | Some (Some r) \<Rightarrow> RETURN (Some (Some (map_state o r)))
  }"

text {*
  The main correctness theorem states that our abstract model checker
  really checks whether the system satisfies the formula, and a
  correct counterexample is returned (if any).
  Note that, if the model does not satisfy the formula,
  returning a counterexample is optional.
*}
theorem abs_model_check_correct:
  "abs_model_check T1 T2 T3 T4 sys \<phi>
  \<le> do{ ASSERT (sa sys);
        SPEC (\<lambda>res. case res of
          None \<Rightarrow> (sa.lang sys \<subseteq> ltlc_language \<phi>)
        | Some None \<Rightarrow> (\<not>(sa.lang sys \<subseteq> ltlc_language \<phi>))
        | Some (Some r) \<Rightarrow> (
            fr_graph.is_run sys r \<and> sa_L sys o r \<notin> ltlc_language \<phi>))}"
  unfolding abs_model_check_def ltl_to_gba_spec_def inter_spec_def
    find_ce_spec_def
  apply (refine_rcg refine_vcg ASSERT_leI le_ASSERTI)
  apply (auto simp: sa.lang_def
    sa.accept_def[THEN meta_eq_to_obj_eq, THEN ext[of "sa.accept sys"] ])
    (* TODO: We really need an extended abs_def attribute, that digests
      conditional definitions! *)
  done

subsection {* Generic Implementation *}
text {*
  In this section, we define a generic implementation of an LTL model checker,
  that is parameterized with implementations of its components.
*}

abbreviation "ltl_rel \<equiv> Id :: ('a ltlc \<times> _) set"

locale impl_model_checker =
  -- {* Assembly of a generic model-checker *}
  fixes sa_rel :: "('sai \<times> ('s,'prop set,'sa_more) sa_rec_scheme) set"
  fixes igba_rel :: "('igbai \<times> ('q, 'prop set, 'igba_more) igba_rec_scheme) set"
  fixes igbg_rel :: "('igbgi \<times> ('sq, 'igbg_more) igb_graph_rec_scheme) set"
  fixes ce_rel :: "('cei \<times> 'sq word) set"
  fixes mce_rel :: "('mcei \<times> 's word) set"

  fixes ltl_to_gba_impl :: "'cfg_l2b \<Rightarrow> 'prop ltlc \<Rightarrow> 'igbai"
  fixes inter_impl :: "'cfg_int \<Rightarrow> 'sai \<Rightarrow> 'igbai \<Rightarrow> 'igbgi \<times> ('sq \<Rightarrow> 's)"
  fixes find_ce_impl :: "'cfg_ce \<Rightarrow> 'igbgi \<Rightarrow> 'cei option option"
  fixes map_run_impl :: "('sq \<Rightarrow> 's) \<Rightarrow> 'cei \<Rightarrow> 'mcei"

  assumes [relator_props, simp, intro!]: "single_valued mce_rel"

  assumes ltl_to_gba_refine:
    "\<And>cfg. (ltl_to_gba_impl cfg,ltl_to_gba_spec)
      \<in> ltl_rel \<rightarrow> \<langle>igba_rel\<rangle>plain_nres_rel"
  assumes inter_refine:
    "\<And>cfg. (inter_impl cfg,inter_spec)
      \<in> sa_rel \<rightarrow> igba_rel \<rightarrow> \<langle>igbg_rel \<times>\<^sub>r (Id \<rightarrow> Id)\<rangle>plain_nres_rel"
  assumes find_ce_refine:
    "\<And>cfg. (find_ce_impl cfg,find_ce_spec)
      \<in> igbg_rel \<rightarrow> \<langle>\<langle>\<langle>ce_rel\<rangle>option_rel\<rangle>option_rel\<rangle>plain_nres_rel"

  assumes map_run_refine: "(map_run_impl,op o) \<in> (Id \<rightarrow> Id) \<rightarrow> ce_rel \<rightarrow> mce_rel"

begin

  fun cfg_l2b where "cfg_l2b (c1,c2,c3) = c1"
  fun cfg_int where "cfg_int (c1,c2,c3) = c2"
  fun cfg_ce where "cfg_ce (c1,c2,c3) = c3"

  definition impl_model_check
    :: "('cfg_l2b\<times>'cfg_int\<times>'cfg_ce)
      \<Rightarrow> 'sai \<Rightarrow> 'prop ltlc \<Rightarrow> 'mcei option option"
    where
    "impl_model_check cfg sys \<phi> \<equiv> let
      ba = ltl_to_gba_impl (cfg_l2b cfg) (LTLcNeg \<phi>);
      (G,map_q) = inter_impl (cfg_int cfg) sys ba;
      ce = find_ce_impl (cfg_ce cfg) G
    in
      case ce of
        None \<Rightarrow> None
      | Some None \<Rightarrow> Some None
      | Some (Some ce) \<Rightarrow> Some (Some (map_run_impl map_q ce))"

  lemma impl_model_check_refine:
    "(impl_model_check cfg,abs_model_check
        TYPE('q) TYPE('igba_more) TYPE('sq) TYPE('igbg_more))
      \<in> sa_rel \<rightarrow> ltl_rel \<rightarrow> \<langle>\<langle>\<langle>mce_rel\<rangle>option_rel\<rangle>option_rel\<rangle>plain_nres_rel"
    apply (intro fun_relI plain_nres_relI)
    unfolding abs_model_check_def impl_model_check_def

    apply (simp only: let_to_bind_conv pull_out_let_conv
      pull_out_RETURN_case_option)

    apply (refine_rcg
      ltl_to_gba_refine[param_fo, THEN plain_nres_relD]
      rel_arg_cong[where f="LTLcNeg"]
      inter_refine[param_fo, THEN plain_nres_relD]
      find_ce_refine[param_fo, THEN plain_nres_relD]
    )

    apply (simp_all split: option.split)
    apply (auto elim: option_relE)
    apply (parametricity add: map_run_refine)
    apply simp
    done

  theorem impl_model_check_correct:
    assumes R: "(sysi,sys)\<in>sa_rel"
    assumes [simp]: "sa sys"
    shows "case impl_model_check cfg sysi \<phi> of
      None
        \<Rightarrow> sa.lang sys \<subseteq> ltlc_language \<phi>
    | Some None
        \<Rightarrow> \<not> sa.lang sys \<subseteq> ltlc_language \<phi>
    | Some (Some ri)
        \<Rightarrow> (\<exists>r. (ri,r)\<in>mce_rel
           \<and> fr_graph.is_run sys r \<and> sa_L sys o r \<notin> ltlc_language \<phi>)"
  proof -
    note impl_model_check_refine[
      where cfg=cfg,
      param_fo,
      THEN plain_nres_relD,
      OF R IdI[of \<phi>]]
    also note abs_model_check_correct
    finally show ?thesis
      apply (simp split: option.split)
      apply (simp add: refine_pw_simps pw_le_iff)
      apply (auto elim!: option_relE) []
      done
  qed

  theorem impl_model_check_correct_no_ce:
    assumes "(sysi,sys)\<in>sa_rel"
    assumes SA: "sa sys"
    shows "impl_model_check cfg sysi \<phi> = None
    \<longleftrightarrow> sa.lang sys \<subseteq> ltlc_language \<phi>"
    using impl_model_check_correct[where cfg=cfg, OF assms, of \<phi>]
    by (auto
      split: option.splits
      simp: sa.lang_def[OF SA] sa.accept_def[OF SA,abs_def])

end

end


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

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

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

fun select :: "'a => (('a, ('a list)) pair) list =>
               (('a, ('a list)) pair) list" where
"select x (nil2) = nil2"
| "select x (cons2 (pair2 y2 ys) x2) =
     cons2 (pair2 y2 (cons2 x ys)) (select x x2)"

fun select2 :: "'a list => (('a, ('a list)) pair) list" where
"select2 (nil2) = nil2"
| "select2 (cons2 y xs) =
     cons2 (pair2 y xs) (select y (select2 xs))"

fun formula :: "(('a, ('a list)) pair) list =>
                ('a list) list" where
"formula (nil2) = nil2"
| "formula (cons2 (pair2 y2 ys) z) =
     cons2 (cons2 y2 ys) (formula z)"

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

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

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

fun all :: "('a => bool) => 'a list => bool" where
"all p (nil2) = True"
| "all p (cons2 y xs) = ((p y) & (all p xs))"

theorem property0 :
  "all
     (% (x :: 'a list) => isPermutation x xs) (formula (select2 xs))"
  oops

end


theory HS_Lens_Spartan_Ex
  imports "Hybrid-Verification.Hybrid_Verification"
begin

subsection \<open> Matrices \<close>

abbreviation mtx_circ :: "2 sq_mtx" ("A")
  where "A \<equiv> mtx
   ([0,  1] #
    [-1, 0] # [])"

lemma nat_of_2_type_2_eq_0: "nat_of (2::2) = 0"
  using exhaust_2 by (metis nat_of_0 zero_neq_one)

lemma "A = to_mtx \<^bold>[[0, - 1], [1, 0]\<^bold>]"
  unfolding mtx_def
  apply(simp add: to_mtx_inject vector_def)
  apply(simp only: vec_eq_iff, clarify)
  using exhaust_2 by (auto simp: nat_of_2_type_2_eq_0)

lit_vars

alphabet ss =
  x :: real
  y :: real
  z :: real

text \<open> Step-by-step Proof Strategy Example \<close>

lemma "`|\<questiondown>x > 1? ; x ::= x + 1 ; x ::= x\<^sup>2] (x > 3)`"
  \<comment> \<open> (1) Apply the simplification laws for @{const fbox} \<close>
  apply (simp add: wlp)
  \<comment> \<open> (2) Evaluate the substitution laws \<close>
  apply (simp add: usubst_eval)
  \<comment> \<open> (3) Unfold into a pure lens expression and apply introduction laws \<close>
  apply (auto simp add: taut_def)
  \<comment> \<open> (4) Expand out lenses and split state space \<close>
  apply (simp add: alpha_splits lens_defs)
  \<comment> \<open> (5) Discharge the remaining proof obligation \<close>
  apply (simp add: field_simps)
  using less_1_mult apply fastforce
  done

lemma "`|\<questiondown>x > 1? ; x ::= x + 1 ; x ::= x\<^sup>2] (x > 3)`"
  apply (simp add: wlp usubst_eval taut_def)
  \<comment> \<open> (4) Expand out lenses and split state space \<close>
  apply (simp add:  lens_defs)
  \<comment> \<open> (5) Discharge the remaining proof obligation \<close>
  apply (simp add: field_simps)
  using less_1_mult apply fastforce
  done

lemma "(r\<^sup>2 = x\<^sup>2 + y\<^sup>2)\<^sub>e \<le> |x ::= 4; y ::= 3] (5\<^sup>2 = x\<^sup>2 + y\<^sup>2)"
  by (auto simp: wlp usubst_eval)

lemma pendulum: "\<^bold>{r\<^sup>2 = x\<^sup>2 + y\<^sup>2\<^bold>} {(x, y)` = (y, -x)} \<^bold>{r\<^sup>2 = x\<^sup>2 + y\<^sup>2\<^bold>}"
  by dInduct

\<comment> \<open> Partial derivatives? \<close>

lemma "\<D>\<^bsub>x\<^esub>\<langle>subst\<rangle> [expr]\<^sub>e = lframe_frechetD x subst (expr::'a ss_scheme \<Rightarrow> real)"
 by (simp add: lframe_frechetD_alt)

lemma "lframe_frechetD x subst expr s =
  (SOME f'. D (expr \<circ> put\<^bsub>x\<^esub> s) \<mapsto> f' (at (get\<^bsub>x\<^esub> s))) (get\<^bsub>x\<^esub> (subst s))"
  unfolding lframe_frechetD_alt frechet_derivative_def by (simp add: comp_def)

lemma "lframe_frechetD x f expr s =
  (SOME f'. bounded_linear f' \<and>
    (\<forall>e>0. \<exists>d>0. \<forall>y\<in>UNIV. \<parallel>y - get\<^bsub>x\<^esub> s\<parallel> < d \<longrightarrow>
      \<parallel>expr (put\<^bsub>x\<^esub> s y) - expr (put\<^bsub>x\<^esub> s (get\<^bsub>x\<^esub> s)) - f' (y - get\<^bsub>x\<^esub> s)\<parallel> \<le> e * \<parallel>y - get\<^bsub>x\<^esub> s\<parallel>))
  (get\<^bsub>x\<^esub> (f s))"
  unfolding lframe_frechetD_alt frechet_derivative_def has_derivative_within_alt
  by (simp add: comp_def)

lemma "(x\<^sup>2 * y)\<^sub>e = (\<lambda>s. (get\<^bsub>x\<^esub> s)^2 * (get\<^bsub>y\<^esub> s))"
  unfolding SEXP_def by simp

lemma "\<D>\<^bsub>x\<^esub>\<langle>[x \<leadsto> 1, y \<leadsto> 1]\<rangle> (x\<^sup>2 * y)
  = (\<lambda>s. (SOME f'. D ((x\<^sup>2 * y)\<^sub>e \<circ> (put\<^bsub>x\<^esub> s)) \<mapsto> f' (at (get\<^bsub>x\<^esub> s))) (get\<^bsub>x\<^esub> ([x \<leadsto> 1, y \<leadsto> 1] s)))"
  unfolding lframe_frechetD_alt frechet_derivative_def by (simp add: comp_def)

lemma "\<D>\<^bsub>x\<^esub>\<langle>[x \<leadsto> 1, y \<leadsto> 1]\<rangle> (x\<^sup>2 * y) = (2 * x * y)\<^sub>e"
  by (simp add: framed_derivs ldifferentiable usubst)

lemma "\<D>\<^bsub>x\<^esub>\<langle>[x \<leadsto> 2, y \<leadsto> 1]\<rangle> (x\<^sup>2 * y) = (4 * x * y)\<^sub>e"
  by (simp add: framed_derivs ldifferentiable usubst)

lemma "\<D>\<^bsub>y\<^esub>\<langle>[x \<leadsto> 3, y \<leadsto> 2]\<rangle> (x\<^sup>2 * y) = (2 * x\<^sup>2 * 1)\<^sub>e"
  by (simp add: framed_derivs ldifferentiable usubst field_simps)

lemma "\<D>\<^bsub>y\<^esub>\<langle>[x \<leadsto> 1, y \<leadsto> 1]\<rangle> (x\<^sup>2 * y) = (x\<^sup>2 * 1)\<^sub>e"
  by (simp add: framed_derivs ldifferentiable usubst)

lemma "\<D>\<^bsub>x +\<^sub>L y\<^esub>\<langle>[x \<leadsto> 1, y \<leadsto> 1]\<rangle> (x\<^sup>2 * y) = (x\<^sup>2 + 2 * x * y)\<^sub>e"
  by (simp add: framed_derivs ldifferentiable usubst)

lemma "\<D>\<^bsub>z\<^esub>\<langle>[x \<leadsto> 1, y \<leadsto> 1, z \<leadsto> 1]\<rangle> (x\<^sup>2 * y + z * y) = (y)\<^sub>e"
   by (simp add: framed_derivs ldifferentiable usubst)

lemma "\<D>\<^bsub>x +\<^sub>L y +\<^sub>L z\<^esub>\<langle>[x \<leadsto> 1, y \<leadsto> 1, z \<leadsto> 1]\<rangle> (x\<^sup>2 * y + z * y) = (x\<^sup>2 + 2 * x * y + y + z)\<^sub>e"
   by (simp add: framed_derivs ldifferentiable usubst field_simps)

lemma "\<D>\<^bsub>x +\<^sub>L y +\<^sub>L z\<^esub>\<langle>[x \<leadsto> 1, y \<leadsto> 1, z \<leadsto> 2]\<rangle> (x\<^sup>2 * y + z * y) = (x\<^sup>2 + 2 * x * y + 2*y + z)\<^sub>e"
   by (simp add: framed_derivs ldifferentiable usubst field_simps)

lemma "\<D>\<^bsub>x\<^esub>\<langle>[x \<leadsto> 2*x]\<rangle> x\<^sup>2 = (4 * x\<^sup>2)\<^sub>e"
   by (simp add: framed_derivs ldifferentiable usubst field_simps)

text \<open> We create the bouncing ball in a locale context using the command "dataspace", which
  generates abstract lenses and contextual information. \<close>

dataspace bball =
  constants
    g :: real \<comment> \<open> Gravitational acceleration constant \<close>
    H :: real \<comment> \<open> The initial or maximum height of the ball \<close>
    c :: real \<comment> \<open> The damping coefficient applied upon rebound \<close>
  assumes g_pos: "g > 0" \<comment> \<open> The gravitational constant should be strictly positive (e.g. 9.81) \<close>
  and c_pos: "c > 0" \<comment> \<open> The damping coefficient is greater than 0... \<close>
  and c_le_one: "c \<le> 1" \<comment> \<open> ... and no greater than 1, otherwise it increases its bounce. \<close>
  and H_pos: "H \<ge> 0"
  variables h::real  v::real

context bball
begin

text \<open> Here is the invariant we wish to prove: it is sufficient to show that always $h \le H$. \<close>

abbreviation "Inv \<equiv> (h \<ge> 0 \<and> v\<^sup>2 \<le> 2*g*(H - h))\<^sup>e"
abbreviation "Dynamics \<equiv> {h` = v, v` = -g | h \<ge> 0}"
abbreviation "Ctrl \<equiv> IF h = 0 THEN v ::= -c * v ELSE skip"

definition BBall :: "'st prog" where "BBall = (Dynamics ; Ctrl)\<^sup>*"

text \<open> We first prove that it is an invariant of the dynamics using Hoare logic. \<close>

lemma "\<^bold>{@Inv\<^bold>}Dynamics\<^bold>{@Inv\<^bold>}"
  by dInduct_mega

lemma l1: "\<^bold>{@Inv\<^bold>}Dynamics\<^bold>{@Inv\<^bold>}"
  apply (rule hoare_conj_inv)
  apply (rule diff_weak_on_rule) \<comment> \<open> Differential weakening (invariant first conjunct) \<close>
   apply (simp)
   apply (dInduct)
  done

text \<open> Next, we prove its also an invariant of the controller. This requires a call to sledgehammer. \<close>

lemma l2: "\<^bold>{@Inv\<^bold>}Ctrl\<^bold>{@Inv\<^bold>}"
  by (hoare_wp_auto)
     (smt c_le_one c_pos mult_less_cancel_right1 power_le_one_iff power_mult_distrib zero_le_power2)

text \<open> As a consequence, it is an invariant of the whole system. \<close>

lemma l3: "\<^bold>{@Inv\<^bold>}BBall\<^bold>{@Inv\<^bold>}"
  unfolding BBall_def
  using hoare_kcomp_inv hoare_kstar_inv l1 l2
  by blast

text \<open> We can now show the safety property we desire using the consequence rule and sledgehammer. \<close>

lemma safety_property_1:
  "\<^bold>{0 \<le> h \<and> v\<^sup>2 \<le> 2*g*(H - h)\<^bold>}BBall\<^bold>{0 \<le> h \<and> h \<le> H\<^bold>}"
  apply (rule hoare_conseq[OF l3]) \<comment> \<open> Consequence rule \<close>
  apply (simp)
  apply (expr_simp)
  apply (smt g_pos zero_le_mult_iff zero_le_power2)
  done

text \<open> A more specific version -- the ball starts stationary and at height $h$. \<close>

lemma safety_property_2:
  "\<^bold>{h = H \<and> v = 0\<^bold>}BBall\<^bold>{0 \<le> h \<and> h \<le> H\<^bold>}"
  apply (rule hoare_conseq[OF safety_property_1])
  apply (simp add: H_pos)
  apply simp
  done

end

end


theory prop_19
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 *)

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

lemma lemma_aa [thy_expl]: "append (append x1 y1) z1 = append x1 (append y1 z1)"
by (hipster_induct_schemes append.simps rev.simps)

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

lemma lemma_ac [thy_expl]: "rev (rev x3) = x3"
by (hipster_induct_schemes append.simps rev.simps)

  theorem x0 :
    "(append (rev (rev x)) y) = (rev (rev (append x y)))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory sort_TSortPermutes'
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

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

datatype 'a Tree = TNode "'a Tree" "'a" "'a Tree" | TNil

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun null :: "'t list => bool" where
"null (Nil2) = True"
| "null (Cons2 y z) = False"

fun flatten :: "'a Tree => 'a list => 'a list" where
"flatten (TNode p z q) y = flatten p (Cons2 z (flatten q y))"
| "flatten (TNil) y = y"

fun elem :: "int => int list => bool" where
"elem x (Nil2) = False"
| "elem x (Cons2 z ys) = or2 (x = z) (elem x ys)"

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

fun delete :: "int => int list => int list" where
"delete x (Nil2) = Nil2"
| "delete x (Cons2 z ys) =
     (if x = z then ys else Cons2 z (delete x ys))"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun isPermutation :: "int list => int list => bool" where
"isPermutation (Nil2) y = null y"
| "isPermutation (Cons2 z xs) y =
     and2 (elem z y) (isPermutation xs (delete z y))"

fun add :: "int => int Tree => int Tree" where
"add x (TNode p z q) =
   (if x <= z then TNode (add x p) z q else TNode p z (add x q))"
| "add x (TNil) = TNode (TNil) x (TNil)"

fun toTree :: "int list => int Tree" where
"toTree (Nil2) = TNil"
| "toTree (Cons2 y xs) = add y (toTree xs)"

fun tsort :: "int list => int list" where
"tsort x =
   dot
     (% (y :: (int list => int list)) => y (Nil2))
     (% (z :: int list) =>
        dot
          (% (x2 :: int Tree) => % (x3 :: int list) => flatten x2 x3)
          (% (x4 :: int list) => toTree x4) z)
     x"

(*hipster or2
          null
          flatten
          elem
          dot
          delete
          and2
          isPermutation
          add
          toTree
          tsort *)

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

end