(*  Title:      HOL/Proofs/Lambda/ParRed.thy
    Author:     Tobias Nipkow
    Copyright   1995 TU Muenchen

Properties of => and "cd", in particular the diamond property of => and
confluence of beta.
*)

section \<open>Parallel reduction and a complete developments\<close>

theory ParRed imports Lambda Commutation begin

subsection \<open>Parallel reduction\<close>

inductive par_beta :: "[dB, dB] => bool"  (infixl "=>" 50)
  where
    var [simp, intro!]: "Var n => Var n"
  | abs [simp, intro!]: "s => t ==> Abs s => Abs t"
  | app [simp, intro!]: "[| s => s'; t => t' |] ==> s \<degree> t => s' \<degree> t'"
  | beta [simp, intro!]: "[| s => s'; t => t' |] ==> (Abs s) \<degree> t => s'[t'/0]"

inductive_cases par_beta_cases [elim!]:
  "Var n => t"
  "Abs s => Abs t"
  "(Abs s) \<degree> t => u"
  "s \<degree> t => u"
  "Abs s => t"

subsection \<open>Inclusions\<close>

text \<open>\<open>beta \<subseteq> par_beta \<subseteq> beta^*\<close> \medskip\<close>

lemma par_beta_varL [simp]:
    "(Var n => t) = (t = Var n)"
  by blast

lemma par_beta_refl [simp]: "t => t"  (* par_beta_refl [intro!] causes search to blow up *)
  by (induct t) simp_all

lemma beta_subset_par_beta: "beta <= par_beta"
  apply (rule predicate2I)
  apply (erule beta.induct)
     apply (blast intro!: par_beta_refl)+
  done

lemma par_beta_subset_beta: "par_beta <= beta^**"
  apply (rule predicate2I)
  apply (erule par_beta.induct)
     apply blast
    apply (blast del: rtranclp.rtrancl_refl intro: rtranclp.rtrancl_into_rtrancl)+
      \<comment> \<open>@{thm[source] rtrancl_refl} complicates the proof by increasing the branching factor\<close>
  done

subsection \<open>Misc properties of \<open>par_beta\<close>\<close>

lemma par_beta_lift [simp]:
    "t => t' \<Longrightarrow> lift t n => lift t' n"
  by (induct t arbitrary: t' n) fastforce+

lemma par_beta_subst:
    "s => s' \<Longrightarrow> t => t' \<Longrightarrow> t[s/n] => t'[s'/n]"
  apply (induct t arbitrary: s s' t' n)
    apply (simp add: subst_Var)
   apply (erule par_beta_cases)
    apply simp
   apply (simp add: subst_subst [symmetric])
   apply (fastforce intro!: par_beta_lift)
  apply fastforce
  done

subsection \<open>Confluence (directly)\<close>

lemma diamond_par_beta: "diamond par_beta"
  apply (unfold diamond_def commute_def square_def)
  apply (rule impI [THEN allI [THEN allI]])
  apply (erule par_beta.induct)
     apply (blast intro!: par_beta_subst)+
  done

subsection \<open>Complete developments\<close>

fun
  cd :: "dB => dB"
where
  "cd (Var n) = Var n"
| "cd (Var n \<degree> t) = Var n \<degree> cd t"
| "cd ((s1 \<degree> s2) \<degree> t) = cd (s1 \<degree> s2) \<degree> cd t"
| "cd (Abs u \<degree> t) = (cd u)[cd t/0]"
| "cd (Abs s) = Abs (cd s)"

lemma par_beta_cd: "s => t \<Longrightarrow> t => cd s"
  apply (induct s arbitrary: t rule: cd.induct)
      apply auto
  apply (fast intro!: par_beta_subst)
  done

subsection \<open>Confluence (via complete developments)\<close>

lemma diamond_par_beta2: "diamond par_beta"
  apply (unfold diamond_def commute_def square_def)
  apply (blast intro: par_beta_cd)
  done

theorem beta_confluent: "confluent beta"
  apply (rule diamond_par_beta2 diamond_to_confluence
    par_beta_subset_beta beta_subset_par_beta)+
  done

end


theory Iso
imports Basics
begin

locale iso =
  fixes get :: "'s \<Rightarrow> 'a" and "back" :: "'a \<Rightarrow> 's"
  assumes get_back[simp]: "back (get a) = a" and back_get[simp]: "get (back s) = s"
begin

definition modify :: "('a \<Rightarrow> 'a) \<Rightarrow> 's \<Rightarrow> 's" where
[optics]: "modify f s = back (f (get s))"

lemma modify_id[simp]: "modify id = id"
unfolding modify_def[abs_def] id_def by simp

lemma modify_comp[simp]: "modify (f \<circ> g) = modify f \<circ> modify g"
unfolding modify_def[abs_def] comp_def by simp

end

lemma bij_iso[intro]:
  assumes "bij f" shows "iso f (inv f)"
proof
  fix a
  show "inv f (f a) = a"
    using assms unfolding bij_betw_def by (simp add: inv_f_f)
next
  fix s
  show "f (inv f s) = s"
    using assms unfolding bij_betw_def by (simp add: surj_f_inv_f)
qed

locale rev_iso =
  inner: iso f g for f g
begin

definition [optics]: "get = g"
definition [optics]: "back = f"

sublocale iso "back" get
by unfold_locales (auto simp: get_def back_def)

end

locale product_iso =
  fst: iso f g + snd: iso h i for f :: "'s \<Rightarrow> 'a" and g and h :: "'t \<Rightarrow> 'b" and i
begin

fun get :: "'s \<times> 't \<Rightarrow> 'a \<times> 'b" where
"get (s, t) = (f s, h t)"

fun "back" :: "'a \<times> 'b \<Rightarrow> 's \<times> 't" where
"back (a, b) = (g a, i b)"

sublocale iso get "back"
by unfold_locales auto

end

locale compose_iso_iso =
  one: iso f g + two: iso h i for f :: "'s \<Rightarrow> 'a" and g and h :: "'a \<Rightarrow> 'b" and i
begin

definition [optics]: "get = h \<circ> f"
definition [optics]: "back = g \<circ> i"

sublocale iso get "back"
by unfold_locales (auto simp: get_def back_def)

end

end


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


section \<open>The Recursive Path Order as an instance of WPO\<close>

text \<open>This theory defines the recursive path order (RPO) that given two terms provides two Booleans,
  whether the terms can be strictly or non-strictly oriented. It is proven that RPO is an instance of WPO, and hence,
  carries over all the nice properties of WPO immediately.\<close>
theory RPO
  imports
    WPO
begin

context
  fixes "pr" :: "'f \<times> nat \<Rightarrow> 'f \<times> nat \<Rightarrow> bool \<times> bool"
    and prl :: "'f \<times> nat \<Rightarrow> bool"
    and c :: "'f \<times> nat \<Rightarrow> order_tag"
    and n :: nat
begin

fun rpo  :: "('f, 'v) term \<Rightarrow> ('f, 'v) term \<Rightarrow> bool \<times> bool"
  where
    "rpo (Var x) (Var y) = (False, x = y)" |
    "rpo (Var x) (Fun g ts) = (False, ts = [] \<and> prl (g,0))" |
    "rpo (Fun f ss) (Var y) = (let con = (\<exists> s \<in> set ss. snd (rpo s (Var y))) in (con,con))" |
    "rpo (Fun f ss) (Fun g ts) = (
    if (\<exists> s \<in> set ss. snd (rpo s (Fun g ts)))
       then (True,True)
       else (let (prs,prns) = pr (f,length ss) (g,length ts) in
         if prns \<and> (\<forall> t \<in> set ts. fst (rpo (Fun f ss) t))
         then if prs
              then (True,True)
              else if c (f,length ss) = Lex \<and> c (g,length ts) = Lex
                   then lex_ext rpo n ss ts
                   else if c (f,length ss) = Mul \<and> c (g,length ts) = Mul
                        then mul_ext rpo ss ts
                        else (length ss \<noteq> 0 \<and> length ts = 0, length ts = 0)
          else (False,False)))"
end

locale rpo_with_assms = precedence prc prl
  for prc :: "'f \<times> nat \<Rightarrow> 'f \<times> nat \<Rightarrow> bool \<times> bool"
    and prl :: "'f \<times> nat \<Rightarrow> bool"
    and c :: "'f \<times> nat \<Rightarrow> order_tag"
    and n :: nat
begin

sublocale wpo_with_assms n "{}" UNIV prc prl full_status c False "\<lambda> _. False"
  by (unfold_locales, auto simp: refl_on_def trans_def simple_arg_pos_def)

abbreviation "rpo_pr \<equiv> rpo prc prl c n"
abbreviation "rpo_s \<equiv> \<lambda> s t. fst (rpo_pr s t)"
abbreviation "rpo_ns \<equiv> \<lambda> s t. snd (rpo_pr s t)"

lemma rpo_eq_wpo: "rpo_pr s t = wpo s t"
proof -
  note simps = wpo.simps
  show ?thesis
  proof (induct s t rule: rpo.induct[of _ prc prl c n])
    case (1 x y)
    then show ?case by (simp add: simps)
  next
    case (2 x g ts)
    then show ?case by (auto simp: simps)
  next
    case (3 f ss y)
    then show ?case by (auto simp: simps[of "Fun f ss" "Var y"] Let_def set_conv_nth)
  next
    case IH: (4 f ss g ts)
    have id: "\<And> s. (s \<in> {}) = False" "\<And> s. (s \<in> UNIV) = True"
      and "(\<exists>i\<in>{0..<length ss}. wpo_ns (ss ! i) t) = (\<exists>si\<in>set ss. wpo_ns si t)"
      by (auto, force simp: set_conv_nth)
    have id': "map ((!) ss) (\<sigma> (f, length ss)) = ss" for f ss by (intro nth_equalityI, auto)
    have ex: "(\<exists>i\<in>set (\<sigma> (f, length ss)). wpo_ns (ss ! i) (Fun g ts)) = (\<exists> si \<in> set ss. rpo_ns si (Fun g ts))"
      using IH(1) unfolding set_conv_nth by auto
    obtain prs prns where prc: "prc (f, length ss) (g, length ts) = (prs, prns)" by force
    show ?case
      unfolding rpo.simps simps[of "Fun f ss" "Fun g ts"] term.simps id id' if_False if_True
        Let_def ex prc split
    proof (rule sym, rule if_cong[OF refl refl], rule if_cong[OF conj_cong[OF refl] if_cong[OF refl refl if_cong[OF refl _ if_cong]] refl])
      assume "\<not> (\<exists>si\<in>set ss. rpo_ns si (Fun g ts))"
      note IH = IH(2-)[OF this prc[symmetric] refl]
      from IH(1) show "(\<forall>j\<in>set (\<sigma> (g, length ts)). wpo_s (Fun f ss) (ts ! j)) = (\<forall>t\<in>set ts. rpo_s (Fun f ss) t)"
        unfolding set_conv_nth by auto
      assume "prns \<and> (\<forall>t\<in>set ts. rpo_s (Fun f ss) t)" "\<not> prs"
      note IH = IH(2-)[OF this]
      {
        assume "c (f, length ss) = Lex \<and> c (g, length ts) = Lex"
        from IH(1)[OF this]
        show "lex_ext wpo n ss ts = lex_ext rpo_pr n ss ts"
          by (intro lex_ext_cong, auto)
      }
      {
        assume "\<not> (c (f, length ss) = Lex \<and> c (g, length ts) = Lex)" "c (f, length ss) = Mul \<and> c (g, length ts) = Mul"
        from IH(2)[OF this]
        show "mul_ext wpo ss ts = mul_ext rpo_pr ss ts"
          by (intro mul_ext_cong, auto)
      }
    qed auto
  qed
qed

abbreviation "RPO_S \<equiv> {(s,t). rpo_s s t}"
abbreviation "RPO_NS \<equiv> {(s,t). rpo_ns s t}"

theorem RPO_SN_order_pair: "SN_order_pair RPO_S RPO_NS"
  unfolding rpo_eq_wpo by (rule WPO_SN_order_pair)

theorem RPO_S_subst: "(s,t) \<in> RPO_S \<Longrightarrow> (s \<cdot> \<sigma>, t \<cdot> \<sigma>) \<in> RPO_S" for \<sigma> :: "('f,'a)subst"
  using WPO_S_subst unfolding rpo_eq_wpo .

theorem RPO_NS_subst: "(s,t) \<in> RPO_NS \<Longrightarrow> (s \<cdot> \<sigma>, t \<cdot> \<sigma>) \<in> RPO_NS" for \<sigma> :: "('f,'a)subst"
  using WPO_NS_subst unfolding rpo_eq_wpo .

theorem RPO_NS_ctxt: "(s,t) \<in> RPO_NS \<Longrightarrow> (Fun f (bef @ s # aft), Fun f (bef @ t # aft)) \<in> RPO_NS"
  using WPO_NS_ctxt unfolding rpo_eq_wpo .

theorem RPO_S_ctxt: "(s,t) \<in> RPO_S \<Longrightarrow> (Fun f (bef @ s # aft), Fun f (bef @ t # aft)) \<in> RPO_S"
  using WPO_S_ctxt unfolding rpo_eq_wpo by auto

theorem RPO_S_subset_RPO_NS: "RPO_S \<subseteq> RPO_NS"
  using WPO_S_subset_WPO_NS unfolding rpo_eq_wpo .

theorem supt_subset_RPO_S: "{\<rhd>} \<subseteq> RPO_S"
  using supt_subset_WPO_S unfolding rpo_eq_wpo by auto

theorem supteq_subset_RPO_NS: "{\<unrhd>} \<subseteq> RPO_NS"
  using supteq_subset_WPO_NS unfolding rpo_eq_wpo by auto

end
end


theory anders_pre_star imports anders_saturation anders_pds (* "~~/src/HOL/Hoare/HeapSyntax" *)
begin

(* Here we define the saturation rule for pre* (pre_star), and try to prove the correctness of the saturation procedure. *)

(* This is the saturation rule defined on page 32 in http://www.lsv.fr/Publis/PAPERS/PDF/schwoon-phd02.pdf *)
definition pre_star_step :: "transition set \<Rightarrow> transition \<Rightarrow> bool" where
  "pre_star_step rel \<equiv> \<lambda>(p,\<gamma>,q). (\<exists>p' w. (p,\<gamma>) \<hookrightarrow> (p',w) \<and> (p', op_labels w, q) \<in> (transition_star rel))"

inductive pre_star_step' :: "transition set \<Rightarrow> transition set \<Rightarrow> bool" where
  add_trans: "(p,\<gamma>) \<hookrightarrow> (p',w) \<Longrightarrow> (p', op_labels w, q) \<in> transition_star rel \<Longrightarrow> (p, \<gamma>, q) \<notin> rel \<Longrightarrow> pre_star_step' rel (rel \<union> {(p,\<gamma>,q)})"
(* It is wrong to have "op_labels" in all these. *)

definition pre_star' :: "transition set \<Rightarrow> transition set \<Rightarrow> bool" where
  "pre_star' \<equiv> rtranclp pre_star_step'"

definition saturated' :: "transition set \<Rightarrow> bool" where
  "saturated' A \<equiv> \<nexists>B. pre_star_step' A B"

definition pre_star_lim' :: "transition set \<Rightarrow> transition set \<Rightarrow> bool" where
  "pre_star_lim' A B \<equiv> pre_star' A B \<and> saturated' B"

(* Use this rule in the saturation procedure. *)
definition pre_star_rel where
  "pre_star_rel = saturate pre_star_step"

(* This is what we want to prove: *)
theorem "language (pre_star_rel rel) = pre_star (language rel)"
  oops

lemma pre_star_step_mono[simp]: "mono pre_star_step"
  using transition_star_mono unfolding mono_def pre_star_step_def
  by clarsimp (meson subsetD)

lemma rule_pre_star_saturation:
  "(p,\<gamma>) \<hookrightarrow> (p',w) \<Longrightarrow> (p', op_labels w, q) \<in> (transition_star rel)
   \<Longrightarrow> (p, \<gamma>, q) \<in> start_from init (saturate_step pre_star_step) rel"
  unfolding saturate_step_def start_from_def pre_star_step_def
  by auto

lemma rule_pre_star_rel: "(p,\<gamma>) \<hookrightarrow> (p',w) \<Longrightarrow> (p', op_labels w, q) \<in> (transition_star (pre_star_rel rel))
       \<Longrightarrow> (p, \<gamma>, q) \<in> pre_star_rel rel"
  unfolding pre_star_rel_def saturate_def
  using saturate_mono pre_star_step_mono lfp_fixpoint rule_pre_star_saturation
  by blast

(* This is Lemma 3.1 from page 33 in http://www.lsv.fr/Publis/PAPERS/PDF/schwoon-phd02.pdf *)
(* I managed to prove this one. *)
lemma lemma_3_1:
  assumes "(p',w) \<Rightarrow>\<^sup>* (p,v)"
      and "(p,v) \<in> language rel"
    shows "accepts (pre_star_rel rel) (p',w)"
  using assms unfolding step_starp_def
proof (induct rule: converse_rtranclp_induct)
  case base
  then show ?case
    using accepts_mono saturate_subseteq
    unfolding mono_def pre_star_rel_def language_def
    by auto
next
  case (step y z)
  then show ?case
    unfolding step_relp_def step_def
    using accepts_unfoldn rule_pre_star_rel accepts_cons
    apply clarsimp
    subgoal for p w
      by (induct w; clarsimp) blast
    done
qed

lemma pre_star_step'_incr: "pre_star_step' A B \<Longrightarrow> A \<subseteq> B"
proof(induction rule: pre_star_step'.inducts)
  case (add_trans p \<gamma> p' w q rel)
  then show ?case
    by auto
qed

lemma pre_star'_incr: "pre_star' A B \<Longrightarrow> A \<subseteq> B"
  unfolding pre_star'_def proof (induction rule: rtranclp_induct)
  case base
  then show ?case by auto
next
  case (step y z)
  then show ?case
    using pre_star_step'_incr by auto
qed

lemma pre_star'_incr_transition_star:
  "pre_star' A A' \<Longrightarrow> transition_star A \<subseteq> transition_star A'"
  using mono_def pre_star'_incr transition_star_mono by blast

lemma pre_star_lim'_incr_transition_star:
  "pre_star_lim' A A' \<Longrightarrow> transition_star A \<subseteq> transition_star A'"
  by (simp add: pre_star'_incr_transition_star pre_star_lim'_def)

lemma step_relp_non_empty: "step_relp (p',w) (p'',u) \<Longrightarrow> w \<noteq> []"
  by (metis case_prod_conv empty_iff step'.simps(1) step_def step_relp_def)

lemma transition_star_split:
  assumes "(p'', u1 @ w1, q) \<in> transition_star A'"
  shows "\<exists>q1. (p'', u1, q1) \<in> transition_star A' \<and> (q1, w1, q) \<in> transition_star A'"
  sorry

lemma lemma_3_1':
  assumes "(p',w) \<Rightarrow>\<^sup>* (p,v)"
      and "(p,v) \<in> language A"
      and "pre_star_lim' A A'"
    shows "accepts A' (p',w)"
  using assms unfolding step_starp_def
proof (induct rule: converse_rtranclp_induct)
  case base
  then have "\<exists>q\<in>Q. F q \<and> (p, v, q) \<in> transition_star A'"
    unfolding language_def accepts_def using pre_star_lim'_incr_transition_star by auto
  then show ?case
    unfolding accepts_def by auto
next
  case (step p'w p''u)
  define p' where "p' = fst p'w"
  define w  where "w = snd p'w"
  define p'' where "p'' = fst p''u"
  define u  where "u = snd p''u"
  have p'w_def: "p'w = (p', w)"
    using p'_def w_def by auto
  have p''u_def: "p''u = (p'', u)"
    using p''_def u_def by auto

  have a: "accepts A' p''u"
    using step by auto

  then obtain q where q_p: "q \<in> Q \<and> F q \<and> (p'', u, q) \<in> transition_star A'"
    unfolding accepts_def using p''_def u_def by auto

  have e: "\<exists>\<gamma> w1 u1. w=\<gamma>#w1 \<and> u=op_labels u1@w1 \<and> (p', \<gamma>) \<hookrightarrow> (p'', u1)"
  proof -
    from step(1) obtain \<gamma> w1 where w_exp: "w=\<gamma>#w1"
      unfolding p''u_def step_def p'w_def using step_relp_non_empty using list.exhaust by blast
    from step(1) have "\<exists>u1. u=op_labels u1@w1 \<and> (p', \<gamma>) \<hookrightarrow> (p'', u1)"
      unfolding step_relp_def p''u_def
        step_def p'w_def w_exp by auto
    then show "\<exists>\<gamma> w1 u1. w=\<gamma>#w1 \<and> u=op_labels u1@w1 \<and> (p', \<gamma>) \<hookrightarrow> (p'', u1)"
      using w_exp by auto
  qed

  then obtain \<gamma> w1 u1 where w_p: "w=\<gamma>#w1" and u_p: "u=op_labels u1@w1" and u_tran: "(p', \<gamma>) \<hookrightarrow> (p'', u1)"
    by blast
  note \<gamma>_w1_u1_p = w_p u_p u_tran

  have "\<exists>q1. (p'', op_labels u1, q1) \<in> transition_star A' \<and> (q1, w1, q) \<in> transition_star A'"
    using q_p unfolding u_p using transition_star_split by auto
  then obtain q1 where q1_p: "(p'', op_labels u1, q1) \<in> transition_star A' \<and> (q1, w1, q) \<in> transition_star A'"
    by blast

  have \<gamma>_w1_u1_p_n: "(p', \<gamma>) \<hookrightarrow> (p'', u1)"
    using \<gamma>_w1_u1_p by blast

  then have "(p', \<gamma>#w1, q) \<in> transition_star A'"
    using transition_star_step q1_p
    by (meson add_trans pre_star_lim'_def saturated'_def step.prems(2))
  then have t_in_A': "(p', w, q) \<in> transition_star A'"
    using \<gamma>_w1_u1_p by blast

  from q_p t_in_A' have "F q \<and> (p', w, q) \<in> transition_star A'"
    using p'_def w_def by auto
  then show ?case
    unfolding accepts_def p'w_def using q_p by auto
qed

(* Lemma 3.2 on page 34 turned out to be harder to prove.
   Here goes several failed attempts... *)

lemma lemma_3_2_base:
  "(p, w, q) \<in> transition_star rel \<Longrightarrow> \<exists>p' w'. (p, w) \<Rightarrow>\<^sup>* (p', w') \<and> (p', w', q) \<in> transition_star rel"
  unfolding step_starp_def
  by auto
lemma lemma_3_2_step:
  "\<lbrakk>(p, w, q) \<in> transition_star (start_from rel_0 (saturate_step f) rel)\<rbrakk>
        \<Longrightarrow> \<exists>p' w'. (p, w) \<Rightarrow>\<^sup>* (p', w') \<and> (p', w', q) \<in> transition_star rel_0"
  unfolding step_starp_def (*saturate_step_def start_from_def*)
  apply -
  oops

lemma "rel \<subseteq> pre_star_rel rel"
  unfolding pre_star_rel_def saturate_def
  apply clarsimp
  apply (induct rule: lfp_ordinal_induct, fact saturate_mono[OF pre_star_step_mono])
  using start_from_subseteq
   apply fast
  apply clarsimp
  nitpick
  oops

lemma pre_star_rel_mono: "t \<in> transition_star rel \<Longrightarrow> t \<in> transition_star (pre_star_rel rel)"
  using transition_star_mono start_from_lfp_subseteq
  unfolding pre_star_rel_def saturate_def
  by (metis in_mono mono_def)

lemma pre_star_rel_induct: "\<lbrakk>P rel_0; \<And>rel. P rel \<Longrightarrow> P (f rel)\<rbrakk> \<Longrightarrow> P (lfp f)"
  apply -
  quickcheck
  oops

lemma "\<lbrakk>(p, w, q) \<in> transition_star (pre_star_saturation rel_0 rel_i);
        (p, w, q) \<notin> transition_star rel_i\<rbrakk>
         \<Longrightarrow> \<exists>p' w'. (p, w) \<Rightarrow>\<^sup>* (p', w') \<and> (p', w', q) \<in> transition_star rel_0"
  oops

lemma lemma_3_2_b_aux':
  assumes "\<nexists>q \<gamma> q'. (q, \<gamma>, q') \<in> A \<and> q' \<in> P"
  assumes "(p, w, q) \<in> transition_star A"
  assumes "q \<in> P"
  shows "w = [] \<and> p = q"
using assms(2) assms(1,3) proof (induction)
  case (transition_star_refl p)
  then show ?case by auto
next
  case (transition_star_step p \<gamma> q' w q)
  then show ?case by blast
qed

fun start_of' :: "transition \<Rightarrow> state" where (* TODO: rename *)
  "start_of' (q, \<gamma>, q') = q"

fun end_of' :: "transition \<Rightarrow> state" where (* TODO: rename *)
  "end_of' (q, \<gamma>, q') = q'"

fun sym_of' :: "transition \<Rightarrow> label" where (* TODO: rename *)
  "sym_of' (q, \<gamma>, q') = \<gamma>"

fun consecs' :: "'a list \<Rightarrow> ('a * 'a) set" where
  "consecs' [] = {}"
| "consecs' [y] = {}"
| "consecs' (x#y#xs) = {(x,y)} \<union> consecs' (y#xs)"

lemma lemma_3_2_a':
  assumes "\<nexists>q \<gamma> q'. (q, \<gamma>, q') \<in> A \<and> q' \<in> P"
  assumes "pre_star' A A'"
  assumes "(p, w, q) \<in> transition_star A'"
  shows "\<exists>p' w'. (p', w', q) \<in> transition_star A \<and> (p, w) \<Rightarrow>\<^sup>* (p', w')"
  using assms(2) assms(1,3) unfolding pre_star'_def proof (induction rule: rtranclp_induct)
  case base
  then show ?case
    unfolding step_starp_def by auto
next
  case (step Aiminus1 Ai)
  from step(2) obtain p1 \<gamma> p' w q' where p1_\<gamma>_p'_w_q'_p: "
                       Ai = Aiminus1 \<union> {(p1, \<gamma>, q')} \<and>
                       (p1, \<gamma>) \<hookrightarrow> (p', w) \<and>
                       (p', op_labels w, q') \<in> transition_star Aiminus1"
    unfolding pre_star_step'.simps by auto
  define t where "t = (p1, \<gamma>, q')"
  (* I think there is a challenge here.
     In the proof he looks at << p \<midarrow>w\<rightarrow>*_i q >> as if it were a path. But there can be
     several paths like that. So I need to fix one.

     Hack: pick the smallest subset of Ai such that p \<midarrow>w\<rightarrow>*_i q \<in> Ai.

  *)

  then show ?case sorry
qed

lemma lemma_3_2:
  assumes "(p, w, q) \<in> transition_star (pre_star_rel rel)"
  shows   "\<exists>p' w'. (p, w) \<Rightarrow>\<^sup>* (p', w') \<and> (p', w', q) \<in> transition_star rel" (* \<and> (q \<in> P_states \<longrightarrow> w' = []) *)
  using assms unfolding pre_star_rel_def saturate_def
proof (induct rule: lfp_ordinal_induct)
  case mono
  then show ?case using saturate_mono by force
next
  case (step S)
  then show ?case by (simp add: lemma_3_2_step)
next
  case (union M)
  then show ?case using assms
    apply (rule_tac ?x="p" in exI)
    apply (rule_tac ?x="w" in exI)
    unfolding step_starp_def
    apply clarsimp
    apply (frule pre_star_rel_mono)
    sorry
qed
thm lfp_ordinal_induct[OF saturate_mono[OF pre_star_sat_step_mono]]
thm lfp_induct_set
lemma lemma_3_2':
  assumes "(p, w, q) \<in> transition_star (pre_star_rel rel)"
  shows   "\<exists>p' w'. (p, w) \<Rightarrow>\<^sup>* (p', w') \<and> (p', w', q) \<in> transition_star rel"
  using assms unfolding pre_star_rel_def saturate_def
  apply (induct rule: lfp_ordinal_induct[OF saturate_mono[OF pre_star_sat_step_mono]])
  apply auto
  apply (simp add: lemma_3_2_step)
  using pre_star_rel_mono
  unfolding pre_star_rel_def
  apply clarsimp
  apply (rule_tac ?x="p" in exI)
  apply (rule_tac ?x="w" in exI)
  unfolding step_starp_def
  apply clarsimp
  oops

lemma lemma_3_2_converse:
  assumes "\<And>p' w'. (p, w) \<Rightarrow>\<^sup>* (p', w') \<Longrightarrow> (p', w', q) \<notin> transition_star rel"
  shows   "(p, w, q) \<notin> transition_star (pre_star_rel rel)"
  using assms unfolding pre_star_rel_def saturate_def
  apply (induct rule: lfp_ordinal_induct[OF saturate_mono[OF pre_star_step_mono]])
   apply clarsimp
  unfolding start_from_def saturate_step_def
   apply safe
   apply simp_all
   defer
  subgoal for M
    apply (cases "rel \<in> M")
    apply auto
   apply (insert lemma_3_2_base)
    oops

lemma lemma_3_2'':
  assumes "(p, w, q) \<in> transition_star (pre_star_rel rel)"
  shows   "\<exists>p' w'. (p, w) \<Rightarrow>\<^sup>* (p', w') \<and> (p', w', q) \<in> transition_star rel"
  using assms unfolding pre_star_rel_def
  thm saturate_converse_induct saturate_converse_induct[OF pre_star_sat_step_mono]
  apply (induct rule: saturate_converse_induct[OF pre_star_sat_step_mono transition_star_mono], assumption)
  using lemma_3_2_base
   apply simp
  apply clarsimp
  apply (simp add: lemma_3_2_step)
  using pre_star_rel_mono
  unfolding pre_star_rel_def
  apply clarsimp
  apply (rule_tac ?x="p" in exI)
  apply (rule_tac ?x="w" in exI)
  unfolding step_starp_def
  apply clarsimp
  oops

(* This proof works, if lemma_3_2_converse can be proven. *)
theorem "language (pre_star_rel rel) = pre_star (language rel)"
  using lemma_3_1 lemma_3_2_converse
  unfolding language_def pre_star_def accepts_def
  by blast

lemma mono_temp[mono]: "mono (\<lambda>p x. (\<exists>t. x = t \<and> t \<in> \<rightarrow>) \<or> (\<exists>t. x = t \<and> pre_star_sat_step {x. p x} t))"
  using pre_star_sat_step_mono
  unfolding mono_def
  by clarsimp (metis Collect_mono_iff rev_predicate1D)

(*
(* inductive and inductive_set cannot prove monocity even though the proof is right above here  *)
inductive rel_pre_starp :: "transition \<Rightarrow> bool" where
  rel_pre_starp_refl[iff]: "t \<in> rel \<Longrightarrow> rel_pre_starp t"
| rel_pre_starp_step: "pre_star_sat {t'. rel_pre_starp t'} t \<Longrightarrow> rel_pre_starp t"

*)
lemma fake_mono: "X \<subseteq> Y \<Longrightarrow> pre_star_sat_step X t \<longrightarrow> pre_star_sat_step Y t"
  oops
(* If you 'sorry' this lemma, then the inductive set below works... *)

(* I first tried to define the saturation procedure as an inductive set like this.
   But it is not happy about it. *)
inductive_set rel_pre_star :: "transition set \<Rightarrow> transition set" for rel where
  rel_pre_star_refl[iff]: "t \<in> rel \<Longrightarrow> t \<in> (rel_pre_star rel)"
| rel_pre_star_step: "pre_star_sat_step (rel_pre_star rel) t \<Longrightarrow> t \<in> (rel_pre_star rel)"
monos fake_mono

(* Here I tried something similar with the general saturation procedure. *)
lemma f_mono: "A \<subseteq> B \<Longrightarrow> Collect (f A) \<subseteq> Collect (f B)"
  oops

inductive_set saturate :: "('a set \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a set"
  for f :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" and S :: "'a set" where
  "t \<in> S \<Longrightarrow> t \<in> saturate f S" |
  "mono f \<Longrightarrow> f (saturate f S) t \<Longrightarrow> t \<in> saturate f S"
monos f_mono
print_theorems

end


(*
  Title: Sup- and Inf-Preserving Transformers Between Complete Lattices
  Author: Georg Struth
  Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Sup- and Inf-Preserving Transformers between Complete Lattices\<close>

theory Sup_Inf_Preserving_Transformers
  imports Isotone_Transformers

begin

subsection \<open>Basic Properties\<close>

text \<open>Definitions and basic properties of Sup-preserving and Inf-preserving functions can be found in the Lattice components.
The main purose of the lemmas that follow is to bring properties of isotone transformers into scope.\<close>

lemma Sup_pres_iso:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Sup_pres f \<Longrightarrow> mono f"
  by (simp add: Sup_supdistl_iso)

lemma Inf_pres_iso:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Inf_pres f \<Longrightarrow> mono f"
  by (simp add: Inf_subdistl_iso)

lemma sup_pres_iso:
  fixes f :: "'a::lattice \<Rightarrow> 'b::lattice"
  shows "sup_pres f \<Longrightarrow> mono f"
  by (metis le_iff_sup mono_def)

lemma inf_pres_iso:
  fixes f :: "'a::lattice \<Rightarrow> 'b::lattice"
  shows "inf_pres f \<Longrightarrow> mono f"
  by (metis inf.absorb_iff2 monoI)

lemma Sup_sup_dual:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Sup_dual f \<Longrightarrow> sup_dual f"
  by (smt comp_eq_elim image_empty image_insert inf_Inf sup_Sup)

lemma Inf_inf_dual:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Inf_dual f \<Longrightarrow> inf_dual f"
  by (smt comp_eq_elim image_empty image_insert inf_Inf sup_Sup)

lemma Sup_bot_dual:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows"Sup_dual f \<Longrightarrow> bot_dual f"
  by (metis INF_empty Sup_empty comp_eq_elim)

lemma Inf_top_dual:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Inf_dual f \<Longrightarrow> top_dual f"
  by (metis Inf_empty SUP_empty comp_eq_elim)

text \<open>Next I show some basic preservation properties.\<close>

lemma Sup_dual2: "Sup_dual f \<Longrightarrow> Inf_dual g \<Longrightarrow> Sup_pres (g \<circ> f)"
  by (simp add: fun_eq_iff image_comp)

lemma Inf_dual2: "Sup_dual f \<Longrightarrow> Inf_dual g \<Longrightarrow> Inf_pres (f \<circ> g)"
  by (simp add: fun_eq_iff image_comp)

lemma Sup_pres_id: "Sup_pres id"
  by simp

lemma Inf_pres_id: "Inf_pres id"
  by simp

lemma Sup_pres_comp: "Sup_pres f \<Longrightarrow> Sup_pres g \<Longrightarrow> Sup_pres (f \<circ> g)"
  by (simp add: fun_eq_iff image_comp)

lemma Inf_pres_comp: "Inf_pres f \<Longrightarrow> Inf_pres g \<Longrightarrow> Inf_pres(f \<circ> g)"
  by (simp add: fun_eq_iff image_comp)

lemma Sup_pres_Sup:
  fixes F :: "('a::complete_lattice \<Rightarrow> 'b::complete_lattice) set"
  shows "\<forall>f \<in> F. Sup_pres f \<Longrightarrow> Sup_pres (\<Squnion>F)"
proof-
  assume h: "\<forall>f \<in> F. f \<circ> Sup = Sup \<circ> image f"
  hence "\<forall>f \<in> F. f \<circ> Sup \<le> Sup \<circ> image (\<Squnion>F)"
    by (simp add: SUP_subset_mono Sup_upper le_fun_def)
  hence "(\<Squnion>F) \<circ> Sup \<le> Sup \<circ> image (\<Squnion>F)"
    by (simp add: SUP_le_iff le_fun_def)
  thus ?thesis
    by (simp add: Sup_pres_iso h antisym iso_Sup_supdistl iso_fSup)
qed

lemma Inf_pres_Inf:
  fixes F :: "('a::complete_lattice \<Rightarrow> 'b::complete_lattice) set"
  shows "\<forall>f \<in> F. Inf_pres f \<Longrightarrow> Inf_pres (\<Sqinter>F)"
proof-
  assume h: "\<forall>f \<in> F. f \<circ> Inf = Inf \<circ> image f"
  hence "\<forall>f \<in> F. Inf \<circ> image (\<Sqinter>F) \<le> f \<circ> Inf"
    by (simp add: le_fun_def, safe, meson INF_lower INF_mono)
  hence "Inf \<circ> image (\<Sqinter>F) \<le> (\<Sqinter>F) \<circ> Inf"
    by (simp add: le_INF_iff le_fun_def)
  thus ?thesis
    by (simp add: Inf_pres_iso h antisym iso_Inf_subdistl iso_fInf)
qed

lemma Sup_pres_sup:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Sup_pres f \<Longrightarrow> Sup_pres g \<Longrightarrow> Sup_pres (f \<squnion> g)"
  by (metis Sup_pres_Sup insert_iff singletonD sup_Sup)

lemma Inf_pres_inf:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'b::complete_lattice"
  shows "Inf_pres f \<Longrightarrow> Inf_pres g \<Longrightarrow> Inf_pres (f \<sqinter> g)"
  by (metis Inf_pres_Inf inf_Inf insert_iff singletonD)

lemma Sup_pres_botf: "Sup_pres (\<lambda>x. \<bottom>::'a::complete_lattice)"
  by (simp add: fun_eq_iff)

text \<open>It is important to note that $\lambda x. \bot$ is not Inf-preserving and that $\lambda x. \top$ is not Sup-preserving.\<close>

lemma "Inf_pres (\<lambda>x. \<bottom>::'a::complete_lattice)" (*nitpick[show_all]*)
  oops

lemma "Sup_pres (\<lambda>x. \<top>::'a::complete_lattice)" (*nitpick[show_all]*)
  oops

lemma Inf_pres_topf: "Inf_pres (\<lambda>x. \<top>::'a::complete_lattice)"
  by (simp add: fun_eq_iff)

text \<open>In complete boolean algebras, complementation yields an explicit variant of duality, which
can be expressed within the language.\<close>

lemma uminus_galois:
  fixes f :: "'a::complete_boolean_algebra \<Rightarrow> 'b::complete_boolean_algebra_alt"
  shows "(uminus f = g) = (uminus g = f)"
  using double_compl by force

lemma uminus_galois_var:
  fixes f :: "'a::complete_boolean_algebra_alt_with_dual \<Rightarrow> 'b::complete_boolean_algebra_alt_with_dual"
  shows "(\<partial> \<circ> f = g) = (\<partial> \<circ> g = f)"
  by force

lemma uminus_galois_var2:
  fixes f :: "'a::complete_boolean_algebra_alt_with_dual \<Rightarrow> 'b::complete_boolean_algebra_alt_with_dual"
  shows "(f \<circ> \<partial> = g) = (g \<circ> \<partial> = f)"
  by force

lemma uminus_mono_iff:
  fixes f :: "'a::complete_boolean_algebra_alt_with_dual \<Rightarrow> 'b::complete_boolean_algebra_alt_with_dual"
  shows "(\<partial> \<circ> f = \<partial> \<circ> g) = (f = g)"
  using uminus_galois_var by force

lemma uminus_epi_iff:
  fixes f :: "'a::complete_boolean_algebra_alt_with_dual \<Rightarrow> 'b::complete_boolean_algebra_alt_with_dual"
  shows "(f \<circ> \<partial> = g \<circ> \<partial>) = (f = g)"
  using uminus_galois_var2 by force

lemma Inf_pres_Sup_pres:
  fixes f :: "'a::complete_boolean_algebra_alt_with_dual \<Rightarrow> 'b::complete_boolean_algebra_alt_with_dual"
  shows "(Inf_pres f) = (Sup_pres (\<partial>\<^sub>F f))"
  by (simp add: Inf_pres_map_dual_var)

lemma Sup_pres_Inf_pres:
  fixes f :: "'a::complete_boolean_algebra_alt_with_dual \<Rightarrow> 'b::complete_boolean_algebra_alt_with_dual"
  shows "(Sup_pres f) = (Inf_pres (\<partial>\<^sub>F f))"
  by (simp add: Sup_pres_map_dual_var)

subsection \<open>Properties of the Kleene Star\<close>

text \<open>I develop the star for Inf-preserving functions only. This is suitable for weakest liberal preconditions.
The case of sup-preserving functions is dual, and straightforward. The main difference to isotone transformers is that Kleene's fixpoint theorem
now applies, that is, the star can be represented by iteration.\<close>

lemma  H_Inf_pres_fpower:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "Inf_pres f \<Longrightarrow> x \<le> f x \<Longrightarrow> x \<le> fpower f i x"
  apply (induct i, simp_all) using H_iso_cond2 Inf_pres_iso by blast

lemma H_Inf_pres_fstar:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "Inf_pres f \<Longrightarrow> x \<le> f x \<Longrightarrow> x \<le> fstar f x"
  by (simp add: H_Inf_pres_fpower fstar_def le_INF_iff)

lemma fpower_Inf_pres: "Inf_pres f \<Longrightarrow> Inf_pres (fpower f i)"
  by (induct i, simp_all add: Inf_pres_comp)

lemma fstar_Inf_pres:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "Inf_pres f \<Longrightarrow> Inf_pres (fstar f)"
  by (simp add: fstar_def Inf_pres_Inf fpower_Inf_pres)

lemma fstar_unfoldl_var [simp]:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "Inf_pres f \<Longrightarrow> x \<sqinter> f (fstar f x) = fstar f x"
proof-
  assume hyp: "Inf_pres f"
  have "x \<sqinter> f (fstar f x) = fpower f 0 x \<sqinter> (\<Sqinter>n. fpower f (Suc n) x)"
    by (simp add: fstar_def image_comp) (metis (no_types) comp_apply hyp image_image)
  also have "... = (\<Sqinter>n. fpower f n x)"
    by (subst fInf_unfold, auto)
  finally show ?thesis
    by (simp add: fstar_def image_comp)
qed

lemma fstar_fiter_id: "Inf_pres f \<Longrightarrow> fstar f = fiter_id f"
proof-
  assume hyp: "Inf_pres f"
  {fix x::"'a::complete_lattice"
  have "fstar f x = x \<sqinter> f (fstar f x)"
    by (simp add: hyp)
  hence a: "fstar f x \<le> gfp (\<lambda>y. x \<sqinter> f y)"
    by (metis gfp_upperbound order_refl)
  have "\<forall>y. y \<le> x \<sqinter> f y \<longrightarrow> y \<le> fstar f x"
    by (meson H_Inf_pres_fstar H_iso_cond2 Inf_pres_iso fstar_Inf_pres hyp le_infE)
  hence "fstar f x = gfp (\<lambda>y. x \<sqinter> f y)"
    by (metis a antisym gfp_least)}
  thus ?thesis
    by (simp add: fun_eq_iff Inf_pres_iso fstar_pred_char hyp)
qed

lemma fstar_unfoldl [simp]:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "Inf_pres f \<Longrightarrow> id \<sqinter> (f \<circ> fstar f) = fstar f"
  by (simp add: fun_eq_iff)

lemma fpower_Inf_comm:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "Inf_pres f \<Longrightarrow> f (\<Sqinter>i. fpower f i x) = (\<Sqinter>i. fpower f i (f x))"
proof-
  assume "Inf_pres f"
  hence "f (\<Sqinter>i. fpower f i x) = (\<Sqinter>i. fpower f (Suc i) x)"
    by (simp add: fun_eq_iff image_comp)
  also have "... =  (\<Sqinter>i. fpower f i (f x))"
    by (metis comp_eq_dest_lhs fun_mon.power_Suc2)
  finally show ?thesis .
qed

lemma fstar_comm:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "Inf_pres f \<Longrightarrow> f \<circ> fstar f = fstar f \<circ> f"
  apply (simp add: fun_eq_iff fstar_def image_comp)
  by (metis (mono_tags, lifting) INF_cong comp_eq_dest fun_mon.power_commutes)

lemma fstar_unfoldr [simp]:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "Inf_pres f \<Longrightarrow> id \<sqinter> (fstar f \<circ> f) = fstar f"
  using fstar_comm fstar_unfoldl by fastforce

subsection \<open>Quantales of Inf- and Top-Preserving Transformers\<close>

text \<open>As for itotone transformers, types must now be restricted to a single one. It is well known that Inf-preserving transformers need not be
top-preserving, and that Sup-preserving transformers need not be bot-preserving. This has been shown elsewhere. This does not affect the following proof,
but it has an impact on how elements are represented. I show only the result for Inf-preserving transformers; that for Sup-preserving ones is dual.\<close>

typedef (overloaded) 'a Inf_pres = "{f::'a::complete_lattice \<Rightarrow> 'a. Inf_pres f}"
  using Inf_pres_topf by blast

setup_lifting type_definition_Inf_pres

instantiation Inf_pres :: (complete_lattice) unital_Sup_quantale
begin

lift_definition one_Inf_pres :: "'a::complete_lattice Inf_pres" is id
  by (simp add: iso_id)

lift_definition times_Inf_pres :: "'a::complete_lattice Inf_pres \<Rightarrow> 'a Inf_pres \<Rightarrow> 'a Inf_pres" is "(\<circ>)"
  by (simp add: Inf_pres_comp)

lift_definition Sup_Inf_pres :: "'a::complete_lattice Inf_pres set \<Rightarrow> 'a Inf_pres" is Inf
  by (simp add: Inf_pres_Inf)

lift_definition less_eq_Inf_pres :: "'a Inf_pres \<Rightarrow> 'a Inf_pres \<Rightarrow> bool" is "(\<ge>)".

lift_definition  less_Inf_pres :: "'a Inf_pres \<Rightarrow> 'a Inf_pres \<Rightarrow> bool" is "(>)".

instance
  by (intro_classes; transfer, simp_all add: o_assoc Inf_lower Inf_greatest fInf_distr_var fInf_distl_var)

end

text \<open>Three comments seem worth making. Firstly, the result bakes in duality by considering Infs in the function space as
Sups in the quantale, hence as Infs in the dual quantale. Secondly, the use of Sup-quantales not only reduces the number of proof obligations.
It also copes with the fact that Sups and top are not represented faithfully by this construction. They are generally different from
those in the super-quantale of isotone transformers. But of course they can be defined from Infs as usual. Alternatively, I could have
proved the results for Inf-quantales, which may have been more straightforward. But Sup-lattices are more conventional.
Thirdly, as in the case of isotone transformers, the proof depends on a restriction to one single type, whereas previous results have
been obtained for poly-typed quantales or quantaloids.\<close>

end


(*:maxLineLen=78:*)

section \<open> Finite Boolean Algebra Probability \label{sec:finite-boolean-algebra-probability} \<close>

(* TODO: Cite Bool's laws of thought, Dempster, Nils Nilsson's Probabilisitic Logic *)

theory Finite_Probability
  imports
    "../Logic/Probability_Logic"
    Finite_Boolean_Algebra
begin

sledgehammer_params [smt_proofs = false]

no_notation
  verum ("\<top>") and
  falsum ("\<bottom>") and
  disjunction (infixr "\<squnion>" 67) and
  conjunction (infixr "\<sqinter>" 67) and
  arbitrary_conjunction ("\<Sqinter>") and
  arbitrary_disjunction ("\<Squnion>")

class \
 =
  fixes \
 :: "'a \<Rightarrow> real"

subsection \<open> Definition of Finitely Additive Probability \<close>

text \<open> TODO: cite @{cite booleChapterXVIIGeneral1853}, @{cite broderickBooleanAlgebraProbability1940}, ``Elementary Theory of Probability'' @{cite kolmogoroffChapterElementareWahrscheinlichkeitsrechnung1933} \<close>

class finitely_additive_probability = \
 + boolean_algebra +
  assumes probability_non_negative: "\
 \<phi> \<ge> 0"
  assumes probability_unity: "\
 \<top> = 1"
  assumes finite_additivity: "\<phi> \<sqinter> \<psi> = \<bottom> \<Longrightarrow> \
 (\<phi> \<squnion> \<psi>) = \
 \<phi> + \
 \<psi>"

context boolean_algebra begin

subsection \<open> Equivalence With Probability Logic \label{subsec:boolean-algebra-probability}\<close>

text \<open> The Boolean algebra formulation of finitely additive probability is
       in fact a special case of probability logic as presented in \S\ref{sec:definition-of-probability-logic}.\<close>

definition residual (infixr "\<Rightarrow>" 70) where
  "\<phi> \<Rightarrow> \<psi> \<equiv> - \<phi> \<squnion> \<psi>"

lemma residual_galois_connection:
  "A \<sqinter> B \<le> C \<longleftrightarrow> B \<le> A \<Rightarrow> C"
proof
  assume "A \<sqinter> B \<le> C"
  have "B \<squnion> (A \<Rightarrow> C) = A \<Rightarrow> C \<squnion> B \<sqinter> \<top>"
    unfolding residual_def
    using inf_top.right_neutral
          sup_commute
    by presburger
  moreover have "\<top> = A \<Rightarrow> C \<squnion> A"
    unfolding residual_def
    using sup_commute sup_compl_top_left2
    by fastforce
  ultimately have "B \<squnion> (A \<Rightarrow> C) = A \<Rightarrow> C \<squnion> B \<sqinter> A"
    unfolding residual_def
    by (simp add: sup_inf_distrib1)
  moreover have "A \<sqinter> B \<squnion> C = C"
    using \<open>A \<sqinter> B \<le> C\<close> sup.absorb_iff2 by blast
  ultimately show "B \<le> A \<Rightarrow> C"
    unfolding residual_def
    by (metis
          inf_commute
          sup.absorb_iff2
          sup.semigroup_axioms
          sup_commute
          semigroup.assoc)
next
  assume "B \<le> A \<Rightarrow> C"
  hence "B \<sqinter> (A \<Rightarrow> C) = B"
    using inf_absorb1
    unfolding residual_def
    by fastforce
  moreover have "A \<Rightarrow> C = C \<squnion> - A"
    unfolding residual_def
    by (simp add: abel_semigroup.commute sup.abel_semigroup_axioms)
  moreover have "A \<sqinter> B \<sqinter> C = A \<sqinter> (B \<sqinter> C)"
      by (simp add: inf.semigroup_axioms semigroup.assoc)
  ultimately show "A \<sqinter> B \<le> C"
    unfolding residual_def
    by (metis
          (no_types)
          inf.orderI
          inf_compl_bot_right
          inf_sup_distrib1
          sup_bot.right_neutral)
qed

interpretation classical_logic "(=) \<top>" "(\<Rightarrow>)" \<bottom>
proof standard
  fix \<phi> \<psi>
  show "\<top> = \<phi> \<Rightarrow> \<psi> \<Rightarrow> \<phi>"
    unfolding residual_def
    by (simp add: sup.commute)
next
  fix \<phi> \<psi> \<chi>
  show "\<top> = (\<phi> \<Rightarrow> \<psi> \<Rightarrow> \<chi>) \<Rightarrow> (\<phi> \<Rightarrow> \<psi>) \<Rightarrow> \<phi> \<Rightarrow> \<chi>"
  proof -
    have "\<top> = (\<phi> \<Rightarrow> \<chi>) \<Rightarrow> \<phi> \<Rightarrow> \<chi>"
      unfolding residual_def
      by (metis compl_sup_top)
    moreover have "- \<phi> \<Rightarrow> \<phi> \<Rightarrow> \<chi> = - \<phi> \<Rightarrow> (\<phi> \<Rightarrow> \<psi> \<Rightarrow> \<chi>) \<Rightarrow> \<phi> \<Rightarrow> \<chi>"
      unfolding residual_def
      by (metis sup_compl_top_left2 sup_left_commute)
    moreover have "\<psi> \<Rightarrow> (\<phi> \<Rightarrow> \<psi> \<Rightarrow> \<chi>) \<Rightarrow> \<phi> \<Rightarrow> \<chi> = \<chi> \<Rightarrow> \<phi> \<Rightarrow> \<chi>"
      unfolding residual_def
      by (metis compl_sup_top sup_compl_top_left2 sup_left_commute)
    ultimately have "\<top> = (\<phi> \<Rightarrow> \<psi> \<Rightarrow> \<chi>) \<Rightarrow> (\<phi> \<Rightarrow> \<chi>) \<squnion> - (\<phi> \<Rightarrow> \<psi>)"
      unfolding residual_def
      using
        abel_semigroup.commute
        sup.abel_semigroup_axioms
        sup_inf_distrib1
      by fastforce
    hence "\<top> = (\<phi> \<Rightarrow> \<psi>) \<Rightarrow> (\<phi> \<Rightarrow> \<psi> \<Rightarrow> \<chi>) \<Rightarrow> \<phi> \<Rightarrow> \<chi>"
      unfolding residual_def
      by (simp add: abel_semigroup.commute sup.abel_semigroup_axioms)
    thus ?thesis
      unfolding residual_def
      by (simp add: sup_left_commute)
  qed
next
  fix \<phi> \<psi>
  show "\<top> = \<phi> \<Rightarrow> \<psi> \<Longrightarrow> \<top> = \<phi> \<Longrightarrow> \<top> = \<psi>"
    unfolding residual_def
    using compl_top_eq
    by auto
next
  fix \<phi>
  show "\<top> = ((\<phi> \<Rightarrow> \<bottom>) \<Rightarrow> \<bottom>) \<Rightarrow> \<phi>"
    unfolding residual_def
    by simp
qed

lemmas axiom_k = axiom_k
lemmas axiom_s = axiom_s
lemmas double_negation = double_negation
lemmas modus_ponens = modus_ponens
lemmas probabilities_def = probabilities_def

lemma probabilities_def':
  "probabilities =
     { \
. class.finitely_additive_probability
                \
 (-) uminus (\<sqinter>) (\<le>) (<) (\<squnion>) \<bottom> \<top> }"
  (is "_ = ?ba_probabilities")
proof
  show "?ba_probabilities \<subseteq> probabilities"
  proof
    fix \

    assume "\
 \<in> ?ba_probabilities"
    from this interpret
      finitely_additive_probability \

      unfolding probabilities_def
      by auto
    have "class.probability_logic ((=) \<top>) (\<Rightarrow>) \<bottom> \
"
    proof standard
      fix \<phi>
      show "0 \<le> \
 \<phi>"
        by (simp add: probability_non_negative)
    next
      fix \<phi>
      show "\<top> = \<phi> \<Longrightarrow> \
 \<phi> = 1"
        using probability_unity by blast
    next
      fix \<phi> \<psi>
      assume "\<top> = (\<phi> \<Rightarrow> \<psi> \<Rightarrow> \<bottom>)"
      hence "\<phi> \<sqinter> \<psi> = \<bottom>"
        unfolding residual_def
        using compl_top_eq by auto
      thus "\
 ((\<phi> \<Rightarrow> \<bottom>) \<Rightarrow> \<psi>) = \
 \<phi> + \
 \<psi>"
        unfolding residual_def
        by (simp add: finite_additivity)
    qed
    thus "\
 \<in> probabilities"
      unfolding probabilities_def
      by auto
  qed
next
  show "probabilities \<subseteq> ?ba_probabilities"
  proof
    fix \

    assume "\
 \<in> probabilities"
    from this interpret probability_logic "(=) \<top>" "(\<Rightarrow>)" \<bottom> \

      unfolding probabilities_def
      by auto
    have
      "class.finitely_additive_probability
         \
 (-) uminus (\<sqinter>) (\<le>) (<) (\<squnion>) \<bottom> \<top>"
    proof standard
      fix \<phi>
      show "0 \<le> \
 \<phi>"
        by (simp add: probability_non_negative)
    next
      show "\
 \<top> = 1"
        using probability_unity by blast
    next
      fix \<phi> \<psi>
      assume "\<phi> \<sqinter> \<psi> = \<bottom>"
      thus "\
 (\<phi> \<squnion> \<psi>) = \
 \<phi> + \
 \<psi>"
        using
          probability_implicational_additivity
          compl_bot_eq
          sup_bot.right_neutral
          residual_def
        by force
    qed
    thus "\
 \<in> ?ba_probabilities"
      by auto
  qed
qed

lemma join_prime_to_dirac_measure:
  assumes "\<alpha> \<in> \<J>"
  shows "(\<lambda> \<phi>. if \<alpha> \<le> \<phi> then 1 else 0) \<in> dirac_measures"
  (is "?\<delta> \<in> dirac_measures")
proof -
  have "class.probability_logic ((=) \<top>) (\<Rightarrow>) \<bottom> ?\<delta>"
  proof standard
    fix \<phi>
    show "0 \<le> ?\<delta> \<phi>"
      by fastforce
  next
    fix \<phi>
    show "\<top> = \<phi> \<Longrightarrow> (if \<alpha> \<le> \<phi> then 1 else 0) = 1"
      using top_greatest by auto
  next
    fix \<phi> \<psi>
    assume "\<top> = \<phi> \<Rightarrow> \<psi> \<Rightarrow> \<bottom>"
    hence "\<phi> \<sqinter> \<psi> = \<bottom>"
      using compl_top_eq residual_def by auto
    hence "\<not> \<alpha> \<le> \<phi> \<or> \<not> \<alpha> \<le> \<psi>"
      using \<open>\<alpha> \<in> \<J>\<close>
      unfolding join_primes_def join_prime_def
      using bot_unique inf.boundedI by blast
    moreover have "\<alpha> \<le> \<phi> \<squnion> \<psi> \<longleftrightarrow> \<alpha> \<le> \<phi> \<or> \<alpha> \<le> \<psi>"
      using \<open>\<alpha> \<in> \<J>\<close>
      unfolding join_primes_def join_prime_def
      using le_supI1 le_supI2 by blast
    ultimately show "?\<delta> ((\<phi> \<Rightarrow> \<bottom>) \<Rightarrow> \<psi>) = ?\<delta> \<phi> + ?\<delta> \<psi>"
      unfolding residual_def
      by auto
  qed
  thus ?thesis
    unfolding dirac_measures_def
    by simp
qed

lemma conditional_probability_measure:
  fixes   \
 :: "'a \<Rightarrow> real"
  assumes "\
 \<in> probabilities" and "\
 \<psi> \<noteq> 0"
  shows   "(\<lambda> \<phi>. \
 (\<phi> \<sqinter> \<psi>) / \
 \<psi>) \<in> probabilities"
proof -
  from assms interpret
    finitely_additive_probability \

    unfolding probabilities_def'
    by auto
  have "\
 \<psi> > 0"
    using
      \<open>\
 \<psi> \<noteq> 0\<close>
      probability_non_negative
      order_class.dual_order.order_iff_strict
    by blast
  let ?\
' = "\<lambda> \<phi>. \
 (\<phi> \<sqinter> \<psi>) / \
 \<psi>"
  have "class.finitely_additive_probability
          ?\
' (-) uminus (\<sqinter>) (\<le>) (<) (\<squnion>) \<bottom> \<top>"
  proof standard
    fix \<phi>
    show "0 \<le> \
 (\<phi> \<sqinter> \<psi>) / \
 \<psi>"
      by (simp add: probability_non_negative)
  next
    show "\
 (\<top> \<sqinter> \<psi>) / \
 \<psi> = 1"
      using \<open>0 < \
 \<psi>\<close> inf_top_left by auto
  next
    fix \<phi> \<chi>
    assume "\<phi> \<sqinter> \<chi> = \<bottom>"
    hence "\
 ((\<phi> \<squnion> \<chi>) \<sqinter> \<psi>) = \
 (\<phi> \<sqinter> \<psi>) + \
 (\<chi> \<sqinter> \<psi>)"
      by (metis
            finite_additivity
            inf.assoc
            inf.commute
            inf_bot_right
            inf_sup_distrib2)
    thus "\
 ((\<phi> \<squnion> \<chi>) \<sqinter> \<psi>) / \
 \<psi> = \
 (\<phi> \<sqinter> \<psi>) / \
 \<psi> + \
 (\<chi> \<sqinter> \<psi>) / \
 \<psi>"
      by (simp add: add_divide_distrib)
  qed
  thus ?thesis
    unfolding probabilities_def'
    by blast
qed

lemma probabilities_convex:
  fixes   \
 \<Q> :: "'a \<Rightarrow> real" and \<alpha> :: real
  assumes "{\
,\<Q>} \<subseteq> probabilities" and "0 \<le> \<alpha>" and "\<alpha> \<le> 1"
  shows   "(\<lambda> \<phi>. \<alpha> * \
 \<phi> + (1 - \<alpha>) * \<Q> \<phi>) \<in> probabilities"
proof -
  let ?\<M> = "\<lambda> \<phi>. \<alpha> * \
 \<phi> + (1 - \<alpha>) * \<Q> \<phi>"
  from assms interpret finitely_additive_probability \

    unfolding probabilities_def'
    by auto
  note \
_probability_non_negative = probability_non_negative
  note \
_probability_unity = probability_unity
  note \
_finite_additivity = finite_additivity
  from assms interpret finitely_additive_probability \<Q>
    unfolding probabilities_def'
    by auto
  have "class.finitely_additive_probability
          ?\<M> (-) uminus (\<sqinter>) (\<le>) (<) (\<squnion>) \<bottom> \<top>"
  proof standard
    fix \<phi>
    show "0 \<le> \<alpha> * \
 \<phi> + (1 - \<alpha>) * \<Q> \<phi>"
      by (simp add:
            \
_probability_non_negative
            probability_non_negative
            \<open>0 \<le> \<alpha>\<close>
            \<open>\<alpha> \<le> 1\<close>)
  next
    show "\<alpha> * \
 \<top> + (1 - \<alpha>) * \<Q> \<top> = 1"
      using \
_probability_unity probability_unity by auto
  next
    fix \<phi> \<psi>
    assume "\<phi> \<sqinter> \<psi> = \<bottom>"
    thus "  \<alpha> * \
 (\<phi> \<squnion> \<psi>) + (1 - \<alpha>) * \<Q> (\<phi> \<squnion> \<psi>)
          = \<alpha> * \
 \<phi> + (1 - \<alpha>) * \<Q> \<phi> + (\<alpha> * \
 \<psi> + (1 - \<alpha>) * \<Q> \<psi>)"
      by (simp add: \
_finite_additivity distrib_left finite_additivity)
  qed
  thus ?thesis
    unfolding probabilities_def'
    by auto
qed

end

context finitely_additive_probability begin

interpretation classical_logic "(=) \<top>" "(\<Rightarrow>)" \<bottom>
  by (standard,
        simp add: axiom_k,
        simp add: axiom_s,
        metis modus_ponens,
        simp add: double_negation)

interpretation probability_logic "(=) \<top>" "(\<Rightarrow>)" \<bottom> \

proof -
  have "class.finitely_additive_probability
          \
 (-) uminus (\<sqinter>) (\<le>) (<) (\<squnion>) \<bottom> \<top>"
    by standard
  hence "\
 \<in> probabilities"
    unfolding probabilities_def'
    by auto

  thus "class.probability_logic ((=) \<top>) (\<Rightarrow>) \<bottom> \
"
    unfolding probabilities_def
    by blast
qed

lemma sum_rule: "\
 a + \
 b = \
 (a \<sqinter> b) + \
 (a \<squnion> b)"
  by (metis compl_inf
            conjunction_def
            disjunction_def
            double_compl
            residual_def
            sum_rule
            sup.commute
            sup_bot.left_neutral)

lemma conditional_probability_join_prime:
  assumes "\<alpha> \<in> \<J>" and "\
 \<alpha> \<noteq> 0"
  shows   "\
 (\<phi> \<sqinter> \<alpha>) / \
 \<alpha> = (if \<alpha> \<le> \<phi> then 1 else 0)"
proof (cases "\<alpha> \<le> \<phi>")
  case True
  hence "\
 (\<phi> \<sqinter> \<alpha>) = \
 \<alpha>"
    by (simp add: inf_absorb2)
  hence "\
 (\<phi> \<sqinter> \<alpha>) / \
 \<alpha> = 1"
    using \<open>\
 \<alpha> \<noteq> 0\<close> right_inverse_eq by blast
  then show ?thesis
    using \<open>\<alpha> \<le> \<phi>\<close> by simp
next
  case False
  hence "\<alpha> \<le> - \<phi>"
    using \<open>\<alpha> \<in> \<J>\<close> top_greatest
    unfolding join_primes_def join_prime_def
    by force
  hence "\<phi> \<sqinter> \<alpha> = \<bottom>"
    by (metis inf_absorb1 inf_compl_bot_right)
  hence "\
 (\<phi> \<sqinter> \<alpha>) / \
 \<alpha> = 0"
    using finite_additivity inf_bot_right sup_bot.right_neutral by fastforce
  then show ?thesis
    using \<open>\<not> \<alpha> \<le> \<phi>\<close> by auto
qed

lemma join_prime_conditional_probability:
  assumes "\<forall> \<phi>. \
 (\<phi> \<sqinter> \<alpha>) / \
 \<alpha> = (if \<alpha> \<le> \<phi> then 1 else 0)"
  shows   "\<alpha> \<in> \<J>"
proof -
  have "\
 (\<top> \<sqinter> \<alpha>) / \
 \<alpha> = 1"
    using assms top_greatest by auto
  hence "\
 \<alpha> > 0"
    using less_eq_real_def probability_non_negative by fastforce
  hence "\<alpha> \<noteq> \<bottom>"
    using gaines_weatherson_antithesis by auto
  moreover
  have \<star>: "\<forall> \<phi>. \
 (\<phi> \<sqinter> \<alpha>) = (if \<alpha> \<le> \<phi> then \
 \<alpha> else 0)"
    by (metis \<open>\
 (\<top> \<sqinter> \<alpha>) / \
 \<alpha> = 1\<close>
              \<open>\<forall> \<phi>. \
 (\<phi> \<sqinter> \<alpha>) / \
 \<alpha> = (if \<alpha> \<le> \<phi> then 1 else 0)\<close>
              divide_eq_0_iff
              inf.absorb2 zero_neq_one)
  {
    fix \<phi> \<psi>
    assume "\<alpha> \<le> \<phi> \<squnion> \<psi>"
    have "\<alpha> \<le> \<phi> \<or> \<alpha> \<le> \<psi>"
    proof (rule ccontr)
      assume "\<not> (\<alpha> \<le> \<phi> \<or> \<alpha> \<le> \<psi>)"
      hence "\
 (\<phi> \<sqinter> \<alpha>) = 0"
            "\
 (\<psi> \<sqinter> \<alpha>) = 0"
        using \<star> by auto
      hence "0 = \
 ((\<phi> \<sqinter> \<alpha>) \<sqinter> (\<psi> \<sqinter> \<alpha>)) + \
 ((\<phi> \<sqinter> \<alpha>) \<squnion> (\<psi> \<sqinter> \<alpha>))"
        using sum_rule by auto
      hence "0 = \
 (\<phi> \<sqinter> \<psi> \<sqinter> \<alpha>) + \
 ((\<phi> \<squnion> \<psi>) \<sqinter> \<alpha>)"
        by (simp add: inf.commute inf.left_commute inf_sup_distrib1)
      hence "0 = \
 (\<phi> \<sqinter> \<psi> \<sqinter> \<alpha>) + \
 \<alpha>"
        by (simp add: \<open>\<alpha> \<le> \<phi> \<squnion> \<psi>\<close> inf.absorb2)
      hence "0 > \
 (\<phi> \<sqinter> \<psi> \<sqinter> \<alpha>)"
        using \<open>0 < \
 \<alpha>\<close> by linarith
      thus False
        using probability_non_negative not_le by blast
    qed
  }
  ultimately show ?thesis
    unfolding join_primes_def join_prime_def
    by blast
qed

lemma monotonicity: "a \<le> b \<Longrightarrow> \
 a \<le> \
 b"
  by (metis
        monotonicity
        residual_def
        sup.commute
        sup.left_commute
        sup_absorb1
        sup_cancel_left1)

lemmas gaines_weatherson_antithesis = gaines_weatherson_antithesis

lemma complementation: "\
 (- \<phi>) = 1 - \
 \<phi>"
  by (metis add_diff_cancel_left'
            finite_additivity
            probability_unity
            inf_compl_bot
            sup_compl_top)

lemma finite_certainty:
  assumes "finite A" and "\<forall> a \<in> A. \
 a = 1"
  shows   "\
 (Finite_Set.fold (\<sqinter>) \<top> A) = 1"
  using assms
proof (induct A rule: finite_induct)
  case empty
  show "\
 (Finite_Set.fold (\<sqinter>) \<top> {}) = 1"
    by (simp add: probability_unity)
next
  case (insert a A)
  have \<star>: "\
 (Finite_Set.fold (\<sqinter>) \<top> (insert a A))
             = \
 (a \<sqinter> Finite_Set.fold (\<sqinter>) \<top> A)"
       (is "\
 ?A' = \
 (a \<sqinter> ?A)")
    by (simp add:
          comp_fun_idem.fold_insert_idem
          insert.hyps(1)
          comp_fun_idem_inf)
  have "\
 ?A = 1"
    using insert.hyps(3) insert.prems by blast
  moreover have "\
 a = 1"
    by (simp add: insert.prems)
  moreover
  have "a \<le> a \<squnion> ?A" by simp
  hence "1 \<le> \
 (a \<squnion> ?A)"
    using monotonicity \<open>\
 a = 1\<close>
    by fastforce
  hence "\
 (a \<squnion> ?A) = 1"
    using unity_upper_bound [of "a \<squnion> ?A"]
    by linarith
  ultimately have "\
 (a \<sqinter> ?A) = 1"
    using sum_rule [where a="a" and b="?A"]
    by linarith
  thus "\
 ?A' = 1"
    using \<star> by auto
qed

lemma full_finite_additivity:
  assumes "finite A" and "\<forall> a \<in> A. \<forall> a' \<in> A. a \<noteq> a' \<longrightarrow> a \<sqinter> a' = \<bottom>"
  shows   "\
 (Finite_Set.fold (\<squnion>) \<bottom> A) = (\<Sum> a \<in> A. \
 a)"
  using assms
proof (induct A rule: finite_induct)
  case empty
  then show ?case
    using gaines_weatherson_antithesis by fastforce
next
  case (insert a A)
  hence "\<forall>a' \<in> A. a \<sqinter> a' = \<bottom>"
    by auto
  with \<open>finite A\<close> \<open>a \<notin> A\<close>
    have "a \<sqinter> (Finite_Set.fold (\<squnion>) \<bottom> A) = \<bottom>" (is "a \<sqinter> ?UA = \<bottom>")
  proof (induct A rule: finite_induct)
    case empty
    then show ?case by auto
  next
    case (insert a' A)
    hence "a \<sqinter> (Finite_Set.fold (\<squnion>) \<bottom> A) = \<bottom>" (is "a \<sqinter> ?UA = \<bottom>")
          "a \<sqinter> a' = \<bottom>"
      by auto
    moreover
      have "Finite_Set.fold (\<squnion>) \<bottom> ({a'} \<union> A) = a' \<squnion> ?UA"
           (is "?UA' = _")
        by (simp add:
              comp_fun_idem.fold_insert_idem
              \<open>finite A\<close>
              comp_fun_idem_sup)
    hence "a \<sqinter> ?UA' = (a \<sqinter> a') \<squnion> (a \<sqinter> ?UA)"
      using inf_sup_distrib1 by auto
    ultimately show ?case
      by auto
  qed
  moreover have "Finite_Set.fold (\<squnion>) \<bottom> ({a} \<union> A) = a \<squnion> ?UA"
    by (simp add: comp_fun_idem.fold_insert_idem \<open>finite A\<close> comp_fun_idem_sup)
  moreover have "\
 ?UA = (\<Sum> a \<in> A. \
 a)"
    using insert by blast
  ultimately show ?case
    by (simp add: \<open>finite A\<close> \<open>a \<notin> A\<close> finite_additivity)
qed

end

subsection \<open> Collapse Theorem For Finite Boolean Algebras \label{subsec:finite-boolean-algebra-collapse} \<close>

context finite_boolean_algebra begin

interpretation classical_logic "(=) \<top>" "(\<Rightarrow>)" \<bottom>
  by (standard,
        simp add: axiom_k,
        simp add: axiom_s,
        metis modus_ponens,
        simp add: double_negation)

lemma join_prime_decomposition:
  fixes   \
 :: "'a \<Rightarrow> real"
  assumes "\
 \<in> probabilities"
  shows   "\
 \<phi> = (\<Sum> \<alpha> \<in> \<J>. \
 \<alpha> * (if \<alpha> \<le> \<phi> then 1 else 0))"
proof -
  interpret finitely_additive_probability \

    using \<open>\
 \<in> probabilities\<close>
    unfolding probabilities_def'
    by blast
  have \<star>: "\<phi> = \<Squnion> { \<alpha> \<in> \<J>. \<alpha> \<le> \<phi> }" (is "\<phi> = \<Squnion> ?\<J>\<phi>")
    using
      join_prime_embedding_def
      sup_join_prime_embedding_ident
    by auto
  have "\<forall> \<alpha> \<in> ?\<J>\<phi>. \<forall> \<alpha>' \<in> ?\<J>\<phi>. \<alpha> \<noteq> \<alpha>' \<longrightarrow> \<alpha> \<sqinter> \<alpha>' = \<bottom>"
    unfolding join_primes_def
    by (metis inf.cobounded1 inf.commute join_prime_def' mem_Collect_eq)
  hence "\
 (\<Squnion> ?\<J>\<phi>) = (\<Sum> \<alpha> \<in> ?\<J>\<phi>. \
 \<alpha>)"
    by (simp add: Sup_def full_finite_additivity)
  with \<star> have \<dagger>: "\
 \<phi> = (\<Sum> \<alpha> \<in> ?\<J>\<phi>. \
 \<alpha>)" by auto
  have "finite ?\<J>\<phi>" by auto
  hence "(\<Sum> \<alpha> \<in> ?\<J>\<phi>. \
 \<alpha>) = (\<Sum> \<alpha> \<in> ?\<J>\<phi>. \
 \<alpha> * (if \<alpha> \<le> \<phi> then 1 else 0))"
    by (induct ?\<J>\<phi> rule: finite_induct, auto)
  with \<dagger> have "\
 \<phi> = (\<Sum> \<alpha> \<in> ?\<J>\<phi>. \
 \<alpha> * (if \<alpha> \<le> \<phi> then 1 else 0))"
    (is "_ = ?\<Sigma>1")
    by presburger
  moreover
  let ?n\<J>\<phi> = "{ \<alpha> \<in> \<J>. \<not> \<alpha> \<le> \<phi> }"
  have "finite ?n\<J>\<phi>" by auto
  hence "0 = (\<Sum> \<alpha> \<in> ?n\<J>\<phi>. \
 \<alpha> * (if \<alpha> \<le> \<phi> then 1 else 0))"
    (is "_ = ?\<Sigma>2")
    by (induct ?n\<J>\<phi> rule: finite_induct, auto)
  with \<dagger> have \<ddagger>: "\
 \<phi> = ?\<Sigma>1 + ?\<Sigma>2" by auto
  have "\<forall>\<alpha> \<in> ?\<J>\<phi> \<inter> ?n\<J>\<phi>. \
 \<alpha> * (if \<alpha> \<le> \<phi> then 1 else 0) = 0" by auto
  with \<ddagger> have "\
 \<phi> = (\<Sum> \<alpha> \<in> ?\<J>\<phi> \<union> ?n\<J>\<phi>. \
 \<alpha> * (if \<alpha> \<le> \<phi> then 1 else 0))"
    by (simp add: sum.union_inter_neutral [where A="?\<J>\<phi>" and B="?n\<J>\<phi>"])
  moreover have "\<J> = ?\<J>\<phi> \<union> ?n\<J>\<phi>" by auto
  ultimately show ?thesis
    by auto
qed

lemma dirac_measure_to_join_prime:
  assumes "\<delta> \<in> dirac_measures"
  shows "\<Sqinter> { \<phi> . \<delta> \<phi> = 1 } \<in> \<J>"
  (is "?\<alpha> \<in> \<J>")
proof -
  have "\<delta> \<in> probabilities"
    using
      \<open>\<delta> \<in> dirac_measures\<close>
      probabilities_def
    unfolding dirac_measures_def
    by blast
  interpret finitely_additive_probability \<delta>
    using \<open>\<delta> \<in> probabilities\<close>
    unfolding probabilities_def'
    by auto
  have "\<forall> \<phi> \<in> { \<phi> . \<delta> \<phi> = 1 }. \<delta> \<phi> = 1"
       (is "\<forall> \<phi> \<in> ?A. \<delta> \<phi> = 1")
       by auto
  hence "\<delta> ?\<alpha> = 1"
    using finite_certainty Inf_def finite
    by presburger
  hence "?\<alpha> \<noteq> \<bottom>"
    using gaines_weatherson_antithesis
    by auto
  moreover
  {
    fix y z
    assume "?\<alpha> \<le> y \<squnion> z"
    hence "1 \<le> \<delta> (y \<squnion> z)"
      using \<open>\<delta> ?\<alpha> = 1\<close> monotonicity
      by fastforce
    hence "\<delta> (y \<squnion> z) = 1"
      by (metis
            probability_unity
            monotonicity
            sup.cobounded2
            sup_top_left
            order_class.eq_iff)
    moreover have "\<delta> y = 0 \<Longrightarrow> \<delta> z = 0 \<Longrightarrow> \<delta> (y \<squnion> z) = 0"
      by (metis
            add.right_neutral
            add_diff_cancel_left'
            diff_ge_0_iff_ge
            probability_non_negative
            sum_rule
            order_class.eq_iff)
    ultimately have "\<delta> y \<noteq> 0 \<or> \<delta> z \<noteq> 0"
      by linarith
    hence "\<delta> y = 1 \<or> \<delta> z = 1"
      using \<open>\<delta> \<in> dirac_measures\<close>
      unfolding dirac_measures_def
      by auto
    hence "y \<in> ?A \<or> z \<in> ?A"
      by auto
    hence "?\<alpha> \<le> y \<or> ?\<alpha> \<le> z"
      using Inf_lower by auto
  }
  ultimately show ?thesis
    unfolding join_primes_def join_prime_def
    by auto
qed

lemma dirac_to_join_prime_ident:
  assumes "\<delta> \<in> dirac_measures"
  shows "(\<lambda> \<phi>. if \<Sqinter> { \<phi> . \<delta> \<phi> = 1 } \<le> \<phi> then 1 else 0) = \<delta>"
proof
  have "\<delta> \<in> probabilities"
    using
      \<open>\<delta> \<in> dirac_measures\<close>
      probabilities_def
    unfolding dirac_measures_def
    by blast
  interpret finitely_additive_probability \<delta>
    using \<open>\<delta> \<in> probabilities\<close>
    unfolding probabilities_def'
    by auto
  fix \<phi>
  show "(if \<Sqinter> { \<phi> . \<delta> \<phi> = 1 } \<le> \<phi> then 1 else 0) = \<delta> \<phi>"
  proof (cases "\<delta> \<phi> = 1")
    case True
    hence "\<Sqinter> { \<phi> . \<delta> \<phi> = 1 } \<le> \<phi>"
      by (fastforce simp add: Inf_lower)
    hence "(if \<Sqinter> { \<phi> . \<delta> \<phi> = 1 } \<le> \<phi> then 1 else 0) = 1"
      by auto
    then show ?thesis
      using \<open>\<delta> \<phi> = 1\<close>
      by simp
  next
    have "join_prime (\<Sqinter> { \<phi> . \<delta> \<phi> = 1 })"
      using
        \<open>\<delta> \<in> dirac_measures\<close>
        dirac_measure_to_join_prime
      unfolding join_primes_def
      by blast
    case False
    hence "\<delta> \<phi> = 0"
      using \<open>\<delta> \<in> dirac_measures\<close>
      unfolding dirac_measures_def
      by auto
    hence "\<delta> (- \<phi>) = 1"
      using complementation
      by auto
    hence "\<Sqinter> { \<phi> . \<delta> \<phi> = 1 } \<le> - \<phi>"
      by (fastforce simp add: Inf_lower)
    hence "\<not> (\<Sqinter> { \<phi> . \<delta> \<phi> = 1 } \<le> \<phi>)"
      using \<open>join_prime (\<Sqinter> { \<phi> . \<delta> \<phi> = 1 })\<close>
      unfolding join_prime_def
      by (metis inf.boundedI inf_compl_bot le_bot)
    hence "(if \<Sqinter> { \<phi> . \<delta> \<phi> = 1 } \<le> \<phi> then 1 else 0) = 0"
      by auto
    then show ?thesis
      using \<open>\<delta> \<phi> = 0\<close>
      by auto
  qed
qed

lemma join_prime_to_dirac_ident:
  assumes "\<alpha> \<in> \<J>"
  shows "\<Sqinter>{ \<phi>. (\<lambda> \<phi>. if \<alpha> \<le> \<phi> then 1 else 0) \<phi> = (1 :: real)} = \<alpha>"
  (is "?\<alpha> = \<alpha>")
proof (rule antisym)
  have "\<alpha> \<in> { \<phi>. (\<lambda> \<phi>. if \<alpha> \<le> \<phi> then 1 else 0) \<phi> = 1 }"
    by simp
  thus "?\<alpha> \<le> \<alpha>"
    by (simp add: Inf_lower)
next
  {
    fix \<phi>
    assume "\<phi> \<in> { \<phi>. (\<lambda> \<phi>. if \<alpha> \<le> \<phi> then 1 else 0) \<phi> = (1 :: real) }"
    hence "(if \<alpha> \<le> \<phi> then 1 else 0) = (1 :: real)"
      by fastforce
    hence "\<alpha> \<le> \<phi>"
      by (meson zero_neq_one)
  }
  hence "\<forall> \<phi> \<in> { \<phi>. (\<lambda> \<phi>. if \<alpha> \<le> \<phi> then 1 else 0) \<phi> = (1 :: real) } . \<alpha> \<le> \<phi>"
    by blast
  thus "\<alpha> \<le> ?\<alpha>"
    using Inf_greatest by blast
qed

lemma dirac_join_prime_bij_betw:
  "bij_betw (\<lambda> \<alpha> \<phi>. if \<alpha> \<le> \<phi> then 1 else 0 :: real) \<J> dirac_measures"
  unfolding bij_betw_def
proof
  obtain to_\<delta> where to_\<delta>_def:
    "to_\<delta> = (\<lambda> \<alpha> \<phi> . if \<alpha> \<le> \<phi> then 1 else 0 :: real)" by auto
  {
    fix \<alpha>\<^sub>1 \<alpha>\<^sub>2
    assume
      "\<alpha>\<^sub>1 \<in> \<J>"
      "\<alpha>\<^sub>2 \<in> \<J>"
      "to_\<delta> \<alpha>\<^sub>1 = to_\<delta> \<alpha>\<^sub>2"
    moreover from this have
      " \<Sqinter>{ \<phi>. (\<lambda> \<phi>. if \<alpha>\<^sub>1 \<le> \<phi> then 1 else 0) \<phi> = (1 :: real) }
         = \<Sqinter>{ \<phi>. (\<lambda> \<phi>. if \<alpha>\<^sub>2 \<le> \<phi> then 1 else 0) \<phi> = (1 :: real) }"
      unfolding to_\<delta>_def
      by metis
    ultimately have "\<alpha>\<^sub>1 = \<alpha>\<^sub>2"
      using
        join_prime_to_dirac_ident [of \<alpha>\<^sub>1]
        join_prime_to_dirac_ident [of \<alpha>\<^sub>2]
      by presburger
  }
  hence "inj_on to_\<delta> \<J>"
    unfolding inj_on_def
    by blast
  thus "inj_on (\<lambda> \<alpha> \<phi>. if \<alpha> \<le> \<phi> then 1 else 0 :: real) \<J>"
    unfolding to_\<delta>_def
    by blast
next
  show "(\<lambda>\<alpha> \<phi>. if \<alpha> \<le> \<phi> then 1 else 0) ` \<J> = dirac_measures"
  proof
    {
      fix \<alpha>
      assume "\<alpha> \<in> \<J>"
      hence "(\<lambda>\<phi>. if \<alpha> \<le> \<phi> then 1 else 0) \<in> dirac_measures"
        using join_prime_to_dirac_measure by blast
    }
    thus "(\<lambda>\<alpha> \<phi>. if \<alpha> \<le> \<phi> then 1 else 0) ` \<J> \<subseteq> dirac_measures" by blast
  next
    {
      fix \<delta>
      assume "\<delta> \<in> dirac_measures"
      let ?\<alpha> = "\<Sqinter> { \<phi> . \<delta> \<phi> = 1 }"
      have "?\<alpha> \<in> \<J>"
        using \<open>\<delta> \<in> dirac_measures\<close> dirac_measure_to_join_prime by blast
      moreover have "(\<lambda>\<phi>. if ?\<alpha> \<le> \<phi> then 1 else 0) = \<delta>"
        using \<open>\<delta> \<in> dirac_measures\<close> dirac_to_join_prime_ident by blast
      ultimately have "\<delta> \<in> (\<lambda>\<alpha> \<phi>. if \<alpha> \<le> \<phi> then 1 else 0) ` \<J>"
        using image_iff by fastforce
    }
    thus "dirac_measures \<subseteq> (\<lambda>\<alpha> \<phi>. if \<alpha> \<le> \<phi> then 1 else 0) ` \<J>"
      using subsetI
      by blast
  qed
qed

lemma dirac_join_prime_bij_betw_alt:
  "bij_betw (\<lambda> \<delta>. \<Sqinter> { \<phi> . \<delta> \<phi> = 1 }) dirac_measures \<J>"
  (is "bij_betw ?to_\<J> _ _")
  unfolding bij_betw_def
proof
  {
    fix \<delta>\<^sub>1 \<delta>\<^sub>2
    assume
      "\<delta>\<^sub>1 \<in> dirac_measures"
      "\<delta>\<^sub>2 \<in> dirac_measures"
      "?to_\<J> \<delta>\<^sub>1 = ?to_\<J> \<delta>\<^sub>2"
    moreover from this have
      "(\<lambda> \<phi>. if ?to_\<J> \<delta>\<^sub>1 \<le> \<phi> then 1 else 0) = \<delta>\<^sub>1"
      "(\<lambda> \<phi>. if ?to_\<J> \<delta>\<^sub>2 \<le> \<phi> then 1 else 0) = \<delta>\<^sub>2"
      using dirac_to_join_prime_ident by blast+
    ultimately have "\<delta>\<^sub>1 = \<delta>\<^sub>2"
      by presburger
  }
  thus "inj_on ?to_\<J> dirac_measures"
    unfolding inj_on_def
    by auto
next
  show "?to_\<J> ` dirac_measures = \<J>"
  proof
    show "(\<lambda>\<delta>. \<Sqinter> {\<phi>. \<delta> \<phi> = 1}) ` dirac_measures \<subseteq> \<J>"
      using dirac_measure_to_join_prime by blast
  next
    {
      fix \<alpha> :: 'a
      assume "\<alpha> \<in> \<J>"
      hence "(\<lambda>\<phi>. if \<alpha> \<le> \<phi> then 1 else 0 :: real) \<in> dirac_measures"
        using join_prime_to_dirac_measure by blast
      moreover have "?to_\<J> (\<lambda>\<phi>. if \<alpha> \<le> \<phi> then 1 else 0 :: real) = \<alpha>"
        by (simp add: \<open>\<alpha> \<in> \<J>\<close> join_prime_to_dirac_ident)
      ultimately have "\<alpha> \<in> ?to_\<J> ` dirac_measures"
        using image_iff by fastforce
    }
    thus "\<J> \<subseteq> (\<lambda>\<delta>. \<Sqinter> {\<phi>. \<delta> \<phi> = 1}) ` dirac_measures"
      using subsetI
      by blast
  qed
qed

lemma special_dirac_collapse:
  "(\<forall> \
 \<in> probabilities. (\<Sum>\<phi>\<leftarrow>\<Phi>. \
 \<phi>) + c \<le> (\<Sum>\<gamma>\<leftarrow>\<Gamma>. \
 \<gamma>))
      = (\<forall> \
 \<in> dirac_measures. (\<Sum>\<phi>\<leftarrow>\<Phi>. \
 \<phi>) + \<lceil>c\<rceil> \<le> (\<Sum>\<gamma>\<leftarrow>\<Gamma>. \
 \<gamma>))"
proof
  assume \<star>: "\<forall> \
 \<in> probabilities. (\<Sum>\<phi>\<leftarrow>\<Phi>. \
 \<phi>) + c \<le> (\<Sum>\<gamma>\<leftarrow>\<Gamma>. \
 \<gamma>)"
  {
    fix \<delta>
    assume "\<delta> \<in> dirac_measures"
    hence "\<forall> \<phi>. \<delta> \<phi> = 1 \<or> \<delta> \<phi> = 0"
      using dirac_measures_def by blast
    have A: "(\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>) = \<lceil>\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>\<rceil>"
    proof (induct \<Phi>)
      case Nil
      then show ?case using \<open>\<forall> \<phi>. \<delta> \<phi> = 1 \<or> \<delta> \<phi> = 0\<close> by simp
    next
      case (Cons \<phi> \<Phi>)
      then show ?case
      proof (cases "\<delta> \<phi> = 0")
        case True
        then show ?thesis
          using Cons.hyps by fastforce
      next
        case False
        hence "\<delta> \<phi> = 1"
          using \<open>\<forall>\<phi>. \<delta> \<phi> = 1 \<or> \<delta> \<phi> = 0\<close> by blast
        then show ?thesis
          by (simp,
              metis
                Cons.hyps
                add.commute
                ceiling_add_one
                of_int_1
                of_int_add)
      qed
    qed
    have B: "(\<Sum>\<gamma>\<leftarrow>\<Gamma>. \<delta> \<gamma>) = \<lceil>\<Sum>\<gamma>\<leftarrow>\<Gamma>. \<delta> \<gamma>\<rceil>"
    proof (induct \<Gamma>)
      case Nil
      then show ?case using \<open>\<forall> \<phi>. \<delta> \<phi> = 1 \<or> \<delta> \<phi> = 0\<close> by simp
    next
      case (Cons \<gamma> \<Gamma>)
      then show ?case
      proof (cases "\<delta> \<gamma> = 0")
        case True
        then show ?thesis
          using Cons.hyps by fastforce
      next
        case False
        hence "\<delta> \<gamma> = 1"
          using \<open>\<forall>\<phi>. \<delta> \<phi> = 1 \<or> \<delta> \<phi> = 0\<close> by blast
        then show ?thesis
          by (simp,
              metis
                Cons.hyps
                add.commute
                ceiling_add_one
                of_int_1
                of_int_add)
      qed
    qed
    have "\<delta> \<in> probabilities"
      using \<open>\<delta> \<in> dirac_measures\<close> dirac_measures_subset by auto
    hence C: "(\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>) + c \<le> (\<Sum>\<gamma>\<leftarrow>\<Gamma>. \<delta> \<gamma>)"
      using \<star>
      by blast
    from A B C have "\<lceil>(\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>)\<rceil> + c \<le> \<lceil>(\<Sum>\<gamma>\<leftarrow>\<Gamma>. \<delta> \<gamma>)\<rceil>"
      by simp
    hence "\<lceil>(\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>)\<rceil> + \<lceil>c\<rceil> \<le> \<lceil>(\<Sum>\<gamma>\<leftarrow>\<Gamma>. \<delta> \<gamma>)\<rceil>"
      by linarith
    hence "(\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>) + \<lceil>c\<rceil> \<le> (\<Sum>\<gamma>\<leftarrow>\<Gamma>. \<delta> \<gamma>)"
      using A B C by simp
  }
  thus "\<forall> \<delta> \<in> dirac_measures. (\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>) + \<lceil>c\<rceil> \<le> (\<Sum>\<gamma>\<leftarrow>\<Gamma>. \<delta> \<gamma>)"
    by auto
next
  assume \<star>: "\<forall> \<delta> \<in> dirac_measures. (\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>) + \<lceil>c\<rceil> \<le> (\<Sum>\<gamma>\<leftarrow>\<Gamma>. \<delta> \<gamma>)"
  let ?to_\<delta> = "\<lambda> \<alpha> \<phi> :: 'a. if \<alpha> \<le> \<phi> then 1 :: real else 0"
  {
    fix \

    assume "\
 \<in> probabilities"
    from this interpret
      finitely_additive_probability \

      unfolding probabilities_def'
      by auto
    have "finite \<J>" by simp
    {
      fix \<Phi> :: "'a list"
      {
        fix A :: "'a set"
        assume "finite A"
        have "(\<Sum>\<phi> \<leftarrow> \<Phi>. (\<Sum>\<alpha> \<in> A. \
 \<alpha> * ?to_\<delta> \<alpha> \<phi>))
                = (\<Sum>\<alpha> \<in> A. \
 \<alpha> * (\<Sum>\<phi> \<leftarrow> \<Phi>. ?to_\<delta> \<alpha> \<phi>))"
        proof (induct \<Phi>)
          case Nil
          then show ?case by simp
        next
          case (Cons \<phi>' \<Phi>)
          with \<open>finite A\<close> show ?case
          proof (induct A rule: finite_induct)
            case empty
            then show ?case by simp
          next
            case (insert a A)
            have
              "(\<Sum>\<phi>\<leftarrow>\<phi>' # \<Phi>. \<Sum>\<alpha>\<in>insert a A. \
 \<alpha> * ?to_\<delta> \<alpha> \<phi>)
               = (\<Sum>\<alpha>\<in>insert a A. \
 \<alpha> * ?to_\<delta> \<alpha> \<phi>')
                 + (\<Sum>\<phi>\<leftarrow>\<Phi>. \<Sum>\<alpha>\<in>insert a A. \
 \<alpha> * ?to_\<delta> \<alpha> \<phi>)"
              by simp
            also have
              "\<dots> = (\<Sum>\<alpha>\<in>insert a A. \
 \<alpha> * ?to_\<delta> \<alpha> \<phi>')
                    + (\<Sum>\<alpha>\<in>insert a A. \
 \<alpha> * (\<Sum>\<phi>\<leftarrow>\<Phi>. ?to_\<delta> \<alpha> \<phi>))"
              using insert.prems by linarith
            also have
              "\<dots> = (\<Sum>\<alpha>\<in>insert a A. (\
 \<alpha> * ?to_\<delta> \<alpha> \<phi>')
                    + \
 \<alpha> * (\<Sum>\<phi>\<leftarrow>\<Phi>. ?to_\<delta> \<alpha> \<phi>))"
              by (simp add: sum.distrib)
            also have
              "\<dots> = (\<Sum>\<alpha>\<in>insert a A. \
 \<alpha> * (\<Sum>\<phi>\<leftarrow>\<phi>' # \<Phi>. ?to_\<delta> \<alpha> \<phi>))"
              by (simp add: distrib_left)
            finally show ?case by simp
          qed
        qed
      }
      note \<dagger> = this
      have "(\<Sum>\<phi>\<leftarrow>\<Phi>. \
 \<phi>) = (\<Sum>\<phi>\<leftarrow>\<Phi>. (\<Sum>\<alpha> \<in> \<J>. \
 \<alpha> * ?to_\<delta> \<alpha> \<phi>))"
        by (induct \<Phi>,
            auto,
            metis join_prime_decomposition [OF \<open>\
 \<in> probabilities\<close>])
      hence "(\<Sum>\<phi>\<leftarrow>\<Phi>. \
 \<phi>) = (\<Sum> \<alpha> \<in> \<J>. \
 \<alpha> * (\<Sum>\<phi> \<leftarrow> \<Phi>. ?to_\<delta> \<alpha> \<phi>))"
        unfolding \<dagger> [OF \<open>finite \<J>\<close>] by auto
    }
    hence X: "(\<Sum>\<phi>\<leftarrow>\<Phi>. \
 \<phi>) = (\<Sum>\<alpha> \<in> \<J>. \
 \<alpha> * (\<Sum>\<phi> \<leftarrow> \<Phi>. ?to_\<delta> \<alpha> \<phi>))"
      and Y: "(\<Sum>\<gamma>\<leftarrow>\<Gamma>. \
 \<gamma>) = (\<Sum>\<alpha> \<in> \<J>. \
 \<alpha> * (\<Sum>\<gamma> \<leftarrow> \<Gamma>. ?to_\<delta> \<alpha> \<gamma>))"
      by auto
    {
      fix A :: "'a set"
      assume "A \<subseteq> \<J>"
      hence "finite A"
        by simp
      hence "(\<Sum>\<alpha> \<in> A. \
 \<alpha> * ((\<Sum>\<phi> \<leftarrow> \<Phi>. ?to_\<delta> \<alpha> \<phi>) + \<lceil>c\<rceil>))
            \<le> (\<Sum>\<alpha> \<in> A. \
 \<alpha> * (\<Sum>\<gamma> \<leftarrow> \<Gamma>. ?to_\<delta> \<alpha> \<gamma>))"
        using \<open>A \<subseteq> \<J>\<close>
      proof (induct A rule: finite_induct)
        case empty
        then show ?case by auto
      next
        case (insert \<alpha>' A)
        hence "\<alpha>' \<in> \<J>"
          by blast
        hence "?to_\<delta> \<alpha>' \<in> dirac_measures"
          using dirac_join_prime_bij_betw
          unfolding bij_betw_def
          by blast
        hence "(\<Sum>\<phi>\<leftarrow>\<Phi>. ?to_\<delta> \<alpha>' \<phi>) + \<lceil>c\<rceil> \<le> (\<Sum>\<gamma>\<leftarrow>\<Gamma>. ?to_\<delta> \<alpha>' \<gamma>)"
          using \<star> by blast
        moreover have "0 \<le> \
 \<alpha>'"
          by (simp add: probability_non_negative)
        ultimately have
          "\
 \<alpha>' * ((\<Sum>\<phi>\<leftarrow>\<Phi>. ?to_\<delta> \<alpha>' \<phi>) + \<lceil>c\<rceil>) \<le> \
 \<alpha>' * (\<Sum>\<gamma>\<leftarrow>\<Gamma>. ?to_\<delta> \<alpha>' \<gamma>)"
          using mult_left_mono by blast
        moreover have
          "(\<Sum>\<alpha> \<in> A. \
 \<alpha> * ((\<Sum>\<phi> \<leftarrow> \<Phi>. ?to_\<delta> \<alpha> \<phi>) + \<lceil>c\<rceil>))
            \<le> (\<Sum>\<alpha> \<in> A. \
 \<alpha> * (\<Sum>\<gamma> \<leftarrow> \<Gamma>. ?to_\<delta> \<alpha> \<gamma>))"
          using insert.hyps insert.prems by blast
        ultimately show ?case
          using insert.hyps(2) by auto
      qed
    }
    hence A:
      "(\<Sum>\<alpha> \<in> \<J>. \
 \<alpha> * ((\<Sum>\<phi> \<leftarrow> \<Phi>. ?to_\<delta> \<alpha> \<phi>) + \<lceil>c\<rceil>))
            \<le> (\<Sum>\<alpha> \<in> \<J>. \
 \<alpha> * (\<Sum>\<gamma> \<leftarrow> \<Gamma>. ?to_\<delta> \<alpha> \<gamma>))"
      by blast
    {
      fix A :: "'a set"
      assume "finite A"
      hence
        "(\<Sum>\<alpha> \<in> A. \
 \<alpha> * ((\<Sum>\<phi> \<leftarrow> \<Phi>. ?to_\<delta> \<alpha> \<phi>) + \<lceil>c\<rceil>))
         = (\<Sum>\<alpha> \<in> A. \
 \<alpha> * (\<Sum>\<phi> \<leftarrow> \<Phi>. ?to_\<delta> \<alpha> \<phi>)) + \<lceil>c\<rceil> * (\<Sum>\<alpha> \<in> A. \
 \<alpha>)"
        by (induct A rule: finite_induct, simp, simp add: distrib_left)
    }
    with A \<open>finite \<J>\<close> have B:
     "(\<Sum>\<alpha> \<in> \<J>. \
 \<alpha> * (\<Sum>\<phi> \<leftarrow> \<Phi>. ?to_\<delta> \<alpha> \<phi>)) + \<lceil>c\<rceil> * (\<Sum>\<alpha> \<in> \<J>. \
 \<alpha>)
         \<le> (\<Sum>\<alpha> \<in> \<J>. \
 \<alpha> * (\<Sum>\<gamma> \<leftarrow> \<Gamma>. ?to_\<delta> \<alpha> \<gamma>))"
      by auto
    have "(\<Sum>\<alpha>\<in>\<J>. \
 \<alpha>) = 1"
      using
        join_prime_decomposition [OF \<open>\
 \<in> probabilities\<close>, where \<phi>="\<top>"]
        top_greatest
      unfolding probability_unity
      by auto
    hence "(\<Sum>\<alpha> \<in> \<J>. \
 \<alpha> * (\<Sum>\<phi> \<leftarrow> \<Phi>. ?to_\<delta> \<alpha> \<phi>)) + \<lceil>c\<rceil>
              \<le> (\<Sum>\<alpha> \<in> \<J>. \
 \<alpha> * (\<Sum>\<gamma> \<leftarrow> \<Gamma>. ?to_\<delta> \<alpha> \<gamma>))"
      using B by auto
    hence "(\<Sum>\<phi> \<leftarrow> \<Phi>. \
 \<phi>) + c \<le> (\<Sum>\<gamma> \<leftarrow> \<Gamma>. \
 \<gamma>)"
      using X Y
      by linarith
  }
  thus "\<forall> \
 \<in> probabilities. (\<Sum>\<phi>\<leftarrow>\<Phi>. \
 \<phi>) + c \<le> (\<Sum>\<gamma>\<leftarrow>\<Gamma>. \
 \<gamma>)" by auto
qed

end

end