(*
    Title:      Dual_Order.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

header "Dual Order"

theory Dual_Order
  imports Main
begin

subsection{*Interpretation of dual order based on order*}

text{*Computable Greatest value operator for finite linorder classes. Based on @{thm "Least_def"}*}

interpretation dual_order: order "(op \<ge>)::('a::{order}=>'a=>bool)" "(op >)"
proof
  fix x y::"'a::{order}" show "(y < x) = (y \<le> x \<and> \<not> x \<le> y)" using less_le_not_le .
  show "x \<le> x" using order_refl .
  fix z show "y \<le> x \<Longrightarrow> z \<le> y \<Longrightarrow> z \<le> x" using order_trans .
next
  fix x y::"'a::{order}" show "y \<le> x \<Longrightarrow> x \<le> y \<Longrightarrow> x = y" by (metis eq_iff)
qed

interpretation dual_linorder: linorder "(op \<ge>)::('a::{linorder}=>'a=>bool)" "(op >)"
proof
  fix x y::'a show "y \<le> x \<or> x \<le> y" using linear .
qed

lemma wf_wellorderI2:
  assumes wf: "wf {(x::'a::ord, y). y < x}"
  assumes lin: "class.linorder (\<lambda>(x\<Colon>'a) y\<Colon>'a. y \<le> x) (\<lambda>(x\<Colon>'a) y\<Colon>'a. y < x)"
  shows "class.wellorder (\<lambda>(x\<Colon>'a) y\<Colon>'a. y \<le> x) (\<lambda>(x\<Colon>'a) y\<Colon>'a. y < x)"
  using lin unfolding class.wellorder_def apply (rule conjI)
  apply (rule class.wellorder_axioms.intro) by (blast intro: wf_induct_rule [OF wf])

lemma (in preorder) tranclp_less': "op >\<^sup>+\<^sup>+ = op >"
  by(auto simp add: fun_eq_iff intro: less_trans elim: tranclp.induct)

interpretation dual_wellorder: wellorder "(op \<ge>)::('a::{linorder, finite}=>'a=>bool)" "(op >)"
proof (rule wf_wellorderI2)
  show "wf {(x :: 'a, y). y < x}"
    by(auto simp add: trancl_def tranclp_less' intro!: finite_acyclic_wf acyclicI)
  show "class.linorder (\<lambda>(x\<Colon>'a) y\<Colon>'a. y \<le> x) (\<lambda>(x\<Colon>'a) y\<Colon>'a. y < x)"
    unfolding class.linorder_def unfolding class.linorder_axioms_def unfolding class.order_def
    unfolding class.preorder_def unfolding class.order_axioms_def by auto
qed

subsection{*Computable greatest operator*}

definition Greatest' :: "('a\<Colon>order \<Rightarrow> bool) \<Rightarrow> 'a\<Colon>order" (binder "GREATEST' " 10)
  where "Greatest' P = dual_order.Least P"

text{*The following THE operator will be computable when the underlying type belongs to a suitable
      class (for example, Enum).*}

lemmas Greatest'I2_order = dual_order.LeastI2_order[folded Greatest'_def]
lemmas Greatest'_equality = dual_order.Least_equality[folded Greatest'_def]
lemmas Greatest'I = dual_wellorder.LeastI[folded Greatest'_def]
lemmas Greatest'I2_ex = dual_wellorder.LeastI2_ex[folded Greatest'_def]
lemmas Greatest'I2_wellorder = dual_wellorder.LeastI2_wellorder[folded Greatest'_def]
lemmas Greatest'I_ex = dual_wellorder.LeastI_ex[folded Greatest'_def]
lemmas not_greater_Greatest' = dual_wellorder.not_less_Least[folded Greatest'_def]
lemmas Greatest'I2 = dual_wellorder.LeastI2[folded Greatest'_def]
lemmas Greatest'_ge = dual_wellorder.Least_le[folded Greatest'_def]

end


(*  Title:     Sensors.thy
    Author:     Sven Linker

Defines perfect sensors for cars. Cars can perceive both
the physical size and braking distance of all other cars.
*)

section\<open> Sensors for Cars\<close>
text\<open>
This section presents the abstract definition of a function
determining the sensor capabilities of cars. Such a function
takes a car \(e\), a traffic snapshot \(ts\) and another
car \(c\), and returns the length of \(c\) as perceived
by \(e\) at the situation determined by \(ts\). The
only restriction we impose is that this length is always
greater than zero.

With such a function, we define a derived notion of the
\emph{space} the car \(c\) occupies as perceived by \(e\).
However, this does not define the lanes \(c\) occupies, but
only a continuous interval. The lanes occupied by \(c\)
are given by the reservation and claim functions of
the traffic snapshot \(ts\).
\<close>

theory Sensors
  imports "Traffic" "Views"
begin

locale sensors = traffic + view +
  fixes sensors::"(cars) \<Rightarrow> traffic \<Rightarrow> (cars) \<Rightarrow> real"
  assumes sensors_ge:"(sensors e ts c) > 0"
begin

definition space ::" traffic \<Rightarrow> view \<Rightarrow> cars \<Rightarrow> real_int"
  where "space ts v c \<equiv> Abs_real_int (pos ts c, pos ts c + sensors (own v) ts c)"

lemma left_space: "left (space ts v c) = pos ts c"
proof -
  have 1:"pos ts c < pos ts c + sensors (own v) ts c" using sensors_ge
    by (metis (no_types, opaque_lifting)  less_add_same_cancel1  )
  show "left (space ts v c ) = pos ts c"
    using space_def Abs_real_int_inverse 1 by simp
qed

lemma right_space: "right (space ts v c) =   pos ts c + sensors (own v) ts c"
proof -
  have 1:"pos ts c < pos ts c + sensors (own v) ts c" using sensors_ge
    by (metis (no_types, opaque_lifting)  less_add_same_cancel1  )
  show 3:"right(space ts v c ) = pos ts c + sensors (own v) ts c"
    using space_def Abs_real_int_inverse 1 by simp
qed

lemma space_nonempty:"left (space ts v c ) < right (space ts v c)"
  using left_space right_space sensors_ge by simp

end
end


header {* Optimizations for Code Float *}
theory Optimize_Float
imports
  "../ODE_Auxiliarities"
  Optimize_Integer
begin

lemma compute_bitlen[code]: "bitlen a = (if a > 0 then log2 a + 1 else 0)"
  by (simp add: bitlen_def log2_def)

lemma compute_real_of_float[code]:
  "real_of_float (Float m e) = (if e \<ge> 0 then m * 2 ^ nat e else m / power_int 2 (-e))"
  unfolding power_int_def[symmetric, of 2 e]
  by (simp add: Float.compute_real_of_float power_int_def)

lemma compute_float_down[code]:
  "float_down p (Float m e) =
    (if p + e < 0 then Float (m div power_int 2 (-(p + e))) (-p) else Float m e)"
  by (simp add: Float.compute_float_down power_int_def)

lemma compute_float_up[code]:
  "float_up p (Float m e) =
    (let P = power_int 2 (-(p + e)); r = m mod P in
      if p + e < 0 then Float (m div P + (if r = 0 then 0 else 1)) (-p) else Float m e)"
  by (simp add: Float.compute_float_up power_int_def)

lemma compute_lapprox_posrat[code]:
  fixes prec::nat and x y::nat
  shows "lapprox_posrat prec x y =
   (let
       l = rat_precision prec x y;
       d = if 0 \<le> l then int x * power_int 2 l div y else int x div power_int 2 (- l) div y
    in normfloat (Float d (- l)))"
  by (auto simp add: Float.compute_lapprox_posrat power_int_def Let_def zdiv_int int_power int_mult)

lemma compute_rapprox_posrat[code]:
  fixes prec x y
  defines "l \<equiv> rat_precision prec x y"
  shows "rapprox_posrat prec x y = (let
     l = l ;
     X = if 0 \<le> l then (int x * power_int 2 l, int y) else (int x, int y * power_int 2 (-l)) ;
     d = fst X div snd X ;
     m = fst X mod snd X
   in normfloat (Float (d + (if m = 0 \<or> y = 0 then 0 else 1)) (- l)))"
  by (auto simp add: l_def Float.compute_rapprox_posrat power_int_def Let_def zdiv_int int_power int_mult)

lemma compute_float_truncate_down[code]:
  "float_round_down prec (Float m e) = (let d = bitlen (abs m) - int prec in
    if 0 < d then let P = power_int 2 d ; n = m div P in Float n (e + d)
             else Float m e)"
  by (simp add: Float.compute_float_round_down power_int_def cong: if_cong)

lemma compute_float_truncate_up[code]:
  "float_round_up prec (Float m e) = (let d = (bitlen (abs m) - int prec) in
     if 0 < d then let P = power_int 2 d ; n = m div P ; r = m mod P
                   in Float (n + (if r = 0 then 0 else 1)) (e + d)
              else Float m e)"
  by (simp add: Float.compute_float_round_up power_int_def cong: if_cong)

lemma compute_int_floor_fl[code]:
  "int_floor_fl (Float m e) = (if 0 \<le> e then m * power_int 2 e else m div (power_int 2 (-e)))"
  by (simp add: Float.compute_int_floor_fl power_int_def)

lemma compute_floor_fl[code]:
  "floor_fl (Float m e) = (if 0 \<le> e then Float m e else Float (m div (power_int 2 ((-e)))) 0)"
  by (simp add: Float.compute_floor_fl power_int_def)

end


theory Reg_Exp_Example
imports
  "~~/src/HOL/Library/Predicate_Compile_Quickcheck"
  "~~/src/HOL/Library/Code_Prolog"
begin

text \<open>An example from the experiments from SmallCheck (\<^url>\<open>http://www.cs.york.ac.uk/fp/smallcheck\<close>)\<close>
text \<open>The example (original in Haskell) was imported with Haskabelle and
  manually slightly adapted.
\<close>

datatype Nat = Zer
             | Suc Nat

fun sub :: "Nat \<Rightarrow> Nat \<Rightarrow> Nat"
where
  "sub x y = (case y of
                 Zer \<Rightarrow> x
               | Suc y' \<Rightarrow> case x of
                                         Zer \<Rightarrow> Zer
                                       | Suc x' \<Rightarrow> sub x' y')"

datatype Sym = N0
             | N1 Sym

datatype RE = Sym Sym
            | Or RE RE
            | Seq RE RE
            | And RE RE
            | Star RE
            | Empty

function accepts :: "RE \<Rightarrow> Sym list \<Rightarrow> bool" and
    seqSplit :: "RE \<Rightarrow> RE \<Rightarrow> Sym list \<Rightarrow> Sym list \<Rightarrow> bool" and
    seqSplit'' :: "RE \<Rightarrow> RE \<Rightarrow> Sym list \<Rightarrow> Sym list \<Rightarrow> bool" and
    seqSplit' :: "RE \<Rightarrow> RE \<Rightarrow> Sym list \<Rightarrow> Sym list \<Rightarrow> bool"
where
  "accepts re ss = (case re of
                       Sym n \<Rightarrow> case ss of
                                              Nil \<Rightarrow> False
                                            | (n' # ss') \<Rightarrow> n = n' & List.null ss'
                     | Or re1 re2 \<Rightarrow> accepts re1 ss | accepts re2 ss
                     | Seq re1 re2 \<Rightarrow> seqSplit re1 re2 Nil ss
                     | And re1 re2 \<Rightarrow> accepts re1 ss & accepts re2 ss
                     | Star re' \<Rightarrow> case ss of
                                                 Nil \<Rightarrow> True
                                               | (s # ss') \<Rightarrow> seqSplit re' re [s] ss'
                     | Empty \<Rightarrow> List.null ss)"
| "seqSplit re1 re2 ss2 ss = (seqSplit'' re1 re2 ss2 ss | seqSplit' re1 re2 ss2 ss)"
| "seqSplit'' re1 re2 ss2 ss = (accepts re1 ss2 & accepts re2 ss)"
| "seqSplit' re1 re2 ss2 ss = (case ss of
                                  Nil \<Rightarrow> False
                                | (n # ss') \<Rightarrow> seqSplit re1 re2 (ss2 @ [n]) ss')"
by pat_completeness auto

termination
  sorry

fun rep :: "Nat \<Rightarrow> RE \<Rightarrow> RE"
where
  "rep n re = (case n of
                  Zer \<Rightarrow> Empty
                | Suc n' \<Rightarrow> Seq re (rep n' re))"

fun repMax :: "Nat \<Rightarrow> RE \<Rightarrow> RE"
where
  "repMax n re = (case n of
                     Zer \<Rightarrow> Empty
                   | Suc n' \<Rightarrow> Or (rep n re) (repMax n' re))"

fun repInt' :: "Nat \<Rightarrow> Nat \<Rightarrow> RE \<Rightarrow> RE"
where
  "repInt' n k re = (case k of
                        Zer \<Rightarrow> rep n re
                      | Suc k' \<Rightarrow> Or (rep n re) (repInt' (Suc n) k' re))"

fun repInt :: "Nat \<Rightarrow> Nat \<Rightarrow> RE \<Rightarrow> RE"
where
  "repInt n k re = repInt' n (sub k n) re"

fun prop_regex :: "Nat * Nat * RE * RE * Sym list \<Rightarrow> bool"
where
  "prop_regex (n, (k, (p, (q, s)))) =
    ((accepts (repInt n k (And p q)) s) = (accepts (And (repInt n k p) (repInt n k q)) s))"

lemma "accepts (repInt n k (And p q)) s --> accepts (And (repInt n k p) (repInt n k q)) s"
(*nitpick
quickcheck[tester = random, iterations = 10000]
quickcheck[tester = predicate_compile_wo_ff]
quickcheck[tester = predicate_compile_ff_fs]*)
oops

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

setup \<open>Code_Prolog.map_code_options (K
  {ensure_groundness = true,
   limit_globally = NONE,
   limited_types = [(@{typ Sym}, 0), (@{typ "Sym list"}, 2), (@{typ RE}, 6)],
   limited_predicates = [(["repIntPa"], 2), (["repP"], 2), (["subP"], 0),
    (["accepts", "acceptsaux", "seqSplit", "seqSplita", "seqSplitaux", "seqSplitb"], 25)],
   replacing =
     [(("repP", "limited_repP"), "lim_repIntPa"),
      (("subP", "limited_subP"), "repIntP"),
      (("repIntPa", "limited_repIntPa"), "repIntP"),
      (("accepts", "limited_accepts"), "quickcheck")],
   manual_reorder = []})\<close>

text \<open>Finding the counterexample still seems out of reach for the
 prolog-style generation.\<close>

lemma "accepts (And (repInt n k p) (repInt n k q)) s --> accepts (repInt n k (And p q)) s"
quickcheck[exhaustive]
quickcheck[tester = random, iterations = 1000]
(*quickcheck[tester = predicate_compile_wo_ff]*)
(*quickcheck[tester = predicate_compile_ff_fs, iterations = 1]*)
(*quickcheck[tester = prolog, iterations = 1, size = 1]*)
oops

section \<open>Given a partial solution\<close>

lemma
(*  assumes "n = Zer"
  assumes "k = Suc (Suc Zer)"*)
  assumes "p = Sym N0"
  assumes "q = Seq (Sym N0) (Sym N0)"
(*  assumes "s = [N0, N0]"*)
  shows "accepts (And (repInt n k p) (repInt n k q)) s --> accepts (repInt n k (And p q)) s"
(*quickcheck[tester = predicate_compile_wo_ff, iterations = 1]*)
quickcheck[tester = prolog, iterations = 1, size = 1]
oops

section \<open>Checking the counterexample\<close>

definition a_sol
where
  "a_sol = (Zer, (Suc (Suc Zer), (Sym N0, (Seq (Sym N0) (Sym N0), [N0, N0]))))"

lemma
  assumes "n = Zer"
  assumes "k = Suc (Suc Zer)"
  assumes "p = Sym N0"
  assumes "q = Seq (Sym N0) (Sym N0)"
  assumes "s = [N0, N0]"
  shows "accepts (repInt n k (And p q)) s --> accepts (And (repInt n k p) (repInt n k q)) s"
(*quickcheck[tester = predicate_compile_wo_ff]*)
oops

lemma
  assumes "n = Zer"
  assumes "k = Suc (Suc Zer)"
  assumes "p = Sym N0"
  assumes "q = Seq (Sym N0) (Sym N0)"
  assumes "s = [N0, N0]"
  shows "accepts (And (repInt n k p) (repInt n k q)) s --> accepts (repInt n k (And p q)) s"
(*quickcheck[tester = predicate_compile_wo_ff, iterations = 1, expect = counterexample]*)
quickcheck[tester = prolog, iterations = 1, size = 1]
oops

lemma
  assumes "n = Zer"
  assumes "k = Suc (Suc Zer)"
  assumes "p = Sym N0"
  assumes "q = Seq (Sym N0) (Sym N0)"
  assumes "s = [N0, N0]"
shows "prop_regex (n, (k, (p, (q, s))))"
quickcheck[tester = smart_exhaustive, depth = 30]
quickcheck[tester = prolog]
oops

lemma "prop_regex a_sol"
quickcheck[tester = random]
quickcheck[tester = smart_exhaustive]
oops

value "prop_regex a_sol"

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
subsection \<open>Resultant\<close>

text \<open>This theory contains
  facts about resultants which are required for addition and multiplication
  of algebraic numbers.

  The results are taken from the textbook \cite[pages 227ff and 235ff]{AlgNumbers}.
\<close>

theory Resultant
imports
  "HOL-Computational_Algebra.Fundamental_Theorem_Algebra" (* for lmpoly_base_conv *)
  Subresultants.Resultant_Prelim
  Berlekamp_Zassenhaus.Unique_Factorization_Poly
  Bivariate_Polynomials
begin

subsubsection \<open>Sylvester matrices and vector representation of polynomials\<close>

definition vec_of_poly_rev_shifted where
  "vec_of_poly_rev_shifted p n j \<equiv>
   vec n (\<lambda>i. if i \<le> j \<and> j \<le> degree p + i then coeff p (degree p + i - j) else 0)"

lemma vec_of_poly_rev_shifted_dim[simp]: "dim_vec (vec_of_poly_rev_shifted p n j) = n"
  unfolding vec_of_poly_rev_shifted_def by auto

lemma col_sylvester:
  fixes p q
  defines "m \<equiv> degree p" and "n \<equiv> degree q"
  assumes j: "j < m+n"
  shows "col (sylvester_mat p q) j =
    vec_of_poly_rev_shifted p n j @\<^sub>v vec_of_poly_rev_shifted q m j" (is "?l = ?r")
proof
  note [simp] = m_def[symmetric] n_def[symmetric]
  show "dim_vec ?l = dim_vec ?r" by simp
  fix i assume "i < dim_vec ?r" hence i: "i < m+n" by auto
  show "?l $ i = ?r $ i"
    unfolding vec_of_poly_rev_shifted_def
    apply (subst index_col) using i apply simp using j apply simp
    apply (subst sylvester_index_mat) using i apply simp using j apply simp
    apply (cases "i < n") apply force using i by simp
qed

lemma inj_on_diff_nat2: "inj_on (\<lambda>i. (n::nat) - i) {..n}" by (rule inj_onI, auto)

lemma image_diff_atMost: "(\<lambda>i. (n::nat) - i) ` {..n} = {..n}" (is "?l = ?r")
  unfolding set_eq_iff
proof (intro allI iffI)
  fix x assume x: "x \<in> ?r"
    thus "x \<in> ?l" unfolding image_def mem_Collect_eq
    by(intro bexI[of _ "n-x"],auto)
qed auto

lemma sylvester_sum_mat_upper:
  fixes p q :: "'a :: comm_semiring_1 poly"
  defines "m \<equiv> degree p" and "n \<equiv> degree q"
  assumes i: "i < n"
  shows "(\<Sum>j<m+n. monom (sylvester_mat p q $$ (i,j)) (m + n - Suc j)) =
    monom 1 (n - Suc i) * p" (is "sum ?f _ = ?r")
proof -
  have n1: "n \<ge> 1" using i by auto
  define ni1 where "ni1 = n-Suc i"
  hence ni1: "n-i = Suc ni1" using i by auto
  define l where "l = m+n-1"
  hence l: "Suc l = m+n" using n1 by auto
  let ?g = "\<lambda>j. monom (coeff (monom 1 (n-Suc i) * p) j) j"
  let ?p = "\<lambda>j. l-j"
  have "sum ?f {..<m+n} = sum ?f {..l}"
    unfolding l[symmetric] unfolding lessThan_Suc_atMost..
  also {
    fix j assume j: "j\<le>l"
    have "?f j = ((\<lambda>j. monom (coeff (monom 1 (n-i) * p) (Suc j)) j) \<circ> ?p) j"
      apply(subst sylvester_index_mat2)
      using i j unfolding l_def m_def[symmetric] n_def[symmetric]
      by (auto simp add: Suc_diff_Suc)
    also have "... = (?g \<circ> ?p) j"
      unfolding ni1
      unfolding coeff_monom_Suc
      unfolding ni1_def
      using i by auto
    finally have "?f j = (?g \<circ> ?p) j".
  }
  hence "(\<Sum>j\<le>l. ?f j) = (\<Sum>j\<le>l. (?g\<circ>?p) j)" using l by auto
  also have "... = (\<Sum>j\<le>l. ?g j)"
    unfolding l_def
    using sum.reindex[OF inj_on_diff_nat2,symmetric,unfolded image_diff_atMost].
  also have "degree ?r \<le> l"
      using degree_mult_le[of "monom 1 (n-Suc i)" p]
      unfolding l_def m_def
      unfolding degree_monom_eq[OF one_neq_zero] using i by auto
    from poly_as_sum_of_monoms'[OF this]
    have "(\<Sum>j\<le>l. ?g j) = ?r".
  finally show ?thesis.
qed

lemma sylvester_sum_mat_lower:
  fixes p q :: "'a :: comm_semiring_1 poly"
  defines "m \<equiv> degree p" and "n \<equiv> degree q"
  assumes ni: "n \<le> i" and imn: "i < m+n"
  shows "(\<Sum>j<m+n. monom (sylvester_mat p q $$ (i,j)) (m + n - Suc j)) =
    monom 1 (m + n - Suc i) * q" (is "sum ?f _ = ?r")
proof -
  define l where "l = m+n-1"
  hence l: "Suc l = m+n" using imn by auto
  define mni1 where "mni1 = m + n - Suc i"
  hence mni1: "m+n-i = Suc mni1" using imn by auto
  let ?g = "\<lambda>j. monom (coeff (monom 1 (m + n - Suc i) * q) j) j"
  let ?p = "\<lambda>j. l-j"
  have "sum ?f {..<m+n} = sum ?f {..l}"
    unfolding l[symmetric] unfolding lessThan_Suc_atMost..
  also {
    fix j assume j: "j\<le>l"
    have "?f j = ((\<lambda>j. monom (coeff (monom 1 (m+n-i) * q) (Suc j)) j) \<circ> ?p) j"
      apply(subst sylvester_index_mat2)
      using ni imn j unfolding l_def m_def[symmetric] n_def[symmetric]
      by (auto simp add: Suc_diff_Suc)
    also have "... = (?g \<circ> ?p) j"
      unfolding mni1
      unfolding coeff_monom_Suc
      unfolding mni1_def..
    finally have "?f j = ...".
  }
  hence "(\<Sum>j\<le>l. ?f j) = (\<Sum>j\<le>l. (?g\<circ>?p) j)" by auto
  also have "... = (\<Sum>j\<le>l. ?g j)"
    using sum.reindex[OF inj_on_diff_nat2,symmetric,unfolded image_diff_atMost].
  also have "degree ?r \<le> l"
      using degree_mult_le[of "monom 1 (m+n-1-i)" q]
      unfolding l_def n_def[symmetric]
      unfolding degree_monom_eq[OF one_neq_zero] using ni imn by auto
    from poly_as_sum_of_monoms'[OF this]
    have "(\<Sum>j\<le>l. ?g j) = ?r".
  finally show ?thesis.
qed

definition "vec_of_poly p \<equiv> let m = degree p in vec (Suc m) (\<lambda>i. coeff p (m-i))"

definition "poly_of_vec v \<equiv> let d = dim_vec v in \<Sum>i<d. monom (v $ (d - Suc i)) i"

lemma poly_of_vec_of_poly[simp]:
  fixes p :: "'a :: comm_monoid_add poly"
  shows "poly_of_vec (vec_of_poly p) = p"
  unfolding poly_of_vec_def vec_of_poly_def Let_def
  unfolding dim_vec
  unfolding lessThan_Suc_atMost
  using poly_as_sum_of_monoms[of p] by auto

lemma poly_of_vec_0[simp]: "poly_of_vec (0\<^sub>v n) = 0" unfolding poly_of_vec_def Let_def by auto

lemma poly_of_vec_0_iff[simp]:
  fixes v  :: "'a :: comm_monoid_add vec"
  shows "poly_of_vec v = 0 \<longleftrightarrow> v = 0\<^sub>v (dim_vec v)" (is "?v = _ \<longleftrightarrow> _ = ?z")
proof
  assume "?v = 0"
  hence "\<forall>i\<in>{..<dim_vec v}. v $ (dim_vec v - Suc i) = 0"
    unfolding poly_of_vec_def Let_def
    by (subst sum_monom_0_iff[symmetric],auto)
  hence a: "\<And>i. i < dim_vec v \<Longrightarrow> v $ (dim_vec v - Suc i) = 0" by auto
  { fix i assume "i < dim_vec v"
    hence "v $ i = 0" using a[of "dim_vec v - Suc i"] by auto
  }
  thus "v = ?z" by auto
  next assume r: "v = ?z"
  show "?v = 0" apply (subst r) by auto
qed

(* TODO: move, copied from no longer existing Cayley-Hamilton/Polynomial_extension *)
lemma degree_sum_smaller:
  assumes "n > 0" "finite A"
  shows "(\<And> x. x \<in>A \<Longrightarrow> degree (f x) < n) \<Longrightarrow> degree (\<Sum>x\<in>A. f x) < n"
  using \<open>finite A\<close>
  by(induct rule: finite_induct)
    (simp_all add: degree_add_less assms)

lemma degree_poly_of_vec_less:
  fixes v :: "'a :: comm_monoid_add vec"
  assumes dim: "dim_vec v > 0"
  shows "degree (poly_of_vec v) < dim_vec v"
  unfolding poly_of_vec_def Let_def
  apply(rule degree_sum_smaller)
    using dim apply force
    apply force
  unfolding lessThan_iff
  by (metis degree_0 degree_monom_eq dim monom_eq_0_iff)

lemma coeff_poly_of_vec:
  "coeff (poly_of_vec v) i = (if i < dim_vec v then v $ (dim_vec v - Suc i) else 0)"
  (is "?l = ?r")
proof -
  have "?l = (\<Sum>x<dim_vec v. if x = i then v $ (dim_vec v - Suc x) else 0)" (is "_ = ?m")
    unfolding poly_of_vec_def Let_def coeff_sum coeff_monom ..
  also have "\<dots> = ?r"
  proof (cases "i < dim_vec v")
    case False
    show ?thesis
      by (subst sum.neutral, insert False, auto)
  next
    case True
    show ?thesis
      by (subst sum.remove[of _ i], force, force simp: True, subst sum.neutral, insert True, auto)
  qed
  finally show ?thesis .
qed

lemma vec_of_poly_rev_shifted_scalar_prod:
  fixes p v
  defines "q \<equiv> poly_of_vec v"
  assumes m[simp]: "degree p = m" and n: "dim_vec v = n"
  assumes j: "j < m+n"
  shows "vec_of_poly_rev_shifted p n (n+m-Suc j) \<bullet> v = coeff (p * q) j" (is "?l = ?r")
proof -
  have id1: "\<And> i. m + i - (n + m - Suc j) = i + Suc j - n"
    using j by auto
  let ?g = "\<lambda> i. if i \<le> n + m - Suc j \<and> n - Suc j \<le> i then coeff p (i + Suc j - n) *  v $ i else 0"
  have "?thesis = ((\<Sum>i = 0..<n. ?g i) =
        (\<Sum>i\<le>j. coeff p i * (if j - i < n then v $ (n - Suc (j - i)) else 0)))" (is "_ = (?l = ?r)")
    unfolding vec_of_poly_rev_shifted_def coeff_mult m scalar_prod_def n q_def
      coeff_poly_of_vec
    by (subst sum.cong, insert id1, auto)
  also have "..."
  proof -
    have "?r = (\<Sum>i\<le>j. (if j - i < n then coeff p i * v $ (n - Suc (j - i)) else 0))" (is "_ = sum ?f _")
      by (rule sum.cong, auto)
    also have "sum ?f {..j} = sum ?f ({i. i \<le> j \<and> j - i < n} \<union> {i. i \<le> j \<and> \<not> j - i < n})"
      (is "_ = sum _ (?R1 \<union> ?R2)")
      by (rule sum.cong, auto)
    also have "\<dots> = sum ?f ?R1 + sum ?f ?R2"
      by (subst sum.union_disjoint, auto)
    also have "sum ?f ?R2 = 0"
      by (rule sum.neutral, auto)
    also have "sum ?f ?R1 + 0 = sum (\<lambda> i. coeff p i * v $ (i + n - Suc j)) ?R1"
      (is "_ = sum ?F _")
      by (subst sum.cong, auto simp: ac_simps)
    also have "\<dots> = sum ?F ((?R1 \<inter> {..m}) \<union> (?R1 - {..m}))"
      (is "_ = sum _ (?R \<union> ?R')")
      by (rule sum.cong, auto)
    also have "\<dots> = sum ?F ?R + sum ?F ?R'"
      by (subst sum.union_disjoint, auto)
    also have "sum ?F ?R' = 0"
    proof -
      {
        fix x
        assume "x > m"
        from coeff_eq_0[OF this[folded m]]
        have "?F x = 0" by simp
      }
      thus ?thesis
        by (subst sum.neutral, auto)
    qed
    finally have r: "?r = sum ?F ?R" by simp

    have "?l = sum ?g ({i. i < n \<and> i \<le> n + m - Suc j \<and> n - Suc j \<le> i}
      \<union> {i. i < n \<and> \<not> (i \<le> n + m - Suc j \<and> n - Suc j \<le> i)})"
      (is "_ = sum _ (?L1 \<union> ?L2)")
      by (rule sum.cong, auto)
    also have "\<dots> = sum ?g ?L1 + sum ?g ?L2"
      by (subst sum.union_disjoint, auto)
    also have "sum ?g ?L2 = 0"
      by (rule sum.neutral, auto)
    also have "sum ?g ?L1 + 0 = sum (\<lambda> i. coeff p (i + Suc j - n) * v $ i) ?L1"
      (is "_ = sum ?G _")
      by (subst sum.cong, auto)
    also have "\<dots> = sum ?G (?L1 \<inter> {i. i + Suc j - n \<le> m} \<union> (?L1 - {i. i + Suc j - n \<le> m}))"
      (is "_ = sum _ (?L \<union> ?L')")
      by (subst sum.cong, auto)
    also have "\<dots> = sum ?G ?L + sum ?G ?L'"
      by (subst sum.union_disjoint, auto)
    also have "sum ?G ?L' = 0"
    proof -
      {
        fix x
        assume "x + Suc j - n > m"
        from coeff_eq_0[OF this[folded m]]
        have "?G x = 0" by simp
      }
      thus ?thesis
        by (subst sum.neutral, auto)
    qed
    finally have l: "?l = sum ?G ?L" by simp

    let ?bij = "\<lambda> i. i + n - Suc j"
    {
      fix x
      assume x: "j < m + n" "Suc (x + j) - n \<le> m" "x < n" "n - Suc j \<le> x"
      define y where "y = x + Suc j - n"
      from x have "x + Suc j \<ge> n" by auto
      with x have xy: "x = ?bij y" unfolding y_def by auto
      from x have y: "y \<in> ?R" unfolding y_def by auto
      have "x \<in> ?bij ` ?R" unfolding xy using y by blast
    } note tedious = this
    show ?thesis unfolding l r
      by (rule sum.reindex_cong[of ?bij], insert j, auto simp: inj_on_def tedious)
  qed
  finally show ?thesis by simp
qed

lemma sylvester_vec_poly:
  fixes p q :: "'a :: comm_semiring_0 poly"
  defines "m \<equiv> degree p"
      and "n \<equiv> degree q"
  assumes v: "v \<in> carrier_vec (m+n)"
  shows "poly_of_vec (transpose_mat (sylvester_mat p q) *\<^sub>v v) =
    poly_of_vec (vec_first v n) * p + poly_of_vec (vec_last v m) * q" (is "?l = ?r")
proof (rule poly_eqI)
  fix i
  note mn[simp] = m_def[symmetric] n_def[symmetric]
  let ?Tv = "transpose_mat (sylvester_mat p q) *\<^sub>v v"
  have dim: "dim_vec (vec_first v n) = n" "dim_vec (vec_last v m) = m" "dim_vec ?Tv = n + m"
    using v by auto
  have if_distrib: "\<And> x y z. (if x then y else (0 :: 'a)) * z = (if x then y * z else 0)"
    by auto
  show "coeff ?l i = coeff ?r i"
  proof (cases "i < m+n")
    case False
      hence i_mn: "i \<ge> m+n"
        and i_n: "\<And>x. x \<le> i \<and> x < n \<longleftrightarrow> x < n"
        and i_m: "\<And>x. x \<le> i \<and> x < m \<longleftrightarrow> x < m" by auto
      have "coeff ?r i =
            (\<Sum> x < n. vec_first v n $ (n - Suc x) * coeff p (i - x)) +
            (\<Sum> x < m. vec_last v m $ (m - Suc x) * coeff q (i - x))"
        (is "_ = sum ?f _ + sum ?g _")
        unfolding coeff_add coeff_mult Let_def
        unfolding coeff_poly_of_vec dim if_distrib
        unfolding atMost_def
        apply(subst sum.inter_filter[symmetric],simp)
        apply(subst sum.inter_filter[symmetric],simp)
        unfolding mem_Collect_eq
        unfolding i_n i_m
        unfolding lessThan_def by simp
      also { fix x assume x: "x < n"
        have "coeff p (i-x) = 0"
          apply(rule coeff_eq_0) using i_mn x unfolding m_def by auto
        hence "?f x = 0" by auto
      } hence "sum ?f {..<n} = 0" by auto
      also { fix x assume x: "x < m"
        have "coeff q (i-x) = 0"
          apply(rule coeff_eq_0) using i_mn x unfolding n_def by auto
        hence "?g x = 0" by auto
      } hence "sum ?g {..<m} = 0" by auto
      finally have "coeff ?r i = 0" by auto
      also from False have "0 = coeff ?l i"
        unfolding coeff_poly_of_vec dim sum.distrib[symmetric] by auto
      finally show ?thesis by auto
    next case True
      hence "coeff ?l i = (transpose_mat (sylvester_mat p q) *\<^sub>v v) $ (n + m - Suc i)"
        unfolding coeff_poly_of_vec dim sum.distrib[symmetric] by auto
      also have "... = coeff (p * poly_of_vec (vec_first v n) + q * poly_of_vec (vec_last v m)) i"
        apply(subst index_mult_mat_vec) using True apply simp
        apply(subst row_transpose) using True apply simp
        apply(subst col_sylvester)
        unfolding mn using True apply simp
        apply(subst vec_first_last_append[of v n m,symmetric]) using v apply(simp add: add.commute)
        apply(subst scalar_prod_append)
        apply (rule carrier_vecI,simp)+
        apply (subst vec_of_poly_rev_shifted_scalar_prod,simp,simp) using True apply simp
        apply (subst add.commute[of n m])
        apply (subst vec_of_poly_rev_shifted_scalar_prod,simp,simp) using True apply simp
        by simp
      also have "... =
        (\<Sum>x\<le>i. (if x < n then vec_first v n $ (n - Suc x) else 0) * coeff p (i - x)) +
        (\<Sum>x\<le>i. (if x < m then vec_last v m $ (m - Suc x) else 0) * coeff q (i - x))"
        unfolding coeff_poly_of_vec[of "vec_first v n",unfolded dim_vec_first,symmetric]
        unfolding coeff_poly_of_vec[of "vec_last v m",unfolded dim_vec_last,symmetric]
        unfolding coeff_mult[symmetric] by (simp add: mult.commute)
      also have "... = coeff ?r i"
        unfolding coeff_add coeff_mult Let_def
        unfolding coeff_poly_of_vec dim..
      finally show ?thesis.
  qed
qed

subsubsection \<open>Homomorphism and Resultant\<close>

text \<open>Here we prove Lemma~7.3.1 of the textbook.\<close>

lemma(in comm_ring_hom) resultant_sub_map_poly:
  fixes p q :: "'a poly"
  shows "hom (resultant_sub m n p q) = resultant_sub m n (map_poly hom p) (map_poly hom q)"
    (is "?l = ?r'")
proof -
  let ?mh = "map_poly hom"
  have "?l = det (sylvester_mat_sub m n (?mh p) (?mh q))"
    unfolding resultant_sub_def
    apply(subst sylvester_mat_sub_map[symmetric]) by auto
  thus ?thesis unfolding resultant_sub_def.
qed

(*
lemma (in comm_ring_hom) resultant_map_poly:
  fixes p q :: "'a poly"
    defines "p' \<equiv> map_poly hom p"
    defines "q' \<equiv> map_poly hom q"
    defines "m \<equiv> degree p"
    defines "n \<equiv> degree q"
    defines "m' \<equiv> degree p'"
    defines "n' \<equiv> degree q'"
    defines "r \<equiv> resultant p q"
    defines "r' \<equiv> resultant p' q'"
  shows "m' = m \<Longrightarrow> n' = n \<Longrightarrow> hom r = r'"
    and "m' = m \<Longrightarrow> hom r = hom (coeff p m')^(n-n') * r'"
    and "m' \<noteq> m \<Longrightarrow> n' = n \<Longrightarrow>
      hom r = (if even n then 1 else (-1)^(m-m')) * hom (coeff q n)^(m-m') * r'"
      (is "_ \<Longrightarrow> _ \<Longrightarrow> ?goal")
    and "m' \<noteq> m \<Longrightarrow> n' \<noteq> n \<Longrightarrow> hom r = 0"
proof -
  have m'm: "m' \<le> m" unfolding m_def m'_def p'_def using degree_map_poly_le by auto
  have n'n: "n' \<le> n" unfolding n_def n'_def q'_def using degree_map_poly_le by auto

  have coeffp'[simp]: "\<And>i. coeff p' i = hom (coeff p i)" unfolding p'_def by auto
  have coeffq'[simp]: "\<And>i. coeff q' i = hom (coeff q i)" unfolding q'_def by auto

  let ?f = "\<lambda>i. (if even n then 1 else (-1)^i) * hom (coeff q n)^i"

  have "hom r = resultant_sub m n p' q'"
    unfolding r_def resultant_sub
    unfolding m_def n_def p'_def q'_def
    by(rule resultant_sub_map_poly)
  also have "... = ?f (m-m') * resultant_sub m' n p' q'"
    using resultant_sub_trim_upper[of p' "m-m'" n q',folded m'_def] m'm
    by (auto simp: power_minus[symmetric])
  also have "... = ?f (m-m') * hom (coeff p m')^(n-n') * r'"
    using resultant_sub_trim_lower[of m' q' "n-n'" p'] n'n
    unfolding r'_def resultant_sub m'_def n'_def by auto
  finally have main: "hom r = ?f (m-m') * hom (coeff p m')^(n-n') * r'" by auto

  { assume "m' = m"
    thus "hom r = hom (coeff p m')^(n-n') * r'" using main by auto
    thus "n' = n \<Longrightarrow> hom r = r'" by auto
  }
  assume "m' \<noteq> m"
  hence m'm: "m' < m" using m'm by auto
  thus "n' = n \<Longrightarrow> ?goal" using main by simp
  assume "n' \<noteq> n"
  hence "n' < n" using n'n by auto
  hence "hom (coeff q n) = 0"
    unfolding coeffq'[symmetric] unfolding n'_def by(rule coeff_eq_0)
  hence "hom (coeff q n) ^ (m-m') = 0" using m'm by (simp add: power_0_left)
  from main[unfolded this]
  show "hom r = 0" using power_0_Suc by auto
qed
*)

subsubsection\<open>Resultant as Polynomial Expression\<close>
context begin
text \<open>This context provides notions for proving Lemma 7.2.1 of the textbook.\<close>

private fun mk_poly_sub where
  "mk_poly_sub A l 0 = A"
| "mk_poly_sub A l (Suc j) = mat_addcol (monom 1 (Suc j)) l (l-Suc j) (mk_poly_sub A l j)"

definition  "mk_poly A = mk_poly_sub (map_mat coeff_lift A) (dim_col A - 1) (dim_col A - 1)"

private lemma mk_poly_sub_dim[simp]:
  "dim_row (mk_poly_sub A l j) = dim_row A"
  "dim_col (mk_poly_sub A l j) = dim_col A"
  by (induct j,auto)

private lemma mk_poly_sub_carrier:
  assumes "A \<in> carrier_mat nr nc" shows "mk_poly_sub A l j \<in> carrier_mat nr nc"
  apply (rule carrier_matI) using assms by auto

private lemma mk_poly_dim[simp]:
  "dim_col (mk_poly A) = dim_col A"
  "dim_row (mk_poly A) = dim_row A"
  unfolding mk_poly_def by auto

private lemma mk_poly_sub_others[simp]:
  assumes "l \<noteq> j'" and "i < dim_row A" and "j' < dim_col A"
  shows "mk_poly_sub A l j $$ (i,j') = A $$ (i,j')"
  using assms by (induct j; simp)

private lemma mk_poly_others[simp]:
  assumes i: "i < dim_row A" and j: "j < dim_col A - 1"
  shows "mk_poly A $$ (i,j) = [: A $$ (i,j) :]"
  unfolding mk_poly_def
  apply(subst mk_poly_sub_others)
  using i j by auto

private lemma mk_poly_delete[simp]:
  assumes i: "i < dim_row A"
  shows "mat_delete (mk_poly A) i (dim_col A - 1) = map_mat coeff_lift (mat_delete A i (dim_col A - 1))"
  apply(rule eq_matI) unfolding mat_delete_def by auto

private lemma col_mk_poly_sub[simp]:
  assumes "l \<noteq> j'" and "j' < dim_col A"
  shows "col (mk_poly_sub A l j) j' = col A j'"
  by(rule eq_vecI; insert assms; simp)

private lemma det_mk_poly_sub:
  assumes A: "(A :: 'a :: comm_ring_1 poly mat) \<in> carrier_mat n n" and i: "i < n"
  shows "det (mk_poly_sub A (n-1) i) = det A"
  using i
proof (induct i)
  case (Suc i)
    show ?case unfolding mk_poly_sub.simps
    apply(subst det_addcol[of _ n])
      using Suc apply simp
      using Suc apply simp
      apply (rule mk_poly_sub_carrier[OF A])
      using Suc by auto
qed simp

private lemma det_mk_poly:
  fixes A :: "'a :: comm_ring_1 mat"
  shows "det (mk_poly A) = [: det A :]"
proof (cases "dim_row A = dim_col A")
  case True
    define n where "n = dim_col A"
    have "map_mat coeff_lift A \<in> carrier_mat (dim_row A) (dim_col A)" by simp
    hence sq: "map_mat coeff_lift A \<in> carrier_mat (dim_col A) (dim_col A)" unfolding True.
    show ?thesis
    proof(cases "dim_col A = 0")
      case True thus ?thesis unfolding det_def by simp
      next case False thus ?thesis
      unfolding mk_poly_def
      by (subst det_mk_poly_sub[OF sq]; simp)
    qed
  next case False
    hence f2: "dim_row A = dim_col A \<longleftrightarrow> False" by simp
    hence f3: "dim_row (mk_poly A) = dim_col (mk_poly A) \<longleftrightarrow> False"
      unfolding mk_poly_dim by auto
    show ?thesis unfolding det_def unfolding f2 f3 if_False by simp
qed

private fun mk_poly2_row where
  "mk_poly2_row A d j pv 0 = pv"
| "mk_poly2_row A d j pv (Suc n) =
   mk_poly2_row A d j pv n |\<^sub>v n \<mapsto> pv $ n + monom (A$$(n,j)) d"

private fun mk_poly2_col where
  "mk_poly2_col A pv 0 = pv"
| "mk_poly2_col A pv (Suc m) =
   mk_poly2_row A m (dim_col A - Suc m) (mk_poly2_col A pv m) (dim_row A)"

private definition "mk_poly2 A \<equiv> mk_poly2_col A (0\<^sub>v (dim_row A)) (dim_col A)"

private lemma mk_poly2_row_dim[simp]: "dim_vec (mk_poly2_row A d j pv i) = dim_vec pv"
  by(induct i arbitrary: pv, auto)

private lemma mk_poly2_col_dim[simp]: "dim_vec (mk_poly2_col A pv j) = dim_vec pv"
  by (induct j arbitrary: pv, auto)

private lemma mk_poly2_row:
  assumes n: "n \<le> dim_vec pv"
  shows "mk_poly2_row A d j pv n $ i =
    (if i < n then pv $ i + monom (A $$ (i,j)) d else pv $ i)"
  using n
proof (induct n arbitrary: pv)
  case (Suc n) thus ?case
    unfolding mk_poly2_row.simps by (cases rule: linorder_cases[of "i" "n"],auto)
qed simp

private lemma mk_poly2_row_col:
  assumes dim[simp]: "dim_vec pv = n" "dim_row A = n" and j: "j < dim_col A"
  shows "mk_poly2_row A d j pv n = pv + map_vec (\<lambda>a. monom a d) (col A j)"
  apply rule using mk_poly2_row[of _ pv] j by auto

private lemma mk_poly2_col:
  fixes pv :: "'a :: comm_semiring_1 poly vec" and A :: "'a mat"
  assumes i: "i < dim_row A" and dim: "dim_row A = dim_vec pv"
  shows "mk_poly2_col A pv j $ i = pv $ i + (\<Sum>j'<j. monom (A $$ (i, dim_col A - Suc j')) j')"
  using dim
proof (induct j arbitrary: pv)
  case (Suc j) show ?case
    unfolding mk_poly2_col.simps
    apply (subst mk_poly2_row)
      using Suc apply simp
    unfolding Suc(1)[OF Suc(2)]
    using i by (simp add: add.assoc)
qed simp

private lemma mk_poly2_pre:
  fixes A :: "'a :: comm_semiring_1 mat"
  assumes i: "i < dim_row A"
  shows "mk_poly2 A $ i = (\<Sum>j'<dim_col A. monom (A $$ (i, dim_col A - Suc j')) j')"
  unfolding mk_poly2_def
  apply(subst mk_poly2_col) using i by auto

private lemma mk_poly2:
  fixes A :: "'a :: comm_semiring_1 mat"
  assumes i: "i < dim_row A"
      and c: "dim_col A > 0"
  shows "mk_poly2 A $ i = (\<Sum>j'<dim_col A. monom (A $$ (i,j')) (dim_col A - Suc  j'))"
    (is "?l = sum ?f ?S")
proof -
  define l where "l = dim_col A - 1"
  have dim: "dim_col A = Suc l" unfolding l_def using i c by auto
  let ?g = "\<lambda>j. l - j"
  have "?l = sum (?f \<circ> ?g) ?S" unfolding l_def mk_poly2_pre[OF i] by auto
  also have "... = sum ?f ?S"
    unfolding dim
    unfolding lessThan_Suc_atMost
    using sum.reindex[OF inj_on_diff_nat2,symmetric,unfolded image_diff_atMost].
  finally show ?thesis.
qed

private lemma mk_poly2_sylvester_upper:
  fixes p q :: "'a :: comm_semiring_1 poly"
  assumes i: "i < degree q"
  shows "mk_poly2 (sylvester_mat p q) $ i = monom 1 (degree q - Suc i) * p"
  apply (subst mk_poly2)
    using i apply simp using i apply simp
  apply (subst sylvester_sum_mat_upper[OF i,symmetric])
  apply (rule sum.cong)
    unfolding sylvester_mat_dim lessThan_Suc_atMost apply simp
  by auto

private lemma mk_poly2_sylvester_lower:
  fixes p q :: "'a :: comm_semiring_1 poly"
  assumes mi: "i \<ge> degree q" and imn: "i < degree p + degree q"
  shows "mk_poly2 (sylvester_mat p q) $ i = monom 1 (degree p + degree q - Suc i) * q"
  apply (subst mk_poly2)
    using imn apply simp using mi imn apply simp
  unfolding sylvester_mat_dim
  using sylvester_sum_mat_lower[OF mi imn]
  apply (subst sylvester_sum_mat_lower) using mi imn by auto

private lemma foo:
  fixes v :: "'a :: comm_semiring_1 vec"
  shows "monom 1 d \<cdot>\<^sub>v map_vec coeff_lift v = map_vec (\<lambda>a. monom a d) v"
  apply (rule eq_vecI)
  unfolding index_map_vec index_col
  by (auto simp add: Polynomial.smult_monom)

private lemma mk_poly_sub_corresp:
  assumes dimA[simp]: "dim_col A = Suc l" and dimpv[simp]: "dim_vec pv = dim_row A"
      and j: "j < dim_col A"
  shows "pv + col (mk_poly_sub (map_mat coeff_lift A) l j) l =
    mk_poly2_col A pv (Suc j)"
proof(insert j, induct j)
  have le: "dim_row A \<le> dim_vec pv" using dimpv by simp
  have l: "l < dim_col A" using dimA by simp
  { case 0 show ?case
      apply (rule eq_vecI)
      using mk_poly2_row[OF le]
      by (auto simp add: monom_0)
  }
  { case (Suc j)
      hence j: "j < dim_col A" by simp
      show ?case
        unfolding mk_poly_sub.simps
        apply(subst col_addcol)
          apply simp
         apply simp
        apply(subst(2) comm_add_vec)
          apply(rule carrier_vecI, simp)
         apply(rule carrier_vecI, simp)
        apply(subst assoc_add_vec[symmetric])
           apply(rule carrier_vecI, rule refl)
          apply(rule carrier_vecI, simp)
         apply(rule carrier_vecI, simp)
        unfolding Suc(1)[OF j]
        apply(subst(2) mk_poly2_col.simps)
        apply(subst mk_poly2_row_col)
           apply simp
          apply simp
        using Suc apply simp
        apply(subst col_mk_poly_sub)
        using Suc apply simp
        using Suc apply simp
        apply(subst col_map_mat)
        using dimA apply simp
        unfolding foo dimA by simp
  }
qed

private lemma col_mk_poly_mk_poly2:
  fixes A :: "'a :: comm_semiring_1 mat"
  assumes dim: "dim_col A > 0"
  shows "col (mk_poly A) (dim_col A - 1) = mk_poly2 A"
proof -
  define l where "l = dim_col A - 1"
  have dim: "dim_col A = Suc l" unfolding l_def using dim by auto
  show ?thesis
    unfolding mk_poly_def mk_poly2_def dim
    apply(subst mk_poly_sub_corresp[symmetric])
      apply(rule dim)
      apply simp
      using dim apply simp
    apply(subst left_zero_vec)
      apply(rule carrier_vecI) using dim apply simp
    apply simp
    done
qed

private lemma mk_poly_mk_poly2:
  fixes A :: "'a :: comm_semiring_1 mat"
  assumes dim: "dim_col A > 0" and i: "i < dim_row A"
  shows "mk_poly A $$ (i,dim_col A - 1) = mk_poly2 A $ i"
proof -
  have "mk_poly A $$ (i,dim_col A - 1) = col (mk_poly A) (dim_col A - 1) $ i"
    apply (subst index_col(1)) using dim i by auto
  also note col_mk_poly_mk_poly2[OF dim]
  finally show ?thesis.
qed

lemma mk_poly_sylvester_upper:
  fixes p q :: "'a :: comm_ring_1 poly"
  defines "m \<equiv> degree p" and "n \<equiv> degree q"
  assumes i: "i < n"
  shows "mk_poly (sylvester_mat p q) $$ (i, m + n - 1) = monom 1 (n - Suc i) * p" (is "?l = ?r")
proof -
  let ?S = "sylvester_mat p q"
  have c: "m+n = dim_col ?S" and r: "m+n = dim_row ?S" unfolding m_def n_def by auto
  hence "dim_col ?S > 0" "i < dim_row ?S" using i by auto
  from mk_poly_mk_poly2[OF this]
  have "?l = mk_poly2 (sylvester_mat p q) $ i" unfolding m_def n_def by auto
  also have "... = ?r"
    apply(subst mk_poly2_sylvester_upper)
      using i unfolding n_def m_def by auto
  finally show ?thesis.
qed

lemma mk_poly_sylvester_lower:
  fixes p q :: "'a :: comm_ring_1 poly"
  defines "m \<equiv> degree p" and "n \<equiv> degree q"
  assumes ni: "n \<le> i" and imn: "i < m+n"
  shows "mk_poly (sylvester_mat p q) $$ (i, m + n - 1) = monom 1 (m + n - Suc i) * q" (is "?l = ?r")
proof -
  let ?S = "sylvester_mat p q"
  have c: "m+n = dim_col ?S" and r: "m+n = dim_row ?S" unfolding m_def n_def by auto
  hence "dim_col ?S > 0" "i < dim_row ?S" using imn by auto
  from mk_poly_mk_poly2[OF this]
  have "?l = mk_poly2 (sylvester_mat p q) $ i" unfolding m_def n_def by auto
  also have "... = ?r"
    apply(subst mk_poly2_sylvester_lower)
      using ni imn unfolding n_def m_def by auto
  finally show ?thesis.
qed

text \<open>The next lemma corresponds to Lemma 7.2.1.\<close>
lemma resultant_as_poly:
  fixes p q :: "'a :: comm_ring_1 poly"
  assumes degp: "degree p > 0" and degq: "degree q > 0"
  shows "\<exists>p' q'. degree p' < degree q \<and> degree q' < degree p \<and>
         [: resultant p q :] = p' * p + q' * q"
proof (intro exI conjI)
  define m where "m = degree p"
  define n where "n = degree q"
  define d where "d = dim_row (mk_poly (sylvester_mat p q))"
  define c where "c = (\<lambda>i. coeff_lift (cofactor (sylvester_mat p q) i (m+n-1)))"
  define p' where "p' = (\<Sum>i<n. monom 1 (n - Suc i) * c i)"
  define q' where "q' = (\<Sum>i<m. monom 1 (m - Suc i) * c (n+i))"

  have degc: "\<And>i. degree (c i) = 0" unfolding c_def by auto

  have dmn: "d = m+n" and mnd: "m + n = d" unfolding d_def m_def n_def by auto
  have "[: resultant p q :] =
    (\<Sum>i<d. mk_poly (sylvester_mat p q) $$ (i,m+n-1) *
        cofactor (mk_poly (sylvester_mat p q)) i (m+n-1))"
    unfolding resultant_def
    unfolding det_mk_poly[symmetric]
    unfolding m_def n_def d_def
    apply(rule laplace_expansion_column[of _ _ "degree p + degree q - 1"])
     apply(rule carrier_matI) using degp by auto
  also { fix i assume i: "i<d"
    have d2: "d = dim_row (sylvester_mat p q)" unfolding d_def by auto
    have "cofactor (mk_poly (sylvester_mat p q)) i (m+n-1) =
      (- 1) ^ (i + (m+n-1)) * det (mat_delete (mk_poly (sylvester_mat p q)) i (m+n-1))"
      using cofactor_def.
    also have "... =
      (- 1) ^ (i+m+n-1) * coeff_lift (det (mat_delete (sylvester_mat p q) i (m+n-1)))"
      using mk_poly_delete[OF i[unfolded d2]] degp degq
      unfolding m_def n_def by (auto simp add: add.assoc)
    also have "i+m+n-1 = i+(m+n-1)" using i[folded mnd] by auto
    finally have "cofactor (mk_poly (sylvester_mat p q)) i (m+n-1) = c i"
      unfolding c_def cofactor_def hom_distribs by simp
  }
  hence "... = (\<Sum>i<d. mk_poly (sylvester_mat p q) $$ (i, m+n-1) * c i)"
    (is "_ = sum ?f _") by auto
  also have "... = sum ?f ({..<n} \<union> {n ..<d})" unfolding dmn apply(subst ivl_disj_un(8)) by auto
  also have "... = sum ?f {..<n} + sum ?f {n..<d}" apply(subst sum.union_disjoint) by auto
  also { fix i assume i: "i < n"
    have "?f i = monom 1 (n - Suc i) * c i * p"
      unfolding m_def n_def
      apply(subst mk_poly_sylvester_upper)
      using i unfolding n_def by auto
  }
  hence "sum ?f {..<n} = p' * p" unfolding p'_def sum_distrib_right by auto
  also { fix i assume i: "i \<in> {n..<d}"
    have "?f i = monom 1 (m + n - Suc i) * c i * q"
      unfolding m_def n_def
      apply(subst mk_poly_sylvester_lower)
      using i unfolding dmn n_def m_def by auto
  }
  hence "sum ?f {n..<d} = (\<Sum>i=n..<d. monom 1 (m + n - Suc i) * c i) * q"
    (is "_ = sum ?h _ * _") unfolding sum_distrib_right by auto
  also have "{n..<d} = (\<lambda>i. i+n) ` {0..<m}"
    by (simp add: dmn)
  also have "sum ?h ... = sum (?h \<circ> (\<lambda>i. i+n)) {0..<m}"
    apply(subst sum.reindex[symmetric])
     apply (rule inj_onI) by auto
  also have "... = q'" unfolding q'_def apply(rule sum.cong) by (auto simp add: add.commute)
  finally show main: "[:resultant p q:] = p' * p + q' * q".
  show "degree p' < n"
    unfolding p'_def
    apply(rule degree_sum_smaller)
    using degq[folded n_def] apply force+
  proof -
    fix i assume i: "i \<in> {..<n}"
    show "degree (monom 1 (n - Suc i) * c i) < n"
      apply (rule order.strict_trans1)
       apply (rule degree_mult_le)
      unfolding add.right_neutral degc
      apply (rule order.strict_trans1)
       apply (rule degree_monom_le) using i by auto
  qed
  show "degree q' < m"
    unfolding q'_def
    apply (rule degree_sum_smaller)
    using degp[folded m_def] apply force+
  proof -
    fix i assume i: "i \<in> {..<m}"
    show "degree (monom 1 (m-Suc i) * c (n+i)) < m"
      apply (rule order.strict_trans1)
       apply (rule degree_mult_le)
      unfolding add.right_neutral degc
      apply (rule order.strict_trans1)
       apply (rule degree_monom_le) using i by auto
  qed
qed

end

subsubsection \<open>Resultant as Nonzero Polynomial Expression\<close>

lemma resultant_zero:
  fixes p q :: "'a :: comm_ring_1 poly"
  assumes deg: "degree p > 0 \<or> degree q > 0"
      and xp: "poly p x = 0" and xq: "poly q x = 0"
  shows "resultant p q = 0"
proof -
  { assume degp: "degree p > 0" and degq: "degree q > 0"
    obtain p' q' where "[: resultant p q :] = p' * p + q' * q"
      using resultant_as_poly[OF degp degq] by force
    hence "resultant p q = poly (p' * p + q' * q) x"
      using mpoly_base_conv(2)[of "resultant p q"] by auto
    also have "... = poly p x * poly p' x + poly q x * poly q' x"
      unfolding poly2_def by simp
    finally have ?thesis using xp xq by simp
  } moreover
  { assume degp: "degree p = 0"
    have p: "p = [:0:]" using xp degree_0_id[OF degp,symmetric] by (metis mpoly_base_conv(2))
    have ?thesis unfolding p using degp deg by simp
  } moreover
  { assume degq: "degree q = 0"
    have q: "q = [:0:]" using xq degree_0_id[OF degq,symmetric] by (metis mpoly_base_conv(2))
    have ?thesis unfolding q using degq deg by simp
  }
  ultimately show ?thesis by auto
qed

lemma poly_resultant_zero:
  fixes p q :: "'a :: comm_ring_1 poly poly"
  assumes deg: "degree p > 0 \<or> degree q > 0"
  assumes p0: "poly2 p x y = 0" and q0: "poly2 q x y = 0"
  shows "poly (resultant p q) x = 0"
proof -
  { assume "degree p > 0" "degree q > 0"
    from resultant_as_poly[OF this]
    obtain p' q' where "[: resultant p q :] = p' * p + q' * q" by force
    hence "resultant p q = poly (p' * p + q' * q) [:y:]"
      using mpoly_base_conv(2)[of "resultant p q"] by auto
    also have "poly ... x = poly2 p x y * poly2 p' x y + poly2 q x y * poly2 q' x y"
      unfolding poly2_def by simp
    finally have ?thesis unfolding p0 q0 by simp
  } moreover {
    assume degp: "degree p = 0"
    hence p: "p = [: coeff p 0 :]" by(subst degree_0_id[OF degp,symmetric],simp)
    hence "resultant p q = coeff p 0 ^ degree q" using resultant_const(1) by metis
    also have "poly ... x = poly (coeff p 0) x ^ degree q" by auto
    also have "... = poly2 p x y ^ degree q" unfolding poly2_def by(subst p, auto)
    finally have ?thesis unfolding p0 using deg degp zero_power by auto
  } moreover {
    assume degq: "degree q = 0"
    hence q: "q = [: coeff q 0 :]" by(subst degree_0_id[OF degq,symmetric],simp)
    hence "resultant p q = coeff q 0 ^ degree p" using resultant_const(2) by metis
    also have "poly ... x = poly (coeff q 0) x ^ degree p" by auto
    also have "... = poly2 q x y ^ degree p" unfolding poly2_def by(subst q, auto)
    finally have ?thesis unfolding q0 using deg degq zero_power by auto
  }
  ultimately show ?thesis by auto
qed

lemma resultant_as_nonzero_poly_weak:
  fixes p q :: "'a :: idom poly"
  assumes degp: "degree p > 0" and degq: "degree q > 0"
      and r0: "resultant p q \<noteq> 0"
  shows "\<exists>p' q'. degree p' < degree q \<and> degree q' < degree p \<and>
         [: resultant p q :] = p' * p + q' * q \<and> p' \<noteq> 0 \<and> q' \<noteq> 0"
proof -
  obtain p' q'
    where deg: "degree p' < degree q" "degree q' < degree p"
      and main: "[: resultant p q :] = p' * p + q' * q"
      using resultant_as_poly[OF degp degq] by auto
  have p0: "p \<noteq> 0" using degp by auto
  have q0: "q \<noteq> 0" using degq by auto
  show ?thesis
  proof (intro exI conjI notI)
    assume "p' = 0"
    hence "[: resultant p q :] = q' * q" using main by auto
    also hence d0: "0 = degree (q' * q)" by (metis degree_pCons_0)
      { assume "q' \<noteq> 0"
        hence "degree (q' * q) = degree q' + degree q"
          apply(rule degree_mult_eq) using q0 by auto
        hence False using d0 degq by auto
      } hence "q' = 0" by auto
    finally show False using r0 by auto
  next
    assume "q' = 0"
    hence "[: resultant p q :] = p' * p" using main by auto
    also
      hence d0: "0 = degree (p' * p)" by (metis degree_pCons_0)
      { assume "p' \<noteq> 0"
        hence "degree (p' * p) = degree p' + degree p"
          apply(rule degree_mult_eq) using p0 by auto
        hence False using d0 degp by auto
      } hence "p' = 0" by auto
    finally show False using r0 by auto
  qed fact+
qed

text \<open> Next lemma corresponds to Lemma 7.2.2 of the textbook \<close>

lemma resultant_as_nonzero_poly:
  fixes p q :: "'a :: idom poly"
  defines "m \<equiv> degree p" and "n \<equiv> degree q"
  assumes degp: "m > 0" and degq: "n > 0"
  shows "\<exists>p' q'. degree p' < n \<and> degree q' < m \<and>
         [: resultant p q :] = p' * p + q' * q \<and> p' \<noteq> 0 \<and> q' \<noteq> 0"
proof (cases "resultant p q = 0")
  case False
  thus ?thesis
    using resultant_as_nonzero_poly_weak degp degq
    unfolding m_def n_def by auto
next case True
  define S where "S = transpose_mat (sylvester_mat p q)"
  have S: "S \<in> carrier_mat (m+n) (m+n)" unfolding S_def m_def n_def by auto
  have "det S = 0" using True
    unfolding resultant_def S_def apply (subst det_transpose) by auto
  then obtain v
    where v: "v \<in> carrier_vec (m+n)" and v0: "v \<noteq> 0\<^sub>v (m+n)" and "S *\<^sub>v v = 0\<^sub>v (m+n)"
    using det_0_iff_vec_prod_zero[OF S] by auto
  hence "poly_of_vec (S *\<^sub>v v) = 0" by auto
  hence main: "poly_of_vec (vec_first v n) * p + poly_of_vec (vec_last v m) * q = 0"
    (is "?p * _ + ?q * _ = _")
    using sylvester_vec_poly[OF v[unfolded m_def n_def], folded m_def n_def S_def]
    by auto
  have split: "vec_first v n @\<^sub>v vec_last v m = v"
    using vec_first_last_append[simplified add.commute] v by auto
  show ?thesis
  proof(intro exI conjI)
    show "[: resultant p q :] = ?p * p + ?q * q" unfolding True using main by auto
    show "?p \<noteq> 0"
    proof
      assume p'0: "?p = 0"
      hence "?q * q = 0" using main by auto
      hence "?q = 0" using degq n_def by auto
      hence "vec_last v m = 0\<^sub>v m" unfolding poly_of_vec_0_iff by auto
      also have "vec_first v n @\<^sub>v ... = 0\<^sub>v (m+n)" using p'0 unfolding poly_of_vec_0_iff by auto
      finally have "v = 0\<^sub>v (m+n)" using split by auto
      thus False using v0 by auto
    qed
    show "?q \<noteq> 0"
    proof
      assume q'0: "?q = 0"
      hence "?p * p = 0" using main by auto
      hence "?p = 0" using degp m_def by auto
      hence "vec_first v n = 0\<^sub>v n" unfolding poly_of_vec_0_iff by auto
      also have "... @\<^sub>v vec_last v m = 0\<^sub>v (m+n)" using q'0 unfolding poly_of_vec_0_iff by auto
      finally have "v = 0\<^sub>v (m+n)" using split by auto
      thus False using v0 by auto
    qed
    show "degree ?p < n" using degree_poly_of_vec_less[of "vec_first v n"] using degq by auto
    show "degree ?q < m" using degree_poly_of_vec_less[of "vec_last v m"] using degp by auto
  qed
qed

text\<open>Corresponds to Lemma 7.2.3 of the textbook\<close>

lemma resultant_zero_imp_common_factor:
  fixes p q :: "'a :: ufd poly"
  assumes deg: "degree p > 0 \<or> degree q > 0" and r0: "resultant p q = 0"
  shows "\<not> coprime p q"
  unfolding neq0_conv[symmetric]
proof -
  { assume degp: "degree p > 0" and degq: "degree q > 0"
    assume cop: "coprime p q"
    obtain p' q' where "p' * p + q' * q = 0"
      and p': "degree p' < degree q" and q': "degree q' < degree p"
      and p'0: "p' \<noteq> 0" and q'0: "q' \<noteq> 0"
      using resultant_as_nonzero_poly[OF degp degq] r0 by auto
    hence "p' * p = - q' * q" by (simp add: eq_neg_iff_add_eq_0)

    from some_gcd.coprime_mult_cross_dvd[OF cop this]
    have "p dvd q'" by auto
    from dvd_imp_degree_le[OF this q'0]
    have "degree p \<le> degree q'" by auto
    hence False using q' by auto
  }
  moreover
  { assume degp: "degree p = 0"
    then obtain x where "p = [:x:]" by (elim degree_eq_zeroE)
    moreover hence "resultant p q = x ^ degree q" using resultant_const by auto
      hence "x = 0" using r0 by auto
    ultimately have "p = 0" by auto
    hence ?thesis unfolding not_coprime_iff_common_factor
      by (metis deg degp dvd_0_right dvd_refl less_numeral_extra(3) poly_dvd_1)
  }
  moreover
  { assume degq: "degree q = 0"
    then obtain x where "q = [:x:]" by (elim degree_eq_zeroE)
    moreover hence "resultant p q = x ^ degree p" using resultant_const by auto
      hence "x = 0" using r0 by auto
    ultimately have "q = 0" by auto
    hence ?thesis unfolding not_coprime_iff_common_factor
      by (metis deg degq dvd_0_right dvd_refl less_numeral_extra(3) poly_dvd_1)
  }
  ultimately show ?thesis by auto
qed

lemma resultant_non_zero_imp_coprime:
  assumes nz: "resultant (f :: 'a :: field poly) g \<noteq> 0"
  and nz': "f \<noteq> 0 \<or> g \<noteq> 0"
shows "coprime f g"
proof (cases "degree f = 0 \<or> degree g = 0")
  case False
  define r where "r = [:resultant f g:]"
  from nz have r: "r \<noteq> 0" unfolding r_def by auto
  from False have "degree f > 0" "degree g > 0" by auto
  from resultant_as_nonzero_poly_weak[OF this nz]
  obtain p q where "degree p < degree g" "degree q < degree f"
    and id: "r = p * f + q * g"
    and "p \<noteq> 0" "q \<noteq> 0" unfolding r_def by auto
  define h where "h = some_gcd f g"
  have "h dvd f" "h dvd g" unfolding h_def by auto
  then obtain j k where f: "f = h * j" and g: "g = h * k" unfolding dvd_def by auto
  from id[unfolded f g] have id: "h * (p * j + q * k) = r" by (auto simp: field_simps)
  from arg_cong[OF id, of degree] have "degree (h * (p * j + q * k)) = 0"
    unfolding r_def by auto
  also have "degree (h * (p * j + q * k)) = degree h + degree (p * j + q * k)"
    by (subst degree_mult_eq, insert id r, auto)
  finally have h: "degree h = 0" "h \<noteq> 0" using r id by auto
  thus ?thesis unfolding h_def using is_unit_iff_degree some_gcd.gcd_dvd_1 by blast
next
  case True
  thus ?thesis
  proof
    assume deg_g: "degree g = 0"
    show ?thesis
    proof (cases "g = 0")
      case False
      then show ?thesis using divides_degree[of _ g, unfolded deg_g]
        by (simp add: is_unit_right_imp_coprime)
    next
      case g: True
      then have "g = [:0:]" by auto
      from nz[unfolded this resultant_const] have "degree f = 0" by auto
      with nz' show ?thesis unfolding g by auto
    qed
  next
    assume deg_f: "degree f = 0"
    show ?thesis
    proof (cases "f = 0")
      case False
      then show ?thesis using divides_degree[of _ f, unfolded deg_f]
        by (simp add: is_unit_left_imp_coprime)
    next
      case f: True
      then have "f = [:0:]" by auto
      from nz[unfolded this resultant_const] have "degree g = 0" by auto
      with nz' show ?thesis unfolding f by auto
    qed
  qed
qed

end


(*  Title:      ZF/AC.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section\<open>The Axiom of Choice\<close>

theory AC imports ZF begin

text\<open>This definition comes from Halmos (1960), page 59.\<close>
axiomatization where
  AC: "[| a \<in> A;  !!x. x \<in> A ==> (\<exists>y. y \<in> B(x)) |] ==> \<exists>z. z \<in> Pi(A,B)"

(*The same as AC, but no premise @{term"a \<in> A"}*)
lemma AC_Pi: "[| !!x. x \<in> A ==> (\<exists>y. y \<in> B(x)) |] ==> \<exists>z. z \<in> Pi(A,B)"
apply (case_tac "A=0")
apply (simp add: Pi_empty1)
(*The non-trivial case*)
apply (blast intro: AC)
done

(*Using dtac, this has the advantage of DELETING the universal quantifier*)
lemma AC_ball_Pi: "\<forall>x \<in> A. \<exists>y. y \<in> B(x) ==> \<exists>y. y \<in> Pi(A,B)"
apply (rule AC_Pi)
apply (erule bspec, assumption)
done

lemma AC_Pi_Pow: "\<exists>f. f \<in> (\<Prod>X \<in> Pow(C)-{0}. X)"
apply (rule_tac B1 = "%x. x" in AC_Pi [THEN exE])
apply (erule_tac [2] exI, blast)
done

lemma AC_func:
     "[| !!x. x \<in> A ==> (\<exists>y. y \<in> x) |] ==> \<exists>f \<in> A->\<Union>(A). \<forall>x \<in> A. f`x \<in> x"
apply (rule_tac B1 = "%x. x" in AC_Pi [THEN exE])
prefer 2 apply (blast dest: apply_type intro: Pi_type, blast)
done

lemma non_empty_family: "[| 0 \<notin> A;  x \<in> A |] ==> \<exists>y. y \<in> x"
by (subgoal_tac "x \<noteq> 0", blast+)

lemma AC_func0: "0 \<notin> A ==> \<exists>f \<in> A->\<Union>(A). \<forall>x \<in> A. f`x \<in> x"
apply (rule AC_func)
apply (simp_all add: non_empty_family)
done

lemma AC_func_Pow: "\<exists>f \<in> (Pow(C)-{0}) -> C. \<forall>x \<in> Pow(C)-{0}. f`x \<in> x"
apply (rule AC_func0 [THEN bexE])
apply (rule_tac [2] bexI)
prefer 2 apply assumption
apply (erule_tac [2] fun_weaken_type, blast+)
done

lemma AC_Pi0: "0 \<notin> A ==> \<exists>f. f \<in> (\<Prod>x \<in> A. x)"
apply (rule AC_Pi)
apply (simp_all add: non_empty_family)
done

end


(******************************************************************************)
(* Submission: "The Interchange Law: A Principle of Concurrent Programming"   *)
(* Authors: Tony Hoare, Bernard Möller, Georg Struth, and Frank Zeyda         *)
(* File: Strict_Operators.thy                                                 *)
(******************************************************************************)
(* LAST REVIEWED: 11 July 2017 *)

section {* Strict Operators *}

theory Strict_Operators
imports Preliminaries Option_Monad ICL
begin

text \<open>All strict operators (on @{type option} types) carry a subscript \<open>_\<^sub>?\<close>.\<close>

subsection {* Equality *}

text \<open>We define a strong notion of equality between undefined values.\<close>

fun equals_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool" (infix "=\<^sub>?" 50) where
"Some x =\<^sub>? Some y \<longleftrightarrow> x = y" |
"Some x =\<^sub>? None \<longleftrightarrow> False" |
"None =\<^sub>? Some y \<longleftrightarrow> False" |
"None =\<^sub>? None \<longleftrightarrow> True"

text \<open>The above indeed coincides with HOL equality.\<close>

lemma equals_option_is_eq:
"(op =\<^sub>?) = (op =)"
apply (rule ext)+
apply (rename_tac x y)
apply (option_tac)
done

subsection {* Relational Operators *}

text \<open>We also define lifted versions of the default orders \<open>\<le>\<close> and \<open><\<close>.\<close>

fun leq_option :: "'a::ord option \<Rightarrow> 'a option \<Rightarrow> bool" (infix "\<le>\<^sub>?" 50) where
"Some x \<le>\<^sub>? Some y \<longleftrightarrow> x \<le> y" |
"Some x \<le>\<^sub>? None \<longleftrightarrow> False" |
"None \<le>\<^sub>? Some y \<longleftrightarrow> True" |
"None \<le>\<^sub>? None \<longleftrightarrow> True"

fun less_option :: "'a::ord option \<Rightarrow> 'a option \<Rightarrow> bool" (infix "<\<^sub>?" 50) where
"Some x <\<^sub>? Some y \<longleftrightarrow> x < y" |
"Some x <\<^sub>? None \<longleftrightarrow> False" |
"None <\<^sub>? Some y \<longleftrightarrow> True" |
"None <\<^sub>? None \<longleftrightarrow> False"

text \<open>Likewise, we can prove these correspond to HOL's default lifted order.\<close>

lemma leq_option_is_less_eq:
"(op \<le>\<^sub>?) = (op \<le>)"
apply (rule ext)+
apply (rename_tac x y)
apply (option_tac)
done

lemma less_option_is_less:
"(op <\<^sub>?) = (op <)"
apply (rule ext)+
apply (rename_tac x y)
apply (option_tac)
done

text \<open>Lastly, we lift subset inclusion into the @{type option} type.\<close>

text \<open>
  From Tony's note, it is not entirely clear to me how to define this operator
  It turns out that \<open>None \<subseteq>\<^sub>? Some y\<close> has to be @{const True} in order to prove
  the ICL example (10). Besides, may the result of \<open>x \<subseteq>\<^sub>? y\<close> be undefined too?
  Or do we always expected a simple @{type bool}ean value when applying lifted
  relational operators? Discuss this with Tony and Georg at a suitable moment.
\<close>

fun subset_option :: "'a set option \<Rightarrow> 'a set option \<Rightarrow> bool" (infix "\<subseteq>\<^sub>?" 50) where
"Some x \<subseteq>\<^sub>? Some y \<longleftrightarrow> x \<subseteq> y" |
"Some x \<subseteq>\<^sub>? None \<longleftrightarrow> (*True*) False" |
"None \<subseteq>\<^sub>? Some y \<longleftrightarrow> (*False*) True" |
"None \<subseteq>\<^sub>? None \<longleftrightarrow> True"

subsection {* Generic Lifting *}

text \<open>We use the constant below for ad hoc overloading to avoid ambiguities.\<close>

consts lift_option :: "'a \<Rightarrow> 'b" ("_\<up>\<^sub>?" [1000] 1000)

definition ulift_option ::
  "('a \<Rightarrow> 'b) \<Rightarrow> ('a option \<Rightarrow> 'b option)" where
"ulift_option f x = do {x' \<leftarrow> x; return (f x')}"

definition blift_option ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow>
   ('a option \<Rightarrow> 'b option \<Rightarrow> 'c option)" where
"blift_option f x y = do {x' \<leftarrow> x; y' \<leftarrow> y; return (f x' y')}"

adhoc_overloading lift_option ulift_option
adhoc_overloading lift_option blift_option

text \<open>Note that we do not add the above operators to @{attribute option_ops}.\<close>

lemma ulift_option_simps [simp]:
"ulift_option f \<bottom> = \<bottom>"
"ulift_option f (Some x) = Some (f x)"
apply (unfold ulift_option_def)
apply (simp_all)
done

lemma blift_option_simps [simp]:
"blift_option f x \<bottom> = \<bottom>"
"blift_option f \<bottom> y = \<bottom>"
"blift_option f (Some x') (Some y') = Some (f x' y')"
apply (unfold blift_option_def)
apply (simp_all)
done

subsection {* Lifted Operators *}

paragraph {* Addition and Subtraction *}

definition plus_option :: "'a::plus option binop" (infixl "+\<^sub>?" 70) where
"(op +\<^sub>?) = (op +)\<up>\<^sub>?"

definition minus_option :: "'a::minus option binop" (infixl "-\<^sub>?" 70) where
"(op -\<^sub>?) = (op -)\<up>\<^sub>?"

paragraph {* Multiplication and Division *}

definition times_option :: "'a::times option binop" (infixl "*\<^sub>?" 70) where
"(op *\<^sub>?) = (op *)\<up>\<^sub>?"

definition divide_option :: "'a::{divide, zero} option binop" (infixl "'/\<^sub>?" 70) where
"x /\<^sub>? y = do {x' \<leftarrow> x; y' \<leftarrow> y; if y' \<noteq> 0 then return (x' div y') else \<bottom>}"

paragraph {* Union and Disjoint Union *}

definition union_option :: "'a set option binop" (infixl "\<union>\<^sub>?" 70) where
"(op \<union>\<^sub>? ) = (op \<union>)\<up>\<^sub>?"

definition disjoint_union :: "'a set option binop" (infixl "\<oplus>\<^sub>?" 70) where
"x \<oplus>\<^sub>? y = do {x' \<leftarrow> x; y' \<leftarrow> y; if x' \<inter> y' = {} then return (x' \<union> y') else \<bottom>}"

paragraph {* Proof Support *}

declare plus_option_def [option_ops]
declare minus_option_def [option_ops]
declare times_option_def [option_ops]
declare divide_option_def [option_ops]
declare union_option_def [option_ops]
declare disjoint_union_def [option_ops]

subsection {* Supplementary Laws *}

lemma div_by_1_option [simp]:
fixes a :: "'a::semidom_divide option"
shows "a /\<^sub>? 1 = a"
apply (option_tac)
done

lemma mult_1_right_option [simp]:
fixes a :: "'a::monoid_mult option"
shows "a *\<^sub>? 1 = a"
apply (option_tac)
apply (induct_tac a; clarsimp)
done

subsection {* ICL Interpretations *}

interpretation preorder_equals_option:
  preorder "TYPE('a option)" "(op =\<^sub>?)"
apply (unfold_locales)
apply (option_tac)+
done

interpretation preorder_leq_option:
  preorder "TYPE('a::preorder option)" "(op \<le>\<^sub>?)"
apply (unfold_locales)
apply (option_tac)
apply (option_tac)
using order_trans apply (auto)
done

interpretation preorder_subset_option:
  preorder "TYPE('a set option)" "(op \<subseteq>\<^sub>?)"
apply (unfold_locales)
apply (option_tac)
apply (option_tac)
apply (auto)
done

text \<open>We make the above interpretation lemmas automatic simplifications.\<close>

declare preorder_equals_option.preorder_axioms [simp]
declare preorder_leq_option.preorder_axioms [simp]
declare preorder_subset_option.preorder_axioms [simp]

subsection {* ICL Lifting Lemmas *}

lemma iclaw_eq_lift_option [simp]:
"iclaw (op =) seq_op par_op \<Longrightarrow>
 iclaw (op =\<^sub>?) seq_op\<up>\<^sub>? par_op\<up>\<^sub>?"
apply (unfold iclaw_def iclaw_axioms_def)
apply (option_tac)
done

lemma preorder_leq_lift_option [simp]:
"preorder (op \<le>::'a::ord relop) \<Longrightarrow>
 preorder (op \<le>\<^sub>?::'a::ord option relop)"
apply (unfold_locales)
apply (option_tac)
apply (meson preorder.refl)
apply (option_tac)
apply (meson preorder.trans)
done

lemma iclaw_leq_lift_option [simp]:
"iclaw (op \<le>) seq_op par_op \<Longrightarrow>
 iclaw (op \<le>\<^sub>?) seq_op\<up>\<^sub>? par_op\<up>\<^sub>?"
apply (unfold iclaw_def iclaw_axioms_def)
apply (option_tac)
done
end


theory VDMTypes
imports VDMToolkit
begin

(*********************************************************************************)
section \<open>Constants\<close>

text \<open>MAX is a reserved word in Isabelle,
values
	MAX: nat1 = 10;
\<close>
abbreviation
  LMAX :: "VDMNat1"
where
  "LMAX \<equiv> 10"

definition
  inv_LMAX :: "\<bool>"
  where
  "inv_LMAX \<equiv> inv_VDMNat1 LMAX"

(*********************************************************************************)
section \<open>Numeric types\<close>

text \<open>Difference: VDM widens resulting type of expressions (e.g. x - y, result as int or nat).\<close>

text \<open>MyType = nat1 inv n == n <= LMAX"\<close>

type_synonym MyType = VDMNat1

definition
  inv_MyType :: "VDMNat1 \<Rightarrow> \<bool>"
  where
  "inv_MyType n \<equiv>
    inv_VDMNat1 n
  \<and> n \<le> LMAX"

text \<open>VDM ranges {1,...,10} can be represented as below. Isabelle also has open/closed ranges\<close>
value "{1..(10::nat)}"
value "{1..<(10::nat)}"
value "{1<..<(10::nat)}"

value "inv_MyType 0"
value "inv_MyType 5"
value "inv_MyType 10"

(*********************************************************************************)
section \<open>Set types\<close>

text \<open>Difference: VDM sets are always finite, and invariant of set type is checked for every element. \<close>

text \<open>MySet = set of MyType inv s == s <> {};\<close>

type_synonym MySet0 = "VDMNat1 VDMSet"

definition
  inv_MySet0 :: "VDMNat1 VDMSet \<Rightarrow> \<bool>"
  where
  "inv_MySet0 s \<equiv>
      inv_VDMSet s \<and>
      (\<forall> i . i \<in> s \<longrightarrow> i \<ge> 0 \<and> i \<le> LMAX) \<and>
      s \<noteq> {}"

definition
  inv_MySet0' :: "VDMNat1 VDMSet \<Rightarrow> \<bool>"
  where
  "inv_MySet0' s \<equiv>
      inv_VDMSet s \<and>
      (\<forall>  i \<in> s . i \<le> LMAX) \<and>
      s \<noteq> {}"

lemma "inv_MySet0' {1,2}"
  unfolding inv_MySet0'_def
  by simp

lemma "inv_MySet0' {0,1,2}"
  unfolding inv_MySet0'_def
  apply simp
  done

definition
  inv_MySet0'' :: "VDMNat1 VDMSet \<Rightarrow> \<bool>"
  where
  "inv_MySet0'' s \<equiv>
      inv_VDMSet s \<and>
      inv_SetElems inv_VDMNat1 s \<and>
      (\<forall>  i \<in> s . i \<le> LMAX) \<and>
      s \<noteq> {}"

lemma "inv_MySet0'' {0,1,2}"
  unfolding inv_MySet0''_def
  apply simp
  unfolding inv_VDMNat1_def
  apply simp
  oops

type_synonym MySet = "MyType VDMSet"

definition
  inv_MySet :: "MyType VDMSet \<Rightarrow> \<bool>"
  where
  "inv_MySet s \<equiv> inv_VDMSet s \<and>
                 inv_SetElems inv_MyType s \<and>
                 s \<noteq> {}"

value "inv_SetElems inv_MyType {1,2,3}"

(*value "inv_MySet {1,2,(3::MyType)}"*)

lemma "inv_MySet {1,2,3}"
  unfolding inv_MySet_def
  unfolding          inv_SetElems_def
          unfolding  inv_MyType_def
           unfolding inv_VDMNat1_def
           unfolding inv_VDMSet_def
  by simp

lemma "\<not> inv_MySet {1,2,20}"
  unfolding inv_MySet_def
            inv_SetElems_def
            inv_MyType_def
            inv_VDMNat1_def
            inv_VDMSet_def
  by simp

lemma "inv_MySet s"
  unfolding inv_MySet_def
            inv_SetElems_def
            inv_MyType_def
            inv_VDMNat1_def
            inv_VDMSet_def
  oops

definition
  inv_MySetExplicit :: "MyType VDMSet \<Rightarrow> \<bool>"
  where
  "inv_MySetExplicit s \<equiv>
                 finite s \<and>
                 (\<forall> e \<in> s . e > 0 \<and> e \<le> LMAX) \<and>
                 s \<noteq> {}"

lemma "inv_MySetExplicit s = inv_MySet s"
  unfolding  inv_MySetExplicit_def inv_MySet_def
inv_SetElems_def
            inv_MyType_def
            inv_VDMNat1_def
            inv_VDMSet_def
  apply auto
  done (* found typo "e \<ge> 0", fixed e > 0! Better not be explicit *)

text \<open>MySet1 = set1 of MyType\<close>

type_synonym MySet1 = "VDMNat1 VDMSet1"

definition
  inv_MySet1 :: "MyType VDMSet1 \<Rightarrow> \<bool>"
  where
  "inv_MySet1 s \<equiv> inv_VDMSet1 s \<and>
                  inv_SetElems inv_MyType s"

lemma "inv_MySet1 s = inv_MySet s"
  unfolding  inv_MySet1_def inv_MySet_def
inv_SetElems_def
            inv_MyType_def
            inv_VDMNat1_def
            inv_VDMSet_def
            inv_VDMSet1_def
  by auto

(*********************************************************************************)
section \<open>Seq types\<close>

text \<open>Difference: VDM seqs are start from 1 not 0, and invariant of set type is checked for every element. \<close>

type_synonym MySeq0 = "VDMNat1 VDMSeq"

value "[1,2,3,4,(3::VDMNat1)]"
value "[1,2,3,4,(3::VDMNat1)] ! 0"
value "[1,2,3,4,(3::VDMNat1)] ! 1"
value "[1,2,3,4,(3::VDMNat1)] ! 2"
value "[1,2,3,4,(3::VDMNat1)] ! 3"
value "[1,2,3,4,(3::VDMNat1)] ! 4"

value "[1,2,3,4,(3::VDMNat1)] $ 1"
value "[1,2,3,4,(3::VDMNat1)] $ 2"
value "[1,2,3,4,(3::VDMNat1)] $ 3"
value "[1,2,3,4,(3::VDMNat1)] $ 4"
value "[1,2,3,4,(3::VDMNat1)] $ 5"

definition
  inv_MySeq0 :: "VDMNat1 VDMSeq \<Rightarrow> \<bool>"
  where
  "inv_MySeq0 s \<equiv> (\<forall> i \<in> inds s . s $ i \<le> LMAX) \<and>
                  (\<forall> e \<in> elems s . e \<le> LMAX) \<and>
                  vdm_card (elems s) = len s"

lemma "inv_MySeq0 [1,2,3]"
  unfolding inv_MySeq0_def
  apply simp
  apply safe
  by (smt (z3) One_nat_def atLeastAtMost_iff dbl_simps(3) dbl_simps(5) diff_Suc_Suc diff_nat_numeral diff_zero nat_numeral nth_Cons' one_eq_numeral_iff)

lemma "inv_MySeq0 [0,1,2,3]"
  unfolding inv_MySeq0_def
  apply simp
  apply safe
  by (smt (z3) One_nat_def add.left_neutral add_diff_cancel_left' atLeastAtMost_iff dbl_inc_simps(3) dbl_inc_simps(5) dbl_simps(3) dbl_simps(5) diff_is_0_eq nat_le_0 nat_numeral nth_Cons' numeral_3_eq_3 numeral_eq_one_iff one_add_one plus_nat.simps(2))

text\<open>MySeq = seq of MyType inv s == card elems s = len s;\<close>
type_synonym MySeq = "MyType VDMSeq"

definition
  inv_MySeq :: "MyType VDMSeq \<Rightarrow> \<bool>"
  where
  "inv_MySeq s \<equiv> inv_SeqElems inv_MyType s \<and>
                  vdm_card (elems s) = len s"

value "inv_MySeq [1, 2, 3]"

lemma "inv_MySeq [1,2,3]"
  unfolding inv_MySeq_def
  inv_SeqElems_def inv_MyType_def inv_VDMNat1_def elems_def len_def vdm_card_def inv_VDMSet_def
  by simp

lemma "\<not> inv_MySeq [1,1,3]"
  unfolding inv_MySeq_def
  inv_SeqElems_def inv_MyType_def inv_VDMNat1_def elems_def len_def vdm_card_def inv_VDMSet_def
  by simp

lemma "\<not> inv_MySeq [0,1,2,3]"
  unfolding inv_MySeq_def
  inv_SeqElems_def inv_MyType_def inv_VDMNat1_def elems_def len_def vdm_card_def inv_VDMSet_def
  by simp

type_synonym MySeqSeq0 = "MyType VDMSeq VDMSeq"

definition
  inv_MySeqSeq0 :: "MyType VDMSeq VDMSeq \<Rightarrow> \<bool>"
  where
  "inv_MySeqSeq0 ss \<equiv>
    inv_SeqElems (inv_SeqElems inv_MyType) ss"

term "inv_SeqElems inv_MyType"
term "inv_SeqElems (inv_SeqElems inv_MyType)"

type_synonym MySeqX = "MyType VDMSeq"

definition
  inv_MySeqX :: "MyType  VDMSeq \<Rightarrow> \<bool>"
  where
  "inv_MySeqX s \<equiv>
    inv_SeqElems inv_MyType s"

type_synonym MySeqSeq = "MyType VDMSeq VDMSeq"

definition
  inv_MySeqSeq :: "MyType VDMSeq VDMSeq \<Rightarrow> \<bool>"
  where
  "inv_MySeqSeq ss \<equiv>
    inv_SeqElems inv_MySeqX ss"

(*********************************************************************************)
section \<open>Enum types\<close>

text\<open>Enum = <E1> | <E2>; \<close>

datatype Enum = E1 | E2

find_theorems name:"VDMTypes.Enum"

text \<open>Even when no invariant exists, it's good idea to define it in case one arises later\<close>
definition
  inv_Enum :: "Enum \<Rightarrow> \<bool>"
  where
  "inv_Enum e \<equiv> True"

(*********************************************************************************)
section \<open>Map types\<close>

text \<open>Difference: VDM maps domain and range sets must be finite, and the invariant of these sets types is checked for every element. \<close>

text\<open>MyMap = map MyType to (nat1 * Enum) inv m == dom m subset {LMAX div 2,...,LMAX}<E1> | <E2>; \<close>

type_synonym MyMap = "MyType \<rightharpoonup> (VDMNat \<times> Enum) VDMSet"
typ MyMap

value "[ 5 \<mapsto> {(0, E1)} ]::MyMap"

text
\<open>Be very careful with div and mod. Their meaning is different in VDM and Isabelle when
 dealing with negative numbers. Have a look inside VDMToolkit for details/examples. If both
 left and right sides of div/mod are >= 0, then you are fine. Otherwise, you will have harder
 proofs to do. That means, make sure your invariants contain this if div/mod is used. In the case
 below, this is implicitly obvious given LMAX is 10 and both 10 and 2 are bigger than 0.\<close>

definition
  inv_MyMapRanElem :: "(MyType \<times> Enum) \<Rightarrow> \<bool>"
  where
  "inv_MyMapRanElem v \<equiv>
    let (n, e) = v in
      inv_MyType n \<and> inv_Enum e"

definition
  inv_MyMapRan0 :: "(MyType \<times> Enum) VDMSet \<Rightarrow> \<bool>"
  where
  "inv_MyMapRan0 s \<equiv>  inv_SetElems (\<lambda> (n,e) . inv_MyType n \<and> inv_Enum e) s"

definition
  inv_MyMapRan :: "(MyType \<times> Enum) VDMSet \<Rightarrow> \<bool>"
  where
  "inv_MyMapRan s \<equiv>  inv_SetElems inv_MyMapRanElem s"

definition
  inv_MyMap :: "MyMap \<Rightarrow> \<bool>"
where
  "inv_MyMap m \<equiv>
      inv_Map inv_MyType inv_MyMapRan m \<and>
      dom m \<subseteq> {LMAX vdmdiv 2 .. LMAX}"

lemma "inv_MyMap m"
  unfolding inv_MyMap_def
 unfolding     inv_Map_def
  unfolding inv_MyMapRan_def inv_MyMapRanElem_def
 unfolding     inv_MyType_def
  unfolding    inv_VDMNat1_def
 unfolding     inv_Enum_def
 unfolding     inv_SetElems_def
 unfolding     inv_VDMSet_def
  apply simp
  apply safe
  oops

type_synonym MyMapOld = "MyType \<rightharpoonup> Enum"

definition
  inv_MyMapOld :: "MyMapOld \<Rightarrow> \<bool>"
where
  "inv_MyMapOld m \<equiv>
      inv_Map inv_MyType inv_Enum m \<and>
      dom m \<subseteq> {LMAX vdmdiv 2 .. LMAX}"

text\<open>Map enumeration { 3 |-> <E1>, 2 |-> <E1>, 1 |-> <E2>, 4 |-> <E2> }\<close>

value
 "[ (3::MyType) |-> E1,
              2 \<mapsto> E1,
              1 \<mapsto> E2,
              4 \<mapsto> E2]
 "

value
 "dom
  [ (3::MyType) \<mapsto> E1,
              2 \<mapsto> E1,
              1 \<mapsto> E2,
              4 \<mapsto> E2]
 "

lemma
 "dom
  [ (3::MyType) \<mapsto> E1,
              2 \<mapsto> E1,
              1 \<mapsto> E2,
              4 \<mapsto> E2]
  = {1..4}
 "
  apply simp
  by auto

abbreviation
  mymap_test :: "MyType \<rightharpoonup> Enum"
  where
  "mymap_test \<equiv>
  [ (3::MyType) \<mapsto> E1,
              2 \<mapsto> E1,
              1 \<mapsto> E2,
              4 \<mapsto> E2]"
lemma
 "ran mymap_test = {E1, E2}"
  apply simp
  by auto

text\<open>Map applicaiton (the operator) + values outside domain\<close>

value "mymap_test 1"
value "mymap_test 2"
value "mymap_test 3"
value "mymap_test 4"
value "mymap_test 5"
value "mymap_test 565454235"
value "mymap_test 10"

value "mymap_test 1 = E2"
value "mymap_test 1 = Some E2"
value "the (mymap_test 1) = E2"
value "the (mymap_test 3) = E1"
value "the (mymap_test 5)"
value "mymap_test 5 = None"
value "5 \<notin> dom mymap_test"

text \<open>Map update\<close>

value "mymap_test(3 \<mapsto> E2) 3"
value "(mymap_test(3 \<mapsto> E2)) 3 = Some E2"
value "the((mymap_test(3 \<mapsto> E2)) 3) = E2"

lemma "dom Map.empty = {}" by simp

(*********************************************************************************)
section \<open>Record types\<close>

text\<open>
  MyRec ::
		x: MyType
		s: MySet
		l: MySeq
		m: MyMap
	inv mk_MyRec(x,s,l,m) ==
		x in set dom m inter elems l inter s
		and
		x in set dom m and x in set elems l and x in set s;
\<close>

text \<open>Record fields declare projection functions from record to field type\<close>
record MyRec =
  xfield :: MyType
  sfield :: MySet
  lfield :: MySeq
  mfield :: MyMap
print_theorems

term xfield
term sfield
term lfield

record Wheel =
  outer_field :: VDMNat
 (* @LF: how do I work out this one?!*)
  inner_field :: "VDMNat option"

lemma "inner_field W \<noteq> None \<Longrightarrow> inv_VDMNat (the(inner_field W))"
(* mk_Wheel(10, nil)*)
value "\<lparr> outer_field = 10, inner_field = None\<rparr>"
lemma "(the (inner_field \<lparr> outer_field = 10, inner_field = None\<rparr>)) = A" apply simp
(* mk_Wheel(10, 20)*)
value "\<lparr> outer_field = 10, inner_field = Some 20\<rparr>"
value "inner_field \<lparr> outer_field = 10, inner_field = Some 20\<rparr>"
value "the (inner_field \<lparr> outer_field = 10, inner_field = Some 20\<rparr>)"

(* mk_MyRec(5, {5}, [5], { 5 \<mapsto> {(0, <E1>)} }) *)
value "(|xfield = 5, sfield = {5}, lfield = [5], mfield = [ 5 |-> {(0,E1)} ]|)"
value "\<lparr>xfield = 5, sfield = {5}, lfield = [5], mfield = [ 5 \<mapsto> {(0,E1)} ]\<rparr>"
(* R = mk_MyRec(5, {5}, [5], { 5 \<mapsto> {(0, <E1>)} }), R.xfield = 5;  (xfield R) *)
value "xfield \<lparr>xfield = 3, sfield = {3}, lfield = [3], mfield = Map.empty\<rparr> = 3"
value "lfield \<lparr>xfield = 3, sfield = {3}, lfield = [3], mfield = Map.empty\<rparr> = [3]"

text\<open>Have to check the type invariants of each field explicitly\<close>
definition
  inv_MyRec0 :: "MyRec \<Rightarrow> \<bool>"
  where
  "inv_MyRec0 r \<equiv> inv_MyType (xfield r) \<and>
                 inv_MySet (sfield r) \<and>
                 inv_MySeq (lfield r) \<and>
                 inv_MyMap (mfield r) \<and> True"

value "inv_MyRec0 \<lparr>xfield = 3, sfield = {3}, lfield = [3], mfield = Map.empty\<rparr>"

lemma "inv_MyRec0 \<lparr>xfield = 3, sfield = {3}, lfield = [3], mfield = Map.empty\<rparr>"
  unfolding inv_MyRec0_def
        inv_MyMap_def
        inv_MySeq_def
        inv_MySet_def
        inv_SeqElems_def
        inv_SetElems_def
        inv_Map_def
        inv_MyType_def
        inv_VDMSet_def
        inv_VDMNat1_def
  by simp

definition
  inv_MyRec :: "MyRec \<Rightarrow> \<bool>"
  where
  "inv_MyRec r \<equiv> (let x=(xfield r); s=(sfield r); l=(lfield r); m=(mfield r) in
                      inv_MyType x \<and>
                     inv_MySet s \<and>
                     inv_MySeq l \<and>
                     inv_MyMap m \<and>
                     x \<in> (dom m) \<inter> (elems l) \<inter> s
                     \<and>
                     x \<in> (dom m) \<and> x \<in> (elems l) \<and> x \<in> s)"

lemma "(let r=\<lparr>xfield = 3, sfield = {3}, lfield = [3], mfield = [3 \<mapsto> {(0,E1)}]\<rparr>;
            x=(xfield r); s=(sfield r); l=(lfield r); m=(mfield r) in x \<in> (dom m) \<inter> (elems l) \<inter> s)"
  by simp

lemma "inv_MyRec \<lparr>xfield = 3, sfield = {3}, lfield = [3], mfield = [3 \<mapsto> {(1,E1)}]\<rparr>"
  unfolding inv_MyRec_def Let_def
  apply (simp,safe)
  unfolding inv_MyType_def inv_VDMNat1_def
     apply simp
  unfolding inv_MySet_def inv_VDMSet_def
    apply (simp add: inv_MyType_def inv_VDMNat1_def)
  unfolding inv_MySeq_def vdm_card_def elems_def inv_VDMSet_def
   apply simp
  apply (simp add: inv_MyType_def inv_VDMNat1_def l_inv_SeqElems_Cons)
  unfolding        inv_MyMap_def
  unfolding inv_MyMapRan_def inv_MyMapRanElem_def
  apply safe
   apply (simp add: inv_Enum_def inv_Map_def inv_MyType_def inv_VDMNat1_def)
  apply simp
  oops

lemma "inv_MyRec \<lparr>xfield = 5, sfield = {5}, lfield = [5], mfield = [5 \<mapsto> {(1,E1)}]\<rparr>"
  unfolding inv_MyRec_def
        inv_MyMap_def
        inv_MySeq_def
        inv_MySet_def
        inv_SeqElems_def
        inv_SetElems_def
        inv_MyType_def
        inv_VDMSet_def
        inv_VDMNat1_def
        inv_Enum_def
        inv_Map_def
        Let_def
        inv_MyMapRan_def
        inv_MyMapRanElem_def
  by simp_all

lemma "inv_MyRec r"
  unfolding inv_MyRec_def Let_def
 unfolding       inv_MyMap_def
        inv_MyMapRan_def
        inv_MyMapRanElem_def
        inv_Map_def
 unfolding       inv_MySeq_def
  unfolding       inv_MySet_def
 unfolding       inv_SeqElems_def
 unfolding       inv_SetElems_def
 unfolding      inv_MyType_def
 unfolding       inv_VDMSet_def
  unfolding      inv_VDMNat1_def
  unfolding inv_Enum_def
  apply simp
  oops

(*********************************************************************************)
section \<open>Union types\<close>

text\<open>MyUnion = MyRec | MyMap; \<close>

datatype MyUnion = R MyRec | M MyMap

definition
  inv_MyUnion :: "MyUnion \<Rightarrow> \<bool>"
  where
  "inv_MyUnion u \<equiv>
    case u of
      R r \<Rightarrow> inv_MyRec r
    | M m \<Rightarrow> inv_MyMap m"

(*****************************************************************)
section \<open> Some useful examples of various expressions \<close>

subsection \<open> Set translations: enumeration, comprehension, ranges \<close>

text \<open>Set comprehension\<close>

(* { expr | var . filter }, { var \<in> type . filter }, { var . filter } *)

value "{ x+x | x . x \<in> {(1::nat),2,3,4,5,6} }"
value "{ x+x | x . x \<in> {(1::nat),2,3} }"
value "{ x+x | x . x \<in> {(1::nat)..3} }" (* "not always work"*)
value "{ x*x | x . x \<in> {(1::int),2,3,5} }"

value "{0..(2::int)}"
value "{0..<(3::int)}"
value "{0<..<(3::int)}"

subsection \<open> Seq translations: enumeration, comprehension, ranges \<close>

(* List application (i.e. s(x)) is available in Isabelle, but is zero based *)
value "[A, B, C] ! 0"
value "[A, B, C] ! 1"
value "[A, B, C] ! 2"
value "[A, B, C] ! 3"
value "nth [A, B, C] 0"

value "applyVDMSeq [A, B] 0" \<comment> \<open>out of range\<close>
value "applyVDMSeq [A, B] 1"
value "applyVDMSeq [A, B] 2"
value "applyVDMSeq [A, B] 3" \<comment> \<open>out of range\<close>

value "[A,B,C,D] $ 0"
value "[A,B,C,D] $ 1"
value "[A,B,C,D] $ 2"
value "[A,B,C,D] $ 3"
value "[A,B,C,D] $ 4"
value "[A,B,C,D] $ 5"

text \<open>Seq comprehension\<close>

value "{ [A,B,C] ! i | i . i \<in> {0,1,2} }"
value "{ [A,B,C,D,E,F] ! i | i . i \<in> {0,2,4} }"
(* { s(i) | i in set inds s & i mod 2 = 0 } *)

value "{ [A,B,C] ! i | i . i \<in> {0,1,2} }"
value "[ x . x \<leftarrow> [0,1,(2::int)]]" (*avoid if possible... *)
value "[ x . x \<leftarrow> [0 .. 3] ]"

value "len [A, B, C]"
value "elems [A, B, C, A, B]"
value "elems [(0::nat), 1, 2]"
value "inds [A,B,C]"
value "inds_as_nat [A,B,C]"
value "card (elems [10, 20, 30, 1, 2, 3, 4, (5::nat), 10])"
value "len [10, 20, 30, 1, 2, 3, 4, (5::nat), 10]"

text \<open>Map comprehension (almost)\<close>

text \<open> Enumeration through sequences (or sequence comprehension) \<close>
value "[ [(3::nat),4,5] [\<mapsto>] [(4::nat),5,6,7] ] = [3 \<mapsto> 4, 4 \<mapsto> 5, 5 \<mapsto> 6]"

lemma "[ [(3::nat),4,5] [\<mapsto>] [(4::nat),5,6,7] ] = [3 \<mapsto> 4, 4 \<mapsto> 5, 5 \<mapsto> 6]"
  by simp

lemma "[ [(3::nat),4,5] [\<mapsto>] [(4::nat)] ] = [3 \<mapsto> 4]"
  by simp

lemma "[ [(3::nat),3,5] [\<mapsto>] [(4::nat),5,6,7] ] = [3 \<mapsto> 5, 5 \<mapsto> 6]"
  by simp

lemma "[[ x . x \<leftarrow> [0,1,(2::nat)] ] [\<mapsto>] [y . y \<leftarrow> [3,4,(5::nat)]] ] = [0 \<mapsto> 3, 1 \<mapsto> 4, 2 \<mapsto> 5]"
  by simp

end


(*  Title:      ZF/Induct/Primrec.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Primitive Recursive Functions: the inductive definition\<close>

theory Primrec imports ZF begin

text \<open>
  Proof adopted from @{cite szasz93}.

  See also @{cite \<open>page 250, exercise 11\<close> mendelson}.
\<close>

subsection \<open>Basic definitions\<close>

definition
  SC :: "i"  where
  "SC \<equiv> \<lambda>l \<in> list(nat). list_case(0, \<lambda>x xs. succ(x), l)"

definition
  CONSTANT :: "i\<Rightarrow>i"  where
  "CONSTANT(k) \<equiv> \<lambda>l \<in> list(nat). k"

definition
  PROJ :: "i\<Rightarrow>i"  where
  "PROJ(i) \<equiv> \<lambda>l \<in> list(nat). list_case(0, \<lambda>x xs. x, drop(i,l))"

definition
  COMP :: "[i,i]\<Rightarrow>i"  where
  "COMP(g,fs) \<equiv> \<lambda>l \<in> list(nat). g ` map(\<lambda>f. f`l, fs)"

definition
  PREC :: "[i,i]\<Rightarrow>i"  where
  "PREC(f,g) \<equiv>
     \<lambda>l \<in> list(nat). list_case(0,
                      \<lambda>x xs. rec(x, f`xs, \<lambda>y r. g ` Cons(r, Cons(y, xs))), l)"
  \<comment> \<open>Note that \<open>g\<close> is applied first to \<^term>\<open>PREC(f,g)`y\<close> and then to \<open>y\<close>!\<close>

consts
  ACK :: "i\<Rightarrow>i"
primrec
  "ACK(0) = SC"
  "ACK(succ(i)) = PREC (CONSTANT (ACK(i) ` [1]), COMP(ACK(i), [PROJ(0)]))"

abbreviation
  ack :: "[i,i]\<Rightarrow>i" where
  "ack(x,y) \<equiv> ACK(x) ` [y]"

text \<open>
  \medskip Useful special cases of evaluation.
\<close>

lemma SC: "\<lbrakk>x \<in> nat;  l \<in> list(nat)\<rbrakk> \<Longrightarrow> SC ` (Cons(x,l)) = succ(x)"
  by (simp add: SC_def)

lemma CONSTANT: "l \<in> list(nat) \<Longrightarrow> CONSTANT(k) ` l = k"
  by (simp add: CONSTANT_def)

lemma PROJ_0: "\<lbrakk>x \<in> nat;  l \<in> list(nat)\<rbrakk> \<Longrightarrow> PROJ(0) ` (Cons(x,l)) = x"
  by (simp add: PROJ_def)

lemma COMP_1: "l \<in> list(nat) \<Longrightarrow> COMP(g,[f]) ` l = g` [f`l]"
  by (simp add: COMP_def)

lemma PREC_0: "l \<in> list(nat) \<Longrightarrow> PREC(f,g) ` (Cons(0,l)) = f`l"
  by (simp add: PREC_def)

lemma PREC_succ:
  "\<lbrakk>x \<in> nat;  l \<in> list(nat)\<rbrakk>
    \<Longrightarrow> PREC(f,g) ` (Cons(succ(x),l)) =
      g ` Cons(PREC(f,g)`(Cons(x,l)), Cons(x,l))"
  by (simp add: PREC_def)

subsection \<open>Inductive definition of the PR functions\<close>

consts
  prim_rec :: i

inductive
  domains prim_rec \<subseteq> "list(nat)->nat"
  intros
    "SC \<in> prim_rec"
    "k \<in> nat \<Longrightarrow> CONSTANT(k) \<in> prim_rec"
    "i \<in> nat \<Longrightarrow> PROJ(i) \<in> prim_rec"
    "\<lbrakk>g \<in> prim_rec; fs\<in>list(prim_rec)\<rbrakk> \<Longrightarrow> COMP(g,fs) \<in> prim_rec"
    "\<lbrakk>f \<in> prim_rec; g \<in> prim_rec\<rbrakk> \<Longrightarrow> PREC(f,g) \<in> prim_rec"
  monos list_mono
  con_defs SC_def CONSTANT_def PROJ_def COMP_def PREC_def
  type_intros nat_typechecks list.intros
    lam_type list_case_type drop_type map_type
    apply_type rec_type

lemma prim_rec_into_fun [TC]: "c \<in> prim_rec \<Longrightarrow> c \<in> list(nat) -> nat"
  by (erule subsetD [OF prim_rec.dom_subset])

lemmas [TC] = apply_type [OF prim_rec_into_fun]

declare prim_rec.intros [TC]
declare nat_into_Ord [TC]
declare rec_type [TC]

lemma ACK_in_prim_rec [TC]: "i \<in> nat \<Longrightarrow> ACK(i) \<in> prim_rec"
  by (induct set: nat) simp_all

lemma ack_type [TC]: "\<lbrakk>i \<in> nat;  j \<in> nat\<rbrakk> \<Longrightarrow>  ack(i,j) \<in> nat"
  by auto

subsection \<open>Ackermann's function cases\<close>

lemma ack_0: "j \<in> nat \<Longrightarrow> ack(0,j) = succ(j)"
  \<comment> \<open>PROPERTY A 1\<close>
  by (simp add: SC)

lemma ack_succ_0: "ack(succ(i), 0) = ack(i,1)"
  \<comment> \<open>PROPERTY A 2\<close>
  by (simp add: CONSTANT PREC_0)

lemma ack_succ_succ:
  "\<lbrakk>i\<in>nat;  j\<in>nat\<rbrakk> \<Longrightarrow> ack(succ(i), succ(j)) = ack(i, ack(succ(i), j))"
  \<comment> \<open>PROPERTY A 3\<close>
  by (simp add: CONSTANT PREC_succ COMP_1 PROJ_0)

lemmas [simp] = ack_0 ack_succ_0 ack_succ_succ ack_type
  and [simp del] = ACK.simps

lemma lt_ack2: "i \<in> nat \<Longrightarrow> j \<in> nat \<Longrightarrow> j < ack(i,j)"
  \<comment> \<open>PROPERTY A 4\<close>
  apply (induct i arbitrary: j set: nat)
   apply simp
  apply (induct_tac j)
   apply (erule_tac [2] succ_leI [THEN lt_trans1])
   apply (rule nat_0I [THEN nat_0_le, THEN lt_trans])
   apply auto
  done

lemma ack_lt_ack_succ2: "\<lbrakk>i\<in>nat; j\<in>nat\<rbrakk> \<Longrightarrow> ack(i,j) < ack(i, succ(j))"
  \<comment> \<open>PROPERTY A 5-, the single-step lemma\<close>
  by (induct set: nat) (simp_all add: lt_ack2)

lemma ack_lt_mono2: "\<lbrakk>j<k; i \<in> nat; k \<in> nat\<rbrakk> \<Longrightarrow> ack(i,j) < ack(i,k)"
  \<comment> \<open>PROPERTY A 5, monotonicity for \<open><\<close>\<close>
  apply (frule lt_nat_in_nat, assumption)
  apply (erule succ_lt_induct)
    apply assumption
   apply (rule_tac [2] lt_trans)
    apply (auto intro: ack_lt_ack_succ2)
  done

lemma ack_le_mono2: "\<lbrakk>j\<le>k;  i\<in>nat;  k\<in>nat\<rbrakk> \<Longrightarrow> ack(i,j) \<le> ack(i,k)"
  \<comment> \<open>PROPERTY A 5', monotonicity for \<open>\<le>\<close>\<close>
  apply (rule_tac f = "\<lambda>j. ack (i,j) " in Ord_lt_mono_imp_le_mono)
     apply (assumption | rule ack_lt_mono2 ack_type [THEN nat_into_Ord])+
  done

lemma ack2_le_ack1:
  "\<lbrakk>i\<in>nat;  j\<in>nat\<rbrakk> \<Longrightarrow> ack(i, succ(j)) \<le> ack(succ(i), j)"
  \<comment> \<open>PROPERTY A 6\<close>
  apply (induct_tac j)
   apply simp_all
  apply (rule ack_le_mono2)
    apply (rule lt_ack2 [THEN succ_leI, THEN le_trans])
      apply auto
  done

lemma ack_lt_ack_succ1: "\<lbrakk>i \<in> nat; j \<in> nat\<rbrakk> \<Longrightarrow> ack(i,j) < ack(succ(i),j)"
  \<comment> \<open>PROPERTY A 7-, the single-step lemma\<close>
  apply (rule ack_lt_mono2 [THEN lt_trans2])
     apply (rule_tac [4] ack2_le_ack1)
      apply auto
  done

lemma ack_lt_mono1: "\<lbrakk>i<j; j \<in> nat; k \<in> nat\<rbrakk> \<Longrightarrow> ack(i,k) < ack(j,k)"
  \<comment> \<open>PROPERTY A 7, monotonicity for \<open><\<close>\<close>
  apply (frule lt_nat_in_nat, assumption)
  apply (erule succ_lt_induct)
    apply assumption
   apply (rule_tac [2] lt_trans)
    apply (auto intro: ack_lt_ack_succ1)
  done

lemma ack_le_mono1: "\<lbrakk>i\<le>j; j \<in> nat; k \<in> nat\<rbrakk> \<Longrightarrow> ack(i,k) \<le> ack(j,k)"
  \<comment> \<open>PROPERTY A 7', monotonicity for \<open>\<le>\<close>\<close>
  apply (rule_tac f = "\<lambda>j. ack (j,k) " in Ord_lt_mono_imp_le_mono)
     apply (assumption | rule ack_lt_mono1 ack_type [THEN nat_into_Ord])+
  done

lemma ack_1: "j \<in> nat \<Longrightarrow> ack(1,j) = succ(succ(j))"
  \<comment> \<open>PROPERTY A 8\<close>
  by (induct set: nat) simp_all

lemma ack_2: "j \<in> nat \<Longrightarrow> ack(succ(1),j) = succ(succ(succ(j#+j)))"
  \<comment> \<open>PROPERTY A 9\<close>
  by (induct set: nat) (simp_all add: ack_1)

lemma ack_nest_bound:
  "\<lbrakk>i1 \<in> nat; i2 \<in> nat; j \<in> nat\<rbrakk>
    \<Longrightarrow> ack(i1, ack(i2,j)) < ack(succ(succ(i1#+i2)), j)"
  \<comment> \<open>PROPERTY A 10\<close>
  apply (rule lt_trans2 [OF _ ack2_le_ack1])
    apply simp
    apply (rule add_le_self [THEN ack_le_mono1, THEN lt_trans1])
       apply auto
  apply (force intro: add_le_self2 [THEN ack_lt_mono1, THEN ack_lt_mono2])
  done

lemma ack_add_bound:
  "\<lbrakk>i1 \<in> nat; i2 \<in> nat; j \<in> nat\<rbrakk>
    \<Longrightarrow> ack(i1,j) #+ ack(i2,j) < ack(succ(succ(succ(succ(i1#+i2)))), j)"
  \<comment> \<open>PROPERTY A 11\<close>
  apply (rule_tac j = "ack (succ (1), ack (i1 #+ i2, j))" in lt_trans)
   apply (simp add: ack_2)
   apply (rule_tac [2] ack_nest_bound [THEN lt_trans2])
      apply (rule add_le_mono [THEN leI, THEN leI])
         apply (auto intro: add_le_self add_le_self2 ack_le_mono1)
  done

lemma ack_add_bound2:
     "\<lbrakk>i < ack(k,j);  j \<in> nat;  k \<in> nat\<rbrakk>
      \<Longrightarrow> i#+j < ack(succ(succ(succ(succ(k)))), j)"
  \<comment> \<open>PROPERTY A 12.\<close>
  \<comment> \<open>Article uses existential quantifier but the ALF proof used \<^term>\<open>k#+#4\<close>.\<close>
  \<comment> \<open>Quantified version must be nested \<open>\<exists>k'. \<forall>i,j \<dots>\<close>.\<close>
  apply (rule_tac j = "ack (k,j) #+ ack (0,j) " in lt_trans)
   apply (rule_tac [2] ack_add_bound [THEN lt_trans2])
      apply (rule add_lt_mono)
         apply auto
  done

subsection \<open>Main result\<close>

declare list_add_type [simp]

lemma SC_case: "l \<in> list(nat) \<Longrightarrow> SC ` l < ack(1, list_add(l))"
    unfolding SC_def
  apply (erule list.cases)
   apply (simp add: succ_iff)
  apply (simp add: ack_1 add_le_self)
  done

lemma lt_ack1: "\<lbrakk>i \<in> nat; j \<in> nat\<rbrakk> \<Longrightarrow> i < ack(i,j)"
  \<comment> \<open>PROPERTY A 4'? Extra lemma needed for \<open>CONSTANT\<close> case, constant functions.\<close>
  apply (induct_tac i)
   apply (simp add: nat_0_le)
  apply (erule lt_trans1 [OF succ_leI ack_lt_ack_succ1])
   apply auto
  done

lemma CONSTANT_case:
    "\<lbrakk>l \<in> list(nat);  k \<in> nat\<rbrakk> \<Longrightarrow> CONSTANT(k) ` l < ack(k, list_add(l))"
  by (simp add: CONSTANT_def lt_ack1)

lemma PROJ_case [rule_format]:
    "l \<in> list(nat) \<Longrightarrow> \<forall>i \<in> nat. PROJ(i) ` l < ack(0, list_add(l))"
    unfolding PROJ_def
  apply simp
  apply (erule list.induct)
   apply (simp add: nat_0_le)
  apply simp
  apply (rule ballI)
  apply (erule_tac n = i in natE)
   apply (simp add: add_le_self)
  apply simp
  apply (erule bspec [THEN lt_trans2])
   apply (rule_tac [2] add_le_self2 [THEN succ_leI])
   apply auto
  done

text \<open>
  \medskip \<open>COMP\<close> case.
\<close>

lemma COMP_map_lemma:
  "fs \<in> list({f \<in> prim_rec. \<exists>kf \<in> nat. \<forall>l \<in> list(nat). f`l < ack(kf, list_add(l))})
    \<Longrightarrow> \<exists>k \<in> nat. \<forall>l \<in> list(nat).
      list_add(map(\<lambda>f. f ` l, fs)) < ack(k, list_add(l))"
  apply (induct set: list)
   apply (rule_tac x = 0 in bexI)
    apply (simp_all add: lt_ack1 nat_0_le)
  apply clarify
  apply (rule ballI [THEN bexI])
  apply (rule add_lt_mono [THEN lt_trans])
       apply (rule_tac [5] ack_add_bound)
         apply blast
        apply auto
  done

lemma COMP_case:
 "\<lbrakk>kg\<in>nat;
     \<forall>l \<in> list(nat). g`l < ack(kg, list_add(l));
     fs \<in> list({f \<in> prim_rec .
                 \<exists>kf \<in> nat. \<forall>l \<in> list(nat).
                        f`l < ack(kf, list_add(l))})\<rbrakk>
   \<Longrightarrow> \<exists>k \<in> nat. \<forall>l \<in> list(nat). COMP(g,fs)`l < ack(k, list_add(l))"
  apply (simp add: COMP_def)
  apply (frule list_CollectD)
  apply (erule COMP_map_lemma [THEN bexE])
  apply (rule ballI [THEN bexI])
   apply (erule bspec [THEN lt_trans])
    apply (rule_tac [2] lt_trans)
     apply (rule_tac [3] ack_nest_bound)
       apply (erule_tac [2] bspec [THEN ack_lt_mono2])
         apply auto
  done

text \<open>
  \medskip \<open>PREC\<close> case.
\<close>

lemma PREC_case_lemma:
 "\<lbrakk>\<forall>l \<in> list(nat). f`l #+ list_add(l) < ack(kf, list_add(l));
     \<forall>l \<in> list(nat). g`l #+ list_add(l) < ack(kg, list_add(l));
     f \<in> prim_rec;  kf\<in>nat;
     g \<in> prim_rec;  kg\<in>nat;
     l \<in> list(nat)\<rbrakk>
  \<Longrightarrow> PREC(f,g)`l #+ list_add(l) < ack(succ(kf#+kg), list_add(l))"
    unfolding PREC_def
  apply (erule list.cases)
   apply (simp add: lt_trans [OF nat_le_refl lt_ack2])
  apply simp
  apply (erule ssubst)  \<comment> \<open>get rid of the needless assumption\<close>
  apply (induct_tac a)
   apply simp_all
   txt \<open>base case\<close>
   apply (rule lt_trans, erule bspec, assumption)
   apply (simp add: add_le_self [THEN ack_lt_mono1])
  txt \<open>ind step\<close>
  apply (rule succ_leI [THEN lt_trans1])
   apply (rule_tac j = "g ` ll #+ mm" for ll mm in lt_trans1)
    apply (erule_tac [2] bspec)
    apply (rule nat_le_refl [THEN add_le_mono])
       apply typecheck
   apply (simp add: add_le_self2)
   txt \<open>final part of the simplification\<close>
  apply simp
  apply (rule add_le_self2 [THEN ack_le_mono1, THEN lt_trans1])
     apply (erule_tac [4] ack_lt_mono2)
      apply auto
  done

lemma PREC_case:
   "\<lbrakk>f \<in> prim_rec;  kf\<in>nat;
       g \<in> prim_rec;  kg\<in>nat;
       \<forall>l \<in> list(nat). f`l < ack(kf, list_add(l));
       \<forall>l \<in> list(nat). g`l < ack(kg, list_add(l))\<rbrakk>
    \<Longrightarrow> \<exists>k \<in> nat. \<forall>l \<in> list(nat). PREC(f,g)`l< ack(k, list_add(l))"
  apply (rule ballI [THEN bexI])
   apply (rule lt_trans1 [OF add_le_self PREC_case_lemma])
          apply typecheck
     apply (blast intro: ack_add_bound2 list_add_type)+
  done

lemma ack_bounds_prim_rec:
    "f \<in> prim_rec \<Longrightarrow> \<exists>k \<in> nat. \<forall>l \<in> list(nat). f`l < ack(k, list_add(l))"
  apply (induct set: prim_rec)
  apply (auto intro: SC_case CONSTANT_case PROJ_case COMP_case PREC_case)
  done

theorem ack_not_prim_rec:
    "(\<lambda>l \<in> list(nat). list_case(0, \<lambda>x xs. ack(x,x), l)) \<notin> prim_rec"
  apply (rule notI)
  apply (drule ack_bounds_prim_rec)
  apply force
  done

end