(* Victor B. F. Gomes, University of Cambridge
   Martin Kleppmann, University of Cambridge
   Dominic P. Mulligan, University of Cambridge
   Alastair R. Beresford, University of Cambridge
*)

section\<open>Strong Eventual Consistency\<close>

text\<open>In this section we formalise the notion of strong eventual consistency.
     We do not make any assumptions about networks or data structures; instead,
     we use an abstract model of operations that may be reordered, and we reason about
    the properties that those operations must satisfy.
    We then provide concrete implementations of that abstract model in later sections.\<close>

theory
  Convergence
imports
  Util
begin

text\<open>The \emph{happens-before} relation, as introduced by \cite{Lamport:1978jq}, captures
     causal dependencies between operations. It can be defined in terms of sending and receiving
     messages on a network.
     However, for now, we keep it abstract, our only restriction on the happens-before relation is
     that it must be a \emph{strict partial order},
     that is, it must be irreflexive and transitive, which implies that it is also antisymmetric.
     We describe the state of a node using an abstract type variable.
     To model state changes, we assume the existence of an \emph{interpretation} function \isa{interp}
     which lifts an operation into a \emph{state transformer}---a function that either maps
     an old state to a new state, or fails.\<close>

locale happens_before = preorder hb_weak hb
  for hb_weak :: "'a \<Rightarrow> 'a \<Rightarrow> bool"  (infix "\<preceq>" 50)
  and hb :: "'a \<Rightarrow> 'a \<Rightarrow> bool"       (infix "\<prec>" 50) +
  fixes interp :: "'a \<Rightarrow> 'b \<rightharpoonup> 'b" ("\<langle>_\<rangle>" [0] 1000)
begin

(*************************************************************************)
subsection\<open>Concurrent operations\<close>
(*************************************************************************)

text\<open>We say that two operations $x$ and $y$ are \emph{concurrent}, written
    $\isa{x} \mathbin{\isasymparallel} \isa{y}$, whenever one does not happen before the other:
    $\neg (\isa{x} \prec \isa{y})$ and $\neg (\isa{y} \prec \isa{x})$.\<close>

definition concurrent :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<parallel>" 50) where
  "s1 \<parallel> s2 \<equiv> \<not> (s1 \<prec> s2) \<and> \<not> (s2 \<prec> s1)"

lemma concurrentI [intro!]: "\<not> (s1 \<prec> s2) \<Longrightarrow> \<not> (s2 \<prec> s1) \<Longrightarrow> s1 \<parallel> s2"
  by (auto simp: concurrent_def)

lemma concurrentD1 [dest]: "s1 \<parallel> s2 \<Longrightarrow> \<not> (s1 \<prec> s2)"
  by (auto simp: concurrent_def)

lemma concurrentD2 [dest]: "s1 \<parallel> s2 \<Longrightarrow> \<not> (s2 \<prec> s1)"
  by (auto simp: concurrent_def)

lemma concurrent_refl [intro!, simp]: "s \<parallel> s"
  by (auto simp: concurrent_def)

lemma concurrent_comm: "s1 \<parallel> s2 \<longleftrightarrow> s2 \<parallel> s1"
  by (auto simp: concurrent_def)

definition concurrent_set :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" where
  "concurrent_set x xs \<equiv> \<forall>y \<in> set xs. x \<parallel> y"

lemma concurrent_set_empty [simp, intro!]:
  "concurrent_set x []"
  by (auto simp: concurrent_set_def)

lemma concurrent_set_ConsE [elim!]:
  assumes "concurrent_set a (x#xs)"
      and "concurrent_set a xs \<Longrightarrow> concurrent x a \<Longrightarrow> G"
    shows "G"
  using assms by (auto simp: concurrent_set_def)

lemma concurrent_set_ConsI [intro!]:
  "concurrent_set a xs \<Longrightarrow> concurrent a x \<Longrightarrow> concurrent_set a (x#xs)"
  by (auto simp: concurrent_set_def)

lemma concurrent_set_appendI [intro!]:
  "concurrent_set a xs \<Longrightarrow> concurrent_set a ys \<Longrightarrow> concurrent_set a (xs@ys)"
  by (auto simp: concurrent_set_def)

lemma concurrent_set_Cons_Snoc [simp]:
  "concurrent_set a (xs@[x]) = concurrent_set a (x#xs)"
  by (auto simp: concurrent_set_def)

(*************************************************************************)
subsection\<open>Happens-before consistency\<close>
(*************************************************************************)

text\<open>The purpose of the happens-before relation is to require that some operations must be applied
     in a particular order, while allowing concurrent operations to be reordered with respect to each other.
     We assume that each node applies operations in some sequential order (a standard assumption
     for distributed algorithms), and so we can model the execution history of a node as a list of operations.\<close>

inductive hb_consistent :: "'a list \<Rightarrow> bool" where
  [intro!]: "hb_consistent []" |
  [intro!]: "\<lbrakk> hb_consistent xs; \<forall>x \<in> set xs. \<not> y \<prec> x \<rbrakk> \<Longrightarrow> hb_consistent (xs @ [y])"

text\<open>As a result, whenever two operations $\isa{x}$ and $\isa{y}$ appear in a hb-consistent list,
     and $\isa{x}\prec\isa{y}$, then $\isa{x}$ must appear before $\isa{y}$ in the list.
     However, if $\isa{x}\mathbin{\isasymparallel}\isa{y}$, the operations can appear in the list
     in either order.\<close>

lemma "(x \<prec> y \<or> concurrent x y) = (\<not> y \<prec> x)"
  using less_asym by blast

lemma consistentI [intro!]:
  assumes "hb_consistent (xs @ ys)"
  and     "\<forall>x \<in> set (xs @ ys). \<not> z \<prec> x"
  shows   "hb_consistent (xs @ ys @ [z])"
  using assms hb_consistent.intros append_assoc by metis

inductive_cases  hb_consistent_elim [elim]:
  "hb_consistent []"
  "hb_consistent (xs@[y])"
  "hb_consistent (xs@ys)"
  "hb_consistent (xs@ys@[z])"

inductive_cases  hb_consistent_elim_gen:
  "hb_consistent zs"

lemma hb_consistent_append_D1 [dest]:
  assumes "hb_consistent (xs @ ys)"
  shows   "hb_consistent xs"
  using assms by(induction ys arbitrary: xs rule: List.rev_induct) auto

lemma hb_consistent_append_D2 [dest]:
  assumes "hb_consistent (xs @ ys)"
  shows   "hb_consistent ys"
  using assms by(induction ys arbitrary: xs rule: List.rev_induct) fastforce+

lemma hb_consistent_append_elim_ConsD [elim]:
  assumes "hb_consistent (y#ys)"
  shows   "hb_consistent ys"
  using assms hb_consistent_append_D2 by(metis append_Cons append_Nil)

lemma hb_consistent_remove1 [intro]:
  assumes "hb_consistent xs"
  shows   "hb_consistent (remove1 x xs)"
  using assms by (induction rule: hb_consistent.induct) (auto simp: remove1_append)

lemma hb_consistent_singleton [intro!]:
  shows "hb_consistent [x]"
  using hb_consistent.intros by fastforce

lemma hb_consistent_prefix_suffix_exists:
  assumes "hb_consistent ys"
          "hb_consistent (xs @ [x])"
          "{x} \<union> set xs = set ys"
          "distinct (x#xs)"
          "distinct ys"
  shows "\<exists>prefix suffix. ys = prefix @ x # suffix \<and> concurrent_set x suffix"
using assms proof (induction arbitrary: xs rule: hb_consistent.induct, simp)
  fix xs y ys
  assume IH: "(\<And>xs. hb_consistent (xs @ [x]) \<Longrightarrow>
               {x} \<union> set xs = set ys \<Longrightarrow>
               distinct (x # xs) \<Longrightarrow> distinct ys \<Longrightarrow>
             \<exists>prefix suffix. ys = prefix @ x # suffix \<and> concurrent_set x suffix) "
  assume assms: "hb_consistent ys" "\<forall>x\<in>set ys. \<not> hb y x"
                "hb_consistent (xs @ [x])"
                "{x} \<union> set xs = set (ys @ [y])"
                "distinct (x # xs)" "distinct (ys @ [y])"
  hence "x = y \<or> y \<in> set xs"
    using assms by auto
  moreover {
    assume "x = y"
    hence "\<exists>prefix suffix. ys @ [y] = prefix @ x # suffix \<and> concurrent_set x suffix"
      by force
  }
  moreover {
    assume y_in_xs: "y \<in> set xs"
    hence "{x} \<union> (set xs - {y}) = set ys"
      using assms by (auto intro: set_equality_technical)
    hence remove_y_in_xs: "{x} \<union> set (remove1 y xs) = set ys"
      using assms by auto
    moreover have "hb_consistent ((remove1 y xs) @ [x])"
      using assms hb_consistent_remove1 by force
    moreover have "distinct (x # (remove1 y xs))"
      using assms by simp
    moreover have "distinct ys"
      using assms by simp
    ultimately obtain prefix suffix where ys_split: "ys = prefix @ x # suffix \<and> concurrent_set x suffix"
      using IH by force
    moreover {
      have "concurrent x y"
        using assms y_in_xs remove_y_in_xs concurrent_def by blast
      hence "concurrent_set x (suffix@[y])"
        using ys_split by clarsimp
    }
    ultimately have "\<exists>prefix suffix. ys @ [y] = prefix @ x # suffix \<and> concurrent_set x suffix"
      by force
  }
  ultimately show "\<exists>prefix suffix. ys @ [y] = prefix @ x # suffix \<and> concurrent_set x suffix"
    by auto
qed

lemma hb_consistent_append [intro!]:
  assumes "hb_consistent suffix"
          "hb_consistent prefix"
          "\<And>s p. s \<in> set suffix \<Longrightarrow> p \<in> set prefix \<Longrightarrow> \<not> s \<prec> p"
  shows "hb_consistent (prefix @ suffix)"
using assms by (induction rule: hb_consistent.induct) force+

lemma hb_consistent_append_porder:
  assumes "hb_consistent (xs @ ys)"
          "x \<in> set xs"
          "y \<in> set ys"
  shows   "\<not> y \<prec> x"
using assms by (induction ys arbitrary: xs rule: rev_induct) force+

(*************************************************************************)
subsection\<open>Apply operations\<close>
(*************************************************************************)

text\<open>We can now define a function \isa{apply-operations} that composes an arbitrary list of operations
     into a state transformer. We first map \isa{interp} across the list to obtain a state transformer
     for each operation, and then collectively compose them using the Kleisli arrow composition combinator.\<close>

definition apply_operations :: "'a list \<Rightarrow> 'b \<rightharpoonup> 'b" where
  "apply_operations es \<equiv> foldl (\<rhd>) Some (map interp es)"

lemma apply_operations_empty [simp]: "apply_operations [] s = Some s"
  by(auto simp: apply_operations_def)

lemma apply_operations_Snoc [simp]:
  "apply_operations (xs@[x]) = (apply_operations xs) \<rhd> \<langle>x\<rangle>"
  by(auto simp add: apply_operations_def kleisli_def)

(*************************************************************************)
subsection\<open>Concurrent operations commute\<close>
(*************************************************************************)

text\<open>We say that two operations $\isa{x}$ and $\isa{y}$ \emph{commute} whenever
     $\langle\isa{x}\rangle \mathbin{\isasymrhd} \langle\isa{y}\rangle = \langle\isa{y}\rangle \mathbin{\isasymrhd} \langle\isa{x}\rangle$,
     i.e. when we can swap the order of the composition of their interpretations without changing
     the resulting state transformer. For our purposes, requiring that this property holds for
     \emph{all} pairs of operations is too strong. Rather, the commutation property is only required
     to hold for operations that are concurrent.\<close>

definition concurrent_ops_commute :: "'a list \<Rightarrow> bool" where
  "concurrent_ops_commute xs \<equiv>
    \<forall>x y. {x, y} \<subseteq> set xs \<longrightarrow> concurrent x y \<longrightarrow> \<langle>x\<rangle>\<rhd>\<langle>y\<rangle> = \<langle>y\<rangle>\<rhd>\<langle>x\<rangle>"

lemma concurrent_ops_commute_empty [intro!]: "concurrent_ops_commute []"
  by(auto simp: concurrent_ops_commute_def)

lemma concurrent_ops_commute_singleton [intro!]: "concurrent_ops_commute [x]"
  by(auto simp: concurrent_ops_commute_def)

lemma concurrent_ops_commute_appendD [dest]:
  assumes "concurrent_ops_commute (xs@ys)"
    shows "concurrent_ops_commute xs"
using assms by (auto simp: concurrent_ops_commute_def)

lemma concurrent_ops_commute_rearrange:
  "concurrent_ops_commute (xs@x#ys) = concurrent_ops_commute (xs@ys@[x])"
  by (clarsimp simp: concurrent_ops_commute_def)

lemma concurrent_ops_commute_concurrent_set:
  assumes "concurrent_ops_commute (prefix@suffix@[x])"
          "concurrent_set x suffix"
          "distinct (prefix @ x # suffix)"
  shows   "apply_operations (prefix @ suffix @ [x]) = apply_operations (prefix @ x # suffix)"
using assms proof(induction suffix arbitrary: rule: rev_induct, force)
  fix a xs
  assume IH: "concurrent_ops_commute (prefix @ xs @ [x]) \<Longrightarrow>
              concurrent_set x xs \<Longrightarrow> distinct (prefix @ x # xs) \<Longrightarrow>
              apply_operations (prefix @ xs @ [x]) = apply_operations (prefix @ x # xs)"
  assume assms: "concurrent_ops_commute (prefix @ (xs @ [a]) @ [x])"
                "concurrent_set x (xs @ [a])" "distinct (prefix @ x # xs @ [a])"
  hence ac_comm: "\<langle>a\<rangle> \<rhd> \<langle>x\<rangle> = \<langle>x\<rangle> \<rhd> \<langle>a\<rangle>"
    by (clarsimp simp: concurrent_ops_commute_def) blast
  have copc: "concurrent_ops_commute (prefix @ xs @ [x])"
    using assms by (clarsimp simp: concurrent_ops_commute_def) blast
  have "apply_operations ((prefix @ x # xs) @ [a]) = (apply_operations (prefix @ x # xs)) \<rhd> \<langle>a\<rangle>"
    by (simp del: append_assoc)
  also have "... = (apply_operations (prefix @ xs @ [x])) \<rhd> \<langle>a\<rangle>"
    using IH assms copc by auto
  also have "... = ((apply_operations (prefix @ xs)) \<rhd> \<langle>x\<rangle>) \<rhd> \<langle>a\<rangle>"
    by (simp add: append_assoc[symmetric] del: append_assoc)
  also have "... = (apply_operations (prefix @ xs)) \<rhd> (\<langle>a\<rangle> \<rhd> \<langle>x\<rangle>)"
    using ac_comm kleisli_comm_cong kleisli_assoc by simp
  finally show "apply_operations (prefix @ (xs @ [a]) @ [x]) = apply_operations (prefix @ x # xs @ [a])"
    by (metis Cons_eq_appendI append_assoc apply_operations_Snoc kleisli_assoc)
qed

(*************************************************************************)
subsection\<open>Abstract convergence theorem\<close>
(*************************************************************************)

text\<open>We can now state and prove our main theorem, $\isa{convergence}$.
     This theorem states that two hb-consistent lists of distinct operations, which are permutations
     of each other and in which concurrent operations commute, have the same interpretation.\<close>

theorem  convergence:
  assumes "set xs = set ys"
          "concurrent_ops_commute xs"
          "concurrent_ops_commute ys"
          "distinct xs"
          "distinct ys"
          "hb_consistent xs"
          "hb_consistent ys"
  shows   "apply_operations xs = apply_operations ys"
using assms proof(induction xs arbitrary: ys rule: rev_induct, simp)
  case assms: (snoc x xs)
  then obtain prefix suffix where ys_split: "ys = prefix @ x # suffix \<and> concurrent_set x suffix"
    using hb_consistent_prefix_suffix_exists by fastforce
  moreover hence *: "distinct (prefix @ suffix)" "hb_consistent xs"
    using assms by auto
  moreover {
    have "hb_consistent prefix" "hb_consistent suffix"
      using ys_split assms hb_consistent_append_D2 hb_consistent_append_elim_ConsD by blast+
    hence "hb_consistent (prefix @ suffix)"
      by (metis assms(8) hb_consistent_append hb_consistent_append_porder list.set_intros(2) ys_split)
  }
  moreover have **: "concurrent_ops_commute (prefix @ suffix @ [x])"
    using assms ys_split by (clarsimp simp: concurrent_ops_commute_def)
  moreover hence "concurrent_ops_commute (prefix @ suffix)"
    by (force simp del: append_assoc simp add: append_assoc[symmetric])
  ultimately have "apply_operations xs = apply_operations (prefix@suffix)"
    using assms by simp (metis Diff_insert_absorb Un_iff * concurrent_ops_commute_appendD set_append)
  moreover have "apply_operations (prefix@suffix @ [x]) = apply_operations (prefix@x # suffix)"
    using ys_split assms ** concurrent_ops_commute_concurrent_set by force
  ultimately show ?case
    using ys_split by (force simp: append_assoc[symmetric] simp del: append_assoc)
qed

corollary convergence_ext:
  assumes "set xs = set ys"
          "concurrent_ops_commute xs"
          "concurrent_ops_commute ys"
          "distinct xs"
          "distinct ys"
          "hb_consistent xs"
          "hb_consistent ys"
  shows   "apply_operations xs s = apply_operations ys s"
  using convergence assms by metis
end

subsection\<open>Convergence and progress\<close>

text\<open>Besides convergence, another required property of SEC is \emph{progress}: if a valid operation
     was issued on one node, then applying that operation on other nodes must also succeed---that is,
     the execution must not become stuck in an error state.
     Although the type signature of the interpretation function allows operations to fail, we need to
     prove that in all $\isa{hb-consistent}$ network behaviours such failure never actually occurs.
     We capture the combined requirements in the $\isa{strong-eventual-consistency}$ locale,
     which extends $\isa{happens-before}$.\<close>

locale strong_eventual_consistency = happens_before +
  fixes op_history :: "'a list \<Rightarrow> bool"
    and initial_state :: "'b"
  assumes causality:     "op_history xs \<Longrightarrow> hb_consistent xs"
  assumes distinctness:  "op_history xs \<Longrightarrow> distinct xs"
  assumes commutativity: "op_history xs \<Longrightarrow> concurrent_ops_commute xs"
  assumes no_failure:    "op_history(xs@[x]) \<Longrightarrow> apply_operations xs initial_state = Some state \<Longrightarrow> \<langle>x\<rangle> state \<noteq> None"
  assumes trunc_history: "op_history(xs@[x]) \<Longrightarrow> op_history xs"
begin

theorem sec_convergence:
  assumes "set xs = set ys"
          "op_history xs"
          "op_history ys"
  shows   "apply_operations xs = apply_operations ys"
  by (meson assms convergence causality commutativity distinctness)

theorem sec_progress:
  assumes "op_history xs"
  shows   "apply_operations xs initial_state \<noteq> None"
using assms proof(induction xs rule: rev_induct, simp)
  case (snoc x xs)
  have "apply_operations xs initial_state \<noteq> None"
    using snoc.IH snoc.prems trunc_history kleisli_def bind_def by blast
  moreover have "apply_operations (xs @ [x]) = apply_operations xs \<rhd> \<langle>x\<rangle>"
    by simp
  ultimately show ?case
    using no_failure snoc.prems by (clarsimp simp add: kleisli_def split: bind_splits)
qed

end
end


(*  Title:      HOL/Datatype_Examples/Stream_Processor.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2014

Stream processors---a syntactic representation of continuous functions on streams.
*)

section \<open>Stream Processors---A Syntactic Representation of Continuous Functions on Streams\<close>

theory Stream_Processor
imports "~~/src/HOL/Library/Stream" "~~/src/HOL/Library/BNF_Axiomatization"
begin

declare [[typedef_overloaded]]

section \<open>Continuous Functions on Streams\<close>

datatype ('a, 'b, 'c) sp\<^sub>\<mu> =
  Get "'a \<Rightarrow> ('a, 'b, 'c) sp\<^sub>\<mu>"
| Put "'b" "'c"

codatatype ('a, 'b) sp\<^sub>\<nu> =
  In (out: "('a, 'b, ('a, 'b) sp\<^sub>\<nu>) sp\<^sub>\<mu>")

primrec run\<^sub>\<mu> :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> 'a stream \<Rightarrow> ('b \<times> 'c) \<times> 'a stream" where
  "run\<^sub>\<mu> (Get f) s = run\<^sub>\<mu> (f (shd s)) (stl s)"
| "run\<^sub>\<mu> (Put b sp) s = ((b, sp), s)"

primcorec run\<^sub>\<nu> :: "('a, 'b) sp\<^sub>\<nu> \<Rightarrow> 'a stream \<Rightarrow> 'b stream" where
  "run\<^sub>\<nu> sp s = (let ((h, sp), s) = run\<^sub>\<mu> (out sp) s in h ## run\<^sub>\<nu> sp s)"

primcorec copy :: "('a, 'a) sp\<^sub>\<nu>" where
  "copy = In (Get (\<lambda>a. Put a copy))"

lemma run\<^sub>\<nu>_copy: "run\<^sub>\<nu> copy s = s"
  by (coinduction arbitrary: s) simp

text \<open>
To use the function package for the definition of composition the
wellfoundedness of the subtree relation needs to be proved first.
\<close>

definition "sub \<equiv> {(f a, Get f) | a f. True}"

lemma subI[intro]: "(f a, Get f) \<in> sub"
  unfolding sub_def by blast

lemma wf_sub[simp, intro]: "wf sub"
proof (rule wfUNIVI)
  fix P  :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> bool" and x
  assume "\<forall>x. (\<forall>y. (y, x) \<in> sub \<longrightarrow> P y) \<longrightarrow> P x"
  hence I: "\<And>x. (\<forall>y. (\<exists>a f. y = f a \<and> x = Get f) \<longrightarrow> P y) \<Longrightarrow> P x" unfolding sub_def by blast
  show "P x" by (induct x) (auto intro: I)
qed

function
  sp\<^sub>\<mu>_comp :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> ('d, 'a, ('d, 'a) sp\<^sub>\<nu>) sp\<^sub>\<mu> \<Rightarrow> ('d, 'b, 'c \<times> ('d, 'a) sp\<^sub>\<nu>) sp\<^sub>\<mu>"
  (infixl "o\<^sub>\<mu>" 65)
where
  "Put b sp o\<^sub>\<mu> fsp = Put b (sp, In fsp)"
| "Get f o\<^sub>\<mu> Put b sp = f b o\<^sub>\<mu> out sp"
| "Get f o\<^sub>\<mu> Get g = Get (\<lambda>a. Get f o\<^sub>\<mu> g a)"
by pat_completeness auto
termination by (relation "lex_prod sub sub") auto

primcorec sp\<^sub>\<nu>_comp (infixl "o\<^sub>\<nu>" 65) where
  "out (sp o\<^sub>\<nu> sp') = map_sp\<^sub>\<mu> id (\<lambda>(sp, sp'). sp o\<^sub>\<nu> sp') (out sp o\<^sub>\<mu> out sp')"

lemma run\<^sub>\<nu>_sp\<^sub>\<nu>_comp: "run\<^sub>\<nu> (sp o\<^sub>\<nu> sp') = run\<^sub>\<nu> sp o run\<^sub>\<nu> sp'"
proof (rule ext, unfold comp_apply)
  fix s
  show "run\<^sub>\<nu> (sp o\<^sub>\<nu> sp') s = run\<^sub>\<nu> sp (run\<^sub>\<nu> sp' s)"
  proof (coinduction arbitrary: sp sp' s)
    case Eq_stream
    show ?case
    proof (induct "out sp" "out sp'" arbitrary: sp sp' s rule: sp\<^sub>\<mu>_comp.induct)
      case (1 b sp'')
      show ?case by (auto simp add: 1[symmetric])
    next
      case (2 f b sp'')
      from 2(1)[of "In (f b)" sp''] show ?case by (simp add: 2(2,3)[symmetric])
    next
      case (3 f h)
      from 3(1)[of _ "shd s" "In (h (shd s))", OF 3(2)] show ?case by (simp add: 3(2,3)[symmetric])
    qed
  qed
qed

text \<open>Alternative definition of composition using primrec instead of function\<close>

primrec sp\<^sub>\<mu>_comp2R  where
  "sp\<^sub>\<mu>_comp2R f (Put b sp) = f b (out sp)"
| "sp\<^sub>\<mu>_comp2R f (Get h) = Get (sp\<^sub>\<mu>_comp2R f o h)"

primrec sp\<^sub>\<mu>_comp2 (infixl "o\<^sup>*\<^sub>\<mu>" 65) where
  "Put b sp o\<^sup>*\<^sub>\<mu> fsp = Put b (sp, In fsp)"
| "Get f o\<^sup>*\<^sub>\<mu> fsp = sp\<^sub>\<mu>_comp2R (op o\<^sup>*\<^sub>\<mu> o f) fsp"

primcorec sp\<^sub>\<nu>_comp2 (infixl "o\<^sup>*\<^sub>\<nu>" 65) where
  "out (sp o\<^sup>*\<^sub>\<nu> sp') = map_sp\<^sub>\<mu> id (\<lambda>(sp, sp'). sp o\<^sup>*\<^sub>\<nu> sp') (out sp o\<^sup>*\<^sub>\<mu> out sp')"

lemma run\<^sub>\<nu>_sp\<^sub>\<nu>_comp2: "run\<^sub>\<nu> (sp o\<^sup>*\<^sub>\<nu> sp') = run\<^sub>\<nu> sp o run\<^sub>\<nu> sp'"
proof (rule ext, unfold comp_apply)
  fix s
  show "run\<^sub>\<nu> (sp o\<^sup>*\<^sub>\<nu> sp') s = run\<^sub>\<nu> sp (run\<^sub>\<nu> sp' s)"
  proof (coinduction arbitrary: sp sp' s)
    case Eq_stream
    show ?case
    proof (induct "out sp" arbitrary: sp sp' s)
      case (Put b sp'')
      show ?case by (auto simp add: Put[symmetric])
    next
      case (Get f)
      then show ?case
      proof (induct "out sp'" arbitrary: sp sp' s)
        case (Put b sp'')
        from Put(2)[of "In (f b)" sp''] show ?case by (simp add: Put(1,3)[symmetric])
      next
        case (Get h)
        from Get(1)[OF _ Get(3,4), of "In (h (shd s))"] show ?case by (simp add: Get(2,4)[symmetric])
      qed
    qed
  qed
qed

text \<open>The two definitions are equivalent\<close>

lemma sp\<^sub>\<mu>_comp_sp\<^sub>\<mu>_comp2[simp]: "sp o\<^sub>\<mu> sp' = sp o\<^sup>*\<^sub>\<mu> sp'"
  by (induct sp sp' rule: sp\<^sub>\<mu>_comp.induct) auto

(*will be provided by the package*)
lemma sp\<^sub>\<mu>_rel_map_map[unfolded vimage2p_def, simp]:
  "rel_sp\<^sub>\<mu> R1 R2 (map_sp\<^sub>\<mu> f1 f2 sp) (map_sp\<^sub>\<mu> g1 g2 sp') =
  rel_sp\<^sub>\<mu> (BNF_Def.vimage2p f1 g1 R1) (BNF_Def.vimage2p f2 g2 R2) sp sp'"
by (tactic \<open>
  let
    val ks = 1 upto 2;
    val ctxt = @{context};
  in
    BNF_Tactics.unfold_thms_tac ctxt
      @{thms sp\<^sub>\<mu>.rel_compp sp\<^sub>\<mu>.rel_conversep sp\<^sub>\<mu>.rel_Grp vimage2p_Grp} THEN
    HEADGOAL (EVERY' [resolve_tac ctxt [iffI],
      resolve_tac ctxt @{thms relcomppI},
      resolve_tac ctxt @{thms GrpI},
      resolve_tac ctxt [refl],
      resolve_tac ctxt [CollectI],
      BNF_Util.CONJ_WRAP' (K (resolve_tac ctxt @{thms subset_UNIV})) ks,
      resolve_tac ctxt @{thms relcomppI}, assume_tac ctxt,
      resolve_tac ctxt @{thms conversepI},
      resolve_tac ctxt @{thms GrpI},
      resolve_tac ctxt [refl],
      resolve_tac ctxt [CollectI],
      BNF_Util.CONJ_WRAP' (K (resolve_tac ctxt @{thms subset_UNIV})) ks,
      REPEAT_DETERM o eresolve_tac ctxt @{thms relcomppE conversepE GrpE},
      hyp_subst_tac ctxt,
      assume_tac ctxt])
  end
\<close>)

lemma sp\<^sub>\<mu>_rel_self: "\<lbrakk>op = \<le> R1; op = \<le> R2\<rbrakk> \<Longrightarrow> rel_sp\<^sub>\<mu> R1 R2 x x"
  by (erule (1) predicate2D[OF sp\<^sub>\<mu>.rel_mono]) (simp only: sp\<^sub>\<mu>.rel_eq)

lemma sp\<^sub>\<nu>_comp_sp\<^sub>\<nu>_comp2: "sp o\<^sub>\<nu> sp' = sp o\<^sup>*\<^sub>\<nu> sp'"
  by (coinduction arbitrary: sp sp') (auto intro!: sp\<^sub>\<mu>_rel_self)

section \<open>Generalization to an Arbitrary BNF as Codomain\<close>

bnf_axiomatization ('a, 'b) F for map: F

notation BNF_Def.convol ("\<langle>(_,/ _)\<rangle>")

definition \<theta> :: "('p,'a) F * 'b \<Rightarrow> ('p,'a * 'b) F" where
  "\<theta> xb = F id \<langle>id, \<lambda> a. (snd xb)\<rangle> (fst xb)"

(* The strength laws for \<theta>: *)
lemma \<theta>_natural: "F id (map_prod f g) o \<theta> = \<theta> o map_prod (F id f) g"
  unfolding \<theta>_def F.map_comp comp_def id_apply convol_def map_prod_def split_beta fst_conv snd_conv ..

definition assl :: "'a * ('b * 'c) \<Rightarrow> ('a * 'b) * 'c" where
  "assl abc = ((fst abc, fst (snd abc)), snd (snd abc))"

lemma \<theta>_rid: "F id fst o \<theta> = fst"
  unfolding \<theta>_def F.map_comp F.map_id comp_def id_apply convol_def fst_conv sym[OF id_def] ..

lemma \<theta>_assl: "F id assl o \<theta> = \<theta> o map_prod \<theta> id o assl"
  unfolding assl_def \<theta>_def F.map_comp comp_def id_apply convol_def map_prod_def split fst_conv snd_conv ..

datatype ('a, 'b, 'c) spF\<^sub>\<mu> = GetF "'a \<Rightarrow> ('a, 'b, 'c) spF\<^sub>\<mu>" | PutF "('b,'c) F"
codatatype ('a, 'b) spF\<^sub>\<nu> = InF (outF: "('a, 'b, ('a, 'b) spF\<^sub>\<nu>) spF\<^sub>\<mu>")

codatatype 'b JF = Ctor (dtor: "('b, 'b JF) F")

(* Definition of run for an arbitrary final coalgebra as codomain: *)

primrec
  runF\<^sub>\<mu> :: "('a, 'b, ('a, 'b) spF\<^sub>\<nu>) spF\<^sub>\<mu> \<Rightarrow> 'a stream \<Rightarrow> (('b, ('a, 'b) spF\<^sub>\<nu>) F) \<times> 'a stream"
where
  "runF\<^sub>\<mu> (GetF f) s = (runF\<^sub>\<mu> o f) (shd s) (stl s)"
| "runF\<^sub>\<mu> (PutF x) s = (x, s)"

primcorec runF\<^sub>\<nu> :: "('a, 'b) spF\<^sub>\<nu> \<Rightarrow> 'a stream \<Rightarrow> 'b JF" where
  "runF\<^sub>\<nu> sp s = (let (x, s) = runF\<^sub>\<mu> (outF sp) s in Ctor (F id (\<lambda> sp. runF\<^sub>\<nu> sp s) x))"

end


theory Lehmer
imports
  Main
  Multiplicative_Group
begin

section {* Lehmer's Theorem *}
text_raw {* \label{sec:lehmer} *}

text {*
  In this section we prove Lehmer's Theorem~\cite{lehmer1927fermat_converse} and its converse.
  These two theorems characterize a necessary and complete criterion for primality. This criterion
  is the basis of the Lucas-Lehmer primality test and the primality certificates of
  Pratt~\cite{pratt1975certificate}.
*}

(* XXX add to Isabelle! *)
lemma prime_phi:
  assumes  "2 \<le> p" "phi p = (nat p) - 1" shows "prime p"
proof -
  have "{x. 0 < x \<and> x < p \<and> coprime x p} = {1..p - 1}"
    using assms unfolding phi_def by (intro card_seteq) fastforce+
  then have cop: "\<And>x. x \<in> {1..p - 1} \<Longrightarrow> coprime x p" by blast

  { fix x assume *: "1 < x" "x < p" and "x dvd p"
    from * have "coprime x p" by (auto intro: cop)
    with `x dvd p` `1 < x` have "False" by auto }
  then show ?thesis unfolding prime_int_code
    using `2 \<le> p` by fastforce
qed

lemma coprime_power_nat:
  fixes a b :: nat assumes "0 < n" shows "coprime a (b ^ n) \<longleftrightarrow> coprime a b"
  using assms
proof (induct n)
  case (Suc n) then show ?case
    by (cases n) (simp_all add: coprime_mul_eq_nat del: One_nat_def)
qed simp

lemma mod_1_coprime_nat:
  fixes a b :: nat assumes "0 < n" "[a ^ n = 1] (mod b)" shows "coprime a b"
proof -
  from assms have "coprime (a ^ n) b" by (simp cong: cong_gcd_eq_nat)
  with `0 < n` show ?thesis
    by (simp add: coprime_power_nat gcd_commute_nat del: One_nat_def)
qed

lemma phi_leq: "phi x \<le> nat x - 1"
proof -
  have "phi x \<le> card {1..x - 1}"
    unfolding phi_def by (rule card_mono) auto
  then show ?thesis by simp
qed

lemma phi_nonzero:
  assumes "2 \<le> x" shows "phi x \<noteq> 0"
proof -
  have "coprime ((x - 1) + 1) (x - 1)"
    by (simp only: coprime_plus_one_int)
  with assms have "card {x - 1} \<le> phi x"
    unfolding phi_def by (intro card_mono bounded_set1_int) (simp add: gcd_commute_int)
    (* XXX: We need bounded_set1_int here because of the finite_Collect simproc) *)
  then show ?thesis by auto
qed

text {*
  This is a weak variant of Lehmer's theorem: All numbers less then @{term "p - 1 :: nat"}
  must be considered.
*}

lemma lehmers_weak_theorem:
  assumes "2 \<le> p"
  assumes min_cong1: "\<And>x. 0 < x \<Longrightarrow> x < p - 1 \<Longrightarrow> [a ^ x \<noteq> 1] (mod p)"
  assumes cong1: "[a ^ (p - 1) = 1] (mod p)"
  shows "prime p"
proof -
  from `2 \<le> p` cong1 have "coprime a p"
    by (intro mod_1_coprime_nat[of "p - 1"]) auto
  then have "[a ^ phi (int p) = 1] (mod p)"
    by (intro euler_theorem[transferred]) auto
  then have "phi (int p) \<ge> p - 1 \<or> phi (int p) = 0"
    using min_cong1[of "phi (int p)"] by fastforce
  then have "prime (int p)" using phi_leq[transferred, of p] phi_nonzero `2 \<le> p`
    by (auto intro: prime_phi)
  then show ?thesis by (simp add: prime_int_def)
qed

lemma prime_factors_elem:
  fixes n :: nat assumes "1 < n" shows "\<exists>p. p \<in> prime_factors n"
  using assms by (cases "prime n") (auto simp: prime_factors_altdef2_nat prime_factor_nat)

lemma prime_factors_dvd_nat:
  fixes p :: nat assumes "x \<in> prime_factors p" shows "x dvd p"
  using assms by (cases "0 < p") (auto simp: prime_factors_altdef2_nat)

lemma cong_pow_1_nat:
  fixes a b :: nat assumes "[a = 1] (mod b)" shows "[a ^ x = 1] (mod b)"
by (metis assms cong_exp_nat power_one)

lemma cong_gcd_eq_1_nat:
  fixes a b :: nat
  assumes "0 < m" and cong_props: "[a ^ m = 1] (mod b)" "[a ^ n = 1] (mod b)"
  shows "[a ^ gcd m n = 1] (mod b)"
proof -
  obtain c d where gcd: "m * c = n * d + gcd m n" using bezout_nat[of m n] `0 < m`
    by auto
  have cong_m: "[a ^ (m * c) = 1] (mod b)" and cong_n: "[a ^ (n * d) = 1] (mod b)"
    using cong_props by (simp_all only: cong_pow_1_nat power_mult)
  have "[1 * a ^ gcd m n = a ^ (n * d) * a ^ gcd m n] (mod b)"
    using cong_n[simplified cong_sym_eq_nat] by (simp only: power_one cong_scalar_nat)
  also have "[a ^ (n * d) * a ^ gcd m n = a ^ (m * c)] (mod b)"
    using gcd by (simp add: power_add)
  also have "[a ^ (m * c) = 1] (mod b)" using cong_m by simp
  finally show "[a ^ gcd m n = 1] (mod b)" by simp
qed

lemma One_leq_div:
  fixes a b :: nat assumes "a dvd b" "a < b" shows "1 < b div a"
by (metis assms dvd_mult_div_cancel gr_implies_not0 less_Suc0 linorder_not_le mult_1_right
  mult_zero_right nat_1 order_le_neq_trans order_refl transfer_nat_int_numerals(2))

theorem lehmers_theorem:
  assumes "2 \<le> p"
  assumes pf_notcong1: "\<And>x. x \<in> prime_factors (p - 1) \<Longrightarrow> [a ^ ((p - 1) div x) \<noteq> 1] (mod p)"
  assumes cong1: "[a ^ (p - 1) = 1] (mod p)"
  shows "prime p"
proof cases
  assume "[a = 1] (mod p)" with `2 \<le>p` pf_notcong1 show ?thesis
    by (metis cong_pow_1_nat less_diff_conv linorder_neqE_nat linorder_not_less
      one_add_one prime_factors_elem two_is_prime_nat)
next
  assume A_notcong_1: "[a \<noteq> 1] (mod p)"
  { fix x assume "0 < x" "x < p - 1"
    have "[a ^ x \<noteq> 1] (mod p)"
    proof
      assume "[a ^ x = 1] (mod p)"
      then have gcd_cong_1: "[a ^ gcd x (p - 1) = 1] (mod p)"
        by (rule cong_gcd_eq_1_nat[OF `0 < x` _ cong1])

      have "gcd x (p - 1) = p - 1"
      proof (rule ccontr)
        assume "\<not>?thesis"
        then have gcd_p1: "gcd x (p - 1) dvd (p - 1)" "gcd x (p - 1) < p - 1"
          using gcd_le2_nat[of "p - 1" x] `2 \<le> p` by (simp, linarith)

        def c \<equiv> "(p - 1) div (gcd x (p - 1))"
        then have p_1_eq: "p - 1 = gcd x (p - 1) * c" unfolding c_def using gcd_p1
          by (metis dvd_mult_div_cancel)

        from gcd_p1 have "1 < c" unfolding c_def by (rule One_leq_div)
        then obtain q where q_pf: "q \<in> prime_factors c"
          using prime_factors_elem by auto
        then have "q dvd c" by (auto simp: prime_factors_dvd_nat)

        have "q \<in> prime_factors (p - 1)" using q_pf `1 < c` `2 \<le> p`
          by (subst p_1_eq) (simp add: prime_factors_product_nat)
        moreover
        have "[a ^ ((p - 1) div q) = 1] (mod p)"
          by (subst p_1_eq,subst dvd_div_mult_self[OF `q dvd c`,symmetric])
             (simp del: One_nat_def add: power_mult gcd_cong_1 cong_pow_1_nat)
        ultimately
        show False using pf_notcong1 by metis
      qed
      then show False using `x < p - 1`
        by (metis `0 < x` gcd_le1_nat gr_implies_not0 linorder_not_less)
    qed
  }
  with lehmers_weak_theorem[OF `2 \<le> p` _ cong1] show ?thesis by metis
qed

text {*
  The converse of Lehmer's theorem is also true.
*}

lemma converse_lehmer_weak:
 assumes prime_p:"prime p"
 shows "\<exists> a. [a^(p - 1) = 1] (mod p) \<and> (\<forall> x . 0 < x \<longrightarrow> x \<le> p - 2 \<longrightarrow> [a^x \<noteq> 1] (mod p))
             \<and> a > 0 \<and> a < p"
 proof -
   have "p \<ge> 2" by (rule prime_ge_2_nat[OF prime_p])
   obtain a where a:"a \<in> {1 .. p - 1} \<and> {1 .. p - 1} = {a^i mod p | i . i \<in> UNIV}"
    using residue_prime_mult_group_has_gen[OF prime_p] by blast
  {
   { fix x::nat assume x:"0 < x \<and> x \<le> p - 2 \<and> [a^x = 1] (mod p)"
     have "{a^i mod p| i. i \<in> UNIV} = {a^i mod p | i. 0 < i \<and> i \<le> x}"
     proof
      show "{a ^ i mod p | i. 0 < i \<and> i \<le> x} \<subseteq> {a ^ i mod p | i. i \<in> UNIV}" by blast
      { fix y assume y:"y \<in> {a^i mod p| i . i \<in> UNIV}"
        then obtain i where i:"y = a^i mod p" by auto
        def q \<equiv> "i div x" def r \<equiv> "i mod x"
        have "i = q*x + r" by (simp add: r_def q_def)
        hence y_q_r:"y = (((a ^ (q*x)) mod p) * ((a ^ r) mod p)) mod p"
          by (simp add: i power_add mod_mult_eq[symmetric])
        have "a ^ (q*x) mod p = (a ^ x mod p) ^ q mod p"
          by (simp add: power_mod nat_mult_commute power_mult[symmetric])
        hence y_r:"y = a ^ r mod p" using `p\<ge>2` x by (simp add: cong_nat_def y_q_r)
        have "y \<in> {a ^ i mod p | i. 0 < i \<and> i \<le> x}"
        proof (cases)
          assume "r = 0"
            hence "y = a^x mod p" using `p\<ge>2` x by (simp add: cong_nat_def y_r)
            thus ?thesis using x by blast
          next
          assume "r \<noteq> 0"
            thus ?thesis using x by (auto simp add: y_r r_def)
        qed
      }
      thus " {a ^ i mod p|i. i \<in> UNIV} \<subseteq> {a ^ i mod p | i. 0 < i \<and> i \<le> x}" by auto
    qed
    note X = this

    have "p - 1 = card {1 .. p - 1}" by auto
    also have "{1 .. p - 1} = {a^i mod p | i. 1 \<le> i \<and> i \<le> x}" using X a by auto
    also have "\<dots> = (\<lambda> i. a^i mod p) ` {1..x}" by auto
    also have "card \<dots> \<le> p - 2"
      using Finite_Set.card_image_le[of "{1..x}" "\<lambda> i. a^i mod p"] x by auto
    finally have False using `2 \<le> p` by arith
   }
   hence "\<forall> x . 0 < x \<longrightarrow> x \<le> p - 2 \<longrightarrow> [a^x \<noteq> 1] (mod p)" by auto
 } note a_is_gen = this
 {
    assume "a>1"
    have "\<not> p dvd a "
    proof (rule ccontr)
      assume "\<not> \<not> p dvd a"
      hence "p dvd a" by auto
      have "p \<le> a" using dvd_nat_bounds[OF _ `p dvd a`] a by simp
      thus False using `a>1` a by force
    qed
    hence "coprime a p" using prime_imp_coprime_nat[OF prime_p]  by (simp add: gcd_commute_nat)
    hence "coprime (int a) (int p)" by (simp add: transfer_int_nat_gcd(1))
    have "phi (int p) = p - 1" by (simp add: prime_int_def phi_prime prime_p)
    hence "[a^(p - 1) = 1] (mod p)" using euler_theorem[OF _ `coprime (int a) (int p)`]
      by (simp add: of_nat_power transfer_int_nat_cong[symmetric])
  }
  hence "[a^(p - 1) = 1] (mod p)" using a by fastforce
  thus ?thesis using a_is_gen a by auto
 qed

theorem converse_lehmer:
 assumes prime_p:"prime(p)"
 shows "\<exists> a . [a^(p - 1) = 1] (mod p) \<and>
              (\<forall> q. q \<in> prime_factors (p - 1) \<longrightarrow> [a^((p - 1) div q) \<noteq> 1] (mod p))
              \<and> a > 0 \<and> a < p"
 proof -
  have "p \<ge> 2" by (rule prime_ge_2_nat[OF prime_p])
  obtain a where a:"[a^(p - 1) = 1] (mod p) \<and> (\<forall> x . 0 < x \<longrightarrow> x \<le> p - 2 \<longrightarrow> [a^x \<noteq> 1] (mod p))
                    \<and> a > 0 \<and> a < p"
    using converse_lehmer_weak[OF prime_p] by blast
  { fix q assume q:"q \<in> prime_factors (p - 1)"
    hence "0 < q \<and> q \<le> p - 1" using `p\<ge>2` by (auto simp add: dvd_nat_bounds prime_factors_dvd_nat)
    hence "(p - 1) div q \<ge> 1" using div_le_mono[of "q" "p - 1" q] div_self[of q] by linarith
    have "q \<ge> 2" using q by (simp add: prime_factors_prime_nat prime_ge_2_nat)
    hence "(p - 1) div q < p - 1" using `p \<ge> 2` by simp
    hence "[a^((p - 1) div q) \<noteq> 1] (mod p)" using a `(p - 1) div q \<ge> 1` by fastforce
  }
  thus ?thesis using a by auto
 qed

end


theory WeakTrioid
  imports OrderTheory
begin

text {*
  Weak trioid is a double dioid wihtout the following axiom:
    mult_annir: "x\<cdot>0 = 0"
*}

class idem_monoid = comm_monoid_add + order +
  assumes leq_def: "x \<le> y \<longleftrightarrow> x + y = y"
  and strict_leq_def: "x < y \<longleftrightarrow> x \<le> y \<and> \<not>(y \<le> x)"

context idem_monoid
begin

lemma add_idem: "x + x = x" using iffD1[OF leq_def order_refl] .

(* Join semilattice *)
lemma ex_lub_dioid: "is_lub (x + y) {x, y}"
  apply (simp add: is_lub_def is_ub_def leq_def)
  by (metis add_assoc add_commute add_idem)

subclass join_semilattice
  by (unfold_locales, metis ex_lub_dioid)

lemma join_plus_equiv [simp]: "x \<squnion> y = x + y"
  by (metis ex_lub_dioid join_def lub_is_lub)

lemma order_prop: "(x \<le> y) \<longleftrightarrow> (\<exists>z. (x + z = y))"
  by (metis add_assoc add_idem leq_def)

lemma add_ub1 [simp]: "x \<le> x + y"
  by (metis add_assoc add_idem leq_def)

lemma add_ub2 [simp]: "y \<le> x + y"
  by (metis add_assoc add_commute add_idem leq_def)

lemma add_lub_var: "x \<le> z \<longrightarrow> y \<le> z \<longrightarrow> x + y \<le> z"
  by (metis add_assoc leq_def)

lemma add_lub: "x + y \<le> z \<longleftrightarrow> x \<le> z \<and> y \<le> z"
  by (metis add_assoc add_ub2 leq_def)

lemma add_iso: "x \<le> y \<longrightarrow> x + z \<le> y + z"
  by (metis add_lub leq_def order_refl)

lemma add_iso_var: "x \<le> y \<longrightarrow> u \<le> v \<longrightarrow> x + u \<le> y + v"
  by (metis add_commute add_iso add_lub)

lemma zero_least [simp]: "0 \<le> x"
  by (metis add_0_left join_plus_equiv leq_def_join)

lemma zero_unique [simp]: "x \<le> 0 \<longleftrightarrow> x = 0"
  by (metis zero_least eq_iff)

lemma no_trivial_inverse: "x \<noteq> 0 \<longrightarrow> \<not>(\<exists>y. x + y = 0)"
  by (metis zero_unique order_prop)

end

class weak_dioid = idem_monoid + one +
  fixes mult :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<cdot>" 70)
  assumes mult_assoc: "(x\<cdot>y)\<cdot>z = x\<cdot>(y\<cdot>z)"
  and mult_onel: "1\<cdot>x = x"
  and mult_oner: "x\<cdot>1 = x"
  and mult_distl: "x\<cdot>(y+z) = x\<cdot>y+x\<cdot>z"
  and mult_distr: "(x+y)\<cdot>z = x\<cdot>z+y\<cdot>z"
  and mult_annil: "0\<cdot>x = 0"

begin

(* Mult operator *)
lemma mult_isor: "x \<le> y \<Longrightarrow> z\<cdot>x \<le> z\<cdot>y"
  by (metis leq_def mult_distl)

lemma mult_isol: "x \<le> y \<Longrightarrow> x\<cdot>z \<le> y\<cdot>z"
  by (metis leq_def mult_distr)

lemma mult_isol_var: "u \<le> x \<and> v \<le> y \<longrightarrow> u \<cdot> v \<le> x \<cdot> y"
  by (metis mult_isol mult_isor order_trans)

lemma mult_double_iso: "x \<le> y \<longrightarrow> w \<cdot> x \<cdot> z \<le> w \<cdot> y \<cdot> z"
  by (metis mult_isol mult_isor)

lemma subdistl: "x\<cdot>z \<le> (x + y)\<cdot>z"
  by (metis mult_distr order_prop)

lemma subdistr: "z\<cdot>x \<le> z\<cdot>(x + y)"
  by (metis mult_distl order_prop)

end

class par_dioid = idem_monoid + one +
  fixes par :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<parallel>" 69)
  assumes par_assoc: "(x\<parallel>y)\<parallel>z = x\<parallel>(y\<parallel>z)"
  and par_comm: "x\<parallel>y = y\<parallel>x"
  and par_distl: "x\<parallel>(y+z) = x\<parallel>y+x\<parallel>z"
  and par_unitl: "1\<parallel>x = x"
  and par_annil: "0\<parallel>x = 0"
begin

(* Parallel operator *)
lemma par_comml: "y\<parallel>(x\<parallel>z) = x\<parallel>(y\<parallel>z)"
  by (metis par_assoc par_comm)

lemma par_distr: "(x+y)\<parallel>z = x\<parallel>z+y\<parallel>z"
  by (metis par_comm par_distl)

lemma par_isol: "x \<le> y \<Longrightarrow> x\<parallel>z \<le> y\<parallel>z"
  by (metis leq_def par_distr)

lemma par_isor: "x \<le> y \<Longrightarrow> z\<parallel>x \<le> z\<parallel>y"
  by (metis leq_def par_distl)

lemma par_unitr: "x\<parallel>1 = x"
  by (metis par_comm par_unitl)

lemma par_annir: "x\<parallel>0 = 0"
  by (metis par_annil par_comm)

lemma par_subdistl: "x\<parallel>z \<le> (x + y)\<parallel>z"
  by (metis order_prop par_distr)

lemma par_subdistr: "z\<parallel>x \<le> z\<parallel>(x + y)"
  by (metis par_comm par_subdistl)

lemma par_double_iso: "w \<le> x \<and> y \<le> z \<longrightarrow> w\<parallel>y \<le> x\<parallel>z"
  by (metis order_trans par_isol par_isor)

end

no_notation
  Transitive_Closure.trancl ("(_\<^sup>+)" [1000] 999) and
  Transitive_Closure.rtrancl ("(_\<^sup>*)" [1000] 999)

(* Weak Kleene Algebra, formed from a weak dioid *)
class wka = weak_dioid +
  fixes star :: "'a \<Rightarrow> 'a" ("_\<^sup>*" [101] 100)
  assumes star_unfoldl: "1 + x\<cdot>x\<^sup>* \<le> x\<^sup>*"
  and star_unfoldr: "1 + x\<^sup>*\<cdot>x \<le> x\<^sup>*"
  and star_inductl: "z + x\<cdot>y \<le> y \<longrightarrow> x\<^sup>*\<cdot>z \<le> y"
  and star_inductr: "z + y\<cdot>x \<le> y \<longrightarrow> z\<cdot>x\<^sup>* \<le> y"

begin

lemma star_ref: "1 \<le> x\<^sup>*"
  by (metis add_lub star_unfoldr)

lemma star_plus_one [simp]: "1 + x\<^sup>* = x\<^sup>*"
  by (metis leq_def star_ref)

lemma star_1l: "x\<cdot>x\<^sup>* \<le> x\<^sup>*"
  by (metis add_lub star_unfoldl)

lemma star_1r: "x\<^sup>*\<cdot>x \<le> x\<^sup>*"
  by (metis add_lub star_unfoldr)

lemma star_trans_eq: "x\<^sup>*\<cdot>x\<^sup>* = x\<^sup>*"
  apply (rule antisym,metis add_commute eq_iff leq_def star_1l star_inductl)
  by (metis mult_onel star_plus_one subdistl)

lemma star_trans: "x\<^sup>* \<cdot> x\<^sup>* \<le> x\<^sup>*"
  by (metis eq_refl star_trans_eq)

lemma star_inductl_var: "x\<cdot>y \<le> y \<longrightarrow> x\<^sup>*\<cdot>y \<le> y"
  by (metis add_commute eq_refl leq_def star_inductl)

lemma star_inductr_var: "y\<cdot>x \<le> y \<longrightarrow> y\<cdot>x\<^sup>* \<le> y"
  by (metis add_commute eq_iff leq_def star_inductr)

lemma star_inductl_var_eq:  "x \<cdot> y = y \<longrightarrow> x\<^sup>* \<cdot> y \<le> y"
  by (metis eq_iff star_inductl_var)

lemma star_inductl_var_eq2: "y = x \<cdot> y \<longrightarrow> y = x\<^sup>* \<cdot> y"
  by (metis antisym mult_onel star_inductl_var_eq star_plus_one subdistl)

lemma star_inductl_one: "1 + x \<cdot> y \<le> y \<longrightarrow> x\<^sup>* \<le> y"
  by (metis mult_oner star_inductl)

lemma star_inductl_star: "x \<cdot> y\<^sup>* \<le> y\<^sup>* \<longrightarrow> x\<^sup>* \<le> y\<^sup>*"
  by (metis add_lub star_inductl_one star_ref)

lemma star_inductl_eq:  "z + x \<cdot> y = y \<longrightarrow> x\<^sup>* \<cdot> z \<le> y"
  by (metis eq_iff star_inductl)

lemma star_subid: "x \<le> 1 \<longrightarrow> x\<^sup>* = 1"
  by (metis add_commute eq_iff leq_def mult_isol mult_onel star_inductl_one star_ref)

lemma star_one [simp]: "1\<^sup>* = 1"
  by (metis eq_refl star_subid)

lemma star_subdist:  "x\<^sup>* \<le> (x + y)\<^sup>*"
  by (metis order_trans star_1l star_inductl_star subdistl)

lemma star_subdist_var:  "x\<^sup>* + y\<^sup>* \<le> (x + y)\<^sup>*"
  by (metis add_commute add_lub star_subdist)

lemma star_iso: "x \<le> y \<Longrightarrow> x\<^sup>* \<le> y\<^sup>*"
  by (metis leq_def star_subdist)

lemma star_invol: "x\<^sup>* = (x\<^sup>*)\<^sup>*"
  by (metis antisym mult_oner star_1r star_inductl_var_eq2 star_plus_one star_trans_eq subdistr)

lemma star2: "(1 + x)\<^sup>* = x\<^sup>*"
  apply(rule antisym, metis add_lub mult_oner order_trans star_1l star_invol star_iso star_plus_one subdistr)
  by (metis add_ub2 star_iso)

lemma sum_star_closure: "x \<le> z\<^sup>* \<and> y \<le> z\<^sup>* \<longrightarrow> x + y \<le> z\<^sup>*"
  by (metis add_lub)

lemma prod_star_closure: "x \<le> z\<^sup>* \<and> y \<le> z\<^sup>* \<longrightarrow> x \<cdot> y \<le> z\<^sup>*"
  by (metis mult_isol mult_isor order_trans star_trans_eq)

lemma star_star_closure: "x\<^sup>* \<le> z\<^sup>* \<longrightarrow> (x\<^sup>*)\<^sup>* \<le> z\<^sup>*"
  by (metis star_invol)

lemma star_closed_unfold: "x\<^sup>* = x \<longrightarrow> x = 1 + x \<cdot> x"
  by (metis star_plus_one star_trans_eq)

lemma star_ext: "x \<le> x\<^sup>*"
  by (metis mult_onel order_trans star_1r star_plus_one subdistl)

lemma star_sim1: "x\<cdot>z \<le> z\<cdot>y \<Longrightarrow> x\<^sup>*\<cdot>z \<le> z\<cdot>y\<^sup>*"
proof -
  assume assm: "x\<cdot>z \<le> z\<cdot>y"
  hence "(x\<cdot>z)\<cdot>y\<^sup>* \<le> (z\<cdot>y)\<cdot>y\<^sup>*"
    by (metis assm mult_isol)
  hence "(x\<cdot>z)\<cdot>y\<^sup>* \<le> z\<cdot>y\<^sup>*"
    by (metis mult_assoc mult_isor order_trans star_1l)
  hence "z + (x\<cdot>z)\<cdot>y\<^sup>* \<le> z\<cdot>y\<^sup>*"
    by (metis add_lub_var mult_oner star_plus_one subdistr)
  thus ?thesis
    by (metis mult_assoc star_inductl)
qed

lemma star_sim2: "z\<cdot>x \<le> y\<cdot>z \<Longrightarrow> z\<cdot>x\<^sup>* \<le> y\<^sup>*\<cdot>z"
proof -
  assume assm: "z\<cdot>x \<le> y\<cdot>z"
  hence "y\<^sup>*\<cdot>(z\<cdot>x) \<le> y\<^sup>*\<cdot>(y\<cdot>z)"
    by (metis assm mult_isor)
  hence "y\<^sup>*\<cdot>(z\<cdot>x) \<le> y\<^sup>*\<cdot>z"
    by (metis mult_assoc mult_isol mult_isor order_trans star_ext star_trans_eq)
  hence "z + y\<^sup>*\<cdot>(z\<cdot>x) \<le> y\<^sup>*\<cdot>z"
    by (metis add_lub mult_onel star_plus_one subdistl)
  thus ?thesis
    by (metis mult_assoc star_inductr)
qed

lemma star_slide1: "(x\<cdot>y)\<^sup>*\<cdot>x \<le> x\<cdot>(y\<cdot>x)\<^sup>*"
  by (metis mult_assoc order_refl star_sim1)

lemma star_slide_var1: "x\<^sup>* \<cdot> x \<le> x \<cdot> x\<^sup>*"
  by (metis eq_refl star_sim1)

lemma star_unfoldl_eq: "x\<^sup>* = 1 + x\<cdot>x\<^sup>*"
  by (metis antisym add_iso_var mult_isor order_refl star_inductl_one star_unfoldl)

lemma star_rtc1_eq [simp]: "1 + x + x\<^sup>* \<cdot> x\<^sup>* = x\<^sup>*"
  by (metis add_assoc leq_def star_ext star_plus_one star_trans_eq)

lemma star_rtc1: "1 + x + x\<^sup>* \<cdot> x\<^sup>* \<le> x\<^sup>*"
  by (metis eq_refl star_rtc1_eq)

lemma star_rtc2: "1 + x \<cdot> x \<le> x \<longleftrightarrow> x = x\<^sup>*"
  by (metis antisym star_ext star_inductl_one star_plus_one star_trans_eq)

lemma star_rtc3: "1 + x \<cdot> x = x \<longleftrightarrow> x = x\<^sup>*"
  by (metis order_refl star_plus_one star_rtc2 star_trans_eq)

lemma star_rtc_least: "1 + x + y \<cdot> y \<le> y \<longrightarrow> x\<^sup>* \<le> y"
  by (metis add_commute add_lub leq_def mult_isol mult_onel star_iso star_rtc3)

lemma star_rtc_least_eq: "1 + x + y \<cdot> y = y \<longrightarrow> x\<^sup>* \<le> y"
  by (metis eq_refl star_rtc_least)

lemma star_subdist_var_1: "x \<le> (x + y)\<^sup>*"
  by (metis add_lub star_ext)

lemma star_subdist_var_2: "x \<cdot> y \<le> (x + y)\<^sup>*"
  by (metis add_lub prod_star_closure star_ext)

lemma star_subdist_var_3: "x\<^sup>* \<cdot> y\<^sup>* \<le> (x + y)\<^sup>*"
  by (metis add_commute prod_star_closure star_subdist)

lemma star_denest [simp]: "(x + y)\<^sup>* = (x\<^sup>* \<cdot> y\<^sup>*)\<^sup>*"
proof (rule antisym)
  have "x + y \<le> x\<^sup>* \<cdot> y\<^sup>*"
    by (metis add_lub_var mult_isol_var mult_onel mult_oner star_ext star_ref)
  thus "(x + y)\<^sup>* \<le> (x\<^sup>* \<cdot> y\<^sup>*)\<^sup>*"
    by (metis star_iso)
  have "x\<^sup>* \<cdot> y\<^sup>* \<le> (x + y)\<^sup>*"
    by (metis star_subdist_var_3)
  thus "(x\<^sup>* \<cdot> y\<^sup>*)\<^sup>* \<le> (x + y)\<^sup>*"
    by (metis star_invol star_iso)
qed

lemma star_sum_var [simp]: "(x\<^sup>* + y\<^sup>*)\<^sup>* = (x + y)\<^sup>*"
  by (metis star_denest star_invol)

lemma star_denest_var [simp]: "(x + y)\<^sup>* = x\<^sup>* \<cdot> (y \<cdot> x\<^sup>*)\<^sup>*"
proof (rule antisym)
  have "1 \<le> x\<^sup>* \<cdot> (y \<cdot> x\<^sup>*)\<^sup>*"
    by (metis add_lub mult_onel star_plus_one subdistl)
  moreover have "x \<cdot> x\<^sup>* \<cdot> (y \<cdot> x\<^sup>*)\<^sup>* \<le> x\<^sup>* \<cdot> (y \<cdot> x\<^sup>*)\<^sup>*"
    by (metis mult_isol star_1l)
  moreover have "y \<cdot> x\<^sup>* \<cdot> (y \<cdot> x\<^sup>*)\<^sup>* \<le> x\<^sup>* \<cdot> (y \<cdot> x\<^sup>*)\<^sup>*"
    by (metis mult_isol_var mult_onel star_1l star_ref)
  hence "1 + (x + y) \<cdot> x\<^sup>* \<cdot> (y \<cdot> x\<^sup>*)\<^sup>* \<le> x\<^sup>* \<cdot> (y \<cdot> x\<^sup>*)\<^sup>*"
    by (metis (full_types) add_lub calculation(1) calculation(2) mult_distr)
  thus "(x + y)\<^sup>* \<le> x\<^sup>* \<cdot> (y \<cdot> x\<^sup>*)\<^sup>*"
    by (metis mult_assoc star_inductl_one)
  have "(y \<cdot> x\<^sup>*)\<^sup>* \<le> (y\<^sup>* \<cdot> x\<^sup>*)\<^sup>*"
    by (metis mult_isol star_ext star_iso)
  moreover have "... = (x + y)\<^sup>*"
    by (metis add_commute star_denest)
  moreover have "x\<^sup>* \<le> (x + y)\<^sup>*"
    by (metis star_subdist)
  thus "x\<^sup>* \<cdot> (y \<cdot> x\<^sup>*)\<^sup>* \<le> (x + y)\<^sup>*"
    by (metis calculation prod_star_closure)
qed

lemma star_denest_var_2: "(x\<^sup>* \<cdot> y\<^sup>*)\<^sup>* = x\<^sup>* \<cdot> (y \<cdot> x\<^sup>*)\<^sup>*"
  by (metis star_denest star_denest_var)

lemma star_denest_var_3 [simp]: "x\<^sup>* \<cdot> (y\<^sup>* \<cdot> x\<^sup>*)\<^sup>* = (x\<^sup>* \<cdot> y\<^sup>*)\<^sup>*"
  by (metis star_denest star_denest_var star_invol)

lemma star_denest_var_4 [simp]: "(y\<^sup>* \<cdot> x\<^sup>*)\<^sup>* = (x\<^sup>* \<cdot> y\<^sup>*)\<^sup>*"
  by (metis add_commute star_denest)

lemma star_denest_var_5: "x\<^sup>* \<cdot> (y \<cdot> x\<^sup>*)\<^sup>* = y\<^sup>* \<cdot> (x \<cdot> y\<^sup>*)\<^sup>*"
  by (metis add_commute star_denest_var)

lemma star_unfoldr_eq: "1 + x\<^sup>*\<cdot>x = x\<^sup>*"
  by (smt mult_distl mult_distr mult_assoc mult_onel mult_oner star_unfoldl_eq star_inductl eq_iff star_unfoldr)

lemma star_slide: "(x\<cdot>y)\<^sup>*\<cdot>x = x\<cdot>(y\<cdot>x)\<^sup>*"
  by (smt add_commute mult_assoc star_unfoldr_eq star_slide1 mult_isor add_iso mult_isol mult_distl mult_oner mult_distr mult_onel star_unfoldl_eq eq_iff star_slide1)

lemma star_slide_var: "x\<^sup>*\<cdot>x = x\<cdot>x\<^sup>*"
  by (metis mult_onel mult_oner star_slide)

lemma star_prod_unfold [simp]: "1 + x \<cdot> (y \<cdot> x)\<^sup>* \<cdot> y = (x \<cdot> y)\<^sup>*"
  by (metis mult_assoc star_slide star_unfoldl_eq)

lemma star_sum_unfold_var [simp]: "1 + x\<^sup>* \<cdot> (x + y)\<^sup>* \<cdot> y\<^sup>* = (x + y)\<^sup>*"
  by (metis star_denest star_denest_var_3 star_denest_var_4 star_plus_one star_slide)

lemma star_sum_unfold [simp]: "x\<^sup>* + x\<^sup>* \<cdot> y \<cdot> (x + y)\<^sup>* = (x + y)\<^sup>*"
  by (metis mult_assoc mult_distl mult_oner star_denest_var star_prod_unfold star_slide)

lemma star_square: "(x \<cdot> x)\<^sup>* \<le> x\<^sup>*"
  by (metis (full_types) prod_star_closure star_ext star_invol star_iso)

lemma star_zero [simp]: "0\<^sup>* = 1"
  by (metis star_subid zero_least)

lemma star_sim3: "z \<cdot> x = y \<cdot> z \<longrightarrow> z \<cdot> x\<^sup>* = y\<^sup>* \<cdot> z"
  by (metis eq_iff star_sim1 star_sim2)

lemma star_sim4: "x \<cdot> y \<le>  y \<cdot> x \<longrightarrow> x\<^sup>* \<cdot> y\<^sup>* \<le> y\<^sup>* \<cdot> x\<^sup>*"
  by (metis star_sim1 star_sim2)

lemma star_inductr_eq: "z + y \<cdot> x = y \<longrightarrow> z \<cdot> x\<^sup>* \<le> y"
  by (metis eq_iff star_inductr)

lemma star_inductr_var_eq: "y \<cdot> x = y \<longrightarrow> y \<cdot> x\<^sup>* \<le> y"
  by (metis eq_iff star_inductr_var)

lemma star_inductr_var_eq2: "y \<cdot> x = y \<longrightarrow> y \<cdot> x\<^sup>* = y"
  by (metis mult_onel star_one star_sim3)

definition trancl :: "'a \<Rightarrow> 'a" ("_\<^sup>+" [101] 100) where
  "x\<^sup>+ \<equiv> x\<^sup>*\<cdot>x"

lemma trancl_ext: "x \<le> x\<^sup>+"
  by (metis mult_oner star_slide_var star_unfoldl_eq subdistr trancl_def)

lemma trancl_unfoldr: "x + x\<^sup>+\<cdot>x = x\<^sup>+"
  by (metis mult_assoc mult_distl mult_oner star_slide_var star_unfoldl_eq trancl_def)

lemma trancl_inductr: "z + y\<cdot>x \<le> y \<Longrightarrow> z\<cdot>x\<^sup>+ \<le> y"
  by (metis add_ub2 mult_distl order_trans star_inductr star_slide_var star_unfoldl_eq trancl_def)

lemma trancl_unfoldl: "x + x\<cdot>x\<^sup>+ = x\<^sup>+"
  by (metis mult_assoc star_slide_var trancl_def trancl_unfoldr)

lemma trancl_inductl: "z + x\<cdot>y \<le> y \<Longrightarrow> x\<^sup>+\<cdot>z \<le> y"
  by (metis add_lub mult_assoc order_prop star_inductl subdistr trancl_def)

lemma star_trancl: "x\<^sup>+ = x \<cdot> x\<^sup>*"
  by (metis star_slide_var trancl_def)

lemma star_trancl2: "x\<^sup>* = 1 + x\<^sup>+"
  by (metis star_trancl star_unfoldl_eq)

end

class weak_trioid = weak_dioid + par_dioid + wka

class weak_cka = weak_trioid +
  assumes exchange: "(w\<parallel>x)\<cdot>(y\<parallel>z) \<le> (w\<cdot>y)\<parallel>(x\<cdot>z)"
begin

lemma mult_incl: "x\<cdot>y \<le> x\<parallel>y"
  by (metis par_unitl par_unitr exchange mult_onel mult_oner)

lemma small_exchange1: "(x\<parallel>y)\<cdot>z \<le> x\<parallel>(y\<cdot>z)"
  by (metis exchange mult_oner par_unitl)

lemma small_exchange2: "x\<cdot>(y\<parallel>z) \<le> (x\<cdot>y)\<parallel>z"
  by (metis exchange mult_onel par_comm par_unitl)

end

end


theory Tut11
  imports "HOL-IMP.Complete_Lattice"
begin

instantiation list :: (order) order
begin

definition less_eq_list :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "(xs:: 'a list) \<le> ys = (length xs = length ys \<and> (\<forall>i. i < length xs \<longrightarrow> xs ! i \<le> ys ! i))"

definition less_list :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "(xs:: 'a list) < ys = (xs \<le> ys \<and> \<not> ys \<le> xs)"

instance
proof (standard, goal_cases)
  case (1 x y)
  then show ?case unfolding less_list_def ..
next
  case (2 x)
  then show ?case unfolding less_eq_list_def by simp
next
  case (3 x y z)
  then show ?case unfolding less_eq_list_def by fastforce
next
  case (4 x y)
  hence "\<forall>i < length x. x ! i = y ! i"
    using less_eq_list_def by fastforce
  with 4 show ?case unfolding less_eq_list_def by(auto intro: nth_equalityI)
qed

end

unbundle lattice_syntax

definition Inf_list :: "nat \<Rightarrow> ('a::complete_lattice) list set \<Rightarrow> 'a list"  where
  "Inf_list n S = map (\<lambda>i. \<Sqinter> ((\<lambda>xs. xs ! i) ` S)) [0..<n]"

interpretation
  Complete_Lattice "{xs. length xs = n}" "Inf_list n" for n
proof (standard, goal_cases)
  case (1 A a)
  then show ?case unfolding less_eq_list_def Inf_list_def by (auto intro: Inf_lower)
next
  case (2 b A)
  then show ?case unfolding less_eq_list_def Inf_list_def by (auto intro: Inf_greatest)
next
  case (3 A)
  then show ?case unfolding Inf_list_def by auto
qed

lemma
    fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f"
  assumes "x\<^sub>0 \<le> f x\<^sub>0"
  shows "\<Squnion> {(f^^i) x\<^sub>0 |i. i\<in>\<nat>} \<le> \<Squnion> {(f^^(i+1)) x\<^sub>0 | i. i\<in>\<nat>}"
proof (rule Sup_least)
  fix x assume "x \<in> {(f ^^ i) x\<^sub>0 |i. i \<in> \<nat>}"
  then obtain i where "x = (f ^^ i) x\<^sub>0" by blast
  show "x \<le> \<Squnion> {(f ^^ (i + 1)) x\<^sub>0 |i. i \<in> \<nat>}"
  proof (cases i)
    case 0
    have "x = x\<^sub>0" by (simp add: "0" \<open>x = (f ^^ i) x\<^sub>0\<close>)
    with assms have "x \<le> f x\<^sub>0" by simp
    also have "... \<le> \<Squnion> {(f ^^ (i + 1)) x\<^sub>0 |i. i \<in> \<nat>}"
    proof (rule Sup_upper)
      have "x\<^sub>0 = (f ^^ i) x\<^sub>0" using \<open>x = x\<^sub>0\<close> \<open>x = (f ^^ i) x\<^sub>0\<close> by simp
      then show "f x\<^sub>0 \<in> {(f ^^ (i + 1)) x\<^sub>0 |i. i \<in> \<nat>}" unfolding Nats_def apply auto by metis
    qed
    then show ?thesis using calculation by auto
  next
    case (Suc n)
    show ?thesis
    proof (intro Sup_upper)
      show "x \<in> {(f ^^ (i + 1)) x\<^sub>0 |i. i \<in> \<nat>}"
        unfolding Nats_def
        using Suc \<open>x = (f ^^ i) x\<^sub>0\<close> by fastforce
    qed
  qed
qed

end