(*<*)
theory Itrev
imports Main
begin
declare [[names_unique = false]]
(*>*)

section\<open>Induction Heuristics\<close>

text\<open>\label{sec:InductionHeuristics}
\index{induction heuristics|(}%
The purpose of this section is to illustrate some simple heuristics for
inductive proofs. The first one we have already mentioned in our initial
example:
\begin{quote}
\emph{Theorems about recursive functions are proved by induction.}
\end{quote}
In case the function has more than one argument
\begin{quote}
\emph{Do induction on argument number $i$ if the function is defined by
recursion in argument number $i$.}
\end{quote}
When we look at the proof of \<open>(xs@ys) @ zs = xs @ (ys@zs)\<close>
in \S\ref{sec:intro-proof} we find
\begin{itemize}
\item \<open>@\<close> is recursive in
the first argument
\item \<^term>\<open>xs\<close>  occurs only as the first argument of
\<open>@\<close>
\item both \<^term>\<open>ys\<close> and \<^term>\<open>zs\<close> occur at least once as
the second argument of \<open>@\<close>
\end{itemize}
Hence it is natural to perform induction on~\<^term>\<open>xs\<close>.

The key heuristic, and the main point of this section, is to
\emph{generalize the goal before induction}.
The reason is simple: if the goal is
too specific, the induction hypothesis is too weak to allow the induction
step to go through. Let us illustrate the idea with an example.

Function \cdx{rev} has quadratic worst-case running time
because it calls function \<open>@\<close> for each element of the list and
\<open>@\<close> is linear in its first argument.  A linear time version of
\<^term>\<open>rev\<close> reqires an extra argument where the result is accumulated
gradually, using only~\<open>#\<close>:
\<close>

primrec itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"itrev []     ys = ys" |
"itrev (x#xs) ys = itrev xs (x#ys)"

text\<open>\noindent
The behaviour of \cdx{itrev} is simple: it reverses
its first argument by stacking its elements onto the second argument,
and returning that second argument when the first one becomes
empty. Note that \<^term>\<open>itrev\<close> is tail-recursive: it can be
compiled into a loop.

Naturally, we would like to show that \<^term>\<open>itrev\<close> does indeed reverse
its first argument provided the second one is empty:
\<close>

lemma "itrev xs [] = rev xs"

txt\<open>\noindent
There is no choice as to the induction variable, and we immediately simplify:
\<close>

apply(induct_tac xs, simp_all)

txt\<open>\noindent
Unfortunately, this attempt does not prove
the induction step:
@{subgoals[display,indent=0,margin=70]}
The induction hypothesis is too weak.  The fixed
argument,~\<^term>\<open>[]\<close>, prevents it from rewriting the conclusion.
This example suggests a heuristic:
\begin{quote}\index{generalizing induction formulae}%
\emph{Generalize goals for induction by replacing constants by variables.}
\end{quote}
Of course one cannot do this na\"{\i}vely: \<^term>\<open>itrev xs ys = rev xs\<close> is
just not true.  The correct generalization is
\<close>
(*<*)oops(*>*)
lemma "itrev xs ys = rev xs @ ys"
(*<*)apply(induct_tac xs, simp_all)(*>*)
txt\<open>\noindent
If \<^term>\<open>ys\<close> is replaced by \<^term>\<open>[]\<close>, the right-hand side simplifies to
\<^term>\<open>rev xs\<close>, as required.

In this instance it was easy to guess the right generalization.
Other situations can require a good deal of creativity.

Although we now have two variables, only \<^term>\<open>xs\<close> is suitable for
induction, and we repeat our proof attempt. Unfortunately, we are still
not there:
@{subgoals[display,indent=0,goals_limit=1]}
The induction hypothesis is still too weak, but this time it takes no
intuition to generalize: the problem is that \<^term>\<open>ys\<close> is fixed throughout
the subgoal, but the induction hypothesis needs to be applied with
\<^term>\<open>a # ys\<close> instead of \<^term>\<open>ys\<close>. Hence we prove the theorem
for all \<^term>\<open>ys\<close> instead of a fixed one:
\<close>
(*<*)oops(*>*)
lemma "\<forall>ys. itrev xs ys = rev xs @ ys"
(*<*)
by(induct_tac xs, simp_all)
(*>*)

text\<open>\noindent
This time induction on \<^term>\<open>xs\<close> followed by simplification succeeds. This
leads to another heuristic for generalization:
\begin{quote}
\emph{Generalize goals for induction by universally quantifying all free
variables {\em(except the induction variable itself!)}.}
\end{quote}
This prevents trivial failures like the one above and does not affect the
validity of the goal.  However, this heuristic should not be applied blindly.
It is not always required, and the additional quantifiers can complicate
matters in some cases. The variables that should be quantified are typically
those that change in recursive calls.

A final point worth mentioning is the orientation of the equation we just
proved: the more complex notion (\<^const>\<open>itrev\<close>) is on the left-hand
side, the simpler one (\<^term>\<open>rev\<close>) on the right-hand side. This constitutes
another, albeit weak heuristic that is not restricted to induction:
\begin{quote}
  \emph{The right-hand side of an equation should (in some sense) be simpler
    than the left-hand side.}
\end{quote}
This heuristic is tricky to apply because it is not obvious that
\<^term>\<open>rev xs @ ys\<close> is simpler than \<^term>\<open>itrev xs ys\<close>. But see what
happens if you try to prove \<^prop>\<open>rev xs @ ys = itrev xs ys\<close>!

If you have tried these heuristics and still find your
induction does not go through, and no obvious lemma suggests itself, you may
need to generalize your proposition even further. This requires insight into
the problem at hand and is beyond simple rules of thumb.
Additionally, you can read \S\ref{sec:advanced-ind}
to learn about some advanced techniques for inductive proofs.%
\index{induction heuristics|)}
\<close>
(*<*)
declare [[names_unique = true]]
end
(*>*)


theory BDD
  imports
    Evasive
    ROBDD.Level_Collapse
    ListLexorder
begin

section\<open>Executably converting Simplicial Complexes to BDDs\<close>
text\<open>We already know how to convert a simplicial complex to a boolean function, and that to a BDT.
We could trivially convert convert boolean functions to BDDs the same way they are converted to BDTs,
but the conversion to BDTs necessarily takes an amount of steps exponential in the number of variables (vertices).
The following method avoids this exponential method.\<close>
text\<open>This theory does not include a proof on the run-time complexity of the conversion.\<close>
(* It is still unclear to me whether this whole thing was necessary *)

text \<open>The basic idea is that each vertex in a simplicial complex corresponds to one
  @{term True} line in the truth table of the inducing Boolean function.
This is captured by the following definition, which is part of the correctness assumptions of the final theorem.\<close>
definition bf_from_sc :: "nat set set => (bool vec \<Rightarrow> bool)"
  where "bf_from_sc K \<equiv> (\<lambda>v. {i. i < dim_vec v \<and> \<not> (vec_index v i)} \<in> K)"

lemma bf_from_sc:
  assumes sc: "simplicial_complex.simplicial_complex n K"
  shows "simplicial_complex_induced_by_monotone_boolean_function n (bf_from_sc K) = K"
  unfolding bf_from_sc_def simplicial_complex_induced_by_monotone_boolean_function_def
  using sc
  unfolding simplicial_complex.simplicial_complex_def
  unfolding simplicial_complex.simplices_def
  unfolding ceros_of_boolean_input_def
  by auto (metis ceros_of_boolean_input_def dim_vec sc
      simplicial_complex.ceros_of_boolean_input_in_set simplicial_complex.simplicial_complex_def)

definition boolfunc_from_sc :: "nat => nat set set \<Rightarrow> nat boolfunc"
  where "boolfunc_from_sc n K \<equiv> \<lambda>p. {i. i < n \<and> \<not> p i} \<in> K"

text\<open>The conversion proven correct in two major steps:
\begin{itemize}
\item Prove that we can convert the list form of simplicial complexes to boolean functions instead of the set form (@{text boolfunc_from_sc_list})
\item Prove that we can convert the list form of simplicial complexes to BDDs (@{text boolfunc_bdd_from_sc_list})
\end{itemize}
\<close>

definition "sc_threshold_2_3 \<equiv> {{},{0::nat},{1},{2},{3},{0,1},{0,2},{0,3},{1,2},{1,3},{2,3}}"

text\<open>Example: The truth table (as separate lemmas) for @{const sc_threshold_2_3}:\<close>
lemma hlp1: "{i. i < 4 \<and> \<not> (f(0 := a0, 1 := a1, 2 := a2, 3 := a3)) i} =
  (if a0 then {} else {0::nat})
\<union> (if a1 then {} else {1})
\<union> (if a2 then {} else {2})
\<union> (if a3 then {} else {3})"
  by auto

lemma sc_threshold_2_3_ffff:
  "boolfunc_from_sc 4 sc_threshold_2_3 (a (0:=False,1:=False,2:=False,3:=False)) = False"
  unfolding hlp1 boolfunc_from_sc_def sc_threshold_2_3_def
  by simp (smt (z3) Suc_eq_numeral insert_absorb insert_commute insert_ident
      insert_not_empty numeral_2_eq_2 singleton_inject zero_neq_numeral)

lemma sc_threshold_2_3_ffft:
  "boolfunc_from_sc 4 sc_threshold_2_3 (a(0:=False,1:=False,2:=False,3:=True)) = False"
  unfolding hlp1 boolfunc_from_sc_def sc_threshold_2_3_def
  by simp (smt (z3) Suc_eq_numeral insertI1 insert_absorb insert_commute
      insert_ident insert_not_empty numeral_2_eq_2 singleton_inject zero_neq_numeral)

lemma sc_threshold_2_3_fftf:
  "boolfunc_from_sc 4 sc_threshold_2_3 (a(0:=False,1:=False,2:=True,3:=False)) = False"
  unfolding hlp1 boolfunc_from_sc_def sc_threshold_2_3_def
  by simp (smt (z3) insertI1 insert_iff numeral_1_eq_Suc_0
      numeral_2_eq_2 numeral_eq_iff semiring_norm(86) singleton_iff zero_neq_numeral)

lemma sc_threshold_2_3_ftff:
  "boolfunc_from_sc 4 sc_threshold_2_3 (a(0:=False,1:=True,2:=False,3:=False)) = False"
  unfolding hlp1 boolfunc_from_sc_def sc_threshold_2_3_def
  by simp (smt (verit, ccfv_SIG) insert_absorb insert_iff insert_not_empty
      numeral_eq_iff semiring_norm(89) zero_neq_numeral)

lemma sc_threshold_2_3_tfff:
  "boolfunc_from_sc 4 sc_threshold_2_3 (a(0:=True,1:=False,2:=False,3:=False)) = False"
  unfolding hlp1 boolfunc_from_sc_def sc_threshold_2_3_def
  by simp (smt (z3) eval_nat_numeral(3) insertI1 insert_commute insert_iff
      n_not_Suc_n numeral_1_eq_Suc_0 numeral_2_eq_2
      numeral_eq_iff singletonD verit_eq_simplify(12))

lemma sc_threshold_2_3_fftt:
  "boolfunc_from_sc 4 sc_threshold_2_3 (a(0:=False,1:=False,2:=True,3:=True)) = True"
  unfolding hlp1 boolfunc_from_sc_def sc_threshold_2_3_def by auto

lemma sc_threshold_2_3_ftft:
  "boolfunc_from_sc 4 sc_threshold_2_3 (a(0:=False,1:=True,2:=False,3:=True)) = True"
  unfolding hlp1 boolfunc_from_sc_def sc_threshold_2_3_def by auto

lemma sc_threshold_2_3_fttf:
  "boolfunc_from_sc 4 sc_threshold_2_3 (a(0:=False,1:=True,2:=True,3:=False)) = True"
  unfolding hlp1 boolfunc_from_sc_def sc_threshold_2_3_def by auto

lemma sc_threshold_2_3_fttt:
  "boolfunc_from_sc 4 sc_threshold_2_3 (a(0:=False,1:=True,2:=True,3:=True)) = True"
  unfolding hlp1 boolfunc_from_sc_def sc_threshold_2_3_def by auto

lemma sc_threshold_2_3_tfft:
  "boolfunc_from_sc 4 sc_threshold_2_3 (a(0:=True,1:=False,2:=False,3:=True)) = True"
  unfolding hlp1 boolfunc_from_sc_def sc_threshold_2_3_def by auto

lemma sc_threshold_2_3_tftf:
  "boolfunc_from_sc 4 sc_threshold_2_3 (a(0:=True,1:=False,2:=True,3:=False)) = True"
  unfolding hlp1 boolfunc_from_sc_def sc_threshold_2_3_def by auto

lemma sc_threshold_2_3_tftt:
  "boolfunc_from_sc 4 sc_threshold_2_3 (a(0:=True,1:=False,2:=True,3:=True)) = True"
  unfolding hlp1 boolfunc_from_sc_def sc_threshold_2_3_def by auto

lemma sc_threshold_2_3_ttff:
  "boolfunc_from_sc 4 sc_threshold_2_3 (a(0:=True,1:=True,2:=False,3:=False)) = True"
  unfolding hlp1 boolfunc_from_sc_def sc_threshold_2_3_def by auto

lemma sc_threshold_2_3_ttft:
  "boolfunc_from_sc 4 sc_threshold_2_3 (a(0:=True,1:=True,2:=False,3:=True)) = True"
  unfolding hlp1 boolfunc_from_sc_def sc_threshold_2_3_def by auto

lemma sc_threshold_2_3_tttf:
  "boolfunc_from_sc 4 sc_threshold_2_3 (a(0:=True,1:=True,2:=True,3:=False)) = True "
  unfolding hlp1 boolfunc_from_sc_def sc_threshold_2_3_def by auto

lemma sc_threshold_2_3_tttt:
  "boolfunc_from_sc 4 sc_threshold_2_3 (a(0:=True,1:=True,2:=True,3:=True)) = True "
  unfolding hlp1 boolfunc_from_sc_def sc_threshold_2_3_def by auto

lemma "boolfunc_from_sc n UNIV = bf_True"
  unfolding boolfunc_from_sc_def by simp

lemma "boolfunc_from_sc n {} = bf_False"
  unfolding boolfunc_from_sc_def by simp

text\<open>This may seem like an extra step, but effectively, it means:
  require that all the atoms outside the vertex are true,
  but don't care about what's in the vertex.\<close>

lemma boolfunc_from_sc_lazy:
  "simplicial_complex.simplicial_complex n K
    \<Longrightarrow> boolfunc_from_sc n K = (\<lambda>p. Pow {i. i < n \<and> \<not> p i} \<subseteq> K)"
  unfolding simplicial_complex.simplicial_complex_def boolfunc_from_sc_def
  by auto (* wow *)

primrec boolfunc_from_vertex_list :: "nat list \<Rightarrow> nat list \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> bool"
  where
  "boolfunc_from_vertex_list n [] = bf_True" |
  "boolfunc_from_vertex_list n (f#fs) =
      bf_and (boolfunc_from_vertex_list n fs) (if f \<in> set n then bf_True else bf_lit f)"

lemma boolfunc_from_vertex_list_Cons:
  "boolfunc_from_vertex_list (a # as) lUNIV =
    (\<lambda>v. (boolfunc_from_vertex_list as lUNIV) (v(a:=True)))"
  by (induction lUNIV; simp add: bf_lit_def)

lemma boolfunc_from_vertex_list_Empty:
  "boolfunc_from_vertex_list [] lUNIV = Ball (set lUNIV)"
  by(induction lUNIV) (auto simp add: bf_lit_def)

lemma boolfunc_from_vertex_list:
  "set lUNIV = {..<n} \<Longrightarrow> boolfunc_from_vertex_list a lUNIV = (\<lambda>p. {i. i < n \<and> \<not> p i} \<subseteq> set a)"
  by (induction a; fastforce
        simp add: boolfunc_from_vertex_list_Empty boolfunc_from_vertex_list_Cons)

primrec boolfunc_from_sc_list :: "nat list \<Rightarrow> nat list list \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> bool"
 where
   "boolfunc_from_sc_list lUNIV [] = bf_False" |
   "boolfunc_from_sc_list lUNIV (l#L) =
      bf_or (boolfunc_from_sc_list lUNIV L) (boolfunc_from_vertex_list l lUNIV)"

lemma boolfunc_from_sc_un:
  "boolfunc_from_sc n (a\<union>b) = bf_or (boolfunc_from_sc n a) (boolfunc_from_sc n b)"
  unfolding boolfunc_from_sc_def unfolding bf_or_def bf_ite_def by force

lemma bf_ite_const[simp]: "bf_ite bf_True a b = a" "bf_ite bf_False a b = b"
  by (simp_all)

lemma Pow_subset_Pow: "Pow a \<subseteq> Pow b = (a \<subseteq> b)"
  by blast

lemma boolfunc_from_sc_list_concat:
  "boolfunc_from_sc_list lUNIV (a @ b) =
      bf_or (boolfunc_from_sc_list lUNIV a) (boolfunc_from_sc_list lUNIV b)"
  by (induction a; auto)

lemma boolfunc_from_sc_list_existing_useless:
  "a \<in> set as \<Longrightarrow> boolfunc_from_sc_list l (a # as) = boolfunc_from_sc_list l as"
proof(induction as)
  case (Cons a1s as) then show ?case by (cases "a1s = a"; simp) metis
qed simp

primrec remove :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where
  "remove a [] = []" |
  "remove a (a1 # as) = (if a = a1 then [] else [a1]) @ remove a as"

lemma set_remove[simp]: "set (remove a as) = set as - {a}"
  by(induction as; auto)

lemma remove_concat[simp]: "remove a (a1 @ a2) = remove a a1 @ remove a a2"
  by(induction a1; simp)

lemma boolfunc_from_sc_list_dedup1:
  "boolfunc_from_sc_list l (a # as) = boolfunc_from_sc_list l (a # remove a as)"
proof(induction as)
  case (Cons a1s as) then show ?case by(cases "a1s = a"; simp) metis
qed simp

lemma boolfunc_from_sc_list_reorder:
  "set a = set b \<Longrightarrow> boolfunc_from_sc_list l a = boolfunc_from_sc_list l b"
proof(induction a arbitrary: b)
next
  case (Cons a1 a2)
  then obtain b1 b2 where  b: "b = b1 @ a1 # b2" by (metis list.set_intros(1) split_list)
  have cons_concat: "\<And>a as. a # as = [a] @ as" by simp
  have bb: "boolfunc_from_sc_list l b =
      bf_or (boolfunc_from_vertex_list a1 l)
            (bf_or (boolfunc_from_sc_list l b1) (boolfunc_from_sc_list l b2))"
    apply(subst b)
    apply(subst boolfunc_from_sc_list_concat)
    apply(subst cons_concat)
    apply(subst boolfunc_from_sc_list_concat)
    apply(auto)
    done
  have bbb: "boolfunc_from_sc_list l b = boolfunc_from_sc_list l (a1 # (remove a1 (b1 @ b2)))"
    unfolding bb boolfunc_from_sc_list_dedup1[symmetric]
    by (auto simp add: boolfunc_from_sc_list_concat)
  show ?case proof(cases "a1 \<in> set a2")
    case True
    then show ?thesis using Cons by (metis insert_absorb list.set(2))
  next
    case False
    then have a2: "set a2 = set (remove a1 (b1 @ b2))"
      using Cons.prems b by fastforce
    show ?thesis using  Cons.IH[OF a2] bbb by simp
  qed
qed simp

lemma boolfunc_from_sc_list:
  "set lUNIV = {..<n::nat}
    \<Longrightarrow> simplicial_complex.simplicial_complex n (set ` set L)
      \<Longrightarrow> boolfunc_from_sc_list lUNIV L = boolfunc_from_sc n (set ` set L)"
proof -
  assume lUNIV: "set lUNIV = {..<n::nat}"
  assume sc: "simplicial_complex.simplicial_complex n (set ` set L)"
  define sorted where "sorted \<equiv> sorted_wrt (\<lambda>a b :: nat list. card (set b) \<le> card (set a))"
  (* wlog, assume L is sorted. the price for that was paid in boolfunc_from_sc_list_reorder *)
  have i: "sorted L
            \<Longrightarrow> simplicial_complex.simplicial_complex n (set ` set L)
            \<Longrightarrow> boolfunc_from_sc_list lUNIV L = boolfunc_from_sc n (set ` set L)" for L
  proof(induction L)
    case Nil
    show ?case by (simp add: boolfunc_from_sc_def)
  next
    case (Cons a L)
    from Cons.prems(2) have p: "Pow (set a) \<subseteq> (set ` set (a # L))"
      unfolding simplicial_complex.simplicial_complex_def by simp
    hence pun: "insert (set a) (set ` set L) = Pow (set a) \<union> (set ` set  L)" by auto
    from p and Cons.prems(2)
    have sp: "simplicial_complex.simplicial_complex n (Pow (set a))"
      by (meson PowD Pow_subset_Pow simplicial_complex.simplicial_complex_def subsetD)
    have bfSing: "boolfunc_from_sc_list lUNIV [a] = boolfunc_from_sc n (Pow (set a))"
      unfolding boolfunc_from_sc_lazy [OF sp]
      by (simp add: Pow_subset_Pow boolfunc_from_vertex_list [OF lUNIV])
    have bflCons: "boolfunc_from_sc_list lUNIV (a # L) =
      bf_or (boolfunc_from_sc_list lUNIV [a]) (boolfunc_from_sc_list lUNIV L)"
      unfolding boolfunc_from_sc_list.simps(2) [of _ a L] by auto
    from Cons.prems have "simplicial_complex.simplicial_complex n (set ` set L)"
      unfolding simplicial_complex.simplicial_complex_def sorted_def
      by simp (metis List.finite_set PowD card_seteq insert_image subset_insert)
    from Cons.IH[OF _ this] Cons.prems(1)
    have "boolfunc_from_sc_list lUNIV L = boolfunc_from_sc n (set ` set L)"
      unfolding sorted_def by simp
    thus ?case
      apply(subst bflCons)
      apply(simp del: boolfunc_from_sc_list.simps)
      apply(subst pun)
      apply(subst boolfunc_from_sc_un)
      apply(subst bfSing)
      apply(simp)
      done
  qed
  define sort where "sort \<equiv> rev (sort_key (\<lambda>l. card (set l)) L)"
  have sc: "simplicial_complex.simplicial_complex n (set ` set sort)"
    unfolding sort_def using sc by simp
  have sorted: "sorted sort"
    by(simp add: sorted_def sort_def sorted_wrt_rev) (metis sorted_map sorted_sort_key)
  have set: "set sort = set L" unfolding sort_def by simp
  from boolfunc_from_sc_list_reorder[OF set] i[OF sorted sc] set
  show ?thesis by presburger
qed

lemma boolfunc_from_sc_alt: "boolfunc_from_sc n K = vec_to_boolfunc n (bf_from_sc K)"
  unfolding boolfunc_from_sc_def vec_to_boolfunc_def bf_from_sc_def
  unfolding dim_vec by(fastforce intro!: eqelem_imp_iff)

primrec bdd_from_vertex_list :: "nat list \<Rightarrow> nat list \<Rightarrow> bddi \<Rightarrow> (nat \<times> bddi) Heap"
  where
    "bdd_from_vertex_list n [] s = tci s" |
    "bdd_from_vertex_list n (f#fs) s = do {
      (f, s) \<leftarrow> if f \<in> set n then tci s else litci f s;
      (fs, s) \<leftarrow> bdd_from_vertex_list n fs s;
    andci fs f s
}"

(* You'd guess that andci is commutative, and thus the argument order doesn't matter.
   You'd be wrong. The automation very much doesn't know about that. *)

primrec bdd_from_sc_list :: "nat list \<Rightarrow> nat list list \<Rightarrow> bddi \<Rightarrow> (nat \<times> bddi) Heap"
  where
    "bdd_from_sc_list lUNIV [] s = fci s" |
    "bdd_from_sc_list lUNIV (l#L) s = do {
      (l, s) \<leftarrow> bdd_from_vertex_list l lUNIV s;
      (L, s) \<leftarrow> bdd_from_sc_list lUNIV L s;
      orci L l s
}"

definition "nat_list_from_vertex v \<equiv> sorted_list_of_set v"

definition "nat_list_from_sc K \<equiv> sorted_list_of_list_set (nat_list_from_vertex ` K)"

definition "ex_2_3 \<equiv> do {
  s \<leftarrow> emptyci;
  (ex, s) \<leftarrow> bdd_from_sc_list [0, 1, 2, 3] (nat_list_from_sc sc_threshold_2_3) s;
  graphifyci ''threshold_two_three'' ex s
}"

lemma nat_list_from_vertex:
  assumes "finite l"
  shows "set (nat_list_from_vertex l) = {i . i \<in> l}"
  unfolding nat_list_from_vertex_def sorted_list_of_set_def
  by auto (metis assms set_sorted_list_of_set sorted_list_of_set_def)+

lemma
  finite_sorted_list_of_set:
  assumes "finite L"
  shows "finite (sorted_list_of_set ` L)"
    using finite_imageI [OF assms, of sorted_list_of_set] .

lemma nat_list_from_sc:
  assumes L: "finite L"
  and l: "\<forall>l\<in>L. finite l"
  shows "set ` set (nat_list_from_sc (L :: nat set set)) = {{i . i \<in> l} | l. l \<in>  L}"
  unfolding nat_list_from_sc_def
  unfolding nat_list_from_vertex_def
  unfolding set_sorted_list_of_list_set [OF finite_sorted_list_of_set [OF L]]
proof (safe)
  fix x :: "nat set"
  assume xl: "x \<in> L"
  hence fx: "finite x" using l by simp
  show exl: "\<exists>l. set (sorted_list_of_set x) = {i. i \<in> l} \<and> l \<in> L"
    by (rule exI [of _ x], auto simp add: xl fx)
  show "{i. i \<in> x} \<in> set ` sorted_list_of_set ` L"
    by (metis Collect_mem_eq exl fx image_iff set_sorted_list_of_set)
qed

(* hommm. seeing is believing. how to execute? *)

definition "ex_false \<equiv> do {
  s \<leftarrow> emptyci;
  (ex, s) \<leftarrow> bdd_from_sc_list [0, 1, 2, 3] (nat_list_from_sc {}) s;
  graphifyci ''false'' ex s
}"

definition "ex_true \<equiv> do {
  s \<leftarrow> emptyci;
  (ex, s) \<leftarrow> bdd_from_sc_list [0, 1, 2, 3]
      (nat_list_from_sc
      {{},{0},{1},{2},{3},
       {0,1},{0,2},{0,3},{1,2},{1,3},{2,3},
       {0,1,2},{0,1,3},{0,2,3},{1,2,3},{0,1,2,3}}) s;
  graphifyci ''true'' ex s
}"

definition "another_ex \<equiv> do {
  s \<leftarrow> emptyci;
  (ex, s) \<leftarrow> bdd_from_sc_list [0, 1, 2, 3]
      (nat_list_from_sc
        {{},{0},{1},{2},{3},
         {0,1},{0,2},{0,3},{1,2},{1,3},{2,3},
         {0,1,2},{0,1,3},{0,2,3},{1,2,3}}) s;
  graphifyci ''another_ex'' ex s
}"

definition "one_another_ex \<equiv> do {
  s \<leftarrow> emptyci;
  (ex, s) \<leftarrow> bdd_from_sc_list [0, 1, 2, 3]
            (nat_list_from_sc
            {{},{0},{1},{2},{3},
             {0,1},{0,2},{0,3},{1,2},{1,3},{2,3},
             {0,1,2},{0,1,3},{1,2,3}}) s;
  graphifyci ''one_another_ex'' ex s
}"

lemma bf_ite_direct[simp]: "bf_ite i bf_True bf_False = i" by simp

lemma andciI: "node_relator (tb, tc) rp \<Longrightarrow> node_relator (eb, ec) rp \<Longrightarrow> rq \<subseteq> rp \<Longrightarrow>
      <bdd_relator rp s> andci tc ec s <\<lambda>(r,s'). bdd_relator (insert (bf_and tb eb,r) rq) s'>"
  by sep_auto

lemma bdd_from_vertex_list[sep_heap_rules]:
  shows "<bdd_relator rp s>
    bdd_from_vertex_list n l s
  <\<lambda>(r,s'). bdd_relator (insert (boolfunc_from_vertex_list n l, r) rp) s'>"
proof(induction l arbitrary: rp s)
  case Nil then show ?case by (sep_auto)
next
  case (Cons a l)
  show ?case proof(cases "a \<in> set n")
    case True
    show ?thesis
      apply(simp only: bdd_from_vertex_list.simps list.map
          boolfunc_from_vertex_list.simps True if_True)
      apply(sep_auto simp only:)
       apply(rule Cons.IH)
      apply(clarsimp simp del: bf_ite_def)
      apply(sep_auto)
      done
  next
    case False
    show ?thesis
      apply(simp only: bdd_from_vertex_list.simps list.map
          boolfunc_from_vertex_list.simps False if_False)
      apply(sep_auto simp only:)
       apply(rule Cons.IH)
      apply(sep_auto simp del: bf_ite_def bf_and_def)
    done
  qed
qed

lemma boolfunc_bdd_from_sc_list:
  shows "<bdd_relator rp s>
    bdd_from_sc_list lUNIV K s
  <\<lambda>(r,s'). bdd_relator (insert (boolfunc_from_sc_list lUNIV K, r) rp) s'>"
proof(induction K arbitrary: rp s)
  case Nil
  then show ?case by sep_auto
next
  case (Cons a K)
  show ?case by(sep_auto heap add: Cons.IH simp del: bf_ite_def bf_or_def)
qed

lemma map_map_idI: "(\<And>x. x \<in> \<Union>(set ` set l) \<Longrightarrow> f x = x) \<Longrightarrow> map (map f) l = l"
  by(induct l; simp; meson map_idI)

definition
  "bdd_from_sc K n \<equiv> bdd_from_sc_list (nat_list_from_vertex {..<n}) (nat_list_from_sc K)"

theorem bdd_from_sc:
  assumes "simplicial_complex.simplicial_complex n (K :: nat set set)"
  shows "<bdd_relator rp s>
    bdd_from_sc K n s
  <\<lambda>(r,s'). bdd_relator (insert (vec_to_boolfunc n (bf_from_sc K), r) rp) s'>"
proof -
  have fK: "finite K"
    using simplicial_complex.finite_simplicial_complex [OF assms] .
  have fv: "\<forall>v\<in>K. finite v"
    using simplicial_complex.finite_simplices [OF assms] ..
  define lUNIV where lUNIV_def: "lUNIV = nat_list_from_vertex {..<n}"
  hence set_lUNIV: "set lUNIV = {..<n}"
    unfolding nat_list_from_vertex_def
    using sorted_list_of_set(1) [OF finite_lessThan [of n]] by simp
  define Klist where "Klist \<equiv> (nat_list_from_sc K)"
  have Klist_set: "set ` set Klist = K"
    using nat_list_from_sc [OF fK fv]
    unfolding Klist_def nat_list_from_sc_def nat_list_from_vertex_def by simp
  have Klist_map: "Klist = nat_list_from_sc K"
    unfolding Klist_def ..
  have sc_Klist: "simplicial_complex.simplicial_complex n (set ` set Klist)"
    unfolding Klist_set using assms .
  show ?thesis
    apply (insert boolfunc_bdd_from_sc_list[of rp s lUNIV Klist])
    unfolding bdd_from_sc_def unfolding Klist_def [symmetric]
    unfolding lUNIV_def [symmetric]
    unfolding boolfunc_from_sc_list [OF set_lUNIV sc_Klist]
    unfolding Klist_set
    unfolding boolfunc_from_sc_alt by simp
qed

code_identifier
  code_module Product_Type \<rightharpoonup> (SML) IBDD
    and (OCaml) IBDD and (Haskell) IBDD
  | code_module Typerep \<rightharpoonup> (SML) IBDD
    and (OCaml) IBDD and (Haskell) IBDD
  | code_module String \<rightharpoonup> (SML) IBDD
    and (OCaml) IBDD and (Haskell) IBDD

export_code open bdd_from_sc ex_2_3 ex_false ex_true another_ex one_another_ex
  in Haskell module_name IBDD file BDD

export_code bdd_from_sc ex_2_3 (* I guess this means its actually executable? *)
  in SML module_name IBDD file SMLBDD

end


(*  Title:      HOL/Semiring_Normalization.thy
    Author:     Amine Chaieb, TU Muenchen
*)

section \<open>Semiring normalization\<close>

theory Semiring_Normalization
imports Numeral_Simprocs Nat_Transfer
begin

text \<open>Prelude\<close>

class comm_semiring_1_cancel_crossproduct = comm_semiring_1_cancel +
  assumes crossproduct_eq: "w * y + x * z = w * z + x * y \<longleftrightarrow> w = x \<or> y = z"
begin

lemma crossproduct_noteq:
  "a \<noteq> b \<and> c \<noteq> d \<longleftrightarrow> a * c + b * d \<noteq> a * d + b * c"
  by (simp add: crossproduct_eq)

lemma add_scale_eq_noteq:
  "r \<noteq> 0 \<Longrightarrow> a = b \<and> c \<noteq> d \<Longrightarrow> a + r * c \<noteq> b + r * d"
proof (rule notI)
  assume nz: "r\<noteq> 0" and cnd: "a = b \<and> c\<noteq>d"
    and eq: "a + (r * c) = b + (r * d)"
  have "(0 * d) + (r * c) = (0 * c) + (r * d)"
    using add_left_imp_eq eq mult_zero_left by (simp add: cnd)
  then show False using crossproduct_eq [of 0 d] nz cnd by simp
qed

lemma add_0_iff:
  "b = b + a \<longleftrightarrow> a = 0"
  using add_left_imp_eq [of b a 0] by auto

end

subclass (in idom) comm_semiring_1_cancel_crossproduct
proof
  fix w x y z
  show "w * y + x * z = w * z + x * y \<longleftrightarrow> w = x \<or> y = z"
  proof
    assume "w * y + x * z = w * z + x * y"
    then have "w * y + x * z - w * z - x * y = 0" by (simp add: algebra_simps)
    then have "w * (y - z) - x * (y - z) = 0" by (simp add: algebra_simps)
    then have "(y - z) * (w - x) = 0" by (simp add: algebra_simps)
    then have "y - z = 0 \<or> w - x = 0" by (rule divisors_zero)
    then show "w = x \<or> y = z" by auto
  qed (auto simp add: ac_simps)
qed

instance nat :: comm_semiring_1_cancel_crossproduct
proof
  fix w x y z :: nat
  have aux: "\<And>y z. y < z \<Longrightarrow> w * y + x * z = w * z + x * y \<Longrightarrow> w = x"
  proof -
    fix y z :: nat
    assume "y < z" then have "\<exists>k. z = y + k \<and> k \<noteq> 0" by (intro exI [of _ "z - y"]) auto
    then obtain k where "z = y + k" and "k \<noteq> 0" by blast
    assume "w * y + x * z = w * z + x * y"
    then have "(w * y + x * y) + x * k = (w * y + x * y) + w * k" by (simp add: \<open>z = y + k\<close> algebra_simps)
    then have "x * k = w * k" by simp
    then show "w = x" using \<open>k \<noteq> 0\<close> by simp
  qed
  show "w * y + x * z = w * z + x * y \<longleftrightarrow> w = x \<or> y = z"
    by (auto simp add: neq_iff dest!: aux)
qed

text \<open>Semiring normalization proper\<close>

ML_file "Tools/semiring_normalizer.ML"

context comm_semiring_1
begin

lemma semiring_normalization_rules:
  "(a * m) + (b * m) = (a + b) * m"
  "(a * m) + m = (a + 1) * m"
  "m + (a * m) = (a + 1) * m"
  "m + m = (1 + 1) * m"
  "0 + a = a"
  "a + 0 = a"
  "a * b = b * a"
  "(a + b) * c = (a * c) + (b * c)"
  "0 * a = 0"
  "a * 0 = 0"
  "1 * a = a"
  "a * 1 = a"
  "(lx * ly) * (rx * ry) = (lx * rx) * (ly * ry)"
  "(lx * ly) * (rx * ry) = lx * (ly * (rx * ry))"
  "(lx * ly) * (rx * ry) = rx * ((lx * ly) * ry)"
  "(lx * ly) * rx = (lx * rx) * ly"
  "(lx * ly) * rx = lx * (ly * rx)"
  "lx * (rx * ry) = (lx * rx) * ry"
  "lx * (rx * ry) = rx * (lx * ry)"
  "(a + b) + (c + d) = (a + c) + (b + d)"
  "(a + b) + c = a + (b + c)"
  "a + (c + d) = c + (a + d)"
  "(a + b) + c = (a + c) + b"
  "a + c = c + a"
  "a + (c + d) = (a + c) + d"
  "(x ^ p) * (x ^ q) = x ^ (p + q)"
  "x * (x ^ q) = x ^ (Suc q)"
  "(x ^ q) * x = x ^ (Suc q)"
  "x * x = x\<^sup>2"
  "(x * y) ^ q = (x ^ q) * (y ^ q)"
  "(x ^ p) ^ q = x ^ (p * q)"
  "x ^ 0 = 1"
  "x ^ 1 = x"
  "x * (y + z) = (x * y) + (x * z)"
  "x ^ (Suc q) = x * (x ^ q)"
  "x ^ (2*n) = (x ^ n) * (x ^ n)"
  by (simp_all add: algebra_simps power_add power2_eq_square
    power_mult_distrib power_mult del: one_add_one)

local_setup \<open>
  Semiring_Normalizer.declare @{thm comm_semiring_1_axioms}
    {semiring = ([@{term "x + y"}, @{term "x * y"}, @{term "x ^ n"}, @{term 0}, @{term 1}],
      @{thms semiring_normalization_rules}),
     ring = ([], []),
     field = ([], []),
     idom = [],
     ideal = []}
\<close>

end

context comm_ring_1
begin

lemma ring_normalization_rules:
  "- x = (- 1) * x"
  "x - y = x + (- y)"
  by simp_all

local_setup \<open>
  Semiring_Normalizer.declare @{thm comm_ring_1_axioms}
    {semiring = ([@{term "x + y"}, @{term "x * y"}, @{term "x ^ n"}, @{term 0}, @{term 1}],
      @{thms semiring_normalization_rules}),
      ring = ([@{term "x - y"}, @{term "- x"}], @{thms ring_normalization_rules}),
      field = ([], []),
      idom = [],
      ideal = []}
\<close>

end

context comm_semiring_1_cancel_crossproduct
begin

local_setup \<open>
  Semiring_Normalizer.declare @{thm comm_semiring_1_cancel_crossproduct_axioms}
    {semiring = ([@{term "x + y"}, @{term "x * y"}, @{term "x ^ n"}, @{term 0}, @{term 1}],
      @{thms semiring_normalization_rules}),
     ring = ([], []),
     field = ([], []),
     idom = @{thms crossproduct_noteq add_scale_eq_noteq},
     ideal = []}
\<close>

end

context idom
begin

local_setup \<open>
  Semiring_Normalizer.declare @{thm idom_axioms}
   {semiring = ([@{term "x + y"}, @{term "x * y"}, @{term "x ^ n"}, @{term 0}, @{term 1}],
      @{thms semiring_normalization_rules}),
    ring = ([@{term "x - y"}, @{term "- x"}], @{thms ring_normalization_rules}),
    field = ([], []),
    idom = @{thms crossproduct_noteq add_scale_eq_noteq},
    ideal = @{thms right_minus_eq add_0_iff}}
\<close>

end

context field
begin

local_setup \<open>
  Semiring_Normalizer.declare @{thm field_axioms}
   {semiring = ([@{term "x + y"}, @{term "x * y"}, @{term "x ^ n"}, @{term 0}, @{term 1}],
      @{thms semiring_normalization_rules}),
    ring = ([@{term "x - y"}, @{term "- x"}], @{thms ring_normalization_rules}),
    field = ([@{term "x / y"}, @{term "inverse x"}], @{thms divide_inverse inverse_eq_divide}),
    idom = @{thms crossproduct_noteq add_scale_eq_noteq},
    ideal = @{thms right_minus_eq add_0_iff}}
\<close>

end

code_identifier
  code_module Semiring_Normalization \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith

end


(*  Title:      HOL/ex/Seq.thy
    Author:     Makarius
*)

section \<open>Finite sequences\<close>

theory Seq
imports Main
begin

datatype 'a seq = Empty | Seq 'a "'a seq"

fun conc :: "'a seq \<Rightarrow> 'a seq \<Rightarrow> 'a seq"
where
  "conc Empty ys = ys"
| "conc (Seq x xs) ys = Seq x (conc xs ys)"

fun reverse :: "'a seq \<Rightarrow> 'a seq"
where
  "reverse Empty = Empty"
| "reverse (Seq x xs) = conc (reverse xs) (Seq x Empty)"

lemma conc_empty: "conc xs Empty = xs"
  by (induct xs) simp_all

lemma conc_assoc: "conc (conc xs ys) zs = conc xs (conc ys zs)"
  by (induct xs) simp_all

lemma reverse_conc: "reverse (conc xs ys) = conc (reverse ys) (reverse xs)"
  by (induct xs) (simp_all add: conc_empty conc_assoc)

lemma reverse_reverse: "reverse (reverse xs) = xs"
  by (induct xs) (simp_all add: reverse_conc)

end


(*  Title:      HOL/Algebra/QuotRing.thy
    Author:     Stephan Hohe
    Author:     Paulo Emílio de Vilhena
*)

theory QuotRing
imports RingHom
begin

section \<open>Quotient Rings\<close>

subsection \<open>Multiplication on Cosets\<close>

definition rcoset_mult :: "[('a, _) ring_scheme, 'a set, 'a set, 'a set] \<Rightarrow> 'a set"
    ("[mod _:] _ \<Otimes>\<index> _" [81,81,81] 80)
  where "rcoset_mult R I A B = (\<Union>a\<in>A. \<Union>b\<in>B. I +>\<^bsub>R\<^esub> (a \<otimes>\<^bsub>R\<^esub> b))"

text \<open>\<^const>\<open>rcoset_mult\<close> fulfils the properties required by congruences\<close>
lemma (in ideal) rcoset_mult_add:
  assumes "x \<in> carrier R" "y \<in> carrier R"
  shows "[mod I:] (I +> x) \<Otimes> (I +> y) = I +> (x \<otimes> y)"
proof -
  have 1: "z \<in> I +> x \<otimes> y"
    if x'rcos: "x' \<in> I +> x" and y'rcos: "y' \<in> I +> y" and zrcos: "z \<in> I +> x' \<otimes> y'" for z x' y'
  proof -
    from that
    obtain hx hy hz where hxI: "hx \<in> I" and x': "x' = hx \<oplus> x" and hyI: "hy \<in> I" and y': "y' = hy \<oplus> y"
      and hzI: "hz \<in> I" and z: "z = hz \<oplus> (x' \<otimes> y')"
      by (auto simp: a_r_coset_def r_coset_def)
    note carr = assms hxI[THEN a_Hcarr] hyI[THEN a_Hcarr] hzI[THEN a_Hcarr]
    from z  x' y' have "z = hz \<oplus> ((hx \<oplus> x) \<otimes> (hy \<oplus> y))" by simp
    also from carr have "\<dots> = (hz \<oplus> (hx \<otimes> (hy \<oplus> y)) \<oplus> x \<otimes> hy) \<oplus> x \<otimes> y" by algebra
    finally have z2: "z = (hz \<oplus> (hx \<otimes> (hy \<oplus> y)) \<oplus> x \<otimes> hy) \<oplus> x \<otimes> y" .
    from hxI hyI hzI carr have "hz \<oplus> (hx \<otimes> (hy \<oplus> y)) \<oplus> x \<otimes> hy \<in> I"
      by (simp add: I_l_closed I_r_closed)
    with z2 show ?thesis
      by (auto simp add: a_r_coset_def r_coset_def)
  qed
  have 2: "\<exists>a\<in>I +> x. \<exists>b\<in>I +> y. z \<in> I +> a \<otimes> b" if "z \<in> I +> x \<otimes> y" for z
    using assms a_rcos_self that by blast
  show ?thesis
    unfolding rcoset_mult_def using assms
    by (auto simp: intro!: 1 2)
qed

subsection \<open>Quotient Ring Definition\<close>

definition FactRing :: "[('a,'b) ring_scheme, 'a set] \<Rightarrow> ('a set) ring"
    (infixl "Quot" 65)
  where "FactRing R I =
    \<lparr>carrier = a_rcosets\<^bsub>R\<^esub> I, mult = rcoset_mult R I,
      one = (I +>\<^bsub>R\<^esub> \<one>\<^bsub>R\<^esub>), zero = I, add = set_add R\<rparr>"

lemmas FactRing_simps = FactRing_def A_RCOSETS_defs a_r_coset_def[symmetric]

subsection \<open>Factorization over General Ideals\<close>

text \<open>The quotient is a ring\<close>
lemma (in ideal) quotient_is_ring: "ring (R Quot I)"
proof (rule ringI)
  show "abelian_group (R Quot I)"
    apply (rule comm_group_abelian_groupI)
    apply (simp add: FactRing_def a_factorgroup_is_comm_group[unfolded A_FactGroup_def'])
    done
  show "Group.monoid (R Quot I)"
    by (rule monoidI)
      (auto simp add: FactRing_simps rcoset_mult_add m_assoc)
qed (auto simp: FactRing_simps rcoset_mult_add a_rcos_sum l_distr r_distr)

text \<open>This is a ring homomorphism\<close>

lemma (in ideal) rcos_ring_hom: "((+>) I) \<in> ring_hom R (R Quot I)"
  by (simp add: ring_hom_memI FactRing_def a_rcosetsI[OF a_subset] rcoset_mult_add a_rcos_sum)

lemma (in ideal) rcos_ring_hom_ring: "ring_hom_ring R (R Quot I) ((+>) I)"
  by (simp add: local.ring_axioms quotient_is_ring rcos_ring_hom ring_hom_ringI2)

text \<open>The quotient of a cring is also commutative\<close>
lemma (in ideal) quotient_is_cring:
  assumes "cring R"
  shows "cring (R Quot I)"
proof -
  interpret cring R by fact
  show ?thesis
    apply (intro cring.intro comm_monoid.intro comm_monoid_axioms.intro quotient_is_ring)
     apply (rule ring.axioms[OF quotient_is_ring])
    apply (auto simp add: FactRing_simps rcoset_mult_add m_comm)
    done
qed

text \<open>Cosets as a ring homomorphism on crings\<close>
lemma (in ideal) rcos_ring_hom_cring:
  assumes "cring R"
  shows "ring_hom_cring R (R Quot I) ((+>) I)"
proof -
  interpret cring R by fact
  show ?thesis
    apply (rule ring_hom_cringI)
      apply (rule rcos_ring_hom_ring)
     apply (rule is_cring)
    apply (rule quotient_is_cring)
   apply (rule is_cring)
   done
qed

subsection \<open>Factorization over Prime Ideals\<close>

text \<open>The quotient ring generated by a prime ideal is a domain\<close>
lemma (in primeideal) quotient_is_domain: "domain (R Quot I)"
proof -
  have 1: "I +> \<one> = I \<Longrightarrow> False"
    using I_notcarr a_rcos_self one_imp_carrier by blast
  have 2: "I +> x = I"
    if  carr: "x \<in> carrier R" "y \<in> carrier R"
    and a: "I +> x \<otimes> y = I"
    and b: "I +> y \<noteq> I" for x y
    by (metis I_prime a a_rcos_const a_rcos_self b m_closed that)
  show ?thesis
    apply (intro domain.intro quotient_is_cring is_cring domain_axioms.intro)
     apply (metis "1" FactRing_def monoid.simps(2) ring.simps(1))
    apply (simp add: FactRing_simps)
    by (metis "2" rcoset_mult_add)
qed

text \<open>Generating right cosets of a prime ideal is a homomorphism
        on commutative rings\<close>
lemma (in primeideal) rcos_ring_hom_cring: "ring_hom_cring R (R Quot I) ((+>) I)"
  by (rule rcos_ring_hom_cring) (rule is_cring)

subsection \<open>Factorization over Maximal Ideals\<close>

text \<open>In a commutative ring, the quotient ring over a maximal ideal is a field.
        The proof follows ``W. Adkins, S. Weintraub: Algebra -- An Approach via Module Theory''\<close>
proposition (in maximalideal) quotient_is_field:
  assumes "cring R"
  shows "field (R Quot I)"
proof -
  interpret cring R by fact
  have 1: "\<zero>\<^bsub>R Quot I\<^esub> \<noteq> \<one>\<^bsub>R Quot I\<^esub>"  \<comment> \<open>Quotient is not empty\<close>
  proof
    assume "\<zero>\<^bsub>R Quot I\<^esub> = \<one>\<^bsub>R Quot I\<^esub>"
    then have II1: "I = I +> \<one>" by (simp add: FactRing_def)
    then have "I = carrier R"
      using a_rcos_self one_imp_carrier by blast
    with I_notcarr show False by simp
  qed
  have 2: "\<exists>y\<in>carrier R. I +> a \<otimes> y = I +> \<one>" if IanI: "I +> a \<noteq> I" and acarr: "a \<in> carrier R" for a
    \<comment> \<open>Existence of Inverse\<close>
  proof -
    \<comment> \<open>Helper ideal \<open>J\<close>\<close>
    define J :: "'a set" where "J = (carrier R #> a) <+> I"
    have idealJ: "ideal J R"
      using J_def acarr add_ideals cgenideal_eq_rcos cgenideal_ideal is_ideal by auto
    have IinJ: "I \<subseteq> J"
    proof (clarsimp simp: J_def r_coset_def set_add_defs)
      fix x
      assume xI: "x \<in> I"
      have "x = \<zero> \<otimes> a \<oplus> x"
        by (simp add: acarr xI)
      with xI show "\<exists>xa\<in>carrier R. \<exists>k\<in>I. x = xa \<otimes> a \<oplus> k" by fast
    qed
    have JnI: "J \<noteq> I"
    proof -
      have "a \<notin> I"
        using IanI a_rcos_const by blast
      moreover have "a \<in> J"
      proof (simp add: J_def r_coset_def set_add_defs)
        from acarr
        have "a = \<one> \<otimes> a \<oplus> \<zero>" by algebra
        with one_closed and additive_subgroup.zero_closed[OF is_additive_subgroup]
        show "\<exists>x\<in>carrier R. \<exists>k\<in>I. a = x \<otimes> a \<oplus> k" by fast
      qed
      ultimately show ?thesis by blast
    qed
    then have Jcarr: "J = carrier R"
      using I_maximal IinJ additive_subgroup.a_subset idealJ ideal_def by blast

    \<comment> \<open>Calculating an inverse for \<^term>\<open>a\<close>\<close>
    from one_closed[folded Jcarr]
    obtain r i where rcarr: "r \<in> carrier R"
      and iI: "i \<in> I" and one: "\<one> = r \<otimes> a \<oplus> i"
      by (auto simp add: J_def r_coset_def set_add_defs)

    from one and rcarr and acarr and iI[THEN a_Hcarr]
    have rai1: "a \<otimes> r = \<ominus>i \<oplus> \<one>" by algebra

    \<comment> \<open>Lifting to cosets\<close>
    from iI have "\<ominus>i \<oplus> \<one> \<in> I +> \<one>"
      by (intro a_rcosI, simp, intro a_subset, simp)
    with rai1 have "a \<otimes> r \<in> I +> \<one>" by simp
    then have "I +> \<one> = I +> a \<otimes> r"
      by (rule a_repr_independence, simp) (rule a_subgroup)

    from rcarr and this[symmetric]
    show "\<exists>r\<in>carrier R. I +> a \<otimes> r = I +> \<one>" by fast
  qed
  show ?thesis
    apply (intro cring.cring_fieldI2 quotient_is_cring is_cring 1)
     apply (clarsimp simp add: FactRing_simps rcoset_mult_add 2)
    done
qed

lemma (in ring_hom_ring) trivial_hom_iff:
  "(h ` (carrier R) = { \<zero>\<^bsub>S\<^esub> }) = (a_kernel R S h = carrier R)"
  using group_hom.trivial_hom_iff[OF a_group_hom] by (simp add: a_kernel_def)

lemma (in ring_hom_ring) trivial_ker_imp_inj:
  assumes "a_kernel R S h = { \<zero> }"
  shows "inj_on h (carrier R)"
  using group_hom.trivial_ker_imp_inj[OF a_group_hom] assms a_kernel_def[of R S h] by simp

(* NEW ========================================================================== *)
lemma (in ring_hom_ring) inj_iff_trivial_ker:
  shows "inj_on h (carrier R) \<longleftrightarrow> a_kernel R S h = { \<zero> }"
  using group_hom.inj_iff_trivial_ker[OF a_group_hom] a_kernel_def[of R S h] by simp

(* NEW ========================================================================== *)
corollary ring_hom_in_hom:
  assumes "h \<in> ring_hom R S" shows "h \<in> hom R S" and "h \<in> hom (add_monoid R) (add_monoid S)"
  using assms unfolding ring_hom_def hom_def by auto

(* NEW ========================================================================== *)
corollary set_add_hom:
  assumes "h \<in> ring_hom R S" "I \<subseteq> carrier R" and "J \<subseteq> carrier R"
  shows "h ` (I <+>\<^bsub>R\<^esub> J) = h ` I <+>\<^bsub>S\<^esub> h ` J"
  using set_mult_hom[OF ring_hom_in_hom(2)[OF assms(1)]] assms(2-3)
  unfolding a_kernel_def[of R S h] set_add_def by simp

(* NEW ========================================================================== *)
corollary a_coset_hom:
  assumes "h \<in> ring_hom R S" "I \<subseteq> carrier R" "a \<in> carrier R"
  shows "h ` (a <+\<^bsub>R\<^esub> I) = h a <+\<^bsub>S\<^esub> (h ` I)" and "h ` (I +>\<^bsub>R\<^esub> a) = (h ` I) +>\<^bsub>S\<^esub> h a"
  using assms coset_hom[OF ring_hom_in_hom(2)[OF assms(1)], of I a]
  unfolding a_l_coset_def l_coset_eq_set_mult
            a_r_coset_def r_coset_eq_set_mult
  by simp_all

(* NEW ========================================================================== *)
corollary (in ring_hom_ring) set_add_ker_hom:
  assumes "I \<subseteq> carrier R"
  shows "h ` (I <+> (a_kernel R S h)) = h ` I" and "h ` ((a_kernel R S h) <+> I) = h ` I"
  using group_hom.set_mult_ker_hom[OF a_group_hom] assms
  unfolding a_kernel_def[of R S h] set_add_def by simp+

lemma (in ring_hom_ring) non_trivial_field_hom_imp_inj:
  assumes "field R"
  shows "h ` (carrier R) \<noteq> { \<zero>\<^bsub>S\<^esub> } \<Longrightarrow> inj_on h (carrier R)"
proof -
  assume "h ` (carrier R) \<noteq> { \<zero>\<^bsub>S\<^esub> }"
  hence "a_kernel R S h \<noteq> carrier R"
    using trivial_hom_iff by linarith
  hence "a_kernel R S h = { \<zero> }"
    using field.all_ideals[OF assms] kernel_is_ideal by blast
  thus "inj_on h (carrier R)"
    using trivial_ker_imp_inj by blast
qed
lemma "field R \<Longrightarrow> cring R"
  using fieldE(1) by blast

lemma non_trivial_field_hom_is_inj:
  assumes "h \<in> ring_hom R S" and "field R" and "field S" shows "inj_on h (carrier R)"
proof -
  interpret ring_hom_cring R S h
    using assms(1) ring_hom_cring.intro[OF assms(2-3)[THEN fieldE(1)]]
    unfolding symmetric[OF ring_hom_cring_axioms_def] by simp

  have "h \<one>\<^bsub>R\<^esub> = \<one>\<^bsub>S\<^esub>" and "\<one>\<^bsub>S\<^esub> \<noteq> \<zero>\<^bsub>S\<^esub>"
    using domain.one_not_zero[OF field.axioms(1)[OF assms(3)]] by auto
  hence "h ` (carrier R) \<noteq> { \<zero>\<^bsub>S\<^esub> }"
    using ring.kernel_zero ring.trivial_hom_iff by fastforce
  thus ?thesis
    using ring.non_trivial_field_hom_imp_inj[OF assms(2)] by simp
qed

lemma (in ring_hom_ring) img_is_add_subgroup:
  assumes "subgroup H (add_monoid R)"
  shows "subgroup (h ` H) (add_monoid S)"
proof -
  have "group ((add_monoid R) \<lparr> carrier := H \<rparr>)"
    using assms R.add.subgroup_imp_group by blast
  moreover have "H \<subseteq> carrier R" by (simp add: R.add.subgroupE(1) assms)
  hence "h \<in> hom ((add_monoid R) \<lparr> carrier := H \<rparr>) (add_monoid S)"
    unfolding hom_def by (auto simp add: subsetD)
  ultimately have "subgroup (h ` carrier ((add_monoid R) \<lparr> carrier := H \<rparr>)) (add_monoid S)"
    using group_hom.img_is_subgroup[of "(add_monoid R) \<lparr> carrier := H \<rparr>" "add_monoid S" h]
    using a_group_hom group_hom_axioms.intro group_hom_def by blast
  thus "subgroup (h ` H) (add_monoid S)" by simp
qed

lemma (in ring) ring_ideal_imp_quot_ideal:
  assumes "ideal I R"
  shows "ideal J R \<Longrightarrow> ideal ((+>) I ` J) (R Quot I)"
proof -
  assume A: "ideal J R" show "ideal (((+>) I) ` J) (R Quot I)"
  proof (rule idealI)
    show "ring (R Quot I)"
      by (simp add: assms(1) ideal.quotient_is_ring)
  next
    have "subgroup J (add_monoid R)"
      by (simp add: additive_subgroup.a_subgroup A ideal.axioms(1))
    moreover have "((+>) I) \<in> ring_hom R (R Quot I)"
      by (simp add: assms(1) ideal.rcos_ring_hom)
    ultimately show "subgroup ((+>) I ` J) (add_monoid (R Quot I))"
      using assms(1) ideal.rcos_ring_hom_ring ring_hom_ring.img_is_add_subgroup by blast
  next
    fix a x assume "a \<in> (+>) I ` J" "x \<in> carrier (R Quot I)"
    then obtain i j where i: "i \<in> carrier R" "x = I +> i"
                      and j: "j \<in> J" "a = I +> j"
      unfolding FactRing_def using A_RCOSETS_def'[of R I] by auto
    hence "a \<otimes>\<^bsub>R Quot I\<^esub> x = [mod I:] (I +> j) \<Otimes> (I +> i)"
      unfolding FactRing_def by simp
    hence "a \<otimes>\<^bsub>R Quot I\<^esub> x = I +> (j \<otimes> i)"
      using ideal.rcoset_mult_add[OF assms(1), of j i] i(1) j(1) A ideal.Icarr by force
    thus "a \<otimes>\<^bsub>R Quot I\<^esub> x \<in> (+>) I ` J"
      using A i(1) j(1) by (simp add: ideal.I_r_closed)

    have "x \<otimes>\<^bsub>R Quot I\<^esub> a = [mod I:] (I +> i) \<Otimes> (I +> j)"
      unfolding FactRing_def i j by simp
    hence "x \<otimes>\<^bsub>R Quot I\<^esub> a = I +> (i \<otimes> j)"
      using ideal.rcoset_mult_add[OF assms(1), of i j] i(1) j(1) A ideal.Icarr by force
    thus "x \<otimes>\<^bsub>R Quot I\<^esub> a \<in> (+>) I ` J"
      using A i(1) j(1) by (simp add: ideal.I_l_closed)
  qed
qed

lemma (in ring_hom_ring) ideal_vimage:
  assumes "ideal I S"
  shows "ideal { r \<in> carrier R. h r \<in> I } R" (* or (carrier R) \<inter> (h -` I) *)
proof
  show "{ r \<in> carrier R. h r \<in> I } \<subseteq> carrier (add_monoid R)" by auto
next
  show "\<one>\<^bsub>add_monoid R\<^esub> \<in> { r \<in> carrier R. h r \<in> I }"
    by (simp add: additive_subgroup.zero_closed assms ideal.axioms(1))
next
  fix a b
  assume "a \<in> { r \<in> carrier R. h r \<in> I }"
     and "b \<in> { r \<in> carrier R. h r \<in> I }"
  hence a: "a \<in> carrier R" "h a \<in> I"
    and b: "b \<in> carrier R" "h b \<in> I" by auto
  hence "h (a \<oplus> b) = (h a) \<oplus>\<^bsub>S\<^esub> (h b)" using hom_add by blast
  moreover have "(h a) \<oplus>\<^bsub>S\<^esub> (h b) \<in> I" using a b assms
    by (simp add: additive_subgroup.a_closed ideal.axioms(1))
  ultimately show "a \<otimes>\<^bsub>add_monoid R\<^esub> b \<in> { r \<in> carrier R. h r \<in> I }"
    using a(1) b (1) by auto

  have "h (\<ominus> a) = \<ominus>\<^bsub>S\<^esub> (h a)" by (simp add: a)
  moreover have "\<ominus>\<^bsub>S\<^esub> (h a) \<in> I"
    by (simp add: a(2) additive_subgroup.a_inv_closed assms ideal.axioms(1))
  ultimately show "inv\<^bsub>add_monoid R\<^esub> a \<in> { r \<in> carrier R. h r \<in> I }"
    using a by (simp add: a_inv_def)
next
  fix a r
  assume "a \<in> { r \<in> carrier R. h r \<in> I }" and r: "r \<in> carrier R"
  hence a: "a \<in> carrier R" "h a \<in> I" by auto

  have "h a \<otimes>\<^bsub>S\<^esub> h r \<in> I"
    using assms a r by (simp add: ideal.I_r_closed)
  thus "a \<otimes> r \<in> { r \<in> carrier R. h r \<in> I }" by (simp add: a(1) r)

  have "h r \<otimes>\<^bsub>S\<^esub> h a \<in> I"
    using assms a r by (simp add: ideal.I_l_closed)
  thus "r \<otimes> a \<in> { r \<in> carrier R. h r \<in> I }" by (simp add: a(1) r)
qed

lemma (in ring) canonical_proj_vimage_in_carrier:
  assumes "ideal I R"
  shows "J \<subseteq> carrier (R Quot I) \<Longrightarrow> \<Union> J \<subseteq> carrier R"
proof -
  assume A: "J \<subseteq> carrier (R Quot I)" show "\<Union> J \<subseteq> carrier R"
  proof
    fix j assume j: "j \<in> \<Union> J"
    then obtain j' where j': "j' \<in> J" "j \<in> j'" by blast
    then obtain r where r: "r \<in> carrier R" "j' = I +> r"
      using A j' unfolding FactRing_def using A_RCOSETS_def'[of R I] by auto
    thus "j \<in> carrier R" using j' assms
      by (meson a_r_coset_subset_G additive_subgroup.a_subset contra_subsetD ideal.axioms(1))
  qed
qed

lemma (in ring) canonical_proj_vimage_mem_iff:
  assumes "ideal I R" "J \<subseteq> carrier (R Quot I)"
  shows "\<And>a. a \<in> carrier R \<Longrightarrow> (a \<in> (\<Union> J)) = (I +> a \<in> J)"
proof -
  fix a assume a: "a \<in> carrier R" show "(a \<in> (\<Union> J)) = (I +> a \<in> J)"
  proof
    assume "a \<in> \<Union> J"
    then obtain j where j: "j \<in> J" "a \<in> j" by blast
    then obtain r where r: "r \<in> carrier R" "j = I +> r"
      using assms j unfolding FactRing_def using A_RCOSETS_def'[of R I] by auto
    hence "I +> r = I +> a"
      using add.repr_independence[of a I r] j r
      by (metis a_r_coset_def additive_subgroup.a_subgroup assms(1) ideal.axioms(1))
    thus "I +> a \<in> J" using r j by simp
  next
    assume "I +> a \<in> J"
    hence "\<zero> \<oplus> a \<in> I +> a"
      using additive_subgroup.zero_closed[OF ideal.axioms(1)[OF assms(1)]]
            a_r_coset_def'[of R I a] by blast
    thus "a \<in> \<Union> J" using a \<open>I +> a \<in> J\<close> by auto
  qed
qed

corollary (in ring) quot_ideal_imp_ring_ideal:
  assumes "ideal I R"
  shows "ideal J (R Quot I) \<Longrightarrow> ideal (\<Union> J) R"
proof -
  assume A: "ideal J (R Quot I)"
  have "\<Union> J = { r \<in> carrier R. I +> r \<in> J }"
    using canonical_proj_vimage_in_carrier[OF assms, of J]
          canonical_proj_vimage_mem_iff[OF assms, of J]
          additive_subgroup.a_subset[OF ideal.axioms(1)[OF A]] by blast
  thus "ideal (\<Union> J) R"
    using ring_hom_ring.ideal_vimage[OF ideal.rcos_ring_hom_ring[OF assms] A] by simp
qed

lemma (in ring) ideal_incl_iff:
  assumes "ideal I R" "ideal J R"
  shows "(I \<subseteq> J) = (J = (\<Union> j \<in> J. I +> j))"
proof
  assume A: "J = (\<Union> j \<in> J. I +> j)" hence "I +> \<zero> \<subseteq> J"
    using additive_subgroup.zero_closed[OF ideal.axioms(1)[OF assms(2)]] by blast
  thus "I \<subseteq> J" using additive_subgroup.a_subset[OF ideal.axioms(1)[OF assms(1)]] by simp
next
  assume A: "I \<subseteq> J" show "J = (\<Union>j\<in>J. I +> j)"
  proof
    show "J \<subseteq> (\<Union> j \<in> J. I +> j)"
    proof
      fix j assume j: "j \<in> J"
      have "\<zero> \<in> I" by (simp add: additive_subgroup.zero_closed assms(1) ideal.axioms(1))
      hence "\<zero> \<oplus> j \<in> I +> j"
        using a_r_coset_def'[of R I j] by blast
      thus "j \<in> (\<Union>j\<in>J. I +> j)"
        using assms(2) j additive_subgroup.a_Hcarr ideal.axioms(1) by fastforce
    qed
  next
    show "(\<Union> j \<in> J. I +> j) \<subseteq> J"
    proof
      fix x assume "x \<in> (\<Union> j \<in> J. I +> j)"
      then obtain j where j: "j \<in> J" "x \<in> I +> j" by blast
      then obtain i where i: "i \<in> I" "x = i \<oplus> j"
        using a_r_coset_def'[of R I j] by blast
      thus "x \<in> J"
        using assms(2) j A additive_subgroup.a_closed[OF ideal.axioms(1)[OF assms(2)]] by blast
    qed
  qed
qed

theorem (in ring) quot_ideal_correspondence:
  assumes "ideal I R"
  shows "bij_betw (\<lambda>J. (+>) I ` J) { J. ideal J R \<and> I \<subseteq> J } { J . ideal J (R Quot I) }"
proof (rule bij_betw_byWitness[where ?f' = "\<lambda>X. \<Union> X"])
  show "\<forall>J \<in> { J. ideal J R \<and> I \<subseteq> J }. (\<lambda>X. \<Union> X) ((+>) I ` J) = J"
    using assms ideal_incl_iff by blast
next
  show "(\<lambda>J. (+>) I ` J) ` { J. ideal J R \<and> I \<subseteq> J } \<subseteq> { J. ideal J (R Quot I) }"
    using assms ring_ideal_imp_quot_ideal by auto
next
  show "(\<lambda>X. \<Union> X) ` { J. ideal J (R Quot I) } \<subseteq> { J. ideal J R \<and> I \<subseteq> J }"
  proof
    fix J assume "J \<in> ((\<lambda>X. \<Union> X) ` { J. ideal J (R Quot I) })"
    then obtain J' where J': "ideal J' (R Quot I)" "J = \<Union> J'" by blast
    hence "ideal J R"
      using assms quot_ideal_imp_ring_ideal by auto
    moreover have "I \<in> J'"
      using additive_subgroup.zero_closed[OF ideal.axioms(1)[OF J'(1)]] unfolding FactRing_def by simp
    ultimately show "J \<in> { J. ideal J R \<and> I \<subseteq> J }" using J'(2) by auto
  qed
next
  show "\<forall>J' \<in> { J. ideal J (R Quot I) }. ((+>) I ` (\<Union> J')) = J'"
  proof
    fix J' assume "J' \<in> { J. ideal J (R Quot I) }"
    hence subset: "J' \<subseteq> carrier (R Quot I) \<and> ideal J' (R Quot I)"
      using additive_subgroup.a_subset ideal_def by blast
    hence "((+>) I ` (\<Union> J')) \<subseteq> J'"
      using canonical_proj_vimage_in_carrier canonical_proj_vimage_mem_iff
      by (meson assms contra_subsetD image_subsetI)
    moreover have "J' \<subseteq> ((+>) I ` (\<Union> J'))"
    proof
      fix x assume "x \<in> J'"
      then obtain r where r: "r \<in> carrier R" "x = I +> r"
        using subset unfolding FactRing_def A_RCOSETS_def'[of R I] by auto
      hence "r \<in> (\<Union> J')"
        using \<open>x \<in> J'\<close> assms canonical_proj_vimage_mem_iff subset by blast
      thus "x \<in> ((+>) I ` (\<Union> J'))" using r(2) by blast
    qed
    ultimately show "((+>) I ` (\<Union> J')) = J'" by blast
  qed
qed

lemma (in cring) quot_domain_imp_primeideal:
  assumes "ideal P R"
  shows "domain (R Quot P) \<Longrightarrow> primeideal P R"
proof -
  assume A: "domain (R Quot P)" show "primeideal P R"
  proof (rule primeidealI)
    show "ideal P R" using assms .
    show "cring R" using is_cring .
  next
    show "carrier R \<noteq> P"
    proof (rule ccontr)
      assume "\<not> carrier R \<noteq> P" hence "carrier R = P" by simp
      hence "\<And>I. I \<in> carrier (R Quot P) \<Longrightarrow> I = P"
        unfolding FactRing_def A_RCOSETS_def' apply simp
        using a_coset_join2 additive_subgroup.a_subgroup assms ideal.axioms(1) by blast
      hence "\<one>\<^bsub>(R Quot P)\<^esub> = \<zero>\<^bsub>(R Quot P)\<^esub>"
        by (metis assms ideal.quotient_is_ring ring.ring_simprules(2) ring.ring_simprules(6))
      thus False using domain.one_not_zero[OF A] by simp
    qed
  next
    fix a b assume a: "a \<in> carrier R" and b: "b \<in> carrier R" and ab: "a \<otimes> b \<in> P"
    hence "P +> (a \<otimes> b) = \<zero>\<^bsub>(R Quot P)\<^esub>" unfolding FactRing_def
      by (simp add: a_coset_join2 additive_subgroup.a_subgroup assms ideal.axioms(1))
    moreover have "(P +> a) \<otimes>\<^bsub>(R Quot P)\<^esub> (P +> b) = P +> (a \<otimes> b)" unfolding FactRing_def
      using a b by (simp add: assms ideal.rcoset_mult_add)
    moreover have "P +> a \<in> carrier (R Quot P) \<and> P +> b \<in> carrier (R Quot P)"
      by (simp add: a b FactRing_def a_rcosetsI additive_subgroup.a_subset assms ideal.axioms(1))
    ultimately have "P +> a = \<zero>\<^bsub>(R Quot P)\<^esub> \<or> P +> b = \<zero>\<^bsub>(R Quot P)\<^esub>"
      using domain.integral[OF A, of "P +> a" "P +> b"] by auto
    thus "a \<in> P \<or> b \<in> P" unfolding FactRing_def apply simp
      using a b assms a_coset_join1 additive_subgroup.a_subgroup ideal.axioms(1) by blast
  qed
qed

lemma (in cring) quot_domain_iff_primeideal:
  assumes "ideal P R"
  shows "domain (R Quot P) = primeideal P R"
  using quot_domain_imp_primeideal[OF assms] primeideal.quotient_is_domain[of P R] by auto

subsection \<open>Isomorphism\<close>

definition
  ring_iso :: "_ \<Rightarrow> _ \<Rightarrow> ('a \<Rightarrow> 'b) set"
  where "ring_iso R S = { h. h \<in> ring_hom R S \<and> bij_betw h (carrier R) (carrier S) }"

definition
  is_ring_iso :: "_ \<Rightarrow> _ \<Rightarrow> bool" (infixr "\<simeq>" 60)
  where "R \<simeq> S = (ring_iso R S \<noteq> {})"

definition
  morphic_prop :: "_ \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  where "morphic_prop R P =
           ((P \<one>\<^bsub>R\<^esub>) \<and>
            (\<forall>r \<in> carrier R. P r) \<and>
            (\<forall>r1 \<in> carrier R. \<forall>r2 \<in> carrier R. P (r1 \<otimes>\<^bsub>R\<^esub> r2)) \<and>
            (\<forall>r1 \<in> carrier R. \<forall>r2 \<in> carrier R. P (r1 \<oplus>\<^bsub>R\<^esub> r2)))"

lemma ring_iso_memI:
  fixes R (structure) and S (structure)
  assumes "\<And>x. x \<in> carrier R \<Longrightarrow> h x \<in> carrier S"
      and "\<And>x y. \<lbrakk> x \<in> carrier R; y \<in> carrier R \<rbrakk> \<Longrightarrow> h (x \<otimes> y) = h x \<otimes>\<^bsub>S\<^esub> h y"
      and "\<And>x y. \<lbrakk> x \<in> carrier R; y \<in> carrier R \<rbrakk> \<Longrightarrow> h (x \<oplus> y) = h x \<oplus>\<^bsub>S\<^esub> h y"
      and "h \<one> = \<one>\<^bsub>S\<^esub>"
      and "bij_betw h (carrier R) (carrier S)"
  shows "h \<in> ring_iso R S"
  by (auto simp add: ring_hom_memI assms ring_iso_def)

lemma ring_iso_memE:
  fixes R (structure) and S (structure)
  assumes "h \<in> ring_iso R S"
  shows "\<And>x. x \<in> carrier R \<Longrightarrow> h x \<in> carrier S"
   and "\<And>x y. \<lbrakk> x \<in> carrier R; y \<in> carrier R \<rbrakk> \<Longrightarrow> h (x \<otimes> y) = h x \<otimes>\<^bsub>S\<^esub> h y"
   and "\<And>x y. \<lbrakk> x \<in> carrier R; y \<in> carrier R \<rbrakk> \<Longrightarrow> h (x \<oplus> y) = h x \<oplus>\<^bsub>S\<^esub> h y"
   and "h \<one> = \<one>\<^bsub>S\<^esub>"
   and "bij_betw h (carrier R) (carrier S)"
  using assms unfolding ring_iso_def ring_hom_def by auto

lemma morphic_propI:
  fixes R (structure)
  assumes "P \<one>"
    and "\<And>r. r \<in> carrier R \<Longrightarrow> P r"
    and "\<And>r1 r2. \<lbrakk> r1 \<in> carrier R; r2 \<in> carrier R \<rbrakk> \<Longrightarrow> P (r1 \<otimes> r2)"
    and "\<And>r1 r2. \<lbrakk> r1 \<in> carrier R; r2 \<in> carrier R \<rbrakk> \<Longrightarrow> P (r1 \<oplus> r2)"
  shows "morphic_prop R P"
  unfolding morphic_prop_def using assms by auto

lemma morphic_propE:
  fixes R (structure)
  assumes "morphic_prop R P"
  shows "P \<one>"
    and "\<And>r. r \<in> carrier R \<Longrightarrow> P r"
    and "\<And>r1 r2. \<lbrakk> r1 \<in> carrier R; r2 \<in> carrier R \<rbrakk> \<Longrightarrow> P (r1 \<otimes> r2)"
    and "\<And>r1 r2. \<lbrakk> r1 \<in> carrier R; r2 \<in> carrier R \<rbrakk> \<Longrightarrow> P (r1 \<oplus> r2)"
  using assms unfolding morphic_prop_def by auto

(* NEW ============================================================================ *)
lemma (in ring) ring_hom_restrict:
  assumes "f \<in> ring_hom R S" and "\<And>r. r \<in> carrier R \<Longrightarrow> f r = g r" shows "g \<in> ring_hom R S"
  using assms(2) ring_hom_memE[OF assms(1)] by (auto intro: ring_hom_memI)

(* PROOF ========================================================================== *)
lemma (in ring) ring_iso_restrict:
  assumes "f \<in> ring_iso R S" and "\<And>r. r \<in> carrier R \<Longrightarrow> f r = g r" shows "g \<in> ring_iso R S"
proof -
  have hom: "g \<in> ring_hom R S"
    using ring_hom_restrict assms unfolding ring_iso_def by auto
  have "bij_betw g (carrier R) (carrier S)"
    using bij_betw_cong[of "carrier R" f g] ring_iso_memE(5)[OF assms(1)] assms(2) by simp
  thus ?thesis
    using ring_hom_memE[OF hom] by (auto intro!: ring_iso_memI)
qed

lemma ring_iso_morphic_prop:
  assumes "f \<in> ring_iso R S"
    and "morphic_prop R P"
    and "\<And>r. P r \<Longrightarrow> f r = g r"
  shows "g \<in> ring_iso R S"
proof -
  have eq0: "\<And>r. r \<in> carrier R \<Longrightarrow> f r = g r"
   and eq1: "f \<one>\<^bsub>R\<^esub> = g \<one>\<^bsub>R\<^esub>"
   and eq2: "\<And>r1 r2. \<lbrakk> r1 \<in> carrier R; r2 \<in> carrier R \<rbrakk> \<Longrightarrow> f (r1 \<otimes>\<^bsub>R\<^esub> r2) = g (r1 \<otimes>\<^bsub>R\<^esub> r2)"
   and eq3: "\<And>r1 r2. \<lbrakk> r1 \<in> carrier R; r2 \<in> carrier R \<rbrakk> \<Longrightarrow> f (r1 \<oplus>\<^bsub>R\<^esub> r2) = g (r1 \<oplus>\<^bsub>R\<^esub> r2)"
    using assms(2-3) unfolding morphic_prop_def by auto
  show ?thesis
    apply (rule ring_iso_memI)
    using assms(1) eq0 ring_iso_memE(1) apply fastforce
    apply (metis assms(1) eq0 eq2 ring_iso_memE(2))
    apply (metis assms(1) eq0 eq3 ring_iso_memE(3))
    using assms(1) eq1 ring_iso_memE(4) apply fastforce
    using assms(1) bij_betw_cong eq0 ring_iso_memE(5) by blast
qed

lemma (in ring) ring_hom_imp_img_ring:
  assumes "h \<in> ring_hom R S"
  shows "ring (S \<lparr> carrier := h ` (carrier R), zero := h \<zero> \<rparr>)" (is "ring ?h_img")
proof -
  have "h \<in> hom (add_monoid R) (add_monoid S)"
    using assms unfolding hom_def ring_hom_def by auto
  hence "comm_group ((add_monoid S) \<lparr>  carrier := h ` (carrier R), one := h \<zero> \<rparr>)"
    using add.hom_imp_img_comm_group[of h "add_monoid S"] by simp
  hence comm_group: "comm_group (add_monoid ?h_img)"
    by (auto intro: comm_monoidI simp add: monoid.defs)

  moreover have "h \<in> hom R S"
    using assms unfolding ring_hom_def hom_def by auto
  hence "monoid (S \<lparr>  carrier := h ` (carrier R), one := h \<one> \<rparr>)"
    using hom_imp_img_monoid[of h S] by simp
  hence monoid: "monoid ?h_img"
    using ring_hom_memE(4)[OF assms] unfolding monoid_def by (simp add: monoid.defs)
  show ?thesis
  proof (rule ringI, simp_all add: comm_group_abelian_groupI[OF comm_group] monoid)
    fix x y z assume "x \<in> h ` carrier R" "y \<in> h ` carrier R" "z \<in> h ` carrier R"
    then obtain r1 r2 r3
      where r1: "r1 \<in> carrier R" "x = h r1"
        and r2: "r2 \<in> carrier R" "y = h r2"
        and r3: "r3 \<in> carrier R" "z = h r3" by blast
    hence "(x \<oplus>\<^bsub>S\<^esub> y) \<otimes>\<^bsub>S\<^esub> z = h ((r1 \<oplus> r2) \<otimes> r3)"
      using ring_hom_memE[OF assms] by auto
    also have " ... = h ((r1 \<otimes> r3) \<oplus> (r2 \<otimes> r3))"
      using l_distr[OF r1(1) r2(1) r3(1)] by simp
    also have " ... = (x \<otimes>\<^bsub>S\<^esub> z) \<oplus>\<^bsub>S\<^esub> (y \<otimes>\<^bsub>S\<^esub> z)"
      using ring_hom_memE[OF assms] r1 r2 r3 by auto
    finally show "(x \<oplus>\<^bsub>S\<^esub> y) \<otimes>\<^bsub>S\<^esub> z = (x \<otimes>\<^bsub>S\<^esub> z) \<oplus>\<^bsub>S\<^esub> (y \<otimes>\<^bsub>S\<^esub> z)" .

    have "z \<otimes>\<^bsub>S\<^esub> (x \<oplus>\<^bsub>S\<^esub> y) = h (r3 \<otimes> (r1 \<oplus> r2))"
      using ring_hom_memE[OF assms] r1 r2 r3 by auto
    also have " ... =  h ((r3 \<otimes> r1) \<oplus> (r3 \<otimes> r2))"
      using r_distr[OF r1(1) r2(1) r3(1)] by simp
    also have " ... = (z \<otimes>\<^bsub>S\<^esub> x) \<oplus>\<^bsub>S\<^esub> (z \<otimes>\<^bsub>S\<^esub> y)"
      using ring_hom_memE[OF assms] r1 r2 r3 by auto
    finally show "z \<otimes>\<^bsub>S\<^esub> (x \<oplus>\<^bsub>S\<^esub> y) = (z \<otimes>\<^bsub>S\<^esub> x) \<oplus>\<^bsub>S\<^esub> (z \<otimes>\<^bsub>S\<^esub> y)" .
  qed
qed

lemma (in ring) ring_iso_imp_img_ring:
  assumes "h \<in> ring_iso R S"
  shows "ring (S \<lparr> zero := h \<zero> \<rparr>)"
proof -
  have "ring (S \<lparr> carrier := h ` (carrier R), zero := h \<zero> \<rparr>)"
    using ring_hom_imp_img_ring[of h S] assms unfolding ring_iso_def by auto
  moreover have "h ` (carrier R) = carrier S"
    using assms unfolding ring_iso_def bij_betw_def by auto
  ultimately show ?thesis by simp
qed

lemma (in cring) ring_iso_imp_img_cring:
  assumes "h \<in> ring_iso R S"
  shows "cring (S \<lparr> zero := h \<zero> \<rparr>)" (is "cring ?h_img")
proof -
  note m_comm
  interpret h_img?: ring ?h_img
    using ring_iso_imp_img_ring[OF assms] .
  show ?thesis
  proof (unfold_locales)
    fix x y assume "x \<in> carrier ?h_img" "y \<in> carrier ?h_img"
    then obtain r1 r2
      where r1: "r1 \<in> carrier R" "x = h r1"
        and r2: "r2 \<in> carrier R" "y = h r2"
      using assms image_iff[where ?f = h and ?A = "carrier R"]
      unfolding ring_iso_def bij_betw_def by auto
    have "x \<otimes>\<^bsub>(?h_img)\<^esub> y = h (r1 \<otimes> r2)"
      using assms r1 r2 unfolding ring_iso_def ring_hom_def by auto
    also have " ... = h (r2 \<otimes> r1)"
      using m_comm[OF r1(1) r2(1)] by simp
    also have " ... = y \<otimes>\<^bsub>(?h_img)\<^esub> x"
      using assms r1 r2 unfolding ring_iso_def ring_hom_def by auto
    finally show "x \<otimes>\<^bsub>(?h_img)\<^esub> y = y \<otimes>\<^bsub>(?h_img)\<^esub> x" .
  qed
qed

lemma (in domain) ring_iso_imp_img_domain:
  assumes "h \<in> ring_iso R S"
  shows "domain (S \<lparr> zero := h \<zero> \<rparr>)" (is "domain ?h_img")
proof -
  note aux = m_closed integral one_not_zero one_closed zero_closed
  interpret h_img?: cring ?h_img
    using ring_iso_imp_img_cring[OF assms] .
  show ?thesis
  proof (unfold_locales)
    have "\<one>\<^bsub>?h_img\<^esub> = \<zero>\<^bsub>?h_img\<^esub> \<Longrightarrow> h \<one> = h \<zero>"
      using ring_iso_memE(4)[OF assms] by simp
    moreover have "h \<one> \<noteq> h \<zero>"
      using ring_iso_memE(5)[OF assms] aux(3-4)
      unfolding bij_betw_def inj_on_def by force
    ultimately show "\<one>\<^bsub>?h_img\<^esub> \<noteq> \<zero>\<^bsub>?h_img\<^esub>"
      by auto
  next
    fix a b
    assume A: "a \<otimes>\<^bsub>?h_img\<^esub> b = \<zero>\<^bsub>?h_img\<^esub>" "a \<in> carrier ?h_img" "b \<in> carrier ?h_img"
    then obtain r1 r2
      where r1: "r1 \<in> carrier R" "a = h r1"
        and r2: "r2 \<in> carrier R" "b = h r2"
      using assms image_iff[where ?f = h and ?A = "carrier R"]
      unfolding ring_iso_def bij_betw_def by auto
    hence "a \<otimes>\<^bsub>?h_img\<^esub> b = h (r1 \<otimes> r2)"
      using assms r1 r2 unfolding ring_iso_def ring_hom_def by auto
    hence "h (r1 \<otimes> r2) = h \<zero>"
      using A(1) by simp
    hence "r1 \<otimes> r2 = \<zero>"
      using ring_iso_memE(5)[OF assms] aux(1)[OF r1(1) r2(1)] aux(5)
      unfolding bij_betw_def inj_on_def by force
    hence "r1 = \<zero> \<or> r2 = \<zero>"
      using aux(2)[OF _ r1(1) r2(1)] by simp
    thus "a = \<zero>\<^bsub>?h_img\<^esub> \<or> b = \<zero>\<^bsub>?h_img\<^esub>"
      unfolding r1 r2 by auto
  qed
qed

lemma (in field) ring_iso_imp_img_field:
  assumes "h \<in> ring_iso R S"
  shows "field (S \<lparr> zero := h \<zero> \<rparr>)" (is "field ?h_img")
proof -
  interpret h_img?: domain ?h_img
    using ring_iso_imp_img_domain[OF assms] .
  show ?thesis
  proof (unfold_locales, auto simp add: Units_def)
    interpret field R using field_axioms .
    fix a assume a: "a \<in> carrier S" "a \<otimes>\<^bsub>S\<^esub> h \<zero> = \<one>\<^bsub>S\<^esub>"
    then obtain r where r: "r \<in> carrier R" "a = h r"
      using assms image_iff[where ?f = h and ?A = "carrier R"]
      unfolding ring_iso_def bij_betw_def by auto
    have "a \<otimes>\<^bsub>S\<^esub> h \<zero> = h (r \<otimes> \<zero>)" unfolding r(2)
      using ring_iso_memE(2)[OF assms r(1)] by simp
    hence "h \<one> = h \<zero>"
      using ring_iso_memE(4)[OF assms] r(1) a(2) by simp
    thus False
      using ring_iso_memE(5)[OF assms]
      unfolding bij_betw_def inj_on_def by force
  next
    interpret field R using field_axioms .
    fix s assume s: "s \<in> carrier S" "s \<noteq> h \<zero>"
    then obtain r where r: "r \<in> carrier R" "s = h r"
      using assms image_iff[where ?f = h and ?A = "carrier R"]
      unfolding ring_iso_def bij_betw_def by auto
    hence "r \<noteq> \<zero>" using s(2) by auto
    hence inv_r: "inv r \<in> carrier R" "inv r \<noteq> \<zero>" "r \<otimes> inv r = \<one>" "inv r \<otimes> r = \<one>"
      using field_Units r(1) by auto
    have "h (inv r) \<otimes>\<^bsub>S\<^esub> h r = h \<one>" and "h r \<otimes>\<^bsub>S\<^esub> h (inv r) = h \<one>"
      using ring_iso_memE(2)[OF assms inv_r(1) r(1)] inv_r(3-4)
            ring_iso_memE(2)[OF assms r(1) inv_r(1)] by auto
    thus "\<exists>s' \<in> carrier S. s' \<otimes>\<^bsub>S\<^esub> s = \<one>\<^bsub>S\<^esub> \<and> s \<otimes>\<^bsub>S\<^esub> s' = \<one>\<^bsub>S\<^esub>"
      using ring_iso_memE(1,4)[OF assms] inv_r(1) r(2) by auto
  qed
qed

lemma ring_iso_same_card: "R \<simeq> S \<Longrightarrow> card (carrier R) = card (carrier S)"
  using bij_betw_same_card unfolding is_ring_iso_def ring_iso_def by auto
(* ========================================================================== *)

lemma ring_iso_set_refl: "id \<in> ring_iso R R"
  by (rule ring_iso_memI) (auto)

corollary ring_iso_refl: "R \<simeq> R"
  using is_ring_iso_def ring_iso_set_refl by auto

lemma ring_iso_set_trans:
  "\<lbrakk> f \<in> ring_iso R S; g \<in> ring_iso S Q \<rbrakk> \<Longrightarrow> (g \<circ> f) \<in> ring_iso R Q"
  unfolding ring_iso_def using bij_betw_trans ring_hom_trans by fastforce

corollary ring_iso_trans: "\<lbrakk> R \<simeq> S; S \<simeq> Q \<rbrakk> \<Longrightarrow> R \<simeq> Q"
  using ring_iso_set_trans unfolding is_ring_iso_def by blast

lemma ring_iso_set_sym:
  assumes "ring R" and h: "h \<in> ring_iso R S"
  shows "(inv_into (carrier R) h) \<in> ring_iso S R"
proof -
  have h_hom: "h \<in> ring_hom R S"
    and h_surj: "h ` (carrier R) = (carrier S)"
    and h_inj:  "\<And> x1 x2. \<lbrakk> x1 \<in> carrier R; x2 \<in> carrier R \<rbrakk> \<Longrightarrow>  h x1 = h x2 \<Longrightarrow> x1 = x2"
    using h unfolding ring_iso_def bij_betw_def inj_on_def by auto

  have h_inv_bij: "bij_betw (inv_into (carrier R) h) (carrier S) (carrier R)"
    by (simp add: bij_betw_inv_into h ring_iso_memE(5))

  have "inv_into (carrier R) h \<in> ring_hom S R"
    using ring_iso_memE [OF h] bij_betwE [OF h_inv_bij] \<open>ring R\<close>
    by (simp add: bij_betw_imp_inj_on bij_betw_inv_into_right inv_into_f_eq ring.ring_simprules ring_hom_memI)
  moreover have "bij_betw (inv_into (carrier R) h) (carrier S) (carrier R)"
    using h_inv_bij by force
    ultimately show "inv_into (carrier R) h \<in> ring_iso S R"
      by (simp add: ring_iso_def)
qed

corollary ring_iso_sym:
  assumes "ring R"
  shows "R \<simeq> S \<Longrightarrow> S \<simeq> R"
  using assms ring_iso_set_sym unfolding is_ring_iso_def by auto

lemma (in ring_hom_ring) the_elem_simp [simp]:
  "\<And>x. x \<in> carrier R \<Longrightarrow> the_elem (h ` ((a_kernel R S h) +> x)) = h x"
proof -
  fix x assume x: "x \<in> carrier R"
  hence "h x \<in> h ` ((a_kernel R S h) +> x)"
    using homeq_imp_rcos by blast
  thus "the_elem (h ` ((a_kernel R S h) +> x)) = h x"
    by (metis (no_types, lifting) x empty_iff homeq_imp_rcos rcos_imp_homeq the_elem_image_unique)
qed

lemma (in ring_hom_ring) the_elem_inj:
  "\<And>X Y. \<lbrakk> X \<in> carrier (R Quot (a_kernel R S h)); Y \<in> carrier (R Quot (a_kernel R S h)) \<rbrakk> \<Longrightarrow>
           the_elem (h ` X) = the_elem (h ` Y) \<Longrightarrow> X = Y"
proof -
  fix X Y
  assume "X \<in> carrier (R Quot (a_kernel R S h))"
     and "Y \<in> carrier (R Quot (a_kernel R S h))"
     and Eq: "the_elem (h ` X) = the_elem (h ` Y)"
  then obtain x y where x: "x \<in> carrier R" "X = (a_kernel R S h) +> x"
                    and y: "y \<in> carrier R" "Y = (a_kernel R S h) +> y"
    unfolding FactRing_def A_RCOSETS_def' by auto
  hence "h x = h y" using Eq by simp
  hence "x \<ominus> y \<in> (a_kernel R S h)"
    by (simp add: a_minus_def abelian_subgroup.a_rcos_module_imp
                  abelian_subgroup_a_kernel homeq_imp_rcos x(1) y(1))
  thus "X = Y"
    by (metis R.a_coset_add_inv1 R.minus_eq abelian_subgroup.a_rcos_const
        abelian_subgroup_a_kernel additive_subgroup.a_subset additive_subgroup_a_kernel x y)
qed

lemma (in ring_hom_ring) quot_mem:
  "\<And>X. X \<in> carrier (R Quot (a_kernel R S h)) \<Longrightarrow> \<exists>x \<in> carrier R. X = (a_kernel R S h) +> x"
proof -
  fix X assume "X \<in> carrier (R Quot (a_kernel R S h))"
  thus "\<exists>x \<in> carrier R. X = (a_kernel R S h) +> x"
    unfolding FactRing_simps by (simp add: a_r_coset_def)
qed

lemma (in ring_hom_ring) the_elem_wf:
  "\<And>X. X \<in> carrier (R Quot (a_kernel R S h)) \<Longrightarrow> \<exists>y \<in> carrier S. (h ` X) = { y }"
proof -
  fix X assume "X \<in> carrier (R Quot (a_kernel R S h))"
  then obtain x where x: "x \<in> carrier R" and X: "X = (a_kernel R S h) +> x"
    using quot_mem by blast
  hence "\<And>x'. x' \<in> X \<Longrightarrow> h x' = h x"
  proof -
    fix x' assume "x' \<in> X" hence "x' \<in> (a_kernel R S h) +> x" using X by simp
    then obtain k where k: "k \<in> a_kernel R S h" "x' = k \<oplus> x"
      by (metis R.add.inv_closed R.add.m_assoc R.l_neg R.r_zero
          abelian_subgroup.a_elemrcos_carrier
          abelian_subgroup.a_rcos_module_imp abelian_subgroup_a_kernel x)
    hence "h x' = h k \<oplus>\<^bsub>S\<^esub> h x"
      by (meson additive_subgroup.a_Hcarr additive_subgroup_a_kernel hom_add x)
    also have " ... =  h x"
      using k by (auto simp add: x)
    finally show "h x' = h x" .
  qed
  moreover have "h x \<in> h ` X"
    by (simp add: X homeq_imp_rcos x)
  ultimately have "(h ` X) = { h x }"
    by blast
  thus "\<exists>y \<in> carrier S. (h ` X) = { y }" using x by simp
qed

corollary (in ring_hom_ring) the_elem_wf':
  "\<And>X. X \<in> carrier (R Quot (a_kernel R S h)) \<Longrightarrow> \<exists>r \<in> carrier R. (h ` X) = { h r }"
  using the_elem_wf by (metis quot_mem the_elem_eq the_elem_simp)

lemma (in ring_hom_ring) the_elem_hom:
  "(\<lambda>X. the_elem (h ` X)) \<in> ring_hom (R Quot (a_kernel R S h)) S"
proof (rule ring_hom_memI)
  show "\<And>x. x \<in> carrier (R Quot a_kernel R S h) \<Longrightarrow> the_elem (h ` x) \<in> carrier S"
    using the_elem_wf by fastforce

  show "the_elem (h ` \<one>\<^bsub>R Quot a_kernel R S h\<^esub>) = \<one>\<^bsub>S\<^esub>"
    unfolding FactRing_def  using the_elem_simp[of "\<one>\<^bsub>R\<^esub>"] by simp

  fix X Y
  assume "X \<in> carrier (R Quot a_kernel R S h)"
     and "Y \<in> carrier (R Quot a_kernel R S h)"
  then obtain x y where x: "x \<in> carrier R" "X = (a_kernel R S h) +> x"
                    and y: "y \<in> carrier R" "Y = (a_kernel R S h) +> y"
    using quot_mem by blast

  have "X \<otimes>\<^bsub>R Quot a_kernel R S h\<^esub> Y = (a_kernel R S h) +> (x \<otimes> y)"
    by (simp add: FactRing_def ideal.rcoset_mult_add kernel_is_ideal x y)
  thus "the_elem (h ` (X \<otimes>\<^bsub>R Quot a_kernel R S h\<^esub> Y)) = the_elem (h ` X) \<otimes>\<^bsub>S\<^esub> the_elem (h ` Y)"
    by (simp add: x y)

  have "X \<oplus>\<^bsub>R Quot a_kernel R S h\<^esub> Y = (a_kernel R S h) +> (x \<oplus> y)"
    using ideal.rcos_ring_hom kernel_is_ideal ring_hom_add x y by fastforce
  thus "the_elem (h ` (X \<oplus>\<^bsub>R Quot a_kernel R S h\<^esub> Y)) = the_elem (h ` X) \<oplus>\<^bsub>S\<^esub> the_elem (h ` Y)"
    by (simp add: x y)
qed

lemma (in ring_hom_ring) the_elem_surj:
    "(\<lambda>X. (the_elem (h ` X))) ` carrier (R Quot (a_kernel R S h)) = (h ` (carrier R))"
proof
  show "(\<lambda>X. the_elem (h ` X)) ` carrier (R Quot a_kernel R S h) \<subseteq> h ` carrier R"
    using the_elem_wf' by fastforce
next
  show "h ` carrier R \<subseteq> (\<lambda>X. the_elem (h ` X)) ` carrier (R Quot a_kernel R S h)"
  proof
    fix y assume "y \<in> h ` carrier R"
    then obtain x where x: "x \<in> carrier R" "h x = y"
      by (metis image_iff)
    hence "the_elem (h ` ((a_kernel R S h) +> x)) = y" by simp
    moreover have "(a_kernel R S h) +> x \<in> carrier (R Quot (a_kernel R S h))"
     unfolding FactRing_simps by (auto simp add: x a_r_coset_def)
    ultimately show "y \<in> (\<lambda>X. (the_elem (h ` X))) ` carrier (R Quot (a_kernel R S h))" by blast
  qed
qed

proposition (in ring_hom_ring) FactRing_iso_set_aux:
  "(\<lambda>X. the_elem (h ` X)) \<in> ring_iso (R Quot (a_kernel R S h)) (S \<lparr> carrier := h ` (carrier R) \<rparr>)"
proof -
  have "bij_betw (\<lambda>X. the_elem (h ` X)) (carrier (R Quot a_kernel R S h)) (h ` (carrier R))"
    unfolding bij_betw_def inj_on_def using the_elem_surj the_elem_inj by simp

  moreover
  have "(\<lambda>X. the_elem (h ` X)): carrier (R Quot (a_kernel R S h)) \<rightarrow> h ` (carrier R)"
    using the_elem_wf' by fastforce
  hence "(\<lambda>X. the_elem (h ` X)) \<in> ring_hom (R Quot (a_kernel R S h)) (S \<lparr> carrier := h ` (carrier R) \<rparr>)"
    using the_elem_hom the_elem_wf' unfolding ring_hom_def by simp

  ultimately show ?thesis unfolding ring_iso_def using the_elem_hom by simp
qed

theorem (in ring_hom_ring) FactRing_iso_set:
  assumes "h ` carrier R = carrier S"
  shows "(\<lambda>X. the_elem (h ` X)) \<in> ring_iso (R Quot (a_kernel R S h)) S"
  using FactRing_iso_set_aux assms by auto

corollary (in ring_hom_ring) FactRing_iso:
  assumes "h ` carrier R = carrier S"
  shows "R Quot (a_kernel R S h) \<simeq> S"
  using FactRing_iso_set assms is_ring_iso_def by auto

corollary (in ring) FactRing_zeroideal:
  shows "R Quot { \<zero> } \<simeq> R" and "R \<simeq> R Quot { \<zero> }"
proof -
  have "ring_hom_ring R R id"
    using ring_axioms by (auto intro: ring_hom_ringI)
  moreover have "a_kernel R R id = { \<zero> }"
    unfolding a_kernel_def' by auto
  ultimately show "R Quot { \<zero> } \<simeq> R" and "R \<simeq> R Quot { \<zero> }"
    using ring_hom_ring.FactRing_iso[of R R id]
          ring_iso_sym[OF ideal.quotient_is_ring[OF zeroideal], of R] by auto
qed

lemma (in ring_hom_ring) img_is_ring: "ring (S \<lparr> carrier := h ` (carrier R) \<rparr>)"
proof -
  let ?the_elem = "\<lambda>X. the_elem (h ` X)"
  have FactRing_is_ring: "ring (R Quot (a_kernel R S h))"
    by (simp add: ideal.quotient_is_ring kernel_is_ideal)
  have "ring ((S \<lparr> carrier := ?the_elem ` (carrier (R Quot (a_kernel R S h))) \<rparr>)
                 \<lparr>    zero := ?the_elem \<zero>\<^bsub>(R Quot (a_kernel R S h))\<^esub> \<rparr>)"
    using ring.ring_iso_imp_img_ring[OF FactRing_is_ring, of ?the_elem
          "S \<lparr> carrier := ?the_elem ` (carrier (R Quot (a_kernel R S h))) \<rparr>"]
          FactRing_iso_set_aux the_elem_surj by auto

  moreover
  have "\<zero> \<in> (a_kernel R S h)"
    using a_kernel_def'[of R S h] by auto
  hence "\<one> \<in> (a_kernel R S h) +> \<one>"
    using a_r_coset_def'[of R "a_kernel R S h" \<one>] by force
  hence "\<one>\<^bsub>S\<^esub> \<in> (h ` ((a_kernel R S h) +> \<one>))"
    using hom_one by force
  hence "?the_elem \<one>\<^bsub>(R Quot (a_kernel R S h))\<^esub> = \<one>\<^bsub>S\<^esub>"
    using the_elem_wf[of "(a_kernel R S h) +> \<one>"] by (simp add: FactRing_def)

  moreover
  have "\<zero>\<^bsub>S\<^esub> \<in> (h ` (a_kernel R S h))"
    using a_kernel_def'[of R S h] hom_zero by force
  hence "\<zero>\<^bsub>S\<^esub> \<in> (h ` \<zero>\<^bsub>(R Quot (a_kernel R S h))\<^esub>)"
    by (simp add: FactRing_def)
  hence "?the_elem \<zero>\<^bsub>(R Quot (a_kernel R S h))\<^esub> = \<zero>\<^bsub>S\<^esub>"
    using the_elem_wf[OF ring.ring_simprules(2)[OF FactRing_is_ring]]
    by (metis singletonD the_elem_eq)

  ultimately
  have "ring ((S \<lparr> carrier := h ` (carrier R) \<rparr>) \<lparr> one := \<one>\<^bsub>S\<^esub>, zero := \<zero>\<^bsub>S\<^esub> \<rparr>)"
    using the_elem_surj by simp
  thus ?thesis
    by auto
qed

lemma (in ring_hom_ring) img_is_cring:
  assumes "cring S"
  shows "cring (S \<lparr> carrier := h ` (carrier R) \<rparr>)"
proof -
  interpret ring "S \<lparr> carrier := h ` (carrier R) \<rparr>"
    using img_is_ring .
  show ?thesis
    apply unfold_locales
    using assms unfolding cring_def comm_monoid_def comm_monoid_axioms_def by auto
qed

lemma (in ring_hom_ring) img_is_domain:
  assumes "domain S"
  shows "domain (S \<lparr> carrier := h ` (carrier R) \<rparr>)"
proof -
  interpret cring "S \<lparr> carrier := h ` (carrier R) \<rparr>"
    using img_is_cring assms unfolding domain_def by simp
  show ?thesis
    apply unfold_locales
    using assms unfolding domain_def domain_axioms_def apply auto
    using hom_closed by blast
qed

proposition (in ring_hom_ring) primeideal_vimage:
  assumes "cring R"
  shows "primeideal P S \<Longrightarrow> primeideal { r \<in> carrier R. h r \<in> P } R"
proof -
  assume A: "primeideal P S"
  hence is_ideal: "ideal P S" unfolding primeideal_def by simp
  have "ring_hom_ring R (S Quot P) (((+>\<^bsub>S\<^esub>) P) \<circ> h)" (is "ring_hom_ring ?A ?B ?h")
    using ring_hom_trans[OF homh, of "(+>\<^bsub>S\<^esub>) P" "S Quot P"]
          ideal.rcos_ring_hom_ring[OF is_ideal] assms
    unfolding ring_hom_ring_def ring_hom_ring_axioms_def cring_def by simp
  then interpret hom: ring_hom_ring R "S Quot P" "((+>\<^bsub>S\<^esub>) P) \<circ> h" by simp

  have "inj_on (\<lambda>X. the_elem (?h ` X)) (carrier (R Quot (a_kernel R (S Quot P) ?h)))"
    using hom.the_elem_inj unfolding inj_on_def by simp
  moreover
  have "ideal (a_kernel R (S Quot P) ?h) R"
    using hom.kernel_is_ideal by auto
  have hom': "ring_hom_ring (R Quot (a_kernel R (S Quot P) ?h)) (S Quot P) (\<lambda>X. the_elem (?h ` X))"
    using hom.the_elem_hom hom.kernel_is_ideal
    by (meson hom.ring_hom_ring_axioms ideal.rcos_ring_hom_ring ring_hom_ring_axioms_def ring_hom_ring_def)

  ultimately
  have "primeideal (a_kernel R (S Quot P) ?h) R"
    using ring_hom_ring.inj_on_domain[OF hom'] primeideal.quotient_is_domain[OF A]
          cring.quot_domain_imp_primeideal[OF assms hom.kernel_is_ideal] by simp

  moreover have "a_kernel R (S Quot P) ?h = { r \<in> carrier R. h r \<in> P }"
  proof
    show "a_kernel R (S Quot P) ?h \<subseteq> { r \<in> carrier R. h r \<in> P }"
    proof
      fix r assume "r \<in> a_kernel R (S Quot P) ?h"
      hence r: "r \<in> carrier R" "P +>\<^bsub>S\<^esub> (h r) = P"
        unfolding a_kernel_def kernel_def FactRing_def by auto
      hence "h r \<in> P"
        using S.a_rcosI R.l_zero S.l_zero additive_subgroup.a_subset[OF ideal.axioms(1)[OF is_ideal]]
              additive_subgroup.zero_closed[OF ideal.axioms(1)[OF is_ideal]] hom_closed by metis
      thus "r \<in> { r \<in> carrier R. h r \<in> P }" using r by simp
    qed
  next
    show "{ r \<in> carrier R. h r \<in> P } \<subseteq> a_kernel R (S Quot P) ?h"
    proof
      fix r assume "r \<in> { r \<in> carrier R. h r \<in> P }"
      hence r: "r \<in> carrier R" "h r \<in> P" by simp_all
      hence "?h r = P"
        by (simp add: S.a_coset_join2 additive_subgroup.a_subgroup ideal.axioms(1) is_ideal)
      thus "r \<in> a_kernel R (S Quot P) ?h"
        unfolding a_kernel_def kernel_def FactRing_def using r(1) by auto
    qed
  qed
  ultimately show "primeideal { r \<in> carrier R. h r \<in> P } R" by simp
qed

end


theory Chisholm_DDL_Dyadic imports DDL          (*Christoph Benzmüller & Xavier Parent, 2019*)

begin (* Chisholm Example *)
consts go::\<sigma> tell::\<sigma> kill::\<sigma>

 nitpick_params [user_axioms,show_all,format=2] (*Settings for model finder.*)

(*It ought to be that Jones goes to assist his neighbors.*)
  abbreviation  "D1 \<equiv> \<^bold>O\<^bold>\<langle>go\<^bold>|\<^bold>\<top>\<^bold>\<rangle>"
(*It ought to be that if Jones goes, then he tells them he is coming.*)
  abbreviation  "D2 \<equiv> \<^bold>O\<^bold>\<langle>tell\<^bold>|go\<^bold>\<rangle>"
(*If Jones doesn't go, then he ought not tell them he is coming.*)
  abbreviation  "D3 \<equiv> \<^bold>O\<^bold>\<langle>\<^bold>\<not>tell\<^bold>|\<^bold>\<not>go\<^bold>\<rangle>"
(*Jones doesn't go. (This is encoded as a locally valid statement.)*)
  abbreviation  "D4 \<equiv> \<^bold>\<not>go"

(*** Chisholm ***)
 (* All-wide scoping is not leading to a dependent set of the axioms.*)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2 \<^bold>\<and> D3) \<^bold>\<rightarrow> D4\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2 \<^bold>\<and> D4) \<^bold>\<rightarrow> D3\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D1 \<^bold>\<and> D3 \<^bold>\<and> D4) \<^bold>\<rightarrow> D2\<rfloor>"  nitpick oops (*countermodel*)
 lemma "\<lfloor>(D2 \<^bold>\<and> D3 \<^bold>\<and> D4) \<^bold>\<rightarrow> D1\<rfloor>"  nitpick oops (*countermodel*)
 (* Chisholm is thus an adequate modeling. *)

 (* Consistency *)
 lemma "\<lfloor>(D1 \<^bold>\<and> D2 \<^bold>\<and> D3)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" nitpick [satisfy] oops (*Consistent? Yes*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2 \<^bold>\<and> D3)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows False nitpick oops (*Inconsistent? No*)
 (* Queries *)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2 \<^bold>\<and> D3)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><\<^bold>\<not>tell>\<rfloor>\<^sub>l" nitpick oops (*Should James not tell? No*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2 \<^bold>\<and> D3)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><tell>\<rfloor>\<^sub>l"
  using assms  sledgehammer nitpick oops (*Should James tell? Timeout*)
 lemma assumes "\<lfloor>(D1 \<^bold>\<and> D2 \<^bold>\<and> D3)\<rfloor> \<and> \<lfloor>D4\<rfloor>\<^sub>l" shows "\<lfloor>\<^bold>\<circle><kill>\<rfloor>\<^sub>l"  nitpick oops (*Should James kill? No*)

end


theory Tut13
  imports "HOL-IMP.Small_Step" "HOL-IMP.Sem_Equiv" "HOL-IMP.Vars"
begin

datatype sign = None | Neg | Pos0 | Any

fun \<gamma> :: "sign \<Rightarrow> val set" where
"\<gamma> None = {}" |
"\<gamma> Neg = {i. i < 0}" |
"\<gamma> Pos0 = {i. i \<ge> 0}" |
"\<gamma> Any = UNIV"

(* _ = _ + _ then what can we say about _,_ *)
fun inv_plus' :: "sign \<Rightarrow> sign \<Rightarrow> sign \<Rightarrow> sign * sign"  where
  "inv_plus' None _ _ = (None, None)" |
  "inv_plus' _ None _ = (None, None)" |
  "inv_plus' _ _ None = (None, None)" |
  "inv_plus' Pos0 Neg Neg = (None, None)" |
  "inv_plus' Pos0 Neg _ = (Neg, Pos0)" |
  "inv_plus' Pos0 _ Neg = (Pos0, Neg)" |
  "inv_plus' Neg Pos0 Pos0 = (None, None)" |
  "inv_plus' Neg Pos0 _ = (Pos0, Neg)" |
  "inv_plus' Neg _ Pos0 = (Neg, Pos0)" |
  "inv_plus' _ x y = (x, y)"

lemma
  "\<lbrakk> inv_plus' a a1 a2 = (a1',a2');  i1 \<in> \<gamma> a1;  i2 \<in> \<gamma> a2; i1+i2 \<in> \<gamma> a \<rbrakk>
  \<Longrightarrow> i1 \<in> \<gamma> a1' \<and> i2 \<in> \<gamma> a2' "
  by(induction a a1 a2 rule: inv_plus'.induct, auto)

fun inv_less' :: "bool \<Rightarrow> sign \<Rightarrow> sign \<Rightarrow> sign * sign"  where
  "inv_less' _ None _ = (None, None)" |
  "inv_less' _ _ None = (None, None)" |
  "inv_less' True Pos0 Neg = (None, None)" |
  "inv_less' True Pos0 Any = (Pos0, Pos0)" |
  "inv_less' True Any Neg = (Neg, Neg)" |
  "inv_less' False Neg Pos0 = (None, None)" |
  "inv_less' False Any Pos0 = (Pos0, Pos0)" |
  "inv_less' False Neg Any = (Neg, Neg)" |
  "inv_less' _ x y = (x, y)"

lemma
  "\<lbrakk> inv_less' bv a1 a2 = (a1',a2');  i1 \<in> \<gamma> a1;  i2 \<in> \<gamma> a2; (i1<i2) = bv \<rbrakk>
  \<Longrightarrow> i1 \<in> \<gamma> a1' \<and> i2 \<in> \<gamma> a2'"
  by(cases a1; cases a2, auto)

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_18
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun t22 :: "Nat => Nat => Nat" where
  "t22 (Z) y = y"
| "t22 (S z) y = S (t22 z y)"

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

theorem property0 :
  "t2 i (S (t22 i m))"
  find_proof DInd
  apply (induct arbitrary: m)(* This arbitrary is not directly important: "induct i" also works well. *)
   apply auto
  done

end