(*  Title:      FOLP/ex/Quantifiers_Int.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge

First-Order Logic: quantifier examples (intuitionistic and classical)
Needs declarations of the theory "thy" and the tactic "tac".
*)

theory Quantifiers_Int
imports IFOLP
begin

schematic_lemma "?p : (ALL x y. P(x,y))  -->  (ALL y x. P(x,y))"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma "?p : (EX x y. P(x,y)) --> (EX y x. P(x,y))"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

(*Converse is false*)
schematic_lemma "?p : (ALL x. P(x)) | (ALL x. Q(x)) --> (ALL x. P(x) | Q(x))"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma "?p : (ALL x. P-->Q(x))  <->  (P--> (ALL x. Q(x)))"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma "?p : (ALL x. P(x)-->Q)  <->  ((EX x. P(x)) --> Q)"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

text "Some harder ones"

schematic_lemma "?p : (EX x. P(x) | Q(x)) <-> (EX x. P(x)) | (EX x. Q(x))"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

(*Converse is false*)
schematic_lemma "?p : (EX x. P(x)&Q(x)) --> (EX x. P(x))  &  (EX x. Q(x))"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

text "Basic test of quantifier reasoning"
(*TRUE*)
schematic_lemma "?p : (EX y. ALL x. Q(x,y)) -->  (ALL x. EX y. Q(x,y))"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma "?p : (ALL x. Q(x))  -->  (EX x. Q(x))"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

text "The following should fail, as they are false!"

schematic_lemma "?p : (ALL x. EX y. Q(x,y))  -->  (EX y. ALL x. Q(x,y))"
  apply (tactic {* IntPr.fast_tac @{context} 1 *})?
  oops

schematic_lemma "?p : (EX x. Q(x))  -->  (ALL x. Q(x))"
  apply (tactic {* IntPr.fast_tac @{context} 1 *})?
  oops

schematic_lemma "?p : P(?a) --> (ALL x. P(x))"
  apply (tactic {* IntPr.fast_tac @{context} 1 *})?
  oops

schematic_lemma "?p : (P(?a) --> (ALL x. Q(x))) --> (ALL x. P(x) --> Q(x))"
  apply (tactic {* IntPr.fast_tac @{context} 1 *})?
  oops

text "Back to things that are provable..."

schematic_lemma "?p : (ALL x. P(x)-->Q(x)) & (EX x. P(x)) --> (EX x. Q(x))"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

(*An example of why exI should be delayed as long as possible*)
schematic_lemma "?p : (P --> (EX x. Q(x))) & P --> (EX x. Q(x))"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma "?p : (ALL x. P(x)-->Q(f(x))) & (ALL x. Q(x)-->R(g(x))) & P(d) --> R(?a)"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

schematic_lemma "?p : (ALL x. Q(x))  -->  (EX x. Q(x))"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

text "Some slow ones"

(*Principia Mathematica *11.53  *)
schematic_lemma "?p : (ALL x y. P(x) --> Q(y)) <-> ((EX x. P(x)) --> (ALL y. Q(y)))"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

(*Principia Mathematica *11.55  *)
schematic_lemma "?p : (EX x y. P(x) & Q(x,y)) <-> (EX x. P(x) & (EX y. Q(x,y)))"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

(*Principia Mathematica *11.61  *)
schematic_lemma "?p : (EX y. ALL x. P(x) --> Q(x,y)) --> (ALL x. P(x) --> (EX y. Q(x,y)))"
  by (tactic {* IntPr.fast_tac @{context} 1 *})

end


(******************************************************************************)
(* Project: The Isabelle/UTP Proof System                                     *)
(* File: Interpret.thy                                                        *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@gmail.com and simon.foster@york.ac.uk                  *)
(******************************************************************************)
(* LAST REVIEWED: 09 Jun 2022 *)

section \<open>Interpretation Tools\<close>

theory Interpret
imports Main
begin

subsection \<open>Preliminaries\<close>

definition surj_on :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> bool" where
"surj_on f A \<longleftrightarrow> f ` A = UNIV"

lemma surj_onI [intro]:
"f ` A = UNIV \<Longrightarrow> surj_on f A"
apply (unfold surj_on_def)
apply (assumption)
done

lemma surj_onD [dest]:
"surj_on f A \<Longrightarrow> \<exists>x\<in>A. f x = y"
apply (unfold surj_on_def)
apply (simp add: image_def)
apply (simp add: set_eq_iff)
apply (drule_tac x = "y" in spec)
apply (clarsimp)
apply (rule_tac x = "x" in bexI)
apply (rule refl)
apply (assumption)
done

lemma surj_comp_funct:
"inj f \<Longrightarrow> surj (\<lambda>g. g o f)"
apply (rule_tac f = "\<lambda>g. g o (inv f)" in surjI)
apply (simp)
done

subsection \<open>Locale @{text interp}\<close>

text \<open>
  Interestingly, surjectivity of the interpretation function @{term f} turns
  out to be sufficient. Compare this, for instance, to the assumptions used in
  the theory @{text Transfer_extra} where we effectively exploit the fact that
  the abstraction and representation functions are indeed mutual inverses.
\<close>

locale interp =
fixes f :: "'a \<Rightarrow> 'b"
fixes A :: "'a set"
assumes f_surj_on_A: "surj_on f A"
begin
lemma forall_transfer:
"(\<forall>y::'b. P y) = (\<forall>(x::'a)\<in>A. P (f x))"
apply (safe)
\<comment> \<open>Subgoal 1\<close>
apply (drule_tac x = "f x" in spec)
apply (assumption)
\<comment> \<open>Subgoal 2\<close>
apply (insert surj_onD [OF f_surj_on_A])
apply (drule_tac x = "y" in meta_spec)
apply (clarsimp)
done

lemma exists_transfer:
"(\<exists>y::'b. P y) = (\<exists>(x::'a)\<in>A. P (f x))"
apply (safe)
\<comment> \<open>Subgoal 1\<close>
apply (insert surj_onD [OF f_surj_on_A]) [1]
apply (drule_tac x = "y" in meta_spec)
apply (clarsimp)
apply (rule_tac x = "x" in bexI)
apply (assumption)
apply (assumption)
\<comment> \<open>Subgoal 2\<close>
apply (rule_tac x = "f x" in exI)
apply (assumption)
done

lemma meta_transfer:
"(\<And>y::'b. PROP P y) \<equiv> (\<And>x::'a. x \<in> A \<Longrightarrow> PROP P (f x))"
apply (rule)
\<comment> \<open>Subgoal 1\<close>
apply (drule_tac x = "f x" in meta_spec)
apply (assumption)
\<comment> \<open>Subgoal 2\<close>
apply (insert surj_onD [OF f_surj_on_A])
apply (drule_tac x = "y" in meta_spec)
(* apply (clarsimp) *)
(* The following is clumsy but clarsimp seems not to work?! *)
apply (drule_tac x = "SOME x. x \<in> A \<and> f x = y" in meta_spec)
apply (subgoal_tac "(SOME x. x \<in> A \<and> f x = y) \<in> A")
\<comment> \<open>Subgoal 2.1\<close>
apply (clarsimp)
apply (subgoal_tac "f (SOME x. x \<in> A \<and> f x = y) = y")
\<comment> \<open>Subgoal 2.1.1\<close>
apply (clarsimp)
\<comment> \<open>Subgoal 2.1.2\<close>
apply (erule someI2_bex; clarsimp)
\<comment> \<open>Subgoal 2.2\<close>
apply (erule someI2_bex; clarsimp)
done

lemmas transfer =
  meta_transfer
  forall_transfer
  exists_transfer
end
end


(*  Title:       Isabelle Collections Framework
    Author:      Peter Lammich <lammich at in.tum.de>
    Maintainer:  Peter Lammich <lammich at in.tum.de>
*)
header {* \isaheader{More Generic Algorithms} *}
theory Algos
imports
  "../spec/SetSpec"
  "../spec/MapSpec"
  "../spec/ListSpec"
begin
text_raw {*\label{thy:Algos}*}

subsection "Injective Map to Naturals"

text "Whether a set is an initial segment of the natural numbers"
definition inatseg :: "nat set \<Rightarrow> bool"
  where "inatseg s == \<exists>k. s = {i::nat. i<k}"

lemma inatseg_simps[simp]:
  "inatseg {}"
  "inatseg {0}"
  by (unfold inatseg_def)
    auto

text "Compute an injective map from objects into an initial
    segment of the natural numbers"
locale map_to_nat_loc =
  s!: StdSet s_ops +
  m!: StdMap m_ops
  for s_ops :: "('x,'s,'more1) set_ops_scheme"
  and m_ops :: "('x,nat,'m,'more2) map_ops_scheme"
begin

  definition map_to_nat
    :: "'s \<Rightarrow> 'm" where
    "map_to_nat s ==
      snd (s.iterate s (\<lambda>x (c,m). (c+1,m.update x c m)) (0,m.empty ()))"

  lemma map_to_nat_correct:
    assumes INV[simp]: "s.invar s"
    shows
      -- "All elements have got a number"
      "dom (m.\<alpha> (map_to_nat s)) = s.\<alpha> s" (is ?T1) and
      -- "No two elements got the same number"
      [rule_format]: "inj_on (m.\<alpha> (map_to_nat s)) (s.\<alpha> s)" (is ?T2) and
      -- "Numbering is inatseg"
      [rule_format]: "inatseg (ran (m.\<alpha> (map_to_nat s)))" (is ?T3) and
      -- "The result satisfies the map invariant"
      "m.invar (map_to_nat s)" (is ?T4)
    proof -
      have i_aux: "!!m S S' k v. \<lbrakk>inj_on m S; S' = insert k S; v\<notin>ran m\<rbrakk>
                                 \<Longrightarrow> inj_on (m(k\<mapsto>v)) S'"
        apply (rule inj_onI)
        apply (simp split: split_if_asm)
        apply (simp add: ran_def)
        apply (simp add: ran_def)
        apply blast
        apply (blast dest: inj_onD)
        done

      have "?T1 \<and> ?T2 \<and> ?T3 \<and> ?T4"
        apply (unfold map_to_nat_def)
        apply (rule_tac I="\<lambda>it (c,m).
          m.invar m \<and>
          dom (m.\<alpha> m) = s.\<alpha> s - it \<and>
          inj_on (m.\<alpha> m) (s.\<alpha> s - it) \<and>
          (ran (m.\<alpha> m) = {i. i<c})
          " in s.iterate_rule_P)
        apply simp
        apply (simp add: m.empty_correct)
        apply (case_tac \<sigma>)
        apply (simp add: m.empty_correct m.update_correct)
        apply (intro conjI)
        apply blast
        apply clarify
        apply (rule_tac m="m.\<alpha> ba" and
                        k=x and v=aa and
                        S'="(s.\<alpha> s - (it - {x}))" and
                        S="(s.\<alpha> s - it)"
                        in i_aux)
        apply auto [3]
        apply auto [1]
        apply (case_tac \<sigma>)
        apply (auto simp add: inatseg_def)
        done
      thus ?T1 ?T2 ?T3 ?T4 by auto
    qed

end

subsection "Map from Set"
text "Build a map using a set of keys and a function to compute the values."

locale it_dom_fun_to_map_loc =
  s!: StdSet s_ops
+ m!: StdMap m_ops
  for s_ops :: "('k,'s,'more1) set_ops_scheme"
  and m_ops :: "('k,'v,'m,'more2) map_ops_scheme"
begin

  definition it_dom_fun_to_map ::
    "'s \<Rightarrow> ('k \<Rightarrow> 'v) \<Rightarrow> 'm"
    where "it_dom_fun_to_map s f ==
           s.iterate s (\<lambda>k m. m.update_dj k (f k) m) (m.empty ())"

  lemma it_dom_fun_to_map_correct:
    assumes INV: "s.invar s"
    shows "m.\<alpha> (it_dom_fun_to_map s f) k
      = (if k \<in> s.\<alpha> s then Some (f k) else None)" (is ?G1)
    and "m.invar (it_dom_fun_to_map s f)" (is ?G2)
  proof -
    have "m.\<alpha> (it_dom_fun_to_map s f) k
      = (if k \<in> s.\<alpha> s then Some (f k) else None) \<and>
      m.invar (it_dom_fun_to_map s f)"
      unfolding it_dom_fun_to_map_def
      apply (rule s.iterate_rule_P[where
        I = "\<lambda>it res. m.invar res
        \<and> (\<forall>k. m.\<alpha> res k = (if (k \<in> (s.\<alpha> s) - it) then Some (f k) else None))"
        ])
        apply (simp add: INV)

        apply (simp add: m.empty_correct)

        apply (subgoal_tac "x\<notin>dom (m.\<alpha> \<sigma>)")

        apply (auto simp: INV m.empty_correct m.update_dj_correct) []

        apply auto [2]
      done
    thus ?G1 and ?G2
      by auto
  qed

end

locale set_to_list_defs_loc =
  s!: StdSetDefs s_ops
+ l!: StdListDefs l_ops
  for s_ops :: "('x,'s,'more1) set_ops_scheme"
  and l_ops :: "('x,'l,'more2) list_ops_scheme"
begin
  definition "g_set_to_listl s \<equiv> s.iterate s l.appendl (l.empty ())"
  definition "g_set_to_listr s \<equiv> s.iterate s l.appendr (l.empty ())"
end

locale set_to_list_loc = set_to_list_defs_loc s_ops l_ops
+ s!: StdSet s_ops
+ l!: StdList l_ops
  for s_ops :: "('x,'s,'more1) set_ops_scheme"
  and l_ops :: "('x,'l,'more2) list_ops_scheme"
begin
  lemma g_set_to_listl_correct:
    assumes I: "s.invar s"
    shows "List.set (l.\<alpha> (g_set_to_listl s)) = s.\<alpha> s"
    and "l.invar (g_set_to_listl s)"
    and "distinct (l.\<alpha> (g_set_to_listl s))"
    using I apply -
    unfolding g_set_to_listl_def
    apply (rule_tac I="\<lambda>it \<sigma>. l.invar \<sigma> \<and> List.set (l.\<alpha> \<sigma>) = it
      \<and> distinct (l.\<alpha> \<sigma>)"
      in s.iterate_rule_insert_P, auto simp: l.correct)+
    done

  lemma g_set_to_listr_correct:
    assumes I: "s.invar s"
    shows "List.set (l.\<alpha> (g_set_to_listr s)) = s.\<alpha> s"
    and "l.invar (g_set_to_listr s)"
    and "distinct (l.\<alpha> (g_set_to_listr s))"
    using I apply -
    unfolding g_set_to_listr_def
    apply (rule_tac I="\<lambda>it \<sigma>. l.invar \<sigma> \<and> List.set (l.\<alpha> \<sigma>) = it
      \<and> distinct (l.\<alpha> \<sigma>)"
      in s.iterate_rule_insert_P, auto simp: l.correct)+
    done

end

end


theory T75
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory Monad
  imports Main
begin

datatype ('M, 'a) state = State (runState: "'M \<Rightarrow> 'a \<times> 'M")
term 0 (**)

definition return :: "'a \<Rightarrow> ('M, 'a) state" where
  "return a \<equiv> State (\<lambda>M. (a, M))"
term 0 (**)

definition bind :: "('M, 'a) state \<Rightarrow> ('a \<Rightarrow> ('M, 'b) state) \<Rightarrow> ('M, 'b) state" (infixl "\<bind>" 54) where
  "s \<bind> k \<equiv> State (\<lambda>M. let (a, M') = runState s M in runState (k a) M')"
term 0 (**)

abbreviation then_monad :: "('M, 'a) state \<Rightarrow> ('M, 'b) state \<Rightarrow> ('M, 'b) state" (infixl "\<then>" 54) where
  "s \<then> s' \<equiv> s \<bind> (\<lambda>_. s')"
term 0 (**)

definition get :: "('M, 'M) state" where
  "get \<equiv> State (\<lambda>M. (M, M))"

definition put :: "'M \<Rightarrow> ('M, unit) state" where
  "put M \<equiv> State (\<lambda>_. ((), M))"
term 0 (**)

nonterminal do_binds and do_bind
syntax
  "_do_block" :: "do_binds \<Rightarrow> 'a" ("do {//(2  _)//}" [12] 62)
  "_do_bind"  :: "[pttrn, 'a] \<Rightarrow> do_bind" ("(2_ \<leftarrow>/ _)" 13)
  "_do_let" :: "[pttrn, 'a] \<Rightarrow> do_bind" ("(2let _ =/ _)" [1000, 13] 13)
  "_do_then" :: "'a \<Rightarrow> do_bind" ("_" [14] 13)
  "_do_final" :: "'a \<Rightarrow> do_binds" ("_")
  "_do_cons" :: "[do_bind, do_binds] \<Rightarrow> do_binds" ("_;//_" [13, 12] 12)

translations
  "_do_block (_do_cons (_do_then t) (_do_final e))"
    \<rightleftharpoons> "CONST then_monad t e"
  "_do_block (_do_cons (_do_bind p t) (_do_final e))"
    \<rightleftharpoons> "CONST bind t (\<lambda>p. e)"
  "_do_block (_do_cons (_do_let p t) bs)"
    \<rightleftharpoons> "let p = t in _do_block bs"
  "_do_block (_do_cons b (_do_cons c cs))"
    \<rightleftharpoons> "_do_block (_do_cons b (_do_final (_do_block (_do_cons c cs))))"
  "_do_cons (_do_let p t) (_do_final s)"
    \<rightleftharpoons> "_do_final (let p = t in s)"
  "_do_block (_do_final e)" \<rightharpoonup> "e"

term 0 (**)
lemma bind_assoc:
  "(s \<bind> k0) \<bind> k1 = s \<bind> (\<lambda>a. k0 a \<bind> k1)"
  unfolding bind_def by (auto split: prod.split)

lemma left_identity:
  "return v \<bind> k = k v"
  unfolding return_def bind_def by simp

lemma right_identity:
  "s \<bind> return = s"
  unfolding return_def bind_def by simp

lemma runState_return:
  "runState (return x) M = (x, M)"
  unfolding return_def by simp
end


theory Observation
  imports Main History
begin

section \<open>Observations\<close>

text \<open>Fundamentally, an observation is a set of objects and observed transactions over them.\<close>

datatype observation = Observation "object set" "otxn set"

text \<open>We define some basic accessors...\<close>

primrec all_otxns :: "observation \<Rightarrow> otxn set" where
"all_otxns (Observation objs txns) = txns"

instantiation observation :: all_objects
begin
primrec all_objects_observation :: "observation \<Rightarrow> object set" where
"all_objects_observation (Observation objs txns) = objs"
instance ..
end

instantiation observation :: all_versions
begin
primrec all_versions_observation :: "observation \<Rightarrow> version set" where
"all_versions_observation (Observation objs txns) = \<Union>{all_versions t | t. t \<in> txns}"
instance ..
end

instantiation observation :: all_oops
begin
primrec all_oops_observation :: "observation \<Rightarrow> oop set" where
"all_oops_observation (Observation objs txns) = \<Union>{all_oops t | t. t \<in> txns}"
instance ..
end

text \<open>A well-formed observation is made up of well-formed objects and transactions, and its
transactions are over those objects.\<close>

primrec wf_observation :: "observation \<Rightarrow> bool" where
"wf_observation (Observation objs txns) =
  ((\<forall>obj. obj \<in> objs \<longrightarrow> wf_object obj) \<and>
   (\<forall>t. t \<in> txns \<longrightarrow> (wf_otxn t \<and> (\<forall>oop. (oop \<in> (all_oops t)) \<longrightarrow>
                                          (\<exists>!obj. (obj \<in> objs) \<and> ((key oop) = (key obj)))))))"

text \<open>We say an observation is compatible with a history via relation m if they have the same
object set, the same number of transactions, and m is a bijective mapping from observed transactions
in the observation to compatible abstract transactions in the history.\<close>

definition is_compatible_observation :: "observation \<Rightarrow> (otxn \<Rightarrow> atxn) \<Rightarrow> history \<Rightarrow> bool" where
"is_compatible_observation obs m h =
  ((all_objects obs = all_objects h) \<and>
   (\<forall>otxn. otxn \<in> (all_otxns obs) \<longrightarrow> (is_compatible_txn otxn (m otxn))))"

section \<open>Interpretations\<close>

text \<open>An interpretation of an observation O is a history H and a bijection M which translates
operations in O to compatible observations in H. Interpretation is a reserved word, so...\<close>

datatype interp = Interp "observation" "(otxn \<Rightarrow> atxn)" "history"

primrec history :: "interp \<Rightarrow> history" where
"history (Interp obs m h) = h"

text \<open>We say f is a total bijection between a and b iff f is bijective and every a maps to a b.
I feel like there should be something for this in Isabelle already but I'm not sure.\<close>

text \<open>Giuliano: you can use the query panel to search for constants or theorems.
Here, look for a constant of the following type: "(_ \<Rightarrow> _) \<Rightarrow> _ set \<Rightarrow> _ set \<Rightarrow> bool", and it will find:\<close>
thm Fun.bij_betw_def \<comment> \<open>That is probably what you wanted\<close>

definition total_bij :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> bool" where
"total_bij f as bs \<equiv> ((bij f) \<and> (\<forall>a. (a \<in> as) \<longrightarrow> ((f a) \<in> bs)))"

(* I can't even show this? Really?  *)
text \<open>Giuliano: it's because it does not hold :) You forgot to assume that @{term \<open>a \<in> as\<close>}.
It's often a good idea to run nitpick as a first sanity check. Here, it immediately finds a counter-example\<close>
lemma "(total_bij f as bs \<and> (b = (f a))) \<longrightarrow> (b \<in> bs)"
  nitpick
  apply (simp add:total_bij_def)
  apply auto
  oops

lemma my_lemma:
  assumes "total_bij f as bs" and "b = f a" and "a \<in> as"
  shows "(b \<in> bs)" \<comment> \<open>Note that this syntax is better becuase it produces a lemma in rule format, ready to be applied without transformation.\<close>
  using assms total_bij_def by fastforce \<comment> \<open>found by sledgehammer in a few seconds\<close>

lemma my_lemma_bad:
  "total_bij f as bs \<and> b = f a \<and> a \<in> as \<longrightarrow> b \<in> bs"
  using total_bij_def by fastforce

text \<open>Now check what the lemmas looks like with @{command thm}\<close>
thm my_lemma \<comment> \<open>In rule form\<close>
thm my_lemma_bad \<comment> \<open>Not in rule form; cannot be applied directly by generic proof tools like auto\<close>

(* Huh, would have thought this would be easy *)
lemma total_bij_image1: "(total_bij f a b) \<Longrightarrow> ((f`a) = b)"
  nitpick \<comment> \<open>Again, nitpick shows that it does not hold\<close>
  apply (simp add: total_bij_def)

  oops

text \<open>Well-formed interpretations are made up of a well-formed observation, a bijection between
observed and abstract transactions, and a well-formed history, such that the observation and
the history are compatible via that bijection.\<close>

primrec wf_interpretation :: "interp \<Rightarrow> bool" where
"wf_interpretation (Interp obs m h) = ((wf_observation obs) \<and>
                                       (wf_history h) \<and>
                                       (total_bij m (all_otxns obs) (all_atxns h)) \<and>
                                       (is_compatible_observation obs m h))"

text \<open>This lets us talk about corresponding transactions via that bijection m.\<close>

primrec corresponding_atxn :: "interp \<Rightarrow> otxn \<Rightarrow> atxn" where
"corresponding_atxn (Interp obs m h) otxn = (m otxn)"

primrec corresponding_otxn :: "interp \<Rightarrow> atxn \<Rightarrow> otxn" where
"corresponding_otxn (Interp obs m h) atxn = (THE otxn. atxn = m otxn)"

text \<open>These are invertible, thanks to m being bijective.\<close>

lemma "(corresponding_otxn (Interp obs h m) atxn) \<in> (all_otxns obs)"

lemma corresponding_invertible: "(corresponding_otxn i (corresponding_atxn i t)) = t"
  oops

section \<open>Recoverability\<close>

text \<open>Recoverability allows us to (in some cases) map a version of some key to a specific
observed transaction which must have produced it. To start, we figure out when a transaction
could have written a particular version of an object: some write resulting in this version of the
object is compatible with a write in the transaction.\<close>

definition could_have_been_written_by :: "object \<Rightarrow> version \<Rightarrow> otxn \<Rightarrow> bool" where
"could_have_been_written_by obj v t \<equiv> (\<exists>aw ow. aw \<in> awrites_of obj v \<and>
                                               ow \<in> all_owrites t \<and>
                                               is_compatible_op ow aw)"

(* might have this wrong *)
lemma "((could_have_been_written_by obj v ot) \<and> (is_compatible_txn ot atxn)) \<longrightarrow>
        (\<exists>v0 a r. (AWrite k v0 a v r) \<in> all_awrites atxn)"
  oops

text \<open>Given an observation, we say a version v of key k is recoverable to a transaction t if t is
the only transaction which could have written that v of k.\<close>

definition is_recoverable :: "observation \<Rightarrow> key \<Rightarrow> version \<Rightarrow> otxn \<Rightarrow> bool" where
"is_recoverable obs k v ot \<equiv> (let obj = (THE ob. ob \<in> all_objects obs \<and> key ob = k) in
                                (could_have_been_written_by obj v ot) \<and>
                                (\<exists>!t. t \<in> all_otxns obs \<and> could_have_been_written_by obj v t))"

end


section {* UTP designs data refinement example *}

theory utp_designs_ref_ex
imports "../theories/utp_designs"
begin

text {* This theory is currently incomplete *}

alphabet my_state =
  s :: "int set"
  q :: "int list"

abbreviation Inv_A :: "my_state upred" where
"Inv_A \<equiv> finite\<^sub>u(&s)"

definition Init_A :: "my_state hrel_des" where
[upred_defs]: "Init_A = (true \<turnstile>\<^sub>n ($s\<acute> =\<^sub>u {}\<^sub>u))"

abbreviation "pre_Add_A(x) \<equiv> Inv_A \<and> \<guillemotleft>x\<guillemotright> \<notin>\<^sub>u &s"

definition Add_A :: "int \<Rightarrow> my_state hrel_des" where
[upred_defs]: "Add_A(x) = (pre_Add_A(x) \<turnstile>\<^sub>n ($s\<acute> =\<^sub>u $s \<union>\<^sub>u {\<guillemotleft>x\<guillemotright>}\<^sub>u))"

abbreviation "pre_Del_A(x) \<equiv> Inv_A \<and> \<guillemotleft>x\<guillemotright> \<in>\<^sub>u &s"

definition Del_A :: "int \<Rightarrow> my_state hrel_des" where
[upred_defs]: "Del_A(x) = (pre_Del_A(x) \<turnstile>\<^sub>n ($s\<acute> =\<^sub>u $s - {\<guillemotleft>x\<guillemotright>}\<^sub>u))"

abbreviation Inv_C :: "my_state upred" where
"Inv_C \<equiv> distinct\<^sub>u(&q)"

definition Init_C :: "my_state hrel_des" where
[upred_defs]: "Init_C = (true \<turnstile>\<^sub>n ($q\<acute> =\<^sub>u \<langle>\<rangle>))"

abbreviation "pre_Add_C(x) \<equiv> Inv_C \<and> \<guillemotleft>x\<guillemotright> \<notin>\<^sub>u ran\<^sub>u(&q)"

definition Add_C :: "int \<Rightarrow> my_state hrel_des" where
[upred_defs]: "Add_C(x) = (pre_Add_C(x) \<turnstile>\<^sub>n ($q\<acute> =\<^sub>u $q ^\<^sub>u \<langle>\<guillemotleft>x\<guillemotright>\<rangle>))"

abbreviation "pre_Del_C(x) \<equiv> Inv_C \<and> \<guillemotleft>x\<guillemotright> \<in>\<^sub>u ran\<^sub>u(&q)"

definition Del_C :: "int \<Rightarrow> my_state hrel_des" where
[upred_defs]: "Del_C(x) = (pre_Del_C(x) \<turnstile>\<^sub>n ($q\<acute> =\<^sub>u $q \<restriction>\<^sub>u (- {\<guillemotleft>x\<guillemotright>}\<^sub>u)))"

definition Abs :: "my_state upred" where
[upred_defs]: "Abs = (distinct\<^sub>u(&q) \<and> &s =\<^sub>u ran\<^sub>u(&q))"

lemma Del_Del: "(Del_A(x) ;; Del_A(x)) = \<bottom>\<^sub>D"
  by (rel_auto)

lemma Add_commute:
  assumes "x \<noteq> y"
  shows "(Add_A(x) ;; Add_A(y)) = (Add_A(y) ;; Add_A(x))"
  using assms by (rel_auto)

end


(* 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.*)
  theory TIP_list_count_nub
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun filter :: "('a => bool) => 'a list => 'a list" where
  "filter p (nil2) = nil2"
| "filter p (cons2 y xs) =
     (if p y then cons2 y (filter p xs) else filter p xs)"

(*fun did not finish the proof*)
function nubBy :: "('a => ('a => bool)) => 'a list => 'a list" where
  "nubBy x (nil2) = nil2"
| "nubBy x (cons2 z xs) =
     cons2 z (nubBy x (filter (% (y2 :: 'a) => (~ ((x z) y2))) xs))"
by pat_completeness auto

fun elem :: "'a => 'a list => bool" where
  "elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun count :: "'a => 'a list => int" where
  "count x (nil2) = 0"
| "count x (cons2 z ys) =
     (if (x = z) then 1 + (count x ys) else count x ys)"

theorem property0 :
  "((elem x xs) ==>
      ((count x (nubBy (% (y :: 'a) => % (z :: 'a) => (y = z)) xs)) =
         1))"
  oops

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 "rcoset_mult"} fulfils the properties required by
  congruences\<close>
lemma (in ideal) rcoset_mult_add:
    "x \<in> carrier R \<Longrightarrow> y \<in> carrier R \<Longrightarrow> [mod I:] (I +> x) \<Otimes> (I +> y) = I +> (x \<otimes> y)"
  apply rule
  apply (rule, simp add: rcoset_mult_def, clarsimp)
  defer 1
  apply (rule, simp add: rcoset_mult_def)
  defer 1
proof -
  fix z x' y'
  assume carr: "x \<in> carrier R" "y \<in> carrier R"
    and x'rcos: "x' \<in> I +> x"
    and y'rcos: "y' \<in> I +> y"
    and zrcos: "z \<in> I +> x' \<otimes> y'"

  from x'rcos have "\<exists>h\<in>I. x' = h \<oplus> x"
    by (simp add: a_r_coset_def r_coset_def)
  then obtain hx where hxI: "hx \<in> I" and x': "x' = hx \<oplus> x"
    by fast+

  from y'rcos have "\<exists>h\<in>I. y' = h \<oplus> y"
    by (simp add: a_r_coset_def r_coset_def)
  then obtain hy where hyI: "hy \<in> I" and y': "y' = hy \<oplus> y"
    by fast+

  from zrcos have "\<exists>h\<in>I. z = h \<oplus> (x' \<otimes> y')"
    by (simp add: a_r_coset_def r_coset_def)
  then obtain hz where hzI: "hz \<in> I" and z: "z = hz \<oplus> (x' \<otimes> y')"
    by fast+

  note carr = carr hxI[THEN a_Hcarr] hyI[THEN a_Hcarr] hzI[THEN a_Hcarr]

  from z have "z = hz \<oplus> (x' \<otimes> y')" .
  also from x' y' have "\<dots> = 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 have "\<exists>h\<in>I. z = h \<oplus> x \<otimes> y" by fast
  then show "z \<in> I +> x \<otimes> y" by (simp add: a_r_coset_def r_coset_def)
next
  fix z
  assume xcarr: "x \<in> carrier R"
    and ycarr: "y \<in> carrier R"
    and zrcos: "z \<in> I +> x \<otimes> y"
  from xcarr have xself: "x \<in> I +> x" by (intro a_rcos_self)
  from ycarr have yself: "y \<in> I +> y" by (intro a_rcos_self)
  show "\<exists>a\<in>I +> x. \<exists>b\<in>I +> y. z \<in> I +> a \<otimes> b"
    using xself and yself and zrcos by fast
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>"

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)"
apply (rule ringI)
   \<comment> \<open>abelian group\<close>
   apply (rule comm_group_abelian_groupI)
   apply (simp add: FactRing_def)
   apply (rule a_factorgroup_is_comm_group[unfolded A_FactGroup_def'])
  \<comment> \<open>mult monoid\<close>
  apply (rule monoidI)
      apply (simp_all add: FactRing_def A_RCOSETS_def RCOSETS_def
             a_r_coset_def[symmetric])
      \<comment> \<open>mult closed\<close>
      apply (clarify)
      apply (simp add: rcoset_mult_add, fast)
     \<comment> \<open>mult \<open>one_closed\<close>\<close>
     apply force
    \<comment> \<open>mult assoc\<close>
    apply clarify
    apply (simp add: rcoset_mult_add m_assoc)
   \<comment> \<open>mult one\<close>
   apply clarify
   apply (simp add: rcoset_mult_add)
  apply clarify
  apply (simp add: rcoset_mult_add)
 \<comment> \<open>distr\<close>
 apply clarify
 apply (simp add: rcoset_mult_add a_rcos_sum l_distr)
apply clarify
apply (simp add: rcoset_mult_add a_rcos_sum r_distr)
done

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

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

lemma (in ideal) rcos_ring_hom_ring: "ring_hom_ring R (R Quot I) ((+>) I)"
apply (rule ring_hom_ringI)
     apply (rule ring_axioms, rule quotient_is_ring)
   apply (simp add: FactRing_def a_rcosetsI[OF a_subset])
  apply (simp add: FactRing_def rcoset_mult_add)
 apply (simp add: FactRing_def a_rcos_sum)
apply (simp add: FactRing_def)
done

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)
      apply (rule quotient_is_ring)
     apply (rule ring.axioms[OF quotient_is_ring])
    apply (simp add: FactRing_def A_RCOSETS_defs a_r_coset_def[symmetric])
    apply clarify
    apply (simp add: 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)"
  apply (rule domain.intro)
   apply (rule quotient_is_cring, rule is_cring)
  apply (rule domain_axioms.intro)
   apply (simp add: FactRing_def) defer 1
    apply (simp add: FactRing_def A_RCOSETS_defs a_r_coset_def[symmetric], clarify)
    apply (simp add: rcoset_mult_add) defer 1
proof (rule ccontr, clarsimp)
  assume "I +> \<one> = I"
  then have "\<one> \<in> I" by (simp only: a_coset_join1 one_closed a_subgroup)
  then have "carrier R \<subseteq> I" by (subst one_imp_carrier, simp, fast)
  with a_subset have "I = carrier R" by fast
  with I_notcarr show False by fast
next
  fix x y
  assume carr: "x \<in> carrier R" "y \<in> carrier R"
    and a: "I +> x \<otimes> y = I"
    and b: "I +> y \<noteq> I"

  have ynI: "y \<notin> I"
  proof (rule ccontr, simp)
    assume "y \<in> I"
    then have "I +> y = I" by (rule a_rcos_const)
    with b show False by simp
  qed

  from carr have "x \<otimes> y \<in> I +> x \<otimes> y" by (simp add: a_rcos_self)
  then have xyI: "x \<otimes> y \<in> I" by (simp add: a)

  from xyI and carr have xI: "x \<in> I \<or> y \<in> I" by (simp add: I_prime)
  with ynI have "x \<in> I" by fast
  then show "I +> x = I" by (rule a_rcos_const)
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>
lemma (in maximalideal) quotient_is_field:
  assumes "cring R"
  shows "field (R Quot I)"
proof -
  interpret cring R by fact
  show ?thesis
    apply (intro cring.cring_fieldI2)
      apply (rule quotient_is_cring, rule is_cring)
     defer 1
     apply (simp add: FactRing_def A_RCOSETS_defs a_r_coset_def[symmetric], clarsimp)
     apply (simp add: rcoset_mult_add) defer 1
  proof (rule ccontr, simp)
    \<comment> \<open>Quotient is not empty\<close>
    assume "\<zero>\<^bsub>R Quot I\<^esub> = \<one>\<^bsub>R Quot I\<^esub>"
    then have II1: "I = I +> \<one>" by (simp add: FactRing_def)
    from a_rcos_self[OF one_closed] have "\<one> \<in> I"
      by (simp add: II1[symmetric])
    then have "I = carrier R" by (rule one_imp_carrier)
    with I_notcarr show False by simp
  next
    \<comment> \<open>Existence of Inverse\<close>
    fix a
    assume IanI: "I +> a \<noteq> I" and acarr: "a \<in> carrier R"

    \<comment> \<open>Helper ideal \<open>J\<close>\<close>
    define J :: "'a set" where "J = (carrier R #> a) <+> I"
    have idealJ: "ideal J R"
      apply (unfold J_def, rule add_ideals)
       apply (simp only: cgenideal_eq_rcos[symmetric], rule cgenideal_ideal, rule acarr)
      apply (rule is_ideal)
      done

    \<comment> \<open>Showing @{term "J"} not smaller than @{term "I"}\<close>
    have IinJ: "I \<subseteq> J"
    proof (rule, simp add: J_def r_coset_def set_add_defs)
      fix x
      assume xI: "x \<in> I"
      have Zcarr: "\<zero> \<in> carrier R" by fast
      from xI[THEN a_Hcarr] acarr
      have "x = \<zero> \<otimes> a \<oplus> x" by algebra
      with Zcarr and xI show "\<exists>xa\<in>carrier R. \<exists>k\<in>I. x = xa \<otimes> a \<oplus> k" by fast
    qed

    \<comment> \<open>Showing @{term "J \<noteq> I"}\<close>
    have anI: "a \<notin> I"
    proof (rule ccontr, simp)
      assume "a \<in> I"
      then have "I +> a = I" by (rule a_rcos_const)
      with IanI show False by simp
    qed

    have aJ: "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

    from aJ and anI have JnI: "J \<noteq> I" by fast

    \<comment> \<open>Deducing @{term "J = carrier R"} because @{term "I"} is maximal\<close>
    from idealJ and IinJ have "J = I \<or> J = carrier R"
    proof (rule I_maximal, unfold J_def)
      have "carrier R #> a \<subseteq> carrier R"
        using subset_refl acarr by (rule r_coset_subset_G)
      then show "carrier R #> a <+> I \<subseteq> carrier R"
        using a_subset by (rule set_add_closed)
    qed

    with JnI have Jcarr: "J = carrier R" by simp

    \<comment> \<open>Calculating an inverse for @{term "a"}\<close>
    from one_closed[folded Jcarr]
    have "\<exists>r\<in>carrier R. \<exists>i\<in>I. \<one> = r \<otimes> a \<oplus> i"
      by (simp add: J_def r_coset_def set_add_defs)
    then obtain r i where rcarr: "r \<in> carrier R"
      and iI: "i \<in> I" and one: "\<one> = r \<otimes> a \<oplus> i" by fast
    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
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 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

(* PROOF ========================================================================== *)
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

(* PROOF ========================================================================== *)
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

(* PROOF ========================================================================== *)
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

(* PROOF ========================================================================== *)
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

(* PROOF ========================================================================== *)
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

(* PROOF ==================================================================== *)
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"
  shows "h \<in> ring_iso R S \<Longrightarrow> (inv_into (carrier R) h) \<in> ring_iso S R"
proof -
  assume h: "h \<in> ring_iso R S"
  hence 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"
    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)"
      using bij_betw_inv_into h ring_iso_def by fastforce

  show "inv_into (carrier R) h \<in> ring_iso S R"
    apply (rule ring_iso_memI)
    apply (simp add: h_surj inv_into_into)
    apply (auto simp add: h_inv_bij)
    apply (smt assms f_inv_into_f h_hom h_inj h_surj inv_into_into
           ring.ring_simprules(5) ring_hom_closed ring_hom_mult)
    apply (smt assms f_inv_into_f h_hom h_inj h_surj inv_into_into
           ring.ring_simprules(1) ring_hom_add ring_hom_closed)
    by (metis (no_types, hide_lams) assms f_inv_into_f h_hom h_inj
        imageI inv_into_into ring.ring_simprules(6) ring_hom_one)
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_def RCOSETS_def A_RCOSETS_def 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_def RCOSETS_def A_RCOSETS_def 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

(* PROOF ========================================================================== *)
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