(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory factorial
imports "CParser.CTranslation" "$L4V_ARCH/imports/MachineWords"
begin

declare hrs_simps [simp add]
declare sep_conj_ac [simp add]

consts free_pool :: "nat \<Rightarrow> heap_assert"

primrec
  fac :: "nat \<Rightarrow> machine_word"
where
  "fac 0 = 1"
| "fac (Suc n) = of_nat (Suc n) * fac n"

lemma fac_unfold:
  "unat n \<noteq> 0 \<Longrightarrow> fac (unat n) = n * fac (unat (n - 1))"
  apply(case_tac "unat n")
   apply simp
  apply(subst unat_minus_one)
   apply(simp only: unat_simps)
   apply(clarify)
   apply simp
  apply clarsimp
  apply(simp only: unat_simps)
  apply(subst mod_less)
   apply (fold len_of_addr_card)
   apply unat_arith
  apply (clarsimp simp: distrib_right split: unat_splits)
  done

primrec
  fac_list :: "nat \<Rightarrow> machine_word list"
where
  "fac_list 0 = [1]"
| "fac_list (Suc n) = fac (Suc n) # fac_list n"

lemma fac_list_length [simp]:
  "length (fac_list n) = n + 1"
  by (induct n) auto

lemma fac_list_unfold:
  "unat n \<noteq> 0 \<Longrightarrow> fac_list (unat n) = fac (unat n) # fac_list (unat (n - 1))"
  apply(case_tac "unat n")
   apply clarsimp
  apply(subst unat_minus_one)
   apply clarsimp+
  done

primrec
  sep_list :: "machine_word list \<Rightarrow> machine_word ptr \<Rightarrow> heap_assert"
where
  "sep_list [] p = (\<lambda>s. p=NULL \<and> \<box> s)"
| "sep_list (x#xs) p = (\<lambda>s. \<exists>j. ((p \<mapsto> x) \<and>\<^sup>* (p +\<^sub>p 1) \<mapsto> j \<and>\<^sup>*
      sep_list xs (Ptr j)) s)"

lemma sep_list_NULL [simp]:
  "sep_list xs NULL = (\<lambda>s. xs = [] \<and> \<box> s)"
  by (case_tac xs) auto

definition
  sep_fac_list :: "machine_word \<Rightarrow> machine_word ptr \<Rightarrow> heap_assert"
where
  "sep_fac_list n p \<equiv> sep_list (fac_list (unat n)) p"

lemma sep_fac_list_unfold:
  "((\<lambda>s. unat n \<noteq> 0 \<and> (\<exists>q. (p \<mapsto> fac (unat n) \<and>\<^sup>* (p +\<^sub>p 1) \<mapsto> q \<and>\<^sup>*
      sep_fac_list (n - 1) (Ptr q)) s)) \<and>\<^sup>* R) s \<Longrightarrow>
      (sep_fac_list n p \<and>\<^sup>* R) s"
  apply (erule sep_globalise)
  apply (simp add: sep_fac_list_def fac_list_unfold)
  done

lemma sep_fac_list_points:
  "sep_points (sep_fac_list n p) s \<Longrightarrow> (p \<hookrightarrow> fac (unat n)) s"
  apply(unfold sep_points_def)
  apply(subst sep_map'_unfold)
  apply(erule sep_conj_impl)
   apply(unfold sep_fac_list_def)
   apply(case_tac "unat n")
    apply simp
    apply(unfold sep_map'_old)
    apply(erule (1) sep_conj_impl)
    apply simp
   apply clarsimp
   apply(subst (asm) sep_conj_assoc [symmetric])+
   apply(erule sep_conj_impl)
    apply simp+
  done

external_file "factorial.c"
install_C_file memsafe "factorial.c"

thm factorial_global_addresses.factorial_body_def

lemma (in factorial_global_addresses) mem_safe_alloc:
  "mem_safe (\<acute>ret__ptr_to_unsigned_long :== PROC alloc()) \<Gamma>"
  apply(insert alloc_impl)
  apply(unfold alloc_body_def)
  apply(subst mem_safe_restrict)
  apply(rule intra_mem_safe)
   apply(simp_all add: restrict_map_def split: if_split_asm)
  apply(auto simp: whileAnno_def comp_def hrs_comm split_def mono_guard_def)
  done

lemma (in factorial_global_addresses) sep_frame_alloc:
  "\<lbrakk> \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace> \<acute>ret__ptr_to_unsigned_long :== PROC alloc() \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>;
      htd_ind f; htd_ind g; \<forall>s. htd_ind (g s) \<rbrakk> \<Longrightarrow>
      \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
              \<acute>ret__ptr_to_unsigned_long :== PROC alloc()
              \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
  unfolding sep_app_def
  by (rule sep_frame, auto intro!: mem_safe_alloc)

lemma (in alloc_spec) alloc_spec':
  shows "\<forall>\<sigma> k R f. factorial_global_addresses.\<Gamma> \<turnstile>
    \<lbrace>\<sigma>. ((\<lambda>x. free_pool k) ((\<lambda>x. undefined) \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
    \<acute>ret__ptr_to_unsigned_long :== PROC alloc()
    \<lbrace> ((\<lambda>p s. if k > 0 then (\<turnstile>\<^sub>s p \<and>\<^sup>* \<turnstile>\<^sub>s (p +\<^sub>p 1) \<and>\<^sup>*
        free_pool (k - 1)) s else (free_pool k) s \<and> p = NULL) \<acute>ret__ptr_to_unsigned_long
        \<and>\<^sup>* R (f \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
  apply clarify
  apply(insert alloc_spec)
  apply(rule_tac x=\<sigma> in spec)
  apply(rule sep_frame_alloc)
     apply(clarsimp simp: sep_app_def split: if_split_asm)
    apply simp+
  done

lemma (in factorial_global_addresses) mem_safe_free:
  "mem_safe (PROC free(\<acute>p)) \<Gamma>"
  apply(insert free_impl)
  apply(unfold free_body_def)
  apply(subst mem_safe_restrict)
  apply(auto simp: whileAnno_def)
  apply(rule intra_mem_safe)
   apply(auto simp: restrict_map_def split: if_split_asm)
  done

lemma (in factorial_global_addresses) sep_frame_free:
  "\<lbrakk> \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace> PROC free(\<acute>p) \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>;
      htd_ind f; htd_ind g; \<forall>s. htd_ind (g s) \<rbrakk> \<Longrightarrow>
      \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
              PROC free(\<acute>p)
              \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
  apply(simp only: sep_app_def)
  apply(rule sep_frame, auto intro!: mem_safe_free)
  done

lemma (in free_spec) free_spec':
  shows "\<forall>\<sigma> k R f. factorial_global_addresses.\<Gamma> \<turnstile>
    \<lbrace>\<sigma>. ((\<lambda>p. sep_cut' (ptr_val p) (2 * size_of TYPE(machine_word)) \<and>\<^sup>* free_pool k) \<acute>p  \<and>\<^sup>* R (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
    PROC free(\<acute>p)
    \<lbrace> ((\<lambda>x. free_pool (k + 1)) ((\<lambda>x. ()) \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (f \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
  apply clarify
  apply(insert free_spec)
  apply(rule_tac x=\<sigma> in spec)
  apply(rule sep_frame_free)
     apply(clarsimp simp: sep_app_def split: if_split_asm)
    apply simp+
  done

lemma double_word_sep_cut':
  "(p \<mapsto> x \<and>\<^sup>* (p +\<^sub>p 1) \<mapsto> y) s \<Longrightarrow> sep_cut' (ptr_val (p::machine_word ptr)) (2*machine_word_bytes) s"
apply(clarsimp simp: sep_conj_def sep_cut'_def dest!: sep_map_dom)
apply(subgoal_tac "{ptr_val p..+machine_word_bytes} \<subseteq> {ptr_val p..+(2*machine_word_bytes)}")
 apply(subgoal_tac "{ptr_val p+(of_nat machine_word_bytes)..+machine_word_bytes} \<subseteq> {ptr_val p..+(2*machine_word_bytes)}")
  apply rule
   apply (fastforce simp: ptr_add_def)
  apply clarsimp
  apply(drule intvlD)
  apply clarsimp
  apply(case_tac "k < machine_word_bytes")
   apply(erule intvlI)
  apply(erule notE)
  apply(clarsimp simp: intvl_def)
  apply(rule_tac x="k - machine_word_bytes" in exI)
  apply rule
   apply(simp only: unat_simps)
   apply(subst mod_less)
    apply(simp add: addr_card)
   apply (simp add: ptr_add_def addr_card)
  apply simp
 apply(clarsimp simp: intvl_def)
 apply(rule_tac x="machine_word_bytes+k" in exI)
 apply simp
apply(rule intvl_start_le)
apply simp
done

locale specs = factorial_global_addresses + alloc_spec + free_spec

lemma (in specs) factorial_spec:
  shows "factorial_spec"
  apply unfold_locales
  apply(hoare_rule HoarePartial.ProcRec1)
  apply (hoare_rule anno = "factorial_invs_body k" in HoarePartial.annotateI)
   prefer 2
   apply (simp add: whileAnno_def factorial_invs_body_def)
  apply(subst factorial_invs_body_def)
  apply(unfold sep_app_def)
  apply (vcg exspec=alloc_spec' exspec=free_spec')
    apply (fold lift_def)
    apply(clarsimp simp: sep_app_def)
    apply (rule conjI)
     apply clarsimp
     apply(rule_tac x=k in exI)
     apply(rule_tac x="\<lambda>p. \<box>" in exI)
     apply(rule_tac x="\<lambda>s. undefined" in exI)
     apply clarsimp
     apply (rule conjI)
      apply clarsimp
     apply clarsimp
     apply (rename_tac a b ret__ptr_to_unsigned_long)
     apply(subgoal_tac "(\<turnstile>\<^sub>s ret__ptr_to_unsigned_long \<and>\<^sup>* sep_true) (lift_state (a,b))")
      prefer 2
      apply(drule sep_conj_sep_true_right)
      apply simp
     apply(subgoal_tac "(\<turnstile>\<^sub>s (ret__ptr_to_unsigned_long +\<^sub>p 1) \<and>\<^sup>* sep_true) (lift_state (a,b))")
      prefer 2
      apply(drule sep_conj_sep_true_left)
      apply simp
      apply(subst (asm) sep_conj_assoc [symmetric])+
      apply(drule_tac Q="free_pool (k - Suc 0)" in sep_conj_sep_true_right)
      apply simp
     apply(simp add: tagd_ptr_safe tagd_g c_guard_ptr_aligned c_guard_NULL)
     apply(simp add: sep_fac_list_def)
     apply(sep_select_tac "(_ +\<^sub>p _) \<mapsto> _")
     apply(rule sep_heap_update_global')
     apply simp
     apply(rule sep_heap_update_global')
     apply simp
    apply clarsimp
    apply(rule_tac x=k in exI)
    apply clarsimp
    apply(rule_tac x="k - Suc (unat (n - 1))" in exI)
    apply clarsimp
    apply(rule_tac x="\<lambda>(n,p). sep_fac_list (n - 1) p" in exI)
    apply(rule_tac x="\<lambda>s. (n_' s,q_' s)" in exI)
    apply (rule conjI, clarsimp)
    apply clarsimp
    apply (rule conjI)
     apply clarsimp
     apply(simp add: sep_fac_list_def)
     apply(rule_tac x="fac_list (unat (n - 1))" in exI)
     apply clarsimp
    apply clarsimp
    apply(subgoal_tac "(\<turnstile>\<^sub>s ret__ptr_to_unsigned_long \<and>\<^sup>* sep_true) (lift_state (ab,bb))")
     prefer 2
     apply(erule (1) sep_conj_impl)
     apply simp
    apply(subgoal_tac "(\<turnstile>\<^sub>s (ret__ptr_to_unsigned_long +\<^sub>p 1) \<and>\<^sup>* sep_true) (lift_state (ab,bb))")
     prefer 2
     apply(subgoal_tac "(\<turnstile>\<^sub>s ret__ptr_to_unsigned_long \<and>\<^sup>*
                         \<turnstile>\<^sub>s (ret__ptr_to_unsigned_long +\<^sub>p 1) \<and>\<^sup>*
                         sep_fac_list (n - 1) ret__ptr_to_unsigned_longa \<and>\<^sup>*
                         free_pool (k - Suc (unat n))) =
                         (\<turnstile>\<^sub>s (ret__ptr_to_unsigned_long +\<^sub>p 1) \<and>\<^sup>* (\<turnstile>\<^sub>s ret__ptr_to_unsigned_long \<and>\<^sup>*
                         sep_fac_list (n - 1) ret__ptr_to_unsigned_longa \<and>\<^sup>*
                         free_pool (k - Suc (unat n))))")
      prefer 2
      apply simp
     apply (simp only:)
     apply(erule (1) sep_conj_impl)
     apply simp
    apply(sep_point_tac sep_fac_list_points)
    apply(simp add: tagd_ptr_safe tagd_g sep_map'_g c_guard_ptr_aligned c_guard_NULL sep_map'_lift)
    apply(rule sep_fac_list_unfold)
    apply clarsimp
    apply (rule conjI, unat_arith)
    apply sep_exists_tac
    apply(rule_tac x="ptr_val ret__ptr_to_unsigned_longa" in exI)
    apply clarsimp
    apply(subst fac_unfold)
     apply unat_arith
    apply clarsimp
    apply(sep_select_tac "(_ +\<^sub>p _) \<mapsto> _")
    apply(rule sep_heap_update_global')
    apply(sep_select_tac "_ \<mapsto> _")
      apply(rule sep_heap_update_global')
      apply(erule (1) sep_conj_impl)+
      apply clarsimp
   apply clarsimp
   apply(case_tac xs)
    apply simp
   apply clarsimp
   apply sep_exists_tac
   apply clarsimp
   apply sep_point_tac
   apply(simp add: sep_map'_g c_guard_ptr_aligned c_guard_NULL sep_map'_lift)
   apply(rule_tac x="k - Suc (length list)" in exI)
   apply(rule_tac x="\<lambda>p. sep_list list (Ptr j)" in exI)
   apply(rule_tac x="\<lambda>x. ()" in exI)
   apply(clarsimp simp: sep_app_def)
   apply (rule conjI)
    apply(subgoal_tac "(q \<mapsto> aa \<and>\<^sup>* sep_list list (Ptr j) \<and>\<^sup>*
                         (q +\<^sub>p 1) \<mapsto> j \<and>\<^sup>* free_pool (k - Suc (length list))) =
                       (sep_list list (Ptr j) \<and>\<^sup>* (q \<mapsto> aa \<and>\<^sup>*
                         (q +\<^sub>p 1) \<mapsto> j \<and>\<^sup>* free_pool (k - Suc (length list))))")
     apply(simp only:)
     apply(erule (1) sep_conj_impl)
     apply simp
     apply(subst sep_conj_com)
     apply(subst (asm) sep_conj_assoc [symmetric])+
     apply(erule sep_conj_impl)
      apply simp
      apply(erule double_word_sep_cut'[simplified])
     apply assumption
    apply simp
   apply clarsimp
   apply(subgoal_tac "Suc (k - Suc (length list)) = k - length list")
    apply force
   apply arith
  apply clarsimp
  done

declare hrs_simps [simp del]

lemma (in factorial_global_addresses) mem_safe_factorial:
  shows "mem_safe (\<acute>ret__ptr_to_unsigned_long :== PROC factorial(\<acute>n)) \<Gamma>"
  apply(subst mem_safe_restrict)
  apply(rule intra_mem_safe)
   apply (insert factorial_impl free_impl alloc_impl)
   apply(drule_tac t="Some C" in sym)
   apply(simp_all add: restrict_map_def call_def block_def whileAnno_def
                       free_body_def alloc_body_def factorial_body_def creturn_def
                split: if_split_asm option.splits)
  apply((erule disjE)?, simp,
        (thin_tac "C=x" for x, (thin_tac "\<Gamma> x = y" for x y)+,
        force simp: intra_sc)?)+
  done

end


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory FixedPointTheorems
imports
  HOLCF
begin

setup \<open>
  Document_Output.antiquotation_raw \<^binding>\<open>haskell\<close> (Scan.lift Args.name)
    (fn _ => fn s => Latex.string ("\\" ^ "<" ^ s ^ "\\>"))
\<close>

(* LaTeXsugar fights with HOLCF syntax: at least cdot *)

(* THEOREMS *)
notation (Rule output)
  Pure.imp  ("\<^latex>\<open>\\mbox{}\\inferrule{\\mbox{\<close>_\<^latex>\<open>}}\<close>\<^latex>\<open>{\\mbox{\<close>_\<^latex>\<open>}}\<close>")

syntax (Rule output)
  "_bigimpl" :: "asms \<Rightarrow> prop \<Rightarrow> prop"
  ("\<^latex>\<open>\\mbox{}\\inferrule{\<close>_\<^latex>\<open>}\<close>\<^latex>\<open>{\\mbox{\<close>_\<^latex>\<open>}}\<close>")

  "_asms" :: "prop \<Rightarrow> asms \<Rightarrow> asms"
  ("\<^latex>\<open>\\mbox{\<close>_\<^latex>\<open>}\\\\\<close>/ _")

  "_asm" :: "prop \<Rightarrow> asms" ("\<^latex>\<open>\\mbox{\<close>_\<^latex>\<open>}\<close>")

(*>*)
section\<open>Fixed-point theorems for program transformation\<close>

text\<open>

We begin by recounting some standard theorems from the early days of
denotational semantics. The origins of these results are lost to
history; the interested reader can find some of it in
\citet{Bekic:1969, Manna:1974, Greibach:1975, Stoy:1977,
DBLP:books/daglib/0002432, Harel:1980, Plotkin:1983, Winskel:1993,
DBLP:journals/toplas/Sangiorgi09}.

\<close>

subsection\<open>The rolling rule\<close>

text\<open>

The \emph{rolling rule} captures what intuitively happens when we
re-order a recursive computation consisting of two parts. This theorem
dates from the 1970s at the latest -- see \citet[p210]{Stoy:1977} and
\citet{Plotkin:1983}. The following proofs were provided by
\citet{GillHutton:2009}.

\<close>

lemma rolling_rule_ltr: "fix\<cdot>(g oo f) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
proof -
  have "g\<cdot>(fix\<cdot>(f oo g)) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
    by (rule below_refl) \<comment> \<open>reflexivity\<close>
  hence "g\<cdot>((f oo g)\<cdot>(fix\<cdot>(f oo g))) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
    using fix_eq[where F="f oo g"] by simp \<comment> \<open>computation\<close>
  hence "(g oo f)\<cdot>(g\<cdot>(fix\<cdot>(f oo g))) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
    by simp \<comment> \<open>re-associate @{term "(oo)"}\<close>
  thus "fix\<cdot>(g oo f) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
    using fix_least_below by blast \<comment> \<open>induction\<close>
qed

lemma rolling_rule_rtl: "g\<cdot>(fix\<cdot>(f oo g)) \<sqsubseteq> fix\<cdot>(g oo f)"
proof -
  have "fix\<cdot>(f oo g) \<sqsubseteq> f\<cdot>(fix\<cdot>(g oo f))" by (rule rolling_rule_ltr)
  hence "g\<cdot>(fix\<cdot>(f oo g)) \<sqsubseteq> g\<cdot>(f\<cdot>(fix\<cdot>(g oo f)))"
    by (rule monofun_cfun_arg) \<comment> \<open>g is monotonic\<close>
  thus "g\<cdot>(fix\<cdot>(f oo g)) \<sqsubseteq> fix\<cdot>(g oo f)"
    using fix_eq[where F="g oo f"] by simp \<comment> \<open>computation\<close>
qed

lemma rolling_rule: "fix\<cdot>(g oo f) = g\<cdot>(fix\<cdot>(f oo g))"
  by (rule below_antisym[OF rolling_rule_ltr rolling_rule_rtl])
(*

This property of a fixed-point operator is termed \emph{dinaturality}
by \citet{DBLP:conf/lics/SimpsonP00}.

*)

subsection\<open>Least-fixed-point fusion\<close>

text\<open>

\label{sec:lfp-fusion}

\emph{Least-fixed-point fusion} provides a kind of induction that has
proven to be very useful in calculational settings. Intuitively it
lifts the step-by-step correspondence between @{term "f"} and @{term
"h"} witnessed by the strict function @{term "g"} to the fixed points
of @{term "f"} and @{term "g"}:
\[
  \begin{diagram}
    \node{\bullet} \arrow{e,t}{h} \node{\bullet}\\
    \node{\bullet} \arrow{n,l}{g} \arrow{e,b}{f} \node{\bullet} \arrow{n,r}{g}
  \end{diagram}
  \qquad \Longrightarrow \qquad
  \begin{diagram}
    \node{\mathsf{fix}\ h}\\
    \node{\mathsf{fix}\ f} \arrow{n,r}{g}
  \end{diagram}
\]
\citet*{FokkingaMeijer:1991}, and also their later
\citet*{barbed-wire:1991}, made extensive use of this rule, as did
\citet{Tullsen:PhDThesis} in his program transformation tool PATH.
This diagram is strongly reminiscent of the simulations used to
establish refinement relations between imperative programs and their
specifications \citep*{EdR:cup98}.

The following proof is close to the third variant of
\citet[p215]{Stoy:1977}. We relate the two fixpoints using the rule
\texttt{parallel\_fix\_ind}:
\begin{center}
  @{thm[mode=Rule] parallel_fix_ind}
\end{center}
in a very straightforward way:

\<close>

lemma lfp_fusion:
  assumes "g\<cdot>\<bottom> = \<bottom>"
  assumes "g oo f = h oo g"
  shows "g\<cdot>(fix\<cdot>f) = fix\<cdot>h"
proof(induct rule: parallel_fix_ind)
  case 2 show "g\<cdot>\<bottom> = \<bottom>" by fact
  case (3 x y)
  from \<open>g\<cdot>x = y\<close> \<open>g oo f = h oo g\<close> show "g\<cdot>(f\<cdot>x) = h\<cdot>y"
    by (simp add: cfun_eq_iff)
qed simp

text\<open>

This lemma also goes by the name of \emph{Plotkin's axiom}
\citep{PittsAM:relpod} or \emph{uniformity}
\citep{DBLP:conf/lics/SimpsonP00}.

\<close>
(*<*)

(* The rest of this theory is only of historical interest. *)

text \<open>Some may find the pointed version easier to read.\<close>

lemma lfp_fusion_pointed:
  assumes Cfg: "\<And>f. C\<cdot>(F\<cdot>f) = G\<cdot>(C\<cdot>f)"
      and strictC: "C\<cdot>\<bottom> = \<bottom>"
  shows "C\<cdot>(fix\<cdot>F) = fix\<cdot>G"
  using lfp_fusion[where f=F and g=C and h=G] assms
  by (simp add: cfcomp1)

subsubsection\<open>More about \<open>lfp-fusion\<close>\<close>

text\<open>

Alternative proofs. This is the ``intuitive'' one
\citet[p125]{Gunter:1992} and \citet[p46]{Tullsen:PhDThesis}, where we
can shuffle @{term "g"} to the end of the the iteration of @{term "f"}
using @{term "fgh"}.

\<close>

lemma lfp_fusion2_aux:
  assumes fgh: "g oo f = h oo g"
  shows "g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>) = iterate i\<cdot>h\<cdot>(g\<cdot>\<bottom>)"
proof(induct i)
  case (Suc i)
  have "g\<cdot>(iterate (Suc i)\<cdot>f\<cdot>\<bottom>) = (g oo f)\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>)" by simp
  also have "... = h\<cdot>(g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>))" using fgh by (simp add: cfcomp1)
  also have "... = h\<cdot>(iterate i\<cdot>h\<cdot>(g\<cdot>\<bottom>))" using Suc by simp
  also have "... = iterate (Suc i)\<cdot>h\<cdot>(g\<cdot>\<bottom>)" by simp
  finally show ?case .
qed simp

lemma lfp_fusion2:
  assumes fgh: "g oo f = h oo g"
      and strictg: "g\<cdot>\<bottom> = \<bottom>"
  shows "g\<cdot>(fix\<cdot>f) = fix\<cdot>h"
proof -
  have "g\<cdot>(fix\<cdot>f) = g\<cdot>(\<Squnion>i. iterate i\<cdot>f\<cdot>\<bottom>)" by (simp only: fix_def2)
  also have "... = (\<Squnion>i. g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>))" by (simp add: contlub_cfun_arg)
  also have "... = (\<Squnion>i. (iterate i\<cdot>h\<cdot>(g\<cdot>\<bottom>)))" by (simp only: lfp_fusion2_aux[OF fgh])
  also have "... = fix\<cdot>h" using strictg by (simp only: fix_def2)
  finally show ?thesis .
qed

text\<open>This is the first one by \citet[p213]{Stoy:1977}, almost
identical to the above.\<close>

lemma lfp_fusion3_aux:
  assumes fgh: "g oo f = h oo g"
      and strictg: "g\<cdot>\<bottom> = \<bottom>"
  shows "g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>) = iterate i\<cdot>h\<cdot>\<bottom>"
proof(induct i)
  case 0 from strictg show ?case by simp
next
  case (Suc i)
  have "g\<cdot>(iterate (Suc i)\<cdot>f\<cdot>\<bottom>) = (g oo f)\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>)" by simp
  also have "... = h\<cdot>(g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>))" using fgh by (simp add: cfcomp1)
  also have "... = h\<cdot>(iterate i\<cdot>h\<cdot>\<bottom>)" using Suc by simp
  also have "... = iterate (Suc i)\<cdot>h\<cdot>\<bottom>" by simp
  finally show ?case .
qed

lemma lfp_fusion3:
  assumes fgh: "g oo f = h oo g"
      and strictg: "g\<cdot>\<bottom> = \<bottom>"
  shows "g\<cdot>(fix\<cdot>f) = fix\<cdot>h"
proof -
  have "g\<cdot>(fix\<cdot>f) = g\<cdot>(\<Squnion>i. iterate i\<cdot>f\<cdot>\<bottom>)" by (simp only: fix_def2)
  also have "... = (\<Squnion>i. g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>))" by (simp add: contlub_cfun_arg)
  also have "... = (\<Squnion>i. (iterate i\<cdot>h\<cdot>\<bottom>))" by (simp only: lfp_fusion3_aux[OF fgh strictg])
  also have "... = fix\<cdot>h" by (simp only: fix_def2)
  finally show ?thesis .
qed

text\<open>Stoy's second proof \citep[p214]{Stoy:1977} is similar to the
original proof using fixed-point induction.\<close>

lemma lfp_fusion4:
  assumes fgh: "g oo f = h oo g"
      and strictg: "g\<cdot>\<bottom> = \<bottom>"
  shows "g\<cdot>(fix\<cdot>f) = fix\<cdot>h"
proof(rule below_antisym)
  show "fix\<cdot>h \<sqsubseteq> g\<cdot>(fix\<cdot>f)"
  proof -
    have "h\<cdot>(g\<cdot>(fix\<cdot>f)) = (g oo f)\<cdot>(fix\<cdot>f)" using fgh by simp
    also have "... = g\<cdot>(fix\<cdot>f)" by (subst fix_eq, simp)
    finally show ?thesis by (rule fix_least)
  qed
  let ?P = "\<lambda>x. g\<cdot>x \<sqsubseteq> fix\<cdot>h"
  show "?P (fix\<cdot>f)"
  proof(induct rule: fix_ind[where P="?P"])
    case 2 with strictg show ?case by simp
  next
    case (3 x) hence indhyp: "g\<cdot>x \<sqsubseteq> fix\<cdot>h" .
    have "g\<cdot>(f\<cdot>x) = (h oo g)\<cdot>x" using fgh[symmetric] by simp
    with indhyp show "g\<cdot>(f\<cdot>x) \<sqsubseteq> fix\<cdot>h"
      by (subst fix_eq, simp add: monofun_cfun)
  qed simp
qed

text\<open>A wrinkly variant from \citet[p11]{barbed-wire:1991}.\<close>

lemma lfp_fusion_barbed_variant:
  assumes ff': "f\<cdot>\<bottom> = f'\<cdot>\<bottom>"
      and fgh: "f oo g = h oo f"
      and f'g'h: "f' oo g' = h oo f'"
  shows "f\<cdot>(fix\<cdot>g) = f'\<cdot>(fix\<cdot>g')"
proof(induct rule: parallel_fix_ind)
  case 2 show "f\<cdot>\<bottom> = f'\<cdot>\<bottom>" by (rule ff')
  case (3 x y)
  from \<open>f\<cdot>x = f'\<cdot>y\<close> have "h\<cdot>(f\<cdot>x) = h\<cdot>(f'\<cdot>y)" by simp
  with fgh f'g'h have "f\<cdot>(g\<cdot>x) = f'\<cdot>(g'\<cdot>y)"
    using cfcomp2[where f="f" and g="g", symmetric]
          cfcomp2[where f="f'" and g="g'", symmetric]
    by simp
  thus ?case by simp
qed simp
(*>*)

(*<*)
end
(*>*)


(*  Title:      Containers/Lexicographic_Order.thy
    Author:     Andreas Lochbihler, KIT *)

theory Lexicographic_Order imports
  List_Fusion
  "~~/src/HOL/Library/Char_ord"
begin

hide_const (open) List.lexordp

section {* List fusion for lexicographic order *}

context linorder begin

lemma lexordp_take_index_conv:
  "lexordp xs ys \<longleftrightarrow>
   (length xs < length ys \<and> take (length xs) ys = xs) \<or>
   (\<exists>i < min (length xs) (length ys). take i xs = take i ys \<and> xs ! i < ys ! i)"
  (is "?lhs = ?rhs")
proof
  assume ?lhs thus ?rhs
    by induct (auto 4 3 del: disjCI intro: disjI2 exI[where x="Suc i" for i])
next
  assume ?rhs (is "?prefix \<or> ?less") thus ?lhs
  proof
    assume "?prefix"
    hence "ys = xs @ hd (drop (length xs) ys) # tl (drop (length xs) ys)"
      by (metis append_Nil2 append_take_drop_id less_not_refl list.collapse)
    thus ?thesis unfolding lexordp_iff by blast
  next
    assume "?less"
    then obtain i where "i < min (length xs) (length ys)"
      and "take i xs = take i ys" and nth: "xs ! i < ys ! i" by blast
    hence "xs = take i xs @ xs ! i # drop (Suc i) xs" "ys = take i xs @ ys ! i # drop (Suc i) ys"
      by -(subst append_take_drop_id[symmetric, of _ i], simp_all add: Cons_nth_drop_Suc)
    with nth show ?thesis unfolding lexordp_iff by blast
  qed
qed

-- {* lexord is extension of partial ordering List.lex *}
lemma lexordp_lex: "(xs, ys) \<in> lex {(xs, ys). xs < ys} \<longleftrightarrow> lexordp xs ys \<and> length xs = length ys"
proof(induct xs arbitrary: ys)
  case Nil thus ?case by clarsimp
next
  case Cons thus ?case by(cases ys)(simp_all, safe, simp)
qed

end

subsection {* Setup for list fusion *}

context ord begin

definition lexord_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
where [code del]: "lexord_fusion g1 g2 s1 s2 = lexordp (list.unfoldr g1 s1) (list.unfoldr g2 s2)"

definition lexord_eq_fusion :: "('a, 's1) generator \<Rightarrow> ('a, 's2) generator \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> bool"
where [code del]: "lexord_eq_fusion g1 g2 s1 s2 = lexordp_eq (list.unfoldr g1 s1) (list.unfoldr g2 s2)"

lemma lexord_fusion_code:
  "lexord_fusion g1 g2 s1 s2 \<longleftrightarrow>
  (if list.has_next g1 s1 then
     if list.has_next g2 s2 then
       let (x, s1') = list.next g1 s1;
           (y, s2') = list.next g2 s2
       in x < y \<or> \<not> y < x \<and> lexord_fusion g1 g2 s1' s2'
     else False
   else list.has_next g2 s2)"
unfolding lexord_fusion_def
by(subst (1 2) list.unfoldr.simps)(auto split: prod.split_asm)

lemma lexord_eq_fusion_code:
  "lexord_eq_fusion g1 g2 s1 s2 \<longleftrightarrow>
  (list.has_next g1 s1 \<longrightarrow>
   list.has_next g2 s2 \<and>
   (let (x, s1') = list.next g1 s1;
        (y, s2') = list.next g2 s2
    in x < y \<or> \<not> y < x \<and> lexord_eq_fusion g1 g2 s1' s2'))"
unfolding lexord_eq_fusion_def
by(subst (1 2) list.unfoldr.simps)(auto split: prod.split_asm)

end

lemmas [code] =
  lexord_fusion_code ord.lexord_fusion_code
  lexord_eq_fusion_code ord.lexord_eq_fusion_code

lemmas [symmetric, code_unfold] =
  lexord_fusion_def ord.lexord_fusion_def
  lexord_eq_fusion_def ord.lexord_eq_fusion_def

end


theory OneThirdRuleProof
imports OneThirdRuleDefs "../Reduction" "../Majorities"
begin

text {*
  We prove that \emph{One-Third Rule} solves the Consensus problem
  under the communication predicate defined above. The proof is
  split into proofs of the Integrity, Agreement, and Termination
  properties.
*}

subsection {* Proof of Integrity *}

text {*
  Showing integrity of the algorithm is a simple, if slightly tedious
  exercise in invariant reasoning. The following inductive invariant
  asserts that the values of the @{text x} and @{text decide} fields
  of the process states are limited to the @{text x} values present
  in the initial states since the algorithm does not introduce any
  new values.
*}

definition VInv where
  "VInv rho n \<equiv>
   let xinit = (range (x \<circ> (rho 0)))
   in  range (x \<circ> (rho n)) \<subseteq> xinit
     \<and> range (decide \<circ> (rho n)) \<subseteq> {None} \<union> (Some ` xinit)"

lemma vinv_invariant:
  assumes run:"HORun OTR_M rho HOs"
  shows "VInv rho n"
proof (induct n)
  from run show "VInv rho 0"
    by (simp add: HORun_eq HOinitConfig_eq OTR_HOMachine_def initState_def
                  OTR_initState_def VInv_def image_def)
next
  fix m
  assume ih: "VInv rho m"
  let ?xinit = "range (x \<circ> (rho 0))"
  have "range (x \<circ> (rho (Suc m))) \<subseteq> ?xinit"
  proof (clarsimp)
    fix p
    from run
    have nxt: "OTR_nextState m p (rho m p)
                        (HOrcvdMsgs OTR_M m p (HOs m p) (rho m))
                        (rho (Suc m) p)"
          (is "OTR_nextState _ _ ?st ?msgs ?st'")
     by (simp add: HORun_eq HOnextConfig_eq OTR_HOMachine_def nextState_def)
    show "x ?st' \<in> ?xinit"
    proof (cases "(2*N) div 3 < card (HOs m p)")
      case True
      hence HO: "HOs m p \<noteq> {}" by auto
      let ?MFRs = "{v. MFR ?msgs v}"
      have "Min ?MFRs \<in> ?MFRs"
      proof (rule Min_in)
        from HO have "?MFRs \<subseteq> (the \<circ> ?msgs)`(HOs m p)"
          by (auto simp: image_def intro: MFR_in_msgs)
        thus "finite ?MFRs" by (auto elim: finite_subset)
      next
        from MFR_exists show "?MFRs \<noteq> {}" by auto
      qed
      with HO have "\<exists>q \<in> HOs m p. Min ?MFRs = the (?msgs q)"
        by (intro MFR_in_msgs) auto
      hence "\<exists>q \<in> HOs m p. Min ?MFRs = x (rho m q)"
        by (auto simp: HOrcvdMsgs_def OTR_HOMachine_def OTR_sendMsg_def)
     moreover
      from True nxt have "x ?st' = Min ?MFRs"
        by (simp add: OTR_nextState_def HOrcvdMsgs_def)
     ultimately
        show ?thesis using ih by (auto simp: VInv_def image_def)
    next
      case False
      with nxt ih show ?thesis
        by (auto simp: OTR_nextState_def VInv_def HOrcvdMsgs_def Let_def)
    qed
  qed
  moreover
  have "\<forall>p. decide ((rho (Suc m)) p) \<in> {None} \<union> (Some ` ?xinit)"
  proof
    fix p
    from run
    have nxt: "OTR_nextState m p (rho m p)
                        (HOrcvdMsgs OTR_M m p (HOs m p) (rho m))
                        (rho (Suc m) p)"
          (is "OTR_nextState _ _ ?st ?msgs ?st'")
      by (simp add: HORun_eq HOnextConfig_eq OTR_HOMachine_def nextState_def)
    show "decide ?st' \<in> {None} \<union> (Some ` ?xinit)"
    proof (cases "(2*N) div 3 < card {q. ?msgs q \<noteq> None}")
      assume HO: "(2*N) div 3 < card {q. ?msgs q \<noteq> None}"
      show ?thesis
      proof (cases "\<exists>v. TwoThirds ?msgs v")
        case True
        let ?dec = "\<some>v. TwoThirds ?msgs v"
        from True have "TwoThirds ?msgs ?dec" by (rule someI_ex)
        hence "HOV ?msgs ?dec \<noteq> {}" by (auto simp add: TwoThirds_def)
        then obtain q where "x (rho m q) = ?dec"
          by (auto simp: HOV_def HOrcvdMsgs_def OTR_HOMachine_def
                         OTR_sendMsg_def)
        from sym[OF this] nxt ih show ?thesis
          by (auto simp: OTR_nextState_def VInv_def image_def)
      next
        case False
        with HO nxt ih show ?thesis
          by (auto simp: OTR_nextState_def VInv_def HOrcvdMsgs_def image_def)
      qed
    next
      case False
      with nxt ih show ?thesis
        by (auto simp: OTR_nextState_def VInv_def image_def)
    qed
  qed
  hence "range (decide \<circ> (rho (Suc m))) \<subseteq> {None} \<union> (Some ` ?xinit)" by auto
  ultimately
  show "VInv rho (Suc m)" by (auto simp: VInv_def image_def)
qed

text {*
  Integrity is an immediate consequence.
*}
theorem OTR_integrity:
  assumes run:"HORun OTR_M rho HOs" and dec: "decide (rho n p) = Some v"
  shows "\<exists>q. v = x (rho 0 q)"
proof -
  let ?xinit = "range (x \<circ> (rho 0))"
  from run have "VInv rho n" by (rule vinv_invariant)
  hence "range (decide \<circ> (rho n)) \<subseteq> {None} \<union> (Some ` ?xinit)"
    by (auto simp: VInv_def Let_def)
  hence "decide ((rho n) p) \<in> {None} \<union> (Some ` ?xinit)"
    by (auto simp: image_def)
  with dec show ?thesis by auto
qed

subsection {* Proof of Agreement *}

text {*
  The following lemma @{text A1} asserts that if process @{text p}
  decides in a round on a value @{text v} then more than $2/3$ of
  all processes have @{text v} as their @{text x} value in their
  local state.

  We show a few simple lemmas in preparation.
*}

lemma nextState_change:
  assumes "HORun OTR_M rho HOs"
      and "\<not> ((2*N) div 3
              < card {q. (HOrcvdMsgs OTR_M n p (HOs n p) (rho n)) q \<noteq> None})"
  shows "rho (Suc n) p = rho n p"
  using assms
  by (auto simp: HORun_eq HOnextConfig_eq OTR_HOMachine_def
                 nextState_def OTR_nextState_def)

lemma nextState_decide:
  assumes run:"HORun OTR_M rho HOs"
  and chg: "decide (rho (Suc n) p) \<noteq> decide (rho n p)"
  shows "TwoThirds (HOrcvdMsgs OTR_M n p (HOs n p) (rho n))
                   (the (decide (rho (Suc n) p)))"
proof -
  from run
  have "OTR_nextState n p (rho n p)
                    (HOrcvdMsgs OTR_M n p (HOs n p) (rho n)) (rho (Suc n) p)"
    by (simp add: HORun_eq HOnextConfig_eq OTR_HOMachine_def nextState_def)
  with chg show ?thesis by (auto simp: OTR_nextState_def elim: someI)
qed

text {*
  The following lemma @{text A2} contains the crucial correctness argument:
  if more than $2/3$ of all processes send @{text v} and process @{text p}
  hears from more than $2/3$ of all processes then the @{text x} field of
  @{text p} will be updated to @{text v}.
*}

lemma A2:
  assumes run: "HORun OTR_M rho HOs"
  and HO: "(2*N) div 3
             < card { q . HOrcvdMsgs OTR_M n p (HOs n p) (rho n) q \<noteq> None }"
  and maj: "(2*N) div 3 < card { q . x (rho n q) = v }"
  shows "x (rho (Suc n) p) = v"
proof -
  from run
  have nxt: "OTR_nextState n p (rho n p)
                      (HOrcvdMsgs OTR_M n p (HOs n p) (rho n))
                      (rho (Suc n) p)"
        (is "OTR_nextState _ _ ?st ?msgs ?st'")
    by (simp add: HORun_eq HOnextConfig_eq OTR_HOMachine_def nextState_def)
  let ?HOVothers = "\<Union> { HOV ?msgs w | w . w \<noteq> v}"
  -- {* processes from which @{text p} received values different from @{text v} *}

  have w: "card ?HOVothers \<le> N div 3"
  proof -
    have "card ?HOVothers \<le> card (UNIV - { q . x (rho n q) = v })"
      by (auto simp: HOV_def HOrcvdMsgs_def OTR_HOMachine_def OTR_sendMsg_def
               intro: card_mono)
    also have "\<dots> = N - card { q . x (rho n q) = v }"
      by (auto simp: card_Diff_subset)
    also from maj have "\<dots> \<le> N div 3" by auto
    finally show ?thesis .
  qed

  have hov: "HOV ?msgs v = { q . ?msgs q \<noteq> None } - ?HOVothers"
    by (auto simp: HOV_def) blast

  have othHO: "?HOVothers \<subseteq> { q . ?msgs q \<noteq> None }"
    by (auto simp: HOV_def)

  txt {* Show that @{text v} has been received from more than $N/3$ processes. *}
  from HO have "N div 3 < card { q . ?msgs q \<noteq> None } - (N div 3)"
    by auto
  also from w HO have "\<dots> \<le> card { q . ?msgs q \<noteq> None } - card ?HOVothers"
    by auto
  also from hov othHO have "\<dots> = card (HOV ?msgs v)"
    by (auto simp: card_Diff_subset)
  finally have HOV: "N div 3 < card (HOV ?msgs v)" .

  txt {* All other values are received from at most $N/3$ processes. *}
  have "\<forall>w. w \<noteq> v \<longrightarrow> card (HOV ?msgs w) \<le> card ?HOVothers"
    by (force intro: card_mono)
  with w have cardw: "\<forall>w. w \<noteq> v \<longrightarrow> card (HOV ?msgs w) \<le> N div 3" by auto

  txt {* In particular, @{text v} is the single most frequently received value. *}
  with HOV have "MFR ?msgs v" by (auto simp: MFR_def)

  moreover
  have "\<forall>w. w \<noteq> v \<longrightarrow> \<not>(MFR ?msgs w)"
  proof (auto simp: MFR_def not_le)
    fix w
    assume "w \<noteq> v"
    with cardw HOV have "card (HOV ?msgs w) < card (HOV ?msgs v)" by auto
    thus "\<exists>v. card (HOV ?msgs w) < card (HOV ?msgs v)" ..
  qed

  ultimately
  have mfrv: "{ w . MFR ?msgs w } = {v}" by auto

  have "card { q . ?msgs q = Some v } \<le> card { q . ?msgs q \<noteq> None }"
    by (auto intro: card_mono)
  with HO mfrv nxt show ?thesis by (auto simp: OTR_nextState_def)
qed

text {*
  Therefore, once more than two thirds of the processes hold @{text v}
  in their @{text x} field, this will remain true forever.
*}

lemma A3:
  assumes run:"HORun OTR_M rho HOs"
      and n: "(2*N) div 3 < card { q . x (rho n q) = v }" (is "?twothird n")
  shows "?twothird (n+k)"
proof (induct k)
  from n show "?twothird (n+0)" by simp
next
  fix m
  assume m: "?twothird (n+m)"
  have "\<forall>q. x (rho (n+m) q) = v \<longrightarrow> x (rho (n + Suc m) q) = v"
  proof (rule+)
    fix q
    assume q: "x ((rho (n+m)) q) = v"
    let ?msgs = "HOrcvdMsgs OTR_M (n+m) q (HOs (n+m) q) (rho (n+m))"
    show "x (rho (n + Suc m) q) = v"
    proof (cases "(2*N) div 3 < card { q . ?msgs q \<noteq> None }")
      case True
      from m have "(2*N) div 3 < card { q . x (rho (n+m) q) = v }" by simp
      with True run show ?thesis by (auto elim: A2)
    next
      case False
      with run q show ?thesis by (auto dest: nextState_change)
    qed
  qed
  hence "card {q. x (rho (n+m) q) = v} \<le> card {q. x (rho (n + Suc m) q) = v}"
    by (auto intro: card_mono)
  with m show "?twothird (n + Suc m)" by simp
qed

text {*
  It now follows that once a process has decided on some value @{text v},
  more than two thirds of all processes continue to hold @{text v} in
  their @{text x} field.
*}

lemma A4:
  assumes run: "HORun OTR_M rho HOs"
  and dec: "decide (rho n p) = Some v" (is "?dec n")
  shows "\<forall>k. (2*N) div 3 < card { q . x (rho (n+k) q) = v }"
        (is "\<forall>k. ?twothird (n+k)")
using dec proof (induct n)
  -- {* The base case is trivial since no process has decided *}
  assume "?dec 0" with run show "\<forall>k. ?twothird (0+k)"
    by (simp add: HORun_eq HOinitConfig_eq OTR_HOMachine_def
                  initState_def OTR_initState_def)
next
  -- {* For the inductive step, we assume that process @{text p} has decided on @{text v}. *}
  fix m
  assume ih: "?dec m \<Longrightarrow> \<forall>k. ?twothird (m+k)" and m: "?dec (Suc m)"
  show "\<forall>k. ?twothird ((Suc m) + k)"
  proof
    fix k
    have "?twothird (m + Suc k)"
    txt {*
      There are two cases to consider: if @{text p} had already decided on @{text v}
      before, the assertion follows from the induction hypothesis. Otherwise, the
      assertion follows from lemmas @{text A1} and @{text A3}.
    *}
    proof (cases "?dec m")
      case True with ih show ?thesis by blast
    next
      case False
      with run m have "?twothird m" by (auto elim: A1)
      with run show ?thesis by (blast dest: A3)
    qed
    thus "?twothird ((Suc m) + k)" by simp
  qed
qed

text {*
  The Agreement property follows easily from lemma @{text A4}: if processes
  @{text p} and @{text q} decide values @{text v} and @{text w},
  respectively, then more than two thirds of the processes must propose
  @{text v} and more than two thirds must propose @{text w}.
  Because these two majorities must have an intersection, we must have
  @{text "v=w"}.

  We first prove an ``asymmetric'' version of the agreement property before
  deriving the general agreement theorem.
*}

lemma A5:
  assumes run:"HORun OTR_M rho HOs"
  and p: "decide (rho n p) = Some v"
  and p': "decide (rho (n+k) p') = Some w"
  shows "v = w"
proof -
  from run p
  have "(2*N) div 3 < card {q. x (rho (n+k) q) = v}" (is "_ < card ?V")
    by (blast dest: A4)
  moreover
  from run p'
  have "(2*N) div 3 < card {q. x (rho ((n+k)+0) q) = w}" (is "_ < card ?W")
    by (blast dest: A4)
  ultimately
  have "N < card ?V + card ?W" by auto
  then obtain proc where "proc \<in> ?V \<inter> ?W" by (auto dest: majorities_intersect)
  thus ?thesis by auto
qed

theorem OTR_agreement:
  assumes run:"HORun OTR_M rho HOs"
  and p: "decide (rho n p) = Some v"
  and p': "decide (rho m p') = Some w"
  shows "v = w"
proof (cases "n \<le> m")
  case True
  then obtain k where "m = n+k" by (auto simp add: le_iff_add)
  with run p p' show ?thesis by (auto elim: A5)
next
  case False
  hence "m \<le> n" by auto
  then obtain k where "n = m+k"  by (auto simp add: le_iff_add)
  with run p p' have "w = v" by (auto elim: A5)
  thus ?thesis ..
qed

subsection {* Proof of  Termination *}

text {*
  We now show that every process must eventually decide.

  The idea of the proof is to observe that the communication predicate
  guarantees the existence of two uniform rounds where every process hears
  from the same two-thirds majority of processes. The first such round
  serves to ensure that all @{text x} fields hold the same value, the
  second round copies that value into all decision fields.

  Lemma @{text A2} is instrumental in this proof.
*}

theorem OTR_termination:
  assumes run: "HORun OTR_M rho HOs"
      and commG: "HOcommGlobal OTR_M HOs"
  shows "\<exists>r v. decide (rho r p) = Some v"
proof -
  from commG obtain r0 \<Pi> where
    pi: "\<forall>q. HOs r0 q = \<Pi>" and pic: "card \<Pi> > (2*N) div 3"
    by (auto simp: OTR_HOMachine_def OTR_commGlobal_def)
  let "?msgs q r" = "HOrcvdMsgs OTR_M r q (HOs r q) (rho r)"

  from run pi have "\<forall>p q. ?msgs q r0 = ?msgs p r0"
    by (auto simp: HORun_eq OTR_HOMachine_def HOrcvdMsgs_def OTR_sendMsg_def)
  then obtain \<mu> where "\<forall>q. ?msgs q r0 = \<mu>" by auto
  moreover
  from pi pic have "\<forall>p. (2*N) div 3 < card {q. ?msgs p r0 q \<noteq> None}"
    by (auto simp: HORun_eq HOnextConfig_eq HOrcvdMsgs_def)
  with run have "\<forall>q. x (rho (Suc r0) q) = Min {v . MFR (?msgs q r0) v}"
    by (auto simp: HORun_eq HOnextConfig_eq OTR_HOMachine_def
                   nextState_def OTR_nextState_def)
  ultimately
  have "\<forall>q. x (rho (Suc r0) q) = Min {v . MFR \<mu> v}" by auto
  then obtain v where v:"\<forall>q. x (rho (Suc r0) q) = v" by auto

  have P:"\<forall>k. \<forall>q. x (rho (Suc r0+k) q) = v"
  proof
    fix k
    show "\<forall>q. x (rho (Suc r0+k) q) = v"
    proof (induct k)
      from v show "\<forall>q. x (rho (Suc r0+0) q) = v" by simp
    next
      fix k
      assume ih:"\<forall>q. x (rho (Suc r0 + k) q) = v"
      show "\<forall>q. x (rho (Suc r0 + Suc k) q) = v"
      proof
        fix q
        show "x (rho (Suc r0 + Suc k) q) = v"
        proof (cases "(2*N) div 3 < card { p . ?msgs q (Suc r0 + k) p \<noteq> None }")
          case True
          have "N > 0" by (rule finite_UNIV_card_ge_0) simp
          with ih
          have "(2*N) div 3 < card { p . x (rho (Suc r0 + k) p) = v }" by auto
          with True run show ?thesis by (auto elim: A2)
        next
          case False
          with run ih show ?thesis by (auto dest: nextState_change)
        qed
      qed
    qed
  qed

  from commG obtain r0' \<Pi>'
    where r0': "r0' \<ge> Suc r0"
      and pi': "\<forall>q. HOs r0' q = \<Pi>'"
      and pic': "card \<Pi>' > (2*N) div 3"
    by (force simp: OTR_HOMachine_def OTR_commGlobal_def)
  from r0' P have v':"\<forall>q. x (rho r0' q) = v" by (auto simp: le_iff_add)

  from run
  have "OTR_nextState r0' p (rho r0' p) (?msgs p r0') (rho (Suc r0') p)"
    by (simp add: HORun_eq HOnextConfig_eq OTR_HOMachine_def nextState_def)
  moreover
  from pi' pic' have "(2*N) div 3 < card {q. (?msgs p r0') q \<noteq> None}"
    by (auto simp: HOrcvdMsgs_def OTR_sendMsg_def)
  moreover
  from pi' pic' v' have "TwoThirds (?msgs p r0') v"
    by (simp add: TwoThirds_def HOrcvdMsgs_def OTR_HOMachine_def
                  OTR_sendMsg_def HOV_def)
  ultimately
  have "decide (rho (Suc r0') p) = Some (\<some>v. TwoThirds (?msgs p r0') v)"
    by (auto simp: OTR_nextState_def)
  thus ?thesis by blast
qed

subsection {* \emph{One-Third Rule} Solves Consensus *}

text {*
  Summing up, all (coarse-grained) runs of \emph{One-Third Rule} for
  HO collections that satisfy the communication predicate satisfy
  the Consensus property.
*}

theorem OTR_consensus:
  assumes run: "HORun OTR_M rho HOs" and commG: "HOcommGlobal OTR_M HOs"
  shows "consensus (x \<circ> (rho 0)) decide rho"
  using OTR_integrity[OF run] OTR_agreement[OF run] OTR_termination[OF run commG]
  by (auto simp: consensus_def image_def)

text {*
  By the reduction theorem, the correctness of the algorithm also follows
  for fine-grained runs of the algorithm. It would be much more tedious
  to establish this theorem directly.
*}

theorem OTR_consensus_fg:
  assumes run: "fg_run OTR_M rho HOs HOs (\<lambda>r q. undefined)"
      and commG: "HOcommGlobal OTR_M HOs"
  shows "consensus (\<lambda>p. x (state (rho 0) p)) decide (state \<circ> rho)"
    (is "consensus ?inits _ _")
proof (rule local_property_reduction[OF run consensus_is_local])
  fix crun
  assume crun: "CSHORun OTR_M crun HOs HOs (\<lambda>r q. undefined)"
     and init: "crun 0 = state (rho 0)"
  from crun have "HORun OTR_M crun HOs" by (unfold HORun_def SHORun_def)
  from this commG have "consensus (x \<circ> (crun 0)) decide crun" by (rule OTR_consensus)
  with init show "consensus ?inits decide crun" by (simp add: o_def)
qed

end


section \<open>State Cover\<close>

text \<open>This theory introduces a simple depth-first strategy for computing state covers.\<close>

theory State_Cover
imports FSM
begin

subsection \<open>Basic Definitions\<close>

type_synonym ('a,'b) state_cover = "('a \<times> 'b) list set"
type_synonym ('a,'b,'c) state_cover_assignment = "'a \<Rightarrow> ('b \<times> 'c) list"

fun is_state_cover :: "('a,'b,'c) fsm \<Rightarrow> ('b,'c) state_cover \<Rightarrow> bool" where
  "is_state_cover M SC = ([] \<in> SC \<and> (\<forall> q \<in> reachable_states M . \<exists> io \<in> SC . q \<in> io_targets M io (initial M)))"

fun is_state_cover_assignment :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) state_cover_assignment \<Rightarrow> bool" where
  "is_state_cover_assignment M f = (f (initial M) = [] \<and> (\<forall> q \<in> reachable_states M . q \<in> io_targets M (f q) (initial M)))"

lemma state_cover_assignment_from_state_cover :
  assumes "is_state_cover M SC"
obtains f where "is_state_cover_assignment M f"
            and "\<And> q . q \<in> reachable_states M \<Longrightarrow> f q \<in> SC"
proof -
  define f where f: "f = (\<lambda> q . (if q = initial M then [] else (SOME io . io \<in> SC \<and> q \<in> io_targets M io (initial M))))"

  have "f (initial M) = []"
    using f by auto
  moreover have "\<And> q . q \<in> reachable_states M \<Longrightarrow> f q \<in> SC \<and> q \<in> io_targets M (f q) (initial M)"
  proof -
    fix q assume "q \<in> reachable_states M"
    show "f q \<in> SC \<and> q \<in> io_targets M (f q) (initial M)"
    proof (cases "q = initial M")
      case True
      have "q \<in> io_targets M (f q) (FSM.initial M)"
        unfolding True \<open>f (initial M) = []\<close> by auto
      then show ?thesis
        using True assms \<open>f (initial M) = []\<close> by auto
    next
      case False
      then have "f q = (SOME io . io \<in> SC \<and> q \<in> io_targets M io (initial M))"
        using f by auto
      moreover have "\<exists> io . io \<in> SC \<and> q \<in> io_targets M io (initial M)"
        using assms \<open>q \<in> reachable_states M\<close>
        by (meson is_state_cover.simps)
      ultimately show ?thesis
        by (metis (no_types, lifting) someI_ex)
    qed
  qed
  ultimately show ?thesis using that[of f]
    by (meson is_state_cover_assignment.elims(3))
qed

lemma is_state_cover_assignment_language :
  assumes "is_state_cover_assignment M V"
  and     "q \<in> reachable_states M"
shows "V q \<in> L M"
  using assms io_targets_language
  by (metis is_state_cover_assignment.simps)

lemma is_state_cover_assignment_observable_after :
  assumes "observable M"
  and     "is_state_cover_assignment M V"
  and     "q \<in> reachable_states M"
shows "after_initial M (V q) = q"
proof -
  have "q \<in> io_targets M (V q) (initial M)"
    using assms(2,3)
    by auto
  then have "io_targets M (V q) (initial M) = {q}"
    using observable_io_targets[OF assms(1) io_targets_language[OF \<open>q \<in> io_targets M (V q) (initial M)\<close>]]
    by (metis singletonD)

  then obtain p where "path M (initial M) p" and "p_io p = V q" and "target (initial M) p = q"
    unfolding io_targets.simps
    by blast
  then show "after_initial M (V q) = q"
    using after_path[OF assms(1), of "initial M" p]
    by simp
qed

lemma non_initialized_state_cover_assignment_from_non_initialized_state_cover :
  assumes "\<And> q . q \<in> reachable_states M \<Longrightarrow> \<exists> io \<in> L M \<inter> SC . q \<in> io_targets M io (initial M)"
obtains f where "\<And> q . q \<in> reachable_states M \<Longrightarrow> q \<in> io_targets M (f q) (initial M)"
            and "\<And> q . q \<in> reachable_states M \<Longrightarrow> f q \<in> L M \<inter>  SC"
proof -
  define f where f: "f = (\<lambda> q . (SOME io . io \<in> L M \<inter> SC \<and> q \<in> io_targets M io (initial M)))"

  have "\<And> q . q \<in> reachable_states M \<Longrightarrow> f q \<in> L M \<inter>  SC \<and> q \<in> io_targets M (f q) (initial M)"
  proof -
    fix q assume "q \<in> reachable_states M"
    show "f q \<in> L M \<inter> SC \<and> q \<in> io_targets M (f q) (initial M)"
    proof -
      have "f q = (SOME io . io \<in> L M \<inter> SC \<and> q \<in> io_targets M io (initial M))"
        using f by auto
      moreover have "\<exists> io . io \<in> L M \<inter> SC \<and> q \<in> io_targets M io (initial M)"
        using assms \<open>q \<in> reachable_states M\<close>
        by (meson Int_iff)
      ultimately show ?thesis
        by (metis (no_types, lifting) someI_ex)
    qed
  qed
  then show ?thesis using that[of f]
    by blast
qed

lemma state_cover_assignment_inj :
  assumes "is_state_cover_assignment M V"
  and     "observable M"
  and     "q1 \<in> reachable_states M"
  and     "q2 \<in> reachable_states M"
  and     "q1 \<noteq> q2"
shows "V q1 \<noteq> V q2"
proof (rule ccontr)
  assume "\<not> V q1 \<noteq> V q2"

  then have "io_targets M (V q1) (initial M) = io_targets M (V q2) (initial M)"
    by auto
  then have "q1 = q2"
    using assms(2)
  proof -
    have f1: "\<forall>a f. a \<notin> FSM.states (f::('a, 'b, 'c) fsm) \<or> FSM.initial (FSM.from_FSM f a) = a"
      by (meson from_FSM_simps(1))
    obtain ff :: "('a \<Rightarrow> ('b \<times> 'c) list) \<Rightarrow> ('a, 'b, 'c) fsm \<Rightarrow> ('a, 'b, 'c) fsm" and pps :: "('a \<Rightarrow> ('b \<times> 'c) list) \<Rightarrow> ('a, 'b, 'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list" where
      f2: "M = ff V M \<and> V = pps V M \<and> pps V M (FSM.initial (ff V M)) = [] \<and> (\<forall>a. a \<notin> reachable_states (ff V M) \<or> a \<in> io_targets (ff V M) (pps V M a) (FSM.initial (ff V M)))"
      using assms(1) by fastforce
    then have f3: "q2 \<in> FSM.states (ff V M)"
      by (simp add: \<open>q2 \<in> reachable_states M\<close> reachable_state_is_state)
    then have f4: "\<exists>ps. FSM.initial (FSM.from_FSM M q2) = target (FSM.initial (ff V M)) ps \<and> path (ff V M) (FSM.initial (ff V M)) ps \<and> p_io ps = V q2"
      using f2 \<open>q2 \<in> reachable_states M\<close> assms(1) by auto
    have "q1 \<in> {target (FSM.initial M) ps |ps. path M (FSM.initial M) ps \<and> p_io ps = V q2}"
      by (metis (no_types) \<open>io_targets M (V q1) (FSM.initial M) = io_targets M (V q2) (FSM.initial M)\<close> \<open>q1 \<in> reachable_states M\<close> assms(1) io_targets.simps is_state_cover_assignment.simps)
    then have "\<exists>ps. FSM.initial (FSM.from_FSM M q1) = target (FSM.initial (ff V M)) ps \<and> path (ff V M) (FSM.initial (ff V M)) ps \<and> p_io ps = V q2"
      using f2 by (simp add: \<open>q1 \<in> reachable_states M\<close> reachable_state_is_state)
    then show ?thesis
      using f4 f3 f2 f1 by (metis (no_types) \<open>observable M\<close> \<open>q1 \<in> reachable_states M\<close> observable_path_io_target reachable_state_is_state singletonD singletonI)
  qed
  then show "False"
    using \<open>q1 \<noteq> q2\<close> by blast
qed

lemma state_cover_assignment_card :
  assumes "is_state_cover_assignment M V"
  and     "observable M"
shows "card (V ` reachable_states M) = card (reachable_states M)"
proof -
  have "inj_on V (reachable_states M)"
    using state_cover_assignment_inj[OF assms] by (meson inj_onI)

  then have "card (reachable_states M) \<le> card (V ` reachable_states M)"
    using fsm_states_finite restrict_to_reachable_states_simps(2)
    by (simp add: card_image)
  moreover have "card (V ` reachable_states M) \<le> card (reachable_states M)"
    using fsm_states_finite
    using card_image_le
    by (metis restrict_to_reachable_states_simps(2))
  ultimately show ?thesis by simp
qed

lemma state_cover_assignment_language :
  assumes "is_state_cover_assignment M V"
  shows "V ` reachable_states M \<subseteq> L M"
  using assms unfolding is_state_cover_assignment.simps
  using language_io_target_append by fastforce

fun is_minimal_state_cover :: "('a,'b,'c) fsm \<Rightarrow> ('b,'c) state_cover \<Rightarrow> bool" where
  "is_minimal_state_cover M SC = (\<exists> f . (SC = f ` reachable_states M) \<and> (is_state_cover_assignment M f))"

lemma minimal_state_cover_is_state_cover :
  assumes "is_minimal_state_cover M SC"
  shows "is_state_cover M SC"
proof -
  obtain f where "f (initial M) = []" and "(SC = f ` reachable_states M)" and "(\<And> q . q \<in> reachable_states M \<Longrightarrow> q \<in> io_targets M (f q) (initial M))"
    using assms by auto

  show ?thesis unfolding is_state_cover.simps \<open>(SC = f ` reachable_states M)\<close>
  proof -
    have "f ` FSM.reachable_states M \<subseteq> L M"
    proof
      fix io assume "io \<in> f ` FSM.reachable_states M"
      then obtain q where "q \<in> reachable_states M" and "io = f q"
        by blast
      then have "q \<in> io_targets M (f q) (initial M)"
        using \<open>(\<And> q . q \<in> reachable_states M \<Longrightarrow> q \<in> io_targets M (f q) (initial M))\<close> by blast
      then show "io \<in> L M"
        unfolding \<open>io = f q \<close> by force
    qed

    moreover have "\<forall>q\<in>FSM.reachable_states M. \<exists>io\<in>f ` FSM.reachable_states M. q \<in> io_targets M io (FSM.initial M)"
      using \<open>(\<And> q . q \<in> reachable_states M \<Longrightarrow> q \<in> io_targets M (f q) (initial M))\<close> by blast

    ultimately show "[] \<in> f ` FSM.reachable_states M \<and> (\<forall>q\<in>FSM.reachable_states M. \<exists>io\<in>f ` FSM.reachable_states M. q \<in> io_targets M io (FSM.initial M))"
      using \<open>f (initial M) = []\<close> reachable_states_initial by force
  qed
qed

lemma state_cover_assignment_after :
  assumes "observable M"
  and     "is_state_cover_assignment M V"
  and     "q \<in> reachable_states M"
shows "V q \<in> L M" and "after_initial M (V q) = q"
proof -
  have "V q \<in> L M \<and> after_initial M (V q) = q"
  using assms(3) proof (induct rule: reachable_states_induct)
    case init
    have "V (FSM.initial M) = []"
      using assms(2)
      by auto
    then show ?case
      by auto
  next
    case (transition t)
    then have "t_target t \<in> reachable_states M"
      using reachable_states_next
      by metis
    then have "t_target t \<in> io_targets M (V (t_target t)) (FSM.initial M)"
      using assms(2)
      unfolding is_state_cover_assignment.simps
      by auto
    then obtain p where "path M (initial M) p" and "target (initial M) p = t_target t" and "p_io p = V (t_target t)"
      by auto
    then have "V (t_target t) \<in> L M"
      by force
    then show ?case
      using after_path[OF assms(1) \<open>path M (initial M) p\<close>]
      unfolding \<open>p_io p = V (t_target t)\<close> \<open>target (initial M) p = t_target t\<close>
      by simp
  qed
  then show "V q \<in> L M" and "after_initial M (V q) = q"
    by simp+
qed

(* transitions considered covered by a state cover in the SPY and SPYH-Methods *)
definition covered_transitions :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) state_cover_assignment \<Rightarrow> ('b \<times> 'c) list \<Rightarrow> ('a,'b,'c) transition set" where
  "covered_transitions M V \<alpha> = (let
    ts = the_elem (paths_for_io M (initial M) \<alpha>)
  in
    List.set (filter (\<lambda>t . ((V (t_source t)) @ [(t_input t, t_output t)]) = (V (t_target t))) ts))"

subsection \<open>State Cover Computation\<close>

fun reaching_paths_up_to_depth :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> ('a,'b,'c) path option) \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> ('a,'b,'c) path option)" where
  "reaching_paths_up_to_depth M nexts dones assignment 0 = assignment" |
  "reaching_paths_up_to_depth M nexts dones assignment (Suc k) = (let
      usable_transitions = filter (\<lambda> t . t_source t \<in> nexts \<and> t_target t \<notin> dones \<and> t_target t \<notin> nexts) (transitions_as_list M);
      targets = map t_target usable_transitions;
      transition_choice = Map.empty(targets [\<mapsto>] usable_transitions);
      assignment' = assignment(targets [\<mapsto>] (map (\<lambda>q' . case transition_choice q' of Some t \<Rightarrow> (case assignment (t_source t) of Some p \<Rightarrow> p@[t])) targets));
      nexts' = set targets;
      dones' = nexts \<union> dones
    in reaching_paths_up_to_depth M nexts' dones' assignment' k)"

lemma reaching_paths_up_to_depth_set :
  assumes "nexts = {q . (\<exists> p . path M (initial M) p \<and> target (initial M) p = q \<and> length p = n) \<and> (\<nexists> p . path M (initial M) p \<and> target (initial M) p = q \<and> length p < n)}"
      and "dones = {q . \<exists> p . path M (initial M) p \<and> target (initial M) p = q \<and> length p < n}"
      and "\<And> q . assignment q = None = (\<nexists>p . path M (initial M) p \<and> target (initial M) p = q \<and> length p \<le> n)"
      and "\<And> q p . assignment q = Some p \<Longrightarrow> path M (initial M) p \<and> target (initial M) p = q \<and> length p \<le> n"
      and "dom assignment = nexts \<union> dones"
  shows "((reaching_paths_up_to_depth M nexts dones assignment k) q = None) = (\<nexists>p . path M (initial M) p \<and> target (initial M) p = q \<and> length p \<le> n+k)"
    and "((reaching_paths_up_to_depth M nexts dones assignment k) q = Some p) \<Longrightarrow> path M (initial M) p \<and> target (initial M) p = q \<and> length p \<le> n+k"
    and "q \<in> nexts \<union> dones \<Longrightarrow> (reaching_paths_up_to_depth M nexts dones assignment k) q = assignment q"
proof -
  have "(((reaching_paths_up_to_depth M nexts dones assignment k) q = None) = (\<nexists>p . path M (initial M) p \<and> target (initial M) p = q \<and> length p \<le> n+k))
        \<and> (((reaching_paths_up_to_depth M nexts dones assignment k) q = Some p) \<longrightarrow> path M (initial M) p \<and> target (initial M) p = q \<and> length p \<le> n+k)
        \<and> (q \<in> nexts \<union> dones \<longrightarrow> (reaching_paths_up_to_depth M nexts dones assignment k) q = assignment q)"
  using assms proof (induction k arbitrary: n q nexts dones assignment)
    case 0

    have *:"((reaching_paths_up_to_depth M nexts dones assignment 0) q) = assignment q"
      by auto
    show ?case
      unfolding * using "0.prems"(3,4)[of q] by simp
  next
    case (Suc k)

    define usable_transitions where d1: "usable_transitions = filter (\<lambda> t . t_source t \<in> nexts \<and> t_target t \<notin> dones \<and> t_target t \<notin> nexts) (transitions_as_list M)"
    moreover define targets where d2: "targets = map t_target usable_transitions"
    moreover define transition_choice where d3: "transition_choice = Map.empty(targets [\<mapsto>] usable_transitions)"
    moreover define assignment' where d4: "assignment' = assignment(targets [\<mapsto>] (map (\<lambda>q' . case transition_choice q' of Some t \<Rightarrow> (case assignment (t_source t) of Some p \<Rightarrow> p@[t])) targets))"
    ultimately have d5: "reaching_paths_up_to_depth M nexts dones assignment (Suc k) = reaching_paths_up_to_depth M (set targets) (nexts \<union> dones) assignment' k"
      unfolding reaching_paths_up_to_depth.simps Let_def by force

    let ?nexts' = "(set targets)"
    let ?dones' = "(nexts \<union> dones)"

    have p1: "?nexts' = {q. (\<exists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p = Suc n) \<and>
                            (\<nexists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p < Suc n)}" (is "?nexts' = ?PS")
    proof -
      have "\<And> q . q \<in> ?nexts' \<Longrightarrow> q \<in> ?PS"
      proof -
        fix q assume "q \<in> ?nexts'"
        then obtain t where "t \<in> transitions M"
                        and "t_source t \<in> nexts"
                        and "t_target t = q"
                        and "t_target t \<notin> dones"
                        and "t_target t \<notin> nexts"
          unfolding d2 d1 using transitions_as_list_set[of M] by force

        obtain p where "path M (initial M) p" and "target (initial M) p = t_source t" and "length p = n"
          using \<open>t_source t \<in> nexts\<close> unfolding Suc.prems by blast
        then have "path M (initial M) (p@[t])" and "target (initial M) (p@[t]) = q"
          unfolding \<open>t_target t = q\<close>[symmetric] using \<open>t \<in> transitions M\<close> by auto
        then have "(\<exists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p = Suc n)"
          using \<open>length p = n\<close> by (metis length_append_singleton)
        moreover have "(\<nexists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p < Suc n)"
          using \<open>t_target t \<notin> dones\<close> \<open>t_target t \<notin> nexts\<close> unfolding \<open>t_target t = q\<close> Suc.prems
          using less_antisym by blast
        ultimately show "q \<in> ?PS"
          by blast
      qed
      moreover have "\<And> q . q \<in> ?PS \<Longrightarrow> q \<in> ?nexts'"
      proof -
        fix q assume "q \<in> ?PS"
        then obtain p where "path M (initial M) p" and "target (initial M) p = q" and "length p = Suc n"
          by auto

        let ?p = "butlast p"
        let ?t = "last p"

        have "p = ?p@[?t]"
          using \<open>length p = Suc n\<close>
          by (metis append_butlast_last_id list.size(3) nat.simps(3))
        then have "path M (initial M) (?p@[?t])"
          using \<open>path M (initial M) p\<close> by auto

        have "path M (FSM.initial M) ?p"
             "?t \<in> FSM.transitions M"
             "t_source ?t = target (FSM.initial M) ?p"
          using path_append_transition_elim[OF \<open>path M (initial M) (?p@[?t])\<close>] by blast+

        have "t_target ?t = q"
          using \<open>target (initial M) p = q\<close> \<open>p = ?p@[?t]\<close> unfolding target.simps visited_states.simps
          by (metis (no_types, lifting) last_ConsR last_map map_is_Nil_conv snoc_eq_iff_butlast)
        moreover have "t_source ?t \<in> nexts"
        proof -
          have "length ?p = n"
            using \<open>p = ?p@[?t]\<close> \<open>length p = Suc n\<close> by auto
          then have "(\<exists> p . path M (initial M) p \<and> target (initial M) p = t_source ?t \<and> length p = n)"
            using \<open>path M (FSM.initial M) ?p\<close> \<open>t_source ?t = target (FSM.initial M) ?p\<close>
            by metis
          moreover have "(\<nexists> p . path M (initial M) p \<and> target (initial M) p = t_source ?t \<and> length p < n)"
          proof
            assume "\<exists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = t_source ?t \<and> length p < n"
            then obtain p' where "path M (FSM.initial M) p'" and "target (FSM.initial M) p' = t_source ?t" and "length p' < n"
              by blast
            then have "path M (initial M) (p'@[?t])" and "length (p'@[?t]) < Suc n"
              using \<open>?t \<in> FSM.transitions M\<close> by auto
            moreover have "target (initial M) (p'@[?t]) = q"
              using \<open>t_target ?t = q\<close> by auto
            ultimately show "False"
              using \<open>q \<in> ?PS\<close>
              by (metis (mono_tags, lifting) mem_Collect_eq)
          qed
          ultimately show ?thesis
            unfolding Suc.prems by blast
        qed
        moreover have "q \<notin> dones" and "q \<notin> nexts"
          unfolding Suc.prems using \<open>q \<in> ?PS\<close>
          using less_SucI by blast+
        ultimately have "t_source ?t \<in> nexts \<and> t_target ?t \<notin> dones \<and> t_target ?t \<notin> nexts"
          by simp
        then show "q \<in> ?nexts'"
          unfolding d2 d1 using transitions_as_list_set[of M] \<open>?t \<in> FSM.transitions M\<close> \<open>t_target ?t = q\<close>
          by auto
      qed
      ultimately show ?thesis
        by blast
    qed

    have p2: "?dones' = {q. \<exists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p < Suc n}" (is "?dones' = ?PS")
    proof -
      have "\<And> q . q \<in> ?dones' \<Longrightarrow> q \<in> ?PS"
        unfolding Suc.prems
        using less_SucI by blast
      moreover have "\<And> q . q \<in> ?PS \<Longrightarrow> q \<in> ?dones'"
      proof -
        fix q assume "q \<in> ?PS"
        show "q \<in> ?dones'" proof (cases "\<exists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p < n")
          case True
          then show ?thesis unfolding Suc.prems by blast
        next
          case False

          obtain p where *: "path M (FSM.initial M) p \<and> target (FSM.initial M) p = q" and "length p < Suc n"
            using \<open>q \<in> ?PS\<close> by blast
          then have "length p = n"
            using False by force

          then show ?thesis
            using * False unfolding Suc.prems by blast
        qed
      qed
      ultimately show ?thesis
        by blast
    qed

    have p3: "(\<And>q. (assignment' q = None) = (\<nexists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> Suc n))"
    and  p4: "(\<And>q p. assignment' q = Some p \<Longrightarrow> path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> Suc n)"
    and  p5: "dom assignment' = ?nexts' \<union> ?dones'"
    proof -

      have "dom transition_choice = set targets"
        unfolding d3 d2 by auto

      show "dom assignment' = ?nexts' \<union> ?dones'"
        by (simp add: \<open>dom assignment = nexts \<union> dones\<close> d4)

      have helper: "\<And> f P (n::nat) . {x . (\<exists> y . P x y \<and> f y = n) \<and> (\<nexists> y . P x y \<and> f y < n)} \<union> {x . (\<exists> y . P x y \<and> f y < n)}= {x . (\<exists> y . P x y \<and> f y \<le> n)}"
        by force

      have dom': "dom assignment' = {q. \<exists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> Suc n}"
        unfolding \<open>dom assignment' = ?nexts' \<union> ?dones'\<close> p1 p2
        using helper[of "\<lambda> q p . path M (FSM.initial M) p \<and> target (FSM.initial M) p = q" length "Suc n"] by force

      have *: "\<And> q . q \<in> ?nexts' \<Longrightarrow> \<exists> p . assignment' q = Some p \<and> path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> Suc n"
      proof -
        fix q assume "q \<in> ?nexts'"
        then obtain t where "transition_choice q = Some t"
          using \<open>dom transition_choice = set targets\<close> d2 d3 by blast
        then have "t \<in> set usable_transitions"
              and "t_target t = q"
              and "q \<in> set targets"
          unfolding d3 d2 using map_upds_map_set_left[of t_target usable_transitions q t] by auto
        then have "t_source t \<in> nexts" and "t \<in> transitions M"
          unfolding d1 using transitions_as_list_set[of M] by auto
        then obtain p where "assignment (t_source t) = Some p"
          using Suc.prems(1,3,4)
          by fastforce
        then have "path M (FSM.initial M) p \<and> target (FSM.initial M) p = t_source t \<and> length p \<le> n"
          using Suc.prems(4) by blast
        then have "path M (FSM.initial M) (p@[t]) \<and> target (FSM.initial M) (p@[t]) = q \<and> length (p@[t]) \<le> Suc n"
          using \<open>t \<in> transitions M\<close> \<open>t_target t = q\<close> by auto
        moreover have "assignment' q = Some (p@[t])"
        proof -
          have "assignment' q = [targets [\<mapsto>] (map (\<lambda>q' . case transition_choice q' of Some t \<Rightarrow> (case assignment (t_source t) of Some p \<Rightarrow> p@[t])) targets)] q"
            unfolding d4 using map_upds_overwrite[OF \<open>q \<in> set targets\<close>, of "map (\<lambda>q' . case transition_choice q' of Some t \<Rightarrow> (case assignment (t_source t) of Some p \<Rightarrow> p@[t])) targets" assignment]
            by auto
          also have "\<dots> = Some (case transition_choice q of Some t \<Rightarrow> case assignment (t_source t) of Some p \<Rightarrow> p @ [t])"
            using map_upds_map_set_right[OF \<open>q \<in> set targets\<close>] by auto
          also have "\<dots> = Some (p@[t])"
            using \<open>transition_choice q = Some t\<close>  \<open>assignment (t_source t) = Some p\<close> by simp
          finally show ?thesis .
        qed
        ultimately show "\<exists> p . assignment' q = Some p \<and> path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> Suc n"
          by simp
      qed

      show "(\<And>q. (assignment' q = None) = (\<nexists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> Suc n))"
        using dom' by blast

      show "(\<And>q p. assignment' q = Some p \<Longrightarrow> path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> Suc n)"
      proof -
        fix q p assume "assignment' q = Some p"

        show "path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> Suc n"
        proof (cases "q \<in> ?nexts'")
          case True
          show ?thesis using *[OF True] \<open>assignment' q = Some p\<close>
            by simp
        next
          case False
          moreover have "\<And> q . assignment q \<noteq> assignment' q \<Longrightarrow> q \<in> ?nexts'"
            unfolding d4
            by (metis (no_types) map_upds_apply_nontin)
          ultimately have "assignment' q = assignment q"
            by force
          then show ?thesis
            using Suc.prems(4) \<open>assignment' q = Some p\<close>
            by (simp add: le_SucI)
        qed
      qed
    qed

    have "\<And> q . (reaching_paths_up_to_depth M (set targets) (nexts \<union> dones) assignment' k q = None) =
          (\<nexists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> n + Suc k) \<and>
          (reaching_paths_up_to_depth M (set targets) (nexts \<union> dones) assignment' k q = Some p \<longrightarrow>
           path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> n + Suc k)"
      using Suc.IH[OF p1 p2 p3 p4 p5] by auto

    moreover have "(q \<in> nexts \<union> dones \<longrightarrow> reaching_paths_up_to_depth M nexts dones assignment (Suc k) q = assignment q)"
    proof -
      have "\<And> q . (q \<in> set targets \<union> (nexts \<union> dones) \<Longrightarrow> reaching_paths_up_to_depth M (set targets) (nexts \<union> dones) assignment' k q = assignment' q)"
        using Suc.IH[OF p1 p2 p3 p4 p5] by auto
      moreover have "\<And> q . assignment q \<noteq> assignment' q \<Longrightarrow> q \<in> ?nexts'"
        unfolding d4
        by (metis (no_types) map_upds_apply_nontin)
      ultimately show ?thesis
        unfolding d5
        by (metis (mono_tags, lifting) Un_iff mem_Collect_eq p1 p2)
    qed
    ultimately show ?case
      unfolding d5 by blast
  qed

  then show "((reaching_paths_up_to_depth M nexts dones assignment k) q = None) = (\<nexists>p . path M (initial M) p \<and> target (initial M) p = q \<and> length p \<le> n+k)"
        and "((reaching_paths_up_to_depth M nexts dones assignment k) q = Some p) \<Longrightarrow> path M (initial M) p \<and> target (initial M) p = q \<and> length p \<le> n+k"
        and "q \<in> nexts \<union> dones \<Longrightarrow> (reaching_paths_up_to_depth M nexts dones assignment k) q = assignment q"
    by blast+
qed

fun get_state_cover_assignment :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> ('a,'b,'c) state_cover_assignment" where
  "get_state_cover_assignment M = (let
      path_assignments = reaching_paths_up_to_depth M {initial M} {} [initial M \<mapsto> []] (size M -1)
    in (\<lambda> q . case path_assignments q of Some p \<Rightarrow> p_io p | None \<Rightarrow> []))"

lemma get_state_cover_assignment_is_state_cover_assignment :
  "is_state_cover_assignment M (get_state_cover_assignment M)"
  unfolding is_state_cover_assignment.simps
proof

  define path_assignments where "path_assignments = reaching_paths_up_to_depth M {initial M} {} [initial M \<mapsto> []] (size M -1)"
  then have *:"\<And> q . get_state_cover_assignment M q = (case path_assignments q of Some p \<Rightarrow> p_io p | None \<Rightarrow> [])"
    by auto

  have c1: " {FSM.initial M} =
    {q. (\<exists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p = 0) \<and>
      (\<nexists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p < 0)}"
    by auto
  have c2:  "{} = {q. \<exists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p < 0}"
    by auto
  have c3: "(\<And>q. ([FSM.initial M \<mapsto> []] q = None) =
        (\<nexists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> 0))" by auto
  have c4: "(\<And>q p. [FSM.initial M \<mapsto> []] q = Some p \<Longrightarrow>
          path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> 0)"
    by (metis (no_types, lifting) c3 le_zero_eq length_0_conv map_upd_Some_unfold option.discI)
  have c5: "dom [FSM.initial M \<mapsto> []] = {FSM.initial M} \<union> {}"
    by simp

  have p1: "\<And> q . (path_assignments q = None) =
                   (\<nexists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> (FSM.size M - 1))"
   and p2: "\<And> q p . path_assignments q = Some p \<Longrightarrow>
                     path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> (FSM.size M - 1)"
   and p3: "path_assignments (initial M) = Some []"
    unfolding \<open>path_assignments = reaching_paths_up_to_depth M {initial M} {} [initial M \<mapsto> []] (size M -1)\<close>
    using reaching_paths_up_to_depth_set[OF c1 c2 c3 c4 c5] by auto

  show "get_state_cover_assignment M (FSM.initial M) = []"
    unfolding * p3 by auto

  show "\<forall>q\<in>reachable_states M. q \<in> io_targets M (get_state_cover_assignment M q) (FSM.initial M)"
  proof
    fix q assume "q \<in> reachable_states M"
    then have "q \<in> reachable_k M (FSM.initial M) (FSM.size M - 1)"
      using reachable_k_states by metis
    then obtain p where "target (initial M) p = q" and "path M (initial M) p" and "length p \<le> size M - 1"
      by auto
    then have "path_assignments q \<noteq> None"
      using p1 by fastforce
    then obtain p' where "get_state_cover_assignment M q = p_io p'"
                     and "path M (FSM.initial M) p'" and "target (FSM.initial M) p' = q"
      using p2 unfolding * by force
    then show "q \<in> io_targets M (get_state_cover_assignment M q) (initial M)"
      unfolding io_targets.simps unfolding \<open>get_state_cover_assignment M q = p_io p'\<close> by blast
  qed
qed

subsection \<open>Computing Reachable States via State Cover Computation\<close>

lemma restrict_to_reachable_states[code]:
  "restrict_to_reachable_states M = (let
      path_assignments = reaching_paths_up_to_depth M {initial M} {} [initial M \<mapsto> []] (size M -1)
    in filter_states M (\<lambda> q . path_assignments q \<noteq> None))"
proof -
  define path_assignments where "path_assignments = reaching_paths_up_to_depth M {initial M} {} [initial M \<mapsto> []] (size M -1)"
  then have *: "(let
      path_assignments = reaching_paths_up_to_depth M {initial M} {} [initial M \<mapsto> []] (size M -1)
    in filter_states M (\<lambda> q . path_assignments q \<noteq> None)) = filter_states M (\<lambda> q . path_assignments q \<noteq> None)"
    by simp

  have c1: " {FSM.initial M} =
    {q. (\<exists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p = 0) \<and>
      (\<nexists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p < 0)}"
    by auto
  have c2:  "{} = {q. \<exists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p < 0}"
    by auto
  have c3: "(\<And>q. ([FSM.initial M \<mapsto> []] q = None) =
        (\<nexists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> 0))" by auto
  have c4: "(\<And>q p. [FSM.initial M \<mapsto> []] q = Some p \<Longrightarrow>
          path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> 0)"
    by (metis (no_types, lifting) c3 le_zero_eq length_0_conv map_upd_Some_unfold option.discI)
  have c5: "dom [FSM.initial M \<mapsto> []] = {FSM.initial M} \<union> {}"
    by simp

  have p1: "\<And> q . (path_assignments q = None) =
                   (\<nexists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> (FSM.size M - 1))"
   and p2: "\<And> q p . path_assignments q = Some p \<Longrightarrow>
                     path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> (FSM.size M - 1)"
   and p3: "path_assignments (initial M) = Some []"
    unfolding \<open>path_assignments = reaching_paths_up_to_depth M {initial M} {} [initial M \<mapsto> []] (size M -1)\<close>
    using reaching_paths_up_to_depth_set[OF c1 c2 c3 c4 c5] by auto

  have "\<And> q . path_assignments q \<noteq> None \<longleftrightarrow> q \<in> reachable_states M"
  proof
    show "\<And>q. path_assignments q \<noteq> None \<Longrightarrow> q \<in> reachable_states M"
      using p2 unfolding reachable_states_def
      by blast
    show "\<And>q. q \<in> reachable_states M \<Longrightarrow> path_assignments q \<noteq> None"
    proof -
      fix q assume "q \<in> reachable_states M"
      then have "q \<in> reachable_k M (FSM.initial M) (FSM.size M - 1)"
        using reachable_k_states by metis
      then obtain p where "target (initial M) p = q" and "path M (initial M) p" and "length p \<le> size M - 1"
        by auto
      then show "path_assignments q \<noteq> None"
        using p1 by fastforce
    qed
  qed
  then show ?thesis
    unfolding restrict_to_reachable_states.simps * by simp
qed

declare [[code drop: reachable_states]]
lemma reachable_states_refined[code] :
  "reachable_states M = (let
      path_assignments = reaching_paths_up_to_depth M {initial M} {} [initial M \<mapsto> []] (size M -1)
    in Set.filter (\<lambda> q . path_assignments q \<noteq> None) (states M))"
proof -
  define path_assignments where "path_assignments = reaching_paths_up_to_depth M {initial M} {} [initial M \<mapsto> []] (size M -1)"
  then have *: "(let
      path_assignments = reaching_paths_up_to_depth M {initial M} {} [initial M \<mapsto> []] (size M -1)
    in Set.filter (\<lambda> q . path_assignments q \<noteq> None) (states M)) = Set.filter (\<lambda> q . path_assignments q \<noteq> None) (states M)"
    by simp

  have c1: " {FSM.initial M} =
    {q. (\<exists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p = 0) \<and>
      (\<nexists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p < 0)}"
    by auto
  have c2:  "{} = {q. \<exists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p < 0}"
    by auto
  have c3: "(\<And>q. ([FSM.initial M \<mapsto> []] q = None) =
        (\<nexists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> 0))" by auto
  have c4: "(\<And>q p. [FSM.initial M \<mapsto> []] q = Some p \<Longrightarrow>
          path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> 0)"
    by (metis (no_types, lifting) c3 le_zero_eq length_0_conv map_upd_Some_unfold option.discI)
  have c5: "dom [FSM.initial M \<mapsto> []] = {FSM.initial M} \<union> {}"
    by simp

  have p1: "\<And> q . (path_assignments q = None) =
                   (\<nexists>p. path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> (FSM.size M - 1))"
   and p2: "\<And> q p . path_assignments q = Some p \<Longrightarrow>
                     path M (FSM.initial M) p \<and> target (FSM.initial M) p = q \<and> length p \<le> (FSM.size M - 1)"
   and p3: "path_assignments (initial M) = Some []"
    unfolding \<open>path_assignments = reaching_paths_up_to_depth M {initial M} {} [initial M \<mapsto> []] (size M -1)\<close>
    using reaching_paths_up_to_depth_set[OF c1 c2 c3 c4 c5] by auto

  have "\<And> q . path_assignments q \<noteq> None \<longleftrightarrow> q \<in> reachable_states M"
  proof
    show "\<And>q. path_assignments q \<noteq> None \<Longrightarrow> q \<in> reachable_states M"
      using p2 unfolding reachable_states_def
      by blast
    show "\<And>q. q \<in> reachable_states M \<Longrightarrow> path_assignments q \<noteq> None"
    proof -
      fix q assume "q \<in> reachable_states M"
      then have "q \<in> reachable_k M (FSM.initial M) (FSM.size M - 1)"
        using reachable_k_states by metis
      then obtain p where "target (initial M) p = q" and "path M (initial M) p" and "length p \<le> size M - 1"
        by auto
      then show "path_assignments q \<noteq> None"
        using p1 by fastforce
    qed
  qed
  then show ?thesis
    unfolding * using reachable_state_is_state by force
qed

lemma minimal_sequence_to_failure_from_state_cover_assignment_ob :
  assumes "L M \<noteq> L I"
  and     "is_state_cover_assignment M V"
  and     "(L M \<inter> (V ` reachable_states M)) = (L I \<inter> (V ` reachable_states M))"
obtains ioT ioX where "ioT \<in> (V ` reachable_states M)"
                  and "ioT @ ioX \<in> (L M - L I) \<union> (L I - L M)"
                  and "\<And> io q . q \<in> reachable_states M \<Longrightarrow> (V q)@io \<in> (L M - L I) \<union> (L I - L M) \<Longrightarrow> length ioX \<le> length io"
proof -

  let ?exts = "{io . \<exists> q \<in> reachable_states M . (V q)@io \<in> (L M - L I) \<union> (L I - L M)}"
  define exMin where exMin: "exMin = arg_min length (\<lambda> io . io \<in> ?exts)"

  have "V (initial M) = []"
    using assms(2) by auto
  moreover have "\<exists> io . io \<in> (L M - L I) \<union> (L I - L M)"
    using assms(1) by blast
  ultimately have "?exts \<noteq> {}"
    using reachable_states_initial by (metis (mono_tags, lifting) append_self_conv2 empty_iff mem_Collect_eq)
  then have "exMin \<in> ?exts \<and> (\<forall> io' . io' \<in> ?exts \<longrightarrow> length exMin \<le> length io')"
    using exMin arg_min_nat_lemma by (metis (no_types, lifting) all_not_in_conv)
  then show ?thesis
    using that by blast
qed

end


theory Submission
  imports Defs
begin

fun compl' :: "intervals \<Rightarrow> intervals" where
  "compl' [[l,\<infinity>)] = []"
| "compl' [[l,r)] = [[r, \<infinity>)]"
| "compl' ([l1,r1)#[l2,r2)#is) = [r1, l2)#compl' ([l2,r2)#is)"
| "compl' [] = []"

fun compl where
  "compl [] = [[0, \<infinity>)]"
| "compl ([l, r)#is) = (if l = 0 then [] else [[0, l)]) @ compl' ([l, r)#is)"
\<comment> \<open>Simon: Needed 15 min for reading & def.\<close>

lemma inv'_anti_mono:
  "inv' k' ins" if "inv' k ins" "k \<ge> k'"
  using that
  apply (induction ins rule: inv'.induct)
     apply auto
  done

lemma inv'_tighten:
  "inv' l ([l, r)#ins)" if "inv' k ([l, r)#ins)"
  using that
  using inv'.elims(3) by fastforce

lemma compl'_inv':
  assumes "inv' k ins"
  shows "inv' (Suc k) (compl' ins)"
  using assms
  apply (induction ins arbitrary: k rule: compl'.induct)
      apply (simp_all add: inv_def)
  apply (auto simp add: inv_def)
  subgoal
    using inv'.elims(2) by fastforce
(*
  subgoal premises prems
    using prems(2-) apply -
    apply (frule prems(1))
    apply (rule inv'_anti_mono, assumption)
    using inv'_anti_mono
    oops
*)
    by (smt (verit) Suc_le_eq compl'.elims interval.inject inv'.elims(3) inv'.simps(3) inv'.simps(4) list.discI list.inject)
  (*
  by (smt (z3) Suc_le_eq compl'.elims interval.inject inv'.simps(1) inv'.simps(2) inv'.simps(3) inv'.simps(4) list.inject)
*)
(*
    by (smt (z3) Suc_le_eq compl'.elims compl'.simps(1) enat.inject interval.inject inv'.elims(1) inv'.simps(1) inv'.simps(2) inv'.simps(4) list.inject zero_le)
*)

(*
lemma compl'_inv:
  assumes "inv ins"
  shows "inv (compl' ins)"
  using assms compl'_inv' by (simp add: inv_def)
*)

lemma [simp]:
  "set_of [i] = set_of_i i"
  unfolding set_of_def by simp

lemma set_of_cons':
  "fold (\<union>) (map set_of_i xs) S = S \<union> fold (\<union>) (map set_of_i xs) {}"
  unfolding set_of_def
  apply (induction xs arbitrary: S)
   apply (simp add: set_of_def)
  by (smt (z3) Un_assoc Un_left_commute fold_simps(2) list.simps(9))

lemma set_of_cons:
  "set_of (a # xs) = set_of_i a \<union> set_of xs"
  unfolding set_of_def
  apply simp
  apply (rule set_of_cons')
  done

lemma Un_Diff_R:
  assumes "A \<inter> C = {}"
  shows "A \<union> B - C = A \<union> (B - C)"
  using assms
  by blast

lemma inv'_inf:
  assumes "inv' k ([l,\<infinity>) # ins)"
  shows "ins = []"
  using assms
  apply (induction "[l,\<infinity>)#ins" arbitrary: l ins rule: inv'.induct)
   apply auto
  done

lemma compl'_lb':
  assumes "inv' k ([l,r)#ins)"
  shows "set_of (compl' ([l,r)#ins)) \<subseteq> {r..}"
  using assms
  apply (induction "[l,r)#ins" arbitrary: k l r ins rule: compl'.induct)
   apply (auto simp add: set_of_def; fail)
  apply (simp add: set_of_cons)
  apply rule
   apply force
  subgoal for l1 r1 l2 r2 "is" k
    apply (cases r2)
     apply simp
     apply force
    apply simp
    apply (auto dest!: inv'_inf simp: set_of_def)
    done
  done

lemma compl'_lb:
  assumes "inv' k ([l,r)#ins)"
  shows "set_of (compl' ([l,r)#ins)) \<subseteq> (case r of \<infinity> \<Rightarrow> {} | enat r \<Rightarrow> {r..})"
  using assms
  apply (cases r)
   apply simp
   apply (rule compl'_lb')
   apply force
  apply simp
  apply (drule inv'_inf)
  apply simp
  done

lemma interval_aux:
  fixes l r1 r2 :: nat
  assumes "l < r1" "r1 < l2"
  shows "{0..<l} \<union> {r1..<l2} = {0..<l2} - {l..<r1}"
  using assms by auto

lemma compl'_correct:
  assumes "inv' k ([l,r)#ins)"
  shows "set_of (compl' ([l,r)#ins)) \<union> {0..<l} = -set_of ([l,r)#ins)"
  using assms
  apply (induction ins arbitrary: k l r)
  subgoal for k l r
   apply (cases "[[l,r)]" rule: compl'.cases)
       apply (auto simp add: set_of_def; fail)
      apply (auto simp add: set_of_def; fail)
     apply (auto simp add: set_of_def; fail)
    apply (auto simp add: set_of_def; fail)
    apply (auto simp add: set_of_def; fail)
    done
  subgoal for a ins k l r
    apply (cases "[l,r) # a # ins" rule: compl'.cases)
        apply (auto simp add: set_of_def; fail)
       apply (auto simp add: set_of_def; fail)
    defer
      apply (auto simp add: set_of_def; fail)
     apply (auto simp add: set_of_def; fail)
    apply simp
    subgoal premises prems for r1 l2 r2

      using prems(1)[of "Suc r1" "l2" "r2"] prems(2-)
      apply simp
      apply (subst set_of_cons)
      apply simp
      apply (subgoal_tac "
  {r1..<l2} \<union> set_of (compl' ([l2,r2) # ins)) \<union> {0..<l} = (set_of (compl' ([l2,r2) # ins)) \<union> {0..<l2}) - {l..<r1}")
      apply simp
       apply (simp add: set_of_cons)
       apply blast
      apply (subgoal_tac "
  {r1..<l2} \<union> {0..<l} = {0..<l2} - {l..<r1}")
       apply (subst Un_commute)
       apply (subst Un_assoc)
       apply (subst Un_Diff_R)
      subgoal
        apply (elim conjE)
        thm compl'_lb
        apply (frule compl'_lb)
        apply (auto split: enat.split_asm)
        done
       apply simp
      apply (subst Un_commute)
      apply (rule interval_aux)
       apply auto
      thm inv'.cases
      apply (cases r2)
       apply simp
      apply simp
      apply (frule inv'_inf)
      apply auto
      done
    done
  done

lemma compl_set_of:
  assumes "inv ins"
  shows "set_of (compl ins) = -set_of ins"
  apply (cases ins rule: compl.cases)
   apply simp
  apply simp
  using assms[unfolded inv_def]
  apply simp
  apply (frule compl'_correct)
  apply (auto simp: set_of_cons)
  done

\<comment> \<open>Simon: Needed ~2h including def.\<close>
theorem compl_inv:
  assumes "inv ins"
  shows "inv (compl ins)"
   apply -
  subgoal
    using assms
    unfolding inv_def
    apply (cases ins rule: compl.cases)
     apply simp
    apply (auto intro: compl'_inv')
    defer
    thm compl'_inv'
    apply (rule compl'_inv')
    thm inv'_tighten
     apply (erule inv'_tighten)
    apply (drule compl'_inv')
    apply (erule inv'_anti_mono)
    apply rule
    done
  done

end