(*  Author:      Christian Sternagel <c.sternagel@gmail.com>
    Maintainer:  Christian Sternagel <c.sternagel@gmail.com>
*)
theory Efficient_Sort
  imports "HOL-Library.Multiset"
begin

section \<open>GHC Version of Mergesort\<close>

text \<open>
  In the following we show that the mergesort implementation
  used in GHC (see \<^url>\<open>http://hackage.haskell.org/package/base-4.11.1.0/docs/src/Data.OldList.html#sort\<close>)
  is a correct and stable sorting algorithm. Furthermore, experimental
  data suggests that generated code for this implementation is much more
  efficient than for the implementation provided by \<^theory>\<open>HOL-Library.Multiset\<close>.

  A high-level overview of an older version of this formalization as well as some experimental data
  is to be found in @{cite "Sternagel2012"}.
\<close>
subsection \<open>Definition of Natural Mergesort\<close>

context
  fixes key :: "'a \<Rightarrow> 'k::linorder"
begin

text \<open>
  Split a list into chunks of ascending and descending parts, where
  descending parts are reversed on the fly.
  Thus, the result is a list of sorted lists.
\<close>
fun sequences :: "'a list \<Rightarrow> 'a list list"
  and asc :: "'a \<Rightarrow> ('a list \<Rightarrow> 'a list) \<Rightarrow> 'a list \<Rightarrow> 'a list list"
  and desc :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list list"
  where
    "sequences (a # b # xs) =
      (if key a > key b then desc b [a] xs else asc b ((#) a) xs)"
  | "sequences [x] = [[x]]"
  | "sequences [] = []"
  | "asc a as (b # bs) =
      (if key a \<le> key b then asc b (\<lambda>ys. as (a # ys)) bs
      else as [a] # sequences (b # bs))"
  | "asc a as [] = [as [a]]"
  | "desc a as (b # bs) =
      (if key a > key b then desc b (a # as) bs
      else (a # as) # sequences (b # bs))"
  | "desc a as [] = [a # as]"

fun merge :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where
    "merge (a # as) (b # bs) =
      (if key a > key b then b # merge (a # as) bs else a # merge as (b # bs))"
  | "merge [] bs = bs"
  | "merge as [] = as"

fun merge_pairs :: "'a list list \<Rightarrow> 'a list list"
  where
    "merge_pairs (a # b # xs) = merge a b # merge_pairs xs"
  | "merge_pairs xs = xs"

lemma length_merge [simp]:
  "length (merge xs ys) = length xs + length ys"
  by (induct xs ys rule: merge.induct) simp_all

lemma length_merge_pairs [simp]:
  "length (merge_pairs xs) = (1 + length xs) div 2"
  by (induct xs rule: merge_pairs.induct) simp_all

fun merge_all :: "'a list list \<Rightarrow> 'a list"
  where
    "merge_all [] = []"
  | "merge_all [x] = x"
  | "merge_all xs = merge_all (merge_pairs xs)"

fun msort_key :: "'a list \<Rightarrow> 'a list"
  where
    "msort_key xs = merge_all (sequences xs)"

subsection \<open>The Functional Argument of @{const asc}\<close>

text \<open>\<open>f\<close> is a function that only adds some prefix to a given list.\<close>
definition "ascP f = (\<forall>xs. f xs = f [] @ xs)"

lemma ascP_Cons [simp]: "ascP ((#) x)" by (simp add: ascP_def)

lemma ascP_comp_append_Cons [simp]:
  "ascP (\<lambda>xs. f [] @ x # xs)"
  by (auto simp: ascP_def)

lemma ascP_f_Cons:
  assumes "ascP f"
  shows "f (x # xs) = f [] @ x # xs"
  using \<open>ascP f\<close> [unfolded ascP_def, THEN spec, of "x # xs"] .

lemma ascP_comp_Cons [simp]:
  assumes "ascP f"
  shows "ascP (\<lambda>ys. f (x # ys))"
proof (unfold ascP_def, intro allI)
  fix xs show "f (x # xs) = f [x] @ xs"
    using assms by (simp add: ascP_f_Cons)
qed

lemma ascP_f_singleton:
  assumes "ascP f"
  shows "f [x] = f [] @ [x]"
  by (rule ascP_f_Cons [OF assms])

subsection \<open>Facts about Lengths\<close>

lemma
  shows length_sequences: "length (sequences xs) \<le> length xs"
    and length_asc: "ascP f \<Longrightarrow> length (asc a f ys) \<le> 1 + length ys"
    and length_desc: "length (desc a xs ys) \<le> 1 + length ys"
  by (induct xs and a f ys and a xs ys rule: sequences_asc_desc.induct) auto

lemma length_concat_merge_pairs [simp]:
  "length (concat (merge_pairs xss)) = length (concat xss)"
  by (induct xss rule: merge_pairs.induct) simp_all

subsection \<open>Functional Correctness\<close>

lemma mset_merge [simp]:
  "mset (merge xs ys) = mset xs + mset ys"
  by (induct xs ys rule: merge.induct) simp_all

lemma set_merge [simp]:
  "set (merge xs ys) = set xs \<union> set ys"
  by (simp flip: set_mset_mset)

lemma mset_concat_merge_pairs [simp]:
  "mset (concat (merge_pairs xs)) = mset (concat xs)"
  by (induct xs rule: merge_pairs.induct) auto

lemma set_concat_merge_pairs [simp]:
  "set (concat (merge_pairs xs)) = set (concat xs)"
  by (simp flip: set_mset_mset)

lemma mset_merge_all [simp]:
  "mset (merge_all xs) = mset (concat xs)"
  by (induct xs rule: merge_all.induct) simp_all

lemma set_merge_all [simp]:
  "set (merge_all xs) = set (concat xs)"
  by (simp flip: set_mset_mset)

lemma
  shows mset_seqeuences [simp]: "mset (concat (sequences xs)) = mset xs"
    and mset_asc: "ascP f \<Longrightarrow> mset (concat (asc x f ys)) = {#x#} + mset (f []) + mset ys"
    and mset_desc: "mset (concat (desc x xs ys)) = {#x#} + mset xs + mset ys"
  by (induct xs and x f ys and x xs ys rule: sequences_asc_desc.induct)
    (auto simp: ascP_f_singleton)

lemma mset_msort_key:
  "mset (msort_key xs) = mset xs"
  by (auto)

lemma sorted_merge [simp]:
  assumes "sorted (map key xs)" and "sorted (map key ys)"
  shows "sorted (map key (merge xs ys))"
  using assms by (induct xs ys rule: merge.induct) (auto)

lemma sorted_merge_pairs [simp]:
  assumes "\<forall>x\<in>set xs. sorted (map key x)"
  shows "\<forall>x\<in>set (merge_pairs xs). sorted (map key x)"
  using assms by (induct xs rule: merge_pairs.induct) simp_all

lemma sorted_merge_all:
  assumes "\<forall>x\<in>set xs. sorted (map key x)"
  shows "sorted (map key (merge_all xs))"
  using assms by (induct xs rule: merge_all.induct) simp_all

lemma
  shows sorted_sequences: "\<forall>x \<in> set (sequences xs). sorted (map key x)"
    and sorted_asc: "ascP f \<Longrightarrow> sorted (map key (f [])) \<Longrightarrow> \<forall>x\<in>set (f []). key x \<le> key a \<Longrightarrow> \<forall>x\<in>set (asc a f ys). sorted (map key x)"
    and sorted_desc: "sorted (map key xs) \<Longrightarrow> \<forall>x\<in>set xs. key a \<le> key x \<Longrightarrow> \<forall>x\<in>set (desc a xs ys). sorted (map key x)"
  by (induct xs and a f ys and a xs ys rule: sequences_asc_desc.induct)
    (auto simp: ascP_f_singleton sorted_append not_less dest: order_trans, fastforce)

lemma sorted_msort_key:
  "sorted (map key (msort_key xs))"
  by (unfold msort_key.simps) (intro sorted_merge_all sorted_sequences)

subsection \<open>Stability\<close>

lemma
  shows filter_by_key_sequences [simp]: "[y\<leftarrow>concat (sequences xs). key y = k] = [y\<leftarrow>xs. key y = k]"
    and filter_by_key_asc: "ascP f \<Longrightarrow> [y\<leftarrow>concat (asc a f ys). key y = k] = [y\<leftarrow>f [a] @ ys. key y = k]"
    and filter_by_key_desc: "sorted (map key xs) \<Longrightarrow> \<forall>x\<in>set xs. key a \<le> key x \<Longrightarrow> [y\<leftarrow>concat (desc a xs ys). key y = k] = [y\<leftarrow>a # xs @ ys. key y = k]"
proof (induct xs and a f ys and a xs ys rule: sequences_asc_desc.induct)
  case (4 a f b bs)
  then show ?case
    by (auto simp: o_def ascP_f_Cons [where f = f])
next
  case (6 a as b bs)
  then show ?case
  proof (cases "key b < key a")
    case True
    with 6 have "[y\<leftarrow>concat (desc b (a # as) bs). key y = k] = [y\<leftarrow>b # (a # as) @ bs. key y = k]"
      by (auto simp: less_le order_trans)
    then show ?thesis
      using True and 6
      by (cases "key a = k", cases "key b = k")
        (auto simp: Cons_eq_append_conv intro!: filter_False)
  qed auto
qed auto

lemma filter_by_key_merge_is_append [simp]:
  assumes "sorted (map key xs)"
  shows "[y\<leftarrow>merge xs ys. key y = k] = [y\<leftarrow>xs. key y = k] @ [y\<leftarrow>ys. key y = k]"
  using assms
  by (induct xs ys rule: merge.induct) (auto simp: Cons_eq_append_conv leD intro!: filter_False)

lemma filter_by_key_merge_pairs [simp]:
  assumes "\<forall>xs\<in>set xss. sorted (map key xs)"
  shows "[y\<leftarrow>concat (merge_pairs xss). key y = k] = [y\<leftarrow>concat xss. key y = k]"
  using assms by (induct xss rule: merge_pairs.induct) simp_all

lemma filter_by_key_merge_all [simp]:
  assumes "\<forall>xs\<in>set xss. sorted (map key xs)"
  shows "[y\<leftarrow>merge_all xss. key y = k] = [y\<leftarrow>concat xss. key y = k]"
  using assms by (induct xss rule: merge_all.induct) simp_all

lemma filter_by_key_merge_all_sequences [simp]:
  "[x\<leftarrow>merge_all (sequences xs) . key x = k] = [x\<leftarrow>xs . key x = k]"
  using sorted_sequences [of xs] by simp

lemma msort_key_stable:
  "[x\<leftarrow>msort_key xs. key x = k] = [x\<leftarrow>xs. key x = k]"
  by auto

lemma sort_key_msort_key_conv:
  "sort_key key = msort_key"
  using msort_key_stable [of "key x" for x]
  by (intro ext properties_for_sort_key mset_msort_key sorted_msort_key)
    (metis (mono_tags, lifting) filter_cong)

end

text \<open>
  Replace existing code equations for \<^const>\<open>sort_key\<close> by \<^const>\<open>msort_key\<close>.
\<close>
declare sort_key_by_quicksort_code [code del]
declare sort_key_msort_key_conv [code]

end


theory AExp
  imports Main
begin
type_synonym vname = string

datatype aexp
  = N int
  | V vname
  | Plus aexp aexp

(* semantics *)
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val"
  where "aval (N n) s = n"
  | "aval (V x) s = s x"
  | "aval (Plus a1 a2) s = aval a1 s + aval a2 s"

value "aval (Plus (N 3) (V ''x'')) (\<lambda>x.0)"

text {* A little syntax magic to write larger states compactly: *}

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds \<Rightarrow> 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

(* We can now write a series of updates to the function \<lambda>x.0 compactly: *)
lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2 :: int))"
  by (rule refl)

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"

text {* In  the @{term[source] "<a := b>"} syntax, variables that are not mentioned are 0 by default:
*}
value "aval (Plus (V ''x'') (N 5)) <''y'' := 7>"

(* Constant folding: Replacing of constant sub expression for his value *)

(*constant folding in a bottom-up manner *)
fun asimp_const :: "aexp \<Rightarrow> aexp"
  where "asimp_const (N n) = N n"
  | "asimp_const (V x) = V x"
  | "asimp_const (Plus a1 a2) =
    (case (asimp_const a1, asimp_const a2)
      of (N n1, N n2) \<Rightarrow> N (n1 + n2)
      |  (b1,b2)      \<Rightarrow> Plus b1 b2)"

(* Correctness for asimp_const means that it doesn't change the semantics *)
lemma "aval (asimp_const a) s = aval a s"
  apply(induction a)
  apply(auto split: aexp.split)
  done

(* An optimizing version of Plus *)
fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp"
  where "plus (N i1) (N i2) = N (i1 + i2)"
  |     "plus (N i) a = (if i = 0 then a else Plus (N i) a)"
  |     "plus a (N i) = (if i = 0 then a else Plus a (N i))"
  |     "plus a1 a2 = Plus a1 a2"

(*Proof that it behaves like Plus under evaluation*)
lemma aval_plus: "aval (plus a1 a2) s = aval a1 s + aval a2 s"
  apply(induction rule:plus.induct)
  apply(auto)
  done

fun asimp :: "aexp \<Rightarrow> aexp"
  where "asimp (N n) = N n"
    |   "asimp (V x) = V x"
    |   "asimp (Plus a1 a2) = plus (asimp a1) (asimp a2)"

lemma aval_simp [simp]: "aval (asimp a) s = aval a s"
  apply(induction a)
  apply(auto split: aexp.split simp: aval_plus)
  done

text{* Exercises *}
text{*
Exercise 3.1. To show that asimp_const really folds all subexpressions of
              the form Plus (N i) (N j), define a function optimal :: aexp => bool
              that checks that its argument does not contain a subexpression of the
              form Plus (N i) (N j). Then prove optimal (asimp_const a).
*}
fun optimal :: "aexp \<Rightarrow> bool"
  where "optimal (N n) = True"
    | "optimal (V x) = True"
    | "optimal (Plus (N _) (N _)) = False"
    | "optimal (Plus va vb) = (case optimal va
        of True  \<Rightarrow> optimal vb
        |  False \<Rightarrow> False)"

lemma "optimal (asimp_const a)"
  apply(induction a)
  apply(auto split: aexp.split)
  done

text{*
Exercise 3.2. In this exercise we verify constant folding for aexp where we
              sum up all constants, even if they are not next to each other.
              For example Plus (N 1) (Plus (V x) (N 2)) becomes Plus (V x) (N 3).
              This goes beyond asimp. Define a function full_asimp :: aexp => aexp
              that sums up all constants and prove its correctness:
              aval (full_asimp a) s = aval a s.
*}
fun full_asimp :: "aexp \<Rightarrow> aexp"
  where "full_asimp (N n) = N n"
  | "full_asimp (V x) = V x"
  | "full_asimp (Plus (N n1) (N n2)) = N (n1+n2)"
  | "full_asimp (Plus va vb) = Plus (full_asimp va) (full_asimp vb)"

lemma full_asimp_correctness: "aval (full_asimp a) s = aval a s"
  apply(induction rule: full_asimp.induct)
  apply(auto)
  done

text{*
Exercise 3.3. Substitution is the process of replacing a variable by an expression
              in an expression. Define a substitution function
              subst :: vname => aexp => aexp such that subst x a e is the result
              of replacing every occurrence of variable x by a in e. For example:
              subst ''x'' (N 3) (Plus (V ''x'') (V ''y'')) = Plus (N 3) (V ''y'')
              Prove the so-called substitution lemma that says that we can either
              substitute first and evaluate afterwards or evaluate with an updated
              state: aval (subst x a e) s = aval e (s (x := aval a s)).
              As a consequence prove:
              aval a1 s = aval a2 s => aval (subst x a1 e) s = aval (subst x a2 e) s
*}

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp"
  where "subst x e (N n) = N n "
  | "subst x e (V y) = (if x=y then e else V y)"
  | "subst x e (Plus e1 e2) = Plus (subst x e e1) (subst x e e2)"

lemma substitution_lemma:
  "aval (subst x a expr) state = aval expr (state (x := aval a state))"
  apply(induction expr)
  apply(auto)
  done

text{*
Exercise 3.4. Take a copy of theory AExp and modify it as follows. Extend type aexp
              with a binary constructor Times that represents multiplication.
              Modify the definition of the functions aval and asimp accordingly.
              You can remove asimp_const. Function asimp should eliminate 0 and 1
              from multiplication as well as evaluate constant subterms. Update
              all proofs concerned.
*}

text{*
Exercise 3.5. Define a datatype aexp2 of extended arithmetic expressions that has,
              in addition to constructors of aexp, a constructor for modelling
              a C-like post-increment operation x++, where x must be a variable.
              Define an evaluation function aval2 :: aval2 => state => val * state
              that returns both the value of the expression and the new state.
              The latter is required because post-increment changes the state.
              Extend aexp2 and aval2 with a division operation. Model partiality
              of division by changing the return type of aval2 to (val * state)
              option. In case of division by 0 let aval2 return None. Division
              on int is the infix div.
*}
datatype aexp\<^sub>2
  = N\<^sub>2 int
  | V\<^sub>2 vname
  | Plus\<^sub>2 aexp\<^sub>2 aexp\<^sub>2
  | PostInc vname
  | Div aexp\<^sub>2 aexp\<^sub>2

fun aval\<^sub>2 :: "aexp\<^sub>2 \<Rightarrow> state \<Rightarrow> (val * state) option"
  where "aval\<^sub>2 (N\<^sub>2 n) s = Some (n, s)"
  | "aval\<^sub>2 (V\<^sub>2 x) s = Some (s x, s)"
  | "aval\<^sub>2 (Plus\<^sub>2 e\<^sub>1 e\<^sub>2) s = (case (aval\<^sub>2 e\<^sub>1 s)
      of None \<Rightarrow> None
      | Some (n\<^sub>1, s\<^sub>1) \<Rightarrow> (case aval\<^sub>2 e\<^sub>2 s\<^sub>1
                           of None \<Rightarrow> None
                           | Some (n\<^sub>2, s\<^sub>2) \<Rightarrow> Some (n\<^sub>1 + n\<^sub>2, s\<^sub>2)))"
  | "aval\<^sub>2 (PostInc x) s = (let n = s x + 1 in Some (n, <''x'' := n >))"
  | "aval\<^sub>2 (Div e\<^sub>1 e\<^sub>2) s
      = (case aval\<^sub>2 e\<^sub>1 s
          of None \<Rightarrow> None
          |  Some (n\<^sub>1, s\<^sub>1) \<Rightarrow> (case aval\<^sub>2 e\<^sub>2 s\<^sub>1
                               of None \<Rightarrow> None
                               |  Some (n\<^sub>2, s\<^sub>2) \<Rightarrow> if n\<^sub>2 = 0
                                                  then None
                                                  else Some (n\<^sub>1 div n\<^sub>2, s\<^sub>2)))"

text{*
Exercise 3.6. The following type add a LET construct to arithmetic expressions:
              datatype lexp = Nl int
                            | Vl vname
                            | Plusl lexp lexp
                            | LET vname lexp lexp
              The LET constructor introduces a local variable: the value of
              LET x e1 e2 is the value of e2 in the state where x is bound to
              the value of e1 in the original state. Define a function
              lval :: lexp => state => int that evaluates lexp expressions.
              Remember s(x := i).
              Define a conversion inline :: lexp => aexp. The expression LET x e1 e2
              is inlined by substituting the converted form of e1 for x in the
              converted form of e2. See exercise 3.3 for more on substitution.
              Prove that inline is correct w.r.t evaluation.
*}
datatype lexp
  = Nl int
  | Vl vname
  | Plusl lexp lexp
  | LET vname lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int"
  where "lval (Nl n) s = n"
  | "lval (Vl x) s = s x"
  | "lval (Plusl le1 le2) s = lval le1 s + lval le2 s"
  | "lval (LET x le1 le2) s = lval le2 (s(x := lval le1 s))"

fun inline :: "lexp \<Rightarrow> aexp"
  where "inline (Nl n) = N n"
  | "inline (Vl x) = V x"
  | "inline (Plusl le1 le2) = Plus (inline le1) (inline le2)"
  | "inline (LET x le1 le2) = subst x (inline le1) (inline le2)"

lemma "lval lexpr state = aval (inline lexpr) state"
  apply(induction lexpr arbitrary: state)
  apply(auto simp: substitution_lemma)
  done

end


chapter\<open>Preliminaries\<close>
text\<open>In this chapter, we introduce the preliminaries, including a three-valued logic, variables,
arithmetic expressions and guard expressions.\<close>

section\<open>Three-Valued Logic\<close>

text\<open>Because our EFSMs are dynamically typed, we cannot rely on conventional Boolean logic when
evaluating expressions. For example, we may end up in the situation where we need to evaluate
the guard $r_1 > 5$. This is fine if $r_1$ holds a numeric value, but if $r_1$ evaluates to a
string, this causes problems. We cannot simply evaluate to \emph{false} because then the negation
would evaluate to \emph{true.} Instead, we need a three-valued logic such that we can meaningfully
evaluate nonsensical guards.

The \texttt{trilean} datatype is used to implement three-valued Bochvar logic
\<^cite>\<open>"bochvar1981"\<close>. Here we prove that the logic is an idempotent semiring, define a partial order,
and prove some other useful lemmas.\<close>

theory Trilean
imports Main
begin

datatype trilean = true | false | invalid

instantiation trilean :: semiring begin
fun times_trilean :: "trilean \<Rightarrow> trilean \<Rightarrow> trilean" where
  "times_trilean _ invalid = invalid" |
  "times_trilean invalid _ = invalid" |
  "times_trilean true true = true" |
  "times_trilean _ false = false" |
  "times_trilean false _ = false"

fun plus_trilean :: "trilean \<Rightarrow> trilean \<Rightarrow> trilean" where
  "plus_trilean invalid _ = invalid" |
  "plus_trilean _ invalid = invalid" |
  "plus_trilean true _ = true" |
  "plus_trilean _ true = true" |
  "plus_trilean false false = false"

abbreviation maybe_and :: "trilean \<Rightarrow> trilean \<Rightarrow> trilean" (infixl "\<and>?" 70) where
  "maybe_and x y \<equiv> x * y"

abbreviation maybe_or :: "trilean \<Rightarrow> trilean \<Rightarrow> trilean" (infixl "\<or>?" 65) where
  "maybe_or x y \<equiv> x + y"

lemma plus_trilean_assoc:
  "a \<or>? b \<or>? c = a \<or>? (b \<or>? c)"
proof(induct a b  arbitrary: c rule: plus_trilean.induct)
case (1 uu)
  then show ?case
    by simp
next
  case "2_1"
  then show ?case
    by simp
next
  case "2_2"
  then show ?case
    by simp
next
  case "3_1"
  then show ?case
    by (metis plus_trilean.simps(2) plus_trilean.simps(4) trilean.exhaust)
next
  case "3_2"
  then show ?case
    by (metis plus_trilean.simps(3) plus_trilean.simps(5) plus_trilean.simps(6) plus_trilean.simps(7) trilean.exhaust)
next
  case 4
  then show ?case
    by (metis plus_trilean.simps(2) plus_trilean.simps(3) plus_trilean.simps(4) plus_trilean.simps(5) plus_trilean.simps(6) trilean.exhaust)
next
  case 5
  then show ?case
    by (metis plus_trilean.simps(6) plus_trilean.simps(7) trilean.exhaust)
qed

lemma plus_trilean_commutative: "a \<or>? b = b \<or>? a"
proof(induct a b rule: plus_trilean.induct)
  case (1 uu)
  then show ?case
    by (metis plus_trilean.simps(1) plus_trilean.simps(2) plus_trilean.simps(3) trilean.exhaust)
qed auto

lemma times_trilean_commutative: "a \<and>? b = b \<and>? a"
  by (metis (mono_tags) times_trilean.simps trilean.distinct(5) trilean.exhaust)

lemma times_trilean_assoc:
  "a \<and>? b \<and>? c = a \<and>? (b \<and>? c)"
proof(induct a b  arbitrary: c rule: plus_trilean.induct)
  case (1 uu)
  then show ?case
    by (metis (mono_tags, lifting) times_trilean.simps(1) times_trilean_commutative)
next
case "2_1"
  then show ?case
    by (metis (mono_tags, lifting) times_trilean.simps(1) times_trilean_commutative)
next
  case "2_2"
  then show ?case
    by (metis (mono_tags, lifting) times_trilean.simps(1) times_trilean_commutative)
next
  case "3_1"
  then show ?case
    by (metis times_trilean.simps(1) times_trilean.simps(4) times_trilean.simps(5) trilean.exhaust)
next
  case "3_2"
  then show ?case
    by (metis times_trilean.simps(1) times_trilean.simps(5) times_trilean.simps(6) times_trilean.simps(7) trilean.exhaust)
next
  case 4
  then show ?case
    by (metis times_trilean.simps(1) times_trilean.simps(4) times_trilean.simps(5) times_trilean.simps(7) trilean.exhaust)
next
case 5
  then show ?case
    by (metis (full_types) times_trilean.simps(1) times_trilean.simps(6) times_trilean.simps(7) trilean.exhaust)
qed

lemma trilean_distributivity_1:
  "(a \<or>? b) \<and>? c = a \<and>? c \<or>? b \<and>? c"
proof(induct a b rule: times_trilean.induct)
case (1 uu)
  then show ?case
    by (metis (mono_tags, lifting) plus_trilean.simps(1) plus_trilean_commutative times_trilean.simps(1) times_trilean_commutative)
next
  case "2_1"
  then show ?case
    by (metis (mono_tags, lifting) plus_trilean.simps(1) times_trilean.simps(1) times_trilean_commutative)
next
  case "2_2"
  then show ?case
    by (metis (mono_tags, lifting) plus_trilean.simps(1) times_trilean.simps(1) times_trilean_commutative)
next
  case 3
  then show ?case
    apply simp
    by (metis (no_types, opaque_lifting) plus_trilean.simps(1) plus_trilean.simps(4) plus_trilean.simps(7) times_trilean.simps(1) times_trilean.simps(4) times_trilean.simps(5) trilean.exhaust)
next
  case "4_1"
  then show ?case
    apply simp
    by (metis (no_types, opaque_lifting) plus_trilean.simps(1) plus_trilean.simps(5) plus_trilean.simps(7) times_trilean.simps(1) times_trilean.simps(4) times_trilean.simps(5) times_trilean.simps(6) times_trilean.simps(7) trilean.exhaust)
next
  case "4_2"
  then show ?case
    apply simp
    by (metis (no_types, opaque_lifting) plus_trilean.simps(1) plus_trilean.simps(7) times_trilean.simps(1) times_trilean.simps(6) times_trilean.simps(7) trilean.exhaust)
next
  case 5
  then show ?case
    apply simp
    by (metis (no_types, opaque_lifting) plus_trilean.simps(1) plus_trilean.simps(6) plus_trilean.simps(7) times_trilean.simps(1) times_trilean.simps(4) times_trilean.simps(5) times_trilean.simps(6) times_trilean.simps(7) trilean.exhaust)
qed

instance
  apply standard
      apply (simp add: plus_trilean_assoc)
     apply (simp add: plus_trilean_commutative)
    apply (simp add: times_trilean_assoc)
   apply (simp add: trilean_distributivity_1)
  using times_trilean_commutative trilean_distributivity_1 by auto
end

lemma maybe_or_idempotent: "a \<or>? a = a"
  by (cases a) auto

lemma maybe_and_idempotent: "a \<and>? a = a"
  by (cases a) auto

instantiation trilean :: ord begin
definition less_eq_trilean :: "trilean \<Rightarrow> trilean \<Rightarrow> bool" where
  "less_eq_trilean a b = (a + b = b)"

definition less_trilean :: "trilean \<Rightarrow> trilean \<Rightarrow> bool" where
  "less_trilean a b = (a \<le> b \<and> a \<noteq> b)"

declare less_trilean_def less_eq_trilean_def [simp]

instance
  by standard
end

instantiation trilean :: uminus begin
  fun maybe_not :: "trilean \<Rightarrow> trilean" ("\<not>? _" [60] 60) where
    "\<not>? true = false" |
    "\<not>? false = true" |
    "\<not>? invalid = invalid"

instance
  by standard
end

lemma maybe_and_one: "true \<and>? x = x"
  by (cases x, auto)

lemma maybe_or_zero: "false \<or>? x = x"
  by (cases x, auto)

lemma maybe_double_negation: "\<not>? \<not>? x = x"
  by (cases x, auto)

lemma maybe_negate_true: "(\<not>? x = true) = (x = false)"
  by (cases x, auto)

lemma maybe_negate_false: "(\<not>? x = false) = (x = true)"
  by (cases x, auto)

lemma maybe_and_true: "(x \<and>? y = true) = (x = true \<and> y = true)"
  using times_trilean.elims by blast

lemma maybe_and_not_true:
  "(x \<and>? y \<noteq> true) = (x \<noteq> true \<or> y \<noteq> true)"
  by (simp add: maybe_and_true)

lemma negate_valid: "(\<not>? x \<noteq> invalid) = (x \<noteq> invalid)"
  by (metis maybe_double_negation maybe_not.simps(3))

lemma maybe_and_valid:
  "x \<and>? y \<noteq> invalid \<Longrightarrow> x \<noteq> invalid \<and> y \<noteq> invalid"
  using times_trilean.elims by blast

lemma maybe_or_valid:
  "x \<or>? y \<noteq> invalid \<Longrightarrow> x \<noteq> invalid \<and> y \<noteq> invalid"
  using plus_trilean.elims by blast

lemma maybe_or_false:
  "(x \<or>? y = false) = (x = false \<and> y = false)"
  using plus_trilean.elims by blast

lemma maybe_or_true:
  "(x \<or>? y = true) = ((x = true \<or> y = true) \<and> x \<noteq> invalid \<and> y \<noteq> invalid)"
  using plus_trilean.elims by blast

lemma maybe_not_invalid: "(\<not>? x = invalid) = (x = invalid)"
  by (metis maybe_double_negation maybe_not.simps(3))

lemma maybe_or_invalid:
  "(x \<or>? y = invalid) = (x = invalid \<or> y = invalid)"
  using plus_trilean.elims by blast

lemma maybe_and_invalid:
  "(x \<and>? y = invalid) = (x = invalid \<or> y = invalid)"
  using times_trilean.elims by blast

lemma maybe_and_false:
  "(x \<and>? y = false) = ((x = false \<or> y = false) \<and> x \<noteq> invalid \<and> y \<noteq> invalid)"
  using times_trilean.elims by blast

lemma invalid_maybe_and: "invalid \<and>? x = invalid"
  using maybe_and_valid by blast

lemma maybe_not_eq: "(\<not>? x = \<not>? y) = (x = y)"
  by (metis maybe_double_negation)

lemma de_morgans_1:
  "\<not>? (a \<or>? b) = (\<not>?a) \<and>? (\<not>?b)"
  by (metis (no_types, opaque_lifting) add.commute invalid_maybe_and maybe_and_idempotent maybe_and_one maybe_not.elims maybe_not.simps(1) maybe_not.simps(3) maybe_not_invalid maybe_or_zero plus_trilean.simps(1) plus_trilean.simps(4) times_trilean.simps(1) times_trilean_commutative trilean.exhaust trilean.simps(6))

lemma de_morgans_2:
  "\<not>? (a \<and>? b) = (\<not>?a) \<or>? (\<not>?b)"
  by (metis de_morgans_1 maybe_double_negation)

lemma not_true: "(x \<noteq> true) = (x = false \<or> x = invalid)"
  by (metis (no_types, lifting) maybe_not.cases trilean.distinct(1) trilean.distinct(3))

lemma pull_negation: "(x = \<not>? y) = (\<not>? x = y)"
  using maybe_double_negation by auto

lemma comp_fun_commute_maybe_or: "comp_fun_commute maybe_or"
  apply standard
  apply (simp add: comp_def)
  apply (rule ext)
  by (simp add: add.left_commute)

lemma comp_fun_commute_maybe_and: "comp_fun_commute maybe_and"
  apply standard
  apply (simp add: comp_def)
  apply (rule ext)
  by (metis add.left_commute de_morgans_2 maybe_not_eq)

end


(*
  Authors: Asta Halkjær From, Agnes Moesgård Eschen & Jørgen Villadsen, DTU Compute
*)

theory LT1 imports System_L1 begin

text \<open>System from Jan Lukasiewicz and Alfred Tarski (1930): Untersuchungen über den Aussagenkalkül\<close>

text \<open>Inspired by Shotaro Tanaka (1965): On Axiom Systems of Propositional Calculi. XIII\<close>

inductive LT (\<open>\<tturnstile>\<close>) where
  LT_MP: \<open>\<tturnstile> q\<close> if \<open>\<tturnstile> p\<close> and \<open>\<tturnstile> (p \<rightarrow> q)\<close> |
  LT_1:  \<open>\<tturnstile> (((p \<rightarrow> (q \<rightarrow> p))
              \<rightarrow> (((\<sim> r \<rightarrow> (s \<rightarrow> \<sim> t)) \<rightarrow> ((r \<rightarrow> (s \<rightarrow> u)) \<rightarrow> ((t \<rightarrow> s) \<rightarrow> (t \<rightarrow> u)))) \<rightarrow> v))
             \<rightarrow> (w \<rightarrow> v))\<close>

lemma LT_3: \<open>\<tturnstile> (p \<rightarrow> (q \<rightarrow> p))\<close>
  using LT_1 LT_MP by metis

lemma LT_5: \<open>\<tturnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close>
  using LT_1 LT_MP by metis

lemma LT_13: \<open>\<tturnstile> (((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)) \<rightarrow> (q \<rightarrow> (p \<rightarrow> r)))\<close>
  using LT_1 LT_5 LT_MP by metis

lemma LT_11: \<open>\<tturnstile> ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close>
  using LT_3 LT_5 LT_MP by metis

lemma LT_20: \<open>\<tturnstile> ((\<sim> p \<rightarrow> p) \<rightarrow> p)\<close>
  using LT_1 LT_3 LT_13 LT_MP by metis

lemma LT_21: \<open>\<tturnstile> (p \<rightarrow> (\<sim> p \<rightarrow> q))\<close>
  using LT_1 LT_3 LT_13 LT_MP by metis

theorem LT_iff_L1: \<open>\<tturnstile> p \<longleftrightarrow> \<turnstile> p\<close>
proof
  have L1_LT_1:
    \<open>\<turnstile> (((p \<rightarrow> (q \<rightarrow> p))
          \<rightarrow> (((\<sim> r \<rightarrow> (s \<rightarrow> \<sim> t)) \<rightarrow> ((r \<rightarrow> (s \<rightarrow> u)) \<rightarrow> ((t \<rightarrow> s) \<rightarrow> (t \<rightarrow> u)))) \<rightarrow> v))
         \<rightarrow> (w \<rightarrow> v))\<close> for p q r s t u v w
    using L1_completeness by simp
  show \<open>\<turnstile> p\<close> if \<open>\<tturnstile> p\<close>
    using that by (induct) (metis MP, metis L1_LT_1)
  show \<open>\<tturnstile> p\<close> if \<open>\<turnstile> p\<close>
    using that by (induct) (metis LT_MP, metis LT_11, metis LT_20, metis LT_21)
qed

theorem LT_soundness: \<open>\<tturnstile> p \<Longrightarrow> I \<Turnstile> p\<close>
  by (induct rule: LT.induct) auto

theorem LT_completeness: \<open>\<forall>I. (I \<Turnstile> p) \<Longrightarrow> \<tturnstile> p\<close>
  using LT_iff_L1 by (simp add: L1_completeness)

section \<open>Soundness and Completeness\<close>

theorem main: \<open>valid p = \<tturnstile> p\<close>
  unfolding valid_def using LT_soundness LT_completeness by blast

lemmas LT = LT.intros main

end


theory aux_lemma
imports Main
begin

lemma mod_div_self: "(a::nat) mod b = 0 \<Longrightarrow> (a div b) * b = a"
by auto

lemma mod_div_mult: "(a::nat) mod b = 0 \<Longrightarrow> a div b \<le> (c - 1) \<Longrightarrow> a \<le> c * b - b"
  apply(subgoal_tac "a \<le> (c - 1) * b")
  apply (simp add: left_diff_distrib')
  by fastforce

lemma mod0_div_self: "(a::nat) mod b = 0 \<Longrightarrow> b * (a div b) = a" by auto

lemma m_mod_div: "n mod x = 0 \<Longrightarrow> (m::nat) * n div x = m * (n div x)"
  by auto

lemma pow_mod_0: "x \<ge> y \<Longrightarrow> (m::nat) ^ x mod m ^ y = 0"
  by (simp add: le_imp_power_dvd)

lemma ge_pow_mod_0: "(x::nat) > y \<Longrightarrow> 4 * n * (4::nat) ^ x mod 4 ^ y = 0"
  by (metis less_imp_le_nat mod_mod_trivial mod_mult_right_eq mult_0_right pow_mod_0)

lemma div2_eq_minus: "x \<noteq> 0 \<and> m \<ge> n \<Longrightarrow> (x::nat) ^ m div x ^ n = x ^ (m - n)"
  by (metis add_diff_cancel_left' div_mult_self1_is_m gr0I le_Suc_ex power_add power_not_zero)

lemma pow_lt_mod0: "(n::nat) > 0 \<and> (x::nat) > y \<Longrightarrow> (n ^ x div n ^ y) mod n = 0"
  by (simp add: div2_eq_minus)

lemma mod_div_gt:
"(m::nat) < n \<Longrightarrow> n mod x = 0 \<Longrightarrow> m div x < n div x"
  by (simp add: less_mult_imp_div_less mod_div_self)

lemma div2_eq_divmul: "(a::nat) div b div c = a div (b * c)"
  by (simp add: Divides.div_mult2_eq)

lemma addr_in_div:
"(addr::nat) \<in> {j2 * M ..< (Suc j2) * M} \<Longrightarrow> addr div M = j2"
  by (simp add: div_nat_eqI mult.commute)

lemma divn_mult_n: "x > 0 \<Longrightarrow> (n::nat) = m div x * x \<Longrightarrow> (if m mod x = 0 then m = n else n < m \<and> m < n + x \<and> n mod x = 0)"
  apply auto
  apply (metis div_mult_mod_eq less_add_same_cancel1)
  by (metis add_le_cancel_left div_mult_mod_eq mod_less_divisor not_less)

lemma mod_minus_0:
"(m::nat) \<le> n \<and> 0 < m  \<Longrightarrow> a * (4::nat) ^ n mod 4 ^ (n - m) = 0"
by (metis diff_le_self mod_mult_right_eq mod_mult_self2_is_0 mult_0 mult_0_right pow_mod_0)

lemma mod_minus_div_4:
"(m::nat) \<le> n \<and> 0 < m  \<Longrightarrow> a * (4::nat) ^ n div 4 ^ (n - m) mod 4 = 0"
by (metis add.left_neutral add_lessD1 diff_less m_mod_div mod_0 mod_mult_right_eq
  mult_0_right nat_less_le pow_lt_mod0 pow_mod_0 zero_less_numeral)

lemma modn0_xy_n: "(n::nat) > 0 \<Longrightarrow> x mod n = 0 \<Longrightarrow> y mod n = 0 \<Longrightarrow> x < y \<Longrightarrow> x + n \<le> y"
  by (metis Nat.le_diff_conv2 add.commute add.left_neutral add_diff_cancel_left'
     le_less less_imp_add_positive mod_add_left_eq mod_less not_less)

lemma divn_multn_addn_le: "(n::nat) > 0 \<Longrightarrow> y mod n = 0 \<Longrightarrow> x < y \<Longrightarrow> x div n * n + n \<le> y"
  using divn_mult_n[of n "x div n * n" x] modn0_xy_n
  apply(case_tac "x mod n = 0")
    apply(rule subst[where s="x" and t="x div n * n"])  apply metis
    by auto

lemma div_in_suc: "y > 0 \<Longrightarrow> n = (x::nat) div y \<Longrightarrow> x \<in> {n * y ..< Suc n * y}"
  by (simp add: dividend_less_div_times)

lemma int1_eq:"P \<inter> {V} \<noteq> {} \<Longrightarrow> P \<inter> {V} = {V}" by auto

lemma int1_belong: "P \<inter> {V} = {V} \<Longrightarrow> V\<in>P" by auto

lemma two_int_one: "P \<inter> {V} \<inter> {Va} \<noteq> {} \<Longrightarrow> V = Va \<and> {V} = P \<inter> {V} \<inter> {Va}" by auto

end


(* Title: Examples/TTS_Foundations/Foundations/FNDS_Definite_Description.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Definite description operator\<close>
theory FNDS_Definite_Description
  imports Main
begin

subsection\<open>Definition and common properties\<close>

definition The_on
  where "The_on U P =
    (if \<exists>!x. x \<in> U \<and> P x then Some (THE x. x \<in> U \<and> P x) else None)"

syntax
  "_The_on" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> 'a option"
  ("(THE _ on _./ _)" [0, 0, 10] 10)
translations "THE x on U. P" \<rightleftharpoons> "CONST The_on U (\<lambda>x. P)"

print_translation \<open>
  [
    (
      \<^const_syntax>\<open>The_on\<close>,
      fn _ => fn [Ut, Abs abs] =>
        let val (x, t) = Syntax_Trans.atomic_abs_tr' abs
        in Syntax.const \<^syntax_const>\<open>_The_on\<close> $ x $ Ut $ t end
    )
  ]
\<close>

lemma The_on_UNIV_eq_The:
  assumes "\<exists>!x. P x"
  obtains x where "(THE x on UNIV. P x) = Some x" and "(THE x. P x) = x"
  unfolding The_on_def by (simp add: assms)

lemma The_on_UNIV_None:
  assumes "\<not>(\<exists>!x. P x)"
  shows "(THE x on UNIV. P x) = None"
  unfolding The_on_def by (simp add: assms)

lemma The_on_eq_The:
  assumes "\<exists>!x. x \<in> U \<and> P x"
  obtains x where "(THE x on U. P x) = Some x" and "(THE x. x \<in> U \<and> P x) = x"
  unfolding The_on_def by (simp add: assms)

lemma The_on_None:
  assumes "\<not>(\<exists>!x. x \<in> U \<and> P x)"
  shows "(THE x on U. P x) = None"
  unfolding The_on_def by (auto simp: assms)

lemma The_on_Some_equality[intro]:
  assumes "a \<in> U" and "P a" and "\<And>x. x \<in> U \<Longrightarrow> P x \<Longrightarrow> x = a"
  shows "(THE x on U. P x) = Some a"
proof-
  from assms have "\<exists>!x. x \<in> U \<and> P x" by auto
  moreover have "(THE x. x \<in> U \<and> P x) = a"
    apply standard using assms by blast+
  ultimately show ?thesis unfolding The_on_def by auto
qed

lemma The_on_equality[intro]:
  assumes "a \<in> U" and "P a" and "\<And>x. x \<in> U \<Longrightarrow> P x \<Longrightarrow> x = a"
  shows "the (THE x on U. P x) = a"
  by (metis assms option.sel The_on_Some_equality)

lemma The_on_SomeI:
  assumes "a \<in> U" and "P a" and "\<And>x. x \<in> U \<Longrightarrow> P x \<Longrightarrow> x = a"
  obtains x where "(THE x on U. P x) = Some x" and "P x"
  using assms unfolding The_on_def by (meson that The_on_Some_equality)

lemma The_onI:
  assumes "a \<in> U" and "P a" and "\<And>x. x \<in> U \<Longrightarrow> P x \<Longrightarrow> x = a"
  shows "P (the (THE x on U. P x))"
  by (metis assms The_on_equality)

lemma The_on_SomeI':
  assumes "\<exists>!x. x \<in> U \<and> P x"
  obtains x where "(THE x on U. P x) = Some x" and "P x"
  by (metis assms The_on_SomeI)

lemma The_onI':
  assumes "\<exists>!x. x \<in> U \<and> P x"
  shows "P (the (THE x on U. P x))"
  by (metis assms The_onI)

lemma The_on_SomeI2:
  assumes "a \<in> U"
    and "P a"
    and "\<And>x. x \<in> U \<Longrightarrow> P x \<Longrightarrow> x = a"
    and "\<And>x. x \<in> U \<Longrightarrow> P x \<Longrightarrow> Q x"
  obtains x where "(THE x on U. P x) = Some x" and "Q x"
  using assms by blast

lemma The_on_I2:
  assumes "a \<in> U"
    and "P a"
    and "\<And>x. x \<in> U \<Longrightarrow> P x \<Longrightarrow> x = a"
    and "\<And>x. x \<in> U \<Longrightarrow> P x \<Longrightarrow> Q x"
  shows "Q (the (THE x on U. P x))"
  by (metis assms The_on_equality)

lemma The_on_Some1I2:
  assumes "\<exists>!x. x \<in> U \<and> P x" and "\<And>x. x \<in> U \<Longrightarrow> P x \<Longrightarrow> Q x"
  obtains x where "(THE x on U. P x) = Some x" and "Q x"
  using assms by blast

lemma The_on1I2:
  assumes "\<exists>!x. x \<in> U \<and> P x" and "\<And>x. x \<in> U \<Longrightarrow> P x \<Longrightarrow> Q x"
  shows "Q (the (THE x on U. P x))"
  by (metis (mono_tags, opaque_lifting) The_on_I2 assms)

lemma The_on1_equality [elim?]:
  assumes "\<exists>!x. P x" and "a \<in> U" and "P a"
  shows "(THE x on U. P x) = Some a"
  using assms by blast

lemma the_sym_eq_trivial:
  assumes "x \<in> U"
  shows "(THE y on U. x = y) = Some x"
  using assms by blast

subsection\<open>Transfer rules\<close>

lemma The_on_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows "(rel_set A ===> (A ===> (=)) ===> rel_option A) The_on The_on"
proof(intro rel_funI)
  fix U and U' and P :: "'a \<Rightarrow> bool" and P' :: "'b \<Rightarrow> bool"
  assume UU'[transfer_rule]: "rel_set A U U'"
    and PP'[transfer_rule]: "(A ===> (=)) P P'"
  show "rel_option A (THE x on U. P x) (THE x on U'. P' x)"
  proof(cases \<open>\<exists>!x'. x' \<in> U' \<and> P' x'\<close>)
    case True show ?thesis
    proof-
      from True obtain x' where "x' \<in> U'" and "P' x'" by clarsimp
      with True have The_on': "(THE x on U'. P' x) = Some x'"
        unfolding The_on_def by auto
      from assms(2) obtain x where [transfer_rule]: "A x x'"
        unfolding right_total_def by auto
      from True have "\<forall>y'\<in>U'. x' \<noteq> y' \<longrightarrow> (\<not>P' y')"
        by (auto simp: \<open>x' \<in> U'\<close> \<open>P' x'\<close>)
      then have "\<forall>y\<in>U. x \<noteq> y \<longrightarrow> (\<not>P y)" by transfer
      moreover from \<open>P' x'\<close> have "P x" by transfer
      ultimately have "\<exists>!x. x \<in> U \<and> P x"
        using UU' \<open>A x x'\<close> \<open>x' \<in> U'\<close> assms(1)
        by (auto dest: bi_uniqueDl rel_setD2)
      moreover from \<open>x' \<in> U'\<close> have "x \<in> U" by transfer
      ultimately have The_on: "(THE x on U. P x) = Some x"
        using \<open>P x\<close> unfolding The_on_def by auto
      show ?thesis unfolding The_on The_on' by transfer_prover
    qed
  next
    case nux: False show ?thesis
    proof(cases \<open>\<exists>x'. x' \<in> U' \<and> P' x'\<close>)
      case True show ?thesis
      proof-
        from True obtain x' where "x' \<in> U'" and "P' x'" by clarsimp
        with nux True obtain y' where "y' \<in> U'" and "P' y'" and "x' \<noteq> y'"
          by auto
        from assms(2) \<open>P' x'\<close> obtain x where [transfer_rule]: "A x x'"
          unfolding right_total_def by auto
        from assms(2) \<open>P' y'\<close> obtain y where [transfer_rule]: "A y y'"
          unfolding right_total_def by auto
        from \<open>P' x'\<close> have "P x" by transfer
        moreover from \<open>P' y'\<close> have "P y" by transfer
        moreover from \<open>x' \<noteq> y'\<close> have "x \<noteq> y" by transfer
        ultimately have "\<nexists>!x. x \<in> U \<and> P x"
          apply transfer
          using UU' \<open>A x x'\<close> \<open>A y y'\<close> \<open>x' \<in> U'\<close> \<open>y' \<in> U'\<close> assms(1)
          by (blast dest: bi_uniqueDl rel_setD2)
        then show ?thesis unfolding The_on_def by (auto simp: nux)
      qed
    next
      case False then show ?thesis
        unfolding The_on_def
        using PP' UU' by (fastforce dest: rel_funD rel_setD1)
    qed
  qed
qed

text\<open>\newpage\<close>

end


(* Title:      Models of Dioids
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Models of Dioids\<close>

theory Dioid_Models
imports Dioid HOL.Real
begin

text \<open>In this section we consider some well known models of
dioids. These so far include the powerset dioid over a monoid,
languages, binary relations, sets of traces, sets paths (in a graph),
as well as the min-plus and the max-plus semirings. Most of these
models are taken from an article about Kleene algebras with
domain~\<^cite>\<open>"desharnaismoellerstruth06kad"\<close>.

The advantage of formally linking these models with the abstract
axiomatisations of dioids is that all abstract theorems are
automatically available in all models. It therefore makes sense to
establish models for the strongest possible axiomatisations (whereas
theorems should be proved for the weakest ones).\<close>

subsection \<open>The Powerset Dioid over a Monoid\<close>

text \<open>We assume a multiplicative monoid and define the usual complex
product on sets of elements. We formalise the well known result that
this lifting induces a dioid.\<close>

instantiation set :: (monoid_mult) monoid_mult
begin

  definition one_set_def:
    "1 = {1}"

  definition c_prod_def: \<comment> \<open>the complex product\<close>
    "A \<cdot> B = {u * v | u v. u \<in> A \<and> v \<in> B}"

  instance
  proof
    fix X Y Z :: "'a set"
     show "X \<cdot> Y \<cdot> Z = X \<cdot> (Y \<cdot> Z)"
      by (auto simp add: c_prod_def) (metis mult.assoc)+
    show "1 \<cdot> X = X"
      by (simp add: one_set_def c_prod_def)
    show "X \<cdot> 1 = X"
      by (simp add: one_set_def c_prod_def)
  qed

end (* instantiation *)

instantiation set :: (monoid_mult) dioid_one_zero
begin

  definition zero_set_def:
    "0 = {}"

  definition plus_set_def:
    "A + B = A \<union> B"

  instance
  proof
    fix X Y Z :: "'a set"
    show "X + Y + Z = X + (Y + Z)"
      by (simp add: Un_assoc plus_set_def)
    show "X + Y = Y + X"
      by (simp add: Un_commute plus_set_def)
    show "(X + Y) \<cdot> Z = X \<cdot> Z + Y \<cdot> Z"
      by (auto simp add: plus_set_def c_prod_def)
    show "1 \<cdot> X = X"
      by (simp add: one_set_def c_prod_def)
    show "X \<cdot> 1 = X"
      by (simp add: one_set_def c_prod_def)
    show "0 + X = X"
      by (simp add: plus_set_def zero_set_def)
    show "0 \<cdot> X = 0"
      by (simp add: c_prod_def zero_set_def)
    show "X \<cdot> 0 = 0"
      by (simp add: c_prod_def zero_set_def)
    show "X \<subseteq> Y \<longleftrightarrow> X + Y = Y"
      by (simp add: plus_set_def subset_Un_eq)
    show "X \<subset> Y \<longleftrightarrow> X \<subseteq> Y \<and> X \<noteq> Y"
      by (fact psubset_eq)
    show "X + X = X"
      by (simp add: Un_absorb plus_set_def)
    show "X \<cdot> (Y + Z) = X \<cdot> Y + X \<cdot> Z"
      by (auto simp add: plus_set_def c_prod_def)
  qed

end (* instantiation *)

subsection \<open>Language Dioids\<close>

text \<open>Language dioids arise as special cases of the monoidal lifting
because sets of words form free monoids. Moreover, monoids of words
are isomorphic to monoids of lists under append.

To show that languages form dioids it therefore suffices to show that
sets of lists closed under append and multiplication with the empty
word form a (multiplicative) monoid. Isabelle then does the rest of the work
automatically. Infix~\<open>@\<close> denotes word
concatenation.\<close>

instantiation list :: (type) monoid_mult
begin

  definition times_list_def:
    "xs * ys \<equiv> xs @ ys"

  definition one_list_def:
    "1 \<equiv> []"

  instance proof
    fix xs ys zs :: "'a list"
    show "xs * ys * zs = xs * (ys * zs)"
      by (simp add: times_list_def)
    show "1 * xs = xs"
      by (simp add: one_list_def times_list_def)
    show "xs * 1 = xs"
      by (simp add: one_list_def times_list_def)
  qed

end  (* instantiation *)

text \<open>Languages as sets of lists have already been formalised in
Isabelle in various places. We can now obtain much of their algebra
for free.\<close>

type_synonym 'a lan = "'a list set"

interpretation lan_dioid: dioid_one_zero "(+)" "(\<cdot>)" "1::'a lan" "0" "(\<subseteq>)" "(\<subset>)" ..

subsection \<open>Relation Dioids\<close>

text \<open>We now show that binary relations under union, relational
composition, the identity relation, the empty relation and set
inclusion form dioids. Due to the well developed relation library of
Isabelle this is entirely trivial.\<close>

interpretation rel_dioid: dioid_one_zero "(\<union>)" "(O)" Id "{}" "(\<subseteq>)" "(\<subset>)"
  by (unfold_locales, auto)

interpretation rel_monoid: monoid_mult Id "(O)" ..

subsection \<open>Trace Dioids\<close>

text \<open>Traces have been considered, for instance, by
Kozen~\<^cite>\<open>"kozen00hoare"\<close> in the context of Kleene algebras with
tests. Intuitively, a trace is an execution sequence of a labelled
transition system from some state to some other state, in which state
labels and action labels alternate, and which begin and end with a
state label.

Traces generalise words: words can be obtained from traces by
forgetting state labels. Similarly, sets of traces generalise
languages.

In this section we show that sets of traces under union, an
appropriately defined notion of complex product, the set of all traces
of length zero, the empty set of traces and set inclusion form a
dioid.

We first define the notion of trace and the product of traces, which
has been called \emph{fusion product} by Kozen.\<close>

type_synonym ('p, 'a) trace = "'p \<times> ('a \<times> 'p) list"

definition first :: "('p, 'a) trace \<Rightarrow> 'p" where
  "first = fst"

lemma first_conv [simp]: "first (p, xs) = p"
  by (unfold first_def, simp)

fun last :: "('p, 'a) trace \<Rightarrow> 'p" where
  "last (p, []) = p"
| "last (_, xs) = snd (List.last xs)"

lemma last_append [simp]: "last (p, xs @ ys) = last (last (p, xs), ys)"
proof (cases xs)
  show "xs = [] \<Longrightarrow> last (p, xs @ ys) = last (last (p, xs), ys)"
    by simp
  show "\<And>a list. xs = a # list \<Longrightarrow>
    last (p, xs @ ys) = last (last (p, xs), ys)"
  proof (cases ys)
    show "\<And>a list. \<lbrakk>xs = a # list; ys = []\<rbrakk>
      \<Longrightarrow> last (p, xs @ ys) = last (last (p, xs), ys)"
      by simp
    show "\<And>a list aa lista. \<lbrakk>xs = a # list; ys = aa # lista\<rbrakk>
      \<Longrightarrow> last (p, xs @ ys) = last (last (p, xs), ys)"
      by simp
  qed
qed

text \<open>The fusion product is a partial operation. It is undefined if
the last element of the first trace and the first element of the
second trace are different. If these elements are the same, then the
fusion product removes the first element from the second trace and
appends the resulting object to the first trace.\<close>

definition t_fusion :: "('p, 'a) trace \<Rightarrow> ('p, 'a) trace \<Rightarrow> ('p, 'a) trace" where
  "t_fusion x y \<equiv> if last x = first y then (fst x, snd x @ snd y) else undefined"

text \<open>We now show that the first element and the last element of a
trace are a left and right unit for that trace and prove some other
auxiliary lemmas.\<close>

lemma t_fusion_leftneutral [simp]: "t_fusion (first x, []) x = x"
  by (cases x, simp add: t_fusion_def)

lemma fusion_rightneutral [simp]: "t_fusion x (last x, []) = x"
  by (simp add: t_fusion_def)

lemma first_t_fusion [simp]: "last x = first y \<Longrightarrow> first (t_fusion x y) = first x"
  by (simp add: first_def t_fusion_def)

lemma last_t_fusion [simp]: "last x = first y \<Longrightarrow> last (t_fusion x y) = last y"
  by (simp add: first_def t_fusion_def)

text \<open>Next we show that fusion of traces is associative.\<close>

lemma t_fusion_assoc [simp]:
  "\<lbrakk> last x = first y; last y = first z \<rbrakk> \<Longrightarrow> t_fusion x (t_fusion y z) = t_fusion (t_fusion x y) z"
  by (cases x, cases y, cases z, simp add: t_fusion_def)

subsection \<open>Sets of Traces\<close>

text \<open>We now lift the fusion product to a complex product on sets of
traces. This operation is total.\<close>

no_notation
  times (infixl "\<cdot>" 70)

definition t_prod :: "('p, 'a) trace set \<Rightarrow> ('p, 'a) trace set \<Rightarrow> ('p, 'a) trace set" (infixl "\<cdot>" 70)
where "X \<cdot> Y = {t_fusion u v| u v. u \<in> X \<and> v \<in> Y \<and> last u = first v}"

text \<open>Next we define the empty set of traces and the set of traces
of length zero as the multiplicative unit of the trace dioid.\<close>

definition t_zero :: "('p, 'a) trace set" where
  "t_zero \<equiv> {}"

definition t_one :: "('p, 'a) trace set" where
  "t_one \<equiv> \<Union>p. {(p, [])}"

text \<open>We now provide elimination rules for trace products.\<close>

lemma t_prod_iff:
  "w \<in> X\<cdot>Y \<longleftrightarrow> (\<exists>u v. w = t_fusion u v \<and> u \<in> X \<and> v \<in> Y \<and> last u = first v)"
  by (unfold t_prod_def) auto

lemma t_prod_intro [simp, intro]:
  "\<lbrakk> u \<in> X; v \<in> Y; last u = first v \<rbrakk> \<Longrightarrow> t_fusion u v \<in> X\<cdot>Y"
  by (meson t_prod_iff)

lemma t_prod_elim [elim]:
  "w \<in> X\<cdot>Y \<Longrightarrow> \<exists>u v. w = t_fusion u v \<and> u \<in> X \<and> v \<in> Y \<and> last u = first v"
  by (meson t_prod_iff)

text \<open>Finally we prove the interpretation statement that sets of traces
under union and the complex product based on trace fusion together
with the empty set of traces and the set of traces of length one forms
a dioid.\<close>

interpretation trace_dioid: dioid_one_zero "(\<union>)" t_prod t_one t_zero "(\<subseteq>)" "(\<subset>)"
apply unfold_locales
apply (auto simp add: t_prod_def t_one_def t_zero_def t_fusion_def)
apply (metis last_append)
apply (metis last_append append_assoc)
done

no_notation
  t_prod (infixl "\<cdot>" 70)

subsection \<open>The Path Diod\<close>

text \<open>The next model we consider are sets of paths in a graph. We
consider two variants, one that contains the empty path and one that
doesn't. The former leads to more difficult proofs and a more involved
specification of the complex product. We start with paths that include
the empty path. In this setting, a path is a list of nodes.\<close>

subsection \<open>Path Models with the Empty Path\<close>

type_synonym 'a path = "'a list"

text \<open>Path fusion is defined similarly to trace
fusion. Mathematically it should be a partial operation. The fusion of
two empty paths yields the empty path; the fusion between a non-empty
path and an empty one is undefined; the fusion of two non-empty paths
appends the tail of the second path to the first one.

We need to use a total alternative and make sure that undefined paths
do not contribute to the complex product.\<close>

fun p_fusion :: "'a path \<Rightarrow> 'a path \<Rightarrow> 'a path" where
  "p_fusion [] _ = []"
| "p_fusion _ [] = []"
| "p_fusion ps (q # qs) = ps @ qs"

lemma p_fusion_assoc:
  "p_fusion ps (p_fusion qs rs) = p_fusion (p_fusion ps qs) rs"
proof (induct rs)
  case Nil show ?case
    by (metis p_fusion.elims p_fusion.simps(2))
  case Cons show ?case
  proof (induct qs)
    case Nil show ?case
      by (metis neq_Nil_conv p_fusion.simps(1) p_fusion.simps(2))
    case Cons show ?case
      proof -
        have "\<forall>ps. ([] = ps \<or> hd ps # tl ps = ps) \<and> ((\<forall>q qs. q # qs \<noteq> ps) \<or> [] \<noteq> ps)"
          using list.collapse by fastforce
        moreover hence "\<forall>ps q qs. p_fusion ps (q # qs) = ps @ qs \<or> [] = ps"
          by (metis p_fusion.simps(3))
        ultimately show ?thesis
          by (metis (no_types) Cons_eq_appendI append_eq_appendI p_fusion.simps(1) p_fusion.simps(3))
      qed
  qed
qed

text \<open>This lemma overapproximates the real situation, but it holds
in all cases where path fusion should be defined.\<close>

lemma p_fusion_last:
  assumes "List.last ps = hd qs"
  and "ps \<noteq> []"
  and "qs \<noteq> []"
  shows "List.last (p_fusion ps qs) = List.last qs"
  by (metis (opaque_lifting, no_types) List.last.simps List.last_append append_Nil2 assms list.sel(1) neq_Nil_conv p_fusion.simps(3))

lemma p_fusion_hd: "\<lbrakk>ps \<noteq> []; qs \<noteq> []\<rbrakk> \<Longrightarrow> hd (p_fusion ps qs) = hd ps"
  by (metis list.exhaust p_fusion.simps(3) append_Cons list.sel(1))

lemma nonempty_p_fusion: "\<lbrakk>ps \<noteq> []; qs \<noteq> []\<rbrakk> \<Longrightarrow> p_fusion ps qs \<noteq> []"
  by (metis list.exhaust append_Cons p_fusion.simps(3) list.simps(2))

text \<open>We now define a condition that filters out undefined paths in
the complex product.\<close>

abbreviation p_filter :: "'a path \<Rightarrow> 'a path \<Rightarrow> bool" where
"p_filter ps qs \<equiv> ((ps = [] \<and> qs = []) \<or> (ps \<noteq> [] \<and> qs \<noteq> [] \<and> (List.last ps) = hd qs))"

no_notation
  times (infixl "\<cdot>" 70)

definition p_prod :: "'a path set \<Rightarrow> 'a path set \<Rightarrow> 'a path set" (infixl "\<cdot>" 70)
where "X \<cdot> Y = {rs . \<exists>ps \<in> X. \<exists>qs \<in> Y. rs = p_fusion ps qs \<and> p_filter ps qs}"

lemma p_prod_iff:
  "ps \<in> X \<cdot> Y \<longleftrightarrow> (\<exists>qs rs. ps = p_fusion qs rs \<and> qs \<in> X \<and> rs \<in> Y \<and> p_filter qs rs)"
  by (unfold p_prod_def) auto

text \<open>Due to the complexity of the filter condition, proving
properties of complex products can be tedious.\<close>

lemma p_prod_assoc: "(X \<cdot> Y) \<cdot> Z = X \<cdot> (Y \<cdot> Z)"
proof (rule set_eqI)
  fix ps
  show "ps \<in> (X \<cdot> Y) \<cdot> Z \<longleftrightarrow> ps \<in> X \<cdot> (Y \<cdot> Z)"
  proof (cases ps)
    case Nil thus ?thesis
      by auto (metis nonempty_p_fusion p_prod_iff)+
  next
    case Cons thus ?thesis
      by (auto simp add: p_prod_iff) (metis (opaque_lifting, mono_tags) nonempty_p_fusion p_fusion_assoc p_fusion_hd p_fusion_last)+
  qed
qed

text \<open>We now define the multiplicative unit of the path dioid as the
set of all paths of length one, including the empty path, and show the
unit laws with respect to the path product.\<close>

definition p_one :: "'a path set" where
  "p_one \<equiv> {p . \<exists>q::'a. p = [q]} \<union> {[]}"

lemma p_prod_onel [simp]: "p_one \<cdot> X = X"
proof (rule set_eqI)
    fix ps
    show "ps \<in> p_one \<cdot> X \<longleftrightarrow> ps \<in> X"
    proof (cases ps)
      case Nil thus ?thesis
        by (auto simp add: p_one_def p_prod_def, metis nonempty_p_fusion not_Cons_self)
    next
      case Cons thus ?thesis
        by (auto simp add: p_one_def p_prod_def, metis append_Cons append_Nil list.sel(1) neq_Nil_conv p_fusion.simps(3), metis Cons_eq_appendI list.sel(1) last_ConsL list.simps(3) p_fusion.simps(3) self_append_conv2)
    qed
qed

lemma p_prod_oner [simp]: "X \<cdot> p_one = X"
proof (rule set_eqI)
    fix ps
    show "ps \<in> X \<cdot> p_one \<longleftrightarrow> ps \<in> X"
    proof (cases ps)
      case Nil thus ?thesis
        by (auto simp add: p_one_def p_prod_def, metis nonempty_p_fusion not_Cons_self2, metis p_fusion.simps(1))
    next
      case Cons thus ?thesis
        by (auto simp add: p_one_def p_prod_def, metis append_Nil2 neq_Nil_conv p_fusion.simps(3), metis list.sel(1) list.simps(2) p_fusion.simps(3) self_append_conv)
    qed
qed

text \<open>Next we show distributivity laws at the powerset level.\<close>

lemma p_prod_distl: "X \<cdot> (Y \<union> Z) = X \<cdot> Y \<union> X \<cdot> Z"
proof (rule set_eqI)
  fix ps
  show "ps \<in> X \<cdot> (Y \<union> Z) \<longleftrightarrow> ps \<in> X \<cdot> Y \<union> X \<cdot> Z"
  by (cases ps) (auto simp add: p_prod_iff)
qed

lemma p_prod_distr: "(X \<union> Y) \<cdot> Z = X \<cdot> Z \<union> Y \<cdot> Z"
proof (rule set_eqI)
  fix ps
  show "ps \<in> (X \<union> Y) \<cdot> Z \<longleftrightarrow> ps \<in> X \<cdot> Z \<union> Y \<cdot> Z"
    by (cases ps) (auto simp add: p_prod_iff)
qed

text \<open>Finally we show that sets of paths under union, the complex
product, the unit set and the empty set form a dioid.\<close>

interpretation path_dioid: dioid_one_zero "(\<union>)" "(\<cdot>)" p_one "{}" "(\<subseteq>)" "(\<subset>)"
proof
  fix x y z :: "'a path set"
  show  "x \<union> y \<union> z = x \<union> (y \<union> z)"
    by auto
  show "x \<union> y = y \<union> x"
    by auto
  show "(x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
    by (fact p_prod_assoc)
  show "(x \<union> y) \<cdot> z = x \<cdot> z \<union> y \<cdot> z"
    by (fact p_prod_distr)
  show "p_one \<cdot> x = x"
    by (fact p_prod_onel)
  show "x \<cdot> p_one = x"
    by (fact p_prod_oner)
  show "{} \<union> x = x"
    by auto
  show "{} \<cdot> x = {}"
    by (metis all_not_in_conv p_prod_iff)
  show "x \<cdot> {} = {}"
    by (metis all_not_in_conv p_prod_iff)
  show "(x \<subseteq> y) = (x \<union> y = y)"
    by auto
  show "(x \<subset> y) = (x \<subseteq> y \<and> x \<noteq> y)"
    by auto
  show "x \<union> x = x"
    by auto
  show "x \<cdot> (y \<union> z) = x \<cdot> y \<union> x \<cdot> z"
    by (fact p_prod_distl)
qed

no_notation
  p_prod (infixl "\<cdot>" 70)

subsection \<open>Path Models without the Empty Path\<close>

text \<open>We now build a model of paths that does not include the empty
path and therefore leads to a simpler complex product.\<close>

datatype 'a ppath = Node 'a | Cons 'a "'a ppath"

primrec pp_first :: "'a ppath \<Rightarrow> 'a" where
  "pp_first (Node x)   = x"
| "pp_first (Cons x _) = x"

primrec pp_last :: "'a ppath \<Rightarrow> 'a" where
  "pp_last (Node x)    = x"
| "pp_last (Cons _ xs) = pp_last xs"

text \<open>The path fusion product (although we define it as a total
funcion) should only be applied when the last element of the first
argument is equal to the first element of the second argument.\<close>

primrec pp_fusion :: "'a ppath \<Rightarrow> 'a ppath \<Rightarrow> 'a ppath" where
  "pp_fusion (Node x) ys = ys"
| "pp_fusion (Cons x xs) ys = Cons x (pp_fusion xs ys)"

text \<open>We now go through the same steps as for traces and paths
before, showing that the first and last element of a trace a left or
right unit for that trace and that the fusion product on traces is
associative.\<close>

lemma pp_fusion_leftneutral [simp]: "pp_fusion (Node (pp_first x)) x = x"
  by simp

lemma pp_fusion_rightneutral [simp]: "pp_fusion x (Node (pp_last x)) = x"
  by (induct x) simp_all

lemma pp_first_pp_fusion [simp]:
  "pp_last x = pp_first y \<Longrightarrow> pp_first (pp_fusion x y) = pp_first x"
  by (induct x) simp_all

lemma pp_last_pp_fusion [simp]:
  "pp_last x = pp_first y \<Longrightarrow> pp_last (pp_fusion x y) = pp_last y"
  by (induct x) simp_all

lemma pp_fusion_assoc [simp]:
  "\<lbrakk> pp_last x = pp_first y; pp_last y = pp_first z \<rbrakk> \<Longrightarrow> pp_fusion x (pp_fusion y z) = pp_fusion (pp_fusion x y) z"
  by (induct x) simp_all

text \<open>We now lift the path fusion product to a complex product on
sets of paths. This operation is total.\<close>

definition pp_prod :: "'a ppath set \<Rightarrow> 'a ppath set \<Rightarrow> 'a ppath set" (infixl "\<cdot>" 70)
  where "X\<cdot>Y = {pp_fusion u v| u v. u \<in> X \<and> v \<in> Y \<and> pp_last u = pp_first v}"

text \<open>Next we define the set of paths of length one as the
multiplicative unit of the path dioid.\<close>

definition pp_one :: "'a ppath set" where
  "pp_one \<equiv> range Node"

text \<open>We again provide an
elimination rule.\<close>

lemma pp_prod_iff:
  "w \<in> X\<cdot>Y \<longleftrightarrow> (\<exists>u v. w = pp_fusion u v \<and> u \<in> X \<and> v \<in> Y \<and> pp_last u = pp_first v)"
  by (unfold pp_prod_def) auto

interpretation ppath_dioid: dioid_one_zero "(\<union>)" "(\<cdot>)" pp_one "{}" "(\<subseteq>)" "(\<subset>)"
proof
  fix x y z :: "'a ppath set"
  show "x \<union> y \<union> z = x \<union> (y \<union> z)"
    by auto
  show "x \<union> y = y \<union> x"
    by auto
  show "x \<cdot> y \<cdot> z = x \<cdot> (y \<cdot> z)"
    by (auto simp add: pp_prod_def, metis pp_first_pp_fusion pp_fusion_assoc, metis pp_last_pp_fusion)
  show "(x \<union> y) \<cdot> z = x \<cdot> z \<union> y \<cdot> z"
    by (auto simp add: pp_prod_def)
  show "pp_one \<cdot> x = x"
    by (auto simp add: pp_one_def pp_prod_def, metis pp_fusion.simps(1) pp_last.simps(1) rangeI)
  show "x \<cdot> pp_one = x"
    by (auto simp add: pp_one_def pp_prod_def, metis pp_first.simps(1) pp_fusion_rightneutral rangeI)
  show "{} \<union> x = x"
    by auto
  show "{} \<cdot> x = {}"
    by (simp add: pp_prod_def)
  show "x \<cdot> {} = {}"
    by (simp add: pp_prod_def)
  show "x \<subseteq> y \<longleftrightarrow> x \<union> y = y"
    by auto
   show "x \<subset> y \<longleftrightarrow> x \<subseteq> y \<and> x \<noteq> y"
     by auto
  show "x \<union> x = x"
    by auto
  show "x \<cdot> (y \<union> z) = x \<cdot> y \<union> x \<cdot> z"
    by (auto simp add: pp_prod_def)
qed

no_notation
  pp_prod (infixl "\<cdot>" 70)

subsection \<open>The Distributive Lattice Dioid\<close>

text \<open>A bounded distributive lattice is a distributive lattice with
a least and a greatest element. Using Isabelle's lattice theory file
we define a bounded distributive lattice as an axiomatic type class
and show, using a sublocale statement, that every bounded distributive
lattice is a dioid with one and zero.\<close>

class bounded_distributive_lattice = bounded_lattice + distrib_lattice

sublocale bounded_distributive_lattice \<subseteq> dioid_one_zero sup inf top bot less_eq
proof
  fix x y z
  show "sup (sup x y) z = sup x (sup y z)"
    by (fact sup_assoc)
  show "sup x y = sup y x"
    by (fact sup.commute)
  show "inf (inf x y) z = inf x (inf y z)"
    by (metis inf.commute inf.left_commute)
  show "inf (sup x y) z = sup (inf x z) (inf y z)"
    by (fact inf_sup_distrib2)
  show "inf top x = x"
    by simp
  show "inf x top = x"
    by simp
  show "sup bot x = x"
    by simp
  show "inf bot x = bot"
    by simp
  show "inf x bot = bot"
    by simp
  show "(x \<le> y) = (sup x y = y)"
    by (fact le_iff_sup)
  show "(x < y) = (x \<le> y \<and> x \<noteq> y)"
    by auto
  show "sup x x = x"
    by simp
  show "inf x (sup y z) = sup (inf x y) (inf x z)"
    by (fact inf_sup_distrib1)
qed

subsection \<open>The Boolean Dioid\<close>

text \<open>In this section we show that the booleans form a dioid,
because the booleans form a bounded distributive lattice.\<close>

instantiation bool :: bounded_distributive_lattice
begin

  instance ..

end (* instantiation *)

interpretation boolean_dioid: dioid_one_zero sup inf True False less_eq less
  by (unfold_locales, simp_all add: inf_bool_def sup_bool_def)

subsection \<open>The Max-Plus Dioid\<close>

text \<open>The following dioids have important applications in
combinatorial optimisations, control theory, algorithm design and
computer networks.\<close>

text \<open>A definition of reals extended with~\<open>+\<infinity>\<close> {\em
and}~\<open>-\<infinity>\<close> may be found in {\em
HOL/Library/Extended\_Real.thy}. Alas, we require separate extensions
with either~\<open>+\<infinity>\<close> or~\<open>-\<infinity>\<close>.\<close>

text \<open>The carrier set of the max-plus semiring is the set of real
numbers extended by minus infinity. The operation of addition is
maximum, the operation of multiplication is addition, the additive
unit is minus infinity and the multiplicative unit is zero.\<close>

datatype mreal = mreal real | MInfty  \<comment> \<open>minus infinity\<close>

fun mreal_max where
  "mreal_max (mreal x) (mreal y) = mreal (max x y)"
| "mreal_max x MInfty = x"
| "mreal_max MInfty y = y"

lemma mreal_max_simp_3 [simp]: "mreal_max MInfty y = y"
  by (cases y, simp_all)

fun mreal_plus where
  "mreal_plus (mreal x) (mreal y) = mreal (x + y)"
| "mreal_plus _ _ = MInfty"

text \<open>We now show that the max plus-semiring satisfies the axioms of
selective semirings, from which it follows that it satisfies the dioid
axioms.\<close>

instantiation mreal :: selective_semiring
begin

  definition zero_mreal_def:
    "0 \<equiv> MInfty"

  definition one_mreal_def:
    "1 \<equiv> mreal 0"

  definition plus_mreal_def:
    "x + y \<equiv> mreal_max x y"

  definition times_mreal_def:
    "x * y \<equiv> mreal_plus x y"

  definition less_eq_mreal_def:
    "(x::mreal) \<le> y \<equiv> x + y = y"

  definition less_mreal_def:
    "(x::mreal) < y \<equiv> x \<le> y \<and> x \<noteq> y"

  instance
  proof
    fix x y z :: mreal
    show "x + y + z = x + (y + z)"
      by (cases x, cases y, cases z, simp_all add: plus_mreal_def)
    show "x + y = y + x"
      by (cases x, cases y, simp_all add: plus_mreal_def)
    show "x * y * z = x * (y * z)"
      by (cases x, cases y, cases z, simp_all add: times_mreal_def)
    show "(x + y) * z = x * z + y * z"
      by (cases x, cases y, cases z, simp_all add: plus_mreal_def times_mreal_def)
    show "1 * x = x"
      by (cases x, simp_all add: one_mreal_def times_mreal_def)
    show "x * 1 = x"
      by (cases x, simp_all add: one_mreal_def times_mreal_def)
    show "0 + x = x"
      by (cases x, simp_all add: plus_mreal_def zero_mreal_def)
    show "0 * x = 0"
      by (cases x, simp_all add: times_mreal_def zero_mreal_def)
    show "x * 0 = 0"
      by (cases x, simp_all add: times_mreal_def zero_mreal_def)
    show "x \<le> y \<longleftrightarrow> x + y = y"
      by (metis less_eq_mreal_def)
    show "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
      by (metis less_mreal_def)
    show "x + y = x \<or> x + y = y"
      by (cases x, cases y, simp_all add: plus_mreal_def, metis linorder_le_cases max.absorb_iff2 max.absorb1)
    show "x * (y + z) = x * y + x * z"
      by (cases x, cases y, cases z, simp_all add: plus_mreal_def times_mreal_def)     qed

end (* instantiation *)

subsection \<open>The Min-Plus Dioid\<close>

text \<open>The min-plus dioid is also known as {\em tropical
semiring}. Here we need to add a positive infinity to the real
numbers. The procedere follows that of max-plus semirings.\<close>

datatype preal = preal real | PInfty  \<comment> \<open>plus infinity\<close>

fun preal_min where
  "preal_min (preal x) (preal y) = preal (min x y)"
| "preal_min x PInfty = x"
| "preal_min PInfty y = y"

lemma preal_min_simp_3 [simp]: "preal_min PInfty y = y"
  by (cases y, simp_all)

fun preal_plus where
  "preal_plus (preal x) (preal y) = preal (x + y)"
| "preal_plus _ _ = PInfty"

instantiation preal :: selective_semiring
begin

  definition zero_preal_def:
    "0 \<equiv> PInfty"

  definition one_preal_def:
    "1 \<equiv> preal 0"

  definition plus_preal_def:
    "x + y \<equiv> preal_min x y"

  definition times_preal_def:
    "x * y \<equiv> preal_plus x y"

  definition less_eq_preal_def:
    "(x::preal) \<le> y \<equiv> x + y = y"

  definition less_preal_def:
    "(x::preal) < y \<equiv> x \<le> y \<and> x \<noteq> y"

  instance
  proof
    fix x y z :: preal
    show "x + y + z = x + (y + z)"
      by (cases x, cases y, cases z, simp_all add: plus_preal_def)
    show "x + y = y + x"
      by (cases x, cases y, simp_all add: plus_preal_def)
    show "x * y * z = x * (y * z)"
      by (cases x, cases y, cases z, simp_all add: times_preal_def)
    show "(x + y) * z = x * z + y * z"
      by (cases x, cases y, cases z, simp_all add: plus_preal_def times_preal_def)
    show "1 * x = x"
      by (cases x, simp_all add: one_preal_def times_preal_def)
    show "x * 1 = x"
      by (cases x, simp_all add: one_preal_def times_preal_def)
    show "0 + x = x"
      by (cases x, simp_all add: plus_preal_def zero_preal_def)
    show "0 * x = 0"
      by (cases x, simp_all add: times_preal_def zero_preal_def)
    show "x * 0 = 0"
      by (cases x, simp_all add: times_preal_def zero_preal_def)
    show "x \<le> y \<longleftrightarrow> x + y = y"
      by (metis less_eq_preal_def)
    show "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
      by (metis less_preal_def)
    show "x + y = x \<or> x + y = y"
     by (cases x, cases y, simp_all add: plus_preal_def, metis linorder_le_cases min.absorb2 min.absorb_iff1)
    show "x * (y + z) = x * y + x * z"
      by (cases x, cases y, cases z, simp_all add: plus_preal_def times_preal_def)   qed

end (* instantiation *)

text \<open>Variants of min-plus and max-plus semirings can easily be
obtained. Here we formalise the min-plus semiring over the natural
numbers as an example.\<close>

datatype pnat = pnat nat | PInfty  \<comment> \<open>plus infinity\<close>

fun pnat_min where
  "pnat_min (pnat x) (pnat y) = pnat (min x y)"
| "pnat_min x PInfty = x"
| "pnat_min PInfty x = x"

lemma pnat_min_simp_3 [simp]: "pnat_min PInfty y = y"
  by (cases y, simp_all)

fun pnat_plus where
  "pnat_plus (pnat x) (pnat y) = pnat (x + y)"
| "pnat_plus _ _ = PInfty"

instantiation pnat :: selective_semiring
begin

  definition zero_pnat_def:
    "0 \<equiv> PInfty"

  definition one_pnat_def:
    "1 \<equiv> pnat 0"

  definition plus_pnat_def:
    "x + y \<equiv> pnat_min x y"

  definition times_pnat_def:
    "x * y \<equiv> pnat_plus x y"

  definition less_eq_pnat_def:
    "(x::pnat) \<le> y \<equiv> x + y = y"

  definition less_pnat_def:
    "(x::pnat) < y \<equiv> x \<le> y \<and> x \<noteq> y"

  lemma zero_pnat_top: "(x::pnat) \<le> 1"
  by (cases x, simp_all add: less_eq_pnat_def plus_pnat_def one_pnat_def)

  instance
  proof
    fix x y z :: pnat
    show "x + y + z = x + (y + z)"
      by (cases x, cases y, cases z, simp_all add: plus_pnat_def)
    show "x + y = y + x"
      by (cases x, cases y, simp_all add: plus_pnat_def)
    show "x * y * z = x * (y * z)"
      by (cases x, cases y, cases z, simp_all add: times_pnat_def)
    show "(x + y) * z = x * z + y * z"
      by (cases x, cases y, cases z, simp_all add: plus_pnat_def times_pnat_def)
    show "1 * x = x"
      by (cases x, simp_all add: one_pnat_def times_pnat_def)
    show "x * 1 = x"
      by (cases x, simp_all add: one_pnat_def times_pnat_def)
    show "0 + x = x"
      by (cases x, simp_all add: plus_pnat_def zero_pnat_def)
    show "0 * x = 0"
      by (cases x, simp_all add: times_pnat_def zero_pnat_def)
    show "x * 0 = 0"
      by (cases x, simp_all add: times_pnat_def zero_pnat_def)
    show "x \<le> y \<longleftrightarrow> x + y = y"
      by (metis less_eq_pnat_def)
    show "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
      by (metis less_pnat_def)
    show "x + y = x \<or> x + y = y"
      by (cases x, cases y, simp_all add: plus_pnat_def, metis linorder_le_cases min.absorb2 min.absorb_iff1)
    show "x * (y + z) = x * y + x * z"
      by (cases x, cases y, cases z, simp_all add: plus_pnat_def times_pnat_def)
  qed

end (* instantiation *)

end


chapter \<open> Probability Logic \label{chapter:probability} \<close>

theory Probability_Logic
  imports
    "Propositional_Logic_Class.Classical_Connectives"
    HOL.Real
    "HOL-Library.Countable"
begin

no_notation FuncSet.funcset (infixr "\<rightarrow>" 60)

section \<open> Definition of Probability Logic \label{sec:definition-of-probability-logic} \<close>

text \<open> Probability logic is defined in terms of an operator over
       classical logic obeying certain postulates. Scholars often credit
       George Boole for first conceiving this kind of formulation @{cite booleChapterXVITheory1853}.
       Theodore Hailperin in particular has written extensively on this subject
       @{cite hailperinProbabilityLogic1984
         and hailperinBooleLogicProbability1986
         and hailperinSententialProbabilityLogic1996}. \<close>

text \<open> The presentation below roughly follows Kolmogorov's axiomatization
       @{cite kolmogoroffChapterElementareWahrscheinlichkeitsrechnung1933}.
       A key difference is that we only require \<^emph>\<open>finite additivity\<close>, rather
       than \<^emph>\<open>countable additivity\<close>. Finite additivity is also defined in
       terms of implication \<^term>\<open>(\<rightarrow>)\<close>. \<close>

class probability_logic = classical_logic +
  fixes \<P> :: "'a \<Rightarrow> real"
  assumes probability_non_negative: "\<P> \<phi> \<ge> 0"
  assumes probability_unity: "\<turnstile> \<phi> \<Longrightarrow> \<P> \<phi> = 1"
  assumes probability_implicational_additivity:
    "\<turnstile> \<phi> \<rightarrow> \<psi> \<rightarrow> \<bottom> \<Longrightarrow> \<P> ((\<phi> \<rightarrow> \<bottom>) \<rightarrow> \<psi>) = \<P> \<phi> + \<P> \<psi>"

text \<open> A similar axiomatization may be credited to
       Rescher @{cite \<open>pg. 185\<close> rescherManyvaluedLogic1969}.
       However, our formulation has fewer axioms.
       While Rescher assumes \<^term>\<open>\<turnstile> \<phi> \<leftrightarrow> \<psi> \<Longrightarrow> \<P> \<phi> = \<P> \<psi>\<close>, we
       show this is a lemma in \S\ref{sec:prob-logic-alt-def}. \<close>

section \<open> Why Finite Additivity? \label{section:why-finite-additivity} \<close>

text \<open> In this section we touch on why we have chosen to
       employ finite additivity in our axiomatization of
       @{class probability_logic} and deviate from conventional
       probability theory. \<close>

text \<open> Conventional probability obeys an axiom known as \<^emph>\<open>countable additivity\<close>.
       Traditionally it states if \<open>S\<close> is a countable set of sets which are
       pairwise disjoint, then the limit \<open>\<Sum> s \<in> S. \<P> s\<close> exists and
       \<open>\<P> (\<Union> S) = (\<Sum> s \<in> S. \<P> s)\<close>. This is more powerful than our
       finite additivity axiom
       @{lemma \<open>\<turnstile> \<phi> \<rightarrow> \<psi> \<rightarrow> \<bottom> \<Longrightarrow> \<P> ((\<phi> \<rightarrow> \<bottom>) \<rightarrow> \<psi>) = \<P> \<phi> + \<P> \<psi>\<close>
          by (metis probability_implicational_additivity) }. \<close>

text \<open> However, we argue that demanding countable additivity is not practical. \<close>

text \<open> Historically, the statisticians Bruno de Finetti and Leonard Savage
       gave the most well known critiques.  In @{cite definettiSuiPassaggiLimite1930}
       de Finetti shows various properties which are true for countably additive
       probability measures may not hold for finitely additive measures.
       Savage @{cite savageDifficultiesTheoryPersonal1967}, on the other hand,
       develops probability based on choices prizes in lotteries. \<close>

text \<open> We instead argue that if we demand countable additivity, then certain
       properties of real world software would no longer be formally verifiable
       as we demonstrate here. In particular, it prohibits conventional recursive
       data structures for defining propositions. Our argument is derivative of
       one given by Giangiacomo Gerla @{cite \<open>Section 3\<close> gerlaInferencesProbabilityLogic1994}. \<close>

text \<open> By taking equivalence classes modulo \<^term>\<open>\<lambda> \<phi> \<psi> . \<turnstile> \<phi> \<leftrightarrow> \<psi>\<close>,
       any classical logic instance gives rise to a Boolean algebra known as
       a \<^emph>\<open>Lindenbaum Algebra\<close>. In the case of @{typ "'a classical_propositional_formula"}
       this Boolean algebra algebra is both countable and \<^emph>\<open>atomless\<close>.
       A theorem of Horn and Tarski @{cite \<open>Theorem 3.2\<close> hornMeasuresBooleanAlgebras1948}
       asserts there can be no countably additive \<^term>\<open>Pr\<close> for a countable
       atomless Boolean algebra. \<close>

text \<open> The above argument is not intended as a blanket refutation of conventional
       probability theory. It is simply an impossibility result with respect
       to software implementations of probability logic. Plenty of classic results
       in probability rely on countable additivity. A nice example, formalized in
       Isabelle/HOL, is Bouffon's needle @{cite eberlBuffonNeedleProblem2017}. \<close>

section \<open> Basic Properties of Probability Logic \<close>

lemma (in probability_logic) probability_additivity:
  assumes "\<turnstile> \<sim> (\<phi> \<sqinter> \<psi>)"
  shows "\<P> (\<phi> \<squnion> \<psi>) = \<P> \<phi> + \<P> \<psi>"
  using
    assms
  unfolding
    conjunction_def
    disjunction_def
    negation_def
  by (simp add: probability_implicational_additivity)

lemma (in probability_logic) probability_alternate_additivity:
  assumes "\<turnstile> \<phi> \<rightarrow> \<psi> \<rightarrow> \<bottom>"
  shows "\<P> (\<phi> \<squnion> \<psi>) = \<P> \<phi> + \<P> \<psi>"
  using assms
  by (metis
        probability_additivity
        double_negation_converse
        modus_ponens
        conjunction_def
        negation_def)

lemma (in probability_logic) complementation:
  "\<P> (\<sim> \<phi>) = 1 - \<P> \<phi>"
  by (metis
        probability_alternate_additivity
        probability_unity
        bivalence
        negation_elimination
        add.commute
        add_diff_cancel_left')

lemma (in probability_logic) unity_upper_bound:
  "\<P> \<phi> \<le> 1"
  by (metis
        (no_types)
        diff_ge_0_iff_ge
        probability_non_negative
        complementation)

section \<open> Alternate Definition of Probability Logic \label{sec:prob-logic-alt-def} \<close>

text \<open> There is an alternate axiomatization of probability logic,
       due to Brian Gaines @{cite \<open>pg. 159, postulates P7, P8, and P8\<close> gainesFuzzyProbabilityUncertainty1978}
       and independently formulated by Brian Weatherson @{cite weathersonClassicalIntuitionisticProbability2003}.
       As Weatherson notes, this axiomatization is suited to formulating
       \<^emph>\<open>intuitionistic\<close> probability logic. In the case where the underlying
       logic is classical the Gaines/Weatherson axiomatization is equivalent
       to the traditional Kolmogorov axiomatization from
       \S\ref{sec:definition-of-probability-logic}. \<close>

class gaines_weatherson_probability = classical_logic +
  fixes \<P> :: "'a \<Rightarrow> real"
  assumes gaines_weatherson_thesis:
    "\<P> \<top> = 1"
  assumes gaines_weatherson_antithesis:
    "\<P> \<bottom> = 0"
  assumes gaines_weatherson_monotonicity:
    "\<turnstile> \<phi> \<rightarrow> \<psi> \<Longrightarrow> \<P> \<phi> \<le> \<P> \<psi>"
  assumes gaines_weatherson_sum_rule:
    "\<P> \<phi> + \<P> \<psi> = \<P> (\<phi> \<sqinter> \<psi>) + \<P> (\<phi> \<squnion> \<psi>)"

sublocale gaines_weatherson_probability \<subseteq> probability_logic
proof
  fix \<phi>
  have "\<turnstile> \<bottom> \<rightarrow> \<phi>"
    by (simp add: ex_falso_quodlibet)
  thus "0 \<le> \<P> \<phi>"
    using
      gaines_weatherson_antithesis
      gaines_weatherson_monotonicity
    by fastforce
next
  fix \<phi>
  assume "\<turnstile> \<phi>"
  thus "\<P> \<phi> = 1"
    by (metis
          gaines_weatherson_thesis
          gaines_weatherson_monotonicity
          eq_iff
          axiom_k
          ex_falso_quodlibet
          modus_ponens
          verum_def)
next
  fix \<phi> \<psi>
  assume "\<turnstile> \<phi> \<rightarrow> \<psi> \<rightarrow> \<bottom>"
  hence "\<turnstile> \<sim> (\<phi> \<sqinter> \<psi>)"
    by (simp add: conjunction_def negation_def)
  thus "\<P> ((\<phi> \<rightarrow> \<bottom>) \<rightarrow> \<psi>) = \<P> \<phi> + \<P> \<psi>"
    by (metis
          add.commute
          add.right_neutral
          eq_iff
          disjunction_def
          ex_falso_quodlibet
          negation_def
          gaines_weatherson_antithesis
          gaines_weatherson_monotonicity
          gaines_weatherson_sum_rule)
qed

lemma (in probability_logic) monotonicity:
  "\<turnstile> \<phi> \<rightarrow> \<psi> \<Longrightarrow> \<P> \<phi> \<le> \<P> \<psi>"
proof -
  assume "\<turnstile> \<phi> \<rightarrow> \<psi>"
  hence "\<turnstile> \<sim> (\<phi> \<sqinter> \<sim> \<psi>)"
    unfolding negation_def conjunction_def
    by (metis
          conjunction_def
          exclusion_contrapositive_equivalence
          negation_def
          weak_biconditional_weaken)
  hence "\<P> (\<phi> \<squnion> \<sim> \<psi>) = \<P> \<phi> + \<P> (\<sim> \<psi>)"
    by (simp add: probability_additivity)
  hence "\<P> \<phi> + \<P> (\<sim> \<psi>) \<le> 1"
    by (metis unity_upper_bound)
  hence "\<P> \<phi> + 1 - \<P> \<psi> \<le> 1"
    by (simp add: complementation)
  thus ?thesis by linarith
qed

lemma (in probability_logic) biconditional_equivalence:
  "\<turnstile> \<phi> \<leftrightarrow> \<psi> \<Longrightarrow> \<P> \<phi> = \<P> \<psi>"
  by (meson
        eq_iff
        modus_ponens
        biconditional_left_elimination
        biconditional_right_elimination
        monotonicity)

lemma (in probability_logic) sum_rule:
  "\<P> (\<phi> \<squnion> \<psi>) + \<P> (\<phi> \<sqinter> \<psi>) = \<P> \<phi> + \<P> \<psi>"
proof -
  have "\<turnstile> (\<phi> \<squnion> \<psi>) \<leftrightarrow> (\<phi> \<squnion> \<psi> \<setminus> (\<phi> \<sqinter> \<psi>))"
  proof -
    have "\<forall> \<MM>. \<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p (\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<squnion> \<^bold>\<langle>\<psi>\<^bold>\<rangle>) \<leftrightarrow> (\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<squnion> \<^bold>\<langle>\<psi>\<^bold>\<rangle> \<setminus> (\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<sqinter> \<^bold>\<langle>\<psi>\<^bold>\<rangle>))"
      unfolding
        classical_logic_class.subtraction_def
        classical_logic_class.negation_def
        classical_logic_class.biconditional_def
        classical_logic_class.conjunction_def
        classical_logic_class.disjunction_def
      by simp
    hence "\<turnstile> \<^bold>\<lparr> (\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<squnion> \<^bold>\<langle>\<psi>\<^bold>\<rangle>) \<leftrightarrow> (\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<squnion> \<^bold>\<langle>\<psi>\<^bold>\<rangle> \<setminus> (\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<sqinter> \<^bold>\<langle>\<psi>\<^bold>\<rangle>)) \<^bold>\<rparr>"
      using propositional_semantics by blast
    thus ?thesis by simp
  qed
  moreover have "\<turnstile> \<phi> \<rightarrow> (\<psi> \<setminus> (\<phi> \<sqinter> \<psi>)) \<rightarrow> \<bottom>"
  proof -
    have "\<forall> \<MM>. \<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<^bold>\<langle>\<phi>\<^bold>\<rangle> \<rightarrow> (\<^bold>\<langle>\<psi>\<^bold>\<rangle> \<setminus> (\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<sqinter> \<^bold>\<langle>\<psi>\<^bold>\<rangle>)) \<rightarrow> \<bottom>"
      unfolding
        classical_logic_class.subtraction_def
        classical_logic_class.negation_def
        classical_logic_class.biconditional_def
        classical_logic_class.conjunction_def
        classical_logic_class.disjunction_def
      by simp
    hence "\<turnstile> \<^bold>\<lparr> \<^bold>\<langle>\<phi>\<^bold>\<rangle> \<rightarrow> (\<^bold>\<langle>\<psi>\<^bold>\<rangle> \<setminus> (\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<sqinter> \<^bold>\<langle>\<psi>\<^bold>\<rangle>)) \<rightarrow> \<bottom> \<^bold>\<rparr>"
      using propositional_semantics by blast
    thus ?thesis by simp
  qed
  hence "\<P> (\<phi> \<squnion> \<psi>) = \<P> \<phi> + \<P> (\<psi> \<setminus> (\<phi> \<sqinter> \<psi>))"
    using
      probability_alternate_additivity
      biconditional_equivalence
      calculation
    by auto
  moreover have "\<turnstile> \<psi> \<leftrightarrow> (\<psi> \<setminus> (\<phi> \<sqinter> \<psi>) \<squnion> (\<phi> \<sqinter> \<psi>))"
  proof -
    have "\<forall> \<MM>. \<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<^bold>\<langle>\<psi>\<^bold>\<rangle> \<leftrightarrow> (\<^bold>\<langle>\<psi>\<^bold>\<rangle> \<setminus> (\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<sqinter> \<^bold>\<langle>\<psi>\<^bold>\<rangle>) \<squnion> (\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<sqinter> \<^bold>\<langle>\<psi>\<^bold>\<rangle>))"
      unfolding
        classical_logic_class.subtraction_def
        classical_logic_class.negation_def
        classical_logic_class.biconditional_def
        classical_logic_class.conjunction_def
        classical_logic_class.disjunction_def
      by auto
    hence "\<turnstile> \<^bold>\<lparr> \<^bold>\<langle>\<psi>\<^bold>\<rangle> \<leftrightarrow> (\<^bold>\<langle>\<psi>\<^bold>\<rangle> \<setminus> (\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<sqinter> \<^bold>\<langle>\<psi>\<^bold>\<rangle>) \<squnion> (\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<sqinter> \<^bold>\<langle>\<psi>\<^bold>\<rangle>)) \<^bold>\<rparr>"
      using propositional_semantics by
      blast
    thus ?thesis by simp
  qed
  moreover have "\<turnstile> (\<psi> \<setminus> (\<phi> \<sqinter> \<psi>)) \<rightarrow> (\<phi> \<sqinter> \<psi>) \<rightarrow> \<bottom>"
    unfolding
      subtraction_def
      negation_def
      conjunction_def
    using
      conjunction_def
      conjunction_right_elimination
    by auto
  hence "\<P> \<psi> = \<P> (\<psi> \<setminus> (\<phi> \<sqinter> \<psi>)) + \<P> (\<phi> \<sqinter> \<psi>)"
    using
      probability_alternate_additivity
      biconditional_equivalence
      calculation
    by auto
  ultimately show ?thesis
    by simp
qed

sublocale probability_logic \<subseteq> gaines_weatherson_probability
proof
  show "\<P> \<top> = 1"
    by (simp add: probability_unity)
next
  show "\<P> \<bottom> = 0"
    by (metis
          add_cancel_left_right
          probability_additivity
          ex_falso_quodlibet
          probability_unity
          bivalence
          conjunction_right_elimination
          negation_def)
next
  fix \<phi> \<psi>
  assume "\<turnstile> \<phi> \<rightarrow> \<psi>"
  thus "\<P> \<phi> \<le> \<P> \<psi>"
    using monotonicity
    by auto
next
  fix \<phi> \<psi>
  show "\<P> \<phi> + \<P> \<psi> = \<P> (\<phi> \<sqinter> \<psi>) + \<P> (\<phi> \<squnion> \<psi>)"
    by (metis sum_rule add.commute)
qed

sublocale probability_logic \<subseteq> consistent_classical_logic
proof
  show "\<not> \<turnstile> \<bottom>" using probability_unity gaines_weatherson_antithesis by auto
qed

lemma (in probability_logic) subtraction_identity:
  "\<P> (\<phi> \<setminus> \<psi>) = \<P> \<phi> - \<P> (\<phi> \<sqinter> \<psi>)"
proof -
  have "\<turnstile> \<phi> \<leftrightarrow> ((\<phi> \<setminus> \<psi>) \<squnion> (\<phi> \<sqinter> \<psi>))"
  proof -
    have "\<forall> \<MM>. \<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<^bold>\<langle>\<phi>\<^bold>\<rangle> \<leftrightarrow> ((\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<setminus> \<^bold>\<langle>\<psi>\<^bold>\<rangle>) \<squnion> (\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<sqinter> \<^bold>\<langle>\<psi>\<^bold>\<rangle>))"
      unfolding
        classical_logic_class.subtraction_def
        classical_logic_class.negation_def
        classical_logic_class.biconditional_def
        classical_logic_class.conjunction_def
        classical_logic_class.disjunction_def
      by (simp, blast)
    hence "\<turnstile> \<^bold>\<lparr> \<^bold>\<langle>\<phi>\<^bold>\<rangle> \<leftrightarrow> ((\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<setminus> \<^bold>\<langle>\<psi>\<^bold>\<rangle>) \<squnion> (\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<sqinter> \<^bold>\<langle>\<psi>\<^bold>\<rangle>)) \<^bold>\<rparr>"
      using propositional_semantics by blast
    thus ?thesis by simp
  qed
  hence "\<P> \<phi>  = \<P> ((\<phi> \<setminus> \<psi>) \<squnion> (\<phi> \<sqinter> \<psi>))"
    using biconditional_equivalence
    by simp
  moreover have "\<turnstile> \<sim>((\<phi> \<setminus> \<psi>) \<sqinter> (\<phi> \<sqinter> \<psi>))"
  proof -
    have "\<forall> \<MM>. \<MM> \<Turnstile>\<^sub>p\<^sub>r\<^sub>o\<^sub>p \<sim>((\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<setminus> \<^bold>\<langle>\<psi>\<^bold>\<rangle>) \<sqinter> (\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<sqinter> \<^bold>\<langle>\<psi>\<^bold>\<rangle>))"
      unfolding
        classical_logic_class.subtraction_def
        classical_logic_class.negation_def
        classical_logic_class.conjunction_def
        classical_logic_class.disjunction_def
      by simp
    hence "\<turnstile> \<^bold>\<lparr> \<sim>((\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<setminus> \<^bold>\<langle>\<psi>\<^bold>\<rangle>) \<sqinter> (\<^bold>\<langle>\<phi>\<^bold>\<rangle> \<sqinter> \<^bold>\<langle>\<psi>\<^bold>\<rangle>)) \<^bold>\<rparr>"
      using propositional_semantics by blast
    thus ?thesis by simp
  qed
  ultimately show ?thesis
    using probability_additivity
    by auto
qed

section \<open> Basic Probability Logic Inequality Results \label{sec:basic-probability-inequality-results}\<close>

lemma (in probability_logic) disjunction_sum_inequality:
  "\<P> (\<phi> \<squnion> \<psi>) \<le> \<P> \<phi> + \<P> \<psi>"
proof -
  have "\<P> (\<phi> \<squnion> \<psi>) + \<P> (\<phi> \<sqinter> \<psi>) = \<P> \<phi> + \<P> \<psi>"
       "0 \<le> \<P> (\<phi> \<sqinter> \<psi>)"
    by (simp add: sum_rule, simp add: probability_non_negative)
  thus ?thesis by linarith
qed

lemma (in probability_logic)
  arbitrary_disjunction_list_summation_inequality:
  "\<P> (\<Squnion> \<Phi>) \<le> (\<Sum>\<phi>\<leftarrow>\<Phi>. \<P> \<phi>)"
proof (induct \<Phi>)
  case Nil
  then show ?case by (simp add: gaines_weatherson_antithesis)
next
  case (Cons \<phi> \<Phi>)
  have "\<P> (\<Squnion> (\<phi> # \<Phi>)) \<le> \<P> \<phi> + \<P> (\<Squnion> \<Phi>)"
    using disjunction_sum_inequality
    by simp
  with Cons have "\<P> (\<Squnion> (\<phi> # \<Phi>)) \<le> \<P> \<phi> + (\<Sum>\<phi>\<leftarrow>\<Phi>. \<P> \<phi>)" by linarith
  then show ?case by simp
qed

lemma (in probability_logic) implication_list_summation_inequality:
  assumes "\<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>"
  shows "\<P> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<P> \<psi>)"
  using
    assms
    arbitrary_disjunction_list_summation_inequality
    monotonicity
    order_trans
  by blast

lemma (in probability_logic) arbitrary_disjunction_set_summation_inequality:
  "\<P> (\<Squnion> \<Phi>) \<le> (\<Sum>\<phi> \<in> set \<Phi>. \<P> \<phi>)"
  by (metis
        arbitrary_disjunction_list_summation_inequality
        arbitrary_disjunction_remdups
        biconditional_equivalence
        sum.set_conv_list)

lemma (in probability_logic) implication_set_summation_inequality:
  assumes "\<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>"
  shows "\<P> \<phi> \<le> (\<Sum>\<psi> \<in> set \<Psi>. \<P> \<psi>)"
  using
    assms
    arbitrary_disjunction_set_summation_inequality
    monotonicity
    order_trans
  by blast

section \<open> Dirac Measures \label{sec:dirac-measures}\<close>

text \<open> Before presenting \<^emph>\<open>Dirac measures\<close> in probability logic, we first
       give the set of all functions satisfying probability logic.\<close>

definition (in classical_logic) probabilities :: "('a \<Rightarrow> real) set"
  where "probabilities =
         {\<P>. class.probability_logic (\<lambda> \<phi>. \<turnstile> \<phi>) (\<rightarrow>) \<bottom> \<P> }"

text \<open> Traditionally, a Dirac measure is a function \<^term>\<open>\<delta>\<^sub>x\<close> where
       \<^term>\<open>\<delta>\<^sub>x(S) = (1::real)\<close> if \<^term>\<open>x \<in> S\<close> and \<^term>\<open>\<delta>\<^sub>x(S) = (0::real)\<close>
       otherwise.  This means that Dirac measures correspond to special
       ultrafilters on their underlying \<^term>\<open>\<sigma>\<close>-algebra which are
       closed under countable unions. \<close>

text \<open> Probability logic, as discussed in \S\ref{section:why-finite-additivity},
       may not have countable joins in its underlying logic. In the setting
       of probability logic, Dirac measures are simple probability functions
       that are either 0 or 1. \<close>

definition (in classical_logic) dirac_measures :: "('a \<Rightarrow> real) set"
  where "dirac_measures =
         { \<P>. class.probability_logic (\<lambda> \<phi>. \<turnstile> \<phi>) (\<rightarrow>) \<bottom> \<P>
               \<and> (\<forall>x. \<P> x = 0 \<or> \<P> x = 1) }"

lemma (in classical_logic) dirac_measures_subset:
  "dirac_measures \<subseteq> probabilities"
  unfolding
    probabilities_def
    dirac_measures_def
  by fastforce

text \<open> Maximally consistent sets correspond to Dirac measures. One direction
       of this correspondence is established below. \<close>

lemma (in classical_logic) MCS_dirac_measure:
  assumes "MCS \<Omega>"
    shows "(\<lambda> \<chi>. if \<chi>\<in>\<Omega> then (1 :: real) else 0) \<in> dirac_measures"
      (is "?\<P> \<in> dirac_measures")
proof -
  have "class.probability_logic (\<lambda> \<phi>. \<turnstile> \<phi>) (\<rightarrow>) \<bottom> ?\<P>"
  proof (standard, simp,
         meson
           assms
           formula_maximally_consistent_set_def_reflection
           maximally_consistent_set_def
           set_deduction_weaken)
    fix \<phi> \<psi>
    assume "\<turnstile> \<phi> \<rightarrow> \<psi> \<rightarrow> \<bottom>"
    hence "\<phi> \<sqinter> \<psi> \<notin> \<Omega>"
      by (metis
            assms
            formula_consistent_def
            formula_maximally_consistent_set_def_def
            maximally_consistent_set_def
            conjunction_def
            set_deduction_modus_ponens
            set_deduction_reflection
            set_deduction_weaken)
    hence "\<phi> \<notin> \<Omega> \<or> \<psi> \<notin> \<Omega>"
      using
        assms
        formula_maximally_consistent_set_def_reflection
        maximally_consistent_set_def
        conjunction_set_deduction_equivalence
      by meson
    have "\<phi> \<squnion> \<psi> \<in> \<Omega> = (\<phi> \<in> \<Omega> \<or> \<psi> \<in> \<Omega>)"
      by (metis
            \<open>\<phi> \<sqinter> \<psi> \<notin> \<Omega>\<close>
            assms
            formula_maximally_consistent_set_def_implication
            maximally_consistent_set_def
            conjunction_def
            disjunction_def)
    have "?\<P> (\<phi> \<squnion> \<psi>) = ?\<P> \<phi> + ?\<P> \<psi>"
    proof (cases "\<phi> \<squnion> \<psi> \<in> \<Omega>")
      case True
      hence \<diamondsuit>: "1 = ?\<P> (\<phi> \<squnion> \<psi>)" by simp
      show ?thesis
      proof (cases "\<phi> \<in> \<Omega>")
        case True
        hence "\<psi> \<notin> \<Omega>"
          using \<open>\<phi> \<notin> \<Omega> \<or> \<psi> \<notin> \<Omega>\<close>
          by blast
        have "?\<P> (\<phi> \<squnion> \<psi>) = (1::real)" using \<diamondsuit> by simp
        also have "... = 1 + (0::real)" by linarith
        also have "... = ?\<P> \<phi> + ?\<P> \<psi>"
          using \<open>\<psi> \<notin> \<Omega>\<close> \<open>\<phi> \<in> \<Omega>\<close> by simp
        finally show ?thesis .
      next
        case False
        hence "\<psi> \<in> \<Omega>"
          using \<open>\<phi> \<squnion> \<psi> \<in> \<Omega>\<close> \<open>(\<phi> \<squnion> \<psi> \<in> \<Omega>) = (\<phi> \<in> \<Omega> \<or> \<psi> \<in> \<Omega>)\<close>
          by blast
        have "?\<P> (\<phi> \<squnion> \<psi>) = (1::real)" using \<diamondsuit> by simp
        also have "... = (0::real) + 1" by linarith
        also have "... = ?\<P> \<phi> + ?\<P> \<psi>"
          using \<open>\<psi> \<in> \<Omega>\<close> \<open>\<phi> \<notin> \<Omega>\<close> by simp
        finally show ?thesis .
      qed
    next
      case False
      moreover from this have "\<phi> \<notin> \<Omega>" "\<psi> \<notin> \<Omega>"
        using \<open>(\<phi> \<squnion> \<psi> \<in> \<Omega>) = (\<phi> \<in> \<Omega> \<or> \<psi> \<in> \<Omega>)\<close> by blast+
      ultimately show ?thesis by simp
    qed
    thus "?\<P> ((\<phi> \<rightarrow> \<bottom>) \<rightarrow> \<psi>) = ?\<P> \<phi> + ?\<P> \<psi>"
      unfolding disjunction_def .
  qed
  thus ?thesis
    unfolding dirac_measures_def
    by simp
qed

notation FuncSet.funcset (infixr "\<rightarrow>" 60)

end