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

header {* Models of Dioids *}

theory Dioid_Models
imports Dioid Real
begin

text {* 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{desharnaismoellerstruth06kad}.

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). *}

subsection {* The Powerset Dioid over a Monoid *}

text {* 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. *}

instantiation set :: (monoid_mult) monoid_mult
begin

  definition one_set_def:
    "1 = {1}"

  definition c_prod_def: -- "the complex product"
    "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 {* Language Dioids *}

text {* 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~@{text @} denotes word
concatenation. *}

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 {* Languages as sets of lists have already been formalised in
Isabelle in various places. We can now obtain much of their algebra
for free. *}

type_synonym 'a lan = "'a list set"

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

subsection {* Relation Dioids *}

text {* 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. *}

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

interpretation rel_monoid: monoid_mult Id "op O" ..

subsection {* Trace Dioids *}

text {* Traces have been considered, for instance, by
Kozen~\cite{kozen00hoare} 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. *}

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 {* 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. *}

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 {* 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. *}

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 (metis (lifting) Dioid_Models.last_append first_def t_fusion_def pair_collapse)

text {* Next we show that fusion of traces is associative. *}

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 {* Sets of Traces *}

text {* We now lift the fusion product to a complex product on sets of
traces. This operation is total. *}

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 {* Next we define the empty set of traces and the set of traces
of length zero as the multiplicative unit of the trace dioid. *}

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 {* We now provide elimination rules for trace products.*}

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 (metis 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 (metis t_prod_iff)

text {* 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. *}

interpretation trace_dioid: dioid_one_zero "op \<union>" t_prod t_one t_zero "op \<subseteq>" "op \<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 {* The Path Diod *}

text {* 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. *}

subsection {* Path Models with the Empty Path *}

type_synonym 'a path = "'a list"

text {* 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. *}

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 list.exhaust p_fusion.simps(1) 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
      by (metis append_Cons append_assoc list.exhaust p_fusion.simps(1) p_fusion.simps(3))
  qed
qed

text {* This lemma overapproximates the real situation, but it holds
in all cases where path fusion should be defined. *}

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 (hide_lams, 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 {* We now define a condition that filters out undefined paths in
the complex product. *}

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 {* Due to the complexity of the filter condition, proving
properties of complex products can be tedious. *}

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 (hide_lams, mono_tags) nonempty_p_fusion p_fusion_assoc p_fusion_hd p_fusion_last)+
  qed
qed

text {* 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. *}

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 {* Next we show distributivity laws at the powerset level. *}

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 {* Finally we show that sets of paths under union, the complex
product, the unit set and the empty set form a dioid. *}

interpretation path_dioid: dioid_one_zero "op \<union>" "op \<cdot>" p_one "{}" "op \<subseteq>" "op \<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 (metis p_prod_distl)
qed

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

subsection {* Path Models without the Empty Path *}

text {* We now build a model of paths that does not include the empty
path and therefore leads to a simpler complex product. *}

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 {* 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. *}

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 {* 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. *}

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 {* We now lift the path fusion product to a complex product on
sets of paths. This operation is total. *}

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 {* Next we define the set of paths of length one as the
multiplicative unit of the path dioid. *}

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

text {* We again provide an
elimination rule. *}

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 "op \<union>" "op \<cdot>" pp_one "{}" "op \<subseteq>" "op \<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 {* The Distributive Lattice Dioid *}

text {* 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. *}

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 {* The Boolean Dioid *}

text {* In this section we show that the booleans form a dioid,
because the booleans form a bounded distributive lattice.  *}

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 {* The Max-Plus Dioid *}

text {* The following dioids have important applications in
combinatorial optimisations, control theory, algorithm design and
computer networks. *}

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

text {* 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. *}

datatype mreal = mreal real | MInfty  -- "minus infinity"

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 {* We now show that the max plus-semiring satisfies the axioms of
selective semirings, from which it follows that it satisfies the dioid
axioms. *}

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 {* The Min-Plus Dioid *}

text {* 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.  *}

datatype preal = preal real | PInfty  -- "plus infinity"

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 {* 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. *}

datatype pnat = pnat nat | PInfty  -- "plus infinity"

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


theory Replace_Reverse_Delete
  imports
  Main
begin

fun replace :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"replace needle new_needle (Cons hay rest) = (Cons
  (if hay = needle
    then new_needle else hay)
  (replace needle new_needle rest))" |
"replace _ _ Nil = Nil"

lemma
  shows replace_append_eq: "replace x y zs @ [y] = replace x y (zs @ [x])"
  by (induct zs arbitrary: x y, simp+)
qed

lemma
  assumes "a \<noteq> x"
  shows replace_append_neq:
    "replace x y zs @ [a] = replace x y (zs @ [a])"
  by(induct zs, auto simp add: assms)

theorem
  shows "rev (replace x y zs) = replace x y (rev zs)"
proof(induct zs)
case Nil
then show ?case by simp
next
  case (Cons a zs)
  then show ?case
    using replace_append_eq replace_append_neq
    by auto
qed

(* Not true by counterexample:
theorem
  shows "replace x y (replace u v zs) = replace u v (replace x y zs)" *)

(* Not true by counterexample:
theorem
  shows "replace y z (replace x y zs) = replace x z zs" *)

fun del1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"del1 x (Cons y xs) = (if x = y then xs else (Cons y (del1 x xs)))" |
"del1 x Nil = Nil"

fun delall :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"delall x (Cons y xs) = (let tail = delall x xs in
  (if x = y then tail else (Cons y tail)))" |
"delall x Nil = Nil"

lemma [simp]:
  shows delall_assoc_cons_eq: "delall x (x # xs) = delall x xs"
  by simp

lemma [simp]:
  assumes "a \<noteq> x"
  shows del1_assoc_cons_neq: "del1 x (a # xs) = a # del1 x xs"
  using assms by auto

lemma [simp]:
  shows del1_assoc_cons_eq: "del1 x (x # xs) = xs"
  by simp

theorem
  shows del1_after_delall: "del1 x (delall x xs) = delall x xs"
proof(induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case
    by(auto simp add: Let_def)
qed

theorem
  shows "delall x (delall x xs) = delall x xs"
proof(induct xs)
case Nil
then show ?case by simp
next
  case (Cons a xs)
  then show ?case by(auto simp add: Let_def)
qed

theorem
  shows "delall x (del1 x xs) = delall x xs"
proof(induct xs)
case Nil
then show ?case by simp
next
  case (Cons a xs)
  then show ?case by(auto simp add: Let_def)
qed

theorem
  shows "del1 x (del1 y zs) = del1 y (del1 x zs)"
proof(induct zs)
case Nil
then show ?case by simp
next
  case (Cons a zs)
  then show ?case by(auto simp add: Let_def)
qed

theorem
  shows "delall x (del1 y zs) = del1 y (delall x zs)"
proof(induct zs arbitrary: x y)
case Nil
  then show ?case by simp
next
  case (Cons a zs)
  then show ?case
    by (simp add: Let_def del1_after_delall)
qed

theorem
  shows "delall x (delall y zs) = delall y (delall x zs)"
proof(induct zs)
case Nil
  then show ?case by simp
next
  case (Cons a zs)
  then show ?case by(auto simp add: Let_def)
qed

(* Disproven by counterexample
theorem
  shows "del1 y (replace x y xs) = del1 x xs" *)

(* Disproven by counterexample
theorem
  shows "delall y (replace x y xs) = delall x xs" *)

theorem "replace x y (delall x zs) = delall x zs"
proof(induction zs)
case Nil
  then show ?case by simp
next
  case (Cons a zs)
  then show ?case by (auto simp add: Let_def)
qed

(* Disproven by counterexample
theorem "replace x y (delall z zs) = delall z (replace x y zs)" *)

(* Disproven by counterexample
theorem "rev(del1 x xs) = del1 x (rev xs)" *)

lemma delall_append_eq:
"delall x (xs @ [x]) = delall x xs "
  by(induct xs, simp+)

lemma delall_append_neq:
"x \<noteq> a \<Longrightarrow> delall x xs @ [a] = delall x (xs @ [a])"
  by(induct xs, auto simp add: Let_def)

lemmas delall_append = delall_append_eq delall_append_neq

theorem "rev(delall x xs) = delall x (rev xs)"
proof(induction xs)
case Nil
then show ?case by simp
next
case (Cons a xs)
  then show ?case
    by(auto simp add: Let_def delall_append)
qed

end


theory Acyclicity
  imports Main
begin

section \<open>Acyclicity\<close>

text \<open> Two of the discussed bounding algorithms ("top-down" and "bottom-up") exploit acyclicity
of the system under projection on sets of state variables closed under mutual variable dependency.
[Abdulaziz et al., p.11]

This specific notion of acyclicity is formalised using topologically sorted dependency graphs
induced by the variable dependency relation. [Abdulaziz et al., p.14]\<close>

subsection "Topological Sorting of Dependency Graphs"

\<comment> \<open>NOTE name shortened.\<close>
\<comment> \<open>NOTE using 'fun' because of multiple defining equations.\<close>
fun top_sorted_abs where
  "top_sorted_abs R [] = True"
| "top_sorted_abs R (h # l) = (list_all (\<lambda>x. \<not>R x h) l \<and> top_sorted_abs R l)"

lemma top_sorted_abs_mem:
  assumes "(top_sorted_abs R (h # l))" "(ListMem x l)"
  shows "(\<not> R x h)"
  using assms
  by (auto simp add: ListMem_iff list.pred_set)

lemma top_sorted_cons:
  assumes "top_sorted_abs R (h # l)"
  shows "(top_sorted_abs R l)"
  using assms
  by simp

subsection \<open>The Weightiest Path Function (wlp)\<close>

text \<open> The weightiest path function is a generalization of an algorithm which computes the
longest path in a DAG starting at a given vertex `v`. Its arguments are the relation `R` which
induces the graph, a weighing function `w` assigning weights to vertices, an accumulating functions
`f` and `g` which aggregate vertex weights into a path weight and the weights of different paths
respectively, the considered vertex and the graph represented as a topological sorted list.
[Abdulaziz et al., p.18]

Typical weight combining functions have the properties defined by `geq\_arg` and `increasing`.
[Abdulaziz et al., p.18] \<close>

\<comment> \<open>NOTE name shortened.\<close>
fun wlp where
  "wlp R w g f x [] = w x"
| "wlp R w g f x (h # l) = (if R x h
    then g (f (w x) (wlp R w g f h l)) (wlp R w g f x l)
    else wlp R w g f x l
  )"

\<comment> \<open>NOTE name shortened.\<close>
definition geq_arg where
  "geq_arg f \<equiv> (\<forall>x y. (x \<le> f x y) \<and> (y \<le> f x y))"

lemma individual_weight_less_eq_lp:
  fixes w :: "'a \<Rightarrow> nat"
  assumes "geq_arg g"
  shows "(w x \<le> wlp R w g f x l)"
  using assms
  unfolding geq_arg_def
proof (induction l arbitrary: R w g f x)
  case (Cons a l)
  then show ?case
    using Cons.IH Cons.prems
  proof (cases "R x a")
    case True
    then show ?thesis
      using Cons le_trans wlp.simps(2)
      by smt
  next
    case False
    then show ?thesis
      using Cons
      by simp
  qed
qed simp

\<comment> \<open>NOTE Types of 'f' and 'g' had to be fixed to be able to use transitivity rule of the less-equal
relation.\<close>
lemma lp_geq_lp_from_successor:
  fixes vtx1 and f g :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  assumes "geq_arg f" "geq_arg g" "(\<forall>vtx. ListMem vtx G \<longrightarrow> \<not>R vtx vtx)" "R vtx2 vtx1"
    "ListMem vtx1 G" "top_sorted_abs R G"
  shows "(f (w vtx2) (wlp R w g f vtx1 G) \<le> (wlp R w g f vtx2 G))"
  using assms
  unfolding geq_arg_def
proof (induction G arbitrary: vtx1 f g R vtx2)
  case Nil
  then show ?case
    using ListMem_iff
    by fastforce
next
  case (Cons a G)
  show ?case
  proof (auto)
    assume P1: "R vtx1 a" "R vtx2 a"
    then show "
        f (w vtx2) (g (f (w vtx1) (wlp R w g f a G)) (wlp R w g f vtx1 G))
        \<le> g (f (w vtx2) (wlp R w g f a G)) (wlp R w g f vtx2 G)"
      using Cons.prems(3, 5, 6)
      by (metis ListMem_iff set_ConsD top_sorted_abs_mem)
  next
    assume P2: "R vtx1 a" "\<not> R vtx2 a"
    then show "
        f (w vtx2) (g (f (w vtx1) (wlp R w g f a G)) (wlp R w g f vtx1 G))
        \<le> wlp R w g f vtx2 G"
      using Cons.prems(4, 5, 6)
      by (metis ListMem_iff set_ConsD top_sorted_abs_mem)
  next
    assume P3: "\<not> R vtx1 a" "R vtx2 a"
    then show "
        f (w vtx2) (wlp R w g f vtx1 G)
        \<le> g (f (w vtx2) (wlp R w g f a G)) (wlp R w g f vtx2 G)"
    proof -
      have f1: "\<forall>n na. n \<le> g n na \<and> na \<le> g n na"
        using Cons.prems(2) by blast
      have f2: "vtx1 = a \<or> vtx1 \<in> set G"
        by (meson Cons.prems(5) ListMem_iff set_ConsD)
      obtain aa :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a" where
        "\<forall>x2. (\<exists>v5. ListMem v5 G \<and> x2 v5 v5) = (ListMem (aa x2) G \<and> x2 (aa x2) (aa x2))"
        by moura
      then have "
          ListMem (aa R) G \<and> R (aa R) (aa R)
          \<or> \<not> ListMem vtx1 G \<or> f (w vtx2) (wlp R w g f vtx1 G) \<le> wlp R w g f vtx2 G"
        using f1 by (metis (no_types) Cons.IH Cons.prems(1, 4, 6) top_sorted_cons)
      then show ?thesis
        using f2 f1 by (meson Cons.prems(3) ListMem_iff insert le_trans)
    qed
  next
    assume P4: "\<not> R vtx1 a" "\<not> R vtx2 a"
    then show "f (w vtx2) (wlp R w g f vtx1 G) \<le> wlp R w g f vtx2 G"
    proof -
      have f1: "top_sorted_abs R G"
        using Cons.prems(6) by fastforce
      have "ListMem vtx1 G"
        by (metis Cons.prems(4) Cons.prems(5) ListMem_iff P4(2) set_ConsD)
      then show ?thesis
        using f1 by (simp add: Cons.IH Cons.prems(1, 2, 3, 4) insert)
    qed
  qed
qed

definition increasing where
  "increasing f \<equiv> (\<forall>e b c d. (e \<le> c) \<and> (b \<le> d) \<longrightarrow> (f e b \<le> f c d))"

lemma weight_fun_leq_imp_lp_leq: "\<And>x.
  (increasing f)
  \<Longrightarrow> (increasing g)
  \<Longrightarrow> (\<forall>y. ListMem y l \<longrightarrow> w1 y \<le> w2 y)
  \<Longrightarrow> (w1 x \<le> w2 x)
  \<Longrightarrow> (wlp R w1 g f x l \<le> wlp R w2 g f x l)
"
  unfolding increasing_def
  by (induction l) (auto simp add: elem insert)

\<comment> \<open>NOTE generalizing `f2`, `x1`, `x2` seems to break the prover.\<close>
lemma wlp_congruence_rule:
  fixes l1 l2 R1 R2 w1 w2 g1 g2 f1 f2 x1 x2
  assumes "(l1 = l2)" "(\<forall>y. ListMem y l2 \<longrightarrow> (R1 x1 y = R2 x2 y))"
    "(\<forall>y. ListMem y l2 \<longrightarrow> (R1 y x1 = R2 y x2))" "(w1 x1 = w2 x2)"
    "(\<forall>y1 y2. (y1 = y2) \<longrightarrow> (f1 (w1 x1) y1 = f2 (w2 x2) y2))"
    "(\<forall>y1 y2 z1 z2. (y1 = y2) \<and> (z1 = z2) \<longrightarrow> ((g1 (f1 (w1 x1) y1) z1) = (g2 (f2 (w2 x2) y2) z2)))"
    "(\<forall>x y. ListMem x l2 \<and> ListMem y l2 \<longrightarrow> (R1 x y = R2 x y))"
    "(\<forall>x. ListMem x l2 \<longrightarrow> (w1 x = w2 x))"
    "(\<forall>x y z. ListMem x l2 \<longrightarrow> (g1 (f1 (w1 x) y) z = g2 (f2 (w2 x) y) z))"
    "(\<forall>x y. ListMem x l2 \<longrightarrow> (f1 (w1 x) y = f2 (w1 x) y))"
  shows "((wlp R1 w1 g1 f1 x1 l1) = (wlp R2 w2 g2 f2 x2 l2))"
  using assms
proof (induction l2 arbitrary: l1 x1 x2)
  case (Cons a l2)
  then have "(wlp R1 w1 g1 f1 x1 l2) = (wlp R2 w2 g2 f2 x2 l2)"
    using Cons
    by (simp add: insert)
  moreover have "(wlp R1 w1 g1 f1 a l2) = (wlp R2 w2 g2 f2 a l2)"
    using Cons
    by (simp add: elem insert)
  ultimately show ?case
    by (simp add: Cons.prems(1,2, 6) elem)
qed auto

lemma wlp_ite_weights:
  fixes x
  assumes "\<forall>y. ListMem y l1 \<longrightarrow> P y" "P x"
  shows "((wlp R (\<lambda>y. if P y then w1 y else w2 y) g f x l1) = (wlp R w1 g f x l1))"
  using assms

proof (induction l1 arbitrary: R P w1 w2 f g)
  case (Cons a l1)
  let ?w1="(\<lambda>y. if P y then w1 y else w2 y)"
  let ?w2="w1"
  {
    have "\<forall>y. ListMem y l1 \<longrightarrow> P y"
      using Cons.prems(1) insert
      by fast
    then have "((wlp R (\<lambda>y. if P y then w1 y else w2 y) g f x l1) = (wlp R w1 g f x l1))"
      using Cons.prems(2) Cons.IH
      by blast
  }
  note 1 = this
  {
    have "(if P x then w1 x else w2 x) = w1 x"
      "\<forall>y1 y2. y1 = y2 \<longrightarrow> f (if P x then w1 x else w2 x) y1 = f (w1 x) y2"
      "\<forall>y1 y2 z1 z2.
        y1 = y2 \<and> z1 = z2
        \<longrightarrow> g (f (if P x then w1 x else w2 x) y1) z1 = g (f (w1 x) y2) z2"
      "\<forall>x. ListMem x (a # l1) \<longrightarrow> (if P x then w1 x else w2 x) = w1 x"
      "\<forall>x y z.
        ListMem x (a # l1)
        \<longrightarrow> g (f (if P x then w1 x else w2 x) y) z = g (f (w1 x) y) z"
      "\<forall>x y.
        ListMem x (a # l1) \<longrightarrow> f (if P x then w1 x else w2 x) y = f (if P x then w1 x else w2 x) y"
      using Cons.prems(1, 2)
      by simp+
    then have "wlp R (\<lambda>y. if P y then w1 y else w2 y) g f x (a # l1) = wlp R w1 g f x (a # l1)"
      using Cons wlp_congruence_rule[of "a # l1" "a # l1" R x R x "?w1" "?w2" f f g g]
      by blast
  }
  then show ?case
    by blast
qed auto

lemma map_wlp_ite_weights: "
  (\<forall>x. ListMem x l1 \<longrightarrow> P x)
  \<Longrightarrow> (\<forall>x. ListMem x l2 \<longrightarrow> P x)
  \<Longrightarrow> (
    map (\<lambda>x. wlp R (\<lambda>y. if P y then w1 y else w2 y) g f x l1) l2
    = map (\<lambda>x. wlp R w1 g f x l1) l2
  )
"
  apply(induction l2)
   apply(auto)
  subgoal by (simp add: elem wlp_congruence_rule)
  subgoal by (simp add: insert)
  done

lemma wlp_weight_lamda_exp: "\<And>x. wlp R w g f x l = wlp R (\<lambda>y. w y) g f x l"
proof -
  fix x
  show "wlp R w g f x l = wlp R (\<lambda>y. w y) g f x l"
    by(induction l) auto
qed

lemma img_wlp_ite_weights: "
  (\<forall>x. ListMem x l \<longrightarrow> P x)
  \<Longrightarrow> (\<forall>x. x \<in> s \<longrightarrow> P x)
  \<Longrightarrow> (
    (\<lambda>x. wlp R (\<lambda>y. if P y then w1 y else w2 y) g f x l) ` s
    = (\<lambda>x. wlp R w1 g f x l) ` s
  )
"
proof -
  assume P1: "\<forall>x. ListMem x l \<longrightarrow> P x"
  assume P2: "\<forall>x. x \<in> s \<longrightarrow> P x"
  show "(
    (\<lambda>x. wlp R (\<lambda>y. if P y then w1 y else w2 y) g f x l) ` s
    = (\<lambda>x. wlp R w1 g f x l) ` s
  )"
    by (auto simp add:  P1 P2 image_iff wlp_ite_weights)
qed

end


section\<open>Proof Systems\<close>
subsection\<open>Sequent Calculus\<close>

theory SC
imports Formulas "HOL-Library.Multiset"
begin

abbreviation msins ("_, _" [56,56] 56) where "x,M == add_mset x M"

text\<open>We do not formalize the concept of sequents, only that of sequent calculus derivations.\<close>
inductive SCp :: "'a formula multiset \<Rightarrow> 'a formula multiset \<Rightarrow> bool" ("(_ \<Rightarrow>/ _)" [53] 53) where
BotL: "\<bottom> \<in># \<Gamma> \<Longrightarrow> \<Gamma>\<Rightarrow>\<Delta>" |
Ax: "Atom k \<in># \<Gamma> \<Longrightarrow> Atom k \<in># \<Delta> \<Longrightarrow> \<Gamma>\<Rightarrow>\<Delta>" |
NotL: "\<Gamma> \<Rightarrow> F,\<Delta> \<Longrightarrow> Not F, \<Gamma> \<Rightarrow> \<Delta>" |
NotR: "F,\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> Not F, \<Delta>" |
AndL: "F,G,\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> And F G, \<Gamma> \<Rightarrow> \<Delta>" |
AndR: "\<lbrakk> \<Gamma> \<Rightarrow> F,\<Delta>; \<Gamma> \<Rightarrow> G,\<Delta> \<rbrakk> \<Longrightarrow> \<Gamma> \<Rightarrow> And F G, \<Delta>" |
OrL: "\<lbrakk> F,\<Gamma> \<Rightarrow> \<Delta>; G,\<Gamma> \<Rightarrow> \<Delta> \<rbrakk> \<Longrightarrow> Or F G, \<Gamma> \<Rightarrow> \<Delta>" |
OrR: "\<Gamma> \<Rightarrow> F,G,\<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> Or F G, \<Delta>" |
ImpL: "\<lbrakk> \<Gamma> \<Rightarrow> F,\<Delta>; G,\<Gamma> \<Rightarrow> \<Delta> \<rbrakk> \<Longrightarrow> Imp F G, \<Gamma> \<Rightarrow> \<Delta>" |
ImpR: "F,\<Gamma> \<Rightarrow> G,\<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> Imp F G, \<Delta>"

text\<open>Many of the proofs here are inspired Troelstra and Schwichtenberg~\cite{troelstra2000basic}.\<close>

lemma
  shows BotL_canonical[intro!]: "\<bottom>,\<Gamma>\<Rightarrow>\<Delta>"
    and Ax_canonical[intro!]: "Atom k,\<Gamma> \<Rightarrow> Atom k,\<Delta>"
  by (meson SCp.intros union_single_eq_member)+

lemma lem1: "x \<noteq> y \<Longrightarrow> x, M = y,N \<longleftrightarrow> x \<in># N \<and> M = y,(N - {#x#})"
  by (metis (no_types, lifting) add_eq_conv_ex add_mset_remove_trivial add_mset_remove_trivial_eq)

text\<open>This is here to deal with a technical problem: the way the simplifier uses @{thm add_mset_commute} is really suboptimal for the unification of SC rules.\<close>

lemma sc_insertion_ordering[simp]:
  "NO_MATCH (I\<^bold>\<rightarrow>J) H \<Longrightarrow> H,F\<^bold>\<rightarrow>G,S = F\<^bold>\<rightarrow>G,H,S"
  "NO_MATCH (I\<^bold>\<rightarrow>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<or>J) H \<Longrightarrow> H,F\<^bold>\<or>G,S = F\<^bold>\<or>G,H,S"
  "NO_MATCH (I\<^bold>\<rightarrow>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<or>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<and>J) H \<Longrightarrow> H,F\<^bold>\<and>G,S = F\<^bold>\<and>G,H,S"
  "NO_MATCH (I\<^bold>\<rightarrow>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<or>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<and>J) H \<Longrightarrow> NO_MATCH (\<^bold>\<not>J) H \<Longrightarrow> H,\<^bold>\<not>G,S = \<^bold>\<not>G,H,S"
  "NO_MATCH (I\<^bold>\<rightarrow>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<or>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<and>J) H \<Longrightarrow> NO_MATCH (\<^bold>\<not>J) H \<Longrightarrow> NO_MATCH (\<bottom>) H \<Longrightarrow> H,\<bottom>,S = \<bottom>,H,S"
  "NO_MATCH (I\<^bold>\<rightarrow>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<or>J) H \<Longrightarrow> NO_MATCH (I\<^bold>\<and>J) H \<Longrightarrow> NO_MATCH (\<^bold>\<not>J) H \<Longrightarrow> NO_MATCH (\<bottom>) H \<Longrightarrow> NO_MATCH (Atom k) H \<Longrightarrow> H,Atom l,S = Atom l,H,S"
  (* I have decided that \<bottom> and atoms should be pulled outwards with the lowest priorities. this may not always be smart. *)
  by simp_all

lemma shows
     inR1: "\<Gamma> \<Rightarrow> G, H, \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> H, G, \<Delta>"
 and inL1: "G, H, \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> H, G, \<Gamma> \<Rightarrow> \<Delta>"
 and inR2: "\<Gamma> \<Rightarrow> F, G, H, \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> G, H, F, \<Delta>"
 and inL2: "F, G, H, \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> G, H, F, \<Gamma> \<Rightarrow> \<Delta>" by(simp_all add: add_mset_commute)
lemmas SCp_swap_applies[elim!,intro] = inL1 inL2 inR1 inR2

lemma NotL_inv: "Not F, \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> F,\<Delta>"
proof(induction "Not F, \<Gamma>" \<Delta> arbitrary: \<Gamma> rule: SCp.induct)
  case (NotL \<Gamma>' G \<Delta>) thus ?case by(cases "Not F = Not G") (auto intro!: SCp.intros(3-) dest!: multi_member_split simp: lem1 lem2)
qed (auto intro!: SCp.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2)

lemma AndL_inv: "And F G, \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> F,G,\<Gamma> \<Rightarrow> \<Delta>"
proof(induction "And F G, \<Gamma>" \<Delta> arbitrary: \<Gamma> rule: SCp.induct)
  case (AndL F' G' \<Gamma>' \<Delta>) thus ?case
    by(cases "And F G = And F' G'";
       auto intro!: SCp.intros(3-) dest!: multi_member_split simp: lem1 lem2;
       metis add_mset_commute)
qed (auto intro!: SCp.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2 inL2)

lemma OrL_inv:
  assumes "Or F G, \<Gamma> \<Rightarrow> \<Delta>"
  shows "F,\<Gamma> \<Rightarrow> \<Delta> \<and> G,\<Gamma> \<Rightarrow> \<Delta>"
proof(insert assms, induction "Or F G, \<Gamma>" \<Delta> arbitrary: \<Gamma> rule: SCp.induct)
  case (OrL F' \<Gamma>' \<Delta> G') thus ?case
    by(cases "Or F G = Or F' G'";
       auto intro!: SCp.intros(3-) dest!: multi_member_split simp: lem1 lem2;
       blast)
qed (fastforce intro!: SCp.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2)+

lemma ImpL_inv:
  assumes "Imp F G, \<Gamma> \<Rightarrow> \<Delta>"
  shows "\<Gamma> \<Rightarrow> F,\<Delta> \<and> G,\<Gamma> \<Rightarrow> \<Delta>"
proof(insert assms, induction "Imp F G, \<Gamma>" \<Delta> arbitrary: \<Gamma> rule: SCp.induct)
  case (ImpL \<Gamma>' F' \<Delta> G') thus ?case
    by(cases "Or F G = Or F' G'"; (* oops, I didn't pay attention and used the wrong constructor\<dots> doesn't matter! *)
       auto intro!: SCp.intros(3-) dest!: multi_member_split simp: lem1 lem2;
       blast)
qed (fastforce intro!: SCp.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2)+

lemma ImpR_inv:
  assumes "\<Gamma> \<Rightarrow> Imp F G,\<Delta>"
  shows "F,\<Gamma> \<Rightarrow> G,\<Delta>"
proof(insert assms, induction \<Gamma> "Imp F G, \<Delta>" arbitrary: \<Delta> rule: SCp.induct)
  case (ImpR  F' \<Gamma> G' \<Delta>') thus ?case
    by(cases "Or F G = Or F' G'";
       auto intro!: SCp.intros(3-) dest!: multi_member_split simp: lem1 lem2;
       blast)
qed (fastforce intro!: SCp.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2)+

lemma AndR_inv:
shows "\<Gamma> \<Rightarrow> And F G, \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> F, \<Delta> \<and> \<Gamma> \<Rightarrow> G, \<Delta>"
proof(induction \<Gamma> "And F G, \<Delta>" arbitrary: \<Delta> rule: SCp.induct)
  case (AndR  \<Gamma> F' \<Delta>' G') thus ?case
    by(cases "Or F G = Or F' G'";
       auto intro!: SCp.intros(3-) dest!: multi_member_split simp: lem1 lem2;
       blast)
qed (fastforce intro!: SCp.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2)+

lemma OrR_inv: "\<Gamma> \<Rightarrow> Or F G, \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> F,G,\<Delta>"
proof(induction \<Gamma> "Or F G, \<Delta>" arbitrary: \<Delta> rule: SCp.induct)
  case (OrR  \<Gamma> F' G' \<Delta>') thus ?case
    by(cases "Or F G = Or F' G'";
       auto intro!: SCp.intros(3-) dest!: multi_member_split simp: lem1 lem2;
       metis add_mset_commute)
qed (fastforce intro!: SCp.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2)+

lemma NotR_inv: "\<Gamma> \<Rightarrow> Not F, \<Delta> \<Longrightarrow> F,\<Gamma> \<Rightarrow> \<Delta>"
proof(induction \<Gamma> "Not F, \<Delta>" arbitrary: \<Delta> rule: SCp.induct)
  case (NotR  G \<Gamma> \<Delta>') thus ?case
    by(cases "Not F = Not G";
       auto intro!: SCp.intros(3-) dest!: multi_member_split simp: lem1 lem2;
       metis add_mset_commute)
qed (fastforce intro!: SCp.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2)+

lemma weakenL: "\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> F,\<Gamma> \<Rightarrow> \<Delta>"
  by(induction rule: SCp.induct)
    (auto intro!: SCp.intros(3-) intro: SCp.intros(1,2))

lemma weakenR: "\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> F,\<Delta> "
  by(induction rule: SCp.induct)
    (auto intro!: SCp.intros(3-) intro: SCp.intros(1,2))

lemma weakenL_set: "\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> F + \<Gamma> \<Rightarrow> \<Delta>"
  by(induction F; simp add: weakenL)
lemma weakenR_set: "\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> F + \<Delta>"
  by(induction F; simp add: weakenR)

lemma extended_Ax: "\<Gamma> \<inter># \<Delta> \<noteq> {#} \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
proof -
  assume "\<Gamma> \<inter># \<Delta> \<noteq> {#}"
  then obtain W where "W \<in># \<Gamma>" "W \<in># \<Delta>" by force
  then show ?thesis proof(induction W arbitrary: \<Gamma> \<Delta>)
    case (Not W)
    from Not.prems obtain \<Gamma>' \<Delta>' where [simp]: "\<Gamma> = Not W,\<Gamma>'" "\<Delta> = Not W,\<Delta>'" by (metis insert_DiffM)
    have "W \<in># W,\<Gamma>'" "W \<in># W,\<Delta>'" by simp_all
    from Not.IH[OF this] obtain n where "W, \<Gamma>' \<Rightarrow> W, \<Delta>'" by presburger
    hence "Not W, \<Gamma>' \<Rightarrow> Not W, \<Delta>'" using SCp.intros(3,4) add_mset_commute by metis
    thus "\<Gamma> \<Rightarrow> \<Delta>" by auto
  next
    case (And G H)
    from And.prems obtain \<Gamma>' \<Delta>' where [simp]: "\<Gamma> = And G H,\<Gamma>'" "\<Delta> = And G H,\<Delta>'" by (metis insert_DiffM)
    have "G \<in># G, H, \<Gamma>'" "G \<in># G, \<Delta>'" by simp_all
    with And.IH(1) have IH1: "G, H, \<Gamma>' \<Rightarrow> G, \<Delta>'" .
    have "H \<in># G, H, \<Gamma>'" "H \<in># H, \<Delta>'" by simp_all
    with And.IH(2) have IH2: "G, H, \<Gamma>' \<Rightarrow> H, \<Delta>'" .
    from IH1 IH2 have "G, H, \<Gamma>' \<Rightarrow> G, \<Delta>'" "G, H, \<Gamma>' \<Rightarrow> H, \<Delta>'" by fast+
    thus "\<Gamma> \<Rightarrow> \<Delta>" using SCp.intros(5,6) by fastforce
  next
    case (Or G H)
    case (Imp G H)
    text\<open>analogously\<close> (*<*)
  next
    case (Or G H)
    from Or.prems obtain \<Gamma>' \<Delta>' where [simp]: "\<Gamma> = Or G H,\<Gamma>'" "\<Delta> = Or G H,\<Delta>'" by (metis insert_DiffM)
    with Or.IH show ?case using SCp.intros(7,8)[where 'a='a] by fastforce
  next
    case (Imp G H)
    from Imp.prems obtain \<Gamma>' \<Delta>' where [simp]: "\<Gamma> = Imp G H,\<Gamma>'" "\<Delta> = Imp G H,\<Delta>'" by (metis insert_DiffM)
    from Imp.IH have "G, \<Gamma>' \<Rightarrow> G, H, \<Delta>'" "H, G, \<Gamma>' \<Rightarrow> H, \<Delta>'" by simp_all
    thus ?case by(auto intro!: SCp.intros(3-))
  (*>*)
  qed (auto intro: SCp.intros)
qed

lemma Bot_delR: "\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>-{#\<bottom>#}"
proof(induction rule: SCp.induct)
  case BotL
  thus ?case by (simp add: SCp.BotL)
next
  case Ax
  thus ?case
    by (metis SCp.Ax diff_union_swap formula.distinct(1) insert_DiffM union_single_eq_member)
next
  case NotL
  thus ?case
    by (metis SCp.NotL diff_single_trivial diff_union_swap2)
next
  case NotR
  thus ?case by(simp add: SCp.NotR)
next
  case AndL
  thus ?case by (simp add: SCp.AndL)
next
  case AndR
  thus ?case
    by (metis SCp.AndR diff_single_trivial diff_union_swap diff_union_swap2 formula.distinct(13))
next
  case OrL
  thus ?case by(simp add: SCp.OrL)
next
  case OrR
  thus ?case
    by (metis SCp.OrR diff_single_trivial diff_union_swap2 formula.distinct(15) insert_iff set_mset_add_mset_insert)
next
  case ImpL
  thus ?case by (metis SCp.ImpL diff_single_trivial diff_union_swap2)
next
  case ImpR
  thus ?case
    by (metis SCp.ImpR diff_single_trivial diff_union_swap diff_union_swap2 formula.distinct(17))
qed
corollary Bot_delR_simp: "\<Gamma> \<Rightarrow> \<bottom>,\<Delta> = \<Gamma> \<Rightarrow> \<Delta>"
  using Bot_delR weakenR by fastforce

end