theory "FMap-Unused"
imports FMap
begin

subsection {* Induction over finite maps *}

lemma fmap_induct[case_names empty update, induct type: fmap]:
  assumes "P fempty"
  assumes "\<And> m x v. P m \<Longrightarrow> x \<notin> fdom m \<Longrightarrow> P (m(x f\<mapsto> v))"
  shows "P m"
proof-
  {
  fix m'
  have "finite (fdom m)" by simp
  hence "fdom m' = fdom m \<Longrightarrow> m' \<le> m \<Longrightarrow> P m'"
  proof(induction arbitrary: m' rule: finite_induct)
  case (empty m')
    hence "m' = fempty" by auto
    with assms(1) show ?case by auto
  next
  case (insert x d m')
    from `fdom m' = insert x d` `x \<notin> d`
    have "fdom (fmap_delete x m') = d" by auto
    moreover
    from `m' \<le> m`
    have "fmap_delete x m' \<le> m" by (metis (full_types) calculation fmap_delete_fmap_upd2 fmap_less_restrict fmap_restr_fmap_upd_other fmap_restr_less fmap_trans insert.hyps(2) order_refl)
    ultimately
    have "P (fmap_delete x m')" by (rule insert.IH)
    moreover
    have "x \<notin> fdom (fmap_delete x m')" using `fdom _ = d` `x \<notin> d` by simp
    ultimately
    have "P ((fmap_delete x m')(x f\<mapsto> m' f! x))" by (rule assms(2))
    with `fdom m' = insert x d`
    show "P m'" by simp
  qed
  }
  thus "P m" by simp
qed

subsubsection {* Conversion to associative lists *}

lemma list_of_exists:
  "\<exists> l. fmap_of l = m"
proof(induction rule: fmap_induct)
case empty
  have "fmap_of [] = f\<emptyset>" by simp
  thus ?case..
next
case (update m x v)
  from `\<exists>l. fmap_of l = m`
  obtain l where "fmap_of l = m" ..
  hence "fmap_of ((x,v)#l) = m(x f\<mapsto> v)" by simp
  thus ?case..
qed

definition list_of :: "'a f\<rightharpoonup> 'b \<Rightarrow> ('a \<times> 'b) list" where
  "list_of m = (SOME l. fmap_of l = m)"

lemma fmap_of_list_of[simp]:
  "fmap_of (list_of m) = m"
  unfolding list_of_def
  by (rule someI_ex[OF list_of_exists])

lemma map_of_list_of[simp]:
  "map_of (list_of m) = lookup m"
  unfolding list_of_def
  by (rule someI2_ex[OF list_of_exists]) auto

lift_definition fran :: "'key f\<rightharpoonup> 'value \<Rightarrow> 'value set" is "ran" ..
lemma finite_fran[simp]: "finite (fran m)"
  by (transfer, rule finite_range)
lemma fran_fmap_restr_subset: "fran (fmap_restr S m) \<subseteq> fran m"
  by transfer (auto simp add: ran_def restrict_map_def)
lemma fran_fmap_delete_subset:
  "fran (fmap_delete x m) \<subseteq> fran m"
  by transfer (auto simp add: ran_def)
lemma fran_fmap_upd[simp]:
  "fran (m(x f\<mapsto> v)) = insert v (fran (fmap_delete x m))"
by (transfer, auto simp add: ran_def)
lemma fran_fun_merge_subset: "fran (m1 f++ m2) \<subseteq> fran m1 \<union> fran m2"
  by (transfer, auto simp add: ran_def)
lemma fran_fmap_copy_subset:
  "fran (fmap_copy m x y) \<subseteq> fran m"
  by transfer (auto simp add: ran_def)
lemma fmap_map_cong: "(\<And> x. x \<in> fran m \<Longrightarrow> f x = f' x) \<Longrightarrow> m = m' \<Longrightarrow> fmap_map f m = fmap_map f' m'"
  by transfer (fastforce simp add: ran_def Option.map_def split:option.split)

end


(*<*)
theory Real_Asymp_Doc
  imports "HOL-Real_Asymp.Real_Asymp"
begin

ML_file \<open>~~/src/Doc/antiquote_setup.ML\<close>
(*>*)

section \<open>Introduction\<close>

text \<open>
  This document describes the \<^verbatim>\<open>real_asymp\<close> package that provides a number of tools
  related to the asymptotics of real-valued functions. These tools are:

    \<^item> The @{method real_asymp} method to prove limits, statements involving Landau symbols
      (`Big-O' etc.), and asymptotic equivalence (\<open>\<sim>\<close>)

    \<^item> The @{command real_limit} command to compute the limit of a real-valued function at a
      certain point

    \<^item> The @{command real_expansion} command to compute the asymptotic expansion of a
      real-valued function at a certain point

  These three tools will be described in the following sections.
\<close>

section \<open>Supported Operations\<close>

text \<open>
  The \<^verbatim>\<open>real_asymp\<close> package fully supports the following operations:

    \<^item> Basic arithmetic (addition, subtraction, multiplication, division)

    \<^item> Powers with constant natural exponent

    \<^item> \<^term>\<open>exp\<close>, \<^term>\<open>ln\<close>, \<^term>\<open>log\<close>, \<^term>\<open>sqrt\<close>, \<^term>\<open>root k\<close> (for a constant k)

    \<^item> \<^term>\<open>sin\<close>, \<^term>\<open>cos\<close>, \<^term>\<open>tan\<close> at finite points

    \<^item> \<^term>\<open>sinh\<close>, \<^term>\<open>cosh\<close>, \<^term>\<open>tanh\<close>

    \<^item> \<^term>\<open>min\<close>, \<^term>\<open>max\<close>, \<^term>\<open>abs\<close>

  Additionally, the following operations are supported in a `best effort' fashion using asymptotic
  upper/lower bounds:

    \<^item> Powers with variable natural exponent

    \<^item> \<^term>\<open>sin\<close> and \<^term>\<open>cos\<close> at \<open>\<plusminus>\<infinity>\<close>

    \<^item> \<^term>\<open>floor\<close>, \<^term>\<open>ceiling\<close>, \<^term>\<open>frac\<close>, and \<open>mod\<close>

  Additionally, the \<^term>\<open>arctan\<close> function is partially supported. The method may fail when
  the argument to \<^term>\<open>arctan\<close> contains functions of different order of growth.
\<close>

section \<open>Proving Limits and Asymptotic Properties\<close>

text \<open>
  \[
    @{method_def (HOL) real_asymp} : \<open>method\<close>
  \]

  \<^rail>\<open>
    @@{method (HOL) real_asymp} opt? (@{syntax simpmod} * )
    ;
    opt: '(' ('verbose' | 'fallback' ) ')'
    ;
    @{syntax_def simpmod}: ('add' | 'del' | 'only' | 'split' (() | '!' | 'del') |
      'cong' (() | 'add' | 'del')) ':' @{syntax thms}
  \<close>
\<close>

text \<open>
  The @{method real_asymp} method is a semi-automatic proof method for proving certain statements
  related to the asymptotic behaviour of real-valued functions. In the following, let \<open>f\<close> and \<open>g\<close>
  be functions of type \<^typ>\<open>real \<Rightarrow> real\<close> and \<open>F\<close> and \<open>G\<close> real filters.

  The functions \<open>f\<close> and \<open>g\<close> can be built from the operations mentioned before and may contain free
  variables. The filters \<open>F\<close> and \<open>G\<close> can be either \<open>\<plusminus>\<infinity>\<close> or a finite point in \<open>\<real>\<close>, possibly
  with approach from the left or from the right.

  The class of statements that is supported by @{method real_asymp} then consists of:

    \<^item> Limits, i.\,e.\ \<^prop>\<open>filterlim f F G\<close>

    \<^item> Landau symbols, i.\,e.\ \<^prop>\<open>f \<in> O[F](g)\<close> and analogously for \<^emph>\<open>o\<close>, \<open>\<Omega>\<close>, \<open>\<omega>\<close>, \<open>\<Theta>\<close>

    \<^item> Asymptotic equivalence, i.\,e.\ \<^prop>\<open>f \<sim>[F] g\<close>

    \<^item> Asymptotic inequalities, i.\,e.\ \<^prop>\<open>eventually (\<lambda>x. f x \<le> g x) F\<close>

  For typical problems arising in practice that do not contain free variables, @{method real_asymp}
  tends to succeed fully automatically within fractions of seconds, e.\,g.:
\<close>

lemma \<open>filterlim (\<lambda>x::real. (1 + 1 / x) powr x) (nhds (exp 1)) at_top\<close>
  by real_asymp

text \<open>
  What makes the method \<^emph>\<open>semi-automatic\<close> is the fact that it has to internally determine the
  sign of real-valued constants and identical zeroness of real-valued functions, and while the
  internal heuristics for this work very well most of the time, there are situations where the
  method fails to determine the sign of a constant, in which case the user needs to go back and
  supply more information about the sign of that constant in order to get a result.

  A simple example is the following:
\<close>
(*<*)
experiment
  fixes a :: real
begin
(*>*)
lemma \<open>filterlim (\<lambda>x::real. exp (a * x)) at_top at_top\<close>
oops

text \<open>
  Here, @{method real_asymp} outputs an error message stating that it could not determine the
  sign of the free variable \<^term>\<open>a :: real\<close>. In this case, the user must add the assumption
  \<open>a > 0\<close> and give it to @{method real_asymp}.
\<close>
lemma
  assumes \<open>a > 0\<close>
  shows   \<open>filterlim (\<lambda>x::real. exp (a * x)) at_top at_top\<close>
  using assms by real_asymp
(*<*)
end
(*>*)
text \<open>
  Additional modifications to the simpset that is used for determining signs can also be made
  with \<open>simp add:\<close> modifiers etc.\ in the same way as when using the @{method simp} method directly.

  The same situation can also occur without free variables if the constant in question is a
  complicated expression that the simplifier does not know enough ebout,
  e.\,g.\ \<^term>\<open>pi - exp 1\<close>.

  In order to trace problems with sign determination, the \<open>(verbose)\<close> option can be passed to
  @{method real_asymp}. It will then print a detailed error message whenever it encounters
  a sign determination problem that it cannot solve.

  The \<open>(fallback)\<close> flag causes the method not to use asymptotic interval arithmetic, but only
  the much simpler core mechanism of computing a single Multiseries expansion for the input
  function. There should normally be no need to use this flag; however, the core part of the
  code has been tested much more rigorously than the asymptotic interval part. In case there
  is some implementation problem with it for a problem that can be solved without it, the
  \<open>(fallback)\<close> option can be used until that problem is resolved.
\<close>

section \<open>Diagnostic Commands\<close>

text \<open>
  \[\begin{array}{rcl}
    @{command_def (HOL) real_limit} & : & \<open>context \<rightarrow>\<close> \\
    @{command_def (HOL) real_expansion} & : & \<open>context \<rightarrow>\<close>
  \end{array}\]

  \<^rail>\<open>
    @@{command (HOL) real_limit} (limitopt*)
    ;
    @@{command (HOL) real_expansion} (expansionopt*)
    ;
    limitopt : ('limit' ':' @{syntax term}) | ('facts' ':' @{syntax thms})
    ;
    expansionopt :
        ('limit' ':' @{syntax term}) |
        ('terms' ':' @{syntax nat} ('(' 'strict' ')') ?) |
        ('facts' ':' @{syntax thms})
  \<close>

    \<^descr>@{command real_limit} computes the limit of the given function \<open>f(x)\<close> for as \<open>x\<close> tends
    to the specified limit point. Additional facts can be provided with the \<open>facts\<close> option,
    similarly to the @{command using} command with @{method real_asymp}. The limit point given
    by the \<open>limit\<close> option must be one of the filters \<^term>\<open>at_top\<close>, \<^term>\<open>at_bot\<close>,
    \<^term>\<open>at_left\<close>, or \<^term>\<open>at_right\<close>. If no limit point is given, \<^term>\<open>at_top\<close> is used
    by default.

    \<^medskip>
    The output of @{command real_limit} can be \<open>\<infinity>\<close>, \<open>-\<infinity>\<close>, \<open>\<plusminus>\<infinity>\<close>, \<open>c\<close> (for some real constant \<open>c\<close>),
    \<open>0\<^sup>+\<close>, or \<open>0\<^sup>-\<close>. The \<open>+\<close> and \<open>-\<close> in the last case indicate whether the approach is from above
    or from below (corresponding to \<^term>\<open>at_right (0::real)\<close> and \<^term>\<open>at_left (0::real)\<close>);
    for technical reasons, this information is currently not displayed if the limit is not 0.

    \<^medskip>
    If the given function does not tend to a definite limit (e.\,g.\ \<^term>\<open>sin x\<close> for \<open>x \<rightarrow> \<infinity>\<close>),
    the command might nevertheless succeed to compute an asymptotic upper and/or lower bound and
    display the limits of these bounds instead.

    \<^descr>@{command real_expansion} works similarly to @{command real_limit}, but displays the first few
    terms of the asymptotic multiseries expansion of the given function at the given limit point
    and the order of growth of the remainder term.

    In addition to the options already explained for the @{command real_limit} command, it takes
    an additional option \<open>terms\<close> that controls how many of the leading terms of the expansion are
    printed. If the \<open>(strict)\<close> modifier is passed to the \<open>terms option\<close>, terms whose coefficient is
    0 are dropped from the output and do not count to the number of terms to be output.

    \<^medskip>
    By default, the first three terms are output and the \<open>strict\<close> option is disabled.

  Note that these two commands are intended for diagnostic use only. While the central part
  of their implementation -- finding a multiseries expansion and reading off the limit -- are the
  same as in the @{method real_asymp} method and therefore trustworthy, there is a small amount
  of unverified code involved in pre-processing and printing (e.\,g.\ for reducing all the
  different options for the \<open>limit\<close> option to the \<^term>\<open>at_top\<close> case).
\<close>

section \<open>Extensibility\<close>

subsection \<open>Basic fact collections\<close>

text \<open>
  The easiest way to add support for additional operations is to add corresponding facts
  to one of the following fact collections. However, this only works for particularly simple cases.

    \<^descr>@{thm [source] real_asymp_reify_simps} specifies a list of (unconditional) equations that are
     unfolded as a first step of @{method real_asymp} and the related commands. This can be used to
     add support for operations that can be represented easily by other operations that are already
     supported, such as \<^term>\<open>sinh\<close>, which is equal to \<^term>\<open>\<lambda>x. (exp x - exp (-x)) / 2\<close>.

    \<^descr>@{thm [source] real_asymp_nat_reify} and @{thm [source] real_asymp_int_reify} is used to
     convert operations on natural numbers or integers to operations on real numbers. This enables
     @{method real_asymp} to also work on functions that return a natural number or an integer.
\<close>

subsection \<open>Expanding Custom Operations\<close>

text \<open>
  Support for some non-trivial new operation \<open>f(x\<^sub>1, \<dots>, x\<^sub>n)\<close> can be added dynamically at any
  time, but it involves writing ML code and involves a significant amount of effort, especially
  when the function has essential singularities.

  The first step is to write an ML function that takes as arguments
    \<^item> the expansion context
    \<^item> the term \<open>t\<close> to expand (which will be of the form \<open>f(g\<^sub>1(x), \<dots>, g\<^sub>n(x))\<close>)
    \<^item> a list of \<open>n\<close> theorems of the form \<^prop>\<open>(g\<^sub>i expands_to G\<^sub>i) bs\<close>
    \<^item> the current basis \<open>bs\<close>
  and returns a theorem of the form \<^prop>\<open>(t expands_to F) bs'\<close> and a new basis \<open>bs'\<close> which
  must be a superset of the original basis.

  This function must then be registered as a handler for the operation by proving a vacuous lemma
  of the form \<^prop>\<open>REAL_ASYMP_CUSTOM f\<close> (which is only used for tagging) and passing that
  lemma and the expansion function to @{ML [source] Exp_Log_Expression.register_custom_from_thm}
  in a @{command local_setup} invocation.

  If the expansion produced by the handler function contains new definitions, corresponding
  evaluation equations must be added to the fact collection @{thm [source] real_asymp_eval_eqs}.
  These equations must have the form \<open>h p\<^sub>1 \<dots> p\<^sub>m = rhs\<close> where \<open>h\<close> must be a constant of arity \<open>m\<close>
  (i.\,e.\ the function on the left-hand side must be fully applied) and the \<open>p\<^sub>i\<close> can be patterns
  involving \<open>constructors\<close>.

  New constructors for this pattern matching can be registered by adding a theorem of the form
  \<^prop>\<open>REAL_ASYMP_EVAL_CONSTRUCTOR c\<close> to the fact collection
  @{thm [source] exp_log_eval_constructor}, but this should be quite rare in practice.

  \<^medskip>
  Note that there is currently no way to add support for custom operations in connection with
  `oscillating' terms. The above mechanism only works if all arguments of the new operation have
  an exact multiseries expansion.
\<close>

subsection \<open>Extending the Sign Oracle\<close>

text \<open>
  By default, the \<^verbatim>\<open>real_asymp\<close> package uses the simplifier with the given simpset and facts
  in order to determine the sign of real constants. This is done by invoking the simplifier
  on goals like \<open>c = 0\<close>, \<open>c \<noteq> 0\<close>, \<open>c > 0\<close>, or \<open>c < 0\<close> or some subset thereof, depending on the
  context.

  If the simplifier cannot prove any of them, the entire method (or command) invocation will fail.
  It is, however, possible to dynamically add additional sign oracles that will be tried; the
  most obvious candidate for an oracle that one may want to add or remove dynamically are
  approximation-based tactics.

  Adding such a tactic can be done by calling
  @{ML [source] Multiseries_Expansion.register_sign_oracle}. Note that if the tactic cannot prove
  a goal, it should fail as fast as possible.
\<close>

(*<*)
end
(*>*)


theory Digraph_Isomorphism imports
  Arc_Walk
  Digraph
  Digraph_Component
begin

section {* Isomorphisms of Digraphs *}

record ('a,'b,'aa,'bb) digraph_isomorphism =
  iso_verts :: "'a \<Rightarrow> 'aa"
  iso_arcs :: "'b \<Rightarrow> 'bb"
  iso_head :: "'bb \<Rightarrow> 'aa"
  iso_tail :: "'bb \<Rightarrow> 'aa"

definition (in pre_digraph) digraph_isomorphism :: "('a,'b,'aa,'bb) digraph_isomorphism \<Rightarrow> bool" where
  "digraph_isomorphism hom \<equiv>
    inj_on (iso_verts hom) (verts G) \<and>
    inj_on (iso_arcs hom) (arcs G) \<and>
    (\<forall>a \<in> arcs G.
    iso_verts hom (tail G a) = iso_tail hom (iso_arcs hom a) \<and>
    iso_verts hom (head G a) = iso_head hom (iso_arcs hom a))"

definition (in pre_digraph) inv_iso :: "('a,'b,'aa,'bb) digraph_isomorphism \<Rightarrow> ('aa,'bb,'a,'b) digraph_isomorphism" where
  "inv_iso hom \<equiv> \<lparr>
    iso_verts = the_inv_into (verts G) (iso_verts hom),
    iso_arcs = the_inv_into (arcs G) (iso_arcs hom),
    iso_head = head G,
    iso_tail = tail G
    \<rparr>"

definition app_iso
    :: "('a,'b,'aa,'bb) digraph_isomorphism \<Rightarrow> ('a,'b) pre_digraph \<Rightarrow> ('aa,'bb) pre_digraph" where
  "app_iso hom G \<equiv> \<lparr> verts = iso_verts hom ` verts G, arcs = iso_arcs hom ` arcs G,
    tail = iso_tail hom, head = iso_head hom \<rparr>"

lemma verts_app_iso: "verts (app_iso hom G) = iso_verts hom ` verts G"
  and arcs_app_iso: "arcs (app_iso hom G) = iso_arcs hom `arcs G"
  and tail_app_iso: "tail (app_iso hom G) = iso_tail hom"
  and head_app_iso: "head (app_iso hom G) = iso_head hom"
  by (auto simp: app_iso_def)

lemmas app_iso_simps[simp] = verts_app_iso arcs_app_iso tail_app_iso head_app_iso

context pre_digraph begin

lemma
  assumes "digraph_isomorphism hom"
  shows iso_verts_inv_iso: "\<And>u. u \<in> verts G \<Longrightarrow> iso_verts (inv_iso hom) (iso_verts hom u) = u"
    and iso_arcs_inv_iso: "\<And>a. a \<in> arcs G \<Longrightarrow> iso_arcs (inv_iso hom) (iso_arcs hom a) = a"
    and iso_verts_iso_inv: "\<And>u. u \<in> verts (app_iso hom G) \<Longrightarrow> iso_verts hom (iso_verts (inv_iso hom) u) = u"
    and iso_arcs_iso_inv: "\<And>a. a \<in> arcs (app_iso hom G) \<Longrightarrow> iso_arcs hom (iso_arcs (inv_iso hom) a) = a"
    and iso_tail_inv_iso: "iso_tail (inv_iso hom) = tail G"
    and iso_head_inv_iso: "iso_head (inv_iso hom) = head G"
    and verts_app_inv_iso:"iso_verts (inv_iso hom) ` iso_verts hom ` verts G = verts G"
    and arcs_app_inv_iso:"iso_arcs (inv_iso hom) ` iso_arcs hom ` arcs G = arcs G"
  using assms by (auto simp: inv_iso_def digraph_isomorphism_def the_inv_into_f_f)

lemmas iso_inv_simps[simp] =
   iso_verts_inv_iso iso_verts_iso_inv
   iso_arcs_inv_iso iso_arcs_iso_inv
   verts_app_inv_iso arcs_app_inv_iso
   iso_tail_inv_iso iso_head_inv_iso

lemma (in wf_digraph) digraph_isomorphism_invI:
  assumes "digraph_isomorphism hom" shows "pre_digraph.digraph_isomorphism (app_iso hom G) (inv_iso hom)"
proof (unfold pre_digraph.digraph_isomorphism_def, safe)
  show "inj_on (iso_verts (inv_iso hom)) (verts (app_iso hom G))"
      "inj_on (iso_arcs (inv_iso hom)) (arcs (app_iso hom G))"
    using assms unfolding pre_digraph.digraph_isomorphism_def inv_iso_def
    by (auto intro: inj_on_the_inv_into)
next
  fix a assume "a \<in> arcs (app_iso hom G)"
  then obtain b where B: "a = iso_arcs hom b" "b \<in> arcs G"
    by auto

  with assms have [simp]:
      "iso_tail hom (iso_arcs hom b) = iso_verts hom (tail G b)"
      "iso_head hom (iso_arcs hom b) = iso_verts hom (head G b)"
      "inj_on (iso_arcs hom) (arcs G)"
      "inj_on (iso_verts hom) (verts G)"
    by (auto simp: digraph_isomorphism_def)

  from B show "iso_verts (inv_iso hom) (tail (app_iso hom G) a)
      = iso_tail (inv_iso hom) (iso_arcs (inv_iso hom) a)"
    by (auto simp: inv_iso_def the_inv_into_f_f)
  from B show "iso_verts (inv_iso hom) (head (app_iso hom G) a)
      = iso_head (inv_iso hom) (iso_arcs (inv_iso hom) a)"
    by (auto simp: inv_iso_def the_inv_into_f_f)
qed

lemma app_iso_inv[simp]:
  assumes "digraph_isomorphism hom"
  shows "app_iso (inv_iso hom) (app_iso hom G) = G"
  using assms by (intro pre_digraph.equality) (auto intro: rev_image_eqI)

lemma iso_verts_eq_iff[simp]:
  assumes "digraph_isomorphism hom" "u \<in> verts G" "v \<in> verts G"
  shows "iso_verts hom u = iso_verts hom v \<longleftrightarrow> u = v"
  using assms by (auto simp: digraph_isomorphism_def dest: inj_onD)

lemma iso_arcs_eq_iff[simp]:
  assumes "digraph_isomorphism hom" "e1 \<in> arcs G" "e2 \<in> arcs G"
  shows "iso_arcs hom e1 = iso_arcs hom e2 \<longleftrightarrow> e1 = e2"
  using assms by (auto simp: digraph_isomorphism_def dest: inj_onD)

lemma
  assumes "digraph_isomorphism hom" "e \<in> arcs G"
  shows iso_verts_tail: "iso_tail hom (iso_arcs hom e) = iso_verts hom (tail G e)"
    and iso_verts_head: "iso_head hom (iso_arcs hom e) = iso_verts hom (head G e)"
  using assms unfolding digraph_isomorphism_def by auto

end

lemma (in wf_digraph) wf_digraphI_app_iso[intro?]:
  assumes "digraph_isomorphism hom"
  shows "wf_digraph (app_iso hom G)"
proof unfold_locales
  fix e assume "e \<in> arcs (app_iso hom G)"
  then obtain e' where e': "e' \<in> arcs G" "iso_arcs hom e' = e"
    by auto
  then have "iso_verts hom (head G e') \<in> verts (app_iso hom G)"
      "iso_verts hom (tail G e') \<in> verts (app_iso hom G)"
    by auto
  then show "tail (app_iso hom G) e \<in> verts (app_iso hom G)"
      "head (app_iso hom G) e \<in> verts (app_iso hom G)"
    using e' assms by (auto simp: iso_verts_tail iso_verts_head)
qed

lemma (in fin_digraph) fin_digraphI_app_iso[intro?]:
  assumes "digraph_isomorphism hom"
  shows "fin_digraph (app_iso hom G)"
proof -
  interpret H: wf_digraph "app_iso hom G" using assms ..
  show ?thesis by unfold_locales auto
qed

context wf_digraph begin

lemma awalk_app_isoI:
  assumes "awalk u p v" and hom: "digraph_isomorphism hom"
  shows "pre_digraph.awalk (app_iso hom G) (iso_verts hom u) (map (iso_arcs hom) p) (iso_verts hom v)"
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..
  from assms show ?thesis
    by (induct p arbitrary: u)
       (auto simp: awalk_simps H.awalk_simps iso_verts_head iso_verts_tail)
qed

lemma awalk_app_isoD:
  assumes w: "pre_digraph.awalk (app_iso hom G) u p v" and hom: "digraph_isomorphism hom"
  shows "awalk (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p) (iso_verts (inv_iso hom) v)"
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..
  from assms show ?thesis
    by (induct p arbitrary: u)
       (force simp: awalk_simps H.awalk_simps iso_verts_head iso_verts_tail)+
qed

lemma awalk_verts_app_iso_eq:
  assumes "digraph_isomorphism hom" and "awalk u p v"
  shows "pre_digraph.awalk_verts (app_iso hom G) (iso_verts hom u) (map (iso_arcs hom) p)
    = map (iso_verts hom) (awalk_verts u p)"
  using assms
  by (induct p arbitrary: u)
     (auto simp: pre_digraph.awalk_verts.simps iso_verts_head iso_verts_tail awalk_Cons_iff)

(*
lemma awalk_verts_app_iso_eq':
  assumes hom: "digraph_isomorphism hom" and w: "pre_digraph.awalk (app_iso hom G) u p v"
  shows "pre_digraph.awalk_verts (app_iso hom G) u p
    = map (iso_verts hom) (awalk_verts (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p))"
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..
  have w': "awalk (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p) (iso_verts (inv_iso hom) v)"
    using w hom by (rule awalk_app_isoD)
  have "pre_digraph.awalk_verts (app_iso hom G) u p =
      pre_digraph.awalk_verts (app_iso hom G) (iso_verts hom (iso_verts (inv_iso hom) u)) (map (iso_arcs hom) (map (iso_arcs (inv_iso hom)) p))"
    using hom w by (auto simp add: o_def set_mp cong: map_cong)
  also have "\<dots> = map (iso_verts hom) (awalk_verts (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p))"
    using hom w' by (rule awalk_verts_app_iso_eq)
  finally show ?thesis .
qed
*)

lemma in_arcs_app_iso_eq:
  assumes "digraph_isomorphism hom" and "u \<in> verts G"
  shows "in_arcs (app_iso hom G) (iso_verts hom u) = iso_arcs hom ` in_arcs G u"
  using assms unfolding in_arcs_def by (auto simp: iso_verts_head)

lemma out_arcs_app_iso_eq:
  assumes "digraph_isomorphism hom" and "u \<in> verts G"
  shows "out_arcs (app_iso hom G) (iso_verts hom u) = iso_arcs hom ` out_arcs G u"
  using assms unfolding out_arcs_def by (auto simp: iso_verts_tail)

lemma in_degree_app_iso_eq:
  assumes "digraph_isomorphism hom" and "u \<in> verts G"
  shows "in_degree (app_iso hom G) (iso_verts hom u) = in_degree G u"
  unfolding in_degree_def in_arcs_app_iso_eq[OF assms]
proof (rule card_image)
  from assms show "inj_on (iso_arcs hom) (in_arcs G u)"
    unfolding digraph_isomorphism_def by - (rule subset_inj_on, auto)
qed

lemma out_degree_app_iso_eq:
  assumes "digraph_isomorphism hom" and "u \<in> verts G"
  shows "out_degree (app_iso hom G) (iso_verts hom u) = out_degree G u"
  unfolding out_degree_def out_arcs_app_iso_eq[OF assms]
proof (rule card_image)
  from assms show "inj_on (iso_arcs hom) (out_arcs G u)"
    unfolding digraph_isomorphism_def by - (rule subset_inj_on, auto)
qed

lemma in_arcs_app_iso_eq':
  assumes "digraph_isomorphism hom" and "u \<in> verts (app_iso hom G)"
  shows "in_arcs (app_iso hom G) u = iso_arcs hom ` in_arcs G (iso_verts (inv_iso hom) u)"
  using assms in_arcs_app_iso_eq[of hom "iso_verts (inv_iso hom) u"] by auto

lemma out_arcs_app_iso_eq':
  assumes "digraph_isomorphism hom" and "u \<in> verts (app_iso hom G)"
  shows "out_arcs (app_iso hom G) u = iso_arcs hom ` out_arcs G (iso_verts (inv_iso hom) u)"
  using assms out_arcs_app_iso_eq[of hom "iso_verts (inv_iso hom) u"] by auto

lemma in_degree_app_iso_eq':
  assumes "digraph_isomorphism hom" and "u \<in> verts (app_iso hom G)"
  shows "in_degree (app_iso hom G) u = in_degree G (iso_verts (inv_iso hom) u)"
  using assms in_degree_app_iso_eq[of hom "iso_verts (inv_iso hom) u"] by auto

lemma out_degree_app_iso_eq':
  assumes "digraph_isomorphism hom" and "u \<in> verts (app_iso hom G)"
  shows "out_degree (app_iso hom G) u = out_degree G (iso_verts (inv_iso hom) u)"
  using assms out_degree_app_iso_eq[of hom "iso_verts (inv_iso hom) u"] by auto

lemmas app_iso_eq =
  awalk_verts_app_iso_eq
  arcs_ends_app_iso_eq
  in_arcs_app_iso_eq'
  out_arcs_app_iso_eq'
  in_degree_app_iso_eq'
  out_degree_app_iso_eq'

lemma reachableI_app_iso:
  assumes r: "u \<rightarrow>\<^sup>* v" and hom: "digraph_isomorphism hom"
  shows "(iso_verts hom u) \<rightarrow>\<^sup>*\<^bsub>app_iso hom G\<^esub> (iso_verts hom v)"
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..
  from r obtain p where "awalk u p v" by (auto simp: reachable_awalk)
  then have "H.awalk (iso_verts hom u) (map (iso_arcs hom) p) (iso_verts hom v)"
    using hom by (rule awalk_app_isoI)
  then show ?thesis by (auto simp: H.reachable_awalk)
qed

lemma connectedI_app_iso:
  assumes c: "connected G" and hom: "digraph_isomorphism hom"
  shows "connected (app_iso hom G)"
proof -
  have *: "symcl (arcs_ends (app_iso hom G)) = (\<lambda>(u,v). (iso_verts hom u, iso_verts hom v)) ` symcl (arcs_ends G)"
    using hom by (auto simp add: app_iso_eq symcl_def)
  { fix u v assume "(u,v) \<in> rtrancl_on (verts G) (symcl (arcs_ends G))"
    then have "(iso_verts hom u, iso_verts hom v) \<in> rtrancl_on (verts (app_iso hom G)) (symcl (arcs_ends (app_iso hom G)))"
    proof induct
      case (step x y)
      have "(iso_verts hom x, iso_verts hom y)
          \<in> rtrancl_on (verts (app_iso hom G)) (symcl (arcs_ends (app_iso hom G)))"
        using step by (rule_tac rtrancl_on_into_rtrancl_on[where b="iso_verts hom x"]) (auto simp: *)
      then show ?case
        by (rule rtrancl_on_trans) (rule step)
    qed auto }
  with c show ?thesis unfolding connected_conv by auto
qed

end

end


(* Author: Alexander Maletzky *)

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

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

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

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

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

lemmas radical_idealI_internalized = radical_idealI[unoverload_type 'x]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

lemmas max_ideal_shapeD_internalized = max_ideal_shapeD_finite[unoverload_type 'x]

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

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

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

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

end (* theory *)


theory DPList
imports Main
begin

declare[[show_types, show_sorts]]

consts id1 :: "'a \<Rightarrow> 'b"

definition distinct_e::"('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> bool"
  where "distinct_e p l \<equiv> l\<noteq>[] \<longrightarrow> (\<forall>i< length l. \<forall>j<length l. i\<noteq>j \<longrightarrow> p (l!i)\<noteq>p (l!j))"

typedef (overloaded) ('a,'b)  dplist =
 "{xs::'a list. xs\<noteq>[] \<longrightarrow> (\<forall>i< length xs. \<forall>j<length xs. i\<noteq>j \<longrightarrow> (id1::('a \<Rightarrow> 'b)) (xs!i)\<noteq>id1 (xs!j))}"
  morphisms list_of_dplist Abs_dplist
proof
  show "[] \<in> {xs::'a list. xs\<noteq>[] \<longrightarrow> (\<forall>i< length xs. \<forall>j<length xs. i\<noteq>j \<longrightarrow> (id1::('a \<Rightarrow> 'b)) (xs!i)\<noteq>id1 (xs!j))}"
    by simp
qed

setup_lifting type_definition_dplist

lemma dlist_eq_iff:
  "dxs = dys \<longleftrightarrow> list_of_dplist dxs = list_of_dplist dys"
  by (simp add: list_of_dplist_inject)

lemma dlist_eqI:
  "list_of_dplist dxs = list_of_dplist dys \<Longrightarrow> dxs = dys"
  by (simp add: dlist_eq_iff)

text \<open>Formal, totalized constructor for \<^typ>\<open>('a,'b) dplist\<close>:\<close>

definition Dplist :: "'a list \<Rightarrow> ('a,'b) dplist" where
  "Dplist xs = Abs_dplist (remdups xs)"

lemma distinct_list_of_dplist [simp, intro]:
  "distinct_e (id1::'a \<Rightarrow> 'b) (list_of_dplist (dxs::('a,'b)dplist))"
  using list_of_dplist [of dxs]  by (simp add:distinct_e_def)

lemma list_of_dplist_Dplist [simp]:
  "list_of_dplist (Dplist xs) = remdups xs"
  by (simp add: Dlist_def Abs_dlist_inverse)

lemma remdups_list_of_dplist [simp]:
  "remdups (list_of_dplist dxs) = list_of_dplist dxs"
  by simp

lemma Dplist_list_of_dplist [simp, code abstype]:
  "Dlist (list_of_dlist dxs) = dxs"
  by (simp add: Dlist_def list_of_dlist_inverse distinct_remdups_id)

text \<open>Fundamental operations:\<close>

context
begin

qualified definition empty :: "'a dlist" where
  "empty = Dlist []"

qualified definition insert :: "'a \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
  "insert x dxs = Dlist (List.insert x (list_of_dlist dxs))"

qualified definition remove :: "'a \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
  "remove x dxs = Dlist (remove1 x (list_of_dlist dxs))"

qualified definition map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b dlist" where
  "map f dxs = Dlist (remdups (List.map f (list_of_dlist dxs)))"

qualified definition filter :: "('a \<Rightarrow> bool) \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
  "filter P dxs = Dlist (List.filter P (list_of_dlist dxs))"

qualified definition rotate :: "nat \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
  "rotate n dxs = Dlist (List.rotate n (list_of_dlist dxs))"

end

text \<open>Derived operations:\<close>

context
begin

qualified definition null :: "'a dlist \<Rightarrow> bool" where
  "null dxs = List.null (list_of_dlist dxs)"

qualified definition member :: "'a dlist \<Rightarrow> 'a \<Rightarrow> bool" where
  "member dxs = List.member (list_of_dlist dxs)"

qualified definition length :: "'a dlist \<Rightarrow> nat" where
  "length dxs = List.length (list_of_dlist dxs)"

qualified definition fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b \<Rightarrow> 'b" where
  "fold f dxs = List.fold f (list_of_dlist dxs)"

qualified definition foldr :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b \<Rightarrow> 'b" where
  "foldr f dxs = List.foldr f (list_of_dlist dxs)"

end

subsection \<open>Executable version obeying invariant\<close>

lemma list_of_dlist_empty [simp, code abstract]:
  "list_of_dlist Dlist.empty = []"
  by (simp add: Dlist.empty_def)

lemma list_of_dlist_insert [simp, code abstract]:
  "list_of_dlist (Dlist.insert x dxs) = List.insert x (list_of_dlist dxs)"
  by (simp add: Dlist.insert_def)

lemma list_of_dlist_remove [simp, code abstract]:
  "list_of_dlist (Dlist.remove x dxs) = remove1 x (list_of_dlist dxs)"
  by (simp add: Dlist.remove_def)

lemma list_of_dlist_map [simp, code abstract]:
  "list_of_dlist (Dlist.map f dxs) = remdups (List.map f (list_of_dlist dxs))"
  by (simp add: Dlist.map_def)

lemma list_of_dlist_filter [simp, code abstract]:
  "list_of_dlist (Dlist.filter P dxs) = List.filter P (list_of_dlist dxs)"
  by (simp add: Dlist.filter_def)

lemma list_of_dlist_rotate [simp, code abstract]:
  "list_of_dlist (Dlist.rotate n dxs) = List.rotate n (list_of_dlist dxs)"
  by (simp add: Dlist.rotate_def)

text \<open>Explicit executable conversion\<close>

definition dlist_of_list [simp]:
  "dlist_of_list = Dlist"

lemma [code abstract]:
  "list_of_dlist (dlist_of_list xs) = remdups xs"
  by simp

text \<open>Equality\<close>

instantiation dlist :: (equal) equal
begin

definition "HOL.equal dxs dys \<longleftrightarrow> HOL.equal (list_of_dlist dxs) (list_of_dlist dys)"

instance
  by standard (simp add: equal_dlist_def equal list_of_dlist_inject)

end

declare equal_dlist_def [code]

lemma [code nbe]: "HOL.equal (dxs :: 'a::equal dlist) dxs \<longleftrightarrow> True"
  by (fact equal_refl)

subsection \<open>Induction principle and case distinction\<close>

lemma dlist_induct [case_names empty insert, induct type: dlist]:
  assumes empty: "P Dlist.empty"
  assumes insrt: "\<And>x dxs. \<not> Dlist.member dxs x \<Longrightarrow> P dxs \<Longrightarrow> P (Dlist.insert x dxs)"
  shows "P dxs"
proof (cases dxs)
  case (Abs_dlist xs)
  then have "distinct xs" and dxs: "dxs = Dlist xs"
    by (simp_all add: Dlist_def distinct_remdups_id)
  from \<open>distinct xs\<close> have "P (Dlist xs)"
  proof (induct xs)
    case Nil from empty show ?case by (simp add: Dlist.empty_def)
  next
    case (Cons x xs)
    then have "\<not> Dlist.member (Dlist xs) x" and "P (Dlist xs)"
      by (simp_all add: Dlist.member_def List.member_def)
    with insrt have "P (Dlist.insert x (Dlist xs))" .
    with Cons show ?case by (simp add: Dlist.insert_def distinct_remdups_id)
  qed
  with dxs show "P dxs" by simp
qed

lemma dlist_case [cases type: dlist]:
  obtains (empty) "dxs = Dlist.empty"
    | (insert) x dys where "\<not> Dlist.member dys x" and "dxs = Dlist.insert x dys"
proof (cases dxs)
  case (Abs_dlist xs)
  then have dxs: "dxs = Dlist xs" and distinct: "distinct xs"
    by (simp_all add: Dlist_def distinct_remdups_id)
  show thesis
  proof (cases xs)
    case Nil with dxs
    have "dxs = Dlist.empty" by (simp add: Dlist.empty_def)
    with empty show ?thesis .
  next
    case (Cons x xs)
    with dxs distinct have "\<not> Dlist.member (Dlist xs) x"
      and "dxs = Dlist.insert x (Dlist xs)"
      by (simp_all add: Dlist.member_def List.member_def Dlist.insert_def distinct_remdups_id)
    with insert show ?thesis .
  qed
qed

subsection \<open>Functorial structure\<close>

functor map: map
  by (simp_all add: remdups_map_remdups fun_eq_iff dlist_eq_iff)

subsection \<open>Quickcheck generators\<close>

quickcheck_generator dlist predicate: distinct constructors: Dlist.empty, Dlist.insert

subsection \<open>BNF instance\<close>

context begin

qualified fun wpull :: "('a \<times> 'b) list \<Rightarrow> ('b \<times> 'c) list \<Rightarrow> ('a \<times> 'c) list"
where
  "wpull [] ys = []"
| "wpull xs [] = []"
| "wpull ((a, b) # xs) ((b', c) # ys) =
  (if b \<in> snd ` set xs then
     (a, the (map_of (rev ((b', c) # ys)) b)) # wpull xs ((b', c) # ys)
   else if b' \<in> fst ` set ys then
     (the (map_of (map prod.swap (rev ((a, b) # xs))) b'), c) # wpull ((a, b) # xs) ys
   else (a, c) # wpull xs ys)"

qualified lemma wpull_eq_Nil_iff [simp]: "wpull xs ys = [] \<longleftrightarrow> xs = [] \<or> ys = []"
by(cases "(xs, ys)" rule: wpull.cases) simp_all

qualified lemma wpull_induct
  [consumes 1,
   case_names Nil left[xs eq in_set IH] right[xs ys eq in_set IH] step[xs ys eq IH] ]:
  assumes eq: "remdups (map snd xs) = remdups (map fst ys)"
  and Nil: "P [] []"
  and left: "\<And>a b xs b' c ys.
    \<lbrakk> b \<in> snd ` set xs; remdups (map snd xs) = remdups (map fst ((b', c) # ys));
      (b, the (map_of (rev ((b', c) # ys)) b)) \<in> set ((b', c) # ys); P xs ((b', c) # ys) \<rbrakk>
    \<Longrightarrow> P ((a, b) # xs) ((b', c) # ys)"
  and right: "\<And>a b xs b' c ys.
    \<lbrakk> b \<notin> snd ` set xs; b' \<in> fst ` set ys;
      remdups (map snd ((a, b) # xs)) = remdups (map fst ys);
      (the (map_of (map prod.swap (rev ((a, b) #xs))) b'), b') \<in> set ((a, b) # xs);
      P ((a, b) # xs) ys \<rbrakk>
    \<Longrightarrow> P ((a, b) # xs) ((b', c) # ys)"
  and step: "\<And>a b xs c ys.
    \<lbrakk> b \<notin> snd ` set xs; b \<notin> fst ` set ys; remdups (map snd xs) = remdups (map fst ys);
      P xs ys \<rbrakk>
    \<Longrightarrow> P ((a, b) # xs) ((b, c) # ys)"
  shows "P xs ys"
using eq
proof(induction xs ys rule: wpull.induct)
  case 1 thus ?case by(simp add: Nil)
next
  case 2 thus ?case by(simp split: if_split_asm)
next
  case Cons: (3 a b xs b' c ys)
  let ?xs = "(a, b) # xs" and ?ys = "(b', c) # ys"
  consider (xs) "b \<in> snd ` set xs" | (ys) "b \<notin> snd ` set xs" "b' \<in> fst ` set ys"
    | (step) "b \<notin> snd ` set xs" "b' \<notin> fst ` set ys" by auto
  thus ?case
  proof cases
    case xs
    with Cons.prems have eq: "remdups (map snd xs) = remdups (map fst ?ys)" by auto
    from xs eq have "b \<in> fst ` set ?ys" by (metis list.set_map set_remdups)
    hence "map_of (rev ?ys) b \<noteq> None" unfolding map_of_eq_None_iff by auto
    then obtain c' where "map_of (rev ?ys) b = Some c'" by blast
    then have "(b, the (map_of (rev ?ys) b)) \<in> set ?ys" by(auto dest: map_of_SomeD split: if_split_asm)
    from xs eq this Cons.IH(1)[OF xs eq] show ?thesis by(rule left)
  next
    case ys
    from ys Cons.prems have eq: "remdups (map snd ?xs) = remdups (map fst ys)" by auto
    from ys eq have "b' \<in> snd ` set ?xs" by (metis list.set_map set_remdups)
    hence "map_of (map prod.swap (rev ?xs)) b' \<noteq> None"
      unfolding map_of_eq_None_iff by(auto simp add: image_image)
    then obtain a' where "map_of (map prod.swap (rev ?xs)) b' = Some a'" by blast
    then have "(the (map_of (map prod.swap (rev ?xs)) b'), b') \<in> set ?xs"
      by(auto dest: map_of_SomeD split: if_split_asm)
    from ys eq this Cons.IH(2)[OF ys eq] show ?thesis by(rule right)
  next
    case *: step
    hence "remdups (map snd xs) = remdups (map fst ys)" "b = b'" using Cons.prems by auto
    from * this(1) Cons.IH(3)[OF * this(1)] show ?thesis unfolding \<open>b = b'\<close> by(rule step)
  qed
qed

qualified lemma set_wpull_subset:
  assumes "remdups (map snd xs) = remdups (map fst ys)"
  shows "set (wpull xs ys) \<subseteq> set xs O set ys"
using assms by(induction xs ys rule: wpull_induct) auto

qualified lemma set_fst_wpull:
  assumes "remdups (map snd xs) = remdups (map fst ys)"
  shows "fst ` set (wpull xs ys) = fst ` set xs"
using assms by(induction xs ys rule: wpull_induct)(auto intro: rev_image_eqI)

qualified lemma set_snd_wpull:
  assumes "remdups (map snd xs) = remdups (map fst ys)"
  shows "snd ` set (wpull xs ys) = snd ` set ys"
using assms by(induction xs ys rule: wpull_induct)(auto intro: rev_image_eqI)

qualified lemma wpull:
  assumes "distinct xs"
  and "distinct ys"
  and "set xs \<subseteq> {(x, y). R x y}"
  and "set ys \<subseteq> {(x, y). S x y}"
  and eq: "remdups (map snd xs) = remdups (map fst ys)"
  shows "\<exists>zs. distinct zs \<and> set zs \<subseteq> {(x, y). (R OO S) x y} \<and>
         remdups (map fst zs) = remdups (map fst xs) \<and> remdups (map snd zs) = remdups (map snd ys)"
proof(intro exI conjI)
  let ?zs = "remdups (wpull xs ys)"
  show "distinct ?zs" by simp
  show "set ?zs \<subseteq> {(x, y). (R OO S) x y}" using assms(3-4) set_wpull_subset[OF eq] by fastforce
  show "remdups (map fst ?zs) = remdups (map fst xs)" unfolding remdups_map_remdups using eq
    by(induction xs ys rule: wpull_induct)(auto simp add: set_fst_wpull intro: rev_image_eqI)
  show "remdups (map snd ?zs) = remdups (map snd ys)" unfolding remdups_map_remdups using eq
    by(induction xs ys rule: wpull_induct)(auto simp add: set_snd_wpull intro: rev_image_eqI)
qed

qualified lift_definition set :: "'a dlist \<Rightarrow> 'a set" is List.set .

qualified lemma map_transfer [transfer_rule]:
  "(rel_fun (=) (rel_fun (pcr_dlist (=)) (pcr_dlist (=)))) (\<lambda>f x. remdups (List.map f x)) Dlist.map"
by(simp add: rel_fun_def dlist.pcr_cr_eq cr_dlist_def Dlist.map_def remdups_remdups)

bnf "'a dlist"
  map: Dlist.map
  sets: set
  bd: natLeq
  wits: Dlist.empty
unfolding OO_Grp_alt mem_Collect_eq
subgoal by(rule ext)(simp add: dlist_eq_iff)
subgoal by(rule ext)(simp add: dlist_eq_iff remdups_map_remdups)
subgoal by(simp add: dlist_eq_iff set_def cong: list.map_cong)
subgoal by(simp add: set_def fun_eq_iff)
subgoal by(simp add: natLeq_card_order)
subgoal by(simp add: natLeq_cinfinite)
subgoal by(rule ordLess_imp_ordLeq)(simp add: finite_iff_ordLess_natLeq[symmetric] set_def)
subgoal by(rule predicate2I)(transfer; auto simp add: wpull)
subgoal by(simp add: set_def)
done

lifting_update dlist.lifting
lifting_forget dlist.lifting

end

end


(*  Title:      HOL/Matrix_LP/LP.thy
    Author:     Steven Obua
*)

theory LP
imports Main "HOL-Library.Lattice_Algebras"
begin

lemma le_add_right_mono:
  assumes
  "a <= b + (c::'a::ordered_ab_group_add)"
  "c <= d"
  shows "a <= b + d"
  apply (rule_tac order_trans[where y = "b+c"])
  apply (simp_all add: assms)
  done

lemma linprog_dual_estimate:
  assumes
  "A * x \<le> (b::'a::lattice_ring)"
  "0 \<le> y"
  "\<bar>A - A'\<bar> \<le> \<delta>_A"
  "b \<le> b'"
  "\<bar>c - c'\<bar> \<le> \<delta>_c"
  "\<bar>x\<bar> \<le> r"
  shows
  "c * x \<le> y * b' + (y * \<delta>_A + \<bar>y * A' - c'\<bar> + \<delta>_c) * r"
proof -
  from assms have 1: "y * b <= y * b'" by (simp add: mult_left_mono)
  from assms have 2: "y * (A * x) <= y * b" by (simp add: mult_left_mono)
  have 3: "y * (A * x) = c * x + (y * (A - A') + (y * A' - c') + (c'-c)) * x" by (simp add: algebra_simps)
  from 1 2 3 have 4: "c * x + (y * (A - A') + (y * A' - c') + (c'-c)) * x <= y * b'" by simp
  have 5: "c * x <= y * b' + \<bar>(y * (A - A') + (y * A' - c') + (c'-c)) * x\<bar>"
    by (simp only: 4 estimate_by_abs)
  have 6: "\<bar>(y * (A - A') + (y * A' - c') + (c'-c)) * x\<bar> <= \<bar>y * (A - A') + (y * A' - c') + (c'-c)\<bar> * \<bar>x\<bar>"
    by (simp add: abs_le_mult)
  have 7: "(\<bar>y * (A - A') + (y * A' - c') + (c'-c)\<bar>) * \<bar>x\<bar> <= (\<bar>y * (A-A') + (y*A'-c')\<bar> + \<bar>c' - c\<bar>) * \<bar>x\<bar>"
    by(rule abs_triangle_ineq [THEN mult_right_mono]) simp
  have 8: "(\<bar>y * (A-A') + (y*A'-c')\<bar> + \<bar>c' - c\<bar>) * \<bar>x\<bar> <= (\<bar>y * (A-A')\<bar> + \<bar>y*A'-c'\<bar> + \<bar>c' - c\<bar>) * \<bar>x\<bar>"
    by (simp add: abs_triangle_ineq mult_right_mono)
  have 9: "(\<bar>y * (A-A')\<bar> + \<bar>y*A'-c'\<bar> + \<bar>c'-c\<bar>) * \<bar>x\<bar> <= (\<bar>y\<bar> * \<bar>A-A'\<bar> + \<bar>y*A'-c'\<bar> + \<bar>c'-c\<bar>) * \<bar>x\<bar>"
    by (simp add: abs_le_mult mult_right_mono)
  have 10: "c'-c = -(c-c')" by (simp add: algebra_simps)
  have 11: "\<bar>c'-c\<bar> = \<bar>c-c'\<bar>"
    by (subst 10, subst abs_minus_cancel, simp)
  have 12: "(\<bar>y\<bar> * \<bar>A-A'\<bar> + \<bar>y*A'-c'\<bar> + \<bar>c'-c\<bar>) * \<bar>x\<bar> <= (\<bar>y\<bar> * \<bar>A-A'\<bar> + \<bar>y*A'-c'\<bar> + \<delta>_c) * \<bar>x\<bar>"
    by (simp add: 11 assms mult_right_mono)
  have 13: "(\<bar>y\<bar> * \<bar>A-A'\<bar> + \<bar>y*A'-c'\<bar> + \<delta>_c) * \<bar>x\<bar> <= (\<bar>y\<bar> * \<delta>_A + \<bar>y*A'-c'\<bar> + \<delta>_c) * \<bar>x\<bar>"
    by (simp add: assms mult_right_mono mult_left_mono)
  have r: "(\<bar>y\<bar> * \<delta>_A + \<bar>y*A'-c'\<bar> + \<delta>_c) * \<bar>x\<bar> <= (\<bar>y\<bar> * \<delta>_A + \<bar>y*A'-c'\<bar> + \<delta>_c) * r"
    apply (rule mult_left_mono)
    apply (simp add: assms)
    apply (rule_tac add_mono[of "0::'a" _ "0", simplified])+
    apply (rule mult_left_mono[of "0" "\<delta>_A", simplified])
    apply (simp_all)
    apply (rule order_trans[where y="\<bar>A-A'\<bar>"], simp_all add: assms)
    apply (rule order_trans[where y="\<bar>c-c'\<bar>"], simp_all add: assms)
    done
  from 6 7 8 9 12 13 r have 14: "\<bar>(y * (A - A') + (y * A' - c') + (c'-c)) * x\<bar> <= (\<bar>y\<bar> * \<delta>_A + \<bar>y*A'-c'\<bar> + \<delta>_c) * r"
    by (simp)
  show ?thesis
    apply (rule le_add_right_mono[of _ _ "\<bar>(y * (A - A') + (y * A' - c') + (c'-c)) * x\<bar>"])
    apply (simp_all only: 5 14[simplified abs_of_nonneg[of y, simplified assms]])
    done
qed

lemma le_ge_imp_abs_diff_1:
  assumes
  "A1 <= (A::'a::lattice_ring)"
  "A <= A2"
  shows "\<bar>A-A1\<bar> <= A2-A1"
proof -
  have "0 <= A - A1"
  proof -
    from assms add_right_mono [of A1 A "- A1"] show ?thesis by simp
  qed
  then have "\<bar>A-A1\<bar> = A-A1" by (rule abs_of_nonneg)
  with assms show "\<bar>A-A1\<bar> <= (A2-A1)" by simp
qed

lemma mult_le_prts:
  assumes
  "a1 <= (a::'a::lattice_ring)"
  "a <= a2"
  "b1 <= b"
  "b <= b2"
  shows
  "a * b <= pprt a2 * pprt b2 + pprt a1 * nprt b2 + nprt a2 * pprt b1 + nprt a1 * nprt b1"
proof -
  have "a * b = (pprt a + nprt a) * (pprt b + nprt b)"
    apply (subst prts[symmetric])+
    apply simp
    done
  then have "a * b = pprt a * pprt b + pprt a * nprt b + nprt a * pprt b + nprt a * nprt b"
    by (simp add: algebra_simps)
  moreover have "pprt a * pprt b <= pprt a2 * pprt b2"
    by (simp_all add: assms mult_mono)
  moreover have "pprt a * nprt b <= pprt a1 * nprt b2"
  proof -
    have "pprt a * nprt b <= pprt a * nprt b2"
      by (simp add: mult_left_mono assms)
    moreover have "pprt a * nprt b2 <= pprt a1 * nprt b2"
      by (simp add: mult_right_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  moreover have "nprt a * pprt b <= nprt a2 * pprt b1"
  proof -
    have "nprt a * pprt b <= nprt a2 * pprt b"
      by (simp add: mult_right_mono assms)
    moreover have "nprt a2 * pprt b <= nprt a2 * pprt b1"
      by (simp add: mult_left_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  moreover have "nprt a * nprt b <= nprt a1 * nprt b1"
  proof -
    have "nprt a * nprt b <= nprt a * nprt b1"
      by (simp add: mult_left_mono_neg assms)
    moreover have "nprt a * nprt b1 <= nprt a1 * nprt b1"
      by (simp add: mult_right_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  ultimately show ?thesis
    by - (rule add_mono | simp)+
qed

lemma mult_le_dual_prts:
  assumes
  "A * x \<le> (b::'a::lattice_ring)"
  "0 \<le> y"
  "A1 \<le> A"
  "A \<le> A2"
  "c1 \<le> c"
  "c \<le> c2"
  "r1 \<le> x"
  "x \<le> r2"
  shows
  "c * x \<le> y * b + (let s1 = c1 - y * A2; s2 = c2 - y * A1 in pprt s2 * pprt r2 + pprt s1 * nprt r2 + nprt s2 * pprt r1 + nprt s1 * nprt r1)"
  (is "_ <= _ + ?C")
proof -
  from assms have "y * (A * x) <= y * b" by (simp add: mult_left_mono)
  moreover have "y * (A * x) = c * x + (y * A - c) * x" by (simp add: algebra_simps)
  ultimately have "c * x + (y * A - c) * x <= y * b" by simp
  then have "c * x <= y * b - (y * A - c) * x" by (simp add: le_diff_eq)
  then have cx: "c * x <= y * b + (c - y * A) * x" by (simp add: algebra_simps)
  have s2: "c - y * A <= c2 - y * A1"
    by (simp add: assms add_mono mult_left_mono algebra_simps)
  have s1: "c1 - y * A2 <= c - y * A"
    by (simp add: assms add_mono mult_left_mono algebra_simps)
  have prts: "(c - y * A) * x <= ?C"
    apply (simp add: Let_def)
    apply (rule mult_le_prts)
    apply (simp_all add: assms s1 s2)
    done
  then have "y * b + (c - y * A) * x <= y * b + ?C"
    by simp
  with cx show ?thesis
    by(simp only:)
qed

end


section\<open>2.Grammar\<close>

theory grammar
  imports Main
begin

subsection\<open>2.2 formal definition\<close>

subsubsection\<open>definition 2-1\<close>
abbreviation "l_prod p \<equiv> fst p"
abbreviation "r_prod p \<equiv> snd p"

consts isvar :: "'a \<Rightarrow> bool"

locale Grammar =
  fixes V :: "'a set"
  fixes T :: "'a set"
  fixes P :: "('a list \<times> 'a list) set"
  fixes S :: 'a

  fixes isvar :: "'a \<Rightarrow> bool"
  fixes isterminal :: "'a \<Rightarrow> bool"
  assumes "isterminal a \<equiv> \<not> (isvar a)"
  assumes "V \<noteq> {}"
  assumes "T \<noteq> {}"
  assumes "P \<noteq> {}"
  assumes "\<forall>v\<in>V. isvar v"
  assumes "\<forall>t\<in>T. isterminal t"
  assumes "\<forall>p\<in>P. l_prod p \<noteq> [] \<and> (\<exists>i<length (l_prod p). isvar ((l_prod p)!i))"
  assumes "isvar S"
begin

lemma "V \<inter> T = {}"
  by (metis Grammar_axioms Grammar_def disjoint_iff_not_equal)
end

subsubsection\<open>examples\<close>

locale example0

begin

datatype V1 = A | B | C | S | a | b | c
fun isvar1 :: "V1 \<Rightarrow> bool"
  where "isvar1 A = True" | "isvar1 B = True" | "isvar1 C = True" | "isvar1 S = True" | "isvar1 _ = False"

definition isterminal1 :: "V1 \<Rightarrow> bool"
  where "isterminal1 v \<equiv> \<not>isvar1 v"

interpretation Grammar
"{A,B,C,S}"
"{a,b,c}"
"{([A,B], [a,a,A])}"
S
isvar1
"isterminal1"
  apply(rule Grammar.intro) apply(simp add:isterminal1_def)+
  by auto

end

print_dependencies Grammar

subsubsection \<open>definition 2-2\<close>
context Grammar
begin

inductive_set derive_set :: "('a list \<times> 'a list) set"
  and derive :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  and derives :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where
    "derive x y \<equiv> (x,y) \<in> derive_set"
  | "derives x y \<equiv> (x,y) \<in> derive_set\<^sup>*"
  | r_drvset: "\<exists>p\<in>P. \<alpha> = l_prod p \<and> \<beta> = r_prod p \<Longrightarrow> (\<gamma>@\<alpha>@\<delta>,\<gamma>@\<beta>@\<delta>)\<in>derive_set"

inductive_set reduce_set :: "('a list \<times> 'a list) set"
and reduce :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
and reduces :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
    "reduce x y \<equiv> (x,y) \<in> reduce_set"
  | "reduces x y \<equiv> (x,y) \<in> reduce_set\<^sup>*"
  | r_redset: "\<exists>p\<in>P. \<alpha> = l_prod p \<and> \<beta> = r_prod p \<Longrightarrow> (\<gamma>@\<beta>@\<delta>,\<gamma>@\<alpha>@\<delta>)\<in>reduce_set"

lemma "derive x y = reduce y x"
  apply(rule iffI)
    apply(rule derive_set.cases) apply simp
  using reduce_set.r_redset apply auto[1]

  apply(rule reduce_set.cases)
  apply simp
  using derive_set.r_drvset by auto

lemma "derives x y = reduces y x" sorry

end

subsubsection\<open>examples\<close>

context example0
begin

interpretation g1: Grammar
"{A}"
"{a}"
"{([A], [a]),([A],[a,A])}"
A
isvar1
"isterminal1"
  apply(rule Grammar.intro) apply(simp add:isterminal1_def)+ done

lemma "g1.derive [A] [a]"
  using g1.r_drvset[where \<alpha>="[A]" and \<gamma> = "[]" and \<delta>="[]" and \<beta>="[a]"] by simp

lemma "g1.derive [A,A,a,a,A,A,A] [a,A,a,a,A,A,A]"
  using g1.r_drvset[where \<alpha>="[A]" and \<gamma> = "[]" and \<delta>="[A, a, a, A, A, A]" and \<beta>="[a]"] by simp

end

context Grammar
begin

definition allterminals :: "'a list \<Rightarrow> bool"
  where "allterminals w \<equiv> (\<forall>i<length w. isterminal (w!i))"

(* after interpretation, we propage the function ``derives'' to the theory.
here we use local.derives to refer to the definition inner the locale. *)

subsubsection\<open>definition 2-4\<close>
definition sentence_form :: "'a list \<Rightarrow> bool"
  where "sentence_form w \<equiv> (derives [S] w)"

subsubsection\<open>definition 2-3\<close>

definition Lang :: "'a list set"
  where "Lang \<equiv> {w. sentence_form w \<and> allterminals w}"

definition sentence :: "'a list \<Rightarrow> bool"
  where "sentence w \<equiv> (w\<in>Lang)"

end

subsection\<open>2.3 construct syntax\<close>

subsubsection\<open>definition 2-5\<close>
thm Grammar.Lang_def
thm Grammar.intro

locale GrammarEquiv
  fixes
begin
interpretation g1: Grammar
  sorry

thm g1.Lang_def

end

end