theory BinarySearch
  imports "../Refine_Imperative_HOL/IICF/IICF"
     "NREST.RefineMonadicVCG" "Imperative_HOL_Time.Asymptotics_1D"
begin
section "Binary Search"

definition avg :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "avg l r = (l + r) div 2"

definition "listlookup_time = 1"

function binarysearch_time :: "nat \<Rightarrow> nat" where
  "n < 2 \<Longrightarrow> binarysearch_time n = 2 + listlookup_time"
| "n \<ge> 2 \<Longrightarrow> binarysearch_time n = 2 + listlookup_time + binarysearch_time (n div 2)"
by force simp_all
termination by (relation "Wellfounded.measure (\<lambda>n. n)") auto

definition binarysearch_time' :: "nat \<Rightarrow> real" where
  "binarysearch_time' n = real (binarysearch_time n)"

lemma div_2_to_rounding:
  "n - n div 2 = nat \<lceil>n / 2\<rceil>" "n div 2 = nat \<lfloor>n / 2\<rfloor>" by linarith+

lemma binarysearch_time'_Theta: "(\<lambda>n. binarysearch_time' n) \<in> \<Theta>(\<lambda>n. ln (real n))"
  apply (master_theorem2 2.3 recursion: binarysearch_time.simps(2) rew: binarysearch_time'_def div_2_to_rounding)
  unfolding listlookup_time_def
  prefer 2 apply auto2
  by (auto simp: binarysearch_time'_def)

lemma binarysearch_mono:
  "m \<le> n \<Longrightarrow> binarysearch_time m \<le> binarysearch_time n"
proof (induction n arbitrary: m rule: less_induct)
  case (less n)
  show ?case
  proof (cases "m<2")
    case True
    then show ?thesis apply (cases "n<2") by auto
  next
    case False
    then show ?thesis using less(2) by (auto intro: less(1))
  qed
qed

definition binarysearch_SPEC :: "nat \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool nrest" where
  "binarysearch_SPEC l r xs x
   = SPECT (emb (\<lambda>s. s \<longleftrightarrow> (\<exists>i. l \<le> i \<and> i < r \<and> xs ! i = x)) (binarysearch_time (r-l)) )"

definition "binarysearch l r x xs \<equiv>
    RECT (\<lambda>fw (l,r).
      if l \<ge> r then RETURNT False
    else if l + 1 \<ge> r then do {
              ASSERT (l < length xs);
             xsi \<leftarrow> mop_lookup_list (\<lambda>_. listlookup_time) xs l;
                                RETURNT (xsi = x) }
    else do {
        m \<leftarrow> RETURNT (avg l r);
        ASSERT (m < length xs);
        xm \<leftarrow> mop_lookup_list (\<lambda>_. listlookup_time) xs m;
      (if xm = x then RETURNT True
      else if xm < x then fw (m + 1, r)
      else fw (l, m))
      }
  ) (l,r)"

prepare_code_thms binarysearch_def
print_theorems
thm binarysearch.code(1,2)

lemma avg_diff1: "(l::nat) \<le> r \<Longrightarrow> r - (avg l r + 1) \<le> (r - l) div 2" by (simp add: avg_def)
lemma avg_diff2: "(l::nat) \<le> r \<Longrightarrow> avg l r - l \<le> (r - l) div 2" by  (simp add: avg_def)

lemma avg_between [backward] :
  "l + 1 < r \<Longrightarrow> r > avg l r"
  "l + 1 < r \<Longrightarrow> avg l r > l" by (auto simp: avg_def)

lemma binarysearch_correct: "sorted xs \<Longrightarrow> l \<le> r \<Longrightarrow> r \<le> length xs \<Longrightarrow>
   binarysearch l r x xs \<le> binarysearch_SPEC l r xs x"
  unfolding binarysearch_SPEC_def
  apply(rule T_specifies_I)
    apply(subst binarysearch.code(1))
proof(induct "r-l" arbitrary: l r rule: less_induct)
  case less
  from less(2-4) show ?case apply(subst binarysearch.code(2))  unfolding mop_lookup_list_def
     apply (vcg'\<open>simp\<close> rules: less(1)[THEN T_conseq4] )
    unfolding Some_le_emb'_conv Some_eq_emb'_conv
    subgoal by auto
    subgoal using le_less_Suc_eq by fastforce
    subgoal apply (simp) by auto2
    subgoal by(simp add: avg_def)
    subgoal by(simp add: avg_def)
    subgoal
      apply (rule allI conjI) apply auto2
        using binarysearch_mono[OF avg_diff1]
        by (simp add: le_SucI)
    subgoal by(simp add: avg_def)
    subgoal by(simp add: avg_def)
    subgoal
      apply (rule allI conjI) apply auto2
        using binarysearch_mono[OF avg_diff2]
        by (simp add: le_SucI)
    subgoal by auto2
    done

qed

sepref_definition binarysearch_impl is
  "uncurry3 binarysearch" :: "nat_assn\<^sup>k *\<^sub>a nat_assn\<^sup>k *\<^sub>a id_assn\<^sup>k *\<^sub>a array_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn"
  unfolding binarysearch_def avg_def  listlookup_time_def
  using [[goals_limit = 3]]
  by sepref

thm binarysearch_impl.refine[to_hnr]
thm hnr_refine[OF binarysearch_correct ] binarysearch_impl.refine[to_hnr, unfolded autoref_tag_defs]
thm  hnr_refine[OF binarysearch_correct, OF _ _ _ binarysearch_impl.refine[to_hnr, unfolded autoref_tag_defs], no_vars]

lemma binary_search_impl_correct:
  assumes "sorted xs" "l \<le> r" "r \<le> length xs"
  shows "hn_refine (hn_ctxt array_assn xs bi * hn_val Id x bia * hn_val nat_rel r bib * hn_val nat_rel l ai)
            (binarysearch_impl ai bib bia bi)
            (hn_ctxt array_assn xs bi * hn_val Id x bia * hn_val nat_rel r bib * hn_val nat_rel l ai)
            bool_assn (binarysearch_SPEC l r xs x)"
  using assms hnr_refine[OF binarysearch_correct, OF _ _ _ binarysearch_impl.refine[to_hnr, unfolded autoref_tag_defs]] by metis

thm extract_cost_ub'[OF binary_search_impl_correct[unfolded  binarysearch_SPEC_def], where Cost_ub="binarysearch_time (r - l)" ]
lemma binary_search_correct': "sorted xs \<Longrightarrow> r \<le> length xs \<Longrightarrow> l \<le> r \<Longrightarrow>
     <hn_ctxt array_assn xs p * hn_val Id x bia * hn_val nat_rel r bib * hn_val nat_rel l ai * timeCredit_assn (binarysearch_time (r - l))>
        binarysearch_impl ai bib bia p
       <\<lambda>ra. hn_ctxt array_assn xs p * \<up> (ra \<longleftrightarrow> (\<exists>i\<ge>l. i < r \<and> xs ! i = x))>\<^sub>t"
  apply(rule extract_cost_ub'[OF binary_search_impl_correct[unfolded  binarysearch_SPEC_def], where Cost_ub="binarysearch_time (r - l)" ])
       apply auto
     apply(subst in_ran_emb_special_case) apply (simp_all add: pure_def) apply auto
   by (metis (no_types, lifting) ent_true_drop(1) entails_ex entt_refl')

subsection \<open>Final Hoare triple and run-time claim.\<close>

lemma binary_search_correct: "sorted xs \<Longrightarrow> r \<le> length xs \<Longrightarrow> l \<le> r \<Longrightarrow>
     <array_assn xs p * timeCredit_assn (binarysearch_time (r - l))>
        binarysearch_impl l r x p
       <\<lambda>ra.   array_assn xs p * \<up> (ra \<longleftrightarrow> (\<exists>i\<ge>l. i < r \<and> xs ! i = x))>\<^sub>t"
  apply(rule ht_cons_rule[OF _ _ binary_search_correct'[ unfolded hn_ctxt_def pure_def ]])
  by (sep_auto )+

lemma binary_search_time_ln: "binarysearch_time \<in> \<Theta>(\<lambda>n. ln (real n))"
  using binarysearch_time'_Theta unfolding binarysearch_time'_def by auto

end


theory Chapter9_2
imports "~~/src/HOL/IMP/Sec_Typing"
begin

text{*
\exercise
Reformulate the inductive predicate @{const sec_type}
as a recursive function and prove the equivalence of the two formulations:
*}

fun ok :: "level \<Rightarrow> com \<Rightarrow> bool" where
(* your definition/proof here *)

theorem "(l \<turnstile> c) = ok l c"
(* your definition/proof here *)

text{*
Try to reformulate the bottom-up system @{prop "\<turnstile> c : l"}
as a function that computes @{text l} from @{text c}. What difficulty do you face?
\endexercise

\exercise
Define a bottom-up termination insensitive security type system
@{text"\<turnstile>' c : l"} with subsumption rule:
*}

inductive sec_type2' :: "com \<Rightarrow> level \<Rightarrow> bool" ("(\<turnstile>' _ : _)" [0,0] 50) where
(* your definition/proof here *)

text{*
Prove equivalence with the bottom-up system @{prop "\<turnstile> c : l"}
without subsumption rule:
*}

lemma "\<turnstile> c : l \<Longrightarrow> \<turnstile>' c : l"
(* your definition/proof here *)

lemma "\<turnstile>' c : l \<Longrightarrow> \<exists>l' \<ge> l. \<turnstile> c : l'"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Define a function that erases those parts of a command that
contain variables above some security level: *}

fun erase :: "level \<Rightarrow> com \<Rightarrow> com" where
(* your definition/proof here *)

text{*
Function @{term "erase l"} should replace all assignments to variables with
security level @{text"\<ge> l"} by @{const SKIP}.
It should also erase certain @{text IF}s and @{text WHILE}s,
depending on the security level of the boolean condition. Now show
that @{text c} and @{term "erase l c"} behave the same on the variables up
to level @{text l}: *}

theorem "\<lbrakk> (c,s) \<Rightarrow> s';  (erase l c,t) \<Rightarrow> t';  0 \<turnstile> c;  s = t (< l) \<rbrakk>
   \<Longrightarrow> s' = t' (< l)"
(* your definition/proof here *)

text{* This theorem looks remarkably like the noninterference lemma from
theory \mbox{@{theory Sec_Typing}} (although @{text"\<le>"} has been replaced by @{text"<"}).
You may want to start with that proof and modify it.
The structure should remain the same. You may also need one or
two simple additional lemmas.

In the theorem above we assume that both @{term"(c,s)"}
and @{term "(erase l c,t)"} terminate. How about the following two properties: *}

lemma "\<lbrakk> (c,s) \<Rightarrow> s';  0 \<turnstile> c;  s = t (< l) \<rbrakk>
  \<Longrightarrow> \<exists>t'. (erase l c, t) \<Rightarrow> t' \<and> s' = t' (< l)"
(* your definition/proof here *)

lemma "\<lbrakk> (erase l c,s) \<Rightarrow> s';  0 \<turnstile> c;  s = t (< l) \<rbrakk>
  \<Longrightarrow> \<exists>t'. (c,t) \<Rightarrow> t' \<and> s' = t' (< l)"
(* your definition/proof here *)

text{* Give proofs or counterexamples.
\endexercise
*}

end


(*  Author: Tobias Nipkow, Alex Krauss, Dmitriy Traytel  *)

section "Regular Sets"

(*<*)
theory Pi_Regular_Set
imports Main
begin
(*>*)

type_synonym 'a lang = "'a list set"

definition conc :: "'a lang \<Rightarrow> 'a lang \<Rightarrow> 'a lang" (infixr "@@" 75) where
"A @@ B = {xs@ys | xs ys. xs:A & ys:B}"

overloading word_pow == "compow :: nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
begin
  primrec word_pow :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "word_pow 0 w = []" |
  "word_pow (Suc n) w = w @ word_pow n w"
end

overloading lang_pow == "compow :: nat \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
begin
  primrec lang_pow :: "nat \<Rightarrow> 'a lang \<Rightarrow> 'a lang" where
  "lang_pow 0 A = {[]}" |
  "lang_pow (Suc n) A = A @@ (lang_pow n A)"
end

lemma word_pow_alt: "compow n w = concat (replicate n w)"
  by (induct n) auto

definition star :: "'a lang \<Rightarrow> 'a lang" where
"star A = (\<Union>n. A ^^ n)"

subsection\<open>Concatenation of Languages\<close>

lemma concI[simp,intro]: "u : A \<Longrightarrow> v : B \<Longrightarrow> u@v : A @@ B"
  by (auto simp add: conc_def)

lemma concE[elim]:
assumes "w \<in> A @@ B"
obtains u v where "u \<in> A" "v \<in> B" "w = u@v"
  using assms by (auto simp: conc_def)

lemma conc_mono: "A \<subseteq> C \<Longrightarrow> B \<subseteq> D \<Longrightarrow> A @@ B \<subseteq> C @@ D"
  by (auto simp: conc_def)

lemma conc_empty[simp]: shows "{} @@ A = {}" and "A @@ {} = {}"
  by auto

lemma conc_epsilon[simp]: shows "{[]} @@ A = A" and "A @@ {[]} = A"
  by (simp_all add:conc_def)

lemma conc_assoc: "(A @@ B) @@ C = A @@ (B @@ C)"
  by (auto elim!: concE) (simp only: append_assoc[symmetric] concI)

lemma conc_Un_distrib:
shows "A @@ (B \<union> C) = A @@ B \<union> A @@ C"
and   "(A \<union> B) @@ C = A @@ C \<union> B @@ C"
  by auto

lemma conc_UNION_distrib:
shows "A @@ \<Union>(M ` I) = \<Union>((%i. A @@ M i) ` I)"
and   "\<Union>(M ` I) @@ A = \<Union>((%i. M i @@ A) ` I)"
  by auto

lemma hom_image_conc: "\<lbrakk>\<And>xs ys. f (xs @ ys) = f xs @ f ys\<rbrakk> \<Longrightarrow> f ` (A @@ B) = f ` A @@ f ` B"
  unfolding conc_def by (auto simp: image_iff) metis

lemma map_image_conc[simp]: "map f ` (A @@ B) = map f ` A @@ map f ` B"
  by (simp add: hom_image_conc)

lemma conc_subset_lists: "A \<subseteq> lists S \<Longrightarrow> B \<subseteq> lists S \<Longrightarrow> A @@ B \<subseteq> lists S"
  by(fastforce simp: conc_def in_lists_conv_set)

subsection\<open>Iteration of Languages\<close>

lemma lang_pow_add: "A ^^ (n + m) = A ^^ n @@ A ^^ m"
  by (induct n) (auto simp: conc_assoc)

lemma lang_pow_simps: "(A ^^ Suc n) = (A ^^ n @@ A)"
  using lang_pow_add[of n "Suc 0" A] by auto

lemma lang_pow_empty: "{} ^^ n = (if n = 0 then {[]} else {})"
  by (induct n) auto

lemma lang_pow_empty_Suc[simp]: "({}::'a lang) ^^ Suc n = {}"
  by (simp add: lang_pow_empty)

lemma length_lang_pow_ub:
  "ALL w : A. length w \<le> k \<Longrightarrow> w : A^^n \<Longrightarrow> length w \<le> k*n"
  by(induct n arbitrary: w) (fastforce simp: conc_def)+

lemma length_lang_pow_lb:
  "ALL w : A. length w \<ge> k \<Longrightarrow> w : A^^n \<Longrightarrow> length w \<ge> k*n"
  by(induct n arbitrary: w) (fastforce simp: conc_def)+

lemma lang_pow_subset_lists: "A \<subseteq> lists S \<Longrightarrow> A ^^ n \<subseteq> lists S"
  by (induct n) (auto simp: conc_subset_lists)

lemma star_subset_lists: "A \<subseteq> lists S \<Longrightarrow> star A \<subseteq> lists S"
  unfolding star_def by(blast dest: lang_pow_subset_lists)

lemma star_if_lang_pow[simp]: "w : A ^^ n \<Longrightarrow> w : star A"
  by (auto simp: star_def)

lemma Nil_in_star[iff]: "[] : star A"
proof (rule star_if_lang_pow)
  show "[] : A ^^ 0" by simp
qed

lemma star_if_lang[simp]: assumes "w : A" shows "w : star A"
proof (rule star_if_lang_pow)
  show "w : A ^^ 1" using \<open>w : A\<close> by simp
qed

lemma append_in_starI[simp]:
assumes "u : star A" and "v : star A" shows "u@v : star A"
proof -
  from \<open>u : star A\<close> obtain m where "u : A ^^ m" by (auto simp: star_def)
  moreover
  from \<open>v : star A\<close> obtain n where "v : A ^^ n" by (auto simp: star_def)
  ultimately have "u@v : A ^^ (m+n)" by (simp add: lang_pow_add)
  thus ?thesis by simp
qed

lemma conc_star_star: "star A @@ star A = star A"
  by (auto simp: conc_def)

lemma conc_star_comm:
  shows "A @@ star A = star A @@ A"
  unfolding star_def conc_pow_comm conc_UNION_distrib
  by simp

lemma star_induct[consumes 1, case_names Nil append, induct set: star]:
assumes "w : star A"
  and "P []"
  and step: "!!u v. u : A \<Longrightarrow> v : star A \<Longrightarrow> P v \<Longrightarrow> P (u@v)"
shows "P w"
proof -
  { fix n have "w : A ^^ n \<Longrightarrow> P w"
    by (induct n arbitrary: w) (auto intro: \<open>P []\<close> step star_if_lang_pow) }
  with \<open>w : star A\<close> show "P w" by (auto simp: star_def)
qed

lemma star_empty[simp]: "star {} = {[]}"
  by (auto elim: star_induct)

lemma star_epsilon[simp]: "star {[]} = {[]}"
  by (auto elim: star_induct)

lemma star_idemp[simp]: "star (star A) = star A"
  by (auto elim: star_induct)

lemma star_unfold_left: "star A = A @@ star A \<union> {[]}" (is "?L = ?R")
proof
  show "?L \<subseteq> ?R" by (rule, erule star_induct) auto
qed auto

lemma concat_in_star: "set ws \<subseteq> A \<Longrightarrow> concat ws : star A"
  by (induct ws) simp_all

lemma in_star_iff_concat:
  "w : star A = (EX ws. set ws \<subseteq> A & w = concat ws & [] \<notin> set ws)"
  (is "_ = (EX ws. ?R w ws)")
proof
  assume "w : star A" thus "EX ws. ?R w ws"
  proof induct
    case Nil have "?R [] []" by simp
    thus ?case ..
  next
    case (append u v)
    moreover
    then obtain ws where "set ws \<subseteq> A \<and> v = concat ws \<and> [] \<notin> set ws" by blast
    ultimately have "?R (u@v) (if u = [] then ws else u#ws)" by auto
    thus ?case ..
  qed
next
  assume "EX us. ?R w us" thus "w : star A"
  by (auto simp: concat_in_star)
qed

lemma star_conv_concat: "star A = {concat ws|ws. set ws \<subseteq> A & [] \<notin> set ws}"
  by (fastforce simp: in_star_iff_concat)

lemma star_insert_eps[simp]: "star (insert [] A) = star(A)"
proof-
  { fix us
    have "set us \<subseteq> insert [] A \<Longrightarrow> EX vs. concat us = concat vs \<and> set vs \<subseteq> A"
      (is "?P \<Longrightarrow> EX vs. ?Q vs")
    proof
      let ?vs = "filter (%u. u \<noteq> []) us"
      show "?P \<Longrightarrow> ?Q ?vs" by (induct us) auto
    qed
  } thus ?thesis by (auto simp: star_conv_concat)
qed

lemma star_decom:
  assumes a: "x \<in> star A" "x \<noteq> []"
  shows "\<exists>a b. x = a @ b \<and> a \<noteq> [] \<and> a \<in> A \<and> b \<in> star A"
  using a by (induct rule: star_induct) (blast)+

lemma Ball_starI: "\<forall>a \<in> set as. [a] \<in> A \<Longrightarrow> as \<in> star A"
  by (induct as rule: rev_induct) auto

lemma map_image_star[simp]: "map f ` star A = star (map f ` A)"
  by (auto elim: star_induct) (auto elim: star_induct simp del: map_append simp: map_append[symmetric] intro!: imageI)

subsection \<open>Left-Quotients of Languages\<close>

definition lQuot :: "'a \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
where "lQuot x A = { xs. x#xs \<in> A }"

definition lQuots :: "'a list \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
where "lQuots xs A = { ys. xs @ ys \<in> A }"

abbreviation
  lQuotss :: "'a list \<Rightarrow> 'a lang set \<Rightarrow> 'a lang"
where
  "lQuotss s As \<equiv> \<Union> (lQuots s ` As)"

lemma lQuot_empty[simp]:   "lQuot a {} = {}"
  and lQuot_epsilon[simp]: "lQuot a {[]} = {}"
  and lQuot_char[simp]:    "lQuot a {[b]} = (if a = b then {[]} else {})"
  and lQuot_chars[simp]:   "lQuot a {[b] | b. P b} = (if P a then {[]} else {})"
  and lQuot_union[simp]:   "lQuot a (A \<union> B) = lQuot a A \<union> lQuot a B"
  and lQuot_inter[simp]:   "lQuot a (A \<inter> B) = lQuot a A \<inter> lQuot a B"
  and lQuot_compl[simp]:   "lQuot a (-A) = - lQuot a A"
  by (auto simp: lQuot_def)

lemma lQuot_conc_subset: "lQuot a A @@ B \<subseteq> lQuot a (A @@ B)" (is "?L \<subseteq> ?R")
proof
  fix w assume "w \<in> ?L"
  then obtain u v where "w = u @ v" "a # u \<in> A" "v \<in> B"
    by (auto simp: lQuot_def)
  then have "a # w \<in> A @@ B"
    by (auto intro: concI[of "a # u", simplified])
  thus "w \<in> ?R" by (auto simp: lQuot_def)
qed

lemma lQuot_conc [simp]: "lQuot c (A @@ B) = (lQuot c A) @@ B \<union> (if [] \<in> A then lQuot c B else {})"
  unfolding lQuot_def conc_def
  by (auto simp add: Cons_eq_append_conv)

lemma lQuot_star [simp]: "lQuot c (star A) = (lQuot c A) @@ star A"
proof -
  have incl: "[] \<in> A \<Longrightarrow> lQuot c (star A) \<subseteq> (lQuot c A) @@ star A"
    unfolding lQuot_def conc_def
    apply(auto simp add: Cons_eq_append_conv)
    apply(drule star_decom)
    apply(auto simp add: Cons_eq_append_conv)
    done

  have "lQuot c (star A) = lQuot c (A @@ star A \<union> {[]})"
    by (simp only: star_unfold_left[symmetric])
  also have "... = lQuot c (A @@ star A)"
    by (simp only: lQuot_union) (simp)
  also have "... =  (lQuot c A) @@ (star A) \<union> (if [] \<in> A then lQuot c (star A) else {})"
    by simp
   also have "... =  (lQuot c A) @@ star A"
    using incl by auto
  finally show "lQuot c (star A) = (lQuot c A) @@ star A" .
qed

lemma lQuot_diff[simp]: "lQuot c (A - B) = lQuot c A - lQuot c B"
  by(auto simp add: lQuot_def)

lemma lQuot_lists[simp]: "c : S \<Longrightarrow> lQuot c (lists S) = lists S"
  by(auto simp add: lQuot_def)

lemma lQuots_simps [simp]:
  shows "lQuots [] A = A"
  and   "lQuots (c # s) A = lQuots s (lQuot c A)"
  and   "lQuots (s1 @ s2) A = lQuots s2 (lQuots s1 A)"
  unfolding lQuots_def lQuot_def by auto

lemma lQuots_append[iff]: "v \<in> lQuots w A \<longleftrightarrow> w @ v \<in> A"
  by (induct w arbitrary: v A) (auto simp add: lQuot_def)

subsection \<open>Right-Quotients of Languages\<close>

definition rQuot :: "'a \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
where "rQuot x A = { xs. xs @ [x] \<in> A }"

definition rQuots :: "'a list \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
where "rQuots xs A = { ys. ys @ rev xs \<in> A }"

abbreviation
  rQuotss :: "'a list \<Rightarrow> 'a lang set \<Rightarrow> 'a lang"
where
  "rQuotss s As \<equiv> \<Union> (rQuots s ` As)"

lemma rQuot_rev_lQuot: "rQuot x A = rev ` lQuot x (rev ` A)"
  unfolding rQuot_def lQuot_def by (auto simp: rev_swap[symmetric])

lemma rQuots_rev_lQuots: "rQuots x A = rev ` lQuots x (rev ` A)"
  unfolding rQuots_def lQuots_def by (auto simp: rev_swap[symmetric])

lemma rQuot_empty[simp]:   "rQuot a {} = {}"
  and rQuot_epsilon[simp]: "rQuot a {[]} = {}"
  and rQuot_char[simp]:    "rQuot a {[b]} = (if a = b then {[]} else {})"
  and rQuot_union[simp]:   "rQuot a (A \<union> B) = rQuot a A \<union> rQuot a B"
  and rQuot_inter[simp]:   "rQuot a (A \<inter> B) = rQuot a A \<inter> rQuot a B"
  and rQuot_compl[simp]:   "rQuot a (-A) = - rQuot a A"
  by (auto simp: rQuot_def)

lemma lQuot_rQuot: "lQuot a (rQuot b A) = rQuot b (lQuot a A)"
  unfolding lQuot_def rQuot_def by auto

lemma rQuot_lQuot: "rQuot a (lQuot b A) = lQuot b (rQuot a A)"
  unfolding lQuot_def rQuot_def by auto

lemma rev_simp_invert: "(xs @ [x] = rev zs) = (zs = x # rev xs)"
  by (induct zs) auto

lemma rev_append_invert: "(xs @ ys = rev zs) = (zs = rev ys @ rev xs)"
  by (induct xs arbitrary: ys rule: rev_induct) auto

lemma image_rev_lists[simp]: "rev ` lists S = lists S"
proof (intro set_eqI)
  fix xs
  show "xs \<in> rev ` lists S \<longleftrightarrow> xs \<in> lists S"
  proof (induct xs rule: rev_induct)
    case (snoc x xs)
    thus ?case by (auto intro!: image_eqI[of _ rev] simp: rev_simp_invert)
  qed simp
qed

lemma image_rev_conc[simp]: "rev ` (A @@ B) = rev ` B @@ rev ` A"
  by auto (auto simp: rev_append[symmetric] simp del: rev_append)

lemma image_rev_star[simp]: "rev ` star A = star (rev ` A)"
  by (auto elim: star_induct) (auto elim: star_induct simp: rev_append[symmetric] simp del: rev_append)

lemma rQuot_conc [simp]: "rQuot c (A @@ B) = A @@ (rQuot c B) \<union> (if [] \<in> B then rQuot c A else {})"
  unfolding rQuot_rev_lQuot by (auto simp: image_image image_Un)

lemma rQuot_star [simp]: "rQuot c (star A) = star A @@ (rQuot c A)"
  unfolding rQuot_rev_lQuot by (auto simp: image_image)

lemma rQuot_diff[simp]: "rQuot c (A - B) = rQuot c A - rQuot c B"
  by(auto simp add: rQuot_def)

lemma rQuot_lists[simp]: "c : S \<Longrightarrow> rQuot c (lists S) = lists S"
  by(auto simp add: rQuot_def)

lemma rQuots_simps [simp]:
  shows "rQuots [] A = A"
  and   "rQuots (c # s) A = rQuots s (rQuot c A)"
  and   "rQuots (s1 @ s2) A = rQuots s2 (rQuots s1 A)"
  unfolding rQuots_def rQuot_def by auto

lemma rQuots_append[iff]: "v \<in> rQuots w A \<longleftrightarrow> v @ rev w \<in> A"
  by (induct w arbitrary: v A) (auto simp add: rQuot_def)

subsection \<open>Two-Sided-Quotients of Languages\<close>

definition biQuot :: "'a \<Rightarrow> 'a \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
where "biQuot x y A = { xs. x # xs @ [y] \<in> A }"

definition biQuots :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
where "biQuots xs ys A = { zs. xs @ zs @ rev ys \<in> A }"

abbreviation
  biQuotss :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a lang set \<Rightarrow> 'a lang"
where
  "biQuotss xs ys As \<equiv> \<Union> (biQuots xs ys ` As)"

lemma biQuot_rQuot_lQuot: "biQuot x y A = rQuot y (lQuot x A)"
  unfolding biQuot_def rQuot_def lQuot_def by auto

lemma biQuot_lQuot_rQuot: "biQuot x y A = lQuot x (rQuot y A)"
  unfolding biQuot_def rQuot_def lQuot_def by auto

lemma biQuots_rQuots_lQuots: "biQuots x y A = rQuots y (lQuots x A)"
  unfolding biQuots_def rQuots_def lQuots_def by auto

lemma biQuots_lQuots_rQuots: "biQuots x y A = lQuots x (rQuots y A)"
  unfolding biQuots_def rQuots_def lQuots_def by auto

lemma biQuot_empty[simp]:   "biQuot a b {} = {}"
  and biQuot_epsilon[simp]: "biQuot a b {[]} = {}"
  and biQuot_char[simp]:    "biQuot a b {[c]} = {}"
  and biQuot_union[simp]:   "biQuot a b (A \<union> B) = biQuot a b A \<union> biQuot a b B"
  and biQuot_inter[simp]:   "biQuot a b (A \<inter> B) = biQuot a b A \<inter> biQuot a b B"
  and biQuot_compl[simp]:   "biQuot a b (-A) = - biQuot a b A"
  by (auto simp: biQuot_def)

lemma biQuot_conc [simp]: "biQuot a b (A @@ B) =
  lQuot a A @@ rQuot b B \<union>
  (if [] \<in> A \<and> [] \<in> B then biQuot a b A \<union> biQuot a b B
  else if [] \<in> A then biQuot a b B
  else if [] \<in> B then biQuot a b A
  else {})"
  unfolding biQuot_rQuot_lQuot by auto

lemma biQuot_star [simp]: "biQuot a b (star A) = biQuot a b A \<union> lQuot a A @@ star A @@ rQuot b A"
  unfolding biQuot_rQuot_lQuot by auto

lemma biQuot_diff[simp]: "biQuot a b (A - B) = biQuot a b A - biQuot a b B"
  by(auto simp add: biQuot_def)

lemma biQuot_lists[simp]: "a : S \<Longrightarrow> b : S \<Longrightarrow> biQuot a b (lists S) = lists S"
  by(auto simp add: biQuot_def)

lemma biQuots_simps [simp]:
  shows "biQuots [] [] A = A"
  and   "biQuots (a#as) (b#bs) A = biQuots as bs (biQuot a b A)"
  and   "\<lbrakk>length s1 = length t1; length s2 = length t2\<rbrakk> \<Longrightarrow>
    biQuots (s1 @ s2) (t1 @ t2) A = biQuots s2 t2 (biQuots s1 t1 A)"
  unfolding biQuots_def biQuot_def by auto

lemma biQuots_append[iff]: "v \<in> biQuots u w A \<longleftrightarrow> u @ v @ rev w \<in> A"
  unfolding biQuots_def by auto

subsection \<open>Arden's Lemma\<close>

lemma arden_helper:
  assumes eq: "X = A @@ X \<union> B"
  shows "X = (A ^^ Suc n) @@ X \<union> (\<Union>m\<le>n. (A ^^ m) @@ B)"
proof (induct n)
  case 0
  show "X = (A ^^ Suc 0) @@ X \<union> (\<Union>m\<le>0. (A ^^ m) @@ B)"
    using eq by simp
next
  case (Suc n)
  have ih: "X = (A ^^ Suc n) @@ X \<union> (\<Union>m\<le>n. (A ^^ m) @@ B)" by fact
  also have "\<dots> = (A ^^ Suc n) @@ (A @@ X \<union> B) \<union> (\<Union>m\<le>n. (A ^^ m) @@ B)" using eq by simp
  also have "\<dots> = (A ^^ Suc (Suc n)) @@ X \<union> ((A ^^ Suc n) @@ B) \<union> (\<Union>m\<le>n. (A ^^ m) @@ B)"
    by (simp add: conc_Un_distrib conc_assoc[symmetric] conc_pow_comm)
  also have "\<dots> = (A ^^ Suc (Suc n)) @@ X \<union> (\<Union>m\<le>Suc n. (A ^^ m) @@ B)"
    by (auto simp add: atMost_Suc)
  finally show "X = (A ^^ Suc (Suc n)) @@ X \<union> (\<Union>m\<le>Suc n. (A ^^ m) @@ B)" .
qed

lemma Arden:
  assumes "[] \<notin> A"
  shows "X = A @@ X \<union> B \<longleftrightarrow> X = star A @@ B"
proof
  assume eq: "X = A @@ X \<union> B"
  { fix w assume "w : X"
    let ?n = "size w"
    from \<open>[] \<notin> A\<close> have "ALL u : A. length u \<ge> 1"
      by (metis Suc_eq_plus1 add_leD2 le_0_eq length_0_conv not_less_eq_eq)
    hence "ALL u : A^^(?n+1). length u \<ge> ?n+1"
      by (metis length_lang_pow_lb nat_mult_1)
    hence "ALL u : A^^(?n+1)@@X. length u \<ge> ?n+1"
      by(auto simp only: conc_def length_append)
    hence "w \<notin> A^^(?n+1)@@X" by auto
    hence "w : star A @@ B" using \<open>w : X\<close> using arden_helper[OF eq, where n="?n"]
      by (auto simp add: star_def conc_UNION_distrib)
  } moreover
  { fix w assume "w : star A @@ B"
    hence "EX n. w : A^^n @@ B" by(auto simp: conc_def star_def)
    hence "w : X" using arden_helper[OF eq] by blast
  } ultimately show "X = star A @@ B" by blast
next
  assume eq: "X = star A @@ B"
  have "star A = A @@ star A \<union> {[]}"
    by (rule star_unfold_left)
  then have "star A @@ B = (A @@ star A \<union> {[]}) @@ B"
    by metis
  also have "\<dots> = (A @@ star A) @@ B \<union> B"
    unfolding conc_Un_distrib by simp
  also have "\<dots> = A @@ (star A @@ B) \<union> B"
    by (simp only: conc_assoc)
  finally show "X = A @@ X \<union> B"
    using eq by blast
qed

lemma reversed_arden_helper:
  assumes eq: "X = X @@ A \<union> B"
  shows "X = X @@ (A ^^ Suc n) \<union> (\<Union>m\<le>n. B @@ (A ^^ m))"
proof (induct n)
  case 0
  show "X = X @@ (A ^^ Suc 0) \<union> (\<Union>m\<le>0. B @@ (A ^^ m))"
    using eq by simp
next
  case (Suc n)
  have ih: "X = X @@ (A ^^ Suc n) \<union> (\<Union>m\<le>n. B @@ (A ^^ m))" by fact
  also have "\<dots> = (X @@ A \<union> B) @@ (A ^^ Suc n) \<union> (\<Union>m\<le>n. B @@ (A ^^ m))" using eq by simp
  also have "\<dots> = X @@ (A ^^ Suc (Suc n)) \<union> (B @@ (A ^^ Suc n)) \<union> (\<Union>m\<le>n. B @@ (A ^^ m))"
    by (simp add: conc_Un_distrib conc_assoc)
  also have "\<dots> = X @@ (A ^^ Suc (Suc n)) \<union> (\<Union>m\<le>Suc n. B @@ (A ^^ m))"
    by (auto simp add: atMost_Suc)
  finally show "X = X @@ (A ^^ Suc (Suc n)) \<union> (\<Union>m\<le>Suc n. B @@ (A ^^ m))" .
qed

theorem reversed_Arden:
  assumes nemp: "[] \<notin> A"
  shows "X = X @@ A \<union> B \<longleftrightarrow> X = B @@ star A"
proof
 assume eq: "X = X @@ A \<union> B"
  { fix w assume "w : X"
    let ?n = "size w"
    from \<open>[] \<notin> A\<close> have "ALL u : A. length u \<ge> 1"
      by (metis Suc_eq_plus1 add_leD2 le_0_eq length_0_conv not_less_eq_eq)
    hence "ALL u : A^^(?n+1). length u \<ge> ?n+1"
      by (metis length_lang_pow_lb nat_mult_1)
    hence "ALL u : X @@ A^^(?n+1). length u \<ge> ?n+1"
      by(auto simp only: conc_def length_append)
    hence "w \<notin> X @@ A^^(?n+1)" by auto
    hence "w : B @@ star A" using \<open>w : X\<close> using reversed_arden_helper[OF eq, where n="?n"]
      by (auto simp add: star_def conc_UNION_distrib)
  } moreover
  { fix w assume "w : B @@ star A"
    hence "EX n. w : B @@ A^^n" by (auto simp: conc_def star_def)
    hence "w : X" using reversed_arden_helper[OF eq] by blast
  } ultimately show "X = B @@ star A" by blast
next
  assume eq: "X = B @@ star A"
  have "star A = {[]} \<union> star A @@ A"
    unfolding conc_star_comm[symmetric]
    by(metis Un_commute star_unfold_left)
  then have "B @@ star A = B @@ ({[]} \<union> star A @@ A)"
    by metis
  also have "\<dots> = B \<union> B @@ (star A @@ A)"
    unfolding conc_Un_distrib by simp
  also have "\<dots> = B \<union> (B @@ star A) @@ A"
    by (simp only: conc_assoc)
  finally show "X = X @@ A \<union> B"
    using eq by blast
qed

subsection \<open>Lists of Fixed Length\<close>

abbreviation listsN where "listsN n S \<equiv> {xs. xs \<in> lists S \<and> length xs = n}"

lemma tl_listsN: "A \<subseteq> listsN (n + 1) S \<Longrightarrow> tl ` A \<subseteq> listsN n S"
proof (intro image_subsetI)
  fix xs assume "A \<subseteq> listsN (n + 1) S" "xs \<in> A"
  thus "tl xs \<in> listsN n S" by (induct xs) auto
qed

lemma map_tl_listsN: "A \<subseteq> lists (listsN (n + 1) S) \<Longrightarrow> map tl ` A \<subseteq> lists (listsN n S)"
proof (intro image_subsetI)
  fix xss assume "A \<subseteq> lists (listsN (n + 1) S)" "xss \<in> A"
  hence "set xss \<subseteq> listsN (n + 1) S" by auto
  hence "\<forall>xs \<in> set xss. tl xs \<in> listsN n S" using tl_listsN[of "set xss" S n] by auto
  thus "map tl xss \<in> lists (listsN n S)" by (induct xss) auto
qed

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

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

datatype Nat = Z | S "Nat"

datatype Heap = Node "Heap" "Nat" "Heap" | Nil

fun toHeap :: "Nat list => Heap list" where
  "toHeap (nil2) = nil2"
| "toHeap (cons2 y z) = cons2 (Node Nil y Nil) (toHeap z)"

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

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

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if le x2 x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

fun hpairwise :: "Heap list => Heap list" where
  "hpairwise (nil2) = nil2"
| "hpairwise (cons2 q (nil2)) = cons2 q (nil2)"
| "hpairwise (cons2 q (cons2 r qs)) =
     cons2 (hmerge q r) (hpairwise qs)"

(*fun did not finish the proof*)
function hmerging :: "Heap list => Heap" where
  "hmerging (nil2) = Nil"
| "hmerging (cons2 q (nil2)) = q"
| "hmerging (cons2 q (cons2 z x2)) =
     hmerging (hpairwise (cons2 q (cons2 z x2)))"
  by pat_completeness auto

fun toHeap2 :: "Nat list => Heap" where
  "toHeap2 x = hmerging (toHeap x)"

(*fun did not finish the proof*)
function toList :: "Heap => Nat list" where
  "toList (Node q y r) = cons2 y (toList (hmerge q r))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hsort :: "Nat list => Nat list" where
  "hsort x = toList (toHeap2 x)"

fun count :: "'a => 'a list => Nat" where
  "count x (nil2) = Z"
| "count x (cons2 z ys) =
     (if (x = z) then plus (S Z) (count x ys) else count x ys)"

theorem property0 :
  "((count x (hsort xs)) = (count x xs))"
  oops

end


theory BExp
imports AExp
begin

subsection "Boolean Expressions"

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

text_raw{*\snip{BExpbvaldef}{1}{2}{% *}
fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s = v" |
"bval (Not b) s = (\<not> bval b s)" |
"bval (And b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s \<and> bval b\<^sub>2 s)" |
"bval (Less a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s < aval a\<^sub>2 s)"
text_raw{*}%endsnip*}

value "bval (Less (V ''x'') (Plus (N 3) (V ''y'')))
            <''x'' := 3, ''y'' := 1>"

subsection "Constant Folding"

text{* Optimizing constructors: *}

text_raw{*\snip{BExplessdef}{0}{2}{% *}
fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (N n\<^sub>1) (N n\<^sub>2) = Bc(n\<^sub>1 < n\<^sub>2)" |
"less a\<^sub>1 a\<^sub>2 = Less a\<^sub>1 a\<^sub>2"
text_raw{*}%endsnip*}

text_raw{*\snip{BExpanddef}{2}{2}{% *}
fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"and (Bc True) b = b" |
"and b (Bc True) = b" |
"and (Bc False) b = Bc False" |
"and b (Bc False) = Bc False" |
"and b\<^sub>1 b\<^sub>2 = And b\<^sub>1 b\<^sub>2"
text_raw{*}%endsnip*}

lemma bval_and[simp]: "bval (and b1 b2) s = (bval b1 s \<and> bval b2 s)"
apply(induction b1 b2 rule: and.induct)
apply simp_all
done

text_raw{*\snip{BExpnotdef}{2}{2}{% *}
fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False" |
"not (Bc False) = Bc True" |
"not b = Not b"
text_raw{*}%endsnip*}

lemma bval_not[simp]: "bval (not b) s = (\<not> bval b s)"
apply(induction b rule: not.induct)
apply simp_all
done

text{* Now the overall optimizer: *}

text_raw{*\snip{BExpbsimpdef}{0}{2}{% *}
fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc v) = Bc v" |
"bsimp (Not b) = not(bsimp b)" |
"bsimp (And b\<^sub>1 b\<^sub>2) = and (bsimp b\<^sub>1) (bsimp b\<^sub>2)" |
"bsimp (Less a\<^sub>1 a\<^sub>2) = less (asimp a\<^sub>1) (asimp a\<^sub>2)"
text_raw{*}%endsnip*}

value "bsimp (And (Less (N 0) (N 1)) b)"

value "bsimp (And (Less (N 1) (N 0)) (Bc True))"

theorem "bval (bsimp b) s = bval b s"
apply(induction b)
apply simp_all
done

end


theory Utility_Functions
imports
  Complex_Main
  "~~/src/HOL/Probability/Probability"
  Missing_PMF
  Preference_Profiles
begin

subsection \<open>Definition of von Neumann--Morgenstern utility functions\<close>

locale vnm_utility = finite_total_preorder_on +
  fixes u :: "'a \<Rightarrow> real"
  assumes utility_le_iff: "x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> u x \<le> u y \<longleftrightarrow> x \<preceq>[le] y"
begin

lemma utility_le: "x \<preceq>[le] y \<Longrightarrow> u x \<le> u y"
  using not_outside[of x y] utility_le_iff by simp

lemma utility_less_iff:
  "x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> u x < u y \<longleftrightarrow> x \<prec>[le] y"
  using utility_le_iff[of x y] utility_le_iff[of y x]
  by (auto simp: strongly_preferred_def)

lemma utility_less: "x \<prec>[le] y \<Longrightarrow> u x < u y"
  using not_outside[of x y] utility_less_iff by (simp add: strongly_preferred_def)

text \<open>
  The following lemma allows us to compute the expected utility by summing
  over all indifference classes, using the fact that alternatives in the same
  indifference class must have the same utility.
\<close>
lemma expected_utility_weak_ranking:
  assumes "p \<in> lotteries_on carrier"
  shows   "measure_pmf.expectation p u =
             (\<Sum>A\<leftarrow>weak_ranking le. u (SOME x. x \<in> A) * measure_pmf.prob p A)"
proof -
  from assms have "measure_pmf.expectation p u = (\<Sum>a\<in>carrier. u a * pmf p a)"
    by (subst integral_measure_pmf[OF finite_carrier])
       (auto simp: lotteries_on_def)
  also have carrier: "carrier = \<Union>set (weak_ranking le)" by (simp add: weak_ranking_Union)
  also from this have finite: "finite A" if "A \<in> set (weak_ranking le)" for A
    using that by (blast intro!: finite_subset[OF _ finite_carrier, of A])
  hence "(\<Sum>a\<in>\<Union>set (weak_ranking le). u a * pmf p a) =
           (\<Sum>A\<leftarrow>weak_ranking le. \<Sum>a\<in>A. u a * pmf p a)" (is "_ = listsum ?xs")
    using weak_ranking_total_preorder
    by (subst setsum.Union_disjoint)
       (auto simp: is_weak_ranking_iff disjoint_def setsum.distinct_set_conv_list)
  also have "?xs  = map (\<lambda>A. \<Sum>a\<in>A. u (SOME a. a\<in>A) * pmf p a) (weak_ranking le)"
  proof (intro map_cong HOL.refl setsum.cong)
    fix x A assume x: "x \<in> A" and A: "A \<in> set (weak_ranking le)"
    have "(SOME x. x \<in> A) \<in> A" by (rule someI_ex) (insert x, blast)
    from weak_ranking_eqclass1[OF A x this] weak_ranking_eqclass1[OF A this x] x this A
      have "u x = u (SOME x. x \<in> A)"
      by (intro antisym; subst utility_le_iff) (auto simp: carrier)
    thus "u x * pmf p x = u (SOME x. x \<in> A) * pmf p x" by simp
  qed
  also have "\<dots> = map (\<lambda>A. u (SOME a. a \<in> A) * measure_pmf.prob p A) (weak_ranking le)"
    using finite by (intro map_cong HOL.refl)
                    (auto simp: setsum_right_distrib measure_measure_pmf_finite)
  finally show ?thesis .
qed

lemma scaled: "c > 0 \<Longrightarrow> vnm_utility carrier le (\<lambda>x. c * u x)"
  by unfold_locales (insert utility_le_iff, auto)

lemma add_right:
  assumes "\<And>x y. le x y \<Longrightarrow> f x \<le> f y"
  shows   "vnm_utility carrier le (\<lambda>x. u x + f x)"
proof
  fix x y assume xy: "x \<in> carrier" "y \<in> carrier"
  from assms[of x y] utility_le_iff[OF xy] assms[of y x] utility_le_iff[OF xy(2,1)]
    show "(u x + f x \<le> u y + f y) = le x y" by auto
qed

lemma add_left:
  "(\<And>x y. le x y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> vnm_utility carrier le (\<lambda>x. f x + u x)"
  by (subst add.commute) (rule add_right)

text \<open>
  Given a consistent utility function, any function that assigns equal values to
  equivalent alternatives can be added to it (scaled with a sufficiently small @{term "\<epsilon>"}),
  again yielding a consistent utility function.
\<close>
lemma add_epsilon:
  assumes A: "\<And>x y. le x y \<Longrightarrow> le y x \<Longrightarrow> f x = f y"
  shows "\<exists>\<epsilon>>0. vnm_utility carrier le (\<lambda>x. u x + \<epsilon> * f x)"
proof -
  let ?A = "{(u y - u x) / (f x - f y) |x y. x \<prec>[le] y \<and> f x > f y}"
  have "?A = (\<lambda>(x,y). (u y - u x) / (f x - f y)) ` {(x,y) |x y. x \<prec>[le] y \<and> f x > f y}" by auto
  also have "finite {(x,y) |x y. x \<prec>[le] y \<and> f x > f y}"
    by (rule finite_subset[of _ "carrier \<times> carrier"])
       (insert not_outside, auto simp: strongly_preferred_def)
  hence "finite ((\<lambda>(x,y). (u y - u x) / (f x - f y)) ` {(x,y) |x y. x \<prec>[le] y \<and> f x > f y})"
    by simp
  finally have finite: "finite ?A" .

  def \<epsilon> \<equiv> "Min (insert 1 ?A) / 2"
  from finite have "Min (insert 1 ?A) > 0"
    by (intro Min_grI) (auto intro!: divide_pos_pos simp: utility_less)
  hence \<epsilon>: "\<epsilon> > 0" unfolding \<epsilon>_def by simp

  have mono: "u x + \<epsilon> * f x < u y + \<epsilon> * f y" if xy: "x \<prec>[le] y" for x y
  proof (cases "f x > f y")
    assume less: "f x > f y"
    from \<epsilon> have "\<epsilon> < Min (insert 1 ?A)" unfolding \<epsilon>_def by linarith
    also from less xy finite have "Min (insert 1 ?A) \<le> (u y - u x) / (f x - f y)" unfolding \<epsilon>_def
      by (intro Min_le) auto
    finally show ?thesis using less by (simp add: field_simps)
  next
    assume "\<not>f x > f y"
    with utility_less[OF xy] \<epsilon> show ?thesis
      by (simp add: algebra_simps not_less add_less_le_mono)
  qed
  have eq: "u x + \<epsilon> * f x = u y + \<epsilon> * f y" if xy: "x \<preceq>[le] y" "y \<preceq>[le] x" for x y
    using xy[THEN utility_le] A[OF xy] by simp
  have "vnm_utility carrier le (\<lambda>x. u x + \<epsilon> * f x)"
  proof
    fix x y assume xy: "x \<in> carrier" "y \<in> carrier"
    show "(u x + \<epsilon> * f x \<le> u y + \<epsilon> * f y) \<longleftrightarrow> le x y"
      using total[OF xy] mono[of x y] mono[of y x] eq[of x y]
      by (cases "le x y"; cases "le y x") (auto simp: strongly_preferred_def)
  qed
  from \<epsilon> this show ?thesis by blast
qed

lemma diff_epsilon:
  assumes "\<And>x y. le x y \<Longrightarrow> le y x \<Longrightarrow> f x = f y"
  shows "\<exists>\<epsilon>>0. vnm_utility carrier le (\<lambda>x. u x - \<epsilon> * f x)"
proof -
  from assms have "\<exists>\<epsilon>>0. vnm_utility carrier le (\<lambda>x. u x + \<epsilon> * -f x)"
    by (intro add_epsilon) (subst neg_equal_iff_equal)
  thus ?thesis by simp
qed

end

end


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

theory Ideal_Product
  imports Ideal
begin

section \<open>Product of Ideals\<close>

text \<open>In this section, we study the structure of the set of ideals of a given ring.\<close>

inductive_set
  ideal_prod :: "[ ('a, 'b) ring_scheme, 'a set, 'a set ] \<Rightarrow> 'a set" (infixl "\<cdot>\<index>" 80)
  for R and I and J (* both I and J are supposed ideals *) where
    prod: "\<lbrakk> i \<in> I; j \<in> J \<rbrakk> \<Longrightarrow> i \<otimes>\<^bsub>R\<^esub> j \<in> ideal_prod R I J"
  |  sum: "\<lbrakk> s1 \<in> ideal_prod R I J; s2 \<in> ideal_prod R I J \<rbrakk> \<Longrightarrow> s1 \<oplus>\<^bsub>R\<^esub> s2 \<in> ideal_prod R I J"

definition ideals_set :: "('a, 'b) ring_scheme \<Rightarrow> ('a set) ring"
  where "ideals_set R = \<lparr> carrier = { I. ideal I R },
                             mult = ideal_prod R,
                              one = carrier R,
                             zero = { \<zero>\<^bsub>R\<^esub> },
                              add = set_add R \<rparr>"

subsection \<open>Basic Properties\<close>

lemma (in ring) ideal_prod_in_carrier:
  assumes "ideal I R" "ideal J R"
  shows "I \<cdot> J \<subseteq> carrier R"
proof
  fix s assume "s \<in> I \<cdot> J" thus "s \<in> carrier R"
    by (induct s rule: ideal_prod.induct) (auto, meson assms ideal.I_l_closed ideal.Icarr)
qed

lemma (in ring) ideal_prod_inter:
  assumes "ideal I R" "ideal J R"
  shows "I \<cdot> J \<subseteq> I \<inter> J"
proof
  fix s assume "s \<in> I \<cdot> J" thus "s \<in> I \<inter> J"
    apply (induct s rule: ideal_prod.induct)
    apply (auto, (meson assms ideal.I_r_closed ideal.I_l_closed ideal.Icarr)+)
    apply (simp_all add: additive_subgroup.a_closed assms ideal.axioms(1))
    done
qed

lemma (in ring) ideal_prod_is_ideal:
  assumes "ideal I R" "ideal J R"
  shows "ideal (I \<cdot> J) R"
proof (rule idealI)
  show "ring R" using ring_axioms .
next
  show "subgroup (I \<cdot> J) (add_monoid R)"
    unfolding subgroup_def
  proof (auto)
    show "\<zero> \<in> I \<cdot> J" using ideal_prod.prod[of \<zero> I \<zero> J R]
      by (simp add: additive_subgroup.zero_closed assms ideal.axioms(1))
  next
    fix s1 s2 assume s1: "s1 \<in> I \<cdot> J" and s2: "s2 \<in> I \<cdot> J"
    have IJcarr: "\<And>a. a \<in> I \<cdot> J \<Longrightarrow> a \<in> carrier R"
      by (meson assms subsetD ideal_prod_in_carrier)
    show "s1 \<in> carrier R" using ideal_prod_in_carrier[OF assms] s1 by blast
    show "s1 \<oplus> s2 \<in> I \<cdot> J" by (simp add: ideal_prod.sum[OF s1 s2])
    show "inv\<^bsub>add_monoid R\<^esub> s1 \<in> I \<cdot> J" using s1
    proof (induct s1 rule: ideal_prod.induct)
      case (prod i j)
      hence "inv\<^bsub>add_monoid R\<^esub> (i \<otimes> j) = (inv\<^bsub>add_monoid R\<^esub> i) \<otimes> j"
        by (metis a_inv_def assms(1) assms(2) ideal.Icarr l_minus)
      thus ?case using ideal_prod.prod[of "inv\<^bsub>add_monoid R\<^esub> i" I j J R] assms
        by (simp add: additive_subgroup.a_subgroup ideal.axioms(1) prod.hyps subgroup.m_inv_closed)
    next
      case (sum s1 s2) thus ?case
        by (metis (no_types) IJcarr a_inv_def add.inv_mult_group ideal_prod.sum sum.hyps)
    qed
  qed
next
  fix s x assume s: "s \<in> I \<cdot> J" and x: "x \<in> carrier R"
  show "x \<otimes> s \<in> I \<cdot> J" using s
  proof (induct s rule: ideal_prod.induct)
    case (prod i j) thus ?case using ideal_prod.prod[of "x \<otimes> i" I j J R] assms
      by (simp add: x ideal.I_l_closed ideal.Icarr m_assoc)
  next
    case (sum s1 s2) thus ?case
    proof -
      have IJ: "I \<cdot> J \<subseteq> carrier R"
        by (metis (no_types) assms(1) assms(2) ideal.axioms(2) ring.ideal_prod_in_carrier)
      then have "s2 \<in> carrier R"
        using sum.hyps(3) by blast
      moreover have "s1 \<in> carrier R"
        using IJ sum.hyps(1) by blast
      ultimately show ?thesis
        by (simp add: ideal_prod.sum r_distr sum.hyps x)
    qed
  qed
  show "s \<otimes> x \<in> I \<cdot> J" using s
  proof (induct s rule: ideal_prod.induct)
    case (prod i j) thus ?case using ideal_prod.prod[of i I "j \<otimes> x" J R] assms x
      by (simp add: x ideal.I_r_closed ideal.Icarr m_assoc)
  next
    case (sum s1 s2) thus ?case
    proof -
      have "s1 \<in> carrier R" "s2 \<in> carrier R"
        by (meson assms subsetD ideal_prod_in_carrier sum.hyps)+
      then show ?thesis
        by (metis ideal_prod.sum l_distr sum.hyps(2) sum.hyps(4) x)
    qed
  qed
qed

lemma (in ring) ideal_prod_eq_genideal:
  assumes "ideal I R" "ideal J R"
  shows "I \<cdot> J = Idl (I <#> J)"
proof
  have "I <#> J \<subseteq> I \<cdot> J"
  proof
    fix s assume "s \<in> I <#> J"
    then obtain i j where "i \<in> I" "j \<in> J" "s = i \<otimes> j"
      unfolding set_mult_def by blast
    thus "s \<in> I \<cdot> J" using ideal_prod.prod by simp
  qed
  thus "Idl (I <#> J) \<subseteq> I \<cdot> J"
    unfolding genideal_def using ideal_prod_is_ideal[OF assms] by blast
next
  show "I \<cdot> J \<subseteq> Idl (I <#> J)"
  proof
    fix s assume "s \<in> I \<cdot> J" thus "s \<in> Idl (I <#> J)"
    proof (induct s rule: ideal_prod.induct)
      case (prod i j) hence "i \<otimes> j \<in> I <#> J" unfolding set_mult_def by blast
      thus ?case unfolding genideal_def by blast
    next
      case (sum s1 s2) thus ?case
        by (simp add: additive_subgroup.a_closed additive_subgroup.a_subset
            assms genideal_ideal ideal.axioms(1) set_mult_closed)
    qed
  qed
qed

lemma (in ring) ideal_prod_simp:
  assumes "ideal I R" "ideal J R" (* the second assumption could be suppressed *)
  shows "I = I <+> (I \<cdot> J)"
proof
  show "I \<subseteq> I <+> I \<cdot> J"
  proof
    fix i assume "i \<in> I" hence "i \<oplus> \<zero> \<in> I <+> I \<cdot> J"
      using set_add_def'[of R I "I \<cdot> J"] ideal_prod_is_ideal[OF assms]
            additive_subgroup.zero_closed[OF ideal.axioms(1), of "I \<cdot> J" R] by auto
    thus "i \<in> I <+> I \<cdot> J"
      using \<open>i \<in> I\<close> assms(1) ideal.Icarr by fastforce
  qed
next
  show "I <+> I \<cdot> J \<subseteq> I"
  proof
    fix s assume "s \<in> I <+> I \<cdot> J"
    then obtain i ij where "i \<in> I" "ij \<in> I \<cdot> J" "s = i \<oplus> ij"
      using set_add_def'[of R I "I \<cdot> J"] by auto
    thus "s \<in> I"
      using ideal_prod_inter[OF assms]
      by (meson additive_subgroup.a_closed assms(1) ideal.axioms(1) inf_sup_ord(1) subsetCE)
  qed
qed

lemma (in ring) ideal_prod_one:
  assumes "ideal I R"
  shows "I \<cdot> (carrier R) = I"
proof
  show "I \<cdot> (carrier R) \<subseteq> I"
  proof
    fix s assume "s \<in> I \<cdot> (carrier R)" thus "s \<in> I"
      by (induct s rule: ideal_prod.induct)
         (simp_all add: assms ideal.I_r_closed additive_subgroup.a_closed ideal.axioms(1))
  qed
next
  show "I \<subseteq> I \<cdot> (carrier R)"
  proof
    fix i assume "i \<in> I" thus "i \<in>  I \<cdot> (carrier R)"
      by (metis assms ideal.Icarr ideal_prod.simps one_closed r_one)
  qed
qed

lemma (in ring) ideal_prod_zero:
  assumes "ideal I R"
  shows "I \<cdot> { \<zero> } = { \<zero> }"
proof
  show "I \<cdot> { \<zero> } \<subseteq> { \<zero> }"
  proof
    fix s assume "s \<in> I \<cdot> {\<zero>}" thus "s \<in> { \<zero> }"
      using assms ideal.Icarr by (induct s rule: ideal_prod.induct) (fastforce, simp)
  qed
next
  show "{ \<zero> } \<subseteq> I \<cdot> { \<zero> }"
    by (simp add: additive_subgroup.zero_closed assms
                  ideal.axioms(1) ideal_prod_is_ideal zeroideal)
qed

lemma (in ring) ideal_prod_assoc:
  assumes "ideal I R" "ideal J R" "ideal K R"
  shows "(I \<cdot> J) \<cdot> K = I \<cdot> (J \<cdot> K)"
proof
  show "(I \<cdot> J) \<cdot> K \<subseteq> I \<cdot> (J \<cdot> K)"
  proof
    fix s assume "s \<in> (I \<cdot> J) \<cdot> K" thus "s \<in> I \<cdot> (J \<cdot> K)"
    proof (induct s rule: ideal_prod.induct)
      case (sum s1 s2) thus ?case
        by (simp add: ideal_prod.sum)
    next
      case (prod i k) thus ?case
      proof (induct i rule: ideal_prod.induct)
        case (prod i j) thus ?case
          using ideal_prod.prod[OF prod(1) ideal_prod.prod[OF prod(2-3),of R], of R]
          by (metis assms ideal.Icarr m_assoc)
      next
        case (sum s1 s2) thus ?case
        proof -
          have "s1 \<in> carrier R" "s2 \<in> carrier R"
            by (meson assms subsetD ideal.axioms(2) ring.ideal_prod_in_carrier sum.hyps)+
          moreover have "k \<in> carrier R"
            by (meson additive_subgroup.a_Hcarr assms(3) ideal.axioms(1) sum.prems)
          ultimately show ?thesis
            by (metis ideal_prod.sum l_distr sum.hyps(2) sum.hyps(4) sum.prems)
        qed
      qed
    qed
  qed
next
  show "I \<cdot> (J \<cdot> K) \<subseteq> (I \<cdot> J) \<cdot> K"
  proof
    fix s assume "s \<in> I \<cdot> (J \<cdot> K)" thus "s \<in> (I \<cdot> J) \<cdot> K"
    proof (induct s rule: ideal_prod.induct)
      case (sum s1 s2) thus ?case by (simp add: ideal_prod.sum)
    next
      case (prod i j) show ?case using prod(2) prod(1)
      proof (induct j rule: ideal_prod.induct)
        case (prod j k) thus ?case
          using ideal_prod.prod[OF ideal_prod.prod[OF prod(3) prod(1), of R] prod (2), of R]
          by (metis assms ideal.Icarr m_assoc)
      next
        case (sum s1 s2) thus ?case
        proof -
          have "\<And>a A B. \<lbrakk>a \<in> B \<cdot> A; ideal A R; ideal B R\<rbrakk> \<Longrightarrow> a \<in> carrier R"
            by (meson subsetD ideal_prod_in_carrier)
          moreover have "i \<in> carrier R"
            by (meson additive_subgroup.a_Hcarr assms(1) ideal.axioms(1) sum.prems)
          ultimately show ?thesis
            by (metis (no_types) assms(2) assms(3) ideal_prod.sum r_distr sum)
        qed
      qed
    qed
  qed
qed

lemma (in ring) ideal_prod_r_distr:
  assumes "ideal I R" "ideal J R" "ideal K R"
  shows "I \<cdot> (J <+> K) = (I \<cdot> J) <+>  (I \<cdot> K)"
proof
  show "I \<cdot> (J <+> K) \<subseteq> I \<cdot> J <+> I \<cdot> K"
  proof
    fix s assume "s \<in> I \<cdot> (J <+> K)" thus "s \<in> I \<cdot> J <+> I \<cdot> K"
    proof(induct s rule: ideal_prod.induct)
      case (prod i jk)
      then obtain j k where j: "j \<in> J" and k: "k \<in> K" and jk: "jk = j \<oplus> k"
        using set_add_def'[of R J K] by auto
      hence "i \<otimes> j \<oplus> i \<otimes> k \<in> I \<cdot> J <+> I \<cdot> K"
        using ideal_prod.prod[OF prod(1) j,of R]
              ideal_prod.prod[OF prod(1) k,of R]
              set_add_def'[of R "I \<cdot> J" "I \<cdot> K"] by auto
      thus ?case
        using assms ideal.Icarr r_distr jk j k prod(1) by metis
    next
      case (sum s1 s2) thus ?case
        by (simp add: add_ideals additive_subgroup.a_closed assms ideal.axioms(1)
                      local.ring_axioms ring.ideal_prod_is_ideal)
    qed
  qed
next
  { fix s J K assume A: "ideal J R" "ideal K R" "s \<in> I \<cdot> J"
    have "s \<in> I \<cdot> (J <+> K) \<and> s \<in> I \<cdot> (K <+> J)"
    proof -
      from \<open>s \<in> I \<cdot> J\<close> have "s \<in> I \<cdot> (J <+> K)"
      proof (induct s rule: ideal_prod.induct)
        case (prod i j)
        hence "(j \<oplus> \<zero>) \<in> J <+> K"
          using set_add_def'[of R J K]
                additive_subgroup.zero_closed[OF ideal.axioms(1), of K R] A(2) by auto
        thus ?case
          by (metis A(1) additive_subgroup.a_Hcarr ideal.axioms(1) ideal_prod.prod prod r_zero)
      next
        case (sum s1 s2) thus ?case
          by (simp add: ideal_prod.sum)
      qed
      thus ?thesis
        by (metis A(1) A(2) ideal_def ring.union_genideal sup_commute)
    qed } note aux_lemma = this

  show "I \<cdot> J <+> I \<cdot> K \<subseteq> I \<cdot> (J <+> K)"
  proof
    fix s assume "s \<in> I \<cdot> J <+> I \<cdot> K"
    then obtain s1 s2 where s1: "s1 \<in> I \<cdot> J" and s2: "s2 \<in> I \<cdot> K" and  s: "s = s1 \<oplus> s2"
      using set_add_def'[of R "I \<cdot> J" "I \<cdot> K"] by auto
    thus "s \<in> I \<cdot> (J <+> K)"
      using aux_lemma[OF assms(2) assms(3) s1]
            aux_lemma[OF assms(3) assms(2) s2] by (simp add: ideal_prod.sum)
  qed
qed

lemma (in cring) ideal_prod_commute:
  assumes "ideal I R" "ideal J R"
  shows "I \<cdot> J = J \<cdot> I"
proof -
  { fix I J assume A: "ideal I R" "ideal J R"
    have "I \<cdot> J \<subseteq> J \<cdot> I"
    proof
      fix s assume "s \<in> I \<cdot> J" thus "s \<in> J \<cdot> I"
      proof (induct s rule: ideal_prod.induct)
        case (prod i j) thus ?case
          using m_comm[OF ideal.Icarr[OF A(1) prod(1)] ideal.Icarr[OF A(2) prod(2)]]
          by (simp add: ideal_prod.prod)
      next
        case (sum s1 s2) thus ?case by (simp add: ideal_prod.sum)
      qed
    qed }
  thus ?thesis using assms by blast
qed

text \<open>The following result would also be true for locale ring\<close>
lemma (in cring) ideal_prod_distr:
  assumes "ideal I R" "ideal J R" "ideal K R"
  shows "I \<cdot> (J <+> K) = (I \<cdot> J) <+>  (I \<cdot> K)"
    and "(J <+> K) \<cdot> I = (J \<cdot> I) <+>  (K \<cdot> I)"
  by (simp_all add: assms ideal_prod_commute local.ring_axioms
                    ring.add_ideals ring.ideal_prod_r_distr)

lemma (in cring) ideal_prod_eq_inter:
  assumes "ideal I R" "ideal J R"
    and "I <+> J = carrier R"
  shows "I \<cdot> J = I \<inter> J"
proof
  show "I \<cdot> J \<subseteq> I \<inter> J"
    using assms ideal_prod_inter by auto
next
  show "I \<inter> J \<subseteq> I \<cdot> J"
  proof
    have "\<one> \<in> I <+> J" using assms(3) one_closed by simp
    then obtain i j where ij: "i \<in> I" "j \<in> J" "\<one> = i \<oplus> j"
      using set_add_def'[of R I J] by auto

    fix s assume s: "s \<in> I \<inter> J"
    hence "(i \<otimes> s \<in> I \<cdot> J) \<and> (s \<otimes> j \<in> I \<cdot> J)"
      using ij(1-2) by (simp add: ideal_prod.prod)
    moreover have "s = (i \<otimes> s) \<oplus> (s \<otimes> j)"
      using ideal.Icarr[OF assms(1) ij(1)]
            ideal.Icarr[OF assms(2) ij(2)]
            ideal.Icarr[OF assms(1), of s]
      by (metis ij(3) s m_comm[of s i] Int_iff r_distr r_one)
    ultimately show "s \<in>  I \<cdot> J"
      using ideal_prod.sum by fastforce
  qed
qed

subsection \<open>Structure of the Set of Ideals\<close>

text \<open>We focus on commutative rings for convenience.\<close>

lemma (in cring) ideals_set_is_semiring: "semiring (ideals_set R)"
proof -
  have "abelian_monoid (ideals_set R)"
    apply (rule abelian_monoidI) unfolding ideals_set_def
    apply (simp_all add: add_ideals zeroideal)
    apply (simp add: add.set_mult_assoc additive_subgroup.a_subset ideal.axioms(1) set_add_defs(1))
    apply (metis Un_absorb1 additive_subgroup.a_subset additive_subgroup.zero_closed
        cgenideal_minimal cgenideal_self empty_iff genideal_minimal ideal.axioms(1)
        local.ring_axioms order_refl ring.genideal_self subset_antisym subset_singletonD
        union_genideal zero_closed zeroideal)
    by (metis sup_commute union_genideal)

  moreover have "monoid (ideals_set R)"
    apply (rule monoidI) unfolding ideals_set_def
    apply (simp_all add: ideal_prod_is_ideal oneideal
                         ideal_prod_commute ideal_prod_one)
    by (metis ideal_prod_assoc ideal_prod_commute)

  ultimately show ?thesis
    unfolding semiring_def semiring_axioms_def ideals_set_def
    by (simp_all add: ideal_prod_distr ideal_prod_commute ideal_prod_zero zeroideal)
qed

lemma (in cring) ideals_set_is_comm_monoid: "comm_monoid (ideals_set R)"
proof -
  have "monoid (ideals_set R)"
    apply (rule monoidI) unfolding ideals_set_def
    apply (simp_all add: ideal_prod_is_ideal oneideal
                         ideal_prod_commute ideal_prod_one)
    by (metis ideal_prod_assoc ideal_prod_commute)
  thus ?thesis
    unfolding comm_monoid_def comm_monoid_axioms_def
    by (simp add: ideal_prod_commute ideals_set_def)
qed

lemma (in cring) ideal_prod_eq_Inter_aux:
  assumes "I: {..(Suc n)} \<rightarrow> { J. ideal J R }"
    and "\<And>i j. \<lbrakk> i \<le> Suc n; j \<le> Suc n \<rbrakk> \<Longrightarrow>
                 i \<noteq> j \<Longrightarrow> (I i) <+> (I j) = carrier R"
  shows "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..n}. I k) <+> (I (Suc n)) = carrier R" using assms
proof (induct n arbitrary: I)
  case 0
  hence "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..0}. I k) <+> I (Suc 0) = (I 0) <+> (I (Suc 0))"
    using comm_monoid.finprod_0[OF ideals_set_is_comm_monoid, of I]
    by (simp add: atMost_Suc ideals_set_def)
  also have " ... = carrier R"
    using 0(2)[of 0 "Suc 0"] by simp
  finally show ?case .
next
  interpret ISet: comm_monoid "ideals_set R"
    by (simp add: ideals_set_is_comm_monoid)

  case (Suc n)
  let ?I' = "\<lambda>i. I (Suc i)"
  have "?I': {..(Suc n)} \<rightarrow> { J. ideal J R }"
    using Suc.prems(1) by auto
  moreover have "\<And>i j. \<lbrakk> i \<le> Suc n; j \<le> Suc n \<rbrakk> \<Longrightarrow>
                         i \<noteq> j \<Longrightarrow> (?I' i) <+> (?I' j) = carrier R"
    by (simp add: Suc.prems(2))
  ultimately have "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..n}. ?I' k) <+> (?I' (Suc n)) = carrier R"
    using Suc.hyps by metis

  moreover have I_carr: "I: {..Suc (Suc n)} \<rightarrow> carrier (ideals_set R)"
    unfolding ideals_set_def using Suc by simp
  hence I'_carr: "I \<in> Suc ` {..n} \<rightarrow> carrier (ideals_set R)" by auto
  ultimately have "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {(Suc 0)..Suc n}. I k) <+> (I (Suc (Suc n))) = carrier R"
    using ISet.finprod_reindex[of I "\<lambda>i. Suc i" "{..n}"] by (simp add: atMost_atLeast0)

  hence "(carrier R) \<cdot> (I 0) = ((\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {Suc 0..Suc n}. I k) <+> I (Suc (Suc n))) \<cdot> (I 0)"
    by auto
  moreover have fprod_cl1: "ideal (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {Suc 0..Suc n}. I k) R"
    by (metis I'_carr ISet.finprod_closed One_nat_def ideals_set_def image_Suc_atMost
        mem_Collect_eq partial_object.select_convs(1))
  ultimately
  have "I 0 = (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {Suc 0..Suc n}. I k) \<cdot> (I 0) <+> I (Suc (Suc n)) \<cdot> (I 0)"
    by (metis PiE Suc.prems(1) atLeast0_atMost_Suc atLeast0_atMost_Suc_eq_insert_0
        atMost_atLeast0 ideal_prod_commute ideal_prod_distr(2) ideal_prod_one insertI1
        mem_Collect_eq oneideal)
  also have " ... = (I 0) \<cdot> (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {Suc 0..Suc n}. I k) <+> I (Suc (Suc n)) \<cdot> (I 0)"
    using fprod_cl1 ideal_prod_commute Suc.prems(1)
    by (simp add: atLeast0_atMost_Suc_eq_insert_0 atMost_atLeast0)
  also have " ... = (I 0) \<otimes>\<^bsub>(ideals_set R)\<^esub> (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {Suc 0..Suc n}. I k) <+>
                     I (Suc (Suc n)) \<cdot> (I 0)"
    by (simp add: ideals_set_def)
  finally have I0: "I 0 = (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k) <+> I (Suc (Suc n)) \<cdot> (I 0)"
    using ISet.finprod_insert[of "{Suc 0..Suc n}" 0 I]
          I_carr I'_carr atMost_atLeast0 ISet.finprod_0' atMost_Suc by auto

  have I_SucSuc_I0: "ideal (I (Suc (Suc n))) R \<and> ideal (I 0) R"
    using Suc.prems(1) by auto
  have fprod_cl2: "ideal (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k) R"
    by (metis (no_types) ISet.finprod_closed I_carr Pi_split_insert_domain atMost_Suc ideals_set_def mem_Collect_eq partial_object.select_convs(1))
  have "carrier R = I (Suc (Suc n)) <+> I 0"
    by (simp add: Suc.prems(2))
  also have " ... = I (Suc (Suc n)) <+>
                    ((\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k) <+> I (Suc (Suc n)) \<cdot> (I 0))"
    using I0 by auto
  also have " ... = I (Suc (Suc n)) <+>
                    (I (Suc (Suc n)) \<cdot> (I 0) <+> (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k))"
    using fprod_cl2 I_SucSuc_I0 by (metis Un_commute ideal_prod_is_ideal union_genideal)
  also have " ... = (I (Suc (Suc n)) <+> I (Suc (Suc n)) \<cdot> (I 0)) <+>
                    (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k)"
    using fprod_cl2 I_SucSuc_I0 by (metis add.set_mult_assoc ideal_def ideal_prod_in_carrier
                                          oneideal ring.ideal_prod_one set_add_defs(1))
  also have " ... = I (Suc (Suc n)) <+> (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k)"
    using ideal_prod_simp[of "I (Suc (Suc n))" "I 0"] I_SucSuc_I0 by simp
  also have " ... = (\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k) <+> I (Suc (Suc n))"
    using fprod_cl2 I_SucSuc_I0 by (metis Un_commute union_genideal)
  finally show ?case by simp
qed

theorem (in cring) ideal_prod_eq_Inter:
  assumes "I: {..n :: nat} \<rightarrow> { J. ideal J R }"
    and "\<And>i j. \<lbrakk> i \<in> {..n}; j \<in> {..n} \<rbrakk> \<Longrightarrow> i \<noteq> j \<Longrightarrow> (I i) <+> (I j) = carrier R"
  shows "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..n}. I k) = (\<Inter> k \<in> {..n}. I k)" using assms
proof (induct n)
  case 0 thus ?case
    using comm_monoid.finprod_0[OF ideals_set_is_comm_monoid] by (simp add: ideals_set_def)
next
  interpret ISet: comm_monoid "ideals_set R"
    by (simp add: ideals_set_is_comm_monoid)

  case (Suc n)
  hence IH: "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..n}. I k) = (\<Inter> k \<in> {..n}. I k)"
    by (simp add: atMost_Suc)
  hence "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k) = I (Suc n) \<otimes>\<^bsub>(ideals_set R)\<^esub> (\<Inter> k \<in> {..n}. I k)"
    using ISet.finprod_insert[of "{Suc 0..Suc n}" 0 I] atMost_Suc_eq_insert_0[of n]
    by (metis ISet.finprod_Suc Suc.prems(1) ideals_set_def partial_object.select_convs(1))
  hence "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k) = I (Suc n) \<cdot> (\<Inter> k \<in> {..n}. I k)"
    by (simp add: ideals_set_def)
  moreover have "(\<Inter> k \<in> {..n}. I k) <+> I (Suc n) = carrier R"
    using ideal_prod_eq_Inter_aux[of I n] by (simp add: Suc.prems IH)
  moreover have "ideal (\<Inter> k \<in> {..n}. I k) R"
    using ring.i_Intersect[of R "I ` {..n}"]
    by (metis IH ISet.finprod_closed Pi_split_insert_domain Suc.prems(1) atMost_Suc
              ideals_set_def mem_Collect_eq partial_object.select_convs(1))
  ultimately
  have "(\<Otimes>\<^bsub>(ideals_set R)\<^esub> k \<in> {..Suc n}. I k) = (\<Inter> k \<in> {..n}. I k) \<inter> I (Suc n)"
    using ideal_prod_eq_inter[of "\<Inter> k \<in> {..n}. I k" "I (Suc n)"]
          ideal_prod_commute[of "\<Inter> k \<in> {..n}. I k" "I (Suc n)"]
    by (metis PiE Suc.prems(1) atMost_iff mem_Collect_eq order_refl)
  thus ?case by (simp add: Int_commute atMost_Suc)
qed

corollary (in cring) inter_plus_ideal_eq_carrier:
  assumes "\<And>i. i \<le> Suc n \<Longrightarrow> ideal (I i) R"
      and "\<And>i j. \<lbrakk> i \<le> Suc n; j \<le> Suc n; i \<noteq> j \<rbrakk> \<Longrightarrow> I i <+> I j = carrier R"
  shows "(\<Inter> i \<le> n. I i) <+> (I (Suc n)) = carrier R"
  using ideal_prod_eq_Inter[of I n] ideal_prod_eq_Inter_aux[of I n] by (auto simp add: assms)

corollary (in cring) inter_plus_ideal_eq_carrier_arbitrary:
  assumes "\<And>i. i \<le> Suc n \<Longrightarrow> ideal (I i) R"
      and "\<And>i j. \<lbrakk> i \<le> Suc n; j \<le> Suc n; i \<noteq> j \<rbrakk> \<Longrightarrow> I i <+> I j = carrier R"
      and "j \<le> Suc n"
  shows "(\<Inter> i \<in> ({..(Suc n)} - { j }). I i) <+> (I j) = carrier R"
proof -
  define I' where "I' = (\<lambda>i. if i = Suc n then (I j) else
                             if i = j     then (I (Suc n))
                                          else (I i))"
  have "\<And>i. i \<le> Suc n \<Longrightarrow> ideal (I' i) R"
    using I'_def assms(1) assms(3) by auto
  moreover have "\<And>i j. \<lbrakk> i \<le> Suc n; j \<le> Suc n; i \<noteq> j \<rbrakk> \<Longrightarrow> I' i <+> I' j = carrier R"
    using I'_def assms(2-3) by force
  ultimately have "(\<Inter> i \<le> n. I' i) <+> (I' (Suc n)) = carrier R"
    using inter_plus_ideal_eq_carrier by simp

  moreover have "I' ` {..n} = I ` ({..(Suc n)} - { j })"
  proof
    show "I' ` {..n} \<subseteq> I ` ({..Suc n} - {j})"
    proof
      fix x assume "x \<in> I' ` {..n}"
      then obtain i where i: "i \<in> {..n}" "I' i = x" by blast
      thus "x \<in> I ` ({..Suc n} - {j})"
      proof (cases)
        assume "i = j" thus ?thesis using i I'_def by auto
      next
        assume "i \<noteq> j" thus ?thesis using I'_def i insert_iff by auto
      qed
    qed
  next
    show "I ` ({..Suc n} - {j}) \<subseteq> I' ` {..n}"
    proof
      fix x assume "x \<in> I ` ({..Suc n} - {j})"
      then obtain i where i: "i \<in> {..Suc n}" "i \<noteq> j" "I i = x" by blast
      thus "x \<in> I' ` {..n}"
      proof (cases)
        assume "i = Suc n" thus ?thesis using I'_def assms(3) i(2-3) by auto
      next
        assume "i \<noteq> Suc n" thus ?thesis using I'_def i by auto
      qed
    qed
  qed
  ultimately show ?thesis using I'_def by metis
qed

subsection \<open>Another Characterization of Prime Ideals\<close>

text \<open>With product of ideals being defined, we can give another definition of a prime ideal\<close>

lemma (in ring) primeideal_divides_ideal_prod:
  assumes "primeideal P R" "ideal I R" "ideal J R"
      and "I \<cdot> J \<subseteq> P"
    shows "I \<subseteq> P \<or> J \<subseteq> P"
proof (cases)
  assume "\<exists> i \<in> I. i \<notin> P"
  then obtain i where i: "i \<in> I" "i \<notin> P" by blast
  have "J \<subseteq> P"
  proof
    fix j assume j: "j \<in> J"
    hence "i \<otimes> j \<in> P"
      using ideal_prod.prod[OF i(1) j, of R] assms(4) by auto
    thus "j \<in> P"
      using primeideal.I_prime[OF assms(1), of i j] i j
      by (meson assms(2-3) ideal.Icarr)
  qed
  thus ?thesis by blast
next
  assume "\<not> (\<exists> i \<in> I. i \<notin> P)" thus ?thesis by blast
qed

lemma (in cring) divides_ideal_prod_imp_primeideal:
  assumes "ideal P R"
    and "P \<noteq> carrier R"
    and "\<And>I J. \<lbrakk> ideal I R; ideal J R; I \<cdot> J \<subseteq> P \<rbrakk> \<Longrightarrow> I \<subseteq> P \<or> J \<subseteq> P"
  shows "primeideal P R"
proof -
  have "\<And>a b. \<lbrakk> a \<in> carrier R; b \<in> carrier R; a \<otimes> b \<in> P \<rbrakk> \<Longrightarrow> a \<in> P \<or> b \<in> P"
  proof -
    fix a b assume A: "a \<in> carrier R" "b \<in> carrier R" "a \<otimes> b \<in> P"
    have "(PIdl a) \<cdot> (PIdl b) = Idl (PIdl (a \<otimes> b))"
      using ideal_prod_eq_genideal[of "Idl { a }" "Idl { b }"]
            A(1-2) cgenideal_eq_genideal cgenideal_ideal cgenideal_prod by auto
    hence "(PIdl a) \<cdot> (PIdl b) = PIdl (a \<otimes> b)"
      by (simp add: A Idl_subset_ideal cgenideal_ideal cgenideal_minimal
                    genideal_self oneideal subset_antisym)
    hence "(PIdl a) \<cdot> (PIdl b) \<subseteq> P"
      by (simp add: A(3) assms(1) cgenideal_minimal)
    hence "(PIdl a) \<subseteq> P \<or> (PIdl b) \<subseteq> P"
      by (simp add: A assms(3) cgenideal_ideal)
    thus "a \<in> P \<or> b \<in> P"
      using A cgenideal_self by blast
  qed
  thus ?thesis
    using assms is_cring by (simp add: primeidealI)
qed

end


(*  Title:      HOL/Computational_Algebra/Euclidean_Algorithm.thy
    Author:     Manuel Eberl, TU Muenchen
*)

section \<open>Abstract euclidean algorithm in euclidean (semi)rings\<close>

theory Euclidean_Algorithm
  imports Factorial_Ring
begin

subsection \<open>Generic construction of the (simple) euclidean algorithm\<close>

class normalization_euclidean_semiring = euclidean_semiring + normalization_semidom
begin

lemma euclidean_size_normalize [simp]:
  "euclidean_size (normalize a) = euclidean_size a"
proof (cases "a = 0")
  case True
  then show ?thesis
    by simp
next
  case [simp]: False
  have "euclidean_size (normalize a) \<le> euclidean_size (normalize a * unit_factor a)"
    by (rule size_mult_mono) simp
  moreover have "euclidean_size a \<le> euclidean_size (a * (1 div unit_factor a))"
    by (rule size_mult_mono) simp
  ultimately show ?thesis
    by simp
qed

context
begin

qualified function gcd :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "gcd a b = (if b = 0 then normalize a else gcd b (a mod b))"
  by pat_completeness simp
termination
  by (relation "measure (euclidean_size \<circ> snd)") (simp_all add: mod_size_less)

declare gcd.simps [simp del]

lemma eucl_induct [case_names zero mod]:
  assumes H1: "\<And>b. P b 0"
  and H2: "\<And>a b. b \<noteq> 0 \<Longrightarrow> P b (a mod b) \<Longrightarrow> P a b"
  shows "P a b"
proof (induct a b rule: gcd.induct)
  case (1 a b)
  show ?case
  proof (cases "b = 0")
    case True then show "P a b" by simp (rule H1)
  next
    case False
    then have "P b (a mod b)"
      by (rule "1.hyps")
    with \<open>b \<noteq> 0\<close> show "P a b"
      by (blast intro: H2)
  qed
qed

qualified lemma gcd_0:
  "gcd a 0 = normalize a"
  by (simp add: gcd.simps [of a 0])

qualified lemma gcd_mod:
  "a \<noteq> 0 \<Longrightarrow> gcd a (b mod a) = gcd b a"
  by (simp add: gcd.simps [of b 0] gcd.simps [of b a])

qualified definition lcm :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "lcm a b = normalize (a * b div gcd a b)"

qualified definition Lcm :: "'a set \<Rightarrow> 'a" \<comment> \<open>Somewhat complicated definition of Lcm that has the advantage of working
    for infinite sets as well\<close>
  where
  [code del]: "Lcm A = (if \<exists>l. l \<noteq> 0 \<and> (\<forall>a\<in>A. a dvd l) then
     let l = SOME l. l \<noteq> 0 \<and> (\<forall>a\<in>A. a dvd l) \<and> euclidean_size l =
       (LEAST n. \<exists>l. l \<noteq> 0 \<and> (\<forall>a\<in>A. a dvd l) \<and> euclidean_size l = n)
       in normalize l
      else 0)"

qualified definition Gcd :: "'a set \<Rightarrow> 'a"
  where [code del]: "Gcd A = Lcm {d. \<forall>a\<in>A. d dvd a}"

end

lemma semiring_gcd:
  "class.semiring_gcd one zero times gcd lcm
    divide plus minus unit_factor normalize"
proof
  show "gcd a b dvd a"
    and "gcd a b dvd b" for a b
    by (induct a b rule: eucl_induct)
      (simp_all add: local.gcd_0 local.gcd_mod dvd_mod_iff)
next
  show "c dvd a \<Longrightarrow> c dvd b \<Longrightarrow> c dvd gcd a b" for a b c
  proof (induct a b rule: eucl_induct)
    case (zero a) from \<open>c dvd a\<close> show ?case
      by (rule dvd_trans) (simp add: local.gcd_0)
  next
    case (mod a b)
    then show ?case
      by (simp add: local.gcd_mod dvd_mod_iff)
  qed
next
  show "normalize (gcd a b) = gcd a b" for a b
    by (induct a b rule: eucl_induct)
      (simp_all add: local.gcd_0 local.gcd_mod)
next
  show "lcm a b = normalize (a * b div gcd a b)" for a b
    by (fact local.lcm_def)
qed

interpretation semiring_gcd one zero times gcd lcm
  divide plus minus unit_factor normalize
  by (fact semiring_gcd)

lemma semiring_Gcd:
  "class.semiring_Gcd one zero times gcd lcm Gcd Lcm
    divide plus minus unit_factor normalize"
proof -
  show ?thesis
  proof
    have "(\<forall>a\<in>A. a dvd Lcm A) \<and> (\<forall>b. (\<forall>a\<in>A. a dvd b) \<longrightarrow> Lcm A dvd b)" for A
    proof (cases "\<exists>l. l \<noteq>  0 \<and> (\<forall>a\<in>A. a dvd l)")
      case False
      then have "Lcm A = 0"
        by (auto simp add: local.Lcm_def)
      with False show ?thesis
        by auto
    next
      case True
      then obtain l\<^sub>0 where l\<^sub>0_props: "l\<^sub>0 \<noteq> 0" "\<forall>a\<in>A. a dvd l\<^sub>0" by blast
      define n where "n = (LEAST n. \<exists>l. l \<noteq> 0 \<and> (\<forall>a\<in>A. a dvd l) \<and> euclidean_size l = n)"
      define l where "l = (SOME l. l \<noteq> 0 \<and> (\<forall>a\<in>A. a dvd l) \<and> euclidean_size l = n)"
      have "\<exists>l. l \<noteq> 0 \<and> (\<forall>a\<in>A. a dvd l) \<and> euclidean_size l = n"
        apply (subst n_def)
        apply (rule LeastI [of _ "euclidean_size l\<^sub>0"])
        apply (rule exI [of _ l\<^sub>0])
        apply (simp add: l\<^sub>0_props)
        done
      from someI_ex [OF this] have "l \<noteq> 0" and "\<forall>a\<in>A. a dvd l"
        and "euclidean_size l = n"
        unfolding l_def by simp_all
      {
        fix l' assume "\<forall>a\<in>A. a dvd l'"
        with \<open>\<forall>a\<in>A. a dvd l\<close> have "\<forall>a\<in>A. a dvd gcd l l'"
          by (auto intro: gcd_greatest)
        moreover from \<open>l \<noteq> 0\<close> have "gcd l l' \<noteq> 0"
          by simp
        ultimately have "\<exists>b. b \<noteq> 0 \<and> (\<forall>a\<in>A. a dvd b) \<and>
          euclidean_size b = euclidean_size (gcd l l')"
          by (intro exI [of _ "gcd l l'"], auto)
        then have "euclidean_size (gcd l l') \<ge> n"
          by (subst n_def) (rule Least_le)
        moreover have "euclidean_size (gcd l l') \<le> n"
        proof -
          have "gcd l l' dvd l"
            by simp
          then obtain a where "l = gcd l l' * a" ..
          with \<open>l \<noteq> 0\<close> have "a \<noteq> 0"
            by auto
          hence "euclidean_size (gcd l l') \<le> euclidean_size (gcd l l' * a)"
            by (rule size_mult_mono)
          also have "gcd l l' * a = l" using \<open>l = gcd l l' * a\<close> ..
          also note \<open>euclidean_size l = n\<close>
          finally show "euclidean_size (gcd l l') \<le> n" .
        qed
        ultimately have *: "euclidean_size l = euclidean_size (gcd l l')"
          by (intro le_antisym, simp_all add: \<open>euclidean_size l = n\<close>)
        from \<open>l \<noteq> 0\<close> have "l dvd gcd l l'"
          by (rule dvd_euclidean_size_eq_imp_dvd) (auto simp add: *)
        hence "l dvd l'" by (rule dvd_trans [OF _ gcd_dvd2])
      }
      with \<open>\<forall>a\<in>A. a dvd l\<close> and \<open>l \<noteq> 0\<close>
        have "(\<forall>a\<in>A. a dvd normalize l) \<and>
          (\<forall>l'. (\<forall>a\<in>A. a dvd l') \<longrightarrow> normalize l dvd l')"
        by auto
      also from True have "normalize l = Lcm A"
        by (simp add: local.Lcm_def Let_def n_def l_def)
      finally show ?thesis .
    qed
    then show dvd_Lcm: "a \<in> A \<Longrightarrow> a dvd Lcm A"
      and Lcm_least: "(\<And>a. a \<in> A \<Longrightarrow> a dvd b) \<Longrightarrow> Lcm A dvd b" for A and a b
      by auto
    show "a \<in> A \<Longrightarrow> Gcd A dvd a" for A and a
      by (auto simp add: local.Gcd_def intro: Lcm_least)
    show "(\<And>a. a \<in> A \<Longrightarrow> b dvd a) \<Longrightarrow> b dvd Gcd A" for A and b
      by (auto simp add: local.Gcd_def intro: dvd_Lcm)
    show [simp]: "normalize (Lcm A) = Lcm A" for A
      by (simp add: local.Lcm_def)
    show "normalize (Gcd A) = Gcd A" for A
      by (simp add: local.Gcd_def)
  qed
qed

interpretation semiring_Gcd one zero times gcd lcm Gcd Lcm
    divide plus minus unit_factor normalize
  by (fact semiring_Gcd)

subclass factorial_semiring
proof -
  show "class.factorial_semiring divide plus minus zero times one
     unit_factor normalize"
  proof (standard, rule factorial_semiring_altI_aux) \<comment> \<open>FIXME rule\<close>
    fix x assume "x \<noteq> 0"
    thus "finite {p. p dvd x \<and> normalize p = p}"
    proof (induction "euclidean_size x" arbitrary: x rule: less_induct)
      case (less x)
      show ?case
      proof (cases "\<exists>y. y dvd x \<and> \<not>x dvd y \<and> \<not>is_unit y")
        case False
        have "{p. p dvd x \<and> normalize p = p} \<subseteq> {1, normalize x}"
        proof
          fix p assume p: "p \<in> {p. p dvd x \<and> normalize p = p}"
          with False have "is_unit p \<or> x dvd p" by blast
          thus "p \<in> {1, normalize x}"
          proof (elim disjE)
            assume "is_unit p"
            hence "normalize p = 1" by (simp add: is_unit_normalize)
            with p show ?thesis by simp
          next
            assume "x dvd p"
            with p have "normalize p = normalize x" by (intro associatedI) simp_all
            with p show ?thesis by simp
          qed
        qed
        moreover have "finite \<dots>" by simp
        ultimately show ?thesis by (rule finite_subset)
      next
        case True
        then obtain y where y: "y dvd x" "\<not>x dvd y" "\<not>is_unit y" by blast
        define z where "z = x div y"
        let ?fctrs = "\<lambda>x. {p. p dvd x \<and> normalize p = p}"
        from y have x: "x = y * z" by (simp add: z_def)
        with less.prems have "y \<noteq> 0" "z \<noteq> 0" by auto
        have normalized_factors_product:
          "{p. p dvd a * b \<and> normalize p = p} \<subseteq>
             (\<lambda>(x,y). normalize (x * y)) ` ({p. p dvd a \<and> normalize p = p} \<times> {p. p dvd b \<and> normalize p = p})"
          for a b
        proof safe
          fix p assume p: "p dvd a * b" "normalize p = p"
          from p(1) obtain x y where xy: "p = x * y" "x dvd a" "y dvd b"
            by (rule dvd_productE)
          define x' y' where "x' = normalize x" and "y' = normalize y"
          have "p = normalize (x' * y')"
            using p by (simp add: xy x'_def y'_def)
          moreover have "x' dvd a \<and> normalize x' = x'" and "y' dvd b \<and> normalize y' = y'"
            using xy by (auto simp: x'_def y'_def)
          ultimately show "p \<in> (\<lambda>(x, y). normalize (x * y)) `
              ({p. p dvd a \<and> normalize p = p} \<times> {p. p dvd b \<and> normalize p = p})" by fast
        qed
        from x y have "\<not>is_unit z" by (auto simp: mult_unit_dvd_iff)
        have "?fctrs x \<subseteq> (\<lambda>(p,p'). normalize (p * p')) ` (?fctrs y \<times> ?fctrs z)"
          by (subst x) (rule normalized_factors_product)
        moreover have "\<not>y * z dvd y * 1" "\<not>y * z dvd 1 * z"
          by (subst dvd_times_left_cancel_iff dvd_times_right_cancel_iff; fact)+
        hence "finite ((\<lambda>(p,p'). normalize (p * p')) ` (?fctrs y \<times> ?fctrs z))"
          by (intro finite_imageI finite_cartesian_product less dvd_proper_imp_size_less)
             (auto simp: x)
        ultimately show ?thesis by (rule finite_subset)
      qed
    qed
  next
    fix p
    assume "irreducible p"
    then show "prime_elem p"
      by (rule irreducible_imp_prime_elem_gcd)
  qed
qed

lemma Gcd_eucl_set [code]:
  "Gcd (set xs) = fold gcd xs 0"
  by (fact Gcd_set_eq_fold)

lemma Lcm_eucl_set [code]:
  "Lcm (set xs) = fold lcm xs 1"
  by (fact Lcm_set_eq_fold)

end

hide_const (open) gcd lcm Gcd Lcm

lemma prime_elem_int_abs_iff [simp]:
  fixes p :: int
  shows "prime_elem \<bar>p\<bar> \<longleftrightarrow> prime_elem p"
  using prime_elem_normalize_iff [of p] by simp

lemma prime_elem_int_minus_iff [simp]:
  fixes p :: int
  shows "prime_elem (- p) \<longleftrightarrow> prime_elem p"
  using prime_elem_normalize_iff [of "- p"] by simp

lemma prime_int_iff:
  fixes p :: int
  shows "prime p \<longleftrightarrow> p > 0 \<and> prime_elem p"
  by (auto simp add: prime_def dest: prime_elem_not_zeroI)

subsection \<open>The (simple) euclidean algorithm as gcd computation\<close>

class euclidean_semiring_gcd = normalization_euclidean_semiring + gcd + Gcd +
  assumes gcd_eucl: "Euclidean_Algorithm.gcd = GCD.gcd"
    and lcm_eucl: "Euclidean_Algorithm.lcm = GCD.lcm"
  assumes Gcd_eucl: "Euclidean_Algorithm.Gcd = GCD.Gcd"
    and Lcm_eucl: "Euclidean_Algorithm.Lcm = GCD.Lcm"
begin

subclass semiring_gcd
  unfolding gcd_eucl [symmetric] lcm_eucl [symmetric]
  by (fact semiring_gcd)

subclass semiring_Gcd
  unfolding  gcd_eucl [symmetric] lcm_eucl [symmetric]
    Gcd_eucl [symmetric] Lcm_eucl [symmetric]
  by (fact semiring_Gcd)

subclass factorial_semiring_gcd
proof
  show "gcd a b = gcd_factorial a b" for a b
    apply (rule sym)
    apply (rule gcdI)
       apply (fact gcd_lcm_factorial)+
    done
  then show "lcm a b = lcm_factorial a b" for a b
    by (simp add: lcm_factorial_gcd_factorial lcm_gcd)
  show "Gcd A = Gcd_factorial A" for A
    apply (rule sym)
    apply (rule GcdI)
       apply (fact gcd_lcm_factorial)+
    done
  show "Lcm A = Lcm_factorial A" for A
    apply (rule sym)
    apply (rule LcmI)
       apply (fact gcd_lcm_factorial)+
    done
qed

lemma gcd_mod_right [simp]:
  "a \<noteq> 0 \<Longrightarrow> gcd a (b mod a) = gcd a b"
  unfolding gcd.commute [of a b]
  by (simp add: gcd_eucl [symmetric] local.gcd_mod)

lemma gcd_mod_left [simp]:
  "b \<noteq> 0 \<Longrightarrow> gcd (a mod b) b = gcd a b"
  by (drule gcd_mod_right [of _ a]) (simp add: gcd.commute)

lemma euclidean_size_gcd_le1 [simp]:
  assumes "a \<noteq> 0"
  shows "euclidean_size (gcd a b) \<le> euclidean_size a"
proof -
  from gcd_dvd1 obtain c where A: "a = gcd a b * c" ..
  with assms have "c \<noteq> 0"
    by auto
  moreover from this
  have "euclidean_size (gcd a b) \<le> euclidean_size (gcd a b * c)"
    by (rule size_mult_mono)
  with A show ?thesis
    by simp
qed

lemma euclidean_size_gcd_le2 [simp]:
  "b \<noteq> 0 \<Longrightarrow> euclidean_size (gcd a b) \<le> euclidean_size b"
  by (subst gcd.commute, rule euclidean_size_gcd_le1)

lemma euclidean_size_gcd_less1:
  assumes "a \<noteq> 0" and "\<not> a dvd b"
  shows "euclidean_size (gcd a b) < euclidean_size a"
proof (rule ccontr)
  assume "\<not>euclidean_size (gcd a b) < euclidean_size a"
  with \<open>a \<noteq> 0\<close> have A: "euclidean_size (gcd a b) = euclidean_size a"
    by (intro le_antisym, simp_all)
  have "a dvd gcd a b"
    by (rule dvd_euclidean_size_eq_imp_dvd) (simp_all add: assms A)
  hence "a dvd b" using dvd_gcdD2 by blast
  with \<open>\<not> a dvd b\<close> show False by contradiction
qed

lemma euclidean_size_gcd_less2:
  assumes "b \<noteq> 0" and "\<not> b dvd a"
  shows "euclidean_size (gcd a b) < euclidean_size b"
  using assms by (subst gcd.commute, rule euclidean_size_gcd_less1)

lemma euclidean_size_lcm_le1:
  assumes "a \<noteq> 0" and "b \<noteq> 0"
  shows "euclidean_size a \<le> euclidean_size (lcm a b)"
proof -
  have "a dvd lcm a b" by (rule dvd_lcm1)
  then obtain c where A: "lcm a b = a * c" ..
  with \<open>a \<noteq> 0\<close> and \<open>b \<noteq> 0\<close> have "c \<noteq> 0" by (auto simp: lcm_eq_0_iff)
  then show ?thesis by (subst A, intro size_mult_mono)
qed

lemma euclidean_size_lcm_le2:
  "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> euclidean_size b \<le> euclidean_size (lcm a b)"
  using euclidean_size_lcm_le1 [of b a] by (simp add: ac_simps)

lemma euclidean_size_lcm_less1:
  assumes "b \<noteq> 0" and "\<not> b dvd a"
  shows "euclidean_size a < euclidean_size (lcm a b)"
proof (rule ccontr)
  from assms have "a \<noteq> 0" by auto
  assume "\<not>euclidean_size a < euclidean_size (lcm a b)"
  with \<open>a \<noteq> 0\<close> and \<open>b \<noteq> 0\<close> have "euclidean_size (lcm a b) = euclidean_size a"
    by (intro le_antisym, simp, intro euclidean_size_lcm_le1)
  with assms have "lcm a b dvd a"
    by (rule_tac dvd_euclidean_size_eq_imp_dvd) (auto simp: lcm_eq_0_iff)
  hence "b dvd a" by (rule lcm_dvdD2)
  with \<open>\<not>b dvd a\<close> show False by contradiction
qed

lemma euclidean_size_lcm_less2:
  assumes "a \<noteq> 0" and "\<not> a dvd b"
  shows "euclidean_size b < euclidean_size (lcm a b)"
  using assms euclidean_size_lcm_less1 [of a b] by (simp add: ac_simps)

end

lemma factorial_euclidean_semiring_gcdI:
  "OFCLASS('a::{factorial_semiring_gcd, normalization_euclidean_semiring}, euclidean_semiring_gcd_class)"
proof
  interpret semiring_Gcd 1 0 times
    Euclidean_Algorithm.gcd Euclidean_Algorithm.lcm
    Euclidean_Algorithm.Gcd Euclidean_Algorithm.Lcm
    divide plus minus unit_factor normalize
    rewrites "dvd.dvd (*) = Rings.dvd"
    by (fact semiring_Gcd) (simp add: dvd.dvd_def dvd_def fun_eq_iff)
  show [simp]: "Euclidean_Algorithm.gcd = (gcd :: 'a \<Rightarrow> _)"
  proof (rule ext)+
    fix a b :: 'a
    show "Euclidean_Algorithm.gcd a b = gcd a b"
    proof (induct a b rule: eucl_induct)
      case zero
      then show ?case
        by simp
    next
      case (mod a b)
      moreover have "gcd b (a mod b) = gcd b a"
        using GCD.gcd_add_mult [of b "a div b" "a mod b", symmetric]
          by (simp add: div_mult_mod_eq)
      ultimately show ?case
        by (simp add: Euclidean_Algorithm.gcd_mod ac_simps)
    qed
  qed
  show [simp]: "Euclidean_Algorithm.Lcm = (Lcm :: 'a set \<Rightarrow> _)"
    by (auto intro!: Lcm_eqI GCD.dvd_Lcm GCD.Lcm_least)
  show "Euclidean_Algorithm.lcm = (lcm :: 'a \<Rightarrow> _)"
    by (simp add: fun_eq_iff Euclidean_Algorithm.lcm_def semiring_gcd_class.lcm_gcd)
  show "Euclidean_Algorithm.Gcd = (Gcd :: 'a set \<Rightarrow> _)"
    by (simp add: fun_eq_iff Euclidean_Algorithm.Gcd_def semiring_Gcd_class.Gcd_Lcm)
qed

subsection \<open>The extended euclidean algorithm\<close>

class euclidean_ring_gcd = euclidean_semiring_gcd + idom
begin

subclass euclidean_ring ..
subclass ring_gcd ..
subclass factorial_ring_gcd ..

function euclid_ext_aux :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'a) \<times> 'a"
  where "euclid_ext_aux s' s t' t r' r = (
     if r = 0 then let c = 1 div unit_factor r' in ((s' * c, t' * c), normalize r')
     else let q = r' div r
          in euclid_ext_aux s (s' - q * s) t (t' - q * t) r (r' mod r))"
  by auto
termination
  by (relation "measure (\<lambda>(_, _, _, _, _, b). euclidean_size b)")
    (simp_all add: mod_size_less)

abbreviation (input) euclid_ext :: "'a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'a) \<times> 'a"
  where "euclid_ext \<equiv> euclid_ext_aux 1 0 0 1"

lemma
  assumes "gcd r' r = gcd a b"
  assumes "s' * a + t' * b = r'"
  assumes "s * a + t * b = r"
  assumes "euclid_ext_aux s' s t' t r' r = ((x, y), c)"
  shows euclid_ext_aux_eq_gcd: "c = gcd a b"
    and euclid_ext_aux_bezout: "x * a + y * b = gcd a b"
proof -
  have "case euclid_ext_aux s' s t' t r' r of ((x, y), c) \<Rightarrow>
    x * a + y * b = c \<and> c = gcd a b" (is "?P (euclid_ext_aux s' s t' t r' r)")
    using assms(1-3)
  proof (induction s' s t' t r' r rule: euclid_ext_aux.induct)
    case (1 s' s t' t r' r)
    show ?case
    proof (cases "r = 0")
      case True
      hence "euclid_ext_aux s' s t' t r' r =
               ((s' div unit_factor r', t' div unit_factor r'), normalize r')"
        by (subst euclid_ext_aux.simps) (simp add: Let_def)
      also have "?P \<dots>"
      proof safe
        have "s' div unit_factor r' * a + t' div unit_factor r' * b =
                (s' * a + t' * b) div unit_factor r'"
          by (cases "r' = 0") (simp_all add: unit_div_commute)
        also have "s' * a + t' * b = r'" by fact
        also have "\<dots> div unit_factor r' = normalize r'" by simp
        finally show "s' div unit_factor r' * a + t' div unit_factor r' * b = normalize r'" .
      next
        from "1.prems" True show "normalize r' = gcd a b"
          by simp
      qed
      finally show ?thesis .
    next
      case False
      hence "euclid_ext_aux s' s t' t r' r =
             euclid_ext_aux s (s' - r' div r * s) t (t' - r' div r * t) r (r' mod r)"
        by (subst euclid_ext_aux.simps) (simp add: Let_def)
      also from "1.prems" False have "?P \<dots>"
      proof (intro "1.IH")
        have "(s' - r' div r * s) * a + (t' - r' div r * t) * b =
              (s' * a + t' * b) - r' div r * (s * a + t * b)" by (simp add: algebra_simps)
        also have "s' * a + t' * b = r'" by fact
        also have "s * a + t * b = r" by fact
        also have "r' - r' div r * r = r' mod r" using div_mult_mod_eq [of r' r]
          by (simp add: algebra_simps)
        finally show "(s' - r' div r * s) * a + (t' - r' div r * t) * b = r' mod r" .
      qed (auto simp: algebra_simps minus_mod_eq_div_mult [symmetric] gcd.commute)
      finally show ?thesis .
    qed
  qed
  with assms(4) show "c = gcd a b" "x * a + y * b = gcd a b"
    by simp_all
qed

declare euclid_ext_aux.simps [simp del]

definition bezout_coefficients :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<times> 'a"
  where [code]: "bezout_coefficients a b = fst (euclid_ext a b)"

lemma bezout_coefficients_0:
  "bezout_coefficients a 0 = (1 div unit_factor a, 0)"
  by (simp add: bezout_coefficients_def euclid_ext_aux.simps)

lemma bezout_coefficients_left_0:
  "bezout_coefficients 0 a = (0, 1 div unit_factor a)"
  by (simp add: bezout_coefficients_def euclid_ext_aux.simps)

lemma bezout_coefficients:
  assumes "bezout_coefficients a b = (x, y)"
  shows "x * a + y * b = gcd a b"
  using assms by (simp add: bezout_coefficients_def
    euclid_ext_aux_bezout [of a b a b 1 0 0 1 x y] prod_eq_iff)

lemma bezout_coefficients_fst_snd:
  "fst (bezout_coefficients a b) * a + snd (bezout_coefficients a b) * b = gcd a b"
  by (rule bezout_coefficients) simp

lemma euclid_ext_eq [simp]:
  "euclid_ext a b = (bezout_coefficients a b, gcd a b)" (is "?p = ?q")
proof
  show "fst ?p = fst ?q"
    by (simp add: bezout_coefficients_def)
  have "snd (euclid_ext_aux 1 0 0 1 a b) = gcd a b"
    by (rule euclid_ext_aux_eq_gcd [of a b a b 1 0 0 1])
      (simp_all add: prod_eq_iff)
  then show "snd ?p = snd ?q"
    by simp
qed

declare euclid_ext_eq [symmetric, code_unfold]

end

class normalization_euclidean_semiring_multiplicative =
  normalization_euclidean_semiring + normalization_semidom_multiplicative
begin

subclass factorial_semiring_multiplicative ..

end

class field_gcd =
  field + unique_euclidean_ring + euclidean_ring_gcd + normalization_semidom_multiplicative
begin

subclass normalization_euclidean_semiring_multiplicative ..

subclass normalization_euclidean_semiring ..

subclass semiring_gcd_mult_normalize ..

end

subsection \<open>Typical instances\<close>

instance nat :: normalization_euclidean_semiring ..

instance nat :: euclidean_semiring_gcd
proof
  interpret semiring_Gcd 1 0 times
    "Euclidean_Algorithm.gcd" "Euclidean_Algorithm.lcm"
    "Euclidean_Algorithm.Gcd" "Euclidean_Algorithm.Lcm"
    divide plus minus unit_factor normalize
    rewrites "dvd.dvd (*) = Rings.dvd"
    by (fact semiring_Gcd) (simp add: dvd.dvd_def dvd_def fun_eq_iff)
  show [simp]: "(Euclidean_Algorithm.gcd :: nat \<Rightarrow> _) = gcd"
  proof (rule ext)+
    fix m n :: nat
    show "Euclidean_Algorithm.gcd m n = gcd m n"
    proof (induct m n rule: eucl_induct)
      case zero
      then show ?case
        by simp
    next
      case (mod m n)
      then have "gcd n (m mod n) = gcd n m"
        using gcd_nat.simps [of m n] by (simp add: ac_simps)
      with mod show ?case
        by (simp add: Euclidean_Algorithm.gcd_mod ac_simps)
    qed
  qed
  show [simp]: "(Euclidean_Algorithm.Lcm :: nat set \<Rightarrow> _) = Lcm"
    by (auto intro!: ext Lcm_eqI)
  show "(Euclidean_Algorithm.lcm :: nat \<Rightarrow> _) = lcm"
    by (simp add: fun_eq_iff Euclidean_Algorithm.lcm_def semiring_gcd_class.lcm_gcd)
  show "(Euclidean_Algorithm.Gcd :: nat set \<Rightarrow> _) = Gcd"
    by (simp add: fun_eq_iff Euclidean_Algorithm.Gcd_def semiring_Gcd_class.Gcd_Lcm)
qed

instance nat :: normalization_euclidean_semiring_multiplicative ..

lemma prime_factorization_Suc_0 [simp]: "prime_factorization (Suc 0) = {#}"
  unfolding One_nat_def [symmetric] using prime_factorization_1 .

instance int :: normalization_euclidean_semiring ..

instance int :: euclidean_ring_gcd
proof
  interpret semiring_Gcd 1 0 times
    "Euclidean_Algorithm.gcd" "Euclidean_Algorithm.lcm"
    "Euclidean_Algorithm.Gcd" "Euclidean_Algorithm.Lcm"
    divide plus minus unit_factor normalize
    rewrites "dvd.dvd (*) = Rings.dvd"
    by (fact semiring_Gcd) (simp add: dvd.dvd_def dvd_def fun_eq_iff)
  show [simp]: "(Euclidean_Algorithm.gcd :: int \<Rightarrow> _) = gcd"
  proof (rule ext)+
    fix k l :: int
    show "Euclidean_Algorithm.gcd k l = gcd k l"
    proof (induct k l rule: eucl_induct)
      case zero
      then show ?case
        by simp
    next
      case (mod k l)
      have "gcd l (k mod l) = gcd l k"
      proof (cases l "0::int" rule: linorder_cases)
        case less
        then show ?thesis
          using gcd_non_0_int [of "- l" "- k"] by (simp add: ac_simps)
      next
        case equal
        with mod show ?thesis
          by simp
      next
        case greater
        then show ?thesis
          using gcd_non_0_int [of l k] by (simp add: ac_simps)
      qed
      with mod show ?case
        by (simp add: Euclidean_Algorithm.gcd_mod ac_simps)
    qed
  qed
  show [simp]: "(Euclidean_Algorithm.Lcm :: int set \<Rightarrow> _) = Lcm"
    by (auto intro!: ext Lcm_eqI)
  show "(Euclidean_Algorithm.lcm :: int \<Rightarrow> _) = lcm"
    by (simp add: fun_eq_iff Euclidean_Algorithm.lcm_def semiring_gcd_class.lcm_gcd)
  show "(Euclidean_Algorithm.Gcd :: int set \<Rightarrow> _) = Gcd"
    by (simp add: fun_eq_iff Euclidean_Algorithm.Gcd_def semiring_Gcd_class.Gcd_Lcm)
qed

instance int :: normalization_euclidean_semiring_multiplicative ..

end


theory Homework5_1
imports Main
begin

  (*
    ISSUED: Wednesday, October 18
    DUE: Wednesday, October 25, 11:59pm
    POINTS: 5
  *)

  (*
    Recall the LTS formalization from the tutorial.
    I copied the important parts here:
  *)

section \<open>Parts of LTS from Tutorial\<close>
type_synonym ('q,'a) lts = "'q \<Rightarrow> 'a \<Rightarrow> 'q \<Rightarrow> bool"

inductive word :: "('q,'a) lts \<Rightarrow> 'q \<Rightarrow> 'a list \<Rightarrow> 'q \<Rightarrow> bool"
  where
    empty: "word L q [] q"
  | cons: "\<lbrakk> L p a q; word L q as r \<rbrakk> \<Longrightarrow> word L p (a#as) r"

lemma word_Nil_conv: "word L p [] q \<longleftrightarrow> p=q"
  by (auto elim: word.cases intro: word.intros)

lemma word_Cons_conv: "word L p (a#bs) r \<longleftrightarrow> (\<exists>q. L p a q \<and> word L q bs r)"
  by (auto elim: word.cases intro: word.intros)

lemma word_append_conv: "word L p (as@bs) r \<longleftrightarrow> (\<exists>q. word L p as q \<and> word L q bs r)"
  (* Slightly changed proof compared to tutorial *)
  by (induction as arbitrary: p) (auto simp: word_Nil_conv word_Cons_conv)

section \<open>Product Construction\<close>
(* Here starts the homework assignment *)

(*
  For a labeled transition system, we define the language
  from state p to state q as the set of all words from p to q.
*)
definition "lang L p q = {w. word L p w q}"

(*
  The product "prod L1 L2" of two labeled transition systems L1 :: ('p,'a) lts
  and L2 :: ('q,'a) lts is a labeled transition system over states of
  type 'p\<times>'q. We define (prod L1 L2) (p1,q1) a (p2,q2) iff
  L1 p1 a p2 and L2 q1 a q2.
*)
definition L_prod :: "('p,'a) lts \<Rightarrow> ('q,'a) lts \<Rightarrow> ('p\<times>'q,'a) lts" where
  "L_prod L1 L2 \<equiv> \<lambda>(p1,p2) l (q1,q2). L1 p1 l q1 \<and> L2 p2 l q2"

(*
  Intuitively, a transition of the product corresponds to a transition
  of both components, with the same label.
*)

(*
  Show that the language of the product LTS corresponds to the
  intersection of the languages of the component LTSs.

  Proof sketch:
    assume we have a word w in the product language.
    hence, we have "word (L_prod L1 L2) (p1, p2) w (q1, q2)"
    by induction on w, we get word L1 p1 w q1 and word L2 p2 w q2
    from which, by definition of lang, we get the proposition.

    the proof of the other direction is symmetric.

  Use an Isar proof! Note: There is no notion of "symmetric" in Isar, so
    you will have to actually prove both directions.

  Hint: In the induction proofs, use the structural equations
     word_Cons_conv word_Nil_conv as simp rules, rather than
     the word.intros and word.cases rules.
     Don't forget to generalize over some variables!

*)

lemma "lang (L_prod L1 L2) (p1,p2) (q1,q2) = (lang L1 p1 q1 \<inter> lang L2 p2 q2)"
proof (intro equalityI subsetI)
  fix w
  assume "w \<in> lang (L_prod L1 L2) (p1, p2) (q1, q2)"
  (* Insert proof of first direction here *)
  show "w \<in> lang L1 p1 q1 \<inter> lang L2 p2 q2" sorry
next
  fix w
  assume "w \<in> lang L1 p1 q1 \<inter> lang L2 p2 q2"
  (* Insert proof of other direction here *)
  show "w \<in> lang (L_prod L1 L2) (p1, p2) (q1, q2)" sorry
qed

end