(*  Title:      HOL/Probability/PMF_Impl.thy
    Author:     Manuel Eberl, TU München

    An implementation of PMFs using Mappings, which are implemented with association lists
    by default. Also includes Quickcheck setup for PMFs.
*)

section \<open>Code generation for PMFs\<close>

theory PMF_Impl
imports Probability_Mass_Function "HOL-Library.AList_Mapping"
begin

subsection \<open>General code generation setup\<close>

definition pmf_of_mapping :: "('a, real) mapping \<Rightarrow> 'a pmf" where
  "pmf_of_mapping m = embed_pmf (Mapping.lookup_default 0 m)"

lemma nn_integral_lookup_default:
  fixes m :: "('a, real) mapping"
  assumes "finite (Mapping.keys m)" "All_mapping m (\<lambda>_ x. x \<ge> 0)"
  shows   "nn_integral (count_space UNIV) (\<lambda>k. ennreal (Mapping.lookup_default 0 m k)) =
             ennreal (\<Sum>k\<in>Mapping.keys m. Mapping.lookup_default 0 m k)"
proof -
  have "nn_integral (count_space UNIV) (\<lambda>k. ennreal (Mapping.lookup_default 0 m k)) =
          (\<Sum>x\<in>Mapping.keys m. ennreal (Mapping.lookup_default 0 m x))" using assms
    by (subst nn_integral_count_space'[of "Mapping.keys m"])
       (auto simp: Mapping.lookup_default_def keys_is_none_rep Option.is_none_def)
  also from assms have "\<dots> = ennreal (\<Sum>k\<in>Mapping.keys m. Mapping.lookup_default 0 m k)"
    by (intro sum_ennreal)
       (auto simp: Mapping.lookup_default_def All_mapping_def split: option.splits)
  finally show ?thesis .
qed

lemma pmf_of_mapping:
  assumes "finite (Mapping.keys m)" "All_mapping m (\<lambda>_ p. p \<ge> 0)"
  assumes "(\<Sum>x\<in>Mapping.keys m. Mapping.lookup_default 0 m x) = 1"
  shows   "pmf (pmf_of_mapping m) x = Mapping.lookup_default 0 m x"
  unfolding pmf_of_mapping_def
proof (intro pmf_embed_pmf)
  from assms show "(\<integral>\<^sup>+x. ennreal (Mapping.lookup_default 0 m x) \<partial>count_space UNIV) = 1"
    by (subst nn_integral_lookup_default) (simp_all)
qed (insert assms, simp add: All_mapping_def Mapping.lookup_default_def split: option.splits)

lemma pmf_of_set_pmf_of_mapping:
  assumes "A \<noteq> {}" "set xs = A" "distinct xs"
  shows   "pmf_of_set A = pmf_of_mapping (Mapping.tabulate xs (\<lambda>_. 1 / real (length xs)))"
           (is "?lhs = ?rhs")
  by (rule pmf_eqI, subst pmf_of_mapping)
     (insert assms, auto intro!: All_mapping_tabulate
                         simp: Mapping.lookup_default_def lookup_tabulate distinct_card)

lift_definition mapping_of_pmf :: "'a pmf \<Rightarrow> ('a, real) mapping" is
  "\<lambda>p x. if pmf p x = 0 then None else Some (pmf p x)" .

lemma lookup_default_mapping_of_pmf:
  "Mapping.lookup_default 0 (mapping_of_pmf p) x = pmf p x"
  by (simp add: mapping_of_pmf.abs_eq lookup_default_def Mapping.lookup.abs_eq)

context
begin

interpretation pmf_as_function .

lemma nn_integral_pmf_eq_1: "(\<integral>\<^sup>+ x. ennreal (pmf p x) \<partial>count_space UNIV) = 1"
  by transfer simp_all
end

lemma pmf_of_mapping_mapping_of_pmf [code abstype]:
    "pmf_of_mapping (mapping_of_pmf p) = p"
  unfolding pmf_of_mapping_def
  by (rule pmf_eqI, subst pmf_embed_pmf)
     (insert nn_integral_pmf_eq_1[of p],
      auto simp: lookup_default_mapping_of_pmf split: option.splits)

lemma mapping_of_pmfI:
  assumes "\<And>x. x \<in> Mapping.keys m \<Longrightarrow> Mapping.lookup m x = Some (pmf p x)"
  assumes "Mapping.keys m = set_pmf p"
  shows   "mapping_of_pmf p = m"
  using assms by transfer (rule ext, auto simp: set_pmf_eq)

lemma mapping_of_pmfI':
  assumes "\<And>x. x \<in> Mapping.keys m \<Longrightarrow> Mapping.lookup_default 0 m x = pmf p x"
  assumes "Mapping.keys m = set_pmf p"
  shows   "mapping_of_pmf p = m"
  using assms unfolding Mapping.lookup_default_def
  by transfer (rule ext, force simp: set_pmf_eq)

lemma return_pmf_code [code abstract]:
  "mapping_of_pmf (return_pmf x) = Mapping.update x 1 Mapping.empty"
  by (intro mapping_of_pmfI) (auto simp: lookup_update')

lemma pmf_of_set_code_aux:
  assumes "A \<noteq> {}" "set xs = A" "distinct xs"
  shows   "mapping_of_pmf (pmf_of_set A) = Mapping.tabulate xs (\<lambda>_. 1 / real (length xs))"
  using assms
  by (intro mapping_of_pmfI, subst pmf_of_set)
     (auto simp: lookup_tabulate distinct_card)

definition pmf_of_set_impl where
  "pmf_of_set_impl A = mapping_of_pmf (pmf_of_set A)"

(* This equation can be used to easily implement pmf_of_set for other set implementations *)
lemma pmf_of_set_impl_code_alt:
  assumes "A \<noteq> {}" "finite A"
  shows   "pmf_of_set_impl A =
             (let p = 1 / real (card A)
              in  Finite_Set.fold (\<lambda>x. Mapping.update x p) Mapping.empty A)"
proof -
  define p where "p = 1 / real (card A)"
  let ?m = "Finite_Set.fold (\<lambda>x. Mapping.update x p) Mapping.empty A"
  interpret comp_fun_idem "\<lambda>x. Mapping.update x p"
    by standard (transfer, force simp: fun_eq_iff)+
  have keys: "Mapping.keys ?m = A"
    using assms(2) by (induction A rule: finite_induct) simp_all
  have lookup: "Mapping.lookup ?m x = Some p" if "x \<in> A" for x
    using assms(2) that by (induction A rule: finite_induct) (auto simp: lookup_update')
  from keys lookup assms show ?thesis unfolding pmf_of_set_impl_def
    by (intro mapping_of_pmfI) (simp_all add: Let_def p_def)
qed

lemma pmf_of_set_impl_code [code]:
  "pmf_of_set_impl (set xs) =
    (if xs = [] then
         Code.abort (STR ''pmf_of_set of empty set'') (\<lambda>_. mapping_of_pmf (pmf_of_set (set xs)))
      else let xs' = remdups xs; p = 1 / real (length xs') in
         Mapping.tabulate xs' (\<lambda>_. p))"
  unfolding pmf_of_set_impl_def
  using pmf_of_set_code_aux[of "set xs" "remdups xs"] by (simp add: Let_def)

lemma pmf_of_set_code [code abstract]:
  "mapping_of_pmf (pmf_of_set A) = pmf_of_set_impl A"
  by (simp add: pmf_of_set_impl_def)

lemma pmf_of_multiset_pmf_of_mapping:
  assumes "A \<noteq> {#}" "set xs = set_mset A" "distinct xs"
  shows   "mapping_of_pmf (pmf_of_multiset A) = Mapping.tabulate xs (\<lambda>x. count A x / real (size A))"
  using assms by (intro mapping_of_pmfI) (auto simp: lookup_tabulate)

definition pmf_of_multiset_impl where
  "pmf_of_multiset_impl A = mapping_of_pmf (pmf_of_multiset A)"

lemma pmf_of_multiset_impl_code_alt:
  assumes "A \<noteq> {#}"
  shows   "pmf_of_multiset_impl A =
             (let p = 1 / real (size A)
              in  fold_mset (\<lambda>x. Mapping.map_default x 0 ((+) p)) Mapping.empty A)"
proof -
  define p where "p = 1 / real (size A)"
  interpret comp_fun_commute "\<lambda>x. Mapping.map_default x 0 ((+) p)"
    unfolding Mapping.map_default_def [abs_def]
    by (standard, intro mapping_eqI ext)
       (simp_all add: o_def lookup_map_entry' lookup_default' lookup_default_def)
  let ?m = "fold_mset (\<lambda>x. Mapping.map_default x 0 ((+) p)) Mapping.empty A"
  have keys: "Mapping.keys ?m = set_mset A" by (induction A) simp_all
  have lookup: "Mapping.lookup_default 0 ?m x = real (count A x) * p" for x
    by (induction A)
       (simp_all add: lookup_map_default' lookup_default_def lookup_empty ring_distribs)
  from keys lookup assms show ?thesis unfolding pmf_of_multiset_impl_def
    by (intro mapping_of_pmfI') (simp_all add: Let_def p_def)
qed

lemma pmf_of_multiset_impl_code [code]:
  "pmf_of_multiset_impl (mset xs) =
     (if xs = [] then
        Code.abort (STR ''pmf_of_multiset of empty multiset'')
          (\<lambda>_. mapping_of_pmf (pmf_of_multiset (mset xs)))
      else let xs' = remdups xs; p = 1 / real (length xs) in
         Mapping.tabulate xs' (\<lambda>x. real (count (mset xs) x) * p))"
  using pmf_of_multiset_pmf_of_mapping[of "mset xs" "remdups xs"]
  by (simp add: pmf_of_multiset_impl_def)

lemma pmf_of_multiset_code [code abstract]:
  "mapping_of_pmf (pmf_of_multiset A) = pmf_of_multiset_impl A"
  by (simp add: pmf_of_multiset_impl_def)

lemma bernoulli_pmf_code [code abstract]:
  "mapping_of_pmf (bernoulli_pmf p) =
     (if p \<le> 0 then Mapping.update False 1 Mapping.empty
      else if p \<ge> 1 then Mapping.update True 1 Mapping.empty
      else Mapping.update False (1 - p) (Mapping.update True p Mapping.empty))"
  by (intro mapping_of_pmfI) (auto simp: bernoulli_pmf.rep_eq lookup_update' set_pmf_eq)

lemma pmf_code [code]: "pmf p x = Mapping.lookup_default 0 (mapping_of_pmf p) x"
  unfolding mapping_of_pmf_def Mapping.lookup_default_def
  by (auto split: option.splits simp: id_def Mapping.lookup.abs_eq)

lemma set_pmf_code [code]: "set_pmf p = Mapping.keys (mapping_of_pmf p)"
  by transfer (auto simp: dom_def set_pmf_eq)

lemma keys_mapping_of_pmf [simp]: "Mapping.keys (mapping_of_pmf p) = set_pmf p"
  by transfer (auto simp: dom_def set_pmf_eq)

definition fold_combine_plus where
  "fold_combine_plus = comm_monoid_set.F (Mapping.combine ((+) :: real \<Rightarrow> _)) Mapping.empty"

context
begin

interpretation fold_combine_plus: combine_mapping_abel_semigroup "(+) :: real \<Rightarrow> _"
  by unfold_locales (simp_all add: add_ac)

qualified lemma lookup_default_fold_combine_plus:
  fixes A :: "'b set" and f :: "'b \<Rightarrow> ('a, real) mapping"
  assumes "finite A"
  shows   "Mapping.lookup_default 0 (fold_combine_plus f A) x =
             (\<Sum>y\<in>A. Mapping.lookup_default 0 (f y) x)"
  unfolding fold_combine_plus_def using assms
    by (induction A rule: finite_induct)
       (simp_all add: lookup_default_empty lookup_default_neutral_combine)

qualified lemma keys_fold_combine_plus:
  "finite A \<Longrightarrow> Mapping.keys (fold_combine_plus f A) = (\<Union>x\<in>A. Mapping.keys (f x))"
  by (simp add: fold_combine_plus_def fold_combine_plus.keys_fold_combine)

qualified lemma fold_combine_plus_code [code]:
  "fold_combine_plus g (set xs) = foldr (\<lambda>x. Mapping.combine (+) (g x)) (remdups xs) Mapping.empty"
  by (simp add: fold_combine_plus_def fold_combine_plus.fold_combine_code)

private lemma lookup_default_0_map_values:
  assumes "f x 0 = 0"
  shows   "Mapping.lookup_default 0 (Mapping.map_values f m) x = f x (Mapping.lookup_default 0 m x)"
  unfolding Mapping.lookup_default_def
  using assms by transfer (auto split: option.splits)

qualified lemma mapping_of_bind_pmf:
  assumes "finite (set_pmf p)"
  shows   "mapping_of_pmf (bind_pmf p f) =
             fold_combine_plus (\<lambda>x. Mapping.map_values (\<lambda>_. (*) (pmf p x))
               (mapping_of_pmf (f x))) (set_pmf p)"
  using assms
  by (intro mapping_of_pmfI')
     (auto simp: keys_fold_combine_plus lookup_default_fold_combine_plus
                 pmf_bind integral_measure_pmf lookup_default_0_map_values
                 lookup_default_mapping_of_pmf mult_ac)

lift_definition bind_pmf_aux :: "'a pmf \<Rightarrow> ('a \<Rightarrow> 'b pmf) \<Rightarrow> 'a set \<Rightarrow> ('b, real) mapping" is
  "\<lambda>(p :: 'a pmf) (f :: 'a \<Rightarrow> 'b pmf) (A::'a set) (x::'b).
     if x \<in> (\<Union>y\<in>A. set_pmf (f y)) then
       Some (measure_pmf.expectation p (\<lambda>y. indicator A y * pmf (f y) x))
     else None" .

lemma keys_bind_pmf_aux [simp]:
  "Mapping.keys (bind_pmf_aux p f A) = (\<Union>x\<in>A. set_pmf (f x))"
  by transfer (auto split: if_splits)

lemma lookup_default_bind_pmf_aux:
  "Mapping.lookup_default 0 (bind_pmf_aux p f A) x =
     (if x \<in> (\<Union>y\<in>A. set_pmf (f y)) then
        measure_pmf.expectation p (\<lambda>y. indicator A y * pmf (f y) x) else 0)"
  unfolding lookup_default_def by transfer' simp_all

lemma lookup_default_bind_pmf_aux' [simp]:
  "Mapping.lookup_default 0 (bind_pmf_aux p f (set_pmf p)) x = pmf (bind_pmf p f) x"
  unfolding lookup_default_def
  by transfer (auto simp: pmf_bind AE_measure_pmf_iff set_pmf_eq
                    intro!: integral_cong_AE integral_eq_zero_AE)

lemma bind_pmf_aux_correct:
  "mapping_of_pmf (bind_pmf p f) = bind_pmf_aux p f (set_pmf p)"
  by (intro mapping_of_pmfI') simp_all

lemma bind_pmf_aux_code_aux:
  assumes "finite A"
  shows   "bind_pmf_aux p f A =
             fold_combine_plus (\<lambda>x. Mapping.map_values (\<lambda>_. (*) (pmf p x))
               (mapping_of_pmf (f x))) A" (is "?lhs = ?rhs")
proof (intro mapping_eqI'[where d = 0])
  fix x assume "x \<in> Mapping.keys ?lhs"
  then obtain y where y: "y \<in> A" "x \<in> set_pmf (f y)" by auto
  hence "Mapping.lookup_default 0 ?lhs x =
           measure_pmf.expectation p (\<lambda>y. indicator A y * pmf (f y) x)"
    by (auto simp: lookup_default_bind_pmf_aux)
  also from assms have "\<dots> = (\<Sum>y\<in>A. pmf p y * pmf (f y) x)"
    by (subst integral_measure_pmf [of A])
       (auto simp: set_pmf_eq indicator_def mult_ac split: if_splits)
  also from assms have "\<dots> = Mapping.lookup_default 0 ?rhs x"
    by (simp add: lookup_default_fold_combine_plus lookup_default_0_map_values
          lookup_default_mapping_of_pmf)
  finally show "Mapping.lookup_default 0 ?lhs x = Mapping.lookup_default 0 ?rhs x" .
qed (insert assms, simp_all add: keys_fold_combine_plus)

lemma bind_pmf_aux_code [code]:
  "bind_pmf_aux p f (set xs) =
     fold_combine_plus (\<lambda>x. Mapping.map_values (\<lambda>_. (*) (pmf p x))
               (mapping_of_pmf (f x))) (set xs)"
  by (rule bind_pmf_aux_code_aux) simp_all

lemmas bind_pmf_code [code abstract] = bind_pmf_aux_correct

end

hide_const (open) fold_combine_plus

lift_definition cond_pmf_impl :: "'a pmf \<Rightarrow> 'a set \<Rightarrow> ('a, real) mapping option" is
  "\<lambda>p A. if A \<inter> set_pmf p = {} then None else
     Some (\<lambda>x. if x \<in> A \<inter> set_pmf p then Some (pmf p x / measure_pmf.prob p A) else None)" .

lemma cond_pmf_impl_code_alt:
  assumes "finite A"
  shows   "cond_pmf_impl p A = (
             let C = A \<inter> set_pmf p;
                 prob = (\<Sum>x\<in>C. pmf p x)
             in  if prob = 0 then
                   None
                 else
                   Some (Mapping.map_values (\<lambda>_ y. y / prob)
                     (Mapping.filter (\<lambda>k _. k \<in> C) (mapping_of_pmf p))))"
proof -
  define C where "C = A \<inter> set_pmf p"
  define prob where "prob = (\<Sum>x\<in>C. pmf p x)"
  also note C_def
  also from assms have "(\<Sum>x\<in>A \<inter> set_pmf p. pmf p x) = (\<Sum>x\<in>A. pmf p x)"
    by (intro sum.mono_neutral_left) (auto simp: set_pmf_eq)
  finally have prob1: "prob = (\<Sum>x\<in>A. pmf p x)" .
  hence prob2: "prob = measure_pmf.prob p A"
    using assms by (subst measure_measure_pmf_finite) simp_all
  have prob3: "prob = 0 \<longleftrightarrow> A \<inter> set_pmf p = {}"
    by (subst prob1, subst sum_nonneg_eq_0_iff) (auto simp: set_pmf_eq assms)
  from assms have prob4: "prob = measure_pmf.prob p C"
    unfolding prob_def by (intro measure_measure_pmf_finite [symmetric]) (simp_all add: C_def)

  show ?thesis
  proof (cases "prob = 0")
    case True
    hence "A \<inter> set_pmf p = {}" by (subst (asm) prob3)
    with True show ?thesis by (simp add: Let_def prob_def C_def cond_pmf_impl.abs_eq)
  next
    case False
    hence A: "C \<noteq> {}" unfolding C_def by (subst (asm) prob3) auto
    with prob3 have prob_nz: "prob \<noteq> 0" by (auto simp: C_def)
    fix x
    have "cond_pmf_impl p A =
            Some (mapping.Mapping (\<lambda>x. if x \<in> C then
              Some (pmf p x / measure_pmf.prob p C) else None))"
         (is "_ = Some ?m")
      using A prob2 prob4 unfolding C_def by transfer (auto simp: fun_eq_iff)
    also have "?m = Mapping.map_values (\<lambda>_ y. y / prob)
                 (Mapping.filter (\<lambda>k _. k \<in> C) (mapping_of_pmf p))"
      using prob_nz prob4 assms unfolding C_def
      by transfer (auto simp: fun_eq_iff set_pmf_eq)
    finally show ?thesis using False by (simp add: Let_def prob_def C_def)
  qed
qed

lemma cond_pmf_impl_code [code]:
  "cond_pmf_impl p (set xs) = (
     let C = set xs \<inter> set_pmf p;
         prob = (\<Sum>x\<in>C. pmf p x)
     in  if prob = 0 then
           None
         else
           Some (Mapping.map_values (\<lambda>_ y. y / prob)
             (Mapping.filter (\<lambda>k _. k \<in> C) (mapping_of_pmf p))))"
  by (rule cond_pmf_impl_code_alt) simp_all

lemma cond_pmf_code [code abstract]:
  "mapping_of_pmf (cond_pmf p A) =
     (case cond_pmf_impl p A of
        None \<Rightarrow> Code.abort (STR ''cond_pmf with set of probability 0'')
                  (\<lambda>_. mapping_of_pmf (cond_pmf p A))
      | Some m \<Rightarrow> m)"
proof (cases "cond_pmf_impl p A")
  case (Some m)
  hence A: "set_pmf p \<inter> A \<noteq> {}" by transfer (auto split: if_splits)
  from Some have B: "Mapping.keys m = set_pmf (cond_pmf p A)"
    by (subst set_cond_pmf[OF A], transfer) (auto split: if_splits)
  with Some A have "mapping_of_pmf (cond_pmf p A) = m"
    by (intro mapping_of_pmfI[OF _ B], transfer) (auto split: if_splits simp: pmf_cond)
  with Some show ?thesis by simp
qed simp_all

lemma binomial_pmf_code [code abstract]:
  "mapping_of_pmf (binomial_pmf n p) = (
     if p < 0 \<or> p > 1 then
       Code.abort (STR ''binomial_pmf with invalid probability'')
         (\<lambda>_. mapping_of_pmf (binomial_pmf n p))
     else if p = 0 then Mapping.update 0 1 Mapping.empty
     else if p = 1 then Mapping.update n 1 Mapping.empty
     else Mapping.tabulate [0..<Suc n] (\<lambda>k. real (n choose k) * p ^ k * (1 - p) ^ (n - k)))"
  by (cases "p < 0 \<or> p > 1")
     (simp, intro mapping_of_pmfI,
      auto simp: lookup_update' lookup_empty set_pmf_binomial_eq lookup_tabulate split: if_splits)

lemma pred_pmf_code [code]:
  "pred_pmf P p = (\<forall>x\<in>set_pmf p. P x)"
  by (auto simp: pred_pmf_def)

lemma mapping_of_pmf_pmf_of_list:
  assumes "\<And>x. x \<in> snd ` set xs \<Longrightarrow> x > 0" "sum_list (map snd xs) = 1"
  shows   "mapping_of_pmf (pmf_of_list xs) =
             Mapping.tabulate (remdups (map fst xs))
               (\<lambda>x. sum_list (map snd (filter (\<lambda>z. fst z = x) xs)))"
proof -
  from assms have wf: "pmf_of_list_wf xs" by (intro pmf_of_list_wfI) force
  with assms have "set_pmf (pmf_of_list xs) = fst ` set xs"
    by (intro set_pmf_of_list_eq) auto
  with wf show ?thesis
    by (intro mapping_of_pmfI) (auto simp: lookup_tabulate pmf_pmf_of_list)
qed

lemma mapping_of_pmf_pmf_of_list':
  assumes "pmf_of_list_wf xs"
  defines "xs' \<equiv> filter (\<lambda>z. snd z \<noteq> 0) xs"
  shows   "mapping_of_pmf (pmf_of_list xs) =
             Mapping.tabulate (remdups (map fst xs'))
               (\<lambda>x. sum_list (map snd (filter (\<lambda>z. fst z = x) xs')))" (is "_ = ?rhs")
proof -
  have wf: "pmf_of_list_wf xs'" unfolding xs'_def by (rule pmf_of_list_remove_zeros) fact
  have pos: "\<forall>x\<in>snd`set xs'. x > 0" using assms(1) unfolding xs'_def
    by (force simp: pmf_of_list_wf_def)
  from assms have "pmf_of_list xs = pmf_of_list xs'"
    unfolding xs'_def by (subst pmf_of_list_remove_zeros) simp_all
  also from wf pos have "mapping_of_pmf \<dots> = ?rhs"
    by (intro mapping_of_pmf_pmf_of_list) (auto simp: pmf_of_list_wf_def)
  finally show ?thesis .
qed

lemma pmf_of_list_wf_code [code]:
  "pmf_of_list_wf xs \<longleftrightarrow> list_all (\<lambda>z. snd z \<ge> 0) xs \<and> sum_list (map snd xs) = 1"
  by (auto simp add: pmf_of_list_wf_def list_all_def)

lemma pmf_of_list_code [code abstract]:
  "mapping_of_pmf (pmf_of_list xs) = (
     if pmf_of_list_wf xs then
       let xs' = filter (\<lambda>z. snd z \<noteq> 0) xs
       in  Mapping.tabulate (remdups (map fst xs'))
             (\<lambda>x. sum_list (map snd (filter (\<lambda>z. fst z = x) xs')))
     else
       Code.abort (STR ''Invalid list for pmf_of_list'') (\<lambda>_. mapping_of_pmf (pmf_of_list xs)))"
  using mapping_of_pmf_pmf_of_list'[of xs] by (simp add: Let_def)

lemma mapping_of_pmf_eq_iff [simp]:
  "mapping_of_pmf p = mapping_of_pmf q \<longleftrightarrow> p = (q :: 'a pmf)"
proof (transfer, intro iffI pmf_eqI)
  fix p q :: "'a pmf" and x :: 'a
  assume "(\<lambda>x. if pmf p x = 0 then None else Some (pmf p x)) =
            (\<lambda>x. if pmf q x = 0 then None else Some (pmf q x))"
  hence "(if pmf p x = 0 then None else Some (pmf p x)) =
           (if pmf q x = 0 then None else Some (pmf q x))" for x
    by (simp add: fun_eq_iff)
  from this[of x] show "pmf p x = pmf q x" by (auto split: if_splits)
qed (simp_all cong: if_cong)

subsection \<open>Code abbreviations for integrals and probabilities\<close>

text \<open>
  Integrals and probabilities are defined for general measures, so we cannot give any
  code equations directly. We can, however, specialise these constants them to PMFs,
  give code equations for these specialised constants, and tell the code generator
  to unfold the original constants to the specialised ones whenever possible.
\<close>

definition pmf_integral where
  "pmf_integral p f = lebesgue_integral (measure_pmf p) (f :: _ \<Rightarrow> real)"

definition pmf_set_integral where
  "pmf_set_integral p f A = lebesgue_integral (measure_pmf p) (\<lambda>x. indicator A x * f x :: real)"

definition pmf_prob where
  "pmf_prob p A = measure_pmf.prob p A"

lemma pmf_prob_compl: "pmf_prob p (-A) = 1 - pmf_prob p A"
  using measure_pmf.prob_compl[of A p] by (simp add: pmf_prob_def Compl_eq_Diff_UNIV)

lemma pmf_integral_pmf_set_integral [code]:
  "pmf_integral p f = pmf_set_integral p f (set_pmf p)"
  unfolding pmf_integral_def pmf_set_integral_def
  by (intro integral_cong_AE) (simp_all add: AE_measure_pmf_iff)

lemma pmf_prob_pmf_set_integral:
  "pmf_prob p A = pmf_set_integral p (\<lambda>_. 1) A"
  by (simp add: pmf_prob_def pmf_set_integral_def)

lemma pmf_set_integral_code_alt_finite:
  "finite A \<Longrightarrow> pmf_set_integral p f A = (\<Sum>x\<in>A. pmf p x * f x)"
  unfolding pmf_set_integral_def
  by (subst integral_measure_pmf[of A]) (auto simp: indicator_def mult_ac split: if_splits)

lemma pmf_set_integral_code [code]:
  "pmf_set_integral p f (set xs) = (\<Sum>x\<in>set xs. pmf p x * f x)"
  by (rule pmf_set_integral_code_alt_finite) simp_all

lemma pmf_prob_code_alt_finite:
  "finite A \<Longrightarrow> pmf_prob p A = (\<Sum>x\<in>A. pmf p x)"
  by (simp add: pmf_prob_pmf_set_integral pmf_set_integral_code_alt_finite)

lemma pmf_prob_code [code]:
  "pmf_prob p (set xs) = (\<Sum>x\<in>set xs. pmf p x)"
  "pmf_prob p (List.coset xs) = 1 - (\<Sum>x\<in>set xs. pmf p x)"
  by (simp_all add: pmf_prob_code_alt_finite pmf_prob_compl)

lemma pmf_prob_code_unfold [code_abbrev]: "pmf_prob p = measure_pmf.prob p"
  by (intro ext) (simp add: pmf_prob_def)

(* FIXME: Why does this not work without parameters? *)
lemma pmf_integral_code_unfold [code_abbrev]: "pmf_integral p = measure_pmf.expectation p"
  by (intro ext) (simp add: pmf_integral_def)

definition "pmf_of_alist xs = embed_pmf (\<lambda>x. case map_of xs x of Some p \<Rightarrow> p | None \<Rightarrow> 0)"

lemma pmf_of_mapping_Mapping [code_post]:
    "pmf_of_mapping (Mapping xs) = pmf_of_alist xs"
  unfolding pmf_of_mapping_def Mapping.lookup_default_def [abs_def] pmf_of_alist_def
  by transfer simp_all

instantiation pmf :: (equal) equal
begin

definition "equal_pmf p q = (mapping_of_pmf p = mapping_of_pmf (q :: 'a pmf))"

instance by standard (simp add: equal_pmf_def)
end

definition single :: "'a \<Rightarrow> 'a multiset" where
"single s = {#s#}"

instantiation pmf :: (random) random
begin

context
  includes state_combinator_syntax term_syntax
begin

definition
  pmfify :: "('b::typerep multiset \<times> (unit \<Rightarrow> Code_Evaluation.term)) \<Rightarrow>
             'b \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow>
             'b pmf \<times> (unit \<Rightarrow> Code_Evaluation.term)" where
  [code_unfold]: "pmfify A x =
    Code_Evaluation.valtermify pmf_of_multiset {\<cdot>}
      (Code_Evaluation.valtermify (+) {\<cdot>} A {\<cdot>}
       (Code_Evaluation.valtermify single {\<cdot>} x))"

definition
  "Quickcheck_Random.random i =
     Quickcheck_Random.random i \<circ>\<rightarrow> (\<lambda>A.
       Quickcheck_Random.random i \<circ>\<rightarrow> (\<lambda>x. Pair (pmfify A x)))"

instance ..

end

end

instantiation pmf :: (full_exhaustive) full_exhaustive
begin

definition full_exhaustive_pmf :: "('a pmf \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option) \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
where
  "full_exhaustive_pmf f i =
     Quickcheck_Exhaustive.full_exhaustive (\<lambda>A.
       Quickcheck_Exhaustive.full_exhaustive (\<lambda>x. f (pmfify A x)) i) i"

instance ..

end

end


section \<open> Incubator \<close>

theory Incubator
  imports "Z_Machines.Z_Machine"
begin

consts MAX_TEMP :: \<int>
consts MIN_TEMP :: \<int>

definition "TEMP = {MIN_TEMP..MAX_TEMP}"

def_consts
  MAX_TEMP = 30
  MIN_TEMP = 15

zstore IncubatorMonitor =
  temp :: \<int>
  where "MIN_TEMP \<le> temp" "temp \<le> MAX_TEMP"

zoperation Increment =
  over IncubatorMonitor
  pre "temp < MAX_TEMP"
  update "[temp\<Zprime> = temp + 1]"

lemma Increment_correct: "\<^bold>{IncubatorMonitor_inv\<^bold>} Increment() \<^bold>{IncubatorMonitor_inv\<^bold>}"
  by zpog_full

zoperation Decrement =
  over IncubatorMonitor
  pre "temp > MIN_TEMP" \<comment> \<open> Change to @{term "(temp \<ge> MIN_TEMP)\<^sub>e"} to break the invariant \<close>
  update "[temp\<Zprime> = temp - 1]"

lemma Decrement_correct: "\<^bold>{IncubatorMonitor_inv\<^bold>} Decrement() \<^bold>{IncubatorMonitor_inv\<^bold>}"
  by zpog_full

zoperation GetTemp =
  over IncubatorMonitor
  params currentTemp \<in> TEMP
  where "temp = currentTemp"

lemma GetTemp_correct: "\<^bold>{IncubatorMonitor_inv\<^bold>} GetTemp v \<^bold>{IncubatorMonitor_inv\<^bold>}"
  by zpog_full

zmachine Incubator =
  init "[temp \<leadsto> 20]"
  operations Increment Decrement GetTemp

animate Incubator

end


(*<*)
theory Blue_Eyes
  imports
    "HOL-Combinatorics.Transposition"
begin
(*>*)

section \<open>Introduction\<close>

text \<open>The original problem statement \<^cite>\<open>xkcd\<close> explains the puzzle well:

\begin{quotation}
A group of people with assorted eye colors live on an island.
They are all perfect logicians -- if a conclusion can be logically deduced,
they will do it instantly.
No one knows the color of their eyes.
Every night at midnight, a ferry stops at the island.
Any islanders who have figured out the color of their own eyes then leave the island, and the rest stay.
Everyone can see everyone else at all times
and keeps a count of the number of people they see with each eye color (excluding themselves),
but they cannot otherwise communicate.
Everyone on the island knows all the rules in this paragraph.

On this island there are 100 blue-eyed people,
100 brown-eyed people,
and the Guru (she happens to have green eyes).
So any given blue-eyed person can see 100 people with brown eyes and 99 people with blue eyes (and one with green),
but that does not tell him his own eye color;
as far as he knows the totals could be 101 brown and 99 blue.
Or 100 brown, 99 blue, and he could have red eyes.

The Guru is allowed to speak once (let's say at noon),
on one day in all their endless years on the island.
Standing before the islanders, she says the following:

``I can see someone who has blue eyes.''

Who leaves the island, and on what night?
\end{quotation}

It might seem weird that the Guru's declaration gives anyone any new information.
For an informal discussion, see \<^cite>\<open>\<open>Section~1.1\<close> in "fagin1995"\<close>.\<close>

section \<open>Modeling the world \label{sec:world}\<close>

text \<open>We begin by fixing two type variables: @{typ "'color"} and @{typ "'person"}.
The puzzle doesn't specify how many eye colors are possible, but four are mentioned.
Crucially, we must assume they are distinct. We specify the existence of colors other
than blue and brown, even though we don't mention them later, because when blue and brown
are the only possible colors, the puzzle has a different solution --- the brown-eyed logicians
may leave one day after the blue-eyed ones.

We refrain from specifying the exact population of the island, choosing to only assume
it is finite and denote a specific person as the Guru.

We could also model the Guru as an outside entity instead of a participant. This doesn't change
the answer and results in a slightly simpler proof, but is less faithful to the problem statement.\<close>

context
  fixes blue brown green red :: 'color
  assumes colors_distinct: "distinct [blue, brown, green, red]"

  fixes guru :: 'person
  assumes "finite (UNIV :: 'person set)"
begin

text \<open>It's slightly tricky to formalize the behavior of perfect logicians.
The representation we use is centered around the type of a @{emph \<open>world\<close>},
which describes the entire state of the environment. In our case, it's a function
@{typ "'person => 'color"} that assigns an eye color to everyone.@{footnote \<open>We would introduce
a type synonym, but at the time of writing Isabelle doesn't support including type variables fixed
by a locale in a type synonym.\<close>}

The only condition known to everyone and not dependent on the observer is Guru's declaration:\<close>

definition valid :: "('person \<Rightarrow> 'color) \<Rightarrow> bool" where
  "valid w \<longleftrightarrow> (\<exists>p. p \<noteq> guru \<and> w p = blue)"

text \<open>We then define the function @{term "possible n p w w'"}, which returns @{term True}
if on day \<open>n\<close> the potential world \<open>w'\<close> is plausible from the perspective of person \<open>p\<close>,
based on the observations they made in the actual world \<open>w\<close>.

Then, @{term "leaves n p w"} is @{term True} if \<open>p\<close> is able to unambiguously deduce
the color of their own eyes, i.e. if it is the same in all possible worlds. Note that if \<open>p\<close> actually
left many moons ago, this function still returns @{term True}.\<close>

fun leaves :: "nat \<Rightarrow> 'person \<Rightarrow> ('person \<Rightarrow> 'color) \<Rightarrow> bool"
  and possible :: "nat \<Rightarrow> 'person \<Rightarrow> ('person \<Rightarrow> 'color) \<Rightarrow> ('person \<Rightarrow> 'color) \<Rightarrow> bool"
  where
    "leaves n p w = (\<forall>w'. possible n p w w' \<longrightarrow> w' p = w p)" |
    "possible n p w w' \<longleftrightarrow> valid w \<and> valid w'
    \<and> (\<forall>p' \<noteq> p. w p' = w' p')
    \<and> (\<forall>n' < n. \<forall>p'. leaves n' p' w = leaves n' p' w')"

text \<open>Naturally, the act of someone leaving can be observed by others, thus the two definitions
are mutually recursive. As such, we need to instruct the simplifier to not unfold these definitions endlessly.\<close>
declare possible.simps[simp del] leaves.simps[simp del]

text \<open>A world is possible if
  \<^enum> The Guru's declaration holds.
  \<^enum> The eye color of everyone but the observer matches.
  \<^enum> The same people left on each of the previous days.

Moreover, we require that the actual world \<open>w\<close> is \<open>valid\<close>, so that the relation is symmetric:\<close>

lemma possible_sym: "possible n p w w' = possible n p w' w"
  by (auto simp: possible.simps)

text \<open>In fact, \<open>possible n p\<close> is an equivalence relation:\<close>

lemma possible_refl: "valid w \<Longrightarrow> possible n p w w"
  by (auto simp: possible.simps)

section \<open>Eye colors other than blue\<close>

text \<open>Since there is no way to distinguish between the colors other than blue,
only the blue-eyed people will ever leave. To formalize this notion, we define
a function that takes a world and replaces the eye color of a specified person.
The original color is specified too, so that the transformation composes nicely
with the recursive hypothetical worlds of @{const possible}.\<close>

definition try_swap :: "'person \<Rightarrow> 'color \<Rightarrow> 'color \<Rightarrow> ('person \<Rightarrow> 'color) \<Rightarrow> ('person \<Rightarrow> 'color)" where
  "try_swap p c\<^sub>1 c\<^sub>2 w x = (if c\<^sub>1 = blue \<or> c\<^sub>2 = blue \<or> x \<noteq> p then w x else transpose c\<^sub>1 c\<^sub>2 (w x))"

lemma try_swap_valid[simp]: "valid (try_swap p c\<^sub>1 c\<^sub>2 w) = valid w"
  by (cases \<open>c\<^sub>1 = blue\<close>; cases \<open>c\<^sub>2 = blue\<close>)
    (auto simp add: try_swap_def valid_def transpose_eq_iff)

lemma try_swap_eq[simp]: "try_swap p c\<^sub>1 c\<^sub>2 w x = try_swap p c\<^sub>1 c\<^sub>2 w' x \<longleftrightarrow> w x = w' x"
  by (auto simp add: try_swap_def transpose_eq_iff)

lemma try_swap_inv[simp]: "try_swap p c\<^sub>1 c\<^sub>2 (try_swap p c\<^sub>1 c\<^sub>2 w) = w"
  by (rule ext) (auto simp add: try_swap_def swap_id_eq)

lemma leaves_try_swap[simp]:
  assumes "valid w"
  shows "leaves n p (try_swap p' c\<^sub>1 c\<^sub>2 w) = leaves n p w"
  using assms
proof (induction n arbitrary: p w rule: less_induct)
  case (less n)
  have "leaves n p w" if "leaves n p (try_swap p' c\<^sub>1 c\<^sub>2 w)" for w
  proof (unfold leaves.simps; rule+)
    fix w'
    assume "possible n p w w'"
    then have "possible n p (try_swap p' c\<^sub>1 c\<^sub>2 w) (try_swap p' c\<^sub>1 c\<^sub>2 w')"
      by (fastforce simp: possible.simps less.IH)
    with \<open>leaves n p (try_swap p' c\<^sub>1 c\<^sub>2 w)\<close> have "try_swap p' c\<^sub>1 c\<^sub>2 w' p = try_swap p' c\<^sub>1 c\<^sub>2 w p"
      unfolding leaves.simps
      by simp
    thus "w' p = w p" by simp
  qed

  with try_swap_inv show ?case by auto
qed

text \<open>This lets us prove that only blue-eyed people will ever leave the island.\<close>

proposition only_blue_eyes_leave:
  assumes "leaves n p w" and "valid w"
  shows "w p = blue"
proof (rule ccontr)
  assume "w p \<noteq> blue"
  then obtain c where c: "w p \<noteq> c"  "c \<noteq> blue"
    using colors_distinct
    by (metis distinct_length_2_or_more)

  let ?w' = "try_swap p (w p) c w"
  have "possible n p w ?w'"
    using \<open>valid w\<close> apply (simp add: possible.simps)
    by (auto simp: try_swap_def)
  moreover have "?w' p \<noteq> w p"
    using c \<open>w p \<noteq> blue\<close> by (auto simp: try_swap_def)
  ultimately have "\<not> leaves n p w"
    by (auto simp: leaves.simps)
  with assms show False by simp
qed

section "The blue-eyed logicians"

text \<open>We will now consider the behavior of the logicians with blue eyes. First,
some simple lemmas. Reasoning about set cardinalities often requires considering infinite
sets separately. Usefully, all sets of people are finite by assumption.\<close>

lemma people_finite[simp]: "finite (S::'person set)"
proof (rule finite_subset)
  show "S \<subseteq> UNIV" by auto
  show "finite (UNIV::'person set)" by fact
qed

text \<open>Secondly, we prove a destruction rule for @{const possible}. It is strictly weaker than
the definition, but thanks to the simpler form, it's easier to guide the automation with it.\<close>
lemma possibleD_colors:
  assumes "possible n p w w'" and "p' \<noteq> p"
  shows "w' p' = w p'"
  using assms unfolding possible.simps by simp

text \<open>A central concept in the reasoning is the set of blue-eyed people someone can see.\<close>
definition blues_seen :: "('person \<Rightarrow> 'color) \<Rightarrow> 'person \<Rightarrow> 'person set" where
  "blues_seen w p = {p'. w p' = blue} - {p}"

lemma blues_seen_others:
  assumes "w p' = blue" and "p \<noteq> p'"
  shows "w p = blue \<Longrightarrow> card (blues_seen w p) = card (blues_seen w p')"
    and "w p \<noteq> blue \<Longrightarrow> card (blues_seen w p) = Suc (card (blues_seen w p'))"
proof -
  assume "w p = blue"
  then have "blues_seen w p' = blues_seen w p \<union> {p} - {p'}"
    by (auto simp add: blues_seen_def)
  moreover have "p \<notin> blues_seen w p"
    unfolding blues_seen_def by auto
  moreover have "p' \<in> blues_seen w p \<union> {p}"
    unfolding blues_seen_def using \<open>p \<noteq> p'\<close> \<open>w p' = blue\<close> by auto
  ultimately show "card (blues_seen w p) = card (blues_seen w p')"
    by simp
next
  assume "w p \<noteq> blue"
  then have "blues_seen w p' = blues_seen w p - {p'}"
    by (auto simp add: blues_seen_def)
  moreover have "p' \<in> blues_seen w p"
    unfolding blues_seen_def using \<open>p \<noteq> p'\<close> \<open>w p' = blue\<close> by auto
  ultimately show "card (blues_seen w p) = Suc (card (blues_seen w p'))"
    by (simp only: card_Suc_Diff1 people_finite)
qed

lemma possible_blues_seen:
  assumes "possible n p w w'"
  assumes "w p' = blue" and "p \<noteq> p'"
  shows "w' p = blue \<Longrightarrow> card (blues_seen w p) = card (blues_seen w' p')"
    and "w' p \<noteq> blue \<Longrightarrow> card (blues_seen w p) = Suc (card (blues_seen w' p'))"
  using possibleD_colors[OF \<open>possible n p w w'\<close>] and blues_seen_others assms
  by (auto simp flip: blues_seen_same)

text \<open>Finally, the crux of the solution. We proceed by strong induction.\<close>

lemma blue_leaves:
  assumes "w p = blue" and "valid w"
    and guru: "w guru \<noteq> blue"
  shows "leaves n p w \<longleftrightarrow> n \<ge> card (blues_seen w p)"
  using assms
proof (induction n arbitrary: p w rule: less_induct)
  case (less n)
  show ?case
  proof
    \<comment> \<open>First, we show that day \<open>n\<close> is sufficient to deduce that the eyes are blue.\<close>
    assume "n \<ge> card (blues_seen w p)"
    have "w' p = blue" if "possible n p w w'" for w'
    proof (cases "card (blues_seen w' p)")
      case 0
      moreover from \<open>possible n p w w'\<close> have "valid w'"
        by (simp add: possible.simps)
      ultimately show "w' p = blue"
        unfolding valid_def blues_seen_def by auto
    next
      case (Suc k)
      \<comment> \<open>We consider the behavior of somebody else, who also has blue eyes.\<close>
      then have "blues_seen w' p \<noteq> {}"
        by auto
      then obtain p' where "w' p' = blue" and "p \<noteq> p'"
        unfolding blues_seen_def by auto
      then have "w p' = blue"
        using possibleD_colors[OF \<open>possible n p w w'\<close>] by simp

      have "p \<noteq> guru"
        using \<open>w p = blue\<close> and \<open>w guru \<noteq> blue\<close> by auto
      hence "w' guru \<noteq> blue"
        using \<open>w guru \<noteq> blue\<close> and possibleD_colors[OF \<open>possible n p w w'\<close>] by simp

      have "valid w'"
        using \<open>possible n p w w'\<close> unfolding possible.simps by simp

      show "w' p = blue"
      proof (rule ccontr)
        assume "w' p \<noteq> blue"
        \<comment> \<open>If our eyes weren't blue, then \<open>p'\<close> would see one blue-eyed person less than us.\<close>
        with possible_blues_seen[OF \<open>possible n p w w'\<close> \<open>w p' = blue\<close> \<open>p \<noteq> p'\<close>]
        have *: "card (blues_seen w p) = Suc (card (blues_seen w' p'))"
          by simp
        \<comment> \<open>By induction, they would've left on day \<open>k = blues_seen w' p'\<close>.\<close>
        let ?k = "card (blues_seen w' p')"
        have "?k < n"
          using \<open>n \<ge> card (blues_seen w p)\<close> and * by simp
        hence "leaves ?k p' w'"
          using \<open>valid w'\<close> \<open>w' p' = blue\<close> \<open>w' guru \<noteq> blue\<close>
          by (intro less.IH[THEN iffD2]; auto)
        \<comment> \<open>However, we know that actually, \<open>p'\<close> didn't leave that day yet.\<close>
        moreover have "\<not> leaves ?k p' w"
        proof
          assume "leaves ?k p' w"
          then have "?k \<ge> card (blues_seen w p')"
            using \<open>?k < n\<close> \<open>w p' = blue\<close> \<open>valid w\<close> \<open>w guru \<noteq> blue\<close>
            by (intro less.IH[THEN iffD1]; auto)

          have "card (blues_seen w p) = card (blues_seen w p')"
            by (intro blues_seen_others; fact)
          with * have "?k < card (blues_seen w p')"
            by simp
          with \<open>?k \<ge> card (blues_seen w p')\<close> show False by simp
        qed
        moreover have "leaves ?k p' w' = leaves ?k p' w"
          using \<open>possible n p w w'\<close> \<open>?k < n\<close>
          unfolding possible.simps by simp
        ultimately show False by simp
      qed
    qed
    thus "leaves n p w"
      unfolding leaves.simps using \<open>w p = blue\<close> by simp
  next
    \<comment> \<open>Then, we show that it's not possible to deduce the eye color any earlier.\<close>
    {
      assume "n < card (blues_seen w p)"
      \<comment> \<open>Consider a hypothetical world where \<open>p\<close> has brown eyes instead. We will prove that this
        world is \<open>possible\<close>.\<close>
      let ?w' = "w(p := brown)"
      have "?w' guru \<noteq> blue"
        using \<open>w guru \<noteq> blue\<close> \<open>w p = blue\<close>
        by auto
      have "valid ?w'"
      proof -
        from \<open>n < card (blues_seen w p)\<close> have "card (blues_seen w p) \<noteq> 0" by auto
        hence "blues_seen w p \<noteq> {}"
          by auto
        then obtain p' where "p' \<in> blues_seen w p"
          by auto
        hence "p \<noteq> p'" and "w p' = blue"
          by (auto simp: blues_seen_def)
        hence "?w' p' = blue" by auto
        with \<open>?w' guru \<noteq> blue\<close> show "valid ?w'"
          unfolding valid_def by auto
      qed
      moreover have "leaves n' p' w = leaves n' p' ?w'" if "n' < n" for n' p'
      proof -
        have not_leavesI: "\<not>leaves n' p' w'"
          if "valid w'"  "w' guru \<noteq> blue" and P: "w' p' = blue \<Longrightarrow> n' < card (blues_seen w' p')" for w'
        proof (cases "w' p' = blue")
          case True
          then have "leaves n' p' w' \<longleftrightarrow> n' \<ge> card (blues_seen w' p')"
            using less.IH \<open>n' < n\<close> \<open>valid w'\<close> \<open>w' guru \<noteq> blue\<close>
            by simp
          with P[OF \<open>w' p' = blue\<close>] show "\<not>leaves n' p' w'" by simp
        next
          case False
          then show "\<not> leaves n' p' w'"
            using only_blue_eyes_leave \<open>valid w'\<close> by auto
        qed

        have "\<not>leaves n' p' w"
        proof (intro not_leavesI)
          assume "w p' = blue"
          with \<open>w p = blue\<close> have "card (blues_seen w p) = card (blues_seen w p')"
            apply (cases "p = p'", simp)
            by (intro blues_seen_others; auto)
          with \<open>n' < n\<close> and \<open>n < card (blues_seen w p)\<close> show "n' < card (blues_seen w p')"
            by simp
        qed fact+

        moreover have "\<not> leaves n' p' ?w'"
        proof (intro not_leavesI)
          assume "?w' p' = blue"
          with colors_distinct have "p \<noteq> p'" and "?w' p \<noteq> blue" by auto
          hence "card (blues_seen ?w' p) = Suc (card (blues_seen ?w' p'))"
            using \<open>?w' p' = blue\<close>
            by (intro blues_seen_others; auto)
          moreover have "blues_seen w p = blues_seen ?w' p"
            unfolding blues_seen_def by auto
          ultimately show "n' < card (blues_seen ?w' p')"
            using \<open>n' < n\<close> and \<open>n < card (blues_seen w p)\<close>
            by auto
        qed fact+

        ultimately show "leaves n' p' w = leaves n' p' ?w'" by simp
      qed
      ultimately have "possible n p w ?w'"
        using \<open>valid w\<close>
        by (auto simp: possible.simps)
      moreover have "?w' p \<noteq> blue"
        using colors_distinct by auto
      ultimately have "\<not> leaves n p w"
        unfolding leaves.simps
        using \<open>w p = blue\<close> by blast
    }
    then show "leaves n p w \<Longrightarrow> n \<ge> card (blues_seen w p)"
      by fastforce
  qed
qed

text \<open>This can be combined into a theorem that describes the behavior of the logicians based
on the objective count of blue-eyed people, and not the count by a specific person. The xkcd
puzzle is the instance where \<open>n = 99\<close>.\<close>

theorem blue_eyes:
  assumes "card {p. w p = blue} = Suc n" and "valid w" and "w guru \<noteq> blue"
  shows "leaves k p w \<longleftrightarrow> w p = blue \<and> k \<ge> n"
proof (cases "w p = blue")
  case True
  with assms have "card (blues_seen w p) = n"
    unfolding blues_seen_def by simp
  then show ?thesis
    using \<open>w p = blue\<close> \<open>valid w\<close> \<open>w guru \<noteq> blue\<close> blue_leaves
    by simp
next
  case False
  then show ?thesis
    using only_blue_eyes_leave \<open>valid w\<close> by auto
qed

end

(*<*)
end
(*>*)

section \<open>Future work\<close>

text \<open>After completing this formalization, I have been made aware of epistemic logic.
The @{emph \<open>possible worlds\<close>} model in \cref{sec:world} turns out to be quite similar
to the usual semantics of this logic. It might be interesting to solve this puzzle within
the axiom system of epistemic logic, without explicit reasoning about possible worlds.\<close>


theory Directed_Products
  imports QuotRing

begin

section \<open>Directed Products\<close>

subsection \<open>Definitions\<close>

definition product_group :: "'a set \<Rightarrow> ('a \<Rightarrow> ('b, 'c) monoid_scheme) \<Rightarrow> ('a \<Rightarrow> 'b) monoid"
  where "product_group I G \<equiv>
           \<lparr> carrier = (\<Pi>\<^sub>E i\<in>I. carrier (G i)),
                mult = (\<lambda>x y. (\<lambda>i\<in>I. mult (G i) (x i) (y i))),
                 one = (\<lambda>i\<in>I. \<one>\<^bsub>G i\<^esub>) \<rparr>"

definition product_ring :: "'a set \<Rightarrow> ('a \<Rightarrow> ('b, 'c) ring_scheme) \<Rightarrow> ('a \<Rightarrow> 'b) ring"
  where "product_ring I R \<equiv> monoid.extend (product_group I R)
           \<lparr> zero = one (product_group I (add_monoid \<circ> R)),
              add = mult (product_group I (add_monoid \<circ> R)) \<rparr>"

definition RDirProd :: "('a, 'n) ring_scheme \<Rightarrow> ('b, 'm) ring_scheme \<Rightarrow> ('a \<times> 'b) ring"
  where "RDirProd R S = monoid.extend (R \<times>\<times> S)
           \<lparr> zero = one ((add_monoid R) \<times>\<times> (add_monoid S)),
              add = mult ((add_monoid R) \<times>\<times> (add_monoid S)) \<rparr>"

subsection \<open>Basic Properties\<close>

text \<open>Usual unfolding lemmas : useful for unfolding one field at a time.\<close>

lemma product_group_fields:
  "carrier (product_group I G) = (\<Pi>\<^sub>E i\<in>I. carrier (G i))"
  "mult    (product_group I G) = (\<lambda>x y. (\<lambda>i\<in>I. mult (G i) (x i) (y i)))"
  "one     (product_group I G) = (\<lambda>i\<in>I. \<one>\<^bsub>G i\<^esub>)"
  unfolding product_group_def by simp+

lemma product_ring_fields:
  "carrier (product_ring I R) = (\<Pi>\<^sub>E i\<in>I. carrier (R i))"
  "mult    (product_ring I R) = (\<lambda>x y. (\<lambda>i\<in>I. mult (R i) (x i) (y i)))"
  "one     (product_ring I R) = (\<lambda>i\<in>I. \<one>\<^bsub>R i\<^esub>)"
  "add     (product_ring I R) = (\<lambda>x y. (\<lambda>i\<in>I. add (R i) (x i) (y i)))"
  "zero    (product_ring I R) = (\<lambda>i\<in>I. \<zero>\<^bsub>R i\<^esub>)"
  unfolding product_ring_def product_group_def by (simp add: monoid.defs)+

lemma RDirProd_fields:
  "carrier (RDirProd R S) = carrier R \<times> carrier S"
  "mult    (RDirProd R S) = (\<lambda>(r, s) (r', s'). (r \<otimes>\<^bsub>R\<^esub> r', s \<otimes>\<^bsub>S\<^esub> s'))"
  "one     (RDirProd R S) = (\<one>\<^bsub>R\<^esub>, \<one>\<^bsub>S\<^esub>)"
  "add     (RDirProd R S) = (\<lambda>(r, s) (r', s'). (r \<oplus>\<^bsub>R\<^esub> r', s \<oplus>\<^bsub>S\<^esub> s'))"
  "zero    (RDirProd R S) = (\<zero>\<^bsub>R\<^esub>, \<zero>\<^bsub>S\<^esub>)"
  unfolding RDirProd_def DirProd_def by (simp add: monoid.defs)+

lemma product_ring_truncate:
  shows "monoid.truncate (product_ring I R) = product_group I R"
  unfolding product_ring_def by (simp add: monoid.defs)

lemma product_ring_add_monoid:
  shows "add_monoid (product_ring I R) = product_group I (add_monoid \<circ> R)"
  unfolding product_group_def product_ring_def by (simp add: monoid.defs)

lemma RDirProd_truncate:
  shows "monoid.truncate (RDirProd R S) = R \<times>\<times> S"
  unfolding RDirProd_def by (simp add: monoid.defs)

lemma RDirProd_add_monoid [simp]:
  shows "add_monoid (RDirProd R S) = (add_monoid R) \<times>\<times> (add_monoid S)"
  by (simp add: RDirProd_def monoid.defs)

subsection \<open>Morphisms\<close>

lemma RDirProd_iso1:
  "(\<lambda>(x, y). (y, x)) \<in> ring_iso (RDirProd R S) (RDirProd S R)"
  unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def
  by (auto simp add: RDirProd_def DirProd_def monoid.defs)

lemma RDirProd_iso2:
  "(\<lambda>(x, (y, z)). ((x, y), z)) \<in> ring_iso (RDirProd R (RDirProd S T)) (RDirProd (RDirProd R S) T)"
  unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def
  by (auto simp add: image_iff RDirProd_def DirProd_def monoid.defs)

lemma RDirProd_iso3:
  "(\<lambda>((x, y), z). (x, (y, z))) \<in> ring_iso (RDirProd (RDirProd R S) T) (RDirProd R (RDirProd S T))"
  unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def
  by (auto simp add: image_iff RDirProd_def DirProd_def monoid.defs)

lemma RDirProd_iso4:
  assumes "f \<in> ring_iso R S" shows "(\<lambda>(r, t). (f r, t)) \<in> ring_iso (RDirProd R T) (RDirProd S T)"
  using assms unfolding ring_iso_def ring_hom_def bij_betw_def inj_on_def
  by (auto simp add: image_iff RDirProd_def DirProd_def monoid.defs)+

lemma RDirProd_iso5:
  assumes "f \<in> ring_iso S T" shows "(\<lambda>(r, s). (r, f s)) \<in> ring_iso (RDirProd R S) (RDirProd R T)"
  using ring_iso_set_trans[OF ring_iso_set_trans[OF RDirProd_iso1 RDirProd_iso4[OF assms]] RDirProd_iso1]
  by (simp add: case_prod_unfold comp_def)

lemma RDirProd_iso6:
  assumes "f \<in> ring_iso R R'" and "g \<in> ring_iso S S'"
  shows "(\<lambda>(r, s). (f r, g s)) \<in> ring_iso (RDirProd R S) (RDirProd R' S')"
  using ring_iso_set_trans[OF RDirProd_iso4[OF assms(1)] RDirProd_iso5[OF assms(2)]]
  by (simp add: case_prod_beta' comp_def)

lemma RDirProd_hom1:
  shows "(\<lambda>a. (a, a)) \<in> ring_hom R (RDirProd R R)"
  by (auto simp add: ring_hom_def RDirProd_def DirProd_def monoid.defs)

lemma RDirProd_hom2:
  assumes "f \<in> ring_hom S T"
  shows "(\<lambda>(x, y). (x, f y)) \<in> ring_hom (RDirProd R S) (RDirProd R T)"
    and "(\<lambda>(x, y). (f x, y)) \<in> ring_hom (RDirProd S R) (RDirProd T R)"
  using assms by (auto simp add: ring_hom_def RDirProd_def DirProd_def monoid.defs)

lemma RDirProd_hom3:
  assumes "f \<in> ring_hom R R'" and "g \<in> ring_hom S S'"
  shows "(\<lambda>(r, s). (f r, g s)) \<in> ring_hom (RDirProd R S) (RDirProd R' S')"
  using ring_hom_trans[OF RDirProd_hom2(2)[OF assms(1)] RDirProd_hom2(1)[OF assms(2)]]
  by (simp add: case_prod_beta' comp_def)

lemma RDirProd_proj1:
  shows "fst \<in> ring_hom (RDirProd R S) R"
  by (auto simp add: ring_hom_def RDirProd_def DirProd_def monoid.defs)

lemma RDirProd_proj2:
  shows "snd \<in> ring_hom (RDirProd R S) S"
  by (auto simp add: ring_hom_def RDirProd_def DirProd_def monoid.defs)

lemma RDirProd_cartesian:
  assumes "f \<in> ring_hom X R" and "g \<in> ring_hom X S"
  shows "(\<lambda>x. (f x, g x)) \<in> ring_hom X (RDirProd R S)"
  using assms by (auto simp add: ring_hom_def RDirProd_def DirProd_def monoid.defs)

(* Move --------------------------------------------------------------------- *)
lemma DirProd_proj1:
  shows "fst \<in> hom (G \<times>\<times> H) G"
  by (auto simp add: hom_def DirProd_def)

lemma DirProd_proj2:
  shows "snd \<in> hom (G \<times>\<times> H) H"
  by (auto simp add: hom_def DirProd_def)

lemma DirProd_cartesian:
  assumes "f \<in> hom X G" and "g \<in> hom X H"
  shows "(\<lambda>x. (f x, g x)) \<in> hom X (G \<times>\<times> H)"
  using assms by (auto simp add: hom_def DirProd_def)
(* -------------------------------------------------------------------------- *)

(* Rename / Move ------------------------------------------------------------ *)
lemma Times_singleton:
  "bij_betw (\<lambda>a. (a, b)) A (A \<times> { b })"
  by (intro bij_betwI', auto)

lemma bij_betw_Times_Pi:
  shows "bij_betw (\<lambda>(a, b). \<lambda>i. if i then a else b) (A \<times> B) (\<Pi> i\<in>UNIV. if i then A else B)"
  by (intro bij_betwI', auto simp add: Pi_iff) (metis)+

lemma bij_betw_Times_PiE:
  shows "bij_betw (\<lambda>(a, b). \<lambda>i. if i then a else b) (A \<times> B) (\<Pi>\<^sub>E i\<in>UNIV. if i then A else B)"
  by (simp add: bij_betw_Times_Pi PiE_UNIV_domain)

lemma bij_betw_Pi_Times:
  shows "bij_betw (\<lambda>f. (f True, f False)) (\<Pi> i\<in>UNIV. if i then A else B) (A \<times> B)"
proof (intro iffD1[OF bij_betw_cong[OF inv_into_f_eq[OF bij_betw_imp_inj_on[OF bij_betw_Times_Pi]]]
                      bij_betw_inv_into[OF bij_betw_Times_Pi]], auto)
  show "f True \<in> A" and "f False \<in> B" if "f \<in> (\<Pi> i\<in>UNIV. if i then A else B)" for f
    using Pi_mem[OF that, of True] Pi_mem[OF that, of False] by simp+
qed

lemma bij_betw_PiE_Times:
  shows "bij_betw (\<lambda>f. (f True, f False)) (\<Pi>\<^sub>E i\<in>UNIV. if i then A else B) (A \<times> B)"
  by (simp add: bij_betw_Pi_Times PiE_UNIV_domain)

lemma bij_combinator: (* named in accordance with the lemma 'inj_combinator' *)
  assumes "i \<notin> I"
  shows "bij_betw (\<lambda>(a, f). f(i := a)) (A i \<times> (\<Pi>\<^sub>E j\<in>I. A j)) (\<Pi>\<^sub>E j\<in>(insert i I). A j)"
  by (intro bij_betw_imageI[OF inj_combinator[OF assms] sym[OF PiE_insert_eq]])

lemma bij_combinator':
  assumes "i \<notin> I"
  shows "bij_betw (\<lambda>f. (f i, f(i := undefined))) (\<Pi>\<^sub>E j\<in>(insert i I). A j) (A i \<times> (\<Pi>\<^sub>E j\<in>I. A j))"
  using bij_betw_imp_inj_on[OF bij_combinator[OF assms]]
  by (intro iffD1[OF bij_betw_cong[OF inv_into_f_eq]
                        bij_betw_inv_into[OF bij_combinator[OF assms]]])
     (auto simp add: assms)
(* -------------------------------------------------------------------------- *)

lemma product_group_iso1:
  shows "(\<lambda>(g, h). \<lambda>b. if b then g else h) \<in>
          iso (G \<times>\<times> H) (product_group UNIV (\<lambda>b. if b then G else H))"
  unfolding iso_def hom_def product_group_def
  using bij_betw_Times_PiE[of "carrier G" "carrier H"]
  by (auto, smt PiE_cong)

lemma product_group_iso2:
  shows "(\<lambda>f. (f True, f False)) \<in>
          iso (product_group UNIV (\<lambda>b. if b then G else H)) (G \<times>\<times> H)"
  unfolding iso_def hom_def product_group_def
  using bij_betw_PiE_Times[of "carrier G" "carrier H"]
  by (auto, smt PiE PiE_UNIV_domain UNIV_I PiE_cong)+

lemma product_group_iso3:
  assumes "i \<notin> I"
  shows "(\<lambda>(g, f). f(i := g)) \<in>
          iso ((G i) \<times>\<times> (product_group I G)) (product_group (insert i I) G)"
  unfolding iso_def hom_def product_group_def
  using bij_combinator[OF assms, of "\<lambda>i. carrier (G i)"]
  by (auto, meson PiE_E)

lemma product_group_iso4:
  assumes "i \<notin> I"
  shows "(\<lambda>f. (f i, f(i := undefined))) \<in>
          iso (product_group (insert i I) G) ((G i) \<times>\<times> (product_group I G))"
  unfolding iso_def hom_def product_group_def
  using bij_combinator'[OF assms, of "\<lambda>i. carrier (G i)"] assms
  by auto

lemma product_group_proj:
  assumes "i \<in> I" shows "(\<lambda>f. f i) \<in> hom (product_group I G) (G i)"
proof -
  have "fst \<circ> (\<lambda>f. (f i, f(i := undefined))) \<in> hom (product_group I G) (G i)"
    using product_group_iso4[of i "I - {i}" G] assms
    by (intro hom_trans[OF _ DirProd_proj1, where ?H1 = "product_group (I - {i}) G"])
       (auto simp add: iso_def insert_absorb[OF assms])
  thus ?thesis
    by (simp add: comp_def)
qed

lemma product_group_cartesian:
  assumes "h \<in> (\<Pi> i\<in>I. hom X (G i))" shows "(\<lambda>x. \<lambda>i\<in>I. (h i) x) \<in> hom X (product_group I G)"
  using Pi_mem[OF assms] unfolding product_group_fields(1,2) hom_def
  by fastforce

lemma product_ring_iso1:
  shows "(\<lambda>(r, s). \<lambda>b. if b then r else s) \<in>
          ring_iso (RDirProd R S) (product_ring UNIV (\<lambda>b. if b then R else S))"
  unfolding ring_iso_def ring_hom_def RDirProd_def product_ring_def product_group_def
  using bij_betw_Times_PiE[of "carrier R" "carrier S"]
  by (auto simp add: monoid.defs, smt PiE_cong)

lemma product_ring_iso2:
  shows "(\<lambda>f. (f True, f False)) \<in>
          ring_iso (product_ring UNIV (\<lambda>b. if b then R else S)) (RDirProd R S)"
  unfolding ring_iso_def ring_hom_def RDirProd_def product_ring_def product_group_def
  using bij_betw_PiE_Times[of "carrier R" "carrier S"]
  by (auto simp add: monoid.defs, smt PiE PiE_UNIV_domain UNIV_I PiE_cong)+

lemma product_ring_iso3:
  assumes "i \<notin> I"
  shows "(\<lambda>(r, f). f(i := r)) \<in>
          ring_iso (RDirProd (R i) (product_ring I R)) (product_ring (insert i I) R)"
  using bij_combinator[OF assms, of "\<lambda>i. carrier (R i)"]
  unfolding ring_iso_def ring_hom_def RDirProd_def
  by (auto simp add: product_ring_fields monoid.defs, meson PiE_E)

lemma product_ring_iso4:
  assumes "i \<notin> I"
  shows "(\<lambda>f. (f i, f(i := undefined))) \<in>
          ring_iso (product_ring (insert i I) R) (RDirProd (R i) (product_ring I R))"
  using bij_combinator'[OF assms, of "\<lambda>i. carrier (R i)"] assms
  unfolding ring_iso_def ring_hom_def RDirProd_def
  by (auto simp add: product_ring_fields monoid.defs)

lemma product_ring_proj:
  assumes "i \<in> I" shows "(\<lambda>f. f i) \<in> ring_hom (product_ring I R) (R i)"
proof -
  have "fst \<circ> (\<lambda>f. (f i, f(i := undefined))) \<in> ring_hom (product_ring I R) (R i)"
    using product_ring_iso4[of i "I - {i}" R] assms
    by (intro ring_hom_trans[OF _ RDirProd_proj1, where ?S1 = "product_ring (I - {i}) R"])
       (auto simp add: ring_iso_def insert_absorb[OF assms])
  thus ?thesis
    by (simp add: comp_def)
qed

lemma product_ring_cartesian:
  assumes "h \<in> (\<Pi> i\<in>I. ring_hom X (R i))" shows "(\<lambda>x. \<lambda>i\<in>I. (h i) x) \<in> ring_hom X (product_ring I R)"
  using Pi_mem[OF assms] unfolding product_ring_fields ring_hom_def
  by fastforce

subsection \<open>Algebraic Structure\<close>

(* Move --------------------------------------------------------------------- *)
lemma (in monoid) group_ByWitness:
  assumes "f \<in> carrier G \<rightarrow> carrier G" and "\<And>x. x \<in> carrier G \<Longrightarrow> f x \<otimes> x = \<one>"
  shows "group G" and "\<And>x. x \<in> carrier G \<Longrightarrow> inv x = f x"
proof -
  have "\<exists>y \<in> carrier G. y \<otimes> x = \<one>" if "x \<in> carrier G" for x
    using assms that by auto
  then interpret group G
    using groupI[of G] by (auto simp add: m_assoc)
  show "group G" and "\<And>x. x \<in> carrier G \<Longrightarrow> inv x = f x"
    using inv_equality[OF assms(2)] assms(1) is_group by fastforce+
qed
(* -------------------------------------------------------------------------- *)

lemma product_group_is_monoid:
  assumes "\<And>i. i \<in> I \<Longrightarrow> monoid (G i)" shows "monoid (product_group I G)"
proof (intro monoid.intro, simp_all add: product_group_def)
  show "(\<lambda>i. \<one>\<^bsub>G i\<^esub>) \<in> (\<Pi> i\<in>I. carrier (G i))"
    using monoid.one_closed[OF assms] by simp
next
  fix x y z
  assume x: "x \<in> (\<Pi>\<^sub>E i\<in>I. carrier (G i))"
     and y: "y \<in> (\<Pi>\<^sub>E i\<in>I. carrier (G i))"
     and z: "z \<in> (\<Pi>\<^sub>E i\<in>I. carrier (G i))"

  show "(\<lambda>i. x i \<otimes>\<^bsub>G i\<^esub> y i) \<in> (\<Pi> i\<in>I. carrier (G i))"
    using monoid.m_closed[OF assms[OF _] PiE_mem[OF x] PiE_mem[OF y]] by simp

  show "(\<lambda>i\<in>I. (if i \<in> I then x i \<otimes>\<^bsub>G i\<^esub> y i else undefined) \<otimes>\<^bsub>G i\<^esub> z i) =
        (\<lambda>i\<in>I. x i \<otimes>\<^bsub>G i\<^esub> (if i \<in> I then y i \<otimes>\<^bsub>G i\<^esub> z i else undefined))"
    using monoid.m_assoc[OF assms PiE_mem[OF x] PiE_mem[OF y] PiE_mem[OF z]]
    by (intro restrict_ext, simp)

  show "(\<lambda>i\<in>I. (if i \<in> I then \<one>\<^bsub>G i\<^esub> else undefined) \<otimes>\<^bsub>G i\<^esub> x i) = x"
   and "(\<lambda>i\<in>I. x i \<otimes>\<^bsub>G i\<^esub> (if i \<in> I then \<one>\<^bsub>G i\<^esub> else undefined)) = x"
    using restrict_ext[of I _ x] monoid.l_one[OF assms] monoid.r_one[OF assms] PiE_mem[OF x]
    unfolding PiE_restrict[OF x] by simp+
qed

lemma product_group_is_comm_monoid:
  assumes "\<And>i. i \<in> I \<Longrightarrow> comm_monoid (G i)" shows "comm_monoid (product_group I G)"
proof (intro comm_monoid.intro)
  show "monoid (product_group I G)"
    using product_group_is_monoid[of I G, OF comm_monoid.axioms(1)[OF assms]] .
next
  show "comm_monoid_axioms (product_group I G)"
    unfolding comm_monoid_axioms_def product_group_fields
    using restrict_ext comm_monoid.m_comm[OF assms] PiE_mem[of _ _ "\<lambda>i. carrier (G i)"] by auto
qed

lemma product_group_is_group:
  assumes "\<And>i. i \<in> I \<Longrightarrow> group (G i)"
  shows "group (product_group I G)"
    and "\<And>x. x \<in> carrier (product_group I G) \<Longrightarrow>
              inv\<^bsub>(product_group I G)\<^esub> x = (\<lambda>i\<in>I. inv\<^bsub>G i\<^esub> (x i))"
proof -
  let ?H = "product_group I G"
  let ?f = "\<lambda>x. (\<lambda>i\<in>I. inv\<^bsub>G i\<^esub> (x i))"

  have hyp1: "?f \<in> carrier ?H \<rightarrow> carrier ?H"
    using group.inv_closed[OF assms]
    by (simp add: PiE_iff product_group_fields(1))
  moreover have hyp2: "?f x \<otimes>\<^bsub>?H\<^esub> x = \<one>\<^bsub>?H\<^esub>" if "x \<in> carrier ?H" for x
    using group.r_inv[OF assms] group.l_inv[OF assms] that
    unfolding product_group_fields
    by (intro restrict_ext, simp add: PiE_iff)
  ultimately show "group ?H" and "\<And>x. x \<in> carrier ?H \<Longrightarrow> inv\<^bsub>?H\<^esub> x = (\<lambda>i\<in>I. inv\<^bsub>G i\<^esub> (x i))"
    using monoid.group_ByWitness[OF product_group_is_monoid[of I G, OF group.axioms(1)[OF assms]] hyp1 hyp2]
    by blast+
qed

lemma product_group_is_comm_group:
  assumes "\<And>i. i \<in> I \<Longrightarrow> comm_group (G i)" shows "comm_group (product_group I G)"
  using comm_group.intro[OF product_group_is_comm_monoid product_group_is_group(1)[of I G]]
        comm_group.axioms[OF assms]
  by simp

lemma product_ring_is_ring:
  assumes "\<And>i. i \<in> I \<Longrightarrow> ring (R i)" shows "ring (product_ring I R)"
proof (intro ring.intro)
  show "abelian_group (product_ring I R)"
    using product_group_is_comm_monoid[of I "add_monoid \<circ> R"]
          product_group_is_comm_group[of I "add_monoid \<circ> R"]
          abelian_group.axioms[OF ring.axioms(1)[OF assms]]
    unfolding abelian_group_def abelian_monoid_def
              abelian_group_axioms_def product_ring_add_monoid
    by simp
next
  have "monoid (monoid.truncate (product_ring I R))"
    using product_group_is_monoid[of I R, OF ring.axioms(2)[OF assms]]
    unfolding product_ring_truncate by simp
  thus "monoid (product_ring I R)"
    unfolding monoid_def by (auto simp add: monoid.defs)
next
  show "ring_axioms (product_ring I R)"
  proof (auto simp add: ring_axioms_def product_ring_fields(1))
    let ?S = "product_ring I R"

    fix x y z
    assume in_carrier:
      "x \<in> (\<Pi>\<^sub>E i\<in>I. carrier (R i))"
      "y \<in> (\<Pi>\<^sub>E i\<in>I. carrier (R i))"
      "z \<in> (\<Pi>\<^sub>E i\<in>I. carrier (R i))"

    show "(x \<oplus>\<^bsub>?S\<^esub> y) \<otimes>\<^bsub>?S\<^esub> z = x \<otimes>\<^bsub>?S\<^esub> z \<oplus>\<^bsub>?S\<^esub> y \<otimes>\<^bsub>?S\<^esub> z"
     and "z \<otimes>\<^bsub>?S\<^esub> (x \<oplus>\<^bsub>?S\<^esub> y) = z \<otimes>\<^bsub>?S\<^esub> x \<oplus>\<^bsub>?S\<^esub> z \<otimes>\<^bsub>?S\<^esub> y"
      using ring.ring_simprules(13, 23)[OF assms in_carrier[THEN PiE_mem]]
      unfolding product_ring_fields
      by (intro restrict_ext, auto)
  qed
qed

lemma product_ring_is_cring:
  assumes "\<And>i. i \<in> I \<Longrightarrow> cring (R i)" shows "cring (product_ring I R)"
proof (intro cring.intro)
  show "ring (product_ring I R)"
    using product_ring_is_ring[of I R, OF cring.axioms(1)[OF assms]] .
next
  have "comm_monoid (monoid.truncate (product_ring I R))"
    using product_group_is_comm_monoid[of I R, OF cring.axioms(2)[OF assms]]
    unfolding product_ring_truncate .
  thus "comm_monoid (product_ring I R)"
    unfolding comm_monoid_def comm_monoid_axioms_def monoid_def
    by (auto simp add: monoid.defs)
qed

text \<open>Remark : The following lemma can't be proven using the lemmas product_ring_iso2 and
      product_ring_is_ring, because the types of R and S are different.\<close>

lemma RDirProd_ring:
  assumes "ring R" and "ring S" shows "ring (RDirProd R S)"
proof -
  have "monoid (RDirProd R S)"
    using DirProd_monoid[OF assms[THEN ring.axioms(2)]] unfolding monoid_def
    by (auto simp add: DirProd_def RDirProd_def monoid.defs)
  then interpret Prod: group "add_monoid (RDirProd R S)" + monoid "RDirProd R S"
    using DirProd_group[OF assms[THEN abelian_group.a_group[OF ring.is_abelian_group]]]
    unfolding RDirProd_add_monoid by auto
  show ?thesis
    by (unfold_locales, auto simp add: RDirProd_def DirProd_def monoid.defs assms ring.ring_simprules)
qed

end


theory Kleene_Algebra
  imports Dioid
begin

(* +------------------------------------------------------------------------+ *)
section {* Kleene Algebras *}
(* +------------------------------------------------------------------------+ *)

record 'a kleene_algebra = "'a dioid" +
  star :: "'a \<Rightarrow> 'a" ("_\<^sup>\<star>\<index>" [101] 100)

locale kleene_algebra' =
  fixes A :: "('a, 'b) kleene_algebra_scheme" (structure)
  assumes ka_dioid: "dioid A"

declare kleene_algebra'_def [simp]

sublocale kleene_algebra' \<subseteq> dioid using ka_dioid .

locale kleene_algebra = kleene_algebra' +
  assumes star_closed: "x \<in> carrier A \<Longrightarrow> x\<^sup>\<star> \<in> carrier A"
  and star_unfoldl: "x \<in> carrier A \<Longrightarrow> 1 + x\<cdot>x\<^sup>\<star> \<sqsubseteq> x\<^sup>\<star>"
  and star_unfoldr: "x \<in> carrier A \<Longrightarrow> 1 + x\<^sup>\<star>\<cdot>x \<sqsubseteq> x\<^sup>\<star>"
  and star_inductl: "\<lbrakk>x \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> z + x\<cdot>y \<sqsubseteq> y \<longrightarrow> x\<^sup>\<star>\<cdot>z \<sqsubseteq> y"
  and star_inductr: "\<lbrakk>x \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> z + y\<cdot>x \<sqsubseteq> y \<longrightarrow> z\<cdot>x\<^sup>\<star> \<sqsubseteq> y"

begin

  lemma star_ref: "x \<in> carrier A \<Longrightarrow> 1 \<sqsubseteq> x\<^sup>\<star>"
    by (metis add_lub mult_closed one_closed star_closed star_unfoldl)

  lemma star_plus_one: "x \<in> carrier A \<Longrightarrow> x\<^sup>\<star> = 1 + x\<^sup>\<star>"
    by (metis add_lub nat_order_def star_unfoldl one_closed star_closed mult_closed)

  lemma star_trans: "x \<in> carrier A \<Longrightarrow> x\<^sup>\<star>\<cdot>x\<^sup>\<star> \<sqsubseteq> x\<^sup>\<star>"
    by (metis add_lub mult_closed nat_refl one_closed star_closed star_inductr star_unfoldr)

  lemma star_trans_eq: "x \<in> carrier A \<Longrightarrow> x\<^sup>\<star>\<cdot>x\<^sup>\<star> = x\<^sup>\<star>"
    by (metis mult_closed mult_oner nat_antisym one_closed star_closed star_plus_one star_trans subdistl)

  lemma star_1l: "x \<in> carrier A \<Longrightarrow> x\<cdot>x\<^sup>\<star> \<sqsubseteq> x\<^sup>\<star>"
    by (metis add_lub mult_closed one_closed star_closed star_unfoldl)

  lemma star_subid: "x \<in> carrier A \<Longrightarrow> x \<sqsubseteq> 1 \<longrightarrow> x\<^sup>\<star> = 1"
    by (smt add_comm mult_oner nat_order_def nat_refl one_closed star_closed star_inductl star_ref)

  lemma star_one: "1\<^sup>\<star> = 1"
    by (metis nat_refl one_closed star_subid)

  lemma star_inductl_var: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x\<cdot>y \<sqsubseteq> y \<longrightarrow> x\<^sup>\<star>\<cdot>y \<sqsubseteq> y"
    by (metis add_lub mult_closed nat_refl star_inductl)

  lemma star_invol: "x \<in> carrier A \<Longrightarrow> x\<^sup>\<star> = (x\<^sup>\<star>)\<^sup>\<star>"
    apply (rule nat_antisym)
    apply (smt mult_closed mult_oner nat_trans one_closed star_1l star_closed star_plus_one subdistl)
    apply (smt mult_oner one_closed star_closed star_inductl star_plus_one star_trans star_trans_eq)
    apply (metis star_closed)+
    done

  lemma star_inductl_eq:  "\<lbrakk>x \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> z+x\<cdot>y = y \<longrightarrow> x\<^sup>\<star>\<cdot>z \<sqsubseteq> y"
    by (metis nat_refl star_inductl)

  lemma star_inductl_var_eq:  "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x\<cdot>y = y \<longrightarrow> x\<^sup>\<star>\<cdot>y \<sqsubseteq> y"
    by (metis nat_refl star_inductl_var)

end

datatype 'a ka_term = KAAtom 'a
                    | KAPlus "'a ka_term" "'a ka_term"
                    | KAMult "'a ka_term" "'a ka_term"
                    | KAStar "'a ka_term"
                    | KAOne
                    | KAZero

primrec (in kleene_algebra) ka_term_unfold :: "'a ka_term \<Rightarrow> 'a" where
  "ka_term_unfold (KAAtom x) = x"
| "ka_term_unfold (KAPlus x y) = (ka_term_unfold x) + (ka_term_unfold y)"
| "ka_term_unfold (KAMult x y) = (ka_term_unfold x) \<cdot> (ka_term_unfold y)"
| "ka_term_unfold (KAStar x) = (ka_term_unfold x)\<^sup>\<star>"
| "ka_term_unfold KAOne = 1"
| "ka_term_unfold KAZero = 0"

lemma (in kleene_algebra) ka_term_fold_atom:
  "x \<in> carrier A \<Longrightarrow> x = ka_term_unfold (KAAtom x)"
  by (rule ka_term_unfold.simps(1)[symmetric])

primrec (in kleene_algebra) ka_term_atoms :: "'a ka_term \<Rightarrow> 'a set" where
  "ka_term_atoms (KAAtom x) = {x}"
| "ka_term_atoms (KAPlus x y) = (ka_term_atoms x) \<union> (ka_term_atoms y)"
| "ka_term_atoms (KAMult x y) = (ka_term_atoms x) \<union> (ka_term_atoms y)"
| "ka_term_atoms (KAStar x) = ka_term_atoms x"
| "ka_term_atoms KAOne = {}"
| "ka_term_atoms KAZero = {}"

lemma (in kleene_algebra) ka_term_closure:
  "ka_term_atoms x \<subseteq> carrier A \<Longrightarrow> ka_term_unfold x \<in> carrier A"
  by (induct x, simp_all add: add_closed mult_closed one_closed zero_closed star_closed)

ML {*
val ka_term_fold_tac =
  term_fold_tac @{thm kleene_algebra.ka_term_fold_atom} @{thms kleene_algebra.ka_term_unfold.simps[symmetric]} @{thm kleene_algebra.ka_term_closure}
*}

method_setup ka_closure = {*
Scan.succeed (fn ctxt =>
  let
    val witnesses = Locale.get_witnesses ctxt
    val unfolds = witnesses RL @{thms kleene_algebra.ka_term_atoms.simps}
  in
    METHOD (fn _ =>
      ka_term_fold_tac true ctxt 1
      THEN asm_full_simp_tac (@{simpset} addsimps unfolds) 1)
  end)
*}

context kleene_algebra
begin

  lemma star_subdist:
    assumes xc: "x \<in> carrier A" and yc: "y \<in> carrier A"
    shows "x\<^sup>\<star> \<sqsubseteq> (x+y)\<^sup>\<star>"
  proof -
    have "x\<^sup>\<star>\<cdot>1 \<sqsubseteq> (x+y)\<^sup>\<star>"
    proof (rule star_inductl[rule_format], insert xc yc, ka_closure+)
      have "1 + x\<cdot>(x+y)\<^sup>\<star> \<sqsubseteq> 1 + (x+y)\<cdot>(x+y)\<^sup>\<star>"
      proof (rule add_iso[rule_format, OF _ _ one_closed], insert xc yc, ka_closure+)
        show "x\<cdot>(x+y)\<^sup>\<star> \<sqsubseteq> (x+y)\<cdot>(x+y)\<^sup>\<star>"
          by (metis add_closed add_lub mult_isor nat_refl star_closed xc yc)
      qed
      moreover have "... \<sqsubseteq> (x+y)\<^sup>\<star>"
        by (metis add_closed star_unfoldl xc yc)
      ultimately show "1 + x\<cdot>(x+y)\<^sup>\<star> \<sqsubseteq> (x+y)\<^sup>\<star>"
        by (rule nat_trans, insert xc yc, ka_closure+)
    qed
    thus ?thesis
      by (metis mult_oner star_closed xc)
  qed

  lemma star_iso: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x \<sqsubseteq> y \<longrightarrow> x\<^sup>\<star> \<sqsubseteq> y\<^sup>\<star>"
    by (metis nat_order_def star_subdist)

  lemma star_ext: "x \<in> carrier A \<Longrightarrow> x \<sqsubseteq> x\<^sup>\<star>"
    by (smt mult_closed mult_oner nat_trans one_closed star_1l star_closed star_plus_one subdistl)

  lemma add_lub_r1:
    "\<lbrakk>x \<in> carrier A; y \<in> carrier A; z \<in> carrier A; x \<sqsubseteq> z; y \<sqsubseteq> z\<rbrakk> \<Longrightarrow> x + y \<sqsubseteq> z"
    by (metis add_lub)

  lemma star_sim1:
    assumes xc: "x \<in> carrier A" and yc: "y \<in> carrier A" and zc: "z \<in> carrier A"
    shows "x\<cdot>z \<sqsubseteq> z\<cdot>y \<longrightarrow> x\<^sup>\<star>\<cdot>z \<sqsubseteq> z\<cdot>y\<^sup>\<star>"
  proof
    assume asm: "x\<cdot>z \<sqsubseteq> z\<cdot>y"
    show "x\<^sup>\<star> \<cdot> z \<sqsubseteq> z \<cdot> y\<^sup>\<star>"
    proof (rule star_inductl[rule_format], insert xc yc zc, ka_closure+)
      show "z + x \<cdot> (z \<cdot> y\<^sup>\<star>) \<sqsubseteq> z \<cdot> y\<^sup>\<star>"
      proof (rule add_lub_r1, insert xc yc zc, ka_closure+)
        show "z \<sqsubseteq> z\<cdot>y\<^sup>\<star>"
          by (smt mult_double_iso mult_oner nat_refl one_closed star_closed star_ref yc zc)
        have "x\<cdot>(z\<cdot>y\<^sup>\<star>) = x\<cdot>z\<cdot>y\<^sup>\<star>"
          by (metis mult_assoc star_closed xc yc zc)
        moreover have "... \<sqsubseteq> z\<cdot>y\<cdot>y\<^sup>\<star>"
          by (metis asm mult_closed mult_isor star_closed xc yc zc)
        moreover have "... \<sqsubseteq> z\<cdot>(y\<cdot>y\<^sup>\<star>)"
          by (metis mult_assoc mult_closed nat_refl star_closed yc zc)
        moreover have "... \<sqsubseteq> z\<cdot>y\<^sup>\<star>"
          by (metis mult_closed mult_isol star_1l star_closed yc zc)
        ultimately show "x\<cdot>(z\<cdot>y\<^sup>\<star>) \<sqsubseteq> z\<cdot>y\<^sup>\<star>"
          by (smt mult_closed nat_trans star_closed xc yc zc)
      qed
    qed
  qed

  lemma star_slide1: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> (x\<cdot>y)\<^sup>\<star>\<cdot>x \<sqsubseteq> x\<cdot>(y\<cdot>x)\<^sup>\<star>"
    by (metis mult_assoc mult_closed nat_refl star_sim1)

  lemma star_slide_var1: "x \<in> carrier A \<Longrightarrow> x\<^sup>\<star>\<cdot>x \<sqsubseteq> x\<cdot>x\<^sup>\<star>"
    by (frule star_slide1[OF _ one_closed], metis mult_onel mult_oner)

  lemma star2: assumes xc: "x \<in> carrier A" shows "(1+x)\<^sup>\<star> = x\<^sup>\<star>"
  proof -
    have "x\<^sup>\<star> \<sqsubseteq> (1+x)\<^sup>\<star>"
      by (metis add_comm assms one_closed star_subdist)
    moreover have "(1+x)\<^sup>\<star> \<sqsubseteq> x\<^sup>\<star>"
      by (metis add_closed add_lub assms mult_oner one_closed star_closed star_ext star_invol star_iso star_ref)
    ultimately show ?thesis
      by (metis add_closed assms nat_antisym one_closed star_closed)
  qed

  lemma star_unfoldl_eq: assumes xc: "x \<in> carrier A" shows "x\<^sup>\<star> = 1+x\<cdot>x\<^sup>\<star>"
  proof -
    have "x\<^sup>\<star>\<cdot>1 \<sqsubseteq> 1 + x\<cdot>x\<^sup>\<star>"
    proof (rule star_inductl[rule_format], insert xc, ka_closure+)
      show "1 + x \<cdot> (1 + x \<cdot> x\<^sup>\<star>) \<sqsubseteq> 1 + x \<cdot> x\<^sup>\<star>"
        apply (rule add_iso[rule_format], insert xc, ka_closure+)
        apply (rule mult_isol[rule_format], ka_closure+)
        by (rule star_unfoldl)
    qed
    thus ?thesis
      by (metis xc add_closed mult_closed mult_oner nat_antisym one_closed star_closed star_unfoldl)
  qed

  lemma star_rtc1: "x \<in> carrier A \<Longrightarrow> 1+x+x\<^sup>\<star>\<cdot>x\<^sup>\<star> \<sqsubseteq> x\<^sup>\<star>"
    by (metis add_assoc nat_order_def one_closed star_closed star_ext star_plus_one star_trans star_trans_eq)

  lemma star_slide: assumes xc: "x \<in> carrier A" and yc: "y \<in> carrier A"
    shows "(x\<cdot>y)\<^sup>\<star>\<cdot>x = x\<cdot>(y\<cdot>x)\<^sup>\<star>"
  proof -
    have "x\<cdot>(y\<cdot>x)\<^sup>\<star> \<sqsubseteq> (x\<cdot>y)\<^sup>\<star>\<cdot>x"
      apply (rule star_inductr[rule_format], insert xc yc, ka_closure+)
      apply (rule add_lub_r1, ka_closure+)
      apply (smt mult_closed mult_double_iso mult_onel nat_refl one_closed star_closed star_ref)
      by (metis mult_assoc mult_closed mult_isol mult_isor star_closed star_ext star_trans_eq)
    thus ?thesis
      by (metis mult_closed nat_antisym star_closed star_slide1 xc yc)
  qed

  lemma star_denest_1:
    assumes xc: "x \<in> carrier A" and yc: "y \<in> carrier A"
    shows "x\<^sup>\<star>\<cdot>(y\<cdot>x\<^sup>\<star>)\<^sup>\<star> \<sqsubseteq> (x + y)\<^sup>\<star>"
    apply (rule star_inductr[rule_format], insert xc yc, ka_closure+)
    apply (rule add_lub_r1, ka_closure+)
    apply (rule star_subdist, ka_closure+)
    apply (rule star_inductl[rule_format], ka_closure+)
    apply (rule add_lub_r1, ka_closure+)
    apply (smt add_closed add_lub mult_double_iso star_closed star_ext star_subdist star_trans_eq)
    by (metis add_closed star_1l)

  lemma star_subdist_var_1: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x \<sqsubseteq> (x+y)\<^sup>\<star>"
    by (metis add_closed add_lub star_closed star_ext)

  lemma star_subdist_var_2: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x\<cdot>y \<sqsubseteq> (x+y)\<^sup>\<star>"
    by (metis add_closed add_comm mult_double_iso star_closed star_subdist_var_1 star_trans_eq)

  lemma star_subdist_var_3: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x\<^sup>\<star>\<cdot>y\<^sup>\<star> \<sqsubseteq> (x+y)\<^sup>\<star>"
    by (metis add_closed add_comm mult_double_iso star_closed star_subdist star_trans_eq)

  lemma star_denest_2:
    assumes xc: "x \<in> carrier A" and yc: "y \<in> carrier A"
    shows "(x + y)\<^sup>\<star> \<sqsubseteq> x\<^sup>\<star>\<cdot>(y\<cdot>x\<^sup>\<star>)\<^sup>\<star>"
  proof -
    have "(x + y)\<^sup>\<star>\<cdot>1 \<sqsubseteq> x\<^sup>\<star>\<cdot>(y\<cdot>x\<^sup>\<star>)\<^sup>\<star>"
      apply (rule star_inductl[rule_format], insert xc yc, ka_closure+)
      apply (rule add_lub_r1, ka_closure+)
      apply (smt mult_closed mult_double_iso mult_onel one_closed star_closed star_ref)
      apply (subst distr, ka_closure+)
      apply (rule add_lub_r1, ka_closure+)
      apply (metis mult_closed mult_assoc mult_isor star_1l star_closed)
      by (smt mult_assoc mult_closed mult_double_iso mult_onel one_closed star_1l star_closed star_ref)
    thus ?thesis
      by (metis dioid.add_closed ka_dioid mult_oner star_closed xc yc)
  qed

  lemma star_denest: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x\<^sup>\<star>\<cdot>(y\<cdot>x\<^sup>\<star>)\<^sup>\<star> = (x + y)\<^sup>\<star>"
    by (smt add_closed mult_closed nat_antisym star_closed star_denest_1 star_denest_2)

  lemma kozen_skat_lemma:
    assumes uc: "u \<in> carrier A" and vc: "v \<in> carrier A" and wc: "w \<in> carrier A"
    and z3: "u\<cdot>v = 0" and z2: "u\<cdot>w = 0"
    shows "(u + v)\<^sup>\<star>\<cdot>w = v\<^sup>\<star>\<cdot>w"
  proof -
    have z1: "u\<cdot>v = u\<cdot>w"
      by (metis z3 z2)
    have "u\<^sup>\<star>\<cdot>w \<sqsubseteq> w"
      by (metis star_inductl_var uc wc z2 zero_min)
    moreover have "w \<sqsubseteq> u\<^sup>\<star>\<cdot>w"
      by (smt distr mult_onel nat_order_def one_closed star_closed star_plus_one uc wc)
    ultimately have a: "u\<^sup>\<star>\<cdot>w = w"
      by (smt nat_antisym uc wc star_closed mult_closed zero_closed)

    have "u\<^sup>\<star>\<cdot>v \<sqsubseteq> v"
      by (metis star_inductl_var uc vc z3 zero_min)
    moreover have "v \<sqsubseteq> u\<^sup>\<star>\<cdot>v"
      by (smt distr mult_onel nat_order_def one_closed star_closed star_plus_one uc vc)
    ultimately have b: "u\<^sup>\<star>\<cdot>v = v"
      by (metis mult_closed nat_antisym star_closed uc vc)

    from a and b show ?thesis
      by (smt add_closed mult_assoc mult_closed nat_antisym star_closed star_denest_1 star_denest_2 star_slide uc vc wc)
  qed

  lemma kozen_skat_lemma_dual:
    assumes uc: "u \<in> carrier A" and vc: "v \<in> carrier A" and wc: "w \<in> carrier A"
    and z3: "v\<cdot>u = 0" and z2: "w\<cdot>u = 0"
    shows "w\<cdot>(u + v)\<^sup>\<star> = w\<cdot>v\<^sup>\<star>"
  proof -
    have z1: "v\<cdot>u = w\<cdot>u"
      by (metis z3 z2)
    have "w\<cdot>u\<^sup>\<star> \<sqsubseteq> w"
      by (metis add_zeror nat_refl star_inductr uc wc z2)
    moreover have "w \<sqsubseteq> w\<cdot>u\<^sup>\<star>"
      by (smt distl mult_oner nat_order_def one_closed star_closed star_plus_one uc wc)
    ultimately have a: "w\<cdot>u\<^sup>\<star> = w"
      by (smt nat_antisym uc wc star_closed mult_closed zero_closed)

    have "v\<cdot>u\<^sup>\<star> \<sqsubseteq> v"
      by (metis add_zeror nat_refl star_inductr uc vc z3)
    moreover have "v \<sqsubseteq> v\<cdot>u\<^sup>\<star>"
      by (smt distl mult_oner nat_order_def one_closed star_closed star_plus_one uc vc)
    ultimately have b: "v\<cdot>u\<^sup>\<star> = v"
      by (metis mult_closed nat_antisym star_closed uc vc)

    from a and b show ?thesis
      by (metis mult_assoc star_closed star_denest uc vc wc)
  qed

  lemma star_comm: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x\<cdot>y = y\<cdot>x \<Longrightarrow> x\<cdot>y\<^sup>\<star> = y\<^sup>\<star>\<cdot>x"
    apply (rule nat_antisym[rotated 2], ka_closure+)
    apply (rule star_inductr[rule_format], ka_closure+)
    apply (rule add_lub_r1, ka_closure+)
    apply (metis distr mult_onel nat_order_def one_closed star_closed star_plus_one)
    apply (smt subdistl distr mult_assoc mult_closed nat_order_def star_closed star_ext star_trans_eq)
    apply (rule star_inductl[rule_format], ka_closure+)
    apply (rule add_lub_r1, ka_closure+)
    apply (smt mult_double_iso mult_oner nat_refl one_closed star_closed star_ref)
    by (smt mult_assoc mult_closed mult_double_iso nat_refl star_1l star_closed)

  lemma star_eliml1: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x = x\<cdot>x \<Longrightarrow> x\<cdot>y = y\<cdot>x \<Longrightarrow> x\<cdot>(x\<cdot>y)\<^sup>\<star> \<sqsubseteq> x\<cdot>y\<^sup>\<star>"
    apply (rule star_inductr[rule_format], ka_closure+)
    apply (rule add_lub_r1, ka_closure+)
    apply (smt mult_double_iso mult_oner nat_refl one_closed star_closed star_ref)
    by (smt mult_assoc mult_closed mult_isol star_1l star_closed star_comm)

  lemma star_eliml2: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x = x\<cdot>x \<Longrightarrow> x\<cdot>y = y\<cdot>x \<Longrightarrow> x\<cdot>y\<^sup>\<star> \<sqsubseteq> x\<cdot>(x\<cdot>y)\<^sup>\<star>"
    by (metis add_idem mult_assoc mult_closed nat_order_def star_comm star_sim1)

  lemma star_eliml: "\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow> x = x\<cdot>x \<Longrightarrow> x\<cdot>y = y\<cdot>x \<Longrightarrow> x\<cdot>(x\<cdot>y)\<^sup>\<star> = x\<cdot>y\<^sup>\<star>"
    by (metis (no_types) mult_closed nat_antisym star_closed star_eliml1 star_eliml2)

  lemma star_elimr: "\<lbrakk>x \<in> carrier A; y \<in> carrier A; x = x\<cdot>x; x\<cdot>y = y\<cdot>x\<rbrakk> \<Longrightarrow> (y\<cdot>x)\<^sup>\<star>\<cdot>x = y\<^sup>\<star>\<cdot>x"
    by (metis star_comm star_eliml star_slide)

  lemma star_sim2: "\<lbrakk>x \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> z\<cdot>x \<sqsubseteq> y\<cdot>z \<Longrightarrow> z\<cdot>x\<^sup>\<star> \<sqsubseteq> y\<^sup>\<star>\<cdot>z"
  proof (rule star_inductr[rule_format], ka_closure+)
    assume xc: "x \<in> carrier A" and yc: "y \<in> carrier A" and zc: "z \<in> carrier A"
    and asm: "z\<cdot>x \<sqsubseteq> y\<cdot>z"
    have "y\<^sup>\<star>\<cdot>(z\<cdot>x) \<sqsubseteq> y\<^sup>\<star>\<cdot>y\<cdot>z"
      by (smt asm mult_assoc mult_closed mult_isol star_closed xc yc zc)
    moreover have "... \<sqsubseteq> y\<^sup>\<star>\<cdot>z"
      by (smt mult_closed mult_isor star_1l star_closed star_comm yc zc)
    ultimately have "y\<^sup>\<star>\<cdot>z\<cdot>x \<sqsubseteq> y\<^sup>\<star>\<cdot>z"
      by (metis (no_types) mult_assoc mult_closed nat_trans star_closed xc yc zc)

    moreover have "z \<sqsubseteq> y\<^sup>\<star>\<cdot>z"
      by (smt distr mult_onel nat_order_def one_closed star_closed star_plus_one yc zc)

    ultimately show "z + y\<^sup>\<star>\<cdot>z\<cdot>x \<sqsubseteq> y\<^sup>\<star>\<cdot>z"
      by (metis add_lub_r1 mult_closed star_closed xc yc zc)
  qed

  lemma star_sim: "\<lbrakk>x \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk> \<Longrightarrow> z\<cdot>x = y\<cdot>z \<Longrightarrow> z\<cdot>x\<^sup>\<star> = y\<^sup>\<star>\<cdot>z"
    apply (rule nat_antisym[rotated 2], ka_closure+)
    apply (rule star_sim2, ka_closure+)
    apply (metis mult_isor nat_refl)
    apply (rule star_sim1[rule_format], ka_closure+)
    by (metis mult_closed nat_refl)

  lemma star_elim:
    assumes xc: "x \<in> carrier A" and yc: "y \<in> carrier A" and zc: "z \<in> carrier A"
    and zz: "z = z\<cdot>z" and yz: "y\<cdot>z = z\<cdot>y" and xz: "x\<cdot>z = z"
    shows "y\<^sup>\<star>\<cdot>z = (x\<cdot>y)\<^sup>\<star>\<cdot>z"
  proof -
    have "z\<cdot>y\<^sup>\<star> = (x\<cdot>y)\<^sup>\<star>\<cdot>z"
    proof (rule star_sim, insert xc yc zc, ka_closure+)
      show "z\<cdot>y = x\<cdot>y\<cdot>z"
        by (metis mult_assoc xc xz yc yz zc)
    qed
    thus ?thesis
      by (metis star_comm yc yz zc)
  qed

end

end