theory KAD
  imports BBI "$AFP/Kleene_Algebra/Kleene_Algebra"
begin

no_notation
  sup (infixl "+" 65)

notation sup (infixl "\<squnion>" 65)
  and inf (infixl "\<sqinter>" 70)
  and bot ("\<bottom>")
  and top ("\<top>")

locale embedded_boolean_semiring =
  fixes bool_hom :: "'a :: boolean_algebra \<Rightarrow> 'b :: dioid_one_zero" ("`_" [999] 1000)
  assumes order_hom [iff]: "`p \<le> `q \<longleftrightarrow> p \<le> q"
  and sup_hom [iff]: "`(p \<squnion> q) = `p + `q"
  and inf_hom [iff]: "`(p \<sqinter> q) = `p \<cdot> `q"
  and top_hom [iff]: "`\<top> = 1"
  and bot_hom [iff]: "`\<bottom> = 0"
begin

abbreviation complementation :: "'a \<Rightarrow> 'b" ("!_" [999] 1000) where "!p \<equiv> `(-p)"

lemma mult_idem [simp]: "`p \<cdot> `p = `p"
  by (metis inf_hom inf_idem)

lemma compl_mult_zero [simp]: "!p \<cdot> `p = 0"
  by (metis bot_hom compl_inf_bot inf_hom)

lemma compl_add_one [simp]: "!p + `p = 1"
  by (metis compl_sup_top sup_hom top_hom)

lemma mult_compl_zero [simp]: "`p \<cdot> !p = 0"
  by (metis bot_hom inf_compl_bot inf_hom)

lemma add_compl_one [simp]: "`p + !p = 1"
  by (metis add_comm compl_add_one)

lemma mult_commute_hom: "`p \<cdot> `q = `q \<cdot> `p"
  by (metis inf_commute inf_hom)

lemma compl_eq_compl_iff_hom [simp]: "!x = !y \<longleftrightarrow> x = y"
  by (metis compl_le_compl_iff eq_iff order_hom)

lemma compl_bot_one [simp]: "!\<bottom> = 1"
  by (metis compl_bot_eq top_hom)

lemma compl_top_zero [simp]: "!\<top> = 0"
  by (metis bot_hom compl_top_eq)

lemma compl_inf_add [simp]: "!(x \<sqinter> y) = !x + !y"
  by (metis compl_inf sup_hom)

lemma compl_sup_mult [simp]: "!(x \<squnion> y) = !x \<cdot> !y"
  by (metis compl_sup inf_hom)

lemma compl_iso: "x \<le> y \<Longrightarrow> !y \<le> !x"
  by (metis compl_mono order_hom)

lemma bool_greatest [simp]: "`p \<le> 1"
  by (metis order_hom top_greatest top_hom)

lemma bool_mult_left: "`p\<cdot>x \<le> x"
  by (metis bool_greatest mult_isor mult_onel)

lemma bool_mult_right: "x\<cdot>`p \<le> x"
  by (metis bool_greatest mult_isol mult_oner)

lemma bool_semiring1: assumes "`p\<cdot>x \<le> x\<cdot>`q" shows "x\<cdot>!q \<le> !p\<cdot>x"
proof -
  have "x\<cdot>!q = (`p + !p)\<cdot>x\<cdot>!q"
    by simp
  also have "... \<le> x\<cdot>(`q\<cdot>!q) + !p\<cdot>x\<cdot>!q"
    by (metis distrib_right' add_iso assms mult_isor mult_assoc)
  also have "... \<le> !p\<cdot>x"
    by (metis add_zero_l annir mult_compl_zero bool_mult_right)
  finally show ?thesis .
qed

lemma bool_semiring2: "x\<cdot>!q \<le> !p\<cdot>x \<Longrightarrow> `p\<cdot>x\<cdot>!q \<le> 0"
  apply (subgoal_tac "`p\<cdot>x\<cdot>!q \<le> `p\<cdot>!p\<cdot>x")
  by (metis annil mult_compl_zero, metis mult_isol mult_assoc)

lemma bool_semiring3: "`p\<cdot>x\<cdot>!q \<le> 0 \<Longrightarrow> `p\<cdot>x = `p\<cdot>x\<cdot>`q"
  apply (subgoal_tac "`p\<cdot>x = `p\<cdot>x\<cdot>(`q + !q)")
  by (metis distrib_left add_zeror zero_unique, simp)

lemma bool_semiring4: "`p\<cdot>x = `p\<cdot>x\<cdot>`q \<Longrightarrow> `p\<cdot>x \<le> x\<cdot>`q"
  by (metis bool_mult_left mult_isor)

lemma bool_semiring_eq: "`p\<cdot>x \<le> x\<cdot>`q \<longleftrightarrow> x\<cdot>!q \<le> !p\<cdot>x"
  by (metis bool_semiring1 bool_semiring2 bool_semiring3 bool_semiring4)

lemma bool_semiring_eq2: "`p\<cdot>x\<cdot>!q = 0 \<longleftrightarrow> x\<cdot>!q \<le> !p\<cdot>x"
  by (metis bool_semiring_eq bool_semiring2 bool_semiring3 bool_semiring4 bool_semiring_eq zero_unique)

end

locale domain_semiring = embedded_boolean_semiring bbi_hom
  for bbi_hom :: "'a :: bbi \<Rightarrow> 'b :: dioid_one_zero" ("`_" [999] 1000) +
  fixes domain :: "'b :: dioid_one_zero \<Rightarrow> 'a :: bbi" ("d _" [999] 1000)
  assumes llp: "d x \<le> p \<longleftrightarrow> x \<le> `p\<cdot>x"
begin

abbreviation compl_bbi :: "'a \<Rightarrow> 'b" ("!_" [999] 1000) where "!p \<equiv> `(-p)"

lemma d_zero [simp]: "d 0 = \<bottom>"
  by (metis bot.extremum_unique llp zero_least)

lemma d_one [simp]: "d 1 = \<top>"
  by (metis llp mult_onel mult_oner order_class.order.antisym order_hom top_greatest top_hom)

lemma gla: "d x \<le> p \<longleftrightarrow> !p\<cdot>x \<le> 0"
  by (metis (hide_lams, no_types) annir bool_semiring_eq bot_hom compl_bot_eq llp double_compl mult_oner top_hom)

lemma d_strict: "d x \<le> \<bottom> \<longleftrightarrow> x \<le> 0"
  by (metis annil llp bot_hom)

lemma d_add: "d(x + y) = d x \<squnion> d y"
proof -
  have "\<forall>p. d(x + y) \<le> p \<longleftrightarrow> !p\<cdot>(x + y) \<le> 0"
    by (metis gla)
  hence "\<forall>p. d(x + y) \<le> p \<longleftrightarrow> d x \<squnion> d y \<le> p"
    by (metis distrib_left add_lub gla sup.bounded_iff)
  thus ?thesis
    by (metis eq_iff)
qed

lemma d_iso: "x \<le> y \<Longrightarrow> d x \<le> d y"
  by (metis dual_order.refl gla mult_isol order.trans)

lemma d_greater: "p \<le> d `p"
  by (metis bool_mult_right llp order_hom order_refl order_trans)

lemma d_identity [simp]: "d `p = p"
  by (metis d_greater double_compl gla mult_compl_zero sup_absorb1 sup_commute zero_least)

lemma d_involution [simp]: "d `d x = d x"
  by (metis d_identity)

lemma left_inv [simp]: "`d x\<cdot>x = x"
  by (metis bool_mult_left eq_iff llp)

lemma d_least: "d(`p\<cdot>x) \<le> p"
  by (simp add: llp mult_assoc[symmetric])

lemma imp_exp_law: "d (`p\<cdot>x) = p \<sqinter> d x"
proof -
  have lhs: "d (`p\<cdot>x) \<le> p \<sqinter> d x"
    by (metis bool_mult_left d_iso inf.bounded_iff d_least inf.bounded_iff)
  have "p \<sqinter> d x = p \<sqinter> d(`p\<cdot>x) \<squnion> p \<sqinter> d(!p\<cdot>x)"
    by (metis d_add distrib_right' mult_onel sup_compl_top sup_hom top_hom inf_sup_distrib1)
  also have "... \<le> p \<sqinter> d(`p\<cdot>x)"
    by (metis d_least eq_iff inf_mono sup_mono inf_compl_bot sup_bot.right_neutral)
  finally have rhs: "p \<sqinter> d x \<le> d(`p\<cdot>x)"
    by (metis inf.bounded_iff)
  thus ?thesis
    by (metis antisym lhs)
qed

lemma subloc: "d(x\<cdot>y) \<le> d(x\<cdot>`d y)"
proof (subst llp)
  have "x\<cdot>y \<le> x\<cdot>`d y\<cdot>y"
    by (metis mult_assoc left_inv order_refl)
  also have "... \<le> `d(x\<cdot>`d y)\<cdot>x\<cdot>`d y\<cdot>y"
    by (metis mult_assoc left_inv order_refl)
  also have "... \<le> `d(x\<cdot>`d y)\<cdot>x\<cdot>y"
    by (metis bool_mult_right mult_isor)
  finally show "x\<cdot>y \<le> `d(x\<cdot>`d y)\<cdot>(x\<cdot>y)"
    by (metis mult_assoc)
qed

lemma loc: "d(x\<cdot>y) = d(x\<cdot>`(d y))"
  (* nitpick *) oops

lemma d_compl [iff]: "- d `p = d !p"
  by (metis d_identity)

lemma d_fixpoint: "(\<exists>y. x = `d y) \<longleftrightarrow> x = `d x"
  by (metis d_involution)

lemma type_conv: "(\<forall>x. x = `d x \<longrightarrow> P x) \<longleftrightarrow> (\<forall>x. P (`d x))"
  by (metis d_fixpoint)

lemma d_mult_le: "d(x\<cdot>y) \<le> d(x)"
  by (metis bool_mult_right d_iso dual_order.trans subloc)

lemma d_subid: "x \<le> 1 \<Longrightarrow> x \<le> `d(x)"
  by (metis left_inv monoid_mult_class.mult.right_neutral mult_isol)

lemma d_very_strict: "d(x) = \<bottom> \<longleftrightarrow> x = 0"
  by (metis annil bot_hom d_zero left_inv)

lemma d_exp: "`d(`d(x)\<cdot>y) = `d(x) \<cdot> `d(y)"
  by (metis imp_exp_law inf_hom)

lemma d_add_closed: "`d(`d(x) + `d(y)) = `d(x) + `d(y)"
  by (metis d_add d_identity sup_hom)

lemma d_mult_closed: "`d(`d(x)\<cdot>`d(y)) = `d(x) \<cdot> `d(y)"
  by (metis d_identity imp_exp_law inf_hom)

lemma d_absorption1 [simp]: "`d(x)\<cdot>(`d(x) + `d(y)) = `d(x)"
  by (metis antisym_conv bool_mult_right d_add_closed mult_idem subdistl)

lemma d_absorption2 [simp]: "`d(x) + `d(x)\<cdot>`d(y) = `d(x)"
  by (metis (hide_lams, no_types) add_comm compl_inf_add compl_le_compl_iff double_compl inf.cobounded1 inf_absorb2 inf_hom)

lemma d_distrib [simp] : "(`d(x) + `d(y))\<cdot>(`d(x) + `d(z)) = `d(x) + `d(y)\<cdot>`d(z)"
  by (metis inf_hom sup_hom sup_inf_distrib1)

definition antidomain :: "'b \<Rightarrow> 'a" ("a _" [999] 1000) where "a x \<equiv> - d(x)"

lemma a_d_compl_d[simp]: "d!d x = a x"
  by (metis antidomain_def d_identity)

lemma a_mult_zero[simp]: "`a x \<cdot> x = 0"
  by (metis antidomain_def d_greater d_identity gla zero_unique)

lemma double_a[simp]: "a `(a x) = d x"
  by (metis antidomain_def d_identity double_compl)

lemma a_gla: "`a(x)\<cdot>y = 0 \<longleftrightarrow> a(x) \<le> a(y)"
  by (metis antidomain_def compl_le_compl_iff gla zero_unique)

lemma a_subdist: "a(x + y) \<le> a(x)"
  by (metis add_ub1 antidomain_def compl_iso d_iso order_hom)

lemma a_1: "`a(x) = 1 \<Longrightarrow> x = 0"
  by (metis a_mult_zero mult_onel)

lemma a_3 [simp]: "`a(x)\<cdot>`a(y)\<cdot>`d(x + y) = 0"
  by (metis a_d_compl_d compl_mult_zero compl_sup_mult d_add d_compl d_involution)

lemma a_add: "`a(x)\<cdot>`a(y) = `a(x + y)"
  by (metis antidomain_def compl_sup d_add inf_hom)

lemma a_export: "a(`a(x)\<cdot>y) = d(x) \<squnion> a(y)"
  by (metis antidomain_def compl_inf double_compl imp_exp_law)

lemma a_zero [simp]: "a(0) = \<top>"
  by (metis antidomain_def compl_bot_eq d_zero)

lemma a_one [simp]: "a(1) = \<bottom>"
  by (metis antidomain_def compl_top_eq d_one)

lemma a_comp_1 [simp]: "`d(x)\<cdot>`a(x) = 0"
  by (metis a_mult_zero double_a)

lemma a_comp_2 [simp]: "`a(x)\<cdot>`d(x) = 0"
  by (metis a_comp_1 mult_commute_hom)

definition fdiamond :: "'b \<Rightarrow> 'a \<Rightarrow> 'a" ("| _ \<rangle> _" [50, 90] 999) where
  "|x\<rangle>y = d(x\<cdot>`y)"

lemma fdia_simp [simp]: "|x\<rangle>(d `p) = |x\<rangle>p"
 by (metis d_identity)

lemma fdia_simp2 [simp]: "d `|x\<rangle>p = |x\<rangle>p"
  by (metis d_identity)

lemma fdia_sup: "|x\<rangle> (p \<squnion> q) = |x\<rangle>p \<squnion> |x\<rangle>q"
  by (metis fdiamond_def sup_hom distrib_left d_add)

lemma fdia_add: "|x + y\<rangle> p = |x\<rangle>p \<squnion> |y\<rangle>p"
  by (metis d_add distrib_right' fdiamond_def)

lemma fdia_mult: "|x\<cdot>y\<rangle> p \<le> |x\<rangle> |y\<rangle> p"
  by (metis fdiamond_def subloc mult_assoc)

lemma fdia_one: "|1\<rangle>p = p"
  by (metis d_identity fdiamond_def monoid_mult_class.mult.left_neutral)

lemma fdia_zero: "|x\<rangle>\<bottom> = \<bottom>"
  by (metis annir bot_hom d_zero fdiamond_def)

lemma fdia_bool: "|(`p)\<rangle>q = p \<sqinter> q"
  by (metis d_identity fdiamond_def inf_hom)

lemma fdemodalisation1: "q \<sqinter> |x\<rangle>p = \<bottom> \<longleftrightarrow> `q\<cdot>x\<cdot>`p = 0"
  by (simp add: fdiamond_def imp_exp_law[symmetric] mult_assoc d_very_strict)

lemma fdemodalisation2: "|x\<rangle>p \<le> q \<longleftrightarrow> !q\<cdot>x\<cdot>`p = 0"
  by (simp add: fdiamond_def gla mult_assoc)

lemma fdemodalisation3: "|x\<rangle>p \<le> q \<longleftrightarrow> x\<cdot>`p \<le> `q\<cdot>x"
  by (metis fdemodalisation2 bool_semiring_eq2 double_compl)

lemma fdia_iso: "p \<le> q \<Longrightarrow> |x\<rangle>p \<le> |x\<rangle>q"
  by (metis fdia_sup le_iff_sup)

lemma fdia_iso_var: "x \<le> y \<Longrightarrow> |x\<rangle>p \<le> |y\<rangle>p"
  by (metis d_iso fdiamond_def mult_isor)

lemma fdia_zero_var: "|0\<rangle>x = \<bottom>"
  by (metis bot_hom fdia_bool inf_bot_left)

lemma fdia_subdist_1: "|x\<rangle>p \<le> |x\<rangle>(p \<squnion> q)"
  by (metis fdia_iso sup.cobounded1)

lemma fdia_subdist_2: "|x\<rangle>(p \<sqinter> q) \<le> |x\<rangle>p"
  by (metis fdia_iso inf.cobounded1)

lemma fdia_subdist: "|x\<rangle>(p \<sqinter> q) \<le> |x\<rangle>p \<sqinter> |x\<rangle>q"
  by (metis fdia_subdist_2 inf.bounded_iff inf_commute)

lemma dia_diff_var: "|x\<rangle>p \<le> |x\<rangle>(p \<sqinter> -q) \<squnion> |x\<rangle>q"
  by (metis add_compl_one fdia_iso fdia_sup inf.bounded_iff order_hom sup.cobounded2 sup_commute sup_hom sup_inf_distrib1)

lemma fdia_export_1:  "q \<sqinter> |x\<rangle>p = |(`q\<cdot>x)\<rangle>p"
  by (metis mult_assoc fdiamond_def imp_exp_law)

lemma fdia_export_2: "-q \<sqinter> |x\<rangle>p = |!q\<cdot>x\<rangle>p"
  by (metis fdia_export_1)

lemma fdia_split: "|x\<rangle>p = (q \<sqinter> |x\<rangle>p) \<squnion> (-q \<sqinter> |x\<rangle>p)"
  by (metis compl_sup_top inf_sup_distrib2 inf_top.left_neutral sup_commute)

lemma a_compl [simp]: "`a(`p) = !p"
  by (metis antidomain_def d_identity)

definition fbox :: "'b \<Rightarrow> 'a \<Rightarrow> 'a" ("| _ ] _" [50, 90] 999) where
  "|x]p \<equiv> a(x\<cdot>!p)"

lemma fbox_fdia: "|x]p = -|x\<rangle>(-p)"
  by (metis antidomain_def fbox_def fdiamond_def)

lemma fdia_fbox: "|x\<rangle>p = -|x](-p)"
  by (metis double_compl fbox_fdia)

lemma fbox_fdia_de_morgan_1: "-|x]p = |x\<rangle>(-p)"
  by (metis double_compl fbox_fdia)

lemma fdia_fbox_de_morgan_2: "-|x\<rangle>p = |x](-p)"
  by (metis double_compl fdia_fbox)

lemma fbox_simp: "|x]p = |x]d(`p)"
  by (metis d_identity)

lemma fbox_simp_2:  "|x]p = d( `|x]p )"
  by (metis d_identity)

lemma fbox_dom: "a(x) = |x]\<bottom>"
  by (metis compl_bot_one fbox_def mult_oner)

lemma fbox_add1: "|x](p \<sqinter> q) = |x]p \<sqinter> |x]q"
  by (metis a_add antidomain_def compl_inf_add d_add d_identity fbox_fdia fdia_sup fdiamond_def inf_hom)

lemma fbox_add2: "|x + y]p = |x]p \<sqinter> |y]p"
  by (metis compl_sup fbox_fdia fdia_add)

lemma fbox_mult: "|x]|y]p \<le> |x\<cdot>y]p"
  by (metis compl_le_compl_iff fbox_fdia fdia_fbox_de_morgan_2 fdia_mult)

lemma fbox_one: "|1]p = p"
  by (metis double_compl fbox_fdia fdia_one)

lemma fbox_one_1: "|x]\<top> = \<top>"
  by (metis compl_bot_eq compl_top_eq fbox_fdia fdia_zero)

lemma fbox_export_1: "-p \<squnion> |x]q = |(`p\<cdot>x)]q"
  by (metis compl_inf fbox_fdia fdia_export_1)

lemma fbox_export_2: "p \<squnion> |x]q = |!p\<cdot>x]q"
  by (metis double_compl fbox_export_1)

lemma fbox_test: "|(`p)]q = -p \<squnion> q"
  by (metis compl_inf double_compl fbox_fdia fdia_bool)

lemma fbox_test_var: "-p \<sqinter> |!p](-q) = -p \<sqinter> -q"
  by (metis (hide_lams, no_types) compl_sup double_compl fbox_fdia fdia_bool inf_top.right_neutral sup_compl_top sup_inf_distrib1)

lemma fbox_demodalisation3: "p \<le> |x]q \<longleftrightarrow> `p\<cdot>x \<le> x\<cdot>`q"
  by (metis bool_semiring_eq compl_le_compl_iff fbox_fdia_de_morgan_1 fdemodalisation3)

lemma fbox_iso: "p \<le> q \<Longrightarrow> |x]p \<le> |x]q"
  by (metis fbox_add1 inf.orderI inf_absorb1)

lemma fbox_antitone_var: "x \<le> y \<Longrightarrow> |y]p \<le> |x]p"
  by (metis compl_iso fbox_fdia fdia_iso_var order_hom)

lemma fbox_subdist_1: "|x](p \<sqinter> q) \<le> |x]p"
  by (metis fbox_iso inf.cobounded1)

lemma fbox_subdist_2: "|x]p \<le> |x](p \<squnion> q)"
  by (metis fbox_iso sup.cobounded1)

lemma fbox_diff_var: "|x](p \<squnion> -q) \<sqinter> |x]q \<le> |x]p"
  by (metis (hide_lams, no_types) fbox_add1 inf.bounded_iff inf_commute inf_compl_bot inf_sup_distrib2 order_refl sup_bot.left_neutral sup_commute)

lemma fbox_diff: "|x](p \<squnion> -q) \<le> |x]p \<squnion> -|x]q"
  apply (simp add: fbox_def antidomain_def)
  oops

end

locale kad = domain_semiring bbi_hom domain
  for bbi_hom :: "'a :: bbi \<Rightarrow> 'b :: kleene_algebra" ("`_" [999] 1000)
  and domain :: "'b :: kleene_algebra \<Rightarrow> 'a :: bbi" ("d _" [999] 1000)
begin

lemma a_star: "a(x\<^sup>\<star>) = \<bottom>"
  by (metis a_one a_subdist bot.extremum_uniqueI star_plus_one)

lemma d_star: "d(x\<^sup>\<star>) = \<top>"
  by (metis a_star a_zero bot_hom double_a)

lemma fdia_star_unfold: "|1\<rangle>p \<squnion> |x\<rangle>|x\<^sup>\<star>\<rangle>p \<ge> |x\<^sup>\<star>\<rangle>p"
proof -
  have "|x\<^sup>\<star>\<rangle>p = |1 + x\<cdot>x\<^sup>\<star>\<rangle>p"
    by (metis star_unfoldl_eq)
  also have "... = |1\<rangle>p \<squnion> |x\<cdot>x\<^sup>\<star>\<rangle>p"
    by (metis fdia_add)
  also have "... \<le> |1\<rangle>p \<squnion> |x\<rangle>|x\<^sup>\<star>\<rangle>p"
    by (metis add_iso_var fdia_mult inf.orderI inf_idem order_hom sup_hom)
  finally show ?thesis .
qed

lemma fbox_star_unfold: "|1]p \<sqinter> |x]|x\<^sup>\<star>]p \<le> |x\<^sup>\<star>]p"
  by (metis compl_le_swap1 double_compl fbox_fdia fbox_one fbox_test fdia_star_unfold fdiamond_def inf_hom mult_onel)

lemma fdia_star_unfold_var: "p \<squnion> |x\<rangle>|x\<^sup>\<star>\<rangle>p \<ge> |x\<^sup>\<star>\<rangle>p"
  by (metis fdia_one fdia_star_unfold)

lemma fbox_star_unfold_var: "p \<sqinter> |x]|x\<^sup>\<star>]p \<le> |x\<^sup>\<star>]p"
  by (metis fbox_one fbox_star_unfold)

lemma fdia_star_unfoldr: "|1\<rangle>p \<squnion> |x\<^sup>\<star>\<rangle>|x\<rangle>p \<ge> |x\<^sup>\<star>\<rangle>p"
proof -
  have "|x\<^sup>\<star>\<rangle>p = |1 + x\<^sup>\<star>\<cdot>x\<rangle>p"
    by (metis star_unfoldr_eq)
  also have "... = |1\<rangle>p \<squnion> |x\<^sup>\<star>\<cdot>x\<rangle>p"
    by (metis fdia_add)
  also have "... \<le> |1\<rangle>p \<squnion> |x\<^sup>\<star>\<rangle>|x\<rangle>p"
    by (metis add_iso_var fdia_mult inf.orderI inf_idem order_hom sup_hom)
  finally show ?thesis .
qed

lemma fbox_star_unfoldr: "|1]p \<sqinter> |x\<^sup>\<star>]|x]p \<le> |x\<^sup>\<star>]p"
  by (metis compl_le_swap1 double_compl fbox_fdia fbox_one fbox_test fdia_star_unfoldr fdiamond_def inf_hom mult_onel)

lemma fdia_star_unfoldr_var: "p \<squnion> |x\<^sup>\<star>\<rangle>|x\<rangle>p \<ge> |x\<^sup>\<star>\<rangle>p"
  by (metis fdia_one fdia_star_unfoldr)

lemma fbox_star_unfoldr_var: "p \<sqinter> |x\<^sup>\<star>]|x]p \<le> |x\<^sup>\<star>]p"
  by (metis fbox_one fbox_star_unfoldr)

lemma fdia_star_induct_var: "|x\<rangle>p \<le> p \<Longrightarrow> |x\<^sup>\<star>\<rangle>p \<le> p"
  by (metis fdemodalisation3 star_sim1)

lemma fbox_star_induct_var: "p \<le> |x]p \<Longrightarrow> p \<le> |x\<^sup>\<star>]p"
  by (metis fbox_demodalisation3 star_sim2)

lemma fdia_star_induct: "q \<squnion> |x\<rangle>p \<le> p \<Longrightarrow> |x\<^sup>\<star>\<rangle>q \<le> p"
  by (metis (hide_lams, no_types) fdia_star_induct_var fdia_subdist_2 inf_sup_aci(1) le_iff_inf le_iff_sup sup.bounded_iff)

lemma fbox_star_induct: "p \<le> q \<sqinter> |x]p \<Longrightarrow>  p \<le> |x\<^sup>\<star>]q"
proof -
  assume "p \<le> q \<sqinter> | x ] p"
  hence f1: "p \<sqinter> (q \<sqinter> | x ] p) = p"
    by (metis inf_absorb2 inf_commute)
  hence "p \<le> | x ] p"
    by (metis inf.cobounded2 inf_assoc)
  thus "p \<le> | x\<^sup>\<star> ] q"
    using f1 by (metis fbox_add1 fbox_star_induct_var inf.boundedE)
qed

lemma fdia_star_induct_eq: "q \<squnion> |x\<rangle>p = p \<Longrightarrow> |x\<^sup>\<star>\<rangle>q \<le> p"
  by (metis fdia_star_induct order_refl)

lemma fbox_star_induct_eq: "q \<sqinter> |x]p = p \<Longrightarrow> p \<le> |x\<^sup>\<star>]q"
  by (metis d_greater d_identity fbox_star_induct)

end

locale local_domain_semiring = domain_semiring +
  assumes fbox_locality: "|x]p * q \<le> |x](p * q)"
begin

lemma fbox_frame: "p \<le> |x]q \<Longrightarrow> p * r \<le> |x](q * r)"
  by (metis fbox_locality Sup.qisor Sup.order_trans)

end

context kad
begin

definition ht :: "'a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool" ("\<turnstile> _ _ _" [55,0,55] 50) where "\<turnstile> p x q \<longleftrightarrow> p \<le> |x]q"

lemma hl_skip: "p \<le> q \<Longrightarrow> \<turnstile> p 1 q"
  by (metis fbox_one ht_def)

lemma hl_strengthen: "q \<le> q' \<Longrightarrow> \<turnstile> p 1 q \<Longrightarrow> \<turnstile> p 1 q'"
  by (metis fbox_one ht_def inf.boundedE inf_absorb2)

lemma hl_weaken: "p' \<le> p \<Longrightarrow> \<turnstile> p 1 q \<Longrightarrow> \<turnstile> p' 1 q"
  by (metis fbox_one hl_strengthen ht_def)

lemma hl_seq: "\<turnstile> p x r \<Longrightarrow> \<turnstile> r y q \<Longrightarrow> \<turnstile> p x\<cdot>y q"
  by (metis (full_types) fbox_iso fbox_mult ht_def inf.boundedE inf_absorb2)

lemma hl_choice: "\<turnstile> p x q \<Longrightarrow> \<turnstile> p y q \<Longrightarrow> \<turnstile> p x + y q"
  by (metis ht_def inf_greatest fbox_add2)

lemma hl_iteration: "\<turnstile> p x p \<Longrightarrow> \<turnstile> p x\<^sup>\<star> p"
  by (metis fbox_star_induct_var ht_def)

end

locale local_kad = kad + local_domain_semiring
begin

lemma sl_frame: "\<turnstile> p x q \<Longrightarrow> \<turnstile> (p * r) x (q * r)"
  by (metis fbox_frame ht_def)

end

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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_MSortBUCount
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

fun map :: "('a => 'b) => 'a list => 'b list" where
  "map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

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

fun lmerge :: "Nat list => Nat list => Nat list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(Nat list) list => (Nat list) list" where
  "pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu :: "(Nat list) list => Nat list" where
  "mergingbu (nil2) = nil2"
| "mergingbu (cons2 xs (nil2)) = xs"
| "mergingbu (cons2 xs (cons2 z x2)) =
     mergingbu (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun msortbu :: "Nat list => Nat list" where
  "msortbu x = mergingbu (map (% (y :: Nat) => cons2 y (nil2)) 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 (msortbu xs)) = (count x xs))"
  oops

end


theory Missing_Multiset
imports Main "~~/src/HOL/Library/Multiset" "~~/src/HOL/Library/Disjoint_Sets"
begin

lemma image_mset_If:
  "image_mset (\<lambda>x. if P x then f x else g x) A =
     image_mset f (filter_mset P A) + image_mset g (filter_mset (\<lambda>x. \<not>P x) A)"
  by (induction A) (auto simp: add_ac)

lemma mset_set_Union:
  "finite A \<Longrightarrow> finite B \<Longrightarrow> A \<inter> B = {} \<Longrightarrow> mset_set (A \<union> B) = mset_set A + mset_set B"
  by (induction A rule: finite_induct) (auto simp: add_ac)

lemma filter_mset_mset_set [simp]:
  "finite A \<Longrightarrow> filter_mset P (mset_set A) = mset_set {x\<in>A. P x}"
proof (induction A rule: finite_induct)
  case (insert x A)
  from insert.hyps have "filter_mset P (mset_set (insert x A)) =
      filter_mset P (mset_set A) + mset_set (if P x then {x} else {})"
    by (simp add: add_ac)
  also have "filter_mset P (mset_set A) = mset_set {x\<in>A. P x}"
    by (rule insert.IH)
  also from insert.hyps
    have "\<dots> + mset_set (if P x then {x} else {}) =
            mset_set ({x \<in> A. P x} \<union> (if P x then {x} else {}))" (is "_ = mset_set ?A")
     by (intro mset_set_Union [symmetric]) simp_all
  also from insert.hyps have "?A = {y\<in>insert x A. P y}" by auto
  finally show ?case .
qed simp_all

lemma image_mset_Diff:
  assumes "B \<subseteq># A"
  shows   "image_mset f (A - B) = image_mset f A - image_mset f B"
proof -
  have "image_mset f (A - B + B) = image_mset f (A - B) + image_mset f B"
    by simp
  also from assms have "A - B + B = A"
    by (simp add: subset_mset.diff_add)
  finally show ?thesis by simp
qed

lemma mset_set_Diff:
  assumes "finite A" "B \<subseteq> A"
  shows  "mset_set (A - B) = mset_set A - mset_set B"
proof -
  from assms have "mset_set ((A - B) \<union> B) = mset_set (A - B) + mset_set B"
    by (intro mset_set_Union) (auto dest: finite_subset)
  also from assms have "A - B \<union> B = A" by blast
  finally show ?thesis by simp
qed

lemma bij_betw_UNION_disjoint:
  assumes disj: "disjoint_family_on A' I"
  assumes bij: "\<And>i. i \<in> I \<Longrightarrow> bij_betw f (A i) (A' i)"
  shows   "bij_betw f (\<Union>i\<in>I. A i) (\<Union>i\<in>I. A' i)"
unfolding bij_betw_def
proof
  from bij show eq: "f ` UNION I A = UNION I A'"
    by (auto simp: bij_betw_def image_UN)
  show "inj_on f (UNION I A)"
  proof (rule inj_onI, clarify)
    fix i j x y assume A: "i \<in> I" "j \<in> I" "x \<in> A i" "y \<in> A j" and B: "f x = f y"
    from A bij[of i] bij[of j] have "f x \<in> A' i" "f y \<in> A' j"
      by (auto simp: bij_betw_def)
    with B have "A' i \<inter> A' j \<noteq> {}" by auto
    with disj A have "i = j" unfolding disjoint_family_on_def by blast
    with A B bij[of i] show "x = y" by (auto simp: bij_betw_def dest: inj_onD)
  qed
qed

lemma mset_set_empty_iff: "mset_set A = {#} \<longleftrightarrow> A = {} \<or> infinite A"
  using finite_set_mset_mset_set by fastforce

lemma size_mset_set [simp]: "size (mset_set A) = card A"
  by (simp only: size_eq_msetsum card_eq_setsum setsum_unfold_msetsum)

lemma count_image_mset:
  "count (image_mset f A) x = (\<Sum>y\<in>f -` {x} \<inter> set_mset A. count A y)"
  by (induction A)
     (auto simp: setsum.distrib setsum.delta' intro!: setsum.mono_neutral_left)

end


section \<open>Stochastic Dominance\<close>

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

(* TODO MOVE *)

(* linordered_nonzero_semiring in isabelle-dev *)
lemma indicator_leI:
  "(x \<in> A \<Longrightarrow> y \<in> B) \<Longrightarrow> (indicator A x :: 'a :: linordered_semidom) \<le> indicator B y"
  by (auto simp: indicator_def)

lemma le_diff_iff': "a \<le> c \<Longrightarrow> b \<le> c \<Longrightarrow> c - a \<le> c - b \<longleftrightarrow> b \<le> (a::nat)"
  by linarith

lemma setsum_lessThan_Suc_shift:
  "(\<Sum>i<Suc n. f i) = f 0 + (\<Sum>i<n. f (Suc i))"
  by (induction n) (simp_all add: add_ac)

lemma measure_return_pmf [simp]: "measure_pmf.prob (return_pmf x) A = indicator A x"
proof -
  have "ereal (measure_pmf.prob (return_pmf x) A) =
          emeasure (measure_pmf (return_pmf x)) A"
    by (simp add: measure_pmf.emeasure_eq_measure)
  also have "\<dots> = ereal (indicator A x)" by (simp add: ereal_indicator)
  finally show ?thesis by simp
qed

lemma (in preorder_on) preferred_alts_refl [simp]: "x \<in> carrier \<Longrightarrow> x \<in> preferred_alts le x"
  by (simp add: preferred_alts_def refl)

lemma measure_pmf_ge_1: "measure_pmf.prob p A \<ge> 1 \<longleftrightarrow> measure_pmf.prob p A = 1"
  by (auto intro!: antisym)

lemma measure_pmf_posI: "x \<in> set_pmf p \<Longrightarrow> x \<in> A \<Longrightarrow> measure_pmf.prob p A > 0"
  using measure_measure_pmf_not_zero[of p A] by (subst zero_less_measure_iff) blast

(* END TODO *)

subsection \<open>Definition of Stochastic Dominance\<close>

text \<open>
  This is the definition of stochastic dominance. It lifts a preference relation
  on alternatives to the stochastic dominance ordering on lotteries.
\<close>
definition SD :: "'alt relation \<Rightarrow> 'alt lottery relation" where
  "p \<succeq>[SD(R)] q \<longleftrightarrow> p \<in> lotteries_on {x. R x x} \<and> q \<in> lotteries_on {x. R x x} \<and>
      (\<forall>x. R x x \<longrightarrow> measure_pmf.prob p {y. y \<succeq>[R] x} \<ge>
                       measure_pmf.prob q {y. y \<succeq>[R] x})"

lemma SD_empty [simp]: "SD (\<lambda>_ _. False) = (\<lambda>_ _. False)"
  by (auto simp: fun_eq_iff SD_def lotteries_on_def set_pmf_not_empty)

text \<open>
  Stochastic dominance over any relation is a preorder.
\<close>
lemma SD_refl: "p \<preceq>[SD(R)] p \<longleftrightarrow> p \<in> lotteries_on {x. R x x}"
  by (simp add: SD_def)

lemma SD_trans [simp, trans]: "p \<preceq>[SD(R)] q \<Longrightarrow> q \<preceq>[SD(R)] r \<Longrightarrow> p \<preceq>[SD(R)] r"
  unfolding SD_def by (auto intro: order.trans)

lemma SD_is_preorder: "preorder_on (lotteries_on {x. R x x}) (SD R)"
  by unfold_locales (auto simp: SD_def intro: order.trans)

context preorder_on
begin

lemma SD_preorder:
   "p \<succeq>[SD(le)] q \<longleftrightarrow> p \<in> lotteries_on carrier \<and> q \<in> lotteries_on carrier \<and>
      (\<forall>x\<in>carrier. measure_pmf.prob p (preferred_alts le x) \<ge>
                     measure_pmf.prob q (preferred_alts le x))"
  by (simp add: SD_def preferred_alts_def carrier_eq)

lemma SD_preorderI [intro?]:
  assumes "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
  assumes "\<And>x. x \<in> carrier \<Longrightarrow>
             measure_pmf.prob p (preferred_alts le x) \<ge> measure_pmf.prob q (preferred_alts le x)"
  shows   "p \<succeq>[SD(le)] q"
  using assms by (simp add: SD_preorder)

lemma SD_preorderD:
  assumes "p \<succeq>[SD(le)] q"
  shows   "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
  and      "\<And>x. x \<in> carrier \<Longrightarrow>
             measure_pmf.prob p (preferred_alts le x) \<ge> measure_pmf.prob q (preferred_alts le x)"
  using assms unfolding SD_preorder by simp_all

lemma SD_refl' [simp]: "p \<preceq>[SD(le)] p \<longleftrightarrow> p \<in> lotteries_on carrier"
  by (simp add: SD_def carrier_eq)

lemma SD_is_preorder': "preorder_on (lotteries_on carrier) (SD(le))"
  using SD_is_preorder[of le] by (simp add: carrier_eq)

lemma SD_singleton_left:
  assumes "x \<in> carrier" "q \<in> lotteries_on carrier"
  shows   "return_pmf x \<preceq>[SD(le)] q \<longleftrightarrow> (\<forall>y\<in>set_pmf q. x \<preceq>[le] y)"
proof
  assume SD: "return_pmf x \<preceq>[SD(le)] q"
  from assms SD_preorderD(3)[OF SD, of x]
    have "measure_pmf.prob (return_pmf x) (preferred_alts le x) \<le>
            measure_pmf.prob q (preferred_alts le x)" by simp
  also from assms have "measure_pmf.prob (return_pmf x) (preferred_alts le x) = 1"
    by (simp add: indicator_def)
  finally have "AE y in q. y \<succeq>[le] x"
    by (simp add: measure_pmf_ge_1 measure_pmf.prob_eq_1 preferred_alts_def)
  thus "\<forall>y\<in>set_pmf q. y \<succeq>[le] x" by (simp add: AE_measure_pmf_iff)
next
  assume A: "\<forall>y\<in>set_pmf q. x \<preceq>[le] y"
  show "return_pmf x \<preceq>[SD(le)] q"
  proof (rule SD_preorderI)
    fix y assume y: "y \<in> carrier"
    show "measure_pmf.prob (return_pmf x) (preferred_alts le y)
              \<le> measure_pmf.prob q (preferred_alts le y)"
    proof (cases "y \<preceq>[le] x")
      case True
      from True A have "measure_pmf.prob q (preferred_alts le y) = 1"
        by (auto simp: AE_measure_pmf_iff measure_pmf.prob_eq_1 preferred_alts_def intro: trans)
      thus ?thesis by simp
    qed (simp_all add: preferred_alts_def indicator_def measure_nonneg)
  qed (insert assms, simp_all add: lotteries_on_def)
qed

lemma SD_singleton_right:
  assumes x: "x \<in> carrier" and q: "q \<in> lotteries_on carrier"
  shows   "q \<preceq>[SD(le)] return_pmf x \<longleftrightarrow> (\<forall>y\<in>set_pmf q. y \<preceq>[le] x)"
proof safe
  fix y assume SD: "q \<preceq>[SD(le)] return_pmf x" and y: "y \<in> set_pmf q"
  from y assms have [simp]: "y \<in> carrier" by (auto simp: lotteries_on_def)

  from y have "0 < measure_pmf.prob q (preferred_alts le y)"
    by (rule measure_pmf_posI) simp_all
  also have "\<dots> \<le> measure_pmf.prob (return_pmf x) (preferred_alts le y)"
    by (rule SD_preorderD(3)[OF SD]) simp_all
  finally show "y \<preceq>[le] x"
    by (auto simp: indicator_def preferred_alts_def split: if_splits)
next
  assume A: "\<forall>y\<in>set_pmf q. y \<preceq>[le] x"
  show "q \<preceq>[SD(le)] return_pmf x"
  proof (rule SD_preorderI)
    fix y assume y: "y \<in> carrier"
    show "measure_pmf.prob q (preferred_alts le y) \<le>
            measure_pmf.prob (return_pmf x) (preferred_alts le y)"
    proof (cases "y \<preceq>[le] x")
      case False
      with A show ?thesis
        by (auto simp: preferred_alts_def indicator_def measure_le_0_iff
                       measure_pmf.prob_eq_0 AE_measure_pmf_iff intro: trans)
    qed (simp_all add: indicator_def preferred_alts_def)
  qed (insert assms, simp_all add: lotteries_on_def)
qed

lemma SD_strict_singleton_left:
  assumes "x \<in> carrier" "q \<in> lotteries_on carrier"
  shows   "return_pmf x \<prec>[SD(le)] q \<longleftrightarrow> (\<forall>y\<in>set_pmf q. x \<preceq>[le] y) \<and> (\<exists>y\<in>set_pmf q. (x \<prec>[le] y))"
  using assms by (auto simp add: strongly_preferred_def SD_singleton_left SD_singleton_right)

lemma SD_strict_singleton_right:
  assumes "x \<in> carrier" "q \<in> lotteries_on carrier"
  shows   "q \<prec>[SD(le)] return_pmf x \<longleftrightarrow> (\<forall>y\<in>set_pmf q. y \<preceq>[le] x) \<and> (\<exists>y\<in>set_pmf q. (y \<prec>[le] x))"
  using assms by (auto simp add: strongly_preferred_def SD_singleton_left SD_singleton_right)

lemma SD_singleton [simp]:
  "x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> return_pmf x \<preceq>[SD(le)] return_pmf y \<longleftrightarrow> x \<preceq>[le] y"
  by (subst SD_singleton_left) (simp_all add: lotteries_on_def)

lemma SD_strict_singleton [simp]:
  "x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> return_pmf x \<prec>[SD(le)] return_pmf y \<longleftrightarrow> x \<prec>[le] y"
  by (simp add: strongly_preferred_def)

end

context pref_profile_wf
begin

context
fixes i assumes i: "i \<in> agents"
begin

interpretation Ri: preorder_on alts "R i" by (simp add: i)

lemmas SD_singleton_left = Ri.SD_singleton_left
lemmas SD_singleton_right = Ri.SD_singleton_right
lemmas SD_strict_singleton_left = Ri.SD_strict_singleton_left
lemmas SD_strict_singleton_right = Ri.SD_strict_singleton_right
lemmas SD_singleton = Ri.SD_singleton
lemmas SD_strict_singleton = Ri.SD_strict_singleton

end
end

lemmas (in pref_profile_wf) [simp] = SD_singleton SD_strict_singleton

subsection \<open>Stochastic Dominance for preference profiles\<close>

context pref_profile_wf
begin

lemma SD_pref_profile:
  assumes "i \<in> agents"
  shows   "p \<succeq>[SD(R i)] q \<longleftrightarrow> p \<in> lotteries_on alts \<and> q \<in> lotteries_on alts \<and>
             (\<forall>x\<in>alts. measure_pmf.prob p (preferred_alts (R i) x) \<ge>
                         measure_pmf.prob q (preferred_alts (R i) x))"
proof -
  from assms interpret total_preorder_on alts "R i" by simp
  have "preferred_alts (R i) x = {y. y \<succeq>[R i] x}" for x using not_outside
    by (auto simp: preferred_alts_def)
  thus ?thesis by (simp add: SD_preorder preferred_alts_def)
qed

lemma SD_pref_profileI [intro?]:
  assumes "i \<in> agents" "p \<in> lotteries_on alts" "q \<in> lotteries_on alts"
  assumes "\<And>x. x \<in> alts \<Longrightarrow>
             measure_pmf.prob p (preferred_alts (R i) x) \<ge>
             measure_pmf.prob q (preferred_alts (R i) x)"
  shows   "p \<succeq>[SD(R i)] q"
  using assms by (simp add: SD_pref_profile)

lemma SD_pref_profileD:
  assumes "i \<in> agents" "p \<succeq>[SD(R i)] q"
  shows   "p \<in> lotteries_on alts" "q \<in> lotteries_on alts"
  and     "\<And>x. x \<in> alts \<Longrightarrow>
             measure_pmf.prob p (preferred_alts (R i) x) \<ge>
             measure_pmf.prob q (preferred_alts (R i) x)"
  using assms by (simp_all add: SD_pref_profile)

end

subsection \<open>SD efficient lotteries\<close>

definition SD_efficient :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt lottery \<Rightarrow> bool" where
  SD_efficient_auxdef:
    "SD_efficient R p \<longleftrightarrow> \<not>(\<exists>q\<in>lotteries_on {x. \<exists>i. R i x x}. q \<succ>[Pareto (SD \<circ> R)] p)"

context pref_profile_wf
begin

sublocale SD: preorder_family agents "lotteries_on alts" "SD \<circ> R" unfolding o_def
  by (intro preorder_family.intro SD_is_preorder)
     (simp_all add: preorder_on.SD_is_preorder' prefs_undefined')

text \<open>
  A lottery is considered SD-efficient if there is no other lottery such that
  all agents weakly prefer the other lottery (w.r.t. stochastic dominance) and at least
  one agent strongly prefers the other lottery.
\<close>
lemma SD_efficient_def:
  "SD_efficient R p \<longleftrightarrow> \<not>(\<exists>q\<in>lotteries_on alts. q \<succ>[Pareto (SD \<circ> R)] p)"
proof -
  have "SD_efficient R p \<longleftrightarrow> \<not>(\<exists>q\<in>lotteries_on {x. \<exists>i. R i x x}. q \<succ>[Pareto (SD \<circ> R)] p)"
    unfolding SD_efficient_auxdef ..
  also from nonempty_agents obtain i where i: "i \<in> agents" by blast
  with preorder_on.refl[of alts "R i"]
    have "{x. \<exists>i. R i x x} = alts" by (auto intro!: exI[of _ i] not_outside)
  finally show ?thesis .
qed

lemma SD_efficient_def':
  "SD_efficient R p \<longleftrightarrow>
     \<not>(\<exists>q\<in>lotteries_on alts. (\<forall>i\<in>agents. q \<succeq>[SD(R i)] p) \<and> (\<exists>i\<in>agents. q \<succ>[SD(R i)] p))"
  unfolding SD_efficient_def SD.Pareto_iff strongly_preferred_def [abs_def] by auto

lemma SD_inefficientI:
  assumes "q \<in> lotteries_on alts" "\<And>i. i \<in> agents \<Longrightarrow> q \<succeq>[SD(R i)] p"
          "i \<in> agents" "q \<succ>[SD(R i)] p"
  shows   "\<not>SD_efficient R p"
  using assms unfolding SD_efficient_def' by blast

lemma SD_inefficientI':
  assumes "q \<in> lotteries_on alts" "\<And>i. i \<in> agents \<Longrightarrow> q \<succeq>[SD(R i)] p"
          "\<exists>i \<in> agents. q \<succ>[SD(R i)] p"
  shows   "\<not>SD_efficient R p"
  using assms unfolding SD_efficient_def' by blast

lemma SD_inefficientE:
  assumes "\<not>SD_efficient R p"
  obtains q i where
    "q \<in> lotteries_on alts" "\<And>i. i \<in> agents \<Longrightarrow> q \<succeq>[SD(R i)] p"
    "i \<in> agents" "q \<succ>[SD(R i)] p"
  using assms unfolding SD_efficient_def' by blast

lemma SD_efficientD:
  assumes "SD_efficient R p" "q \<in> lotteries_on alts"
      and "\<And>i. i \<in> agents \<Longrightarrow> q \<succeq>[SD(R i)] p" "\<exists>i\<in>agents. \<not>(q \<preceq>[SD(R i)] p)"
  shows False
  using assms unfolding SD_efficient_def' strongly_preferred_def by blast

lemma SD_efficient_singleton_iff:
  assumes [simp]: "x \<in> alts"
  shows   "SD_efficient R (return_pmf x) \<longleftrightarrow> x \<notin> pareto_losers R"
proof -
  {
    assume x: "x \<in> pareto_losers R"
    from pareto_losersE[OF x] guess y . note y = this
    from y have "\<not>SD_efficient R (return_pmf x)"
      by (intro SD_inefficientI'[of "return_pmf y"]) (force simp: Pareto_strict_iff)+
  } moreover {
    assume "\<not>SD_efficient R (return_pmf x)"
    from SD_inefficientE[OF this] guess q i . note q = this
    moreover from q obtain y where "y \<in> set_pmf q" "y \<succ>[R i] x"
      by (auto simp: SD_strict_singleton_left)
    ultimately have "y \<succ>[Pareto(R)] x"
      by (fastforce simp: Pareto_strict_iff SD_singleton_left)
    hence "x \<in> pareto_losers R" by simp
  }
  ultimately show ?thesis by blast
qed

end

subsection \<open>Equivalence proof\<close>

text \<open>
  We now show that a lottery is preferred w.r.t. Stochastic Dominance iff
  it yields more expected utility for all compatible utility functions.
\<close>

context finite_total_preorder_on
begin

abbreviation "is_vnm_utility \<equiv> vnm_utility carrier le"

lemma utility_weak_ranking_index:
  "is_vnm_utility (\<lambda>x. real (length (weak_ranking le) - weak_ranking_index x))"
proof
  fix x y assume xy: "x \<in> carrier" "y \<in> carrier"
  with this[THEN nth_weak_ranking_index(1)] this[THEN nth_weak_ranking_index(2)]
    show "(real (length (weak_ranking le) - weak_ranking_index x)
            \<le> real (length (weak_ranking le) - weak_ranking_index y)) \<longleftrightarrow> le x y"
    by (simp add: le_diff_iff')
qed

(*
  TODO: one direction could probably be generalised to weakly consistent
  utility functions
*)
lemma SD_iff_expected_utilities_le:
  assumes "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
  shows   "p \<preceq>[SD(le)] q \<longleftrightarrow>
             (\<forall>u. is_vnm_utility u \<longrightarrow> measure_pmf.expectation p u \<le> measure_pmf.expectation q u)"
proof safe
  fix u assume SD: "p \<preceq>[SD(le)] q" and is_utility: "is_vnm_utility u"
  from is_utility interpret vnm_utility carrier le u .
  def xs \<equiv> "weak_ranking le"
  have le: "is_weak_ranking xs" "le = of_weak_ranking xs"
    by (simp_all add: xs_def weak_ranking_total_preorder)

  let ?pref = "\<lambda>p x. measure_pmf.prob p {y. x \<preceq>[le] y}" and
      ?pref' = "\<lambda>p x. measure_pmf.prob p {y. x \<prec>[le] y}"
  def f \<equiv> "\<lambda>i. SOME x. x \<in> xs ! i"
  have xs_wf: "is_weak_ranking xs"
    by (simp add: xs_def weak_ranking_total_preorder)
  hence f: "f i \<in> xs ! i" if "i < length xs" for i
    using that unfolding f_def is_weak_ranking_def
    by (intro someI_ex[of "\<lambda>x. x \<in> xs ! i"]) (auto simp: set_conv_nth)
  have f': "f i \<in> carrier" if "i < length xs" for i
    using that f weak_ranking_Union unfolding xs_def by (auto simp: set_conv_nth)
  def n \<equiv> "length xs - 1"
  from assms weak_ranking_Union have carrier_nonempty: "carrier \<noteq> {}" and "xs \<noteq> []"
    by (auto simp: xs_def lotteries_on_def set_pmf_not_empty)
  hence n: "length xs = Suc n" and xs_nonempty: "xs \<noteq> []" by (auto simp add: n_def)
  have SD': "?pref p (f i) \<le> ?pref q (f i)" if "i < length xs" for i
    using f'[OF that] SD by (auto simp: SD_preorder preferred_alts_def)
  have f_le: "le (f i) (f j) \<longleftrightarrow> i \<ge> j" if "i < length xs" "j < length xs" for i j
    using that weak_ranking_index_unique[OF xs_wf that(1) _ f]
               weak_ranking_index_unique[OF xs_wf that(2) _ f]
    by (auto simp add: le intro: f elim!: of_weak_ranking.cases intro!: of_weak_ranking.intros)

  have "measure_pmf.expectation p u =
          (\<Sum>i<n. (u (f i) - u (f (Suc i))) * ?pref p (f i)) + u (f n)"
    if p: "p \<in> lotteries_on carrier" for p
  proof -
    from p have "measure_pmf.expectation p u =
                   (\<Sum>i<length xs. u (f i) * measure_pmf.prob p (xs ! i))"
      by (simp add: f_def expected_utility_weak_ranking xs_def listsum_setsum_nth atLeast0LessThan)
    also have "\<dots> = (\<Sum>i<length xs. u (f i) * (?pref p (f i) - ?pref' p (f i)))"
    proof (intro setsum.cong HOL.refl)
      fix i assume i: "i \<in> {..<length xs}"
      have "?pref p (f i) - ?pref' p (f i) =
              measure_pmf.prob p ({y. f i \<preceq>[le] y} - {y. f i \<prec>[le] y})"
        by (subst measure_pmf.finite_measure_Diff [symmetric])
           (auto simp: strongly_preferred_def)
      also have "{y. f i \<preceq>[le] y} - {y. f i \<prec>[le] y} =
                   {y. f i \<preceq>[le] y \<and> y \<preceq>[le] f i}" (is "_ = ?A")
        by (auto simp: strongly_preferred_def)
      also have "\<dots> = xs ! i"
      proof safe
        fix x assume le: "le (f i) x" "le x (f i)"
        from i f show "x \<in> xs ! i"
          by (intro weak_ranking_eqclass2[OF _ _ le]) (auto simp: xs_def)
      next
        fix x assume "x \<in> xs ! i"
        from weak_ranking_eqclass1[OF _ this f] weak_ranking_eqclass1[OF _ f this] i
          show "le x (f i)" "le (f i) x" by (simp_all add: xs_def)
      qed
      finally show "u (f i) * measure_pmf.prob p (xs ! i) =
                      u (f i) * (?pref p (f i) - ?pref' p (f i))" by simp
    qed
    also have "\<dots> = (\<Sum>i<length xs. u (f i) * ?pref p (f i)) -
                      (\<Sum>i<length xs. u (f i) * ?pref' p (f i))"
      by (simp add: setsum_subtractf ring_distribs)
    also have "(\<Sum>i<length xs. u (f i) * ?pref p (f i)) =
                 (\<Sum>i<n. u (f i) * ?pref p (f i)) + u (f n) * ?pref p (f n)" (is "_ = ?sum")
      by (simp add: n)
    also have "(\<Sum>i<length xs. u (f i) * ?pref' p (f i)) =
                 (\<Sum>i<n. u (f (Suc i)) * ?pref' p (f (Suc i))) + u (f 0) * ?pref' p (f 0)"
      unfolding n setsum_lessThan_Suc_shift by simp
    also have "(\<Sum>i<n. u (f (Suc i)) * ?pref' p (f (Suc i))) =
                 (\<Sum>i<n. u (f (Suc i)) * ?pref p (f i))"
    proof (intro setsum.cong HOL.refl)
      fix i assume i: "i \<in> {..<n}"
      have "f (Suc i) \<prec>[le] y \<longleftrightarrow> f i \<preceq>[le] y" for y
      proof (cases "y \<in> carrier")
        assume "y \<in> carrier"
        with weak_ranking_Union obtain j where j: "j < length xs" "y \<in> xs ! j"
          by (auto simp: set_conv_nth xs_def)
        with weak_ranking_eqclass1[OF _ f j(2)] weak_ranking_eqclass1[OF _ j(2) f]
          have iff: "le y z \<longleftrightarrow> le (f j) z" "le z y \<longleftrightarrow> le z (f j)" for z
          by (auto intro: trans simp: xs_def)
        thus ?thesis using i j unfolding n_def
          by (auto simp: iff f_le strongly_preferred_def)
      qed (insert not_outside, auto simp: strongly_preferred_def)
      thus "u (f (Suc i)) * ?pref' p (f (Suc i)) = u (f (Suc i)) * ?pref p (f i)" by simp
    qed
    also have "?sum - (\<dots> + u (f 0) * ?pref' p (f 0)) =
      (\<Sum>i<n. (u (f i) - u (f (Suc i))) * ?pref p (f i)) -
       u (f 0) * ?pref' p (f 0) + u (f n) * ?pref p (f n)"
         by (simp add: ring_distribs setsum_subtractf)
    also have "{y. f 0 \<prec>[le] y} = {}"
      using hd_weak_ranking[of "f 0"] xs_nonempty f not_outside
      by (auto simp: hd_conv_nth xs_def strongly_preferred_def)
    also have "{y. le (f n) y} = carrier"
      using last_weak_ranking[of "f n"] xs_nonempty f not_outside
      by (auto simp: last_conv_nth xs_def n_def)
    also from p have "measure_pmf.prob p carrier = 1"
      by (subst measure_pmf.prob_eq_1)
         (auto simp: AE_measure_pmf_iff lotteries_on_def)
    finally show ?thesis by simp
  qed

  from assms[THEN this] show "measure_pmf.expectation p u \<le> measure_pmf.expectation q u"
    unfolding SD_preorder n_def using f'
    by (auto intro!: setsum_mono mult_left_mono SD' simp: utility_le_iff f_le)

next
  assume "\<forall>u. is_vnm_utility u \<longrightarrow> measure_pmf.expectation p u \<le> measure_pmf.expectation q u"
  hence expected_utility_le: "measure_pmf.expectation p u \<le> measure_pmf.expectation q u"
    if "is_vnm_utility u" for u using that by blast
  def xs \<equiv> "weak_ranking le"
  have le: "le = of_weak_ranking xs" and [simp]: "is_weak_ranking xs"
    by (simp_all add: xs_def weak_ranking_total_preorder)
  have carrier: "carrier = \<Union>set xs"
    by (simp add: xs_def weak_ranking_Union)
  from assms have carrier_nonempty: "carrier \<noteq> {}"
    by (auto simp: lotteries_on_def set_pmf_not_empty)

  {
    fix x assume x: "x \<in> carrier"
    let ?idx = "\<lambda>y. length xs - weak_ranking_index y"
    have preferred_subset_carrier: "{y. le x y} \<subseteq> carrier"
      using not_outside x by auto
    have "measure_pmf.prob p {y. le x y} / real (length xs) \<le>
             measure_pmf.prob q {y. le x y} / real (length xs)"
    proof (rule field_le_epsilon)
      fix \<epsilon> :: real assume \<epsilon>: "\<epsilon> > 0"
      def u \<equiv> "\<lambda>y. indicator {y. y \<succeq>[le] x} y + \<epsilon> * ?idx y"
      have is_utility: "is_vnm_utility u" unfolding u_def xs_def
      proof (intro vnm_utility.add_left vnm_utility.scaled utility_weak_ranking_index)
        fix y z assume "le y z"
        thus "indicator {y. y \<succeq>[le] x} y \<le> (indicator {y. y \<succeq>[le] x} z :: real)"
          by (auto intro: trans simp: indicator_def split: if_splits)
      qed fact+

      have "(\<Sum>y|le x y. pmf p y) \<le>
              (\<Sum>y|le x y. pmf p y) + \<epsilon> * (\<Sum>y\<in>carrier. ?idx y * pmf p y)"
        using \<epsilon> by (auto intro!: mult_nonneg_nonneg setsum_nonneg pmf_nonneg)
      also from expected_utility_le is_utility have
        "measure_pmf.expectation p u \<le> measure_pmf.expectation q u" .
      with assms
        have "(\<Sum>a\<in>carrier. u a * pmf p a) \<le> (\<Sum>a\<in>carrier. u a * pmf q a)"
        by (subst (asm) (1 2) integral_measure_pmf[OF finite_carrier])
           (auto simp: lotteries_on_def set_pmf_eq)
      hence "(\<Sum>y|le x y. pmf p y) + \<epsilon> * (\<Sum>y\<in>carrier. ?idx y * pmf p y) \<le>
               (\<Sum>y|le x y. pmf q y) + \<epsilon> * (\<Sum>y\<in>carrier. ?idx y * pmf q y)"
        using x preferred_subset_carrier unfolding u_def
        by (simp add: setsum.distrib finite_carrier algebra_simps Int_absorb1 setsum_right_distrib)
      also have "(\<Sum>y\<in>carrier. ?idx y * pmf q y) \<le> (\<Sum>y\<in>carrier. length xs * pmf q y)"
        by (intro setsum_mono mult_right_mono) (simp_all add: pmf_nonneg)
      also have "\<dots> = measure_pmf.expectation q (\<lambda>_. length xs)"
        using assms by (subst integral_measure_pmf[OF finite_carrier])
                       (auto simp: lotteries_on_def set_pmf_eq)
      also have "\<dots> = length xs" by simp
      also have "(\<Sum>y | le x y. pmf p y) = measure_pmf.prob p {y. le x y}"
        using finite_subset[OF preferred_subset_carrier finite_carrier]
        by (simp add: measure_measure_pmf_finite)
      also have "(\<Sum>y | le x y. pmf q y) = measure_pmf.prob q {y. le x y}"
        using finite_subset[OF preferred_subset_carrier finite_carrier]
        by (simp add: measure_measure_pmf_finite)
      finally show "measure_pmf.prob p {y. le x y} / length xs \<le>
                      measure_pmf.prob q {y. le x y} / length xs + \<epsilon>"
        using \<epsilon> by (simp add: divide_simps)
    qed
    moreover from carrier_nonempty carrier have "xs \<noteq> []" by auto
    ultimately have "measure_pmf.prob p {y. le x y} \<le>
                       measure_pmf.prob q {y. le x y}"
      by (simp add: field_simps)
  }
  with assms show "p \<preceq>[SD(le)] q" unfolding SD_preorder preferred_alts_def by blast
qed

lemma not_strict_SD_iff:
  assumes "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
  shows   "\<not>(p \<prec>[SD(le)] q) \<longleftrightarrow>
             (\<exists>u. is_vnm_utility u \<and> measure_pmf.expectation q u \<le> measure_pmf.expectation p u)"
proof
  let ?E = "measure_pmf.expectation :: 'a pmf \<Rightarrow> _ \<Rightarrow> real"
  assume "\<exists>u. is_vnm_utility u \<and> ?E p u \<ge> ?E q u"
  then obtain u where u: "is_vnm_utility u" "?E p u \<ge> ?E q u" by blast
  interpret u: vnm_utility carrier le u by fact

  show "\<not> p \<prec>[SD le] q"
  proof
    assume less: "p \<prec>[SD le] q"
    with assms have pq: "?E p u \<le> ?E q u" if "is_vnm_utility u" for u
      using that by (auto simp: SD_iff_expected_utilities_le strongly_preferred_def)
    with u have u_eq: "?E p u = ?E q u" by (intro antisym) simp_all
    from less assms obtain u' where u': "is_vnm_utility u'" "?E p u' < ?E q u'"
      by (auto simp: SD_iff_expected_utilities_le strongly_preferred_def not_le)
    interpret u': vnm_utility carrier le u' by fact

    have "\<exists>\<epsilon>>0. is_vnm_utility (\<lambda>x. u x - \<epsilon> * u' x)"
      by (intro u.diff_epsilon antisym u'.utility_le)
    then guess \<epsilon> by (elim exE conjE) note \<epsilon> = this
    def u'' \<equiv> "\<lambda>x. u x - \<epsilon> * u' x"
    interpret u'': vnm_utility carrier le u'' unfolding u''_def by fact
    have exp_u'': "?E p u'' = ?E p u - \<epsilon> * ?E p u'" if "p \<in> lotteries_on carrier" for p using that
      by (subst (1 2 3) integral_measure_pmf[of carrier])
         (auto simp: lotteries_on_def u''_def algebra_simps setsum_subtractf setsum_right_distrib)
    from assms \<epsilon> have "?E p u'' > ?E q u''"
      by (simp_all add: exp_u'' algebra_simps u_eq u')
    with pq[OF u''.vnm_utility_axioms] show False by simp
  qed
qed (insert assms utility_weak_ranking_index,
     auto simp: strongly_preferred_def SD_iff_expected_utilities_le not_le not_less intro: antisym)

lemma strict_SD_iff:
  assumes "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
  shows   "(p \<prec>[SD(le)] q) \<longleftrightarrow>
             (\<forall>u. is_vnm_utility u \<longrightarrow> measure_pmf.expectation p u < measure_pmf.expectation q u)"
  using not_strict_SD_iff[OF assms] by auto

end

end