theory TheoryTesting
  imports Main "HOL-Library.Word"
begin

(*datatype UnknownNumer =
  Unknown (down: "64 word") (up: "64 word")*)

value "NOT (0::64 word)"

typedef IntegerHole = "{(down::64 word, up::64 word) . ((NOT down) OR up = NOT 0)}"
proof -
  have "((NOT 0::64 word) OR 0 = NOT 0)"
    by simp
  then show ?thesis
    by blast
qed

fun valid_number :: "IntegerHole \<Rightarrow> 64 word \<Rightarrow> bool" where
  "valid_number hole num = (let (down, up) = Rep_IntegerHole hole in
    down AND num = down \<and>
    (NOT up) AND num = 0
  )"

code_datatype Abs_IntegerHole

lemma only_set: "valid_number (Abs_IntegerHole (-1, -1)) x \<Longrightarrow> x = -1"
  unfolding valid_number.simps
  by (simp add: Abs_IntegerHole_inverse)

lemma none_set: "valid_number (Abs_IntegerHole (0, 0)) x \<Longrightarrow> x = 0"
  unfolding valid_number.simps
  by (simp add: Abs_IntegerHole_inverse)

lemma
  assumes "Rep_IntegerHole xhole = (xdown, xup)"
  assumes "Rep_IntegerHole yhole = (ydown, yup)"
  assumes "valid_number xhole x"
  assumes "valid_number yhole y"
  assumes "(NOT xdown) AND yup = 0"
  shows "x AND y = y"
  using assms unfolding valid_number.simps
  apply (simp add: Abs_IntegerHole_inverse)
  by (metis (no_types, hide_lams) bit.conj_disj_distrib2 bit.disj_cancel_left or.left_neutral word_ao_absorbs(2) word_oa_dist)

definition shiftl (infix "<<" 75) where
  "shiftl w n = (shiftl1 ^^ n) w"

lemma shiftl_power[simp]: "(x::('a::len) word) * (2 ^ j) = x << j"
  unfolding shiftl_def apply (induction j)
  apply simp unfolding funpow_Suc_right
  by (metis (no_types, lifting) comp_def funpow_swap1 mult.left_commute power_Suc shiftl1_eq_mult_2)

lemma "(x::('a::len) word) * ((2 ^ j) + 1) = x << j + x"
  by (simp add: distrib_left)

lemma "(x::('a::len) word) * ((2 ^ j) - 1) = x << j - x"
  by (simp add: right_diff_distrib)

lemma "(x::('a::len) word) * ((2^j) + (2^k)) = x << j + x << k"
  by (simp add: distrib_left)

lemma "(x::('a::len) word) * ((2^j) - (2^k)) = x << j - x << k"
  by (simp add: right_diff_distrib)

definition signed_shiftr (infix ">>" 75) where
  "signed_shiftr w n = (sshiftr1 ^^ n) w"

definition shiftr (infix ">>>" 75) where
  "shiftr w n = (shiftr1 ^^ n) w"

lemma shiftr_power[simp]: "(x::('a::len) word) div (2 ^ j) = x >>> j"
  unfolding shiftr_def apply (induction j)
  apply simp unfolding funpow_Suc_right
  by (metis (no_types, lifting) comp_apply div_exp_eq funpow_swap1 power_Suc2 power_add power_one_right shiftr1_eq_div_2)

end


(* Author: Alexander Maletzky *)

section \<open>Sample Computations of Gr\"obner Bases via Macaulay Matrices\<close>

theory Groebner_Macaulay_Examples
  imports
    Groebner_Macaulay
    Dube_Bound
    Groebner_Bases.Benchmarks
    Jordan_Normal_Form.Gauss_Jordan_IArray_Impl
    Groebner_Bases.Code_Target_Rat
begin

subsection \<open>Combining @{theory Draft.Groebner_Macaulay} and @{theory Draft.Dube_Bound}\<close>

context extended_ord_pm_powerprod
begin

theorem thm_2_3_6_Dube:
  assumes "finite X" and "set fs \<subseteq> P[X]"
  shows "punit.is_Groebner_basis (set (punit.Macaulay_list
                                        (deg_shifts X (Dube (Suc (card X)) (maxdeg (set fs))) fs)))"
  using assms Dube_is_GB_cofactor_bound by (rule thm_2_3_6) (simp_all add: assms)

theorem thm_2_3_7_Dube:
  assumes "finite X" and "set fs \<subseteq> P[X]"
  shows "1 \<in> ideal (set fs) \<longleftrightarrow>
          1 \<in> set (punit.Macaulay_list (deg_shifts X (Dube (Suc (card X)) (maxdeg (set fs))) fs))"
  using assms Dube_is_GB_cofactor_bound by (rule thm_2_3_7) (simp_all add: assms)

theorem thm_2_3_6_indets_Dube:
  fixes fs
  defines "X \<equiv> UNION (set fs) indets"
  shows "punit.is_Groebner_basis (set (punit.Macaulay_list
                                        (deg_shifts X (Dube (Suc (card X)) (maxdeg (set fs))) fs)))"
  unfolding X_def using Dube_is_GB_cofactor_bound_indets by (rule thm_2_3_6_indets) (fact finite_set)

theorem thm_2_3_7_indets_Dube:
  fixes fs
  defines "X \<equiv> UNION (set fs) indets"
  shows "1 \<in> ideal (set fs) \<longleftrightarrow>
          1 \<in> set (punit.Macaulay_list (deg_shifts X (Dube (Suc (card X)) (maxdeg (set fs))) fs))"
  unfolding X_def using Dube_is_GB_cofactor_bound_indets by (rule thm_2_3_7_indets) (fact finite_set)

end (* extended_ord_pm_powerprod *)

subsection \<open>Preparations\<close>

(* This is exactly the same as in "Groebner_Bases.F4_Examples". Pull out into common ancestor? *)

primrec remdups_wrt_rev :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'a list" where
  "remdups_wrt_rev f [] vs = []" |
  "remdups_wrt_rev f (x # xs) vs =
    (let fx = f x in if List.member vs fx then remdups_wrt_rev f xs vs else x # (remdups_wrt_rev f xs (fx # vs)))"

lemma remdups_wrt_rev_notin: "v \<in> set vs \<Longrightarrow> v \<notin> f ` set (remdups_wrt_rev f xs vs)"
proof (induct xs arbitrary: vs)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  from Cons(2) have 1: "v \<notin> f ` set (remdups_wrt_rev f xs vs)" by (rule Cons(1))
  from Cons(2) have "v \<in> set (f x # vs)" by simp
  hence 2: "v \<notin> f ` set (remdups_wrt_rev f xs (f x # vs))" by (rule Cons(1))
  from Cons(2) show ?case by (auto simp: Let_def 1 2 List.member_def)
qed

lemma distinct_remdups_wrt_rev: "distinct (map f (remdups_wrt_rev f xs vs))"
proof (induct xs arbitrary: vs)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  show ?case by (simp add: Let_def Cons(1) remdups_wrt_rev_notin)
qed

lemma map_of_remdups_wrt_rev':
  "map_of (remdups_wrt_rev fst xs vs) k = map_of (filter (\<lambda>x. fst x \<notin> set vs) xs) k"
proof (induct xs arbitrary: vs)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  show ?case
  proof (simp add: Let_def List.member_def Cons, intro impI)
    assume "k \<noteq> fst x"
    have "map_of (filter (\<lambda>y. fst y \<noteq> fst x \<and> fst y \<notin> set vs) xs) =
          map_of (filter (\<lambda>y. fst y \<noteq> fst x) (filter (\<lambda>y. fst y \<notin> set vs) xs))"
      by (simp only: filter_filter conj_commute)
    also have "... = map_of (filter (\<lambda>y. fst y \<notin> set vs) xs) |` {y. y \<noteq> fst x}" by (rule map_of_filter)
    finally show "map_of (filter (\<lambda>y. fst y \<noteq> fst x \<and> fst y \<notin> set vs) xs) k =
                  map_of (filter (\<lambda>y. fst y \<notin> set vs) xs) k"
      by (simp add: restrict_map_def \<open>k \<noteq> fst x\<close>)
  qed
qed

corollary map_of_remdups_wrt_rev: "map_of (remdups_wrt_rev fst xs []) = map_of xs"
  by (rule ext, simp add: map_of_remdups_wrt_rev')

lemma (in term_powerprod) compute_list_to_poly [code]:
  "list_to_poly ts cs = distr\<^sub>0 DRLEX (remdups_wrt_rev fst (zip ts cs) [])"
  by (rule poly_mapping_eqI,
      simp add: lookup_list_to_poly list_to_fun_def distr\<^sub>0_def oalist_of_list_ntm_def
        oa_ntm.lookup_oalist_of_list distinct_remdups_wrt_rev lookup_dflt_def map_of_remdups_wrt_rev)

lemma (in ordered_term) compute_Macaulay_list [code]:
  "Macaulay_list ps =
     (let ts = Keys_to_list ps in
      filter (\<lambda>p. p \<noteq> 0) (mat_to_polys ts (row_echelon (polys_to_mat ts ps)))
     )"
  by (simp add: Macaulay_list_def Macaulay_mat_def Let_def)

declare conversep_iff [code]

derive (eq) ceq poly_mapping
derive (no) ccompare poly_mapping
derive (dlist) set_impl poly_mapping
derive (no) cenum poly_mapping

derive (eq) ceq rat
derive (no) ccompare rat
derive (dlist) set_impl rat
derive (no) cenum rat

subsubsection \<open>Connection between @{typ "('x \<Rightarrow>\<^sub>0 'a) \<Rightarrow>\<^sub>0 'b"} and @{typ "('x, 'a) pp \<Rightarrow>\<^sub>0 'b"}\<close>

(* Move into "Polynomials.PP_Type"? *)

definition keys_pp_to_list :: "('x::linorder, 'a::zero) pp \<Rightarrow> 'x list"
  where "keys_pp_to_list t = sorted_list_of_set (keys_pp t)"

lemma inj_PP: "inj PP"
  by (simp add: PP_inject inj_def)

lemma inj_mapping_of: "inj mapping_of"
  by (simp add: mapping_of_inject inj_def)

lemma mapping_of_comp_PP [simp]:
  "mapping_of \<circ> PP = (\<lambda>x. x)"
  "PP \<circ> mapping_of = (\<lambda>x. x)"
  by (simp_all add: comp_def PP_inverse mapping_of_inverse)

lemma map_key_PP_mapping_of [simp]: "Poly_Mapping.map_key PP (Poly_Mapping.map_key mapping_of p) = p"
  by (simp add: map_key_compose[OF inj_PP inj_mapping_of] comp_def PP_inverse map_key_id)

lemma map_key_mapping_of_PP [simp]: "Poly_Mapping.map_key mapping_of (Poly_Mapping.map_key PP p) = p"
  by (simp add: map_key_compose[OF inj_mapping_of inj_PP] comp_def mapping_of_inverse map_key_id)

lemmas map_key_PP_plus = map_key_plus[OF inj_PP]
lemmas map_key_PP_zero [simp] = map_key_zero[OF inj_PP]

lemma lookup_map_key_PP: "lookup (Poly_Mapping.map_key PP p) t = lookup p (PP t)"
  by (simp add: map_key.rep_eq inj_PP)

lemma keys_map_key_PP: "keys (Poly_Mapping.map_key PP p) = mapping_of ` keys p"
  by (simp add: keys_map_key inj_PP)
     (smt Collect_cong PP_inverse UNIV_I image_def pp.mapping_of_inverse vimage_def)

lemma map_key_PP_zero_iff [iff]: "Poly_Mapping.map_key PP p = 0 \<longleftrightarrow> p = 0"
  by (metis map_key_PP_zero map_key_mapping_of_PP)

lemma map_key_PP_uminus [simp]: "Poly_Mapping.map_key PP (- p) = - Poly_Mapping.map_key PP p"
  by (rule poly_mapping_eqI) (simp add: lookup_map_key_PP)

lemma map_key_PP_minus:
  "Poly_Mapping.map_key PP (p - q) = Poly_Mapping.map_key PP p - Poly_Mapping.map_key PP q"
  by (rule poly_mapping_eqI) (simp add: lookup_map_key_PP lookup_minus)

lemma map_key_PP_monomial [simp]: "Poly_Mapping.map_key PP (monomial c t) = monomial c (mapping_of t)"
proof -
  have "Poly_Mapping.map_key PP (monomial c t) = Poly_Mapping.map_key PP (monomial c (PP (mapping_of t)))"
    by (simp only: mapping_of_inverse)
  also from inj_PP have "\<dots> = monomial c (mapping_of t)" by (fact map_key_single)
  finally show ?thesis .
qed

lemma map_key_PP_one [simp]: "Poly_Mapping.map_key PP 1 = 1"
  by (simp add: zero_pp.rep_eq flip: single_one)

lemma map_key_PP_monom_mult_punit:
  "Poly_Mapping.map_key PP (monom_mult_punit c t p) =
    monom_mult_punit c (mapping_of t) (Poly_Mapping.map_key PP p)"
  by (rule poly_mapping_eqI)
     (simp add: punit.lookup_monom_mult monom_mult_punit_def adds_pp_iff PP_inverse lookup_map_key_PP
          mapping_of_inverse flip: minus_pp.abs_eq)

lemma map_key_PP_times:
  "Poly_Mapping.map_key PP (p * q) =
    Poly_Mapping.map_key PP p * Poly_Mapping.map_key PP (q::(_, _::add_linorder) pp \<Rightarrow>\<^sub>0 _)"
  by (induct p rule: poly_mapping_plus_induct)
     (simp_all add: distrib_right map_key_PP_plus times_monomial_left map_key_PP_monom_mult_punit
        flip: monom_mult_punit_def)

lemma map_key_PP_sum: "Poly_Mapping.map_key PP (sum f A) = (\<Sum>a\<in>A. Poly_Mapping.map_key PP (f a))"
  by (induct A rule: infinite_finite_induct) (simp_all add: map_key_PP_plus)

lemma map_key_PP_ideal:
  "Poly_Mapping.map_key PP ` ideal F = ideal (Poly_Mapping.map_key PP ` (F::((_, _::add_linorder) pp \<Rightarrow>\<^sub>0 _) set))"
proof -
  from map_key_PP_mapping_of have "surj (Poly_Mapping.map_key PP)" by (rule surjI)
  with map_key_PP_plus map_key_PP_times show ?thesis by (rule image_ideal_eq_surj)
qed

subsubsection \<open>Locale \<open>pp_powerprod\<close>\<close>

text \<open>We have to introduce a new locale analogous to @{locale pm_powerprod}, but this time for
  power-products represented by @{type pp} rather than @{type poly_mapping}. This apparently leads
  to some (more-or-less) duplicate definitions and lemmas, but seems to be the only feasible way to
  get both
  \<^item> the convenient representation by @{type poly_mapping} for theory development, and
  \<^item> the executable representation by @{type pp} for code generation.\<close>

locale pp_powerprod =
  ordered_powerprod ord ord_strict
  for ord::"('x::{countable,linorder}, nat) pp \<Rightarrow> ('x, nat) pp \<Rightarrow> bool"
  and ord_strict
begin

sublocale gd_powerprod ..

sublocale pp_pm: extended_ord_pm_powerprod "\<lambda>s t. ord (PP s) (PP t)" "\<lambda>s t. ord_strict (PP s) (PP t)"
  by standard (auto simp: zero_min plus_monotone simp flip: zero_pp_def plus_pp.abs_eq PP_inject)

definition poly_deg_pp :: "(('x, nat) pp \<Rightarrow>\<^sub>0 'a::zero) \<Rightarrow> nat"
  where "poly_deg_pp p = (if p = 0 then 0 else max_list (map deg_pp (punit.keys_to_list p)))"

primrec deg_le_sect_pp_aux :: "'x list \<Rightarrow> nat \<Rightarrow> ('x, nat) pp \<Rightarrow>\<^sub>0 nat" where
  "deg_le_sect_pp_aux xs 0 = 1" |
  "deg_le_sect_pp_aux xs (Suc n) =
    (let p = deg_le_sect_pp_aux xs n in p + foldr (\<lambda>x. (+) (monom_mult_punit 1 (single_pp x 1) p)) xs 0)"

definition deg_le_sect_pp  :: "'x list \<Rightarrow> nat \<Rightarrow> ('x, nat) pp list"
  where "deg_le_sect_pp xs d = punit.keys_to_list (deg_le_sect_pp_aux xs d)"

definition deg_shifts_pp :: "'x list \<Rightarrow> nat \<Rightarrow>
                                (('x, nat) pp \<Rightarrow>\<^sub>0 'b) list \<Rightarrow> (('x, nat) pp \<Rightarrow>\<^sub>0 'b::semiring_1) list"
  where "deg_shifts_pp xs d fs = concat (map (\<lambda>f. (map (\<lambda>t. monom_mult_punit 1 t f)
                                          (deg_le_sect_pp xs (d - poly_deg_pp f)))) fs)"

definition indets_pp :: "(('x, nat) pp \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> 'x list"
  where "indets_pp p = remdups (concat (map keys_pp_to_list (punit.keys_to_list p)))"

definition Indets_pp :: "(('x, nat) pp \<Rightarrow>\<^sub>0 'b::zero) list \<Rightarrow> 'x list"
  where "Indets_pp ps = remdups (concat (map indets_pp ps))"

lemma map_PP_insort:
  "map PP (pp_pm.ordered_powerprod_lin.insort x xs) = ordered_powerprod_lin.insort (PP x) (map PP xs)"
  by (induct xs) simp_all

lemma map_PP_sorted_list_of_set:
  "map PP (pp_pm.ordered_powerprod_lin.sorted_list_of_set T) =
    ordered_powerprod_lin.sorted_list_of_set (PP ` T)"
proof (induct T rule: infinite_finite_induct)
  case (infinite T)
  moreover from inj_PP subset_UNIV have "inj_on PP T" by (rule inj_on_subset)
  ultimately show ?case by (simp add: inj_PP finite_image_iff)
next
  case empty
  show ?case by simp
next
  case (insert t T)
  moreover from insert(2) have "PP t \<notin> PP ` T" by (simp add: PP_inject image_iff)
  ultimately show ?case by (simp add: map_PP_insort)
qed

lemma map_PP_pps_to_list: "map PP (pp_pm.punit.pps_to_list T) = punit.pps_to_list (PP ` T)"
  by (simp add: pp_pm.punit.pps_to_list_def punit.pps_to_list_def map_PP_sorted_list_of_set flip: rev_map)

lemma map_mapping_of_pps_to_list:
  "map mapping_of (punit.pps_to_list T) = pp_pm.punit.pps_to_list (mapping_of ` T)"
proof -
  have "map mapping_of (punit.pps_to_list T) = map mapping_of (punit.pps_to_list (PP ` mapping_of ` T))"
    by (simp add: image_comp)
  also have "\<dots> = map mapping_of (map PP (pp_pm.punit.pps_to_list (mapping_of ` T)))"
    by (simp only: map_PP_pps_to_list)
  also have "\<dots> = pp_pm.punit.pps_to_list (mapping_of ` T)" by simp
  finally show ?thesis .
qed

lemma keys_to_list_map_key_PP:
  "pp_pm.punit.keys_to_list (Poly_Mapping.map_key PP p) = map mapping_of (punit.keys_to_list p)"
  by (simp add: pp_pm.punit.keys_to_list_def punit.keys_to_list_def keys_map_key_PP map_mapping_of_pps_to_list)

lemma Keys_to_list_map_key_PP:
  "pp_pm.punit.Keys_to_list (map (Poly_Mapping.map_key PP) fs) = map mapping_of (punit.Keys_to_list fs)"
  by (simp add: punit.Keys_to_list_eq_pps_to_list pp_pm.punit.Keys_to_list_eq_pps_to_list
          map_mapping_of_pps_to_list Keys_def image_UN keys_map_key_PP)

lemma poly_deg_map_key_PP: "poly_deg (Poly_Mapping.map_key PP p) = poly_deg_pp p"
proof -
  {
    assume "p \<noteq> 0"
    hence "map deg_pp (punit.keys_to_list p) \<noteq> []"
      by (simp add: punit.keys_to_list_def punit.pps_to_list_def)
    hence "Max (deg_pp ` keys p) = max_list (map deg_pp (punit.keys_to_list p))"
      by (simp add: max_list_Max punit.set_keys_to_list)
  }
  thus ?thesis
    by (simp add: poly_deg_def poly_deg_pp_def keys_map_key_PP image_image flip: deg_pp.rep_eq)
qed

lemma deg_le_sect_pp_aux_1:
  assumes "t \<in> keys (deg_le_sect_pp_aux xs n)"
  shows "deg_pp t \<le> n" and "keys_pp t \<subseteq> set xs"
proof -
  from assms have "deg_pp t \<le> n \<and> keys_pp t \<subseteq> set xs"
  proof (induct n arbitrary: t)
    case 0
    thus ?case by (simp_all add: keys_pp.rep_eq zero_pp.rep_eq)
  next
    case (Suc n)
    define X where "X = set xs"
    define q where "q = deg_le_sect_pp_aux xs n"
    have 1: "s \<in> keys q \<Longrightarrow> deg_pp s \<le> n \<and> keys_pp s \<subseteq> X" for s unfolding q_def X_def by (fact Suc.hyps)
    note Suc.prems
    also have "keys (deg_le_sect_pp_aux xs (Suc n)) \<subseteq> keys q \<union>
                    keys (foldr (\<lambda>x. (+) (monom_mult_punit 1 (single_pp x 1) q)) xs 0)"
      (is "_ \<subseteq> _ \<union> keys (foldr ?r xs 0)") by (simp add: Let_def Poly_Mapping.keys_add flip: q_def)
    finally show ?case
    proof
      assume "t \<in> keys q"
      hence "deg_pp t \<le> n \<and> keys_pp t \<subseteq> set xs" unfolding q_def by (rule Suc.hyps)
      thus ?thesis by simp
    next
      assume "t \<in> keys (foldr ?r xs 0)"
      moreover have "set xs \<subseteq> X" by (simp add: X_def)
      ultimately have "deg_pp t \<le> Suc n \<and> keys_pp t \<subseteq> X"
      proof (induct xs arbitrary: t)
        case Nil
        thus ?case by simp
      next
        case (Cons x xs)
        from Cons.prems(2) have "x \<in> X" and "set xs \<subseteq> X" by simp_all
        note Cons.prems(1)
        also have "keys (foldr ?r (x # xs) 0) \<subseteq> keys (?r x 0) \<union> keys (foldr ?r xs 0)"
          by (simp add: Poly_Mapping.keys_add)
        finally show ?case
        proof
          assume "t \<in> keys (?r x 0)"
          also have "\<dots> = (+) (single_pp x 1) ` keys q"
            by (simp add: monom_mult_punit_def punit.keys_monom_mult)
          finally obtain s where "s \<in> keys q" and t: "t = single_pp x 1 + s" ..
          from this(1) have "deg_pp s \<le> n \<and> keys_pp s \<subseteq> X" by (rule 1)
          with \<open>x \<in> X\<close> show ?thesis
            by (simp add: t deg_pp_plus deg_pp_single keys_pp.rep_eq plus_pp.rep_eq
                keys_plus_ninv_comm_monoid_add single_pp.rep_eq)
        next
          assume "t \<in> keys (foldr ?r xs 0)"
          thus "deg_pp t \<le> Suc n \<and> keys_pp t \<subseteq> X" using \<open>set xs \<subseteq> X\<close> by (rule Cons.hyps)
        qed
      qed
      thus ?thesis by (simp only: X_def)
    qed
  qed
  thus "deg_pp t \<le> n" and "keys_pp t \<subseteq> set xs" by simp_all
qed

lemma deg_le_sect_pp_aux_2:
  assumes "deg_pp t \<le> n" and "keys_pp t \<subseteq> set xs"
  shows "t \<in> keys (deg_le_sect_pp_aux xs n)"
  using assms
proof (induct n arbitrary: t)
  case 0
  thus ?case by simp
next
  case (Suc n)
  have foldr: "foldr (\<lambda>x. (+) (f x)) ys 0 + y = foldr (\<lambda>x. (+) (f x)) ys y"
    for f ys and y::"'z::monoid_add" by (induct ys) (simp_all add: ac_simps)
  define q where "q = deg_le_sect_pp_aux xs n"
  from Suc.prems(1) have "deg_pp t \<le> n \<or> deg_pp t = Suc n" by auto
  thus ?case
  proof
    assume "deg_pp t \<le> n"
    hence "t \<in> keys q" unfolding q_def using Suc.prems(2) by (rule Suc.hyps)
    hence "0 < lookup q t" by (simp add: in_keys_iff)
    also have "\<dots> \<le> lookup (deg_le_sect_pp_aux xs (Suc n)) t"
      by (simp add: Let_def lookup_add flip: q_def)
    finally show ?thesis by (simp add: in_keys_iff)
  next
    assume eq: "deg_pp t = Suc n"
    hence "keys_pp t \<noteq> {}" by (auto simp: keys_pp.rep_eq deg_pp.rep_eq)
    then obtain x where "x \<in> keys_pp t" by blast
    with Suc.prems(2) have "x \<in> set xs" ..
    then obtain xs1 xs2 where xs: "xs = xs1 @ x # xs2" by (meson split_list)
    define s where "s = t - single_pp x 1"
    from \<open>x \<in> keys_pp t\<close> have "single_pp x 1 adds t"
      by (simp add: adds_pp_iff single_pp.rep_eq keys_pp.rep_eq adds_poly_mapping le_fun_def
          lookup_single when_def in_keys_iff)
    hence "s + single_pp x 1 = (t + single_pp x 1) - single_pp x 1"
      unfolding s_def by (rule minus_plus)
    hence t: "t = single_pp x 1 + s" by (simp add: add.commute)
    with eq have "deg_pp s \<le> n" by (simp add: deg_pp_plus deg_pp_single)
    moreover have "keys_pp s \<subseteq> set xs"
    proof (rule subset_trans)
      from Suc.prems(2) \<open>x \<in> set xs\<close> show "keys_pp t \<union> keys_pp (single_pp x (Suc 0)) \<subseteq> set xs"
        by (simp add: keys_pp.rep_eq single_pp.rep_eq)
    qed (simp add: s_def keys_pp.rep_eq minus_pp.rep_eq keys_diff)
    ultimately have "s \<in> keys q" unfolding q_def by (rule Suc.hyps)
    hence "t \<in> keys (monom_mult_punit 1 (single_pp x 1) q)"
      by (simp add: monom_mult_punit_def punit.keys_monom_mult t)
    hence "0 < lookup (monom_mult_punit 1 (single_pp x 1) q) t" by (simp add: in_keys_iff)
    also have "\<dots> \<le> lookup (q + (foldr (\<lambda>x. (+) (monom_mult_punit 1 (single_pp x 1) q)) xs1 0 +
                      (monom_mult_punit 1 (single_pp x 1) q +
                        foldr (\<lambda>x. (+) (monom_mult_punit 1 (single_pp x 1) q)) xs2 0))) t"
      by (simp add: lookup_add)
    also have "\<dots> = lookup (deg_le_sect_pp_aux xs (Suc n)) t"
      by (simp add: Let_def foldr flip: q_def, simp add: xs)
    finally show ?thesis by (simp add: in_keys_iff)
  qed
qed

lemma keys_deg_le_sect_pp_aux:
  "keys (deg_le_sect_pp_aux xs n) = {t. deg_pp t \<le> n \<and> keys_pp t \<subseteq> set xs}"
  by (auto dest: deg_le_sect_pp_aux_1 deg_le_sect_pp_aux_2)

lemma deg_le_sect_deg_le_sect_pp:
  "map PP (pp_pm.punit.pps_to_list (deg_le_sect (set xs) d)) = deg_le_sect_pp xs d"
proof -
  have "PP ` {t. deg_pm t \<le> d \<and> keys t \<subseteq> set xs} = PP ` {t. deg_pp (PP t) \<le> d \<and> keys_pp (PP t) \<subseteq> set xs}"
    by (simp only: keys_pp.abs_eq deg_pp.abs_eq)
  also have "\<dots> = {t. deg_pp t \<le> d \<and> keys_pp t \<subseteq> set xs}"
  proof (intro subset_antisym subsetI)
    fix t
    assume "t \<in> {t. deg_pp t \<le> d \<and> keys_pp t \<subseteq> set xs}"
    moreover have "t = PP (mapping_of t)" by (simp only: mapping_of_inverse)
    ultimately show "t \<in> PP ` {t. deg_pp (PP t) \<le> d \<and> keys_pp (PP t) \<subseteq> set xs}" by auto
  qed auto
  finally show ?thesis
    by (simp add: deg_le_sect_pp_def punit.keys_to_list_def keys_deg_le_sect_pp_aux deg_le_sect_alt
      PPs_def conj_commute map_PP_pps_to_list flip: Collect_conj_eq)
qed

lemma deg_shifts_deg_shifts_pp:
  "pp_pm.deg_shifts (set xs) d (map (Poly_Mapping.map_key PP) fs) =
        map (Poly_Mapping.map_key PP) (deg_shifts_pp xs d fs)"
  by (simp add: pp_pm.deg_shifts_def deg_shifts_pp_def map_concat comp_def poly_deg_map_key_PP
         map_key_PP_monom_mult_punit PP_inverse flip: deg_le_sect_deg_le_sect_pp monom_mult_punit_def)

lemma ideal_deg_shifts_pp: "ideal (set (deg_shifts_pp xs d fs)) = ideal (set fs)"
proof -
  have "ideal (set (deg_shifts_pp xs d fs)) =
        Poly_Mapping.map_key mapping_of ` Poly_Mapping.map_key PP ` ideal (set (deg_shifts_pp xs d fs))"
    by (simp add: image_comp)
  also have "\<dots> = Poly_Mapping.map_key mapping_of ` ideal
                    (set (map (Poly_Mapping.map_key PP) (deg_shifts_pp xs d fs)))"
    by (simp add: map_key_PP_ideal)
  also have "\<dots> = Poly_Mapping.map_key mapping_of ` ideal (Poly_Mapping.map_key PP ` set fs)"
    by (simp flip: deg_shifts_deg_shifts_pp)
  also have "\<dots> = Poly_Mapping.map_key mapping_of ` Poly_Mapping.map_key PP ` ideal (set fs)"
    by (simp only: map_key_PP_ideal)
  also have "\<dots> = ideal (set fs)" by (simp add: image_comp)
  finally show ?thesis .
qed

lemma set_indets_pp: "set (indets_pp p) = indets (Poly_Mapping.map_key PP p)"
  by (simp add: indets_pp_def indets_def keys_pp_to_list_def keys_pp.rep_eq punit.set_keys_to_list
        keys_map_key_PP)

lemma poly_to_row_map_key_PP:
  "poly_to_row (map pp.mapping_of xs) (Poly_Mapping.map_key PP p) = poly_to_row xs p"
  by (simp add: poly_to_row_def comp_def lookup_map_key_PP mapping_of_inverse)

lemma Macaulay_mat_map_key_PP:
  "pp_pm.punit.Macaulay_mat (map (Poly_Mapping.map_key PP) fs) = punit.Macaulay_mat fs"
  by (simp add: punit.Macaulay_mat_def pp_pm.punit.Macaulay_mat_def Keys_to_list_map_key_PP
          polys_to_mat_def comp_def poly_to_row_map_key_PP)

lemma row_to_poly_mapping_of:
  assumes "distinct ts" and "dim_vec r = length ts"
  shows "row_to_poly (map pp.mapping_of ts) r = Poly_Mapping.map_key PP (row_to_poly ts r)"
proof (rule poly_mapping_eqI, simp only: lookup_map_key_PP)
  fix t
  let ?ts = "map mapping_of ts"
  from inj_mapping_of subset_UNIV have "inj_on mapping_of (set ts)" by (rule inj_on_subset)
  with assms(1) have 1: "distinct ?ts" by (simp add: distinct_map)
  from assms(2) have 2: "dim_vec r = length ?ts" by simp
  show "lookup (row_to_poly ?ts r) t = lookup (row_to_poly ts r) (PP t)"
  proof (cases "t \<in> set ?ts")
    case True
    then obtain i where i1: "i < length ?ts" and t1: "t = ?ts ! i" by (metis in_set_conv_nth)
    hence i2: "i < length ts" and t2: "PP t = ts ! i" by (simp_all add: mapping_of_inverse)
    have "lookup (row_to_poly ?ts r) t = r $ i"
      unfolding t1 using 1 2 i1 by (rule punit.lookup_row_to_poly)
    moreover have "lookup (row_to_poly ts r) (PP t) = r $ i"
      unfolding t2 using assms i2 by (rule punit.lookup_row_to_poly)
    ultimately show ?thesis by simp
  next
    case False
    have "PP t \<notin> set ts"
    proof
      assume "PP t \<in> set ts"
      hence "mapping_of (PP t) \<in> mapping_of ` set ts" by (rule imageI)
      with False show False by (simp add: PP_inverse)
    qed
    with punit.keys_row_to_poly have "lookup (row_to_poly ts r) (PP t) = 0"
      by (metis in_keys_iff in_mono)
    moreover from False punit.keys_row_to_poly have "lookup (row_to_poly ?ts r) t = 0"
      by (metis in_keys_iff in_mono)
    ultimately show ?thesis by simp
  qed
qed

lemma mat_to_polys_mapping_of:
  assumes "distinct ts" and "dim_col m = length ts"
  shows "mat_to_polys (map pp.mapping_of ts) m = map (Poly_Mapping.map_key PP) (mat_to_polys ts m)"
proof -
  {
    fix r
    assume "r \<in> set (rows m)"
    then obtain i where "r = row m i" by (auto simp: rows_def)
    hence "dim_vec r = length ts" by (simp add: assms(2))
    with assms(1) have "row_to_poly (map pp.mapping_of ts) r = Poly_Mapping.map_key PP (row_to_poly ts r)"
      by (rule row_to_poly_mapping_of)
  }
  thus ?thesis using assms by (simp add: mat_to_polys_def)
qed

lemma map_key_PP_Macaulay_list:
  "map (Poly_Mapping.map_key PP) (punit.Macaulay_list fs) =
      pp_pm.punit.Macaulay_list (map (Poly_Mapping.map_key PP) fs)"
  by (simp add: punit.Macaulay_list_def pp_pm.punit.Macaulay_list_def Macaulay_mat_map_key_PP
          Keys_to_list_map_key_PP mat_to_polys_mapping_of filter_map comp_def
          punit.distinct_Keys_to_list punit.length_Keys_to_list)

lemma lpp_map_key_PP: "pp_pm.lpp (Poly_Mapping.map_key PP p) = mapping_of (lpp p)"
proof (cases "p = 0")
  case True
  thus ?thesis by (simp add: zero_pp.rep_eq)
next
  case False
  show ?thesis
  proof (rule pp_pm.punit.lt_eqI_keys)
    show "pp.mapping_of (lpp p) \<in> keys (Poly_Mapping.map_key PP p)" unfolding keys_map_key_PP
      by (intro imageI punit.lt_in_keys False)
  next
    fix s
    assume "s \<in> keys (Poly_Mapping.map_key PP p)"
    then obtain t where "t \<in> keys p" and s: "s = mapping_of t" unfolding keys_map_key_PP ..
    thus "ord (PP s) (PP (pp.mapping_of (lpp p)))" by (simp add: mapping_of_inverse punit.lt_max_keys)
  qed
qed

lemma is_GB_map_key_PP:
  "finite G \<Longrightarrow> pp_pm.punit.is_Groebner_basis (Poly_Mapping.map_key PP ` G) \<longleftrightarrow> punit.is_Groebner_basis G"
  by (simp add: punit.GB_alt_3_finite pp_pm.punit.GB_alt_3_finite lpp_map_key_PP adds_pp_iff
        flip: map_key_PP_ideal)

lemma thm_2_3_6_pp:
  assumes "pp_pm.is_GB_cofactor_bound (Poly_Mapping.map_key PP ` set fs) b"
  shows "punit.is_Groebner_basis (set (punit.Macaulay_list (deg_shifts_pp (Indets_pp fs) b fs)))"
proof -
  let ?fs = "map (Poly_Mapping.map_key PP) fs"
  from assms have "pp_pm.is_GB_cofactor_bound (set ?fs) b" by simp
  hence "pp_pm.punit.is_Groebner_basis
                (set (pp_pm.punit.Macaulay_list (pp_pm.deg_shifts (\<Union> (indets ` set ?fs)) b ?fs)))"
    by (rule pp_pm.thm_2_3_6_indets)
  also have "(\<Union> (indets ` set ?fs)) = set (Indets_pp fs)" by (simp add: Indets_pp_def set_indets_pp)
  finally show ?thesis
    by (simp add: deg_shifts_deg_shifts_pp map_key_PP_Macaulay_list flip: set_map is_GB_map_key_PP)
qed

lemma Dube_is_GB_cofactor_bound_pp:
  "pp_pm.is_GB_cofactor_bound (Poly_Mapping.map_key PP ` set fs)
            (Dube (Suc (length (Indets_pp fs))) (max_list (map poly_deg_pp fs)))"
proof (cases "fs = []")
  case True
  show ?thesis by (rule pp_pm.is_GB_cofactor_boundI_subset_zero) (simp add: True)
next
  case False
  let ?F = "Poly_Mapping.map_key PP ` set fs"
  have "pp_pm.is_GB_cofactor_bound ?F (Dube (Suc (card (\<Union> (indets ` ?F)))) (maxdeg ?F))"
    by (intro pp_pm.Dube_is_GB_cofactor_bound_indets finite_imageI finite_set)
  moreover have "card (\<Union> (indets ` ?F)) = length (Indets_pp fs)"
    by (simp add: Indets_pp_def length_remdups_card_conv set_indets_pp)
  moreover from False have "maxdeg ?F = max_list (map poly_deg_pp fs)"
    by (simp add: max_list_Max maxdeg_def image_image poly_deg_map_key_PP)
  ultimately show ?thesis by simp
qed

definition GB_Macaulay_Dube :: "(('x, nat) pp \<Rightarrow>\<^sub>0 'a) list \<Rightarrow> (('x, nat) pp \<Rightarrow>\<^sub>0 'a::field) list"
  where "GB_Macaulay_Dube fs = punit.Macaulay_list (deg_shifts_pp (Indets_pp fs)
                            (Dube (Suc (length (Indets_pp fs))) (max_list (map poly_deg_pp fs))) fs)"

lemma GB_Macaulay_Dube_is_GB: "punit.is_Groebner_basis (set (GB_Macaulay_Dube fs))"
  unfolding GB_Macaulay_Dube_def using Dube_is_GB_cofactor_bound_pp by (rule thm_2_3_6_pp)

lemma ideal_GB_Macaulay_Dube: "ideal (set (GB_Macaulay_Dube fs)) = ideal (set fs)"
  by (simp add: GB_Macaulay_Dube_def punit.pmdl_Macaulay_list[simplified] ideal_deg_shifts_pp)

end

global_interpretation punit': pp_powerprod "ord_pp_punit cmp_term" "ord_pp_strict_punit cmp_term"
  rewrites "punit.adds_term = (adds)"
  and "punit.pp_of_term = (\<lambda>x. x)"
  and "punit.component_of_term = (\<lambda>_. ())"
  and "punit.monom_mult = monom_mult_punit"
  and "punit.mult_scalar = mult_scalar_punit"
  and "punit'.punit.min_term = min_term_punit"
  and "punit'.punit.lt = lt_punit cmp_term"
  and "punit'.punit.lc = lc_punit cmp_term"
  and "punit'.punit.tail = tail_punit cmp_term"
  and "punit'.punit.ord_p = ord_p_punit cmp_term"
  and "punit'.punit.keys_to_list = keys_to_list_punit cmp_term"
  for cmp_term :: "('a::nat, nat) pp nat_term_order"

  defines max_punit = punit'.ordered_powerprod_lin.max
  and max_list_punit = punit'.ordered_powerprod_lin.max_list
  and Keys_to_list_punit = punit'.punit.Keys_to_list
  and Macaulay_mat_punit = punit'.punit.Macaulay_mat
  and Macaulay_list_punit = punit'.punit.Macaulay_list
  and poly_deg_pp_punit = punit'.poly_deg_pp
  and deg_le_sect_pp_aux_punit = punit'.deg_le_sect_pp_aux
  and deg_le_sect_pp_punit = punit'.deg_le_sect_pp
  and deg_shifts_pp_punit = punit'.deg_shifts_pp
  and indets_pp_punit = punit'.indets_pp
  and Indets_pp_punit = punit'.Indets_pp
  and GB_Macaulay_Dube_punit = punit'.GB_Macaulay_Dube

  (* Only needed for auto-reduction: *)
  and find_adds_punit = punit'.punit.find_adds
  and trd_aux_punit = punit'.punit.trd_aux
  and trd_punit = punit'.punit.trd
  and comp_min_basis_punit = punit'.punit.comp_min_basis
  and comp_red_basis_aux_punit = punit'.punit.comp_red_basis_aux
  and comp_red_basis_punit = punit'.punit.comp_red_basis
  subgoal unfolding punit0.ord_pp_def punit0.ord_pp_strict_def ..
  subgoal by (fact punit_adds_term)
  subgoal by (simp add: id_def)
  subgoal by (fact punit_component_of_term)
  subgoal by (simp only: monom_mult_punit_def)
  subgoal by (simp only: mult_scalar_punit_def)
  subgoal using min_term_punit_def by fastforce
  subgoal by (simp only: lt_punit_def ord_pp_punit_alt)
  subgoal by (simp only: lc_punit_def ord_pp_punit_alt)
  subgoal by (simp only: tail_punit_def ord_pp_punit_alt)
  subgoal by (simp only: ord_p_punit_def ord_pp_strict_punit_alt)
  subgoal by (simp only: keys_to_list_punit_def ord_pp_punit_alt)
  done

subsection \<open>Computations\<close>

experiment begin interpretation trivariate\<^sub>0_rat .

lemma
  "comp_red_basis_punit DRLEX (GB_Macaulay_Dube_punit DRLEX [X * Y\<^sup>2 + 3 * X\<^sup>2 * Y, Y ^ 3 - X ^ 3]) =
    [X ^ 5, X ^ 3 * Y - C\<^sub>0 (1 / 9) * X ^ 4, Y ^ 3 - X ^ 3, X * Y\<^sup>2 + 3 * X\<^sup>2 * Y]"
  by eval

end

end (* theory *)


theory Context_Free_Grammar_Example
imports "HOL-Library.Code_Prolog"
begin
(*
declare mem_def[code_pred_inline]
*)

subsection \<open>Alternative rules for length\<close>

definition size_list :: "'a list => nat"
where "size_list = size"

lemma size_list_simps:
  "size_list [] = 0"
  "size_list (x # xs) = Suc (size_list xs)"
by (auto simp add: size_list_def)

declare size_list_simps[code_pred_def]
declare size_list_def[symmetric, code_pred_inline]

setup \<open>
  Context.theory_map
    (Quickcheck.add_tester ("prolog", (Code_Prolog.active, Code_Prolog.test_goals)))
\<close>

datatype alphabet = a | b

inductive_set S\<^sub>1 and A\<^sub>1 and B\<^sub>1 where
  "[] \<in> S\<^sub>1"
| "w \<in> A\<^sub>1 \<Longrightarrow> b # w \<in> S\<^sub>1"
| "w \<in> B\<^sub>1 \<Longrightarrow> a # w \<in> S\<^sub>1"
| "w \<in> S\<^sub>1 \<Longrightarrow> a # w \<in> A\<^sub>1"
| "w \<in> S\<^sub>1 \<Longrightarrow> b # w \<in> S\<^sub>1"
| "\<lbrakk>v \<in> B\<^sub>1; v \<in> B\<^sub>1\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>1"

lemma
  "S\<^sub>1p w \<Longrightarrow> w = []"
quickcheck[tester = prolog, iterations=1, expect = counterexample]
oops

definition "filter_a = filter (\<lambda>x. x = a)"

lemma [code_pred_def]: "filter_a [] = []"
unfolding filter_a_def by simp

lemma [code_pred_def]: "filter_a (x#xs) = (if x = a then x # filter_a xs else filter_a xs)"
unfolding filter_a_def by simp

declare filter_a_def[symmetric, code_pred_inline]

definition "filter_b = filter (\<lambda>x. x = b)"

lemma [code_pred_def]: "filter_b [] = []"
unfolding filter_b_def by simp

lemma [code_pred_def]: "filter_b (x#xs) = (if x = b then x # filter_b xs else filter_b xs)"
unfolding filter_b_def by simp

declare filter_b_def[symmetric, code_pred_inline]

setup \<open>Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [(["s1p", "a1p", "b1p"], 2)],
  replacing = [(("s1p", "limited_s1p"), "quickcheck")],
  manual_reorder = [(("quickcheck", 1), [0,2,1,4,3,5])]})\<close>

theorem S\<^sub>1_sound:
"S\<^sub>1p w \<Longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[tester = prolog, iterations=1, expect = counterexample]
oops

inductive_set S\<^sub>2 and A\<^sub>2 and B\<^sub>2 where
  "[] \<in> S\<^sub>2"
| "w \<in> A\<^sub>2 \<Longrightarrow> b # w \<in> S\<^sub>2"
| "w \<in> B\<^sub>2 \<Longrightarrow> a # w \<in> S\<^sub>2"
| "w \<in> S\<^sub>2 \<Longrightarrow> a # w \<in> A\<^sub>2"
| "w \<in> S\<^sub>2 \<Longrightarrow> b # w \<in> B\<^sub>2"
| "\<lbrakk>v \<in> B\<^sub>2; v \<in> B\<^sub>2\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>2"

setup \<open>Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [(["s2p", "a2p", "b2p"], 3)],
  replacing = [(("s2p", "limited_s2p"), "quickcheck")],
  manual_reorder = [(("quickcheck", 1), [0,2,1,4,3,5])]})\<close>

theorem S\<^sub>2_sound:
  "S\<^sub>2p w \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[tester = prolog, iterations=1, expect = counterexample]
oops

inductive_set S\<^sub>3 and A\<^sub>3 and B\<^sub>3 where
  "[] \<in> S\<^sub>3"
| "w \<in> A\<^sub>3 \<Longrightarrow> b # w \<in> S\<^sub>3"
| "w \<in> B\<^sub>3 \<Longrightarrow> a # w \<in> S\<^sub>3"
| "w \<in> S\<^sub>3 \<Longrightarrow> a # w \<in> A\<^sub>3"
| "w \<in> S\<^sub>3 \<Longrightarrow> b # w \<in> B\<^sub>3"
| "\<lbrakk>v \<in> B\<^sub>3; w \<in> B\<^sub>3\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>3"

setup \<open>Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [(["s3p", "a3p", "b3p"], 6)],
  replacing = [(("s3p", "limited_s3p"), "quickcheck")],
  manual_reorder = [(("quickcheck", 1), [0,2,1,4,3,5])]})\<close>

lemma S\<^sub>3_sound:
  "S\<^sub>3p w \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[tester = prolog, iterations=1, size=1, expect = no_counterexample]
oops

(*
setup {* Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [],
  replacing = [],
  manual_reorder = [],
  timeout = seconds 10.0,
  prolog_system = Code_Prolog.SWI_PROLOG}) *}

theorem S\<^sub>3_complete:
"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^sub>3"
quickcheck[tester = prolog, size=1, iterations=1]
oops
*)

inductive_set S\<^sub>4 and A\<^sub>4 and B\<^sub>4 where
  "[] \<in> S\<^sub>4"
| "w \<in> A\<^sub>4 \<Longrightarrow> b # w \<in> S\<^sub>4"
| "w \<in> B\<^sub>4 \<Longrightarrow> a # w \<in> S\<^sub>4"
| "w \<in> S\<^sub>4 \<Longrightarrow> a # w \<in> A\<^sub>4"
| "\<lbrakk>v \<in> A\<^sub>4; w \<in> A\<^sub>4\<rbrakk> \<Longrightarrow> b # v @ w \<in> A\<^sub>4"
| "w \<in> S\<^sub>4 \<Longrightarrow> b # w \<in> B\<^sub>4"
| "\<lbrakk>v \<in> B\<^sub>4; w \<in> B\<^sub>4\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>4"

setup \<open>Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [(["s4p", "a4p", "b4p"], 6)],
  replacing = [(("s4p", "limited_s4p"), "quickcheck")],
  manual_reorder = [(("quickcheck", 1), [0,2,1,4,3,5])]})\<close>

theorem S\<^sub>4_sound:
  "S\<^sub>4p w \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[tester = prolog, size=1, iterations=1, expect = no_counterexample]
oops

(*
theorem S\<^sub>4_complete:
"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^sub>4"
oops
*)

hide_const a b

end


subsection \<open>AbsNode Phase\<close>

theory AbsPhase
  imports
    Common
begin

phase AbsNode
  terminating size
begin

(* Marks' lemmas *)

lemma abs_pos:
  fixes v :: "('a :: len word)"
  assumes "0 \<le>s v"
  shows "(if v <s 0 then - v else v) = v"
  by (simp add: assms signed.leD)

lemma abs_neg:
  fixes v :: "('a :: len word)"
  assumes "v <s 0"
  assumes "-(2 ^ (Nat.size v - 1)) <s v" (* changed size func used*)
  shows "(if v <s 0 then - v else v) = - v \<and> 0 <s -v"
  by (smt (verit, ccfv_SIG) assms(1) assms(2) signed_take_bit_int_greater_eq_minus_exp
     signed_take_bit_int_greater_eq_self_iff sint_0 sint_word_ariths(4) word_sless_alt)

lemma abs_max_neg:
  fixes v :: "('a :: len word)"
  assumes "v <s 0"
  assumes "- (2 ^ (Nat.size v - 1)) = v" (* changed size func used *)
  shows "-v = v"
  using assms
  by (metis One_nat_def add.inverse_neutral double_eq_zero_iff mult_minus_right size_word.rep_eq)

lemma final_abs:
  fixes v :: "('a :: len word)"
  assumes "take_bit (Nat.size v) v = v"
  assumes "- (2 ^ (Nat.size v - 1)) \<noteq> v" (* changed size func used *)
  shows "0 \<le>s (if v <s 0 then -v else v)"

proof (cases "v <s 0")
  case True
  then show ?thesis
  proof (cases "v = - (2 ^ (Nat.size v - 1))") (* changed size func used *)
    case True
    then show ?thesis using abs_max_neg
      using assms by presburger
  next
    case False
    then have "- (2 ^ (Nat.size v - 1)) <s v" (* changed size func used *)
      unfolding word_sless_def using signed_take_bit_int_greater_self_iff
      by (smt (verit, best) One_nat_def diff_less double_eq_zero_iff len_gt_0 lessI less_irrefl
          mult_minus_right neg_equal_0_iff_equal signed.rep_eq signed_of_int
          signed_take_bit_int_greater_eq_self_iff signed_word_eqI sint_0 sint_range_size
          sint_sbintrunc' sint_word_ariths(4) size_word.rep_eq unsigned_0 word_2p_lem
          word_sless.rep_eq word_sless_def)
    then show ?thesis
      using abs_neg abs_pos signed.nless_le by auto
  qed
next
  case False
  then show ?thesis using abs_pos by auto
qed

(* end *)

lemma wf_abs: "is_IntVal x \<Longrightarrow> intval_abs x \<noteq> UndefVal"
  using intval_abs.simps unfolding new_int.simps
  using is_IntVal_def by force

fun bin_abs :: "'a ::len word \<Rightarrow> 'a ::len word" where
  "bin_abs v = (if (v <s 0) then (- v) else v)"

(* Helpers - Value level *)
lemma val_abs_zero:
  "intval_abs (new_int b 0) = new_int b 0"
  by simp

lemma less_eq_zero:
  assumes "val_to_bool (val[(IntVal b 0) < (IntVal b v)])"
  shows "int_signed_value b v > 0"
  using assms unfolding intval_less_than.simps(1) apply simp
  by (metis bool_to_val.elims val_to_bool.simps(1))

lemma val_abs_pos:
  assumes "val_to_bool(val[(new_int b 0) < (new_int b v)])"
  shows "intval_abs (new_int b v) = (new_int b v)"
  using assms using less_eq_zero unfolding intval_abs.simps new_int.simps
  by force

lemma val_abs_neg:
  assumes "val_to_bool(val[(new_int b v) < (new_int b 0)])"
  shows "intval_abs (new_int b v) = intval_negate (new_int b v)"
  using assms using less_eq_zero unfolding intval_abs.simps new_int.simps
  by force

lemma val_bool_unwrap:
  "val_to_bool (bool_to_val v) = v"
  by (metis bool_to_val.elims one_neq_zero val_to_bool.simps(1))

lemma take_bit_unwrap:
  "b = 64 \<Longrightarrow> take_bit b (v1::64 word) = v1"
  by (metis size64 size_word.rep_eq take_bit_length_eq)

lemma bit_less_eq_def:
  fixes v1 v2 :: "64 word"
  assumes "b \<le> 64"
  shows "sint (signed_take_bit (b - Suc (0::nat)) (take_bit b v1))
    < sint (signed_take_bit (b - Suc (0::nat)) (take_bit b v2)) \<longleftrightarrow>
    signed_take_bit (63::nat) (Word.rep v1) < signed_take_bit (63::nat) (Word.rep v2)"
  using assms sorry
  (* likely untrue but is a very useful simplification temporarily during merging *)
lemma less_eq_def:
  (*assumes "0 < b \<and> b \<le> 64"*)
  shows "val_to_bool(val[(new_int b v1) < (new_int b v2)]) \<longleftrightarrow> v1 <s v2"
  unfolding new_int.simps intval_less_than.simps bool_to_val_bin.simps bool_to_val.simps
            int_signed_value.simps
  apply (simp add: val_bool_unwrap) apply auto[1]
  unfolding word_sless_def apply auto[1]
  unfolding signed_def apply auto[1] apply auto[2]
  using bit_less_eq_def apply (metis bot_nat_0.extremum take_bit_0)
  by (metis bit_less_eq_def bot_nat_0.extremum take_bit_0)

lemma val_abs_always_pos:
  assumes "intval_abs (new_int b v) = (new_int b v')"
  shows "0 \<le>s v'"
  using assms
proof (cases "v = 0")
  case True
  then have "v' = 0"
    using val_abs_zero assms
    by (smt (verit, ccfv_threshold) Suc_diff_1 bit_less_eq_def bot_nat_0.extremum diff_is_0_eq
        len_gt_0 len_of_numeral_defs(2) order_le_less signed_eq_0_iff take_bit_0
        take_bit_signed_take_bit take_bit_unwrap)
  then show ?thesis by simp
next
  case neq0: False
  then show ?thesis
  proof (cases "val_to_bool(val[(new_int b 0) < (new_int b v)])")
    case True
    then show ?thesis using less_eq_def
      using assms val_abs_pos
      by (smt (verit, ccfv_SIG) One_nat_def Suc_leI bit.compl_one bit_less_eq_def
          cancel_comm_monoid_add_class.diff_cancel diff_zero len_gt_0 len_of_numeral_defs(2)
          mask_0 mask_1 one_le_numeral one_neq_zero signed_word_eqI take_bit_dist_subL
          take_bit_minus_one_eq_mask take_bit_not_eq_mask_diff take_bit_signed_take_bit
          zero_le_numeral)
  next
    case False
    then have "val_to_bool(val[(new_int b v) < (new_int b 0)])"
      using neq0 less_eq_def
      by (metis signed.neqE)
    then show ?thesis using val_abs_neg less_eq_def unfolding new_int.simps intval_negate.simps
      by (metis signed.nless_le take_bit_0)
  qed

qed

lemma intval_abs_elims:
  assumes "intval_abs x \<noteq> UndefVal"
  shows "\<exists>t v . x = IntVal t v \<and> intval_abs x = new_int t (if int_signed_value t v < 0 then - v else v)"
  using assms
  by (meson intval_abs.elims)

lemma wf_abs_new_int:
  assumes "intval_abs (IntVal t v) \<noteq> UndefVal"
  shows "intval_abs (IntVal t v) = new_int t v \<or> intval_abs (IntVal t v) = new_int t (-v)"
  using assms
  using intval_abs.simps(1) by presburger

lemma mono_undef_abs:
  assumes "intval_abs (intval_abs x) \<noteq> UndefVal"
  shows "intval_abs x \<noteq> UndefVal"
  using assms
  by force

(* Value level proofs *)
lemma val_abs_idem:
  assumes "intval_abs(intval_abs(x)) \<noteq> UndefVal"
  shows "intval_abs(intval_abs(x)) = intval_abs x"
  using assms
proof -
  obtain b v where in_def: "intval_abs x = new_int b v"
    using assms intval_abs_elims mono_undef_abs by blast
  then show ?thesis
  proof (cases "val_to_bool(val[(new_int b v) < (new_int b 0)])")
    case True
    then have nested: "(intval_abs (intval_abs x)) = new_int b (-v)"
      using val_abs_neg intval_negate.simps in_def
      by simp
    then have "x = new_int b (-v)"
      using in_def True unfolding new_int.simps
      by (smt (verit, best) intval_abs.simps(1) less_eq_def less_eq_zero less_numeral_extra(1)
          mask_1 mask_eq_take_bit_minus_one neg_one.elims neg_one_signed new_int.simps
          one_le_numeral one_neq_zero signed.neqE signed.not_less take_bit_of_0 val_abs_always_pos)
    then show ?thesis using val_abs_always_pos
      using True in_def less_eq_def signed.leD
      using signed.nless_le by blast
  next
    case False
    then show ?thesis
      using in_def by force
  qed
qed

lemma val_abs_negate:
  assumes "intval_abs (intval_negate x) \<noteq> UndefVal"
  shows   "intval_abs (intval_negate x) = intval_abs x"
  using assms apply (cases x; auto)
   apply (metis less_eq_def new_int.simps signed.dual_order.strict_iff_not signed.less_linear
          take_bit_0)
  by (smt (verit, ccfv_threshold) add.inverse_neutral intval_abs.simps(1) less_eq_def less_eq_zero
      less_numeral_extra(1) mask_1 mask_eq_take_bit_minus_one neg_one.elims neg_one_signed
      new_int.simps one_le_numeral one_neq_zero signed.order.order_iff_strict take_bit_of_0
      val_abs_always_pos)

text \<open>Optimisations\<close>

optimization AbsIdempotence: "abs(abs(x)) \<longmapsto>  abs(x)"
   apply auto[1]
  by (metis UnaryExpr unary_eval.simps(1) val_abs_idem)

optimization AbsNegate: "(abs(-x)) \<longmapsto>  abs(x)"
    apply auto[1] using val_abs_negate
  by (metis unary_eval.simps(1) unfold_unary)

end (* End of AbsPhase *)

end (* End of file *)


theory Grid_Path
  imports "../DP_CRelVS" "../DP_Lifting" "../DP_Proof"
begin
(*
definition lift_option_choice :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a option \<Rightarrow> 'a option \<Rightarrow> 'a option" where
  "lift_option_choice \<equiv> \<lambda>f v0 v1.
    case v0 of
      None \<Rightarrow> (case v1 of
        None \<Rightarrow> None
      | Some y \<Rightarrow> Some y)
    | Some x \<Rightarrow> (case v1 of
      None \<Rightarrow> Some x
      | Some y \<Rightarrow> Some (f x y))"

definition lift_option_choice :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a option \<Rightarrow> 'a option \<Rightarrow> 'a option" where
  "lift_option_choice \<equiv> \<lambda>f. \<lambda>v0. \<lambda>v1.
    case_option
      (case_option
        None
        (\<lambda>y. Some y)
        v1)
      (\<lambda>x. (case_option
        (Some x)
        (\<lambda>y. Some (f x y))
        v1))
      v0"

abbreviation min_opt :: "'a::ord option \<Rightarrow> 'a option \<Rightarrow> 'a option" where
  "min_opt \<equiv> lift_option_choice min"
term 0 (**)

definition lift_option_choice\<^sub>T :: "('M, ('a =='M\<Longrightarrow> 'a =='M\<Longrightarrow> 'a) =='M\<Longrightarrow> 'a option =='M\<Longrightarrow> 'a option =='M\<Longrightarrow> 'a option) state" where
  "lift_option_choice\<^sub>T \<equiv> \<lambda>\<^sub>Tf v0 v1.
    case_option\<^sub>T
    . (case_option\<^sub>T
      . \<langle>None\<rangle>
      . (\<lambda>\<^sub>T y. Some\<^sub>T . \<langle>y\<rangle>)
      . \<langle>v1\<rangle>)
    . (\<lambda>\<^sub>T x. case_option\<^sub>T
      . (Some\<^sub>T . \<langle>x\<rangle>)
      . (\<lambda>\<^sub>T y. Some\<^sub>T . (\<langle>f\<rangle> . \<langle>x\<rangle> . \<langle>y\<rangle>))
      . \<langle>v1\<rangle>)
    . \<langle>v0\<rangle>"

abbreviation min_opt\<^sub>T :: "('M, 'a::ord option =='M\<Longrightarrow> 'a option =='M\<Longrightarrow> 'a option) state" where
  "min_opt\<^sub>T \<equiv> lift_option_choice\<^sub>T . min\<^sub>T"

context dp_consistency begin

definition "min_opt a b \<equiv>
  case (a, b) of
    (None, None) \<Rightarrow> None
  | (Some a0, None) \<Rightarrow> Some a0
  | (None, Some b0) \<Rightarrow> Some b0
  | (Some a0, Some b0) \<Rightarrow> Some (min a0 b0)"
term 0 (**)

context
  fixes W :: "nat \<Rightarrow> nat \<Rightarrow> nat option"
begin

fun ed :: "nat\<times>nat \<Rightarrow> nat option" where
  "ed (0, 0) = W 0 0"
| "ed (0, Suc j) = case_option None (\<lambda>prev.
                     case_option None (\<lambda>here.
                       Some (plus prev here)
                     ) (W 0 (Suc j))
                   ) (ed (0, j))"
| "ed (Suc i, 0) = case_option None (\<lambda>prev.
                     case_option None (\<lambda>here.
                       Some (plus prev here)
                     ) (W (Suc i) 0)
                   ) (ed (i, 0))"
| "ed (Suc i, Suc j) = case_option None (\<lambda>prev.
                         case_option None (\<lambda>here.
                           Some (plus prev here)
                         ) (W (Suc i) (Suc j))
                       ) (min_opt (ed (i, j)) (min_opt (ed (Suc i, j)) (ed (i, Suc j))))"

ML_file \<open>../scratch/Transform.ML\<close>
local_setup \<open>
lift_fun NONE;
\<close>
print_theorems

interpretation ed: dp_consistency ed .

term 0 (**)
lemma "ed.consistentDP ed\<^sub>T"
  by (dp_match induct: ed\<^sub>T.induct simp: ed.simps simp\<^sub>T: ed\<^sub>T.simps)

end


theory Iterate
imports Main
begin

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)" for f where
  iter_refl [simp]: "iter f a a"
| iter_step [simp]: "f a b \<Longrightarrow> iter f b c \<Longrightarrow> iter f a c"

lemma [elim]: "iter f a b \<Longrightarrow> iter f b c \<Longrightarrow> iter f a c"
  by (induction a b rule: iter.induct) simp_all

end