(* Author: Alexander Maletzky *)

section \<open>Field-Theoretic Version of Hilbert's Nullstellensatz\<close>

theory Nullstellensatz_Field
  imports Nullstellensatz "HOL-Types_To_Sets.Types_To_Sets"
begin

text \<open>Building upon the geometric version of Hilbert's Nullstellensatz in
  @{theory Nullstellensatz.Nullstellensatz}, we prove its field-theoretic version here. To that end we employ
  the `types to sets' methodology.\<close>

subsection \<open>Getting Rid of Sort Constraints in Geometric Version\<close>

text \<open>We can use the `types to sets' approach to get rid of the @{class countable} and @{class linorder}
  sort constraints on the type of indeterminates in the geometric version of the Nullstellensatz.
  Once the `types to sets' methodology is integrated as a standard component into the main library of
  Isabelle, the theorems in @{theory Nullstellensatz.Nullstellensatz} could be replaced by their counterparts
  in this section.\<close>

lemmas radical_idealI_internalized = radical_idealI[unoverload_type 'x]

    from well_ordering obtain le_y'::"('y \<times> 'y) set" where fld: "Field le_y' = UNIV"
      and wo: "Well_order le_y'" by meson
    define le_y where "le_y = (\<lambda>a b::'y. (a, b) \<in> le_y')"

    from \<open>f \<in> P[Y]\<close> have 0: "map_indets rep (map_indets abs f) = f" unfolding map_indets_map_indets
      by (intro map_indets_id) (auto intro!: y.Abs_inverse dest: PolysD)
    have 1: "map_indets (rep \<circ> abs) ` F = F"
    proof
      from F_sub show "map_indets (rep \<circ> abs) ` F \<subseteq> F"
        by (smt PolysD(2) comp_apply image_subset_iff map_indets_id subsetD y.Abs_inverse)
    next
      from F_sub show "F \<subseteq> map_indets (rep \<circ> abs) ` F"
        by (smt PolysD(2) comp_apply image_eqI map_indets_id subsetD subsetI y.Abs_inverse)
    qed
    have 2: "inj rep" by (meson inj_onI y.Rep_inject)
    hence 3: "inj (map_indets rep)" by (rule map_indets_injI)
    from fin_Y have 4: "finite (abs ` Y)" by (rule finite_imageI)
    from wo have le_y_refl: "le_y x x" for x
      by (simp add: le_y_def well_order_on_def linear_order_on_def partial_order_on_def
                    preorder_on_def refl_on_def fld)
    have le_y_total: "le_y x y \<or> le_y y x" for x y
    proof (cases "x = y")
      case True
      thus ?thesis by (simp add: le_y_refl)
    next
      case False
      with wo show ?thesis
        by (simp add: le_y_def well_order_on_def linear_order_on_def total_on_def
                      Relation.total_on_def fld)
    qed

    from 4 finite_imp_inj_to_nat_seg y.Abs_image have "class.countable TYPE('y)"
      by unfold_locales fastforce
    moreover have "class.linorder le_y (strict le_y)"
      apply standard
      subgoal by (fact refl)
      subgoal by (fact le_y_refl)
      subgoal using wo
        by (auto simp: le_y_def well_order_on_def linear_order_on_def partial_order_on_def
                      preorder_on_def fld dest: transD)
      subgoal using wo
        by (simp add: le_y_def well_order_on_def linear_order_on_def partial_order_on_def
                      preorder_on_def antisym_def fld)
      subgoal by (fact le_y_total)
      done
    moreover from assms(1) have "finite (abs ` X)" by (rule finite_imageI)
    moreover have "map_indets abs ` F \<subseteq> P[abs ` X]"
    proof (rule subset_trans)
      from assms(2) show "map_indets abs ` F \<subseteq> map_indets abs ` P[X]" by (rule image_mono)
    qed (simp only: image_map_indets_Polys)
    moreover have "map_indets abs f \<in> P[abs ` X]"
    proof
      from assms(3) show "map_indets abs f \<in> map_indets abs ` P[X]" by (rule imageI)
    qed (simp only: image_map_indets_Polys)
    moreover from assms(4) y.Abs_inject have "abs x \<notin> abs ` X" unfolding Y_def by blast
    moreover have "\<V> (insert (1 - punit.monom_mult 1 (Poly_Mapping.single (abs x) (Suc 0))
                                    (map_indets abs f)) (map_indets abs ` F)) = {}"
    proof (intro set_eqI iffI)
      fix a
      assume "a \<in> \<V> (insert (1 - punit.monom_mult 1 (Poly_Mapping.single (abs x) (Suc 0))
                                    (map_indets abs f)) (map_indets abs ` F))"
      also have "\<dots> = (\<lambda>b. b \<circ> abs) -` \<V> (insert (1 - punit.monom_mult 1 (Poly_Mapping.single x 1) f) F)"
        by (simp add: map_indets_minus map_indets_times map_indets_monomial
                flip: variety_of_map_indets times_monomial_left)
      finally show "a \<in> {}" by (simp only: assms(5) vimage_empty)
    qed simp
    ultimately have "map_indets abs f \<in> \<surd>ideal (map_indets abs ` F)"
      by (rule radical_idealI_internalized[where 'x='y, untransferred, simplified])
    hence "map_indets rep (map_indets abs f) \<in> map_indets rep ` \<surd>ideal (map_indets abs ` F)"
      by (rule imageI)
    also from 2 have "\<dots> = \<surd>(ideal F \<inter> P[Y]) \<inter> P[Y]"
      by (simp add: image_map_indets_ideal image_map_indets_radical image_image map_indets_map_indets
                    1 y.Rep_range)
    also have "\<dots> \<subseteq> \<surd>ideal F" using radical_mono by blast
    finally have ?thesis by (simp only: 0)
  }
  note rl = this[cancel_type_definition]
  have "Y \<noteq> {}" by (simp add: Y_def)
  thus ?thesis by (rule rl)
qed

corollary radical_idealI_extend_indets:
  assumes "finite X" and "F \<subseteq> P[X]"
    and "\<V> (insert (1 - punit.monom_mult 1 (Poly_Mapping.single None 1) (extend_indets f))
                            (extend_indets ` F)) = {}"
  shows "(f::_ \<Rightarrow>\<^sub>0 _::alg_closed_field) \<in> \<surd>ideal F"
proof -
  define Y where "Y = X \<union> indets f"
  from assms(1) have fin_Y: "finite Y" by (simp add: Y_def finite_indets)
  have "P[X] \<subseteq> P[Y]" by (rule Polys_mono) (simp add: Y_def)
  with assms(2) have F_sub: "F \<subseteq> P[Y]" by (rule subset_trans)
  have f_in: "f \<in> P[Y]" by (simp add: Y_def Polys_alt)

  let ?F = "extend_indets ` F"
  let ?f = "extend_indets f"
  let ?X = "Some ` Y"
  from fin_Y have "finite ?X" by (rule finite_imageI)
  moreover from F_sub have "?F \<subseteq> P[?X]"
    by (auto simp: indets_extend_indets intro!: PolysI_alt imageI dest!: PolysD(2) subsetD[of F])
  moreover from f_in have "?f \<in> P[?X]"
    by (auto simp: indets_extend_indets intro!: PolysI_alt imageI dest!: PolysD(2))
  moreover have "None \<notin> ?X" by simp
  ultimately have "?f \<in> \<surd>ideal ?F" using assms(3) by (rule radical_idealI)
  also have "?f \<in> \<surd>ideal ?F \<longleftrightarrow> f \<in> \<surd>ideal F"
  proof
    assume "f \<in> \<surd>ideal F"
    then obtain m where "f ^ m \<in> ideal F" by (rule radicalE)
    hence "extend_indets (f ^ m) \<in> extend_indets ` ideal F" by (rule imageI)
    with extend_indets_ideal_subset have "?f ^ m \<in> ideal ?F" unfolding extend_indets_power ..
    thus "?f \<in> \<surd>ideal ?F" by (rule radicalI)
  next
    assume "?f \<in> \<surd>ideal ?F"
    then obtain m where "?f ^ m \<in> ideal ?F" by (rule radicalE)
    moreover have "?f ^ m \<in> P[- {None}]"
      by (rule Polys_closed_power) (auto intro!: PolysI_alt simp: indets_extend_indets)
    ultimately have "extend_indets (f ^ m) \<in> extend_indets ` ideal F"
      by (simp add: extend_indets_ideal extend_indets_power)
    hence "f ^ m \<in> ideal F" by (simp only: inj_image_mem_iff[OF inj_extend_indets])
    thus "f \<in> \<surd>ideal F" by (rule radicalI)
  qed
  finally show ?thesis .
qed

theorem Nullstellensatz:
  assumes "finite X" and "F \<subseteq> P[X]"
    and "(f::_ \<Rightarrow>\<^sub>0 _::alg_closed_field) \<in> \<I> (\<V> F)"
  shows "f \<in> \<surd>ideal F"
  using assms(1, 2)
proof (rule radical_idealI_extend_indets)
  let ?f = "punit.monom_mult 1 (monomial 1 None) (extend_indets f)"
  show "\<V> (insert (1 - ?f) (extend_indets ` F)) = {}"
  proof (intro subset_antisym subsetI)
    fix a
    assume "a \<in> \<V> (insert (1 - ?f) (extend_indets ` F))"
    moreover have "1 - ?f \<in> insert (1 - ?f) (extend_indets ` F)" by simp
    ultimately have "poly_eval a (1 - ?f) = 0" by (rule variety_ofD)
    hence "poly_eval a (extend_indets f) \<noteq> 0"
      by (auto simp: poly_eval_minus poly_eval_times simp flip: times_monomial_left)
    hence "poly_eval (a \<circ> Some) f \<noteq> 0" by (simp add: poly_eval_extend_indets)
    have "a \<circ> Some \<in> \<V> F"
    proof (rule variety_ofI)
      fix f'
      assume "f' \<in> F"
      hence "extend_indets f' \<in> insert (1 - ?f) (extend_indets ` F)" by simp
      with \<open>a \<in> _\<close> have "poly_eval a (extend_indets f') = 0" by (rule variety_ofD)
      thus "poly_eval (a \<circ> Some) f' = 0" by (simp only: poly_eval_extend_indets)
    qed
    with assms(3) have "poly_eval (a \<circ> Some) f = 0" by (rule ideal_ofD)
    with \<open>poly_eval (a \<circ> Some) f \<noteq> 0\<close> show "a \<in> {}" ..
  qed simp
qed

theorem strong_Nullstellensatz:
  assumes "finite X" and "F \<subseteq> P[X]"
  shows "\<I> (\<V> F) = \<surd>ideal (F::(_ \<Rightarrow>\<^sub>0 _::alg_closed_field) set)"
proof (intro subset_antisym subsetI)
  fix f
  assume "f \<in> \<I> (\<V> F)"
  with assms show "f \<in> \<surd>ideal F" by (rule Nullstellensatz)
qed (metis ideal_ofI variety_ofD variety_of_radical_ideal)

theorem weak_Nullstellensatz:
  assumes "finite X" and "F \<subseteq> P[X]" and "\<V> F = ({}::(_ \<Rightarrow> _::alg_closed_field) set)"
  shows "ideal F = UNIV"
proof -
  from assms(1, 2) have "\<I> (\<V> F) = \<surd>ideal F" by (rule strong_Nullstellensatz)
  thus ?thesis by (simp add: assms(3) flip: radical_ideal_eq_UNIV_iff)
qed

lemma radical_ideal_iff:
  assumes "finite X" and "F \<subseteq> P[X]" and "f \<in> P[X]" and "x \<notin> X"
  shows "(f::_ \<Rightarrow>\<^sub>0 _::alg_closed_field) \<in> \<surd>ideal F \<longleftrightarrow>
            1 \<in> ideal (insert (1 - punit.monom_mult 1 (Poly_Mapping.single x 1) f) F)"
proof -
  let ?f = "punit.monom_mult 1 (Poly_Mapping.single x 1) f"
  show ?thesis
  proof
    assume "f \<in> \<surd>ideal F"
    then obtain m where "f ^ m \<in> ideal F" by (rule radicalE)
    from assms(1) have "finite (insert x X)" by simp
    moreover have "insert (1 - ?f) F \<subseteq> P[insert x X]" unfolding insert_subset
    proof (intro conjI Polys_closed_minus one_in_Polys Polys_closed_monom_mult PPs_closed_single)
      have "P[X] \<subseteq> P[insert x X]" by (rule Polys_mono) blast
      with assms(2, 3) show "f \<in> P[insert x X]" and "F \<subseteq> P[insert x X]" by blast+
    qed simp
    moreover have "\<V> (insert (1 - ?f) F) = {}"
    proof (intro subset_antisym subsetI)
      fix a
      assume "a \<in> \<V> (insert (1 - ?f) F)"
      moreover have "1 - ?f \<in> insert (1 - ?f) F" by simp
      ultimately have "poly_eval a (1 - ?f) = 0" by (rule variety_ofD)
      hence "poly_eval a (f ^ m) \<noteq> 0"
        by (auto simp: poly_eval_minus poly_eval_times poly_eval_power simp flip: times_monomial_left)
      from \<open>a \<in> _\<close> have "a \<in> \<V> (ideal (insert (1 - ?f) F))" by (simp only: variety_of_ideal)
      moreover from \<open>f ^ m \<in> ideal F\<close> ideal.span_mono have "f ^ m \<in> ideal (insert (1 - ?f) F)"
        by (rule rev_subsetD) blast
      ultimately have "poly_eval a (f ^ m) = 0" by (rule variety_ofD)
      with \<open>poly_eval a (f ^ m) \<noteq> 0\<close> show "a \<in> {}" ..
    qed simp
    ultimately have "ideal (insert (1 - ?f) F) = UNIV" by (rule weak_Nullstellensatz)
    thus "1 \<in> ideal (insert (1 - ?f) F)" by simp
  next
    assume "1 \<in> ideal (insert (1 - ?f) F)"
    have "\<V> (insert (1 - ?f) F) = {}"
    proof (intro subset_antisym subsetI)
      fix a
      assume "a \<in> \<V> (insert (1 - ?f) F)"
      hence "a \<in> \<V> (ideal (insert (1 - ?f) F))" by (simp only: variety_of_ideal)
      hence "poly_eval a 1 = 0" using \<open>1 \<in> _\<close> by (rule variety_ofD)
      thus "a \<in> {}" by simp
    qed simp
    with assms show "f \<in> \<surd>ideal F" by (rule radical_idealI)
  qed
qed

subsection \<open>Field-Theoretic Version of the Nullstellensatz\<close>

text \<open>Due to the possibility of infinite indeterminate-types, we have to explicitly add the set of
  indeterminates under consideration to the definition of maximal ideals.\<close>

definition generates_max_ideal :: "'x set \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_ring_1) set \<Rightarrow> bool"
  where "generates_max_ideal X F \<longleftrightarrow> (ideal F \<noteq> UNIV \<and>
                                      (\<forall>F'. F' \<subseteq> P[X] \<longrightarrow> ideal F \<subset> ideal F' \<longrightarrow> ideal F' = UNIV))"

lemma generates_max_idealI:
  assumes "ideal F \<noteq> UNIV" and "\<And>F'. F' \<subseteq> P[X] \<Longrightarrow> ideal F \<subset> ideal F' \<Longrightarrow> ideal F' = UNIV"
  shows "generates_max_ideal X F"
  using assms by (simp add: generates_max_ideal_def)

lemma generates_max_idealI_alt:
  assumes "ideal F \<noteq> UNIV" and "\<And>p. p \<in> P[X] \<Longrightarrow> p \<notin> ideal F \<Longrightarrow> 1 \<in> ideal (insert p F)"
  shows "generates_max_ideal X F"
  using assms(1)
proof (rule generates_max_idealI)
  fix F'
  assume "F' \<subseteq> P[X]" and sub: "ideal F \<subset> ideal F'"
  from this(2) ideal.span_subset_spanI have "\<not> F' \<subseteq> ideal F" by blast
  then obtain p where "p \<in> F'" and "p \<notin> ideal F" by blast
  from this(1) \<open>F' \<subseteq> P[X]\<close> have "p \<in> P[X]" ..
  hence "1 \<in> ideal (insert p F)" using \<open>p \<notin> _\<close> by (rule assms(2))
  also have "\<dots> \<subseteq> ideal (F' \<union> F)" by (rule ideal.span_mono) (simp add: \<open>p \<in> F'\<close>)
  also have "\<dots> = ideal (ideal F' \<union> ideal F)" by (simp add: ideal.span_Un ideal.span_span)
  also from sub have "ideal F' \<union> ideal F = ideal F'" by blast
  finally show "ideal F' = UNIV" by (simp only: ideal_eq_UNIV_iff_contains_one ideal.span_span)
qed

lemma generates_max_idealD:
  assumes "generates_max_ideal X F"
  shows "ideal F \<noteq> UNIV" and "F' \<subseteq> P[X] \<Longrightarrow> ideal F \<subset> ideal F' \<Longrightarrow> ideal F' = UNIV"
  using assms by (simp_all add: generates_max_ideal_def)

lemma generates_max_ideal_cases:
  assumes "generates_max_ideal X F" and "F' \<subseteq> P[X]" and "ideal F \<subseteq> ideal F'"
  obtains "ideal F = ideal F'" | "ideal F' = UNIV"
  using assms by (auto simp: generates_max_ideal_def)

lemma max_ideal_UNIV_radical:
  assumes "generates_max_ideal UNIV F"
  shows "\<surd>ideal F = ideal F"
proof (rule ccontr)
  assume "\<surd>ideal F \<noteq> ideal F"
  with radical_superset have "ideal F \<subset> \<surd>ideal F" by blast
  also have "\<dots> = ideal (\<surd>ideal F)" by simp
  finally have "ideal F \<subset> ideal (\<surd>ideal F)" .
  with assms _ have "ideal (\<surd>ideal F) = UNIV" by (rule generates_max_idealD) simp
  hence "\<surd>ideal F = UNIV" by simp
  hence "1 \<in> \<surd>ideal F" by simp
  hence "1 \<in> ideal F" by (auto elim: radicalE)
  hence "ideal F = UNIV" by (simp only: ideal_eq_UNIV_iff_contains_one)
  moreover from assms have "ideal F \<noteq> UNIV" by (rule generates_max_idealD)
  ultimately show False by simp
qed

lemma max_ideal_shape_aux:
  "(\<lambda>x. monomial 1 (Poly_Mapping.single x 1) - monomial (a x) 0) ` X \<subseteq> P[X]"
  by (auto intro!: Polys_closed_minus Polys_closed_monomial PPs_closed_single zero_in_PPs)

lemma max_ideal_shapeI:
  "generates_max_ideal X ((\<lambda>x. monomial (1::'a::field) (Poly_Mapping.single x 1) - monomial (a x) 0) ` X)"
    (is "generates_max_ideal X ?F")
proof (rule generates_max_idealI_alt)
  (* Proof modeled after https://math.stackexchange.com/a/1028331. *)

  show "ideal ?F \<noteq> UNIV"
  proof
    assume "ideal ?F = UNIV"
    hence "\<V> (ideal ?F) = \<V> UNIV" by (rule arg_cong)
    hence "\<V> ?F = {}" by simp
    moreover have "a \<in> \<V> ?F" by (rule variety_ofI) (auto simp: poly_eval_minus poly_eval_monomial)
    ultimately show False by simp
  qed
next
  fix p
  assume "p \<in> P[X]" and "p \<notin> ideal ?F"
  have "p \<in> ideal (insert p ?F)" by (rule ideal.span_base) simp
  let ?f = "\<lambda>x. monomial (1::'a) (Poly_Mapping.single x 1) - monomial (a x) 0"
  let ?g = "\<lambda>x. monomial (1::'a) (Poly_Mapping.single x 1) + monomial (a x) 0"
  define q where "q = poly_subst ?g p"
  have "p = poly_subst ?f q" unfolding q_def poly_subst_poly_subst
    by (rule sym, rule poly_subst_id)
        (simp add: poly_subst_plus poly_subst_monomial subst_pp_single flip: times_monomial_left)
  also have "\<dots> = (\<Sum>t\<in>keys q. punit.monom_mult (lookup q t) 0 (subst_pp ?f t))" by (fact poly_subst_def)
  also have "\<dots> = punit.monom_mult (lookup q 0) 0 (subst_pp ?f 0) +
                  (\<Sum>t\<in>keys q - {0}. monomial (lookup q t) 0 * subst_pp ?f t)"
      (is "_ = _ + ?r")
    by (cases "0 \<in> keys q") (simp_all add: sum.remove in_keys_iff flip: times_monomial_left)
  also have "\<dots> = monomial (lookup q 0) 0 + ?r" by (simp flip: times_monomial_left)
  finally have eq: "p - ?r = monomial (lookup q 0) 0" by simp
  have "?r \<in> ideal ?F"
  proof (intro ideal.span_sum ideal.span_scale)
    fix t
    assume "t \<in> keys q - {0}"
    hence "t \<in> keys q" and "keys t \<noteq> {}" by simp_all
    from this(2) obtain x where "x \<in> keys t" by blast
    hence "x \<in> indets q" using \<open>t \<in> keys q\<close> by (rule in_indetsI)
    then obtain y where "y \<in> indets p" and "x \<in> indets (?g y)" unfolding q_def
      by (rule in_indets_poly_substE)
    from this(2) indets_plus_subset have "x \<in> indets (monomial (1::'a) (Poly_Mapping.single y 1)) \<union>
                                                indets (monomial (a y) 0)" ..
    with \<open>y \<in> indets p\<close> have "x \<in> indets p" by (simp add: indets_monomial)
    also from \<open>p \<in> P[X]\<close> have "\<dots> \<subseteq> X" by (rule PolysD)
    finally have "x \<in> X" .
    from \<open>x \<in> keys t\<close> have "lookup t x \<noteq> 0" by (simp add: in_keys_iff)
    hence eq: "b ^ lookup t x = b ^ Suc (lookup t x - 1)" for b by simp

    have "subst_pp ?f t = (\<Prod>y\<in>keys t. ?f y ^ lookup t y)" by (fact subst_pp_def)
    also from \<open>x \<in> keys t\<close> have "\<dots> = ((\<Prod>y\<in>keys t - {x}. ?f y ^ lookup t y) * ?f x ^ (lookup t x - 1)) * ?f x"
      by (simp add: prod.remove mult.commute eq)
    also from \<open>x \<in> X\<close> have "\<dots> \<in> ideal ?F" by (intro ideal.span_scale ideal.span_base imageI)
    finally show "subst_pp ?f t \<in> ideal ?F" .
  qed
  also have "\<dots> \<subseteq> ideal (insert p ?F)" by (rule ideal.span_mono) blast
  finally have "?r \<in> ideal (insert p ?F)" .
  with \<open>p \<in> ideal _\<close> have "p - ?r \<in> ideal (insert p ?F)" by (rule ideal.span_diff)
  hence "monomial (lookup q 0) 0 \<in> ideal (insert p ?F)" by (simp only: eq)
  hence "monomial (inverse (lookup q 0)) 0 * monomial (lookup q 0) 0 \<in> ideal (insert p ?F)"
    by (rule ideal.span_scale)
  hence "monomial (inverse (lookup q 0) * lookup q 0) 0 \<in> ideal (insert p ?F)"
    by (simp add: times_monomial_monomial)
  moreover have "lookup q 0 \<noteq> 0"
  proof
    assume "lookup q 0 = 0"
    with eq \<open>?r \<in> ideal ?F\<close> have "p \<in> ideal ?F" by simp
    with \<open>p \<notin> ideal ?F\<close> show False ..
  qed
  ultimately show "1 \<in> ideal (insert p ?F)" by simp
qed

text \<open>We first prove the following lemma assuming that the type of indeterminates is finite, and then
  transfer the result to arbitrary types of indeterminates by using the `types to sets' methodology.
  This approach facilitates the proof considerably.\<close>

lemma max_ideal_shapeD_finite:
  assumes "generates_max_ideal UNIV (F::(('x::finite \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::alg_closed_field) set)"
  obtains a where "ideal F = ideal (range (\<lambda>x. monomial 1 (Poly_Mapping.single x 1) - monomial (a x) 0))"
proof -
  have fin: "finite (UNIV::'x set)" by simp
  have "(\<Inter>a\<in>\<V> F. ideal (range (\<lambda>x. monomial 1 (Poly_Mapping.single x 1) - monomial (a x) 0))) = \<I> (\<V> F)"
    (is "?A = _")
  proof (intro set_eqI iffI ideal_ofI INT_I)
    fix p a
    assume "p \<in> ?A" and "a \<in> \<V> F"
    hence "p \<in> ideal (range (\<lambda>x. monomial 1 (Poly_Mapping.single x 1) - monomial (a x) 0))"
      (is "_ \<in> ideal ?B") ..
    have "a \<in> \<V> ?B"
    proof (rule variety_ofI)
      fix f
      assume "f \<in> ?B"
      then obtain x where "f = monomial 1 (Poly_Mapping.single x 1) - monomial (a x) 0" ..
      thus "poly_eval a f = 0" by (simp add: poly_eval_minus poly_eval_monomial)
    qed
    hence "a \<in> \<V> (ideal ?B)" by (simp only: variety_of_ideal)
    thus "poly_eval a p = 0" using \<open>p \<in> ideal _\<close> by (rule variety_ofD)
  next
    fix p a
    assume "p \<in> \<I> (\<V> F)" and "a \<in> \<V> F"
    hence eq: "poly_eval a p = 0" by (rule ideal_ofD)
    have "p \<in> \<surd>ideal (range (\<lambda>x. monomial 1 (monomial 1 x) - monomial (a x) 0))" (is "_ \<in> \<surd>ideal ?B")
      using fin max_ideal_shape_aux
    proof (rule Nullstellensatz)
      show "p \<in> \<I> (\<V> ?B)"
      proof (rule ideal_ofI)
        fix a0
        assume "a0 \<in> \<V> ?B"
        have "a0 = a"
        proof
          fix x
          have "monomial 1 (monomial 1 x) - monomial (a x) 0 \<in> ?B" by (rule rangeI)
          with \<open>a0 \<in> _\<close> have "poly_eval a0 (monomial 1 (monomial 1 x) - monomial (a x) 0) = 0"
            by (rule variety_ofD)
          thus "a0 x = a x" by (simp add: poly_eval_minus poly_eval_monomial)
        qed
        thus "poly_eval a0 p = 0" by (simp only: eq)
      qed
    qed
    also have "\<dots> = ideal (range (\<lambda>x. monomial 1 (monomial 1 x) - monomial (a x) 0))"
      using max_ideal_shapeI by (rule max_ideal_UNIV_radical)
    finally show "p \<in> ideal (range (\<lambda>x. monomial 1 (monomial 1 x) - monomial (a x) 0))" .
  qed
  also from fin have "\<dots> = \<surd>ideal F" by (rule strong_Nullstellensatz) simp
  also from assms have "\<dots> = ideal F" by (rule max_ideal_UNIV_radical)
  finally have eq: "?A = ideal F" .
  also from assms have "\<dots> \<noteq> UNIV" by (rule generates_max_idealD)
  finally obtain a where "a \<in> \<V> F"
    and "ideal (range (\<lambda>x. monomial 1 (Poly_Mapping.single x (1::nat)) - monomial (a x) 0)) \<noteq> UNIV"
      (is "?B \<noteq> _") by auto
  from \<open>a \<in> \<V> F\<close> have "ideal F \<subseteq> ?B" by (auto simp flip: eq)
  with assms max_ideal_shape_aux show ?thesis
  proof (rule generates_max_ideal_cases)
    assume "ideal F = ?B"
    thus ?thesis ..
  next
    assume "?B = UNIV"
    with \<open>?B \<noteq> UNIV\<close> show ?thesis ..
  qed
qed

lemmas max_ideal_shapeD_internalized = max_ideal_shapeD_finite[unoverload_type 'x]

lemma max_ideal_shapeD:
  assumes "finite X" and "F \<subseteq> P[X]"
    and "generates_max_ideal X (F::(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::alg_closed_field) set)"
  obtains a where "ideal F = ideal ((\<lambda>x. monomial 1 (Poly_Mapping.single x 1) - monomial (a x) 0) ` X)"
proof (cases "X = {}")
  case True
  from assms(3) have "ideal F \<noteq> UNIV" by (rule generates_max_idealD)
  hence "1 \<notin> ideal F" by (simp add: ideal_eq_UNIV_iff_contains_one)
  have "F \<subseteq> {0}"
  proof
    fix f
    assume "f \<in> F"
    with assms(2) have "f \<in> P[X]" ..
    then obtain c where f: "f = monomial c 0" by (auto simp: True Polys_empty)
    with \<open>f \<in> F\<close> have "monomial c 0 \<in> ideal F" by (simp only: ideal.span_base)
    hence "monomial (inverse c) 0 * monomial c 0 \<in> ideal F" by (rule ideal.span_scale)
    hence "monomial (inverse c * c) 0 \<in> ideal F" by (simp add: times_monomial_monomial)
    with \<open>1 \<notin> ideal F\<close> left_inverse have "c = 0" by fastforce
    thus "f \<in> {0}" by (simp add: f)
  qed
  hence "ideal F = ideal ((\<lambda>x. monomial 1 (Poly_Mapping.single x 1) - monomial (undefined x) 0) ` X)"
    by (simp add: True)
  thus ?thesis ..
next
  case False
  {
    text \<open>We define the type @{typ 'y} to be isomorphic to @{term X}.\<close>
    assume "\<exists>(Rep :: 'y \<Rightarrow> 'x) Abs. type_definition Rep Abs X"
    then obtain rep :: "'y \<Rightarrow> 'x" and abs :: "'x \<Rightarrow> 'y" where t: "type_definition rep abs X"
      by blast
    then interpret y: type_definition rep abs X .

    have 1: "map_indets (rep \<circ> abs) ` A = A" if "A \<subseteq> P[X]" for A::"(_ \<Rightarrow>\<^sub>0 'a) set"
    proof
      from that show "map_indets (rep \<circ> abs) ` A \<subseteq> A"
        by (smt PolysD(2) comp_apply image_subset_iff map_indets_id subsetD y.Abs_inverse)
    next
      from that show "A \<subseteq> map_indets (rep \<circ> abs) ` A"
        by (smt PolysD(2) comp_apply image_eqI map_indets_id subsetD subsetI y.Abs_inverse)
    qed
    have 2: "inj rep" by (meson inj_onI y.Rep_inject)
    hence 3: "inj (map_indets rep)" by (rule map_indets_injI)

    have "class.finite TYPE('y)"
    proof
      from assms(1) have "finite (abs ` X)" by (rule finite_imageI)
      thus "finite (UNIV::'y set)" by (simp only: y.Abs_image)
    qed
    moreover have "generates_max_ideal UNIV (map_indets abs ` F)"
    proof (intro generates_max_idealI notI)
      assume "ideal (map_indets abs ` F) = UNIV"
      hence "1 \<in> ideal (map_indets abs ` F)" by simp
      hence "map_indets rep 1 \<in> map_indets rep ` ideal (map_indets abs ` F)" by (rule imageI)
      also from map_indets_plus map_indets_times have "\<dots> \<subseteq> ideal (map_indets rep ` map_indets abs ` F)"
        by (rule image_ideal_subset)
      also from assms(2) have "map_indets rep ` map_indets abs ` F = F"
        by (simp only: image_image map_indets_map_indets 1)
      finally have "1 \<in> ideal F" by simp
      moreover from assms(3) have "ideal F \<noteq> UNIV" by (rule generates_max_idealD)
      ultimately show False by (simp add: ideal_eq_UNIV_iff_contains_one)
    next
      fix F'
      assume "ideal (map_indets abs ` F) \<subset> ideal F'"
      with inj_on_subset have "map_indets rep ` ideal (map_indets abs ` F) \<subset> map_indets rep ` ideal F'"
        by (rule inj_on_strict_subset) (fact 3, fact subset_UNIV)
      hence sub: "ideal F \<inter> P[X] \<subset> ideal (map_indets rep ` F') \<inter> P[X]" using 2 assms(2)
        by (simp add: image_map_indets_ideal image_image map_indets_map_indets 1 y.Rep_range)
      have "ideal F \<subset> ideal (map_indets rep ` F')"
      proof (intro psubsetI notI ideal.span_subset_spanI subsetI)
        fix p
        assume "p \<in> F"
        with assms(2) ideal.span_base sub show "p \<in> ideal (map_indets rep ` F')" by blast
      next
        assume "ideal F = ideal (map_indets rep ` F')"
        with sub show False by simp
      qed
      with assms(3) _ have "ideal (map_indets rep ` F') = UNIV"
      proof (rule generates_max_idealD)
        from subset_UNIV have "map_indets rep ` F' \<subseteq> range (map_indets rep)" by (rule image_mono)
        also have "\<dots> = P[X]" by (simp only: range_map_indets y.Rep_range)
        finally show "map_indets rep ` F' \<subseteq> P[X]" .
      qed
      hence "P[range rep] = ideal (map_indets rep ` F') \<inter> P[range rep]" by simp
      also from 2 have "\<dots> = map_indets rep ` ideal F'" by (simp only: image_map_indets_ideal)
      finally have "map_indets rep ` ideal F' = range (map_indets rep)"
        by (simp only: range_map_indets)
      with 3 show "ideal F' = UNIV" by (metis inj_image_eq_iff)
    qed
    ultimately obtain a
      where *: "ideal (map_indets abs ` F) =
                 ideal (range (\<lambda>x. monomial 1 (Poly_Mapping.single x (Suc 0)) - monomial (a x) 0))"
        (is "_ = ?A")
      by (rule max_ideal_shapeD_internalized[where 'x='y, untransferred, simplified])
    hence "map_indets rep ` ideal (map_indets abs ` F) = map_indets rep ` ?A" by simp
    with 2 assms(2) have "ideal F \<inter> P[X] =
           ideal (range (\<lambda>x. monomial 1 (Poly_Mapping.single (rep x) 1) - monomial (a x) 0)) \<inter> P[X]"
        (is "_ = ideal ?B \<inter> _")
      by (simp add: image_map_indets_ideal y.Rep_range image_image map_indets_map_indets
              map_indets_minus map_indets_monomial 1)
    also have "?B = (\<lambda>x. monomial 1 (Poly_Mapping.single x 1) - monomial ((a \<circ> abs) x) 0) ` X"
        (is "_ = ?C")
    proof
      show "?B \<subseteq> ?C" by (smt comp_apply image_iff image_subset_iff y.Abs_image y.Abs_inverse)
    next
      from y.Rep_inverse y.Rep_range show "?C \<subseteq> ?B" by auto
    qed
    finally have eq: "ideal F \<inter> P[X] = ideal ?C \<inter> P[X]" .
    have "ideal F = ideal ?C"
    proof (intro subset_antisym ideal.span_subset_spanI subsetI)
      fix p
      assume "p \<in> F"
      with assms(2) ideal.span_base have "p \<in> ideal F \<inter> P[X]" by blast
      thus "p \<in> ideal ?C" by (simp add: eq)
    next
      fix p
      assume "p \<in> ?C"
      then obtain x where "x \<in> X" and "p = monomial 1 (monomial 1 x) - monomial ((a \<circ> abs) x) 0" ..
      note this(2)
      also from \<open>x \<in> X\<close> have "\<dots> \<in> P[X]"
        by (intro Polys_closed_minus Polys_closed_monomial PPs_closed_single zero_in_PPs)
      finally have "p \<in> P[X]" .
      with \<open>p \<in> ?C\<close> have "p \<in> ideal ?C \<inter> P[X]" by (simp add: ideal.span_base)
      also have "\<dots> = ideal F \<inter> P[X]" by (simp only: eq)
      finally show "p \<in> ideal F" by simp
    qed
    hence ?thesis ..
  }
  note rl = this[cancel_type_definition]
  from False show ?thesis by (rule rl)
qed

theorem Nullstellensatz_field:
  assumes "finite X" and "F \<subseteq> P[X]" and "generates_max_ideal X (F::(_ \<Rightarrow>\<^sub>0 _::alg_closed_field) set)"
    and "x \<in> X"
  shows "{0} \<subset> ideal F \<inter> P[{x}]"
  unfolding subset_not_subset_eq
proof (intro conjI notI)
  show "{0} \<subseteq> ideal F \<inter> P[{x}]" by (auto intro: ideal.span_zero zero_in_Polys)
next
  from assms(1, 2, 3) obtain a
    where eq: "ideal F = ideal ((\<lambda>x. monomial 1 (monomial 1 x) - monomial (a x) 0) ` X)"
    by (rule max_ideal_shapeD)
  let ?p = "\<lambda>x. monomial 1 (monomial 1 x) - monomial (a x) 0"
  from assms(4) have "?p x \<in> ?p ` X" by (rule imageI)
  also have "\<dots> \<subseteq> ideal F" unfolding eq by (rule ideal.span_superset)
  finally have "?p x \<in> ideal F" .
  moreover have "?p x \<in> P[{x}]"
    by (auto intro!: Polys_closed_minus Polys_closed_monomial PPs_closed_single zero_in_PPs)
  ultimately have "?p x \<in> ideal F \<inter> P[{x}]" ..
  also assume "\<dots> \<subseteq> {0}"
  finally show False
    by (metis diff_eq_diff_eq diff_self monomial_0D monomial_inj one_neq_zero singletonD)
qed

end (* theory *)


text \<open> Version 0.5, last changed 2019-01-30
  (C) fovefi ltd, www.fovefi.co
  (author: Lukas Bulwahn [lubu@fovefi.co], comments by Manfred Kerber [make@fovefi.co])

  Dually licenced under
  Creative Commons Attribution (CC-BY) 4.0 [https://creativecommons.org/licenses/by/4.0/]
  ISC License (1-clause BSD License)       [https://www.isc.org/downloads/software-support-policy/isc-license/]
  See LICENSE files for details.
  (Rationale for this dual licence: http://arxiv.org/abs/1107.3212)

  In the following, an executable definition of the percentile function is given that is
  close to the one used in OpenSIMM, a system with a standard implementation for the computation
  of risk.
  \<close>

theory Percentile_Code
  imports Percentile
begin

section \<open>Code Generation of Percentile\<close>
paragraph \<open>The percentile definition close to the Java implementation\<close>

text \<open> In the Java code follows a check that the level is below 1 - 1/(2*size).
 * If not, it throws an exception. In the Isabelle implementation (there is no exception
 * handling in Isabelle), the code is underspecified, that is, no specific values will be
 * returned for larger values. This will be fixed in the definition of the percentile function
 * in the next section.
 \<close>

text \<open> An integer greater equal 0 considered as a real number is the same as the integer first considered
       as a natural number and this then considered as a real number. \<close>
lemma real_of_int:
  assumes "0 \<le> i"
  shows "real_of_int i = real (nat i)"
by (simp add: assms)

text \<open> The value of the minimum of the domain of equidistant point is determined. \<close>
lemma Min_equidistant_points_on_unit_interval_of_bounded:
  fixes x :: real
  assumes "ys \<noteq> []"
  assumes "1 / (2 * length ys) < x"
  assumes "x \<le> 1 - 1 / (2 * length ys)"
  shows "Min {x' \<in> dom (equidistant_points_on_unit_interval_of ys). x \<le> x'} = (ceiling (length ys * x - 0.5) + 0.5) / length ys"
  (is "Min ?A = ?expr")
proof (rule Min_eqI)
  text \<open>let ?A = "{x' \<in> dom (equidistant_points_on_unit_interval_of ys). x \<le> x'}"\<close>
  show "finite ?A" by simp
  show "?expr \<le> y" if "y \<in> ?A" for y
  proof -
    from that \<open>ys \<noteq> []\<close> obtain n where "y = (real n + 1 / 2) / real (length ys)" and "x \<le> y"
      unfolding equidistant_points_on_unit_interval_of_def
      apply auto done
    obtain i where "i = int n" by auto
    from this \<open>y = _\<close> have y: "y = (real_of_int i + 1 / 2) / real (length ys)"
      by simp
    have "i \<ge> ceiling (length ys * x - 0.5)"
    proof -
      have "x \<le> (real_of_int i + 1 / 2) / real (length ys)"
        using \<open>x \<le> y\<close> y by blast
      from this have "length ys * x \<le> (real_of_int i + 1 / 2)"
        apply -
        apply (frule mult_left_mono[where c="real (length ys)"])
         apply simp
        by (simp add: assms(1))
        find_theorems "_ * _ \<le> _ * _"
      from this have "length ys * x - 1 / 2 \<le> real_of_int i" by linarith
      from this show ?thesis
        by (simp add: ceiling_le)
    qed
    from this y have "y \<ge> (real_of_int (ceiling (length ys * x - 0.5)) + 1 / 2) / real (length ys)"
      apply simp
      find_theorems "_ / _ \<le> _ / _"
      apply (rule divide_right_mono)
      apply simp
      apply simp
      done
    from this show ?thesis by simp
  qed
  show "?expr \<in> ?A"
  proof -
    from assms have "0 \<le> real (length ys) * x - 1 / 2"
      apply auto
      by (simp add: Groups.mult_ac(2) divide_less_eq)
    from this have "0 \<le> \<lceil>real (length ys) * x - 1 / 2\<rceil>" by simp
    from this have a: "real_of_int \<lceil>real (length ys) * x - 1 / 2\<rceil> = real (nat \<lceil>real (length ys) * x - 1 / 2\<rceil>)"
      by simp
    have b: "nat \<lceil>real (length ys) * x - 1 / 2\<rceil> \<in> {0..<length ys}"
    proof -
      have "real (length ys) * x - 1 / 2 \<le> (length ys - 1)"
      proof -
        have "real (length ys) * x - 1 / 2 \<le> real (length ys) * (1 - 1 / real (2 * length ys)) - 1 / 2"
          using assms(1, 3) by simp
        also have "\<dots> = real (length ys) - 1"
          apply auto
          apply (subst right_diff_distrib)
          apply simp
          by (simp add: assms(1))
        also have "\<dots> = real (length ys - 1)"
          by (metis One_nat_def Suc_pred assms(1) diff_Suc_Suc diff_is_0_eq length_greater_0_conv of_nat_1 of_nat_diff zero_diff)
        finally show ?thesis .
      qed
      text \<open>have "\<lceil>real (length ys) * x - 1 / 2\<rceil> \<ge> 0" s_orry\<close>
      from this have a: "\<lceil>real (length ys) * x - 1 / 2\<rceil> \<le> \<lceil>real (length ys - 1)\<rceil>"
        using ceiling_mono by blast
      have "\<lceil>real (length ys - 1)\<rceil> = int (length ys - 1)" by simp
      from a this have "nat \<lceil>real (length ys) * x - 1 / 2\<rceil> < length ys"
        by (smt assms(1) int_nat_eq length_greater_0_conv nat_less_le of_nat_0_less_iff of_nat_1 of_nat_diff of_nat_less_imp_less zero_less_diff)
      from this show ?thesis
        apply auto done
    qed
    have "(real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> + 5 / 10) / real (length ys)
      \<in> dom (equidistant_points_on_unit_interval_of ys)"
      unfolding dom_equidistant_points_on_unit_interval_of
      apply auto
      apply (subst a)
      apply (rule image_eqI)
       apply (rule refl)
      apply (rule b) done
      find_theorems "dom (equidistant_points_on_unit_interval_of _)"
    moreover have "x \<le> (real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> + 5 / 10) / real (length ys)"
    proof -
      have "real (length ys) > 0" (* only need \<ge> *)
        by (simp add: assms)
      have a: "real (length ys) * x - 5 / 10 \<le> real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil>"
        by linarith
      have "x \<le> ((real (length ys) * x - 5 / 10) + 5 / 10) / real (length ys)"
        using \<open>real (length ys) > 0\<close> by auto
      also have "\<dots> \<le> (real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> + 5 / 10) / real (length ys)"
        using \<open>real (length ys) > 0\<close> a
        apply -
        apply (rule divide_right_mono)
        apply linarith
        apply simp done
      finally show ?thesis .
    qed
    ultimately show ?thesis by auto
  qed
qed

text \<open> A property of the ceiling function. \<close>
lemma ceiling_minus_leq:
  assumes "a + b \<ge> 1"
  shows "real_of_int \<lceil>x - a\<rceil> - b \<le> x"
using assms by linarith

text \<open> Relationship between floor and ceiling (floor plus 1 is less equal ceiling). \<close>
lemma floor_leq_ceiling:
  fixes x :: real
  assumes "x \<notin> real_of_int ` UNIV"
  shows "1 + real_of_int (floor x) \<le> real_of_int (ceiling x)"
using assms by (smt UNIV_I ceiling_correct image_eqI int_less_real_le le_floor_iff)

text \<open> If i < y for two integers then i \<le> y - 1 (when converted to real).\<close>
lemma less_to_leq:
  fixes y :: real
  assumes "real i < y"
  assumes "y \<in> real_of_int ` UNIV"
  shows "real i \<le> y - 1"
proof -
  from assms(2) obtain j where "y = real_of_int j"
    apply auto done
  obtain k where "j = int k"
    by (smt \<open>y = real_of_int j\<close> assms(1) int_less_real_le nat_0_le of_int_1 of_nat_0_le_iff)
  from this \<open>y = _\<close> assms(1) show ?thesis by auto
qed

text \<open> The value of the maximum of the domain of equidistant point is determined. \<close>
lemma Max_equidistant_points_on_unit_interval_of_bounded:
  fixes x :: real
  assumes "ys \<noteq> []"
  assumes "1 / (2 * length ys) < x" "x \<le> 1 - 1 / (2 * length ys)"
  shows "Max {x' \<in> dom (equidistant_points_on_unit_interval_of ys). x' < x} = (ceiling (length ys * x - 0.5) - 0.5) / length ys"
    (is "_ = ?expr")
proof -
  let ?A = "{x' \<in> (\<lambda>x. (1 / length ys) * (x + 0.5)) ` {0..<length ys}. x' < x}"
  have "Max ?A = ?expr"
  find_theorems "_ ` _" "Max"
  proof (rule Max_eqI)
    show "finite ?A" by simp
    show "y \<le> ?expr" if "y \<in> ?A" for y
    proof -
      show ?thesis
      proof (cases "real (length ys) * x - 1 / 2 \<in> range real_of_int")
        case True
          from that obtain i where "i \<in> {0..<length ys}"
            and y: "y = 1 / real (length ys) * (real i + 5 / 10)" and "y < x" by auto
          have "(real i + 5 / 10) < real (length ys) * x"
            by (metis \<open>y < x\<close> assms(1) divide_less_eq length_greater_0_conv mult.commute mult_numeral_1 numeral_One of_nat_0_less_iff times_divide_eq_right y)
          from this have "real i < real (length ys) * x - 0.5"
            by linarith
          from this have "real i \<le> real (length ys) * x - 1.5"
            apply -
            apply (frule less_to_leq)
            apply (simp add: True)
            by linarith
          from this have "(real i + 5 / 10) \<le> real (length ys) * x - 1"
            apply simp done
          have "1 / real (length ys) > 0" by (simp add: assms(1))
          from this assms y have y2: "y \<le> 1 / real (length ys) * (real (length ys) * x - 1)"
            using \<open>real i + 5 / 10 \<le> real (length ys) * x - 1\<close> real_mult_le_cancel_iff2 by blast
          have "real (length ys) * x - 1 / 2 \<le> real_of_int \<lceil>real (length ys) * x - 1 / 2\<rceil>"
            by simp
          from this have "real (length ys) * x - 1 \<le> real_of_int \<lceil>real (length ys) * x - 1 / 2\<rceil> - 1 / 2"
          proof -
            have "real (length ys) * x - 1 = (real (length ys) * x - 1 / 2) - 1 / 2" by simp
            also have "\<dots> \<le> real_of_int \<lceil>real (length ys) * x - 1 / 2\<rceil> - 1 / 2"
              by linarith
            finally show ?thesis .
          qed
        from this y2 show ?thesis
          apply auto
          find_theorems "?a \<le> ?b \<Longrightarrow> ?b \<le> ?c \<Longrightarrow> ?a \<le> ?c"
          apply (rule order.trans)
          apply assumption
          apply (rule divide_right_mono)
          apply simp apply simp done
          find_theorems "_ / _ \<le> _ / _"
      next
        case False
        then show ?thesis
        proof -
          have "y \<le> 1 / real (length ys) * (real_of_int \<lfloor>real (length ys) * x - 5 / 10\<rfloor> + 5 / 10)"
          proof -
            from that obtain i where "i \<in> {0..<length ys}"
              and "y = 1 / real (length ys) * (real i + 5 / 10)" and "y \<le> x" by auto
            have "i \<le> \<lfloor>real (length ys) * x - 5 / 10\<rfloor>"
        proof -
          have a: "1 / real (length ys) * (real i + 5 / 10) \<le> x"
            using \<open>y = _\<close> \<open>y \<le> x\<close> by blast
          have "(real i + 5 / 10) \<le> real (length ys) * x"
          proof -
            have "(real i + 5 / 10) = real (length ys) * (1 / real (length ys) * (real i + 5 / 10))"
              by (simp add: assms(1))
            also have "\<dots> \<le> real (length ys) * x"
              using a mult_left_mono of_nat_0_le_iff by blast
            finally show ?thesis .
          qed
          from this have "real i \<le> real (length ys) * x - 5 / 10" by linarith
          from this show ?thesis by linarith
        qed
        from this \<open>y = _\<close> show ?thesis
        proof -
          have "real (length ys) > 0" by (simp add: assms(1))
          from \<open>i \<le> floor _\<close> have "(real i + 5 / 10) \<le> real_of_int \<lfloor>real (length ys) * x - 5 / 10\<rfloor> + 5 / 10"
            by linarith
          from this \<open>y = _\<close> \<open>real (length ys) > 0\<close> show ?thesis
            using real_mult_le_cancel_iff2 by fastforce
        qed
      qed
      also have "\<dots> \<le> (real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> - 5 / 10) / real (length ys)"
      proof -
        from False
        have "(real_of_int \<lfloor>real (length ys) * x - 5 / 10\<rfloor> + 5 / 10) \<le> (real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> - 5 / 10)"
          apply simp
          apply (rule floor_leq_ceiling)
          apply assumption
          done
        from this show ?thesis
          apply simp
          apply (rule divide_right_mono)
           apply simp apply simp done
      qed
      finally show ?thesis .
    qed
    qed qed
    show "?expr \<in> ?A"
    proof -
      have "?expr \<in> (\<lambda>x. 1 / real (length ys) * (real x + 5 / 10)) ` {0..<length ys}"
      proof
        have "real (length ys) * x - 1 / 2 > 0"
          by (metis assms(1) assms(2) diff_gt_0_iff_gt divide_divide_eq_left divide_less_eq length_greater_0_conv mult.commute of_nat_0_less_iff of_nat_mult of_nat_numeral)
        from this have "nat \<lceil>real (length ys) * x - 1 / 2\<rceil> \<ge> 1"
          by linarith
        from this show "(real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> - 5 / 10) / real (length ys) =
          1 / real (length ys) * (real (nat \<lceil>real (length ys) * x - 5 / 10\<rceil> - 1) + 5 / 10)"
          using \<open>ys \<noteq> []\<close>
          apply auto done
        have "real (length ys) \<ge> 0" by auto
        have "x \<le> 1"
          by (smt assms(3) divide_less_0_1_iff of_nat_0_le_iff)
        from this have "real (length ys) * x \<le> length ys"
          by (simp add: mult_left_le)
        from this \<open>real (length ys) \<ge> 0\<close> have "real (length ys) * x \<le> length ys + 1 / 2"
          by linarith
        from this have "real (length ys) * x - 1 / 2 \<le> length ys"
          by fastforce
        from this show "nat \<lceil>real (length ys) * x - 5 / 10\<rceil> - 1 \<in> {0..<length ys}"
          apply auto
          using \<open>1 \<le> nat \<lceil>real (length ys) * x - 1 / 2\<rceil>\<close> by linarith
      qed
      moreover have "?expr < x"
      proof -
        have "real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> < real (length ys) * x + 5 / 10"
          by linarith
        then have "real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> < x * real (length ys) + 5 / 10"
          by (simp add: mult.commute)
        have "real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> - 5 / 10 < x * real (length ys)"
          using \<open>real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> < x * real (length ys) + 5 / 10\<close> by linarith
        from this show "(real_of_int \<lceil>real (length ys) * x - 5 / 10\<rceil> - 5 / 10) / real (length ys) < x"
          apply auto
          by (simp add: assms(1) divide_less_eq)
      qed
      ultimately show ?thesis by auto
    qed
  qed
  from this show ?thesis
    unfolding equidistant_points_on_unit_interval_of_def by simp
qed

text \<open> The lemma determines the values of equidistant point on the unit interval. \<close>
lemma equidistant_points_on_unit_interval_of_eq_nth2:
  fixes i :: int
  assumes "0 \<le> i" "nat i < length ys"
  shows "the (equidistant_points_on_unit_interval_of ys ((real_of_int i + 5 / 10) / size ys)) = ys ! (nat i)"
proof -
  let ?xs = "map (\<lambda>x. (real x + 1 / 2) / real (length ys)) [0..<length ys]"
  have "distinct ?xs" by (auto intro!: inj_onI simp add: distinct_map)
  have eq: "(real_of_int i + 1 / 2) / real (length ys) = ?xs ! nat i"
    using assms by auto
  show ?thesis
    unfolding equidistant_points_on_unit_interval_of_def
    apply simp
    apply (subst eq)
    thm map_of_zip_nth
    apply (subst map_of_zip_nth)
       apply simp
      apply (rule \<open>distinct ?xs\<close>)
     apply (rule assms)
    apply simp done
qed

text \<open> The lemma gives an alternative characterization of the values of equidistant point on the unit interval. \<close>
lemma equidistant_points_on_unit_interval_of_eq_nth1:
  fixes i :: int
  assumes "1 \<le> i" "i \<le> length ys"
  shows "the (equidistant_points_on_unit_interval_of ys ((real_of_int i - 5 / 10) / size ys)) = ys ! nat (i - 1)"
proof -
  (* todo: size ys = real (length ys); which is better to write down? *)
  let ?f = "\<lambda>x. the (equidistant_points_on_unit_interval_of ys (x / size ys))"
  have "?f (real_of_int i - 5 / 10) = ?f (real_of_int (i - 1) + 5 / 10)" by force
  also have "\<dots> = ys ! nat (i - 1)"
    using assms by (simp only: equidistant_points_on_unit_interval_of_eq_nth2)
  finally show ?thesis .
qed

text \<open> The definition contains an executable version of the percentile function which is close to the
       Java implementation in the OpenSIMM implementation. \<close>
definition percentile_impl :: "real list \<Rightarrow> real \<Rightarrow> real"
where
  "percentile_impl values level =
    (let  (size :: real) = (real (length values));
           (sorted :: (real list)) = sort values;
           i = (ceiling (size * level - 0.5));
           (lower :: real) = (i - 0.5) / size;
           (upper ::real) = (i + 0.5) / size;
           \<comment>\<open>Note that we convert i to a nat since we want to use it
              as an index in a list. This means that we automatically
              have values greater equal 0\<close>
           (lower_value :: real)  = sorted ! (nat (i-1));
           (upper_value :: real)  = sorted ! (nat i)
    in lower_value + (level - lower) * (upper_value - lower_value) / (upper - lower))"

text \<open> The lemma states the equivalence of the abstract definition of the percentile function from
       the Percentile theory and the computational version in the standard interval, except the left limit. \<close>
lemma percentile_java_equiv_except_left:
  assumes "values \<noteq> []"
  assumes "1 / real (2 * length values) < level" (* todo: lesseq instead of less *)
  assumes "level \<le> 1 - 1 / real (2 * length values)"
  shows "Percentile.percentile values level = percentile_impl values level"
proof -
  from assms(2) have "level \<noteq> 1 / real (2 * length values)" by blast
  let ?def = "(let p = equidistant_points_on_unit_interval_of (sort values);
         (x1, x2) = (Max {x' \<in> dom p. x' < level}, Min {x' \<in> dom p. level \<le> x'});
         (y1, y2) = (the (p x1), the (p x2))
     in linear (x1, y1) (x2, y2) level)"
  {
    fix size sorted i lower upper lower_value upper_value
    assume "size = real (length values)"
    assume "sorted = sort values"
    assume "i = \<lceil>size * level - 5 / 10\<rceil>"
    assume "lower = (real_of_int i - 5 / 10) / size"
    assume "upper = (real_of_int i + 5 / 10) / size"
    assume "lower_value = sorted ! nat (i - 1)"
    assume "upper_value = sorted ! nat i"
    have "length values = length sorted" and "sorted \<noteq> []" (* is this noteq Nil fact needed? *) and "length sorted > 0"
      using \<open>sorted = _\<close> \<open>_ \<noteq> []\<close> apply auto
      by (metis length_0_conv length_sort) (* todo: find a better lemma *)
    have "lower_value + (level - lower) * (upper_value - lower_value) / (upper - lower) =
      linear (lower, lower_value) (upper, upper_value) level"
      apply (subst linear_eq[symmetric]) ..
    also have "\<dots> = ?def"
    proof -
      have b1: "0 \<le> \<lceil>real (length sorted) * level - 5 / 10\<rceil>"
      proof -
        have "- 1 / 2 \<le> real (length sorted) * level - 5 / 10"
          apply simp

          by (meson assms(2) le_less_trans less_eq_real_def of_nat_0_le_iff zero_le_divide_1_iff zero_le_mult_iff)
          (* strange proof? *)
        from this show ?thesis by linarith
      qed
      have b2: "nat \<lceil>real (length sorted) * level - 5 / 10\<rceil> < length sorted"
      proof -
        have "real (length sorted) * level \<le> real (length sorted) - 1 / 2"
        proof -
          from assms(3) have "level \<le> 1 - 1 / real (2 * length sorted)"
            using \<open>length values = length sorted\<close> by simp
          from this have "real (length sorted) * level \<le> real (length sorted) * (1 - 1 / real (2 * length sorted))"
            using \<open>0 < length sorted\<close> by auto
          also have "\<dots> = real (length sorted) - 1 / 2"
            apply simp
            by (metis \<open>length values = length sorted\<close> \<open>size = real (length values)\<close> assms(1)
                      length_0_conv mult.commute mult.right_neutral mult_cancel_left
                      nonzero_mult_divide_mult_cancel_left of_nat_eq_iff of_nat_mult
                      right_diff_distrib' times_divide_eq_right)
          finally show ?thesis .
        qed
        from this show ?thesis
          using b1 by linarith
      qed
      have b3: "1 \<le> \<lceil>real (length sorted) * level - 5 / 10\<rceil>"
      proof -
        show ?thesis
          using assms(2) \<open>length _ = _\<close> \<open>length sorted > 0\<close>
          by (simp add: Groups.mult_ac(2) divide_less_eq)
      qed
      from b2 have b4: "\<lceil>real (length sorted) * level - 5 / 10\<rceil> \<le> int (length sorted)" by simp
      have "Max {x' \<in> dom (equidistant_points_on_unit_interval_of sorted). x' < level} = lower"
        using \<open>lower = _\<close> \<open>i = _\<close> \<open>size = _\<close> \<open>length values = _\<close>
        apply (subst Max_equidistant_points_on_unit_interval_of_bounded)
           prefer 4
           apply simp
        using \<open>sorted \<noteq> []\<close> apply blast
        using assms(2) apply auto[1]
        using assms(3) by auto
      moreover have "Min {x' \<in> dom (equidistant_points_on_unit_interval_of sorted). level \<le> x'} = upper"
        using \<open>upper = _\<close> \<open>i = _\<close> \<open>size = _\<close> \<open>length values = _\<close>
        apply (subst Min_equidistant_points_on_unit_interval_of_bounded)
         prefer 4
         apply simp
        using \<open>sorted \<noteq> []\<close> apply blast
        using assms(2) apply auto[1]
        using assms(3) by auto
      moreover have "the (equidistant_points_on_unit_interval_of sorted lower) = lower_value"
        using \<open>i = _\<close>  \<open>size = _\<close> \<open>lower_value = _\<close> \<open>lower = _\<close> \<open>length values = _\<close>
        apply (simp only:)
        apply (subst equidistant_points_on_unit_interval_of_eq_nth1)
        apply (rule b3)
        apply (rule b4)
        apply simp
        done
      moreover have "the (equidistant_points_on_unit_interval_of sorted upper) = upper_value"
        using \<open>i = _\<close>  \<open>size = _\<close> \<open>upper_value = _\<close> \<open>upper = _\<close> \<open>length values = _\<close>
        apply (simp only:)
        apply (subst equidistant_points_on_unit_interval_of_eq_nth2)
        apply (rule b1)
        apply (rule b2)
        apply simp done
      ultimately show ?thesis
        using \<open>sorted = _\<close> by simp
    qed
    finally have "lower_value + (level - lower) * (upper_value - lower_value) / (upper - lower) =
       ?def" by simp (* intermediate proof step not needed? change proof structure? *)
  }
  from this \<open>level \<noteq> _\<close> show ?thesis
    by (simp add: percentile_alternative_pseudo_def percentile_impl_def)
qed

text \<open> The lemma states the equivalence of the abstract definition of the percentile function from
       the Percentile theory and the computational version in the standard interval for the left limit. \<close>
lemma percentile_java_equiv_left:
  assumes "values \<noteq> []"
  assumes "1 / real (2 * length values) = level"
  shows "Percentile.percentile values level = percentile_impl values level"
proof -
  have "(length values) * level = 1/2" using assms by auto
  then have ceil: "ceiling ((length values) * level - 0.5) = 0" using ceiling_def
    by (simp add: \<open>real (length values) * level = 1 / 2\<close>)
  have "(sort values)!0 = (sort values)!(nat (0-1))"  by simp
  then have "percentile_impl values level = (sort values)!0" using ceil
    by (metis add.commute add.left_neutral diff_self div_0 mult_zero_right
              nat_zero_as_int percentile_impl_def)
  have "length values = length (sort values)" by simp
  have left_most: "(\<lambda>x. (1 / length values) * (x + 0.5)) 0 = level"
    using \<open>real (length values) * level = 1 / 2\<close> add_divide_distrib eq_divide_eq_1 mult_cancel_right1
          nonzero_mult_div_cancel_left times_divide_eq_left assms by auto
  have "level = ((map (\<lambda>x. (1 /length values) * (x + 0.5)) [0..<length values]))!0"
    using assms(1) left_most by auto
  then have "level \<in> set (map (\<lambda>x. (1 /length values) * (x + 0.5)) [0..<length values])"
    using assms(1) by force
  then have "level \<in> set (map (\<lambda>x. (1 /length values) * (x + 0.5)) [0..<length values])"
       using left_most by blast
  then have "level \<in> dom (equidistant_points_on_unit_interval_of (sort values))"
    using equidistant_points_on_unit_interval_of_def
    by simp
  then have "neighbors (equidistant_points_on_unit_interval_of (sort values)) level = (level, level)"
    using defined_point_neighbors_eq finite_equidistant_points_on_unit_interval_of by blast
  then have "linear_interpolation (equidistant_points_on_unit_interval_of (sort values)) level = (sort values)!0"
    using one_point_interpolation \<open>length values = length (sort values)\<close>
         \<open>level \<in> dom (equidistant_points_on_unit_interval_of (sort values))\<close> assms(1)
         equidistant_points_on_unit_interval_of_eq_nth2 finite_equidistant_points_on_unit_interval_of
         left_most length_greater_0_conv mult_cancel_right1 nat_zero_as_int of_nat_eq_0_iff
         real_of_int times_divide_eq_left
  proof -
    have f1: "(0::int) \<le> 0"
      by auto
  have f3: "length values \<noteq> 0 \<longrightarrow> (5 / 10 + real_of_int 0) / (of_nat_1 (length (sort values))) = 1 * (5 / 10) / (if length values = 0 then 0 else of_nat_1 (length values))"
    by auto
  have f4: "1 / (if length values = 0 then 0 else (length values)) * (5 / 10) = level"
    using left_most by auto
  have "\<forall>x1. real_of_int x1 + 5 / 10 = 5 / 10 + real_of_int x1"
    by auto
  then have "length values \<noteq> 0 \<longrightarrow> linear_interpolation (equidistant_points_on_unit_interval_of (sort values)) level = sort values ! 0"
    using f4 f3 f1 \<open>\<And>c b a. b / c * a = b * a / c\<close> \<open>length values = length (sort values)\<close>
         \<open>level \<in> dom (equidistant_points_on_unit_interval_of (sort values))\<close> \<open>values \<noteq> []\<close>
         equidistant_points_on_unit_interval_of_eq_nth2 finite_equidistant_points_on_unit_interval_of
         length_greater_0_conv nat_zero_as_int one_point_interpolation
    by (smt divide_inverse_commute divide_numeral_1 inverse_divide of_int_0)
  then show ?thesis
    using \<open>values \<noteq> []\<close> by fastforce
qed
  then have "Percentile.percentile values level = (sort values)!0" using linear_interpolation_def
    using one_point_interpolation by (simp add: percentile_def)
  then show ?thesis
    by (simp add: \<open>percentile_impl values level = sort values ! 0\<close>)
qed

text \<open> The theorem states the equivalence of the abstract definition of the percentile function from
       the Percentile theory and the computational version in the standard interval\<close>
theorem percentile_java_equiv:
  assumes "values \<noteq> []"
  assumes "1 / real (2 * length values) \<le> level"
  assumes "level \<le> 1 - 1 / real (2 * length values)"
  shows "Percentile.percentile values level = percentile_impl values level"
  using assms less_eq_real_def percentile_java_equiv_except_left percentile_java_equiv_left by blast

export_code percentile_impl in Scala
end


theory Recursive_PGCL
  imports "Markov_Models.Markov_Decision_Process"
begin

typedef (overloaded) ('a::order, 'b::order) mono_fun ("(_ \<Rightarrow>\<^sub>m /_)" [22, 21] 21) = "{f :: 'a \<Rightarrow> 'b. mono f}"
  by (auto simp: mono_def)

setup_lifting type_definition_mono_fun

instantiation mono_fun :: (order, complete_lattice) complete_lattice
begin

lift_definition less_eq_mono_fun :: "('a \<Rightarrow>\<^sub>m 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>m 'b) \<Rightarrow> bool" is "(\<le>)" .

definition less_mono_fun :: "('a \<Rightarrow>\<^sub>m 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>m 'b) \<Rightarrow> bool"
where
  "less_mono_fun a b \<longleftrightarrow> a \<le> b \<and> \<not> b \<le> a"

lift_definition Sup_mono_fun :: "('a \<Rightarrow>\<^sub>m 'b) set \<Rightarrow> ('a \<Rightarrow>\<^sub>m 'b)" is "Sup"
  by (auto simp: mono_def le_fun_def intro!: SUP_mono)

lift_definition Inf_mono_fun :: "('a \<Rightarrow>\<^sub>m 'b) set \<Rightarrow> ('a \<Rightarrow>\<^sub>m 'b)" is "Inf"
  by (auto simp: mono_def le_fun_def intro!: INF_mono)

lift_definition sup_mono_fun :: "('a \<Rightarrow>\<^sub>m 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>m 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>m 'b)" is "sup"
  by (auto simp: mono_def le_fun_def intro: le_supI1 le_supI2)

lift_definition inf_mono_fun :: "('a \<Rightarrow>\<^sub>m 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>m 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>m 'b)" is "inf"
  by (auto simp: mono_def le_fun_def intro: le_infI1 le_infI2)

lift_definition top_mono_fun :: "('a \<Rightarrow>\<^sub>m 'b)" is "top"
  by (auto simp: mono_def le_fun_def)

lift_definition bot_mono_fun :: "('a \<Rightarrow>\<^sub>m 'b)" is "bot"
  by (auto simp: mono_def le_fun_def)

instance
  apply standard
  apply (simp add: less_mono_fun_def)
  apply (transfer; auto intro: Sup_upper Sup_least Inf_lower Inf_greatest)+
  done
end

datatype ('s, 'n) pgcl =
    Skip
  | Abort
  | Assign "'s \<Rightarrow> 's pmf"
  | Seq "('s, 'n) pgcl" "('s, 'n) pgcl" ("_;;/ _"  [60, 61] 60)
  | Par "('s, 'n) pgcl" "('s, 'n) pgcl"
  | If "'s \<Rightarrow> bool" "('s, 'n) pgcl" "('s, 'n) pgcl"
  | Call "'n"

lift_definition wp_body ::
  "('n \<Rightarrow> ('s, 'n) pgcl) \<Rightarrow> (('s, 'n) pgcl \<Rightarrow> ('s \<Rightarrow> ennreal) \<Rightarrow>\<^sub>m ('s \<Rightarrow> ennreal)) \<Rightarrow>
    ('s, 'n) pgcl \<Rightarrow> ('s \<Rightarrow> ennreal) \<Rightarrow>\<^sub>m ('s \<Rightarrow> ennreal)"
is
  "\<lambda>D wp. \<lambda>
    Skip       \<Rightarrow> \<lambda>f s. f s
  | Abort      \<Rightarrow> \<lambda>f s. 0
  | Assign u   \<Rightarrow> \<lambda>f s. \<integral>\<^sup>+s'. f s' \<partial>u s
  | Seq c1 c2  \<Rightarrow> wp c1 \<circ> wp c2
  | Par c1 c2  \<Rightarrow> wp c1 \<squnion> wp c2
  | If b c1 c2 \<Rightarrow> \<lambda>f s. if b s then wp c1 f s else wp c2 f s
  | Call n     \<Rightarrow> wp (D n)"
  by (auto simp: mono_def le_fun_def intro!: nn_integral_mono intro: le_supI1 le_supI2 split: pgcl.split)

definition wp :: "('n \<Rightarrow> ('s, 'n) pgcl) \<Rightarrow> ('s, 'n) pgcl \<Rightarrow> ('s \<Rightarrow> ennreal) \<Rightarrow> ('s \<Rightarrow> ennreal)" where
  "wp D c = Rep_mono_fun (lfp (wp_body D) c)"

lemma mono_wp_body: "mono (wp_body D)"
  unfolding mono_def le_fun_def
  apply transfer
  apply (auto simp: le_fun_def intro: le_supI1 le_supI2 split: pgcl.split)
  subgoal for wp1 wp2 c1 c2 f s
    apply (rule le_funD[where x=s])
    apply (rule order_trans[where y="wp1 c1 (wp2 c2 f)"])
    apply (rule monoD[where f="wp1 c1"])
    apply simp
    apply (simp add: le_fun_def)
    apply (simp add: le_fun_def)
    done
  done

lemma mono_wp[simp]: "mono (wp D c)"
  using Rep_mono_fun[of "lfp (wp_body D) c"] by (simp add: wp_def)

lemma unfold_wp': "wp D c = Rep_mono_fun (wp_body D (Abs_mono_fun \<circ> wp D) c)"
  unfolding wp_def[abs_def]
  apply (subst lfp_unfold[OF mono_wp_body])
  apply (simp add: comp_def Rep_mono_fun_inverse)
  done

lemma unfold_wp: "wp D c = (case c
  of Skip \<Rightarrow> \<lambda>f s. f s
   | Abort \<Rightarrow> \<lambda>f s. 0
   | Assign u \<Rightarrow> \<lambda>f s. \<integral>\<^sup>+s'. f s' \<partial>u s
   | Seq c1 c2 \<Rightarrow> wp D c1 \<circ> wp D c2
   | Par c1 c2 \<Rightarrow> wp D c1 \<squnion> wp D c2
   | If b c1 c2 \<Rightarrow> \<lambda>f s. if b s then wp D c1 f s else wp D c2 f s
   | Call n \<Rightarrow> wp D (D n))"
  by (subst unfold_wp')
    (simp_all add: fun_eq_iff wp_body.rep_eq comp_def Rep_mono_fun_inverse Abs_mono_fun_inverse cong: if_cong split: pgcl.split)

lemma wp_Skip[simp]:   "wp D Skip = (\<lambda>f s. f s)"
  and wp_Abort[simp]:  "wp D Abort = (\<lambda>f s. 0)"
  and wp_Assign[simp]: "wp D (Assign u) = (\<lambda>f s. \<integral>\<^sup>+s'. f s' \<partial>u s)"
  and wp_Seq[simp]:    "wp D (Seq c1 c2) = wp D c1 \<circ> wp D c2"
  and wp_Par[simp]:    "wp D (Par c1 c2) = wp D c1 \<squnion> wp D c2"
  and wp_If[simp]:     "wp D (If b c1 c2) = (\<lambda>f s. if b s then wp D c1 f s else wp D c2 f s)"
  and wp_Call[simp]:   "wp D (Call n) = wp D (D n)"
  by (simp_all add: unfold_wp)

end


(*
  This file contains all the Isabelle shallow embedding to C correspondence theorems for word
  array functions.
*)
theory WordArray_SVCorres
  imports WordArray_Shallow WordArray_VAbsFun
begin

subsection "Shallow Word Array Value Relation"
text
  "The shallow embedding of a word array is a list of words. Currently we only support word
   arrays with primitive words as values. In the future, we hope to extend this to elements which
   are non-linear."

overloading
  valRel_WordArrayUX \<equiv> valRel
begin
  definition valRel_WordArrayUX:
    "\<And>\<xi> x v. valRel_WordArrayUX (\<xi> :: (funtyp,vabstyp) vabsfuns) (x :: (('a :: len8) word) WordArray) (v :: (funtyp, vabstyp) vval) \<equiv>
      (if len_of TYPE('a) = 8 then
        \<exists>xs. v = VAbstract (VWA (TPrim (Num U8)) xs) \<and> length x = length xs \<and> (\<forall>i < length xs. (xs ! i) = VPrim (LU8 (ucast (x ! i))))
      else if len_of TYPE('a) = 16 then
        \<exists>xs. v = VAbstract (VWA (TPrim (Num U16)) xs) \<and> length x = length xs \<and> (\<forall>i < length xs. (xs ! i) = VPrim (LU16 (ucast (x ! i))))
      else if len_of TYPE('a) = 32 then
        \<exists>xs. v = VAbstract (VWA (TPrim (Num U32)) xs) \<and> length x = length xs \<and> (\<forall>i < length xs. (xs ! i) = VPrim (LU32 (ucast (x ! i))))
      else if len_of TYPE('a) = 64 then
        \<exists>xs. v = VAbstract (VWA (TPrim (Num U64)) xs) \<and> length x = length xs \<and> (\<forall>i < length xs. (xs ! i) = VPrim (LU64 (ucast (x ! i))))
      else False)"
end

(* Alternate definitions for the valRel relations for word arrays

overloading
  valRel_WordArrayU8 \<equiv> valRel
begin
  definition valRel_WordArrayU8:
    "\<And>\<xi> x v. valRel_WordArrayU8 (\<xi> :: (funtyp,vabstyp) vabsfuns) (x :: (8 word) WordArray) (v :: (funtyp, vabstyp) vval) \<equiv>
      \<exists>xs. v = VAbstract (VWA (TPrim (Num U8)) xs) \<and> length x = length xs \<and> (\<forall>i < length xs. xs ! i = VPrim (LU8 (x ! i)))"
end

overloading
  valRel_WordArrayU16 \<equiv> valRel
begin
  definition valRel_WordArrayU16:
    "\<And>\<xi> x v. valRel_WordArrayU16 (\<xi> :: (funtyp,vabstyp) vabsfuns) (x :: (16 word) WordArray) (v :: (funtyp, vabstyp) vval) \<equiv>
      \<exists>xs. v = VAbstract (VWA (TPrim (Num U16)) xs) \<and> length x = length xs \<and> (\<forall>i < length xs. xs ! i = VPrim (LU16 (x ! i)))"
end

overloading
  valRel_WordArrayU32 \<equiv> valRel
begin
  definition valRel_WordArrayU32:
    "\<And>\<xi> x v. valRel_WordArrayU32 (\<xi> :: (funtyp,vabstyp) vabsfuns) (x :: (32 word) WordArray) (v :: (funtyp, vabstyp) vval) \<equiv>
      \<exists>xs. v = VAbstract (VWA (TPrim (Num U32)) xs) \<and> length x = length xs \<and> (\<forall>i < length xs. xs ! i = VPrim (LU32 (x ! i)))"
end

overloading
  valRel_WordArrayU64 \<equiv> valRel
begin
  definition valRel_WordArrayU64:
    "\<And>\<xi> x v. valRel_WordArrayU64 (\<xi> :: (funtyp,vabstyp) vabsfuns) (x :: (64 word) WordArray) (v :: (funtyp, vabstyp) vval) \<equiv>
      \<exists>xs. v = VAbstract (VWA (TPrim (Num U64)) xs) \<and> length x = length xs \<and> (\<forall>i < length xs. xs ! i = VPrim (LU64 (x ! i)))"
end

*)

context WordArray begin

section "Shallow to Deep Corresondence Lemmas (@{term val.scorres}) for Word Array Functions"

lemmas valRel_WordArray_simps = valRel_WordArrayUX

subsection "wordarray_length"
text
  "@{term wordarray_length} returns the length of a word array.

   Below is a proof tactic to prove @{term val.scorres} for wordarray_length. The proof is
   quite simple as @{term val.scorres} can be proven by simplifying the @{term valRel} definitions
   and by applying the @{term v_sem} introduction rules."
ML \<open>
fun wa_length_tac ctxt =
let
  fun clarsimp_add thms i = Clasimp.clarsimp_tac (add_simps thms ctxt) i;
  fun clarsimp_split thm i = Clasimp.clarsimp_tac (Splitter.add_split thm ctxt) i
  val base_simpset = @{thms val.scorres_def valRel_records wordarray_length' valRel_WordArray_simps};
in
  clarsimp_add base_simpset 1
  THEN clarsimp_split @{thm if_split_asm} 1
  THEN ALLGOALS (fn a =>
    etac @{thm v_sem_appE} a
    THEN etac @{thm v_sem_afunE} a
    THEN etac @{thm v_sem_varE} a
    THEN clarsimp_add @{thms val_wa_length_def} a
    THEN TRYALL (fn i => rtac @{thm FalseE} i
      THEN etac @{thm v_sem_afunE} i
      THEN clarsimp_add [] i))
end;

val goal = @{cterm "valRel \<xi>p (v:: (('a :: len8) word) WordArray) v' \<Longrightarrow> val.scorres (wordarray_length v) (App (AFun ''wordarray_length'' ts) (Var 0)) [v'] \<xi>p"};
val proof_state = Goal.init goal;
val n = proof_state |> wa_length_tac @{context} |>  Seq.hd
\<close>

lemma
  "\<xi>p' ''wordarray_length'' =  val_wa_length \<Longrightarrow> val.scorres((wordarray_length:: ('a :: len8) word WordArray \<Rightarrow> 32 word)) (AFun ''wordarray_length'' ts) \<gamma> \<xi>p'"
  apply (clarsimp simp: val.scorres_def)
  apply (erule v_sem_afunE)
  apply (clarsimp simp: val_wa_length_def  wordarray_length' valRel_WordArray_simps split: if_splits)
  done

lemma scorres_wordarray_length:
  "\<lbrakk>i < length \<gamma>; \<xi>p' ''wordarray_length'' =  val_wa_length;
    valRel \<xi>p' (v:: ('a :: len8) word WordArray) (\<gamma> ! i)\<rbrakk>
    \<Longrightarrow> val.scorres (wordarray_length v) (App (AFun ''wordarray_length'' ts) (Var i)) \<gamma> \<xi>p'"
  by (tactic \<open>wa_length_tac @{context}\<close>)

\<comment>\<open> Proofs for alternate definition of @{term valRel} for word arrays \<close>
(*lemma scorres_wordarray_length_u8:
  "\<lbrakk>valRel \<xi>p (v:: 8 word WordArray) v'\<rbrakk>
    \<Longrightarrow> val.scorres (wordarray_length v) (App (AFun ''wordarray_length'' ts) (Var 0)) [v'] \<xi>p"
  by (tactic \<open>wa_length_tac @{context}\<close>)

lemma scorres_wordarray_length_u16:
  "\<lbrakk>valRel \<xi>p (v:: 16 word WordArray) v'\<rbrakk>
    \<Longrightarrow> val.scorres (wordarray_length v) (App (AFun ''wordarray_length'' ts) (Var 0)) [v'] \<xi>p"
  by (tactic \<open>wa_length_tac @{context}\<close>)

lemma scorres_wordarray_length_u32:
  "\<lbrakk>valRel \<xi>p (v:: 32 word WordArray) v'\<rbrakk>
    \<Longrightarrow> val.scorres (wordarray_length v) (App (AFun ''wordarray_length'' ts) (Var 0)) [v'] \<xi>p"
  by (tactic \<open>wa_length_tac @{context}\<close>)

lemma scorres_wordarray_length_u64:
  "\<lbrakk>valRel \<xi>p (v:: 64 word WordArray) v'\<rbrakk>
    \<Longrightarrow> val.scorres (wordarray_length v) (App (AFun ''wordarray_length'' ts) (Var 0)) [v'] \<xi>p"
  by (tactic \<open>wa_length_tac @{context}\<close>)
*)

subsection "wordarray_get"
text
  "@{term wordarray_get} is similar to the @{term nth} function for lists, except is does not cause
   and error when the index requested is out of bounds. Instead it returns the value @{term 0}. One
   issue with this behaviour is that it that we cannot define a generic @{term valRel} relation for
   word arrays as word arrays of other types may not have a sensible @{term 0} value.

   Below is a proof tactic to prove @{term val.scorres} for wordarray_get. The proof is
   slightly more tricky than @{term wordarray_length}, but it essentially can be proven using
   the simplifier to unfold the @{term valRel} definitions and by applying the @{term v_sem}
   introduction rules where necessary."
ML \<open>
fun wa_get_tac ctxt =
let
  fun clarsimp_add thms = Clasimp.clarsimp_tac (add_simps thms ctxt);
  fun clarsimp_split thm i = Clasimp.clarsimp_tac (Splitter.add_split thm ctxt) i
  val base_simpset = @{thms val.scorres_def valRel_records wordarray_get' valRel_WordArray_simps};
in
  clarsimp_add base_simpset 1
  THEN clarsimp_split @{thm if_split_asm} 1
  THEN ALLGOALS (fn a =>
    rtac @{thm conjI} a
    THEN ALLGOALS (fn i => clarsimp_add [] i
      THEN etac @{thm v_sem_appE} i
      THEN etac @{thm v_sem_afunE} i
      THEN etac @{thm v_sem_varE} i
      THEN clarsimp_add @{thms val_wa_get_def ucast_id} i)
    THEN TRYALL (fn i => rtac @{thm FalseE} i
      THEN etac @{thm v_sem_afunE} i
      THEN clarsimp_add [] i))
end;

val goal = @{cterm "valRel \<xi>p (v:: (32 word WordArray, 32 word) T0) v'
    \<Longrightarrow> val.scorres (wordarray_get v) (App (AFun ''wordarray_get'' ts) (Var 0)) [v'] \<xi>p"};
val proof_state = Goal.init goal;
val n = proof_state |> wa_get_tac @{context} |>  Seq.hd
\<close>

\<comment>\<open> @{term valRel} does not exist for @{typ "('a :: len8) word"} so we can't make a generalised
   lemma like we did for @{term wordarray_length}. \<close>

lemma scorres_wordarray_get_u8:
  "\<lbrakk>i < length \<gamma>;  \<xi>p' ''wordarray_get'' =  val_wa_get;
    valRel \<xi>p' (v:: (8 word WordArray, 32 word) T0) (\<gamma> ! i)\<rbrakk>
    \<Longrightarrow> val.scorres (wordarray_get v) (App (AFun ''wordarray_get'' ts) (Var i)) \<gamma> \<xi>p'"
  by (tactic \<open>wa_get_tac @{context}\<close>)

lemma scorres_wordarray_get_u16:
  "\<lbrakk>i < length \<gamma>;  \<xi>p' ''wordarray_get'' =  val_wa_get;
    valRel \<xi>p' (v:: (16 word WordArray, 32 word) T0) (\<gamma> ! i)\<rbrakk>
    \<Longrightarrow> val.scorres (wordarray_get v) (App (AFun ''wordarray_get'' ts) (Var i)) \<gamma> \<xi>p'"
  by (tactic \<open>wa_get_tac @{context}\<close>)

lemma scorres_wordarray_get_u32:
  "\<lbrakk>i < length \<gamma>;  \<xi>p' ''wordarray_get'' =  val_wa_get;
    valRel \<xi>p' (v:: (32 word WordArray, 32 word) T0) (\<gamma> ! i)\<rbrakk>
    \<Longrightarrow> val.scorres (wordarray_get v) (App (AFun ''wordarray_get'' ts) (Var i)) \<gamma> \<xi>p'"
  by (tactic \<open>wa_get_tac @{context}\<close>)

lemma scorres_wordarray_get_u64:
  "\<lbrakk>i < length \<gamma>; \<xi>p' ''wordarray_get'' =  val_wa_get;
    valRel \<xi>p' (v:: (64 word WordArray, 32 word) T0) (\<gamma> ! i)\<rbrakk>
    \<Longrightarrow> val.scorres (wordarray_get v) (App (AFun ''wordarray_get'' ts) (Var i)) \<gamma> \<xi>p'"
  by (tactic \<open>wa_get_tac @{context}\<close>)

subsection "wordarray_put2"

text
  "@{term wordarray_put2} has the same behaviour as @{term list_update}."

lemma related_lists_update_nth_eq:
  "\<lbrakk>length ys = length xs; j < length xs; \<forall>i < length xs. xs ! i = f (ys ! i)\<rbrakk>
    \<Longrightarrow> xs[i := f v] ! j = f (ys[i := v] ! j)"
  apply (erule_tac x = j in allE)
  apply (case_tac " i = j"; clarsimp)
  done

text
  "Below is a proof tactic to prove @{term val.scorres} for wordarray_put2. The proof tactic was
   slightly more tricky than @{term wordarray_get} to create. However, the core part is the same as
   the proof @{thm scorres_wordarray_get_u8}, and the only major difference is the addition of the
   helper lemma @{thm related_lists_update_nth_eq}."

ML \<open>
fun inst_param_tac param_nms var_nms thm tac ({context, params, ...} : Subgoal.focus) =
let
  fun mk_inst a b = ((b, 0), (snd o hd o (filter (fn v => fst v = a))) params)
  val insts = map2 mk_inst param_nms var_nms
  val inst_thm = Drule.infer_instantiate context insts thm
in
  tac context [inst_thm] 1
end
\<close>

ML \<open>
fun wa_put2_tac ctxt =
let
  fun clarsimp_add thms = Clasimp.clarsimp_tac (add_simps thms ctxt);
  fun clarsimp_split thm i = Clasimp.clarsimp_tac (Splitter.add_split thm ctxt) i
  val base_simpset = @{thms val.scorres_def valRel_records wordarray_put2' valRel_WordArray_simps};
  val helper_thm = @{thm related_lists_update_nth_eq}
in
  clarsimp_add base_simpset 1
  THEN clarsimp_split @{thm if_split_asm} 1
  THEN ALLGOALS (fn a =>
    etac @{thm v_sem_appE} a
    THEN etac @{thm v_sem_afunE} a
    THEN etac @{thm v_sem_varE} a
    THEN clarsimp_add @{thms val_wa_put2_def ucast_id} a
    THEN Subgoal.FOCUS_PARAMS (inst_param_tac ["i"] ["j"] helper_thm resolve_tac) ctxt a
    THEN ALLGOALS (fn i => asm_full_simp_tac ctxt i)
    THEN etac @{thm v_sem_afunE} a
    THEN rtac @{thm FalseE} a
    THEN clarsimp_add [] a)
end;
\<close>
ML \<open>
val goal = @{cterm "valRel \<xi>p (v:: (32 word WordArray, 32 word, 32 word) WordArrayPutP) v'
    \<Longrightarrow> val.scorres (wordarray_put2 v) (App (AFun ''wordarray_put2'' ts) (Var 0)) [v'] \<xi>p"};
val proof_state = Goal.init goal;
val n = proof_state |> wa_put2_tac @{context} |> Seq.hd
\<close>

lemma scorres_wordarray_put2_u8:
  "\<lbrakk>k < length \<gamma>;  \<xi>p' ''wordarray_put2'' =  val_wa_put2;
    valRel \<xi>p' (v:: (8 word WordArray, 32 word, 8 word) WordArrayPutP) (\<gamma> ! k)\<rbrakk>
    \<Longrightarrow> val.scorres (wordarray_put2 v) (App (AFun ''wordarray_put2'' ts) (Var k)) \<gamma> \<xi>p'"
  by (tactic \<open> wa_put2_tac @{context}\<close>)

lemma scorres_wordarray_put2_u16:
  "\<lbrakk>k < length \<gamma>;  \<xi>p' ''wordarray_put2'' =  val_wa_put2;
    valRel \<xi>p' (v:: (16 word WordArray, 32 word, 16 word) WordArrayPutP) (\<gamma> ! k)\<rbrakk>
    \<Longrightarrow> val.scorres (wordarray_put2 v) (App (AFun ''wordarray_put2'' ts) (Var k)) \<gamma> \<xi>p'"
  by (tactic \<open> wa_put2_tac @{context}\<close>)

lemma scorres_wordarray_put2_u32:
  "\<lbrakk>k < length \<gamma>;  \<xi>p' ''wordarray_put2'' =  val_wa_put2;
    valRel \<xi>p' (v:: (32 word WordArray, 32 word, 32 word) WordArrayPutP) (\<gamma> ! k)\<rbrakk>
    \<Longrightarrow> val.scorres (wordarray_put2 v) (App (AFun ''wordarray_put2'' ts) (Var k)) \<gamma> \<xi>p'"
  by (tactic \<open> wa_put2_tac @{context}\<close>)

lemma scorres_wordarray_put2_u64:
  "\<lbrakk>k < length \<gamma>;  \<xi>p' ''wordarray_put2'' =  val_wa_put2;
    valRel \<xi>p' (v:: (64 word WordArray, 32 word, 64 word) WordArrayPutP) (\<gamma> ! k)\<rbrakk>
    \<Longrightarrow> val.scorres (wordarray_put2 v) (App (AFun ''wordarray_put2'' ts) (Var k)) \<gamma> \<xi>p'"
  by (tactic \<open> wa_put2_tac @{context}\<close>)

subsection "wordarray_fold_no_break"

text
  "@{term wordarray_fold_no_break} is very similar to the list @{term fold} function. It differs
   from the traditional @{term fold} function as it can be applied to only a specified range of
   a list. It also takes an addition observer argument which remains unchanged throughout the
   @{term fold} operation and can be used throughout the @{term fold} operation. This can easily be
   emulated with the traditional @{term fold} function."

lemma map_forall:
  "\<lbrakk>length xs = length ys; \<forall>i<length xs. xs ! i = f(ys ! i)\<rbrakk> \<Longrightarrow> xs = map f ys"
  apply (induct xs arbitrary: ys; clarsimp)
  apply (drule_tac x = "tl ys" in meta_spec; clarsimp)
  apply (drule meta_mp)
   apply linarith
  apply (drule meta_mp)
   apply clarsimp
   apply (erule_tac x = "Suc i" in allE)
   apply clarsimp
   apply (simp add: tl_drop_1)
  apply clarsimp
  by (metis list.sel(3) list_exhaust_size_gt0 list_to_map_more nth_Cons_0 zero_less_Suc)

lemma take_1_drop:
  "i < length xs \<Longrightarrow> List.take (Suc 0) (List.drop i xs) = [xs ! i]"
  apply (induct xs arbitrary: i)
   apply (simp add: take_Suc_conv_app_nth)
  by (simp add: drop_Suc_nth)

lemma take_drop_Suc:
  "i < l \<and> i < length xs \<Longrightarrow>
    List.take (l - i) (List.drop i xs) = (xs ! i) # List.take (l - Suc i) (List.drop (Suc i) xs)"
  apply clarsimp
  by (metis Cons_nth_drop_Suc Suc_diff_Suc take_Suc_Cons)

lemma take_drop_Suc_app:
  "\<lbrakk>i < Suc l; Suc l \<le> length xs\<rbrakk> \<Longrightarrow>
    List.take (Suc l - i) (List.drop i xs) = List.take (l - i) (List.drop i xs) @ [xs ! l]"
  apply (induct i)
   apply (simp add: take_Suc_conv_app_nth)
  apply clarsimp
  apply (subst Suc_diff_Suc[symmetric])
   apply arith
  apply (subst take_hd_drop[symmetric])
   apply simp
  apply simp
  using Suc_le_lessD hd_drop_conv_nth by blast

abbreviation "upd_rec_field rec i v \<equiv> (case rec of VRecord fs \<Rightarrow> VRecord (fs[i := v]))"

text
  \<open> We cannot generalise this unless you can prove that
    @{term "\<forall>a b. valRel \<xi>\<^sub>i (a :: 'a) b \<longleftrightarrow> valRel \<xi>\<^sub>j a b"} which is generally not true for
    functions.\<close>
lemma scorres_wordarray_fold_no_break_u32:
  "\<lbrakk>i < length \<gamma>; \<xi>p1' ''wordarray_fold_no_break'' = val_wa_foldnbp \<xi>p';
    valRel \<xi>p' \<lparr>WordArrayMapNoBreakP.arr\<^sub>f = (arr:: 32 word WordArray), frm\<^sub>f = (frm::32 word), to\<^sub>f = to,
      f\<^sub>f = f, acc\<^sub>f = (acc :: 'b), obsv\<^sub>f = obsv\<rparr> (\<gamma> ! i);
    \<forall>x x'. valRel \<xi>p' (x :: 'b) x' \<longleftrightarrow> valRel \<xi>p1' x x'\<rbrakk>
    \<Longrightarrow> val.scorres
    (wordarray_fold_no_break \<lparr>WordArrayMapNoBreakP.arr\<^sub>f = arr, frm\<^sub>f = frm, to\<^sub>f = to, f\<^sub>f = f,
        acc\<^sub>f = acc, obsv\<^sub>f = obsv\<rparr>) (App (AFun ''wordarray_fold_no_break'' ts) (Var i)) \<gamma> \<xi>p1'"
  apply (clarsimp simp: val.scorres_def)
  apply (erule v_sem_appE; erule v_sem_afunE; clarsimp)
  apply (erule v_sem_varE; clarsimp)
  apply (clarsimp simp: val_wa_foldnbp_def)
  apply (clarsimp simp: wordarray_fold_no_break' valRel_records valRel_WordArray_simps)
  apply (induct to arbitrary: i \<gamma>)
   apply clarsimp
   apply (erule val_wa_foldnb_bod.elims; clarsimp split: if_split_asm)
  apply clarsimp
  apply (drule unatSuc; clarsimp)
  apply (rename_tac to r xs func acca obsva i \<gamma>)
  apply (case_tac "length xs < Suc (unat to)")
   apply (drule val_wa_foldnb_bod_back_step'; simp?)
   apply (drule_tac x = r in meta_spec)
   apply (drule_tac x = xs in meta_spec)
   apply (drule_tac x = func in meta_spec)
   apply (drule_tac x = acca in meta_spec)
   apply (drule_tac x = obsva in meta_spec)
   apply (drule_tac x = i in meta_spec)
   apply (drule_tac x = "\<gamma>[i := upd_rec_field (\<gamma> ! i) 2 (VPrim (LU32 to))]" in meta_spec)
   apply clarsimp
  apply (case_tac "unat frm \<ge> Suc (unat to)")
   apply clarsimp
   apply (erule val_wa_foldnb_bod.elims; clarsimp)
  apply (drule val_wa_foldnb_bod_back_step; clarsimp)
  apply (rename_tac r')
  apply (drule_tac x = r' in meta_spec)
  (*apply (drule_tac x = t in meta_spec)*)
  apply (drule_tac x = xs in meta_spec)
  apply (drule_tac x = func in meta_spec)
  apply (drule_tac x = acca in meta_spec)
  apply (drule_tac x = obsva in meta_spec)
  apply clarsimp
  apply (drule_tac x = i in meta_spec)
  apply (drule_tac x = "\<gamma>[i := upd_rec_field (\<gamma> ! i) 2 (VPrim (LU32 to))]" in meta_spec)
  apply clarsimp
  apply (subst take_drop_Suc_app; simp?)
(*   apply (clarsimp split: if_split_asm)*)
  apply (clarsimp simp: ucast_id)
  apply (case_tac func; clarsimp)
   apply (erule_tac x = "\<lparr>ElemAO.elem\<^sub>f = arr ! unat to,
    acc\<^sub>f = fold (\<lambda>a b. f \<lparr>ElemAO.elem\<^sub>f = a, acc\<^sub>f = b, obsv\<^sub>f = obsv\<rparr>)
      (take (unat to - unat frm) (List.drop (unat frm) arr)) acc, obsv\<^sub>f = obsv\<rparr>" in allE)
   apply (erule_tac x = "VRecord [xs ! unat to, r', obsva]" in allE)
   apply clarsimp
   apply (erule v_sem_appE; clarsimp)
   apply (erule v_sem_varE; clarsimp)
(*   apply (erule impE)
  apply (clarsimp split: if_split_asm; erule_tac x = "unat to" in allE; clarsimp)*)
  apply (erule_tac x = "\<lparr>ElemAO.elem\<^sub>f = arr ! unat to,
    acc\<^sub>f = fold (\<lambda>a b. f \<lparr>ElemAO.elem\<^sub>f = a, acc\<^sub>f = b, obsv\<^sub>f = obsv\<rparr>)
      (take (unat to - unat frm) (List.drop (unat frm) arr)) acc, obsv\<^sub>f = obsv\<rparr>" in allE)
  apply (erule_tac x = "VRecord [xs ! unat to, r', obsva]" in allE)
  apply clarsimp
  apply (erule v_sem_appE; erule v_sem_afunE; clarsimp)
  apply (erule v_sem_varE; clarsimp)
  done

subsection "wordarray_map_no_break"

lemma min_word_0:
  "min x (0 :: ('a :: len8 word)) = 0"
  by simp

lemma max_word_0:
  "max x (0 :: ('a :: len8 word)) = x"
  apply (unfold max_def)
  by simp

lemma myslice_nth_last:
  "\<lbrakk>frm < Suc to; Suc to \<le> length xs; length xs' = to - frm\<rbrakk>
    \<Longrightarrow> ((List.take frm xs) @ xs' @ x # (List.drop (Suc to) xs)) ! to = x"
  apply (cut_tac xs = "(List.take frm xs)" and
      ys = " xs' @ x # (List.drop (Suc to) xs)" and
      n = "to - frm" in nth_append_length_plus)
  apply simp
  apply (cut_tac xs = xs' and
      ys = "x # List.drop (Suc to) xs" and
      n = 0 in nth_append_length_plus)
  apply simp
  done

lemma scorres_wordarray_map_no_break_u32:
  "\<lbrakk>i < length \<gamma>; \<xi>p1' ''wordarray_map_no_break'' = val_wa_mapAccumnbp \<xi>p';
    valRel \<xi>p' \<lparr>WordArrayMapNoBreakP.arr\<^sub>f = (arr:: 32 word WordArray), frm\<^sub>f = (frm::32 word), to\<^sub>f = to,
      f\<^sub>f = f, acc\<^sub>f = (acc :: 'b), obsv\<^sub>f = obsv\<rparr> (\<gamma> ! i); \<forall>x x'. valRel \<xi>p' (x :: 'b) x' \<longleftrightarrow> valRel \<xi>p1' x x'\<rbrakk>
    \<Longrightarrow> val.scorres
    (wordarray_map_no_break \<lparr>WordArrayMapNoBreakP.arr\<^sub>f = arr, frm\<^sub>f = frm, to\<^sub>f = to, f\<^sub>f = f,
        acc\<^sub>f = acc, obsv\<^sub>f = obsv\<rparr>) (App (AFun ''wordarray_map_no_break'' ts) (Var i)) \<gamma> \<xi>p1'"
  apply (clarsimp simp: val.scorres_def)
  apply (erule v_sem_appE; erule v_sem_afunE; clarsimp)
  apply (erule v_sem_varE; clarsimp)
  apply (clarsimp simp: val_wa_mapAccumnbp_def)
  apply (clarsimp simp: wordarray_map_no_break' valRel_records valRel_WordArray_simps)
  apply (induct to arbitrary: i \<gamma>)
  apply clarsimp
   apply (erule val_wa_mapAccumnb_bod.elims; clarsimp split: if_split_asm simp: ucast_id)
  apply clarsimp
  apply (drule unatSuc; clarsimp)
  apply (rename_tac to r xs func acca obsva i \<gamma>)
  apply (case_tac "length xs < Suc (unat to)")
   apply (drule val_wa_mapAccumnb_bod_back_step'; simp?)
   apply (clarsimp simp: ucast_id)
   apply (drule_tac x = r in meta_spec)
   apply (drule_tac x = xs in meta_spec)
   apply (drule_tac x = func in meta_spec)
   apply (drule_tac x = acca in meta_spec)
   apply (drule_tac x = obsva in meta_spec)
   apply (drule_tac x = i in meta_spec)
   apply (drule_tac x = "\<gamma>[i := upd_rec_field (\<gamma> ! i) 2 (VPrim (LU32 to))]" in meta_spec)
   apply clarsimp
   apply (clarsimp split: if_split_asm prod.splits simp: word_less_nat_alt word_le_nat_alt)
  apply (case_tac "unat frm \<ge> Suc (unat to)")
   apply clarsimp
   apply (erule val_wa_mapAccumnb_bod.elims)
   apply (clarsimp split: if_split_asm simp: ucast_id word_less_nat_alt word_le_nat_alt)
  apply (frule val_wa_mapAccumnb_bod_preservation'; clarsimp)
  apply (rename_tac rxs racc)
  apply (drule val_wa_mapAccumnb_bod_back_step; clarsimp simp: ucast_id)
  apply (rename_tac racc')
  apply (drule_tac x = "VRecord [VAbstract (VWA (TPrim (Num U32))
    (rxs[unat to := VPrim (LU32 (arr ! unat to))])), racc']" in meta_spec)
  apply clarsimp
  apply (drule_tac x = xs in meta_spec)
  apply (drule_tac x = func in meta_spec)
  apply (drule_tac x = acca in meta_spec)
  apply (drule_tac x = obsva in meta_spec)
  apply clarsimp
  apply (drule_tac x = i in meta_spec)
  apply (drule_tac x = "\<gamma>[i := upd_rec_field (\<gamma> ! i) 2 (VPrim (LU32 to))]" in meta_spec)
  apply clarsimp
  apply (subst take_drop_Suc_app; simp?)+
  apply (clarsimp simp: mapAccum_step)
  apply (clarsimp split: prod.splits if_splits simp: word_less_nat_alt word_le_nat_alt)
  apply (rename_tac rxs' racc')
  apply (cut_tac acc = acc and
      xs = "(take (unat to - unat frm) (List.drop (unat frm) arr))" and
      f = "(\<lambda>a b. (T0.p1\<^sub>f (f \<lparr>ElemAO.elem\<^sub>f = a, acc\<^sub>f = b, obsv\<^sub>f = obsv\<rparr>),
                 T0.p2\<^sub>f (f \<lparr>ElemAO.elem\<^sub>f = a, acc\<^sub>f = b, obsv\<^sub>f = obsv\<rparr>)))" in mapAccum_length)
  apply (case_tac func; clarsimp)
   apply (rename_tac racc'a rxs' racc' fn ts)
   apply (erule_tac x = "\<lparr>ElemAO.elem\<^sub>f = arr ! unat to, acc\<^sub>f = racc', obsv\<^sub>f = obsv\<rparr>" in allE)
   apply (erule_tac x = "VRecord [VPrim (LU32 (arr ! unat to)), racc'a, obsva]" in allE)
   apply clarsimp
   apply (erule v_sem_appE; clarsimp)
   apply (erule v_sem_varE; clarsimp)
   apply (erule_tac x = " VRecord [rxs ! unat to, racc]" in allE; clarsimp)
   apply (rename_tac j)
   apply (erule_tac x = j in allE; clarsimp)
   apply (erule_tac x = j in allE; clarsimp)
   apply (case_tac "j = unat to"; clarsimp simp: myslice_nth_last nth_append)
  apply (rename_tac racc'a rxs' racc' fn ts)
  apply (erule_tac x = "\<lparr>ElemAO.elem\<^sub>f = arr ! unat to, acc\<^sub>f = racc', obsv\<^sub>f = obsv\<rparr>" in allE)
  apply (erule_tac x = "VRecord [VPrim (LU32 (arr ! unat to)), racc'a, obsva]" in allE)
  apply clarsimp
  apply (erule v_sem_appE; erule v_sem_afunE; clarsimp)
  apply (erule v_sem_varE; clarsimp)
  apply (rotate_tac -2)
  apply (erule_tac x = " VRecord [rxs ! unat to, racc]" in allE; clarsimp)
  apply (rename_tac j)
  apply (erule_tac x = j in allE; clarsimp)
  apply (erule_tac x = j in allE; clarsimp)
  apply (case_tac "j = unat to"; clarsimp simp: myslice_nth_last nth_append)
  done

end (* of context *)

end


theory Compiler
  imports "HOL-IMP.Big_Step" "HOL-IMP.Star"
begin

declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
"(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))"

lemma inth_append [simp]: "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
  by (induction xs arbitrary: i) (auto simp: algebra_simps)

abbreviation (output) "isize xs == int (length xs)"

notation isize ("size")

datatype instr =
  LOADI int | LOAD vname |
  ADD |
  STORE vname |
  JMP int | JMPLESS int | JMPGE int

type_synonym stack = "val list"
type_synonym config = "int \<times> state \<times> stack"

abbreviation "hd2 xs == hd (tl xs)"
abbreviation "tl2 xs == tl (tl xs)"

fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
  "iexec instr (i, s, stk) = (case instr of
    LOADI n \<Rightarrow> (i + 1, s, n # stk) |
    LOAD x \<Rightarrow> (i + 1, s, s x # stk) |
    ADD \<Rightarrow> (i + 1, s, (hd2 stk + hd stk) # tl2 stk) |
    STORE x \<Rightarrow> (i + 1, s(x := hd stk), tl stk) |
    JMP n \<Rightarrow>  (i + 1 + n, s, stk) |
    JMPLESS n \<Rightarrow> (if hd2 stk < hd stk then i + 1 + n else i + 1, s, tl2 stk) |
    JMPGE n \<Rightarrow> (if hd2 stk >= hd stk then i + 1 + n else i + 1, s, tl2 stk))"

definition exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
  ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)  where
  "P \<turnstile> c \<rightarrow> c' =
  (\<exists>i s stk. c = (i, s, stk) \<and> c' = iexec(P !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size P)"

lemma exec1I [intro, code_pred_intro]:
  "c' = iexec (P!!i) (i,s,stk) \<Longrightarrow>
  0 \<le> i \<Longrightarrow> i < size P \<Longrightarrow>
  P \<turnstile> (i,s,stk) \<rightarrow> c'"
  by (simp add: exec1_def)

abbreviation  exec :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
  ("(_/ \<turnstile> (_ \<rightarrow>*/ _))" 50) where
  "exec P \<equiv> star (exec1 P)"

lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)]

code_pred exec1 by (metis exec1_def)

lemma iexec_shift [simp]:
  "(n+i',s',stk') = iexec x (n+i,s,stk) \<longleftrightarrow>
  (i',s',stk') = iexec x (i,s,stk)"
by(auto split:instr.split)

lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow> c'"
by (auto simp: exec1_def)

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow>* c'"
by (induction rule: star.induct) (fastforce intro: star.step exec1_appendR)+

lemma exec1_appendL:
  fixes i i' :: int
  shows
  "P \<turnstile> (i,s,stk) \<rightarrow> (i',s',stk') \<Longrightarrow>
   P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow> (size(P')+i',s',stk')"
  unfolding exec1_def
  by (auto simp del: iexec.simps)

lemma exec_appendL:
  fixes i i' :: int
  shows
 "P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')  \<Longrightarrow>
  P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow>* (size(P')+i',s',stk')"
  by (induction rule: exec_induct) (blast intro: star.step exec1_appendL)+

text\<open>Now we specialise the above lemmas to enable automatic proofs of
\<^prop>\<open>P \<turnstile> c \<rightarrow>* c'\<close> where \<open>P\<close> is a mixture of concrete instructions and
pieces of code that we already know how they execute (by induction), combined
by \<open>@\<close> and \<open>#\<close>. Backward jumps are not supported.
The details should be skipped on a first reading.

If we have just executed the first instruction of the program, drop it:\<close>

lemma exec_Cons_1 [intro]:
  "P \<turnstile> (0,s,stk) \<rightarrow>* (j,t,stk') \<Longrightarrow>
  instr#P \<turnstile> (1,s,stk) \<rightarrow>* (1+j,t,stk')"
by (drule exec_appendL[where P'="[instr]"]) simp

lemma exec_appendL_if[intro]:
  fixes i i' j :: int
  shows
  "size P' <= i
   \<Longrightarrow> P \<turnstile> (i - size P',s,stk) \<rightarrow>* (j,s',stk')
   \<Longrightarrow> i' = size P' + j
   \<Longrightarrow> P' @ P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')"
by (drule exec_appendL[where P'=P']) simp

text\<open>Split the execution of a compound program up into the execution of its
parts:\<close>

lemma exec_append_trans[intro]:
  fixes i' i'' j'' :: int
  shows
"P \<turnstile> (0,s,stk) \<rightarrow>* (i',s',stk') \<Longrightarrow>
 size P \<le> i' \<Longrightarrow>
 P' \<turnstile>  (i' - size P,s',stk') \<rightarrow>* (i'',s'',stk'') \<Longrightarrow>
 j'' = size P + i''
 \<Longrightarrow>
 P @ P' \<turnstile> (0,s,stk) \<rightarrow>* (j'',s'',stk'')"
by(metis star_trans[OF exec_appendR exec_appendL_if])

declare Let_def[simp]

subsection "Compilation"

fun acomp :: "aexp \<Rightarrow> instr list" where
"acomp (N n) = [LOADI n]" |
"acomp (V x) = [LOAD x]" |
"acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"

lemma acomp_correct[intro]:
  "acomp a \<turnstile> (0,s,stk) \<rightarrow>* (size(acomp a),s,aval a s#stk)"
by (induction a arbitrary: stk) fastforce+

fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
"bcomp (Bc v) f n = (if v=f then [JMP n] else [])" |
"bcomp (Not b) f n = bcomp b (\<not>f) n" |
"bcomp (And b1 b2) f n =
 (let cb2 = bcomp b2 f n;
        m = if f then size cb2 else (size cb2::int)+n;
      cb1 = bcomp b1 False m
  in cb1 @ cb2)" |
"bcomp (Less a1 a2) f n =
 acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"

value
  "bcomp (And (Less (V ''x'') (V ''y'')) (Not(Less (V ''u'') (V ''v''))))
     False 3"

lemma bcomp_correct[intro]:
  fixes n :: int
  shows
  "0 \<le> n \<Longrightarrow>
  bcomp b f n \<turnstile>
 (0,s,stk)  \<rightarrow>*  (size(bcomp b f n) + (if f = bval b s then n else 0),s,stk)"
proof(induction b arbitrary: f n)
  case Not
  from Not(1)[where f="~f"] Not(2) show ?case by fastforce
next
  case (And b1 b2)
  from And(1)[of "if f then size(bcomp b2 f n) else size(bcomp b2 f n) + n"
                 "False"]
       And(2)[of n f] And(3)
  show ?case by fastforce
qed fastforce+

fun ccomp :: "com \<Rightarrow> instr list" where
"ccomp SKIP = []" |
"ccomp (x ::= a) = acomp a @ [STORE x]" |
"ccomp (c\<^sub>1;;c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
"ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
  (let cc\<^sub>1 = ccomp c\<^sub>1; cc\<^sub>2 = ccomp c\<^sub>2; cb = bcomp b False (size cc\<^sub>1 + 1)
   in cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
"ccomp (WHILE b DO c) =
 (let cc = ccomp c; cb = bcomp b False (size cc + 1)
  in cb @ cc @ [JMP (-(size cb + size cc + 1))])"

value "ccomp
 (IF Less (V ''u'') (N 1) THEN ''u'' ::= Plus (V ''u'') (N 1)
  ELSE ''v'' ::= V ''u'')"

value "ccomp (WHILE Less (V ''u'') (N 1) DO (''u'' ::= Plus (V ''u'') (N 1)))"

subsection "Preservation of semantics"

lemma ccomp_bigstep:
  "(c,s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk)"
proof(induction arbitrary: stk rule: big_step_induct)
  case (Assign x a s)
  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
next
  case (Seq c1 s1 s2 c2 s3)
  let ?cc1 = "ccomp c1"  let ?cc2 = "ccomp c2"
  have "?cc1 @ ?cc2 \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cc1,s2,stk)"
    using Seq.IH(1) by fastforce
  moreover
  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1,s2,stk) \<rightarrow>* (size(?cc1 @ ?cc2),s3,stk)"
    using Seq.IH(2) by fastforce
  ultimately show ?case by simp (blast intro: star_trans)
next
  case (WhileTrue b s1 c s2 s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b False (size ?cc + 1)"
  let ?cw = "ccomp(WHILE b DO c)"
  have "?cw \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cb,s1,stk)"
    using \<open>bval b s1\<close> by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb,s1,stk) \<rightarrow>* (size ?cb + size ?cc,s2,stk)"
    using WhileTrue.IH(1) by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb + size ?cc,s2,stk) \<rightarrow>* (0,s2,stk)"
    by fastforce
  moreover
  have "?cw \<turnstile> (0,s2,stk) \<rightarrow>* (size ?cw,s3,stk)" by(rule WhileTrue.IH(2))
  ultimately show ?case by(blast intro: star_trans)
qed fastforce+

end