(*
  File:      Stalnaker_Logic.thy
  Author:    Laura Gamboa Guzman

  This work is a formalization of Stalnaker's epistemic logic
  and its soundness and completeness theorems, as well as the
  equivalence between the axiomatization of S4 available in the Epistemic
  Logic theory and the topological one.
  It builds on the Epistemic_Logic theory by A.H. From.
*)

theory Stalnaker_Logic
  imports "Epistemic_Logic.Epistemic_Logic"

begin

section \<open>Utility\<close>

subsection \<open>Some properties of Normal Modal Logics\<close>

lemma duality_taut: \<open>tautology (((K i p) \<^bold>\<longrightarrow> K i (\<^bold>\<not>q))\<^bold>\<longrightarrow> ((L i q) \<^bold>\<longrightarrow> (\<^bold>\<not> K i p)))\<close>
  by force

lemma K_imp_trans:
  assumes \<open>A \<turnstile> (p \<^bold>\<longrightarrow> q)\<close>  \<open>A \<turnstile> (q \<^bold>\<longrightarrow> r)\<close>
  shows  \<open>A \<turnstile> (p \<^bold>\<longrightarrow> r)\<close>
proof -
  have \<open>tautology  ((p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> ( (q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow>  (p \<^bold>\<longrightarrow> r)))\<close>
    by fastforce
  then show ?thesis
    by (meson A1 R1 assms(1) assms(2))
qed

lemma K_imp_trans':
  assumes \<open>A \<turnstile> (q \<^bold>\<longrightarrow> r)\<close>
  shows  \<open>A \<turnstile> ((p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> (p \<^bold>\<longrightarrow> r))\<close>
proof -
  have \<open>tautology  ((q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> ((p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> (p \<^bold>\<longrightarrow> r)))\<close>
    by fastforce
  then show ?thesis
    using A1 R1 assms by blast
qed

lemma K_imply_multi:
  assumes \<open>A \<turnstile> (a \<^bold>\<longrightarrow> b)\<close> and \<open>A \<turnstile> (a \<^bold>\<longrightarrow> c)\<close>
  shows \<open>A \<turnstile> (a \<^bold>\<longrightarrow> (b\<^bold>\<and>c))\<close>
proof -
  have \<open>tautology ((a\<^bold>\<longrightarrow>b)\<^bold>\<longrightarrow>(a\<^bold>\<longrightarrow>c)\<^bold>\<longrightarrow>(a\<^bold>\<longrightarrow>(b\<^bold>\<and>c)))\<close>
    by force
  then have \<open>A \<turnstile> ((a\<^bold>\<longrightarrow>b)\<^bold>\<longrightarrow>(a\<^bold>\<longrightarrow>c)\<^bold>\<longrightarrow>(a\<^bold>\<longrightarrow>(b\<^bold>\<and>c)))\<close>
    using A1 by blast
  then have \<open>A \<turnstile> ((a\<^bold>\<longrightarrow>c)\<^bold>\<longrightarrow>(a\<^bold>\<longrightarrow>(b\<^bold>\<and>c)))\<close>
    using assms(1) R1 by blast
  then show ?thesis
    using assms(2) R1 by blast
qed

lemma K_multi_imply:
  assumes \<open>A \<turnstile> (a \<^bold>\<longrightarrow> b \<^bold>\<longrightarrow> c)\<close>
  shows \<open>A \<turnstile> ((a\<^bold>\<and>b) \<^bold>\<longrightarrow> c)\<close>
proof -
  have \<open>tautology ((a \<^bold>\<longrightarrow> b \<^bold>\<longrightarrow> c) \<^bold>\<longrightarrow> ((a\<^bold>\<and>b) \<^bold>\<longrightarrow> c))\<close>
    by force
  then have \<open>A \<turnstile> ((a \<^bold>\<longrightarrow> b \<^bold>\<longrightarrow> c) \<^bold>\<longrightarrow> ((a\<^bold>\<and>b) \<^bold>\<longrightarrow> c))\<close>
    using A1 by blast
  then show ?thesis
    using assms R1 by blast
qed

lemma K_thm: \<open>A \<turnstile> ((K i p) \<^bold>\<and> (L i q) \<^bold>\<longrightarrow> L i (p \<^bold>\<and> q))\<close>
proof -
  have \<open>tautology (p \<^bold>\<longrightarrow> (\<^bold>\<not>(p \<^bold>\<and> q)) \<^bold>\<longrightarrow> \<^bold>\<not> q)\<close>
    by force
  then have \<open>A \<turnstile> (p \<^bold>\<longrightarrow> (\<^bold>\<not>(p \<^bold>\<and> q)) \<^bold>\<longrightarrow> \<^bold>\<not> q)\<close>
    by (simp add: A1)
  then have \<open>A \<turnstile> ((K i p) \<^bold>\<longrightarrow> K i ((\<^bold>\<not>(p \<^bold>\<and> q)) \<^bold>\<longrightarrow> \<^bold>\<not> q))\<close>
        and \<open>A \<turnstile> (K i ((\<^bold>\<not>(p \<^bold>\<and> q)) \<^bold>\<longrightarrow> \<^bold>\<not> q) \<^bold>\<longrightarrow> K i (\<^bold>\<not>(p \<^bold>\<and> q)) \<^bold>\<longrightarrow> K i (\<^bold>\<not> q))\<close>
     apply (simp add: K_map)
    by (meson K_A2')
  then have \<open>A \<turnstile> ((K i p) \<^bold>\<longrightarrow> K i (\<^bold>\<not>(p \<^bold>\<and> q)) \<^bold>\<longrightarrow> K i (\<^bold>\<not> q))\<close>
    using K_imp_trans by blast
  then have \<open>A \<turnstile> ((K i p) \<^bold>\<longrightarrow> L i (q) \<^bold>\<longrightarrow> L i (p \<^bold>\<and> q))\<close>
    by (metis AK.simps K_imp_trans duality_taut)
  then show ?thesis
    by (simp add: K_multi_imply)
qed

primrec conjunct :: \<open>'i fm list \<Rightarrow> 'i fm\<close> where
  \<open>conjunct [] = \<^bold>\<top>\<close>
| \<open>conjunct (p#ps) = (p \<^bold>\<and> conjunct ps)\<close>

lemma imply_conjunct: \<open>tautology ((imply G p) \<^bold>\<longrightarrow> ((conjunct G) \<^bold>\<longrightarrow> p))\<close>
  apply(induction G)
  apply simp
  by force

lemma conjunct_imply: \<open>tautology (((conjunct G) \<^bold>\<longrightarrow> p) \<^bold>\<longrightarrow>(imply G p))\<close>
  by (induct G) simp_all

lemma K_imply_conjunct:
  assumes \<open>A \<turnstile> imply G p\<close>
  shows \<open>A \<turnstile> ((conjunct G) \<^bold>\<longrightarrow> p)\<close>
  using A1 R1 assms imply_conjunct by blast

lemma K_conjunct_imply:
  assumes \<open>A \<turnstile> ((conjunct G) \<^bold>\<longrightarrow> p)\<close>
  shows \<open>A \<turnstile> imply G p\<close>
  using A1 R1 assms conjunct_imply by blast

lemma K_conj_imply_factor:
  fixes A :: \<open>('i fm \<Rightarrow> bool)\<close>
  shows \<open>A \<turnstile> ((((K i p) \<^bold>\<and> (K i q)) \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow>((K i (p \<^bold>\<and> q)) \<^bold>\<longrightarrow> r))\<close>
proof -
  have *: \<open>A \<turnstile> ((K i (p \<^bold>\<and> q)) \<^bold>\<longrightarrow> ((K i p) \<^bold>\<and> (K i q)))\<close>
  proof (rule ccontr)
    assume \<open>\<not> A \<turnstile> ((K i (p \<^bold>\<and> q)) \<^bold>\<longrightarrow> ((K i p) \<^bold>\<and> (K i q)))\<close>
    then have \<open>consistent A {\<^bold>\<not>((K i (p \<^bold>\<and> q)) \<^bold>\<longrightarrow> ((K i p) \<^bold>\<and> (K i q)))}\<close>
      by (metis imply.simps(1) inconsistent_imply insert_is_Un list.set(1))
    let ?V = \<open>Extend A {\<^bold>\<not>((K i (p \<^bold>\<and> q)) \<^bold>\<longrightarrow> ((K i p) \<^bold>\<and> (K i q)))}\<close>
    let ?M = \<open>\<lparr>\<W> = mcss A, \<K> = reach A, \<pi> = pi\<rparr>\<close>
    have \<open>?V \<in> \<W> ?M \<and> ?M, ?V \<Turnstile> \<^bold>\<not>((K i (p \<^bold>\<and> q)) \<^bold>\<longrightarrow> ((K i p) \<^bold>\<and> (K i q)))\<close>
      using canonical_model \<open>consistent A {\<^bold>\<not> (K i (p \<^bold>\<and> q) \<^bold>\<longrightarrow> K i p \<^bold>\<and> K i q)}\<close>
            insert_iff mem_Collect_eq by fastforce
    then have o: \<open>?M, ?V \<Turnstile> ((K i (p \<^bold>\<and> q)) \<^bold>\<and> \<^bold>\<not>((K i p) \<^bold>\<and> (K i q)))\<close>
      by auto
    then have \<open>?M, ?V \<Turnstile> (K i (p \<^bold>\<and> q))\<close> \<open>(?M, ?V \<Turnstile> \<^bold>\<not>(K i p)) \<or> (?M, ?V \<Turnstile> \<^bold>\<not>(K i q))\<close>
      by auto
    then have \<open>\<forall> U \<in> \<W> ?M \<inter> \<K> ?M i ?V. ?M, U \<Turnstile>(p \<^bold>\<and> q)\<close>
              \<open>\<exists> U \<in> \<W> ?M \<inter> \<K> ?M i ?V. ?M, U \<Turnstile> ((\<^bold>\<not>p) \<^bold>\<or> (\<^bold>\<not>q))\<close>
      using o by auto
    then show False
      by simp
  qed
  then have \<open>A \<turnstile> (((K i (p \<^bold>\<and> q)) \<^bold>\<longrightarrow> ((K i p) \<^bold>\<and> (K i q))) \<^bold>\<longrightarrow>
                   ((((K i p) \<^bold>\<and> (K i q)) \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> ((K i (p \<^bold>\<and> q)) \<^bold>\<longrightarrow> r)))\<close>
    by (simp add: A1)
  then show ?thesis
    using "*" R1 by blast
qed

lemma K_conjunction_in: \<open>A \<turnstile> (K i (p \<^bold>\<and> q) \<^bold>\<longrightarrow> ((K i p) \<^bold>\<and> K i q))\<close>
proof -
  have o1: \<open>A \<turnstile> ((p\<^bold>\<and>q) \<^bold>\<longrightarrow> p)\<close> and o2: \<open>A \<turnstile> ((p\<^bold>\<and>q) \<^bold>\<longrightarrow> q)\<close>
    apply(simp add: A1)
    by (simp add: A1)
  then have c1: \<open>A \<turnstile> (K i (p \<^bold>\<and> q) \<^bold>\<longrightarrow> K i q)\<close> and c2: \<open>A \<turnstile> (K i (p \<^bold>\<and> q) \<^bold>\<longrightarrow> K i p)\<close>
    apply (simp add: K_map o2)
    by (simp add: K_map o1)
  then show ?thesis
    by (simp add: K_imply_multi)
qed

lemma K_conjunction_in_mult:  \<open>A \<turnstile> ((K i (conjunct G)) \<^bold>\<longrightarrow> conjunct (map (K i) G))\<close>
proof (induct G)
  case Nil
  then show ?case
    by (simp add: A1)
  case (Cons a G)
  then have \<open>A \<turnstile> ((K i (conjunct (a#G))) \<^bold>\<longrightarrow> (K i (a \<^bold>\<and> conjunct G)))\<close>
        and  \<open>A \<turnstile> ((K i (a \<^bold>\<and> conjunct G)) \<^bold>\<longrightarrow> ((K i a) \<^bold>\<and> K i (conjunct G)))\<close>
    apply (simp add: A1)
    by (metis K_conjunction_in)
  then have o1: \<open>A \<turnstile> ((K i (conjunct (a#G))) \<^bold>\<longrightarrow> ((K i a) \<^bold>\<and> K i (conjunct G)))\<close>
    using K_imp_trans by blast
  then have \<open>A \<turnstile> (((K i a) \<^bold>\<and> K i (conjunct G)) \<^bold>\<longrightarrow> K i a)\<close>
        and o2: \<open>A \<turnstile> (((K i a) \<^bold>\<and> K i (conjunct G)) \<^bold>\<longrightarrow> conjunct (map (K i) G))\<close>
    apply (simp add: A1)
    by (metis Cons.hyps K_imply_Cons K_multi_imply imply.simps(1) imply.simps(2))
  then have \<open>A \<turnstile> (((K i a) \<^bold>\<and> K i (conjunct G)) \<^bold>\<longrightarrow> (K i a) \<^bold>\<and> conjunct (map (K i) G))\<close>
    using K_imply_multi by blast
  then show ?case
    using K_imp_trans o1 by auto
qed

lemma K_conjunction_out: \<open>A \<turnstile> ((K i p) \<^bold>\<and> (K i q) \<^bold>\<longrightarrow> K i (p \<^bold>\<and> q))\<close>
proof -
  have \<open>A \<turnstile> (p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> p\<^bold>\<and>q)\<close>
    by (simp add: A1)
  then have \<open>A \<turnstile> K i (p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> p\<^bold>\<and>q)\<close>
    by (simp add: R2)
  then have \<open>A \<turnstile> ((K i p) \<^bold>\<longrightarrow> K i (q \<^bold>\<longrightarrow> p\<^bold>\<and>q))\<close>
    by (simp add: K_map \<open>A \<turnstile> (p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> p \<^bold>\<and> q)\<close>)
  then have \<open>A \<turnstile> ((K i p) \<^bold>\<longrightarrow> (K i q) \<^bold>\<longrightarrow> K i (p\<^bold>\<and>q))\<close>
    by (meson K_A2' K_imp_trans)
  then show ?thesis
    using K_multi_imply by blast
qed

lemma K_conjunction_out_mult: \<open>A \<turnstile> (conjunct (map (K i) G) \<^bold>\<longrightarrow> (K i (conjunct G)))\<close>
proof (induct G)
  case Nil
  then show ?case
    by (metis A1 K_imply_conjunct Nil_is_map_conv R2 conjunct.simps(1) eval.simps(5) imply.simps(1))
  case (Cons a G)
  then have \<open>A \<turnstile> ((conjunct (map (K i) (a#G))) \<^bold>\<longrightarrow> ((K i a) \<^bold>\<and> conjunct (map (K i) G)))\<close>
    by (simp add: A1)
  then have *: \<open>A \<turnstile> (((K i a) \<^bold>\<and> conjunct (map (K i) G))\<^bold>\<longrightarrow> (K i a) \<^bold>\<and> K i (conjunct G))\<close>
    by (metis Cons.hyps K_imply_Cons K_imply_head K_imply_multi K_multi_imply imply.simps(1) imply.simps(2))
  then have \<open>A \<turnstile> (((K i a) \<^bold>\<and> K i (conjunct G))\<^bold>\<longrightarrow> K i (conjunct (a#G)))\<close>
    by (simp add: K_conjunction_out)
  then show ?case
    using "*" K_imp_trans by auto
qed

subsection \<open>More on mcs's properties\<close>

lemma mcs_conjunction:
  assumes \<open>consistent A V\<close> and \<open>maximal A V\<close>
  shows \<open>p \<in> V \<and> q \<in> V \<longrightarrow> (p \<^bold>\<and> q) \<in> V\<close>
proof -
  have \<open>tautology (p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> (p\<^bold>\<and>q))\<close>
    by force
  then have \<open>(p \<^bold>\<longrightarrow> q \<^bold>\<longrightarrow> (p\<^bold>\<and>q)) \<in> V\<close>
    using A1 assms(1) assms(2) deriv_in_maximal by blast
  then have \<open>p \<in> V \<longrightarrow> (q \<^bold>\<longrightarrow> (p\<^bold>\<and>q)) \<in> V\<close>
    by (meson assms(1) assms(2) consequent_in_maximal)
  then show ?thesis
    using assms(1) assms(2) consequent_in_maximal by blast
qed

lemma mcs_conjunction_mult:
 assumes \<open>consistent A V\<close> and \<open>maximal A V\<close>
  shows \<open>(set (S :: ('i fm list)) \<subseteq> V \<and> finite (set S)) \<longrightarrow> (conjunct S) \<in> V\<close>
proof(induct S)
  case Nil
  then show ?case
    by (metis K_Boole assms(1) assms(2) conjunct.simps(1) consistent_def inconsistent_subset maximal_def)
  case (Cons a S)
  then have \<open>set S \<subseteq> set (a#S)\<close>
    by (meson set_subset_Cons)
  then have c1: \<open> set (a # S) \<subseteq> V \<and> finite (set (a # S)) \<longrightarrow> conjunct (S) \<in> V \<and> a \<in> V\<close>
    using Cons by fastforce
  then have \<open> conjunct (S) \<in> V \<and> a \<in> V \<longrightarrow> (conjunct (a#S)) \<in> V \<close>
    using assms(1) assms(2) mcs_conjunction by auto
  then show ?case
    using c1 by fastforce
qed

lemma reach_dualK:
  assumes \<open>consistent A V\<close> \<open>maximal A V\<close>
    and \<open>consistent A W\<close> \<open>maximal A W\<close> \<open>W \<in> reach A i V\<close>
  shows \<open>\<forall>p. p \<in> W \<longrightarrow> (L i p) \<in> V\<close>
proof (rule ccontr)
  assume \<open>\<not> (\<forall>p. p \<in> W \<longrightarrow> (L i p) \<in> V)\<close>
  then obtain p' where *: \<open>p' \<in> W \<and> (L i p') \<notin> V\<close>
    by presburger
  then have \<open>(\<^bold>\<not> L i p') \<in> V\<close>
    using assms(1) assms(2) assms(3) assms(4) assms(5) exactly_one_in_maximal by blast
  then have \<open>K i (\<^bold>\<not> p') \<in> V\<close>
    using assms(1) assms(2) exactly_one_in_maximal by blast
  then have \<open>(\<^bold>\<not> p') \<in> W\<close>
    using assms(5) by blast
  then show False
    by (meson "*" assms(3) assms(4) exactly_one_in_maximal)
qed

lemma dual_reach:
  assumes \<open>consistent A V\<close> \<open>maximal A V\<close>
  shows \<open>(L i p) \<in> V \<longrightarrow> (\<exists> W. W \<in> reach A i V \<and> p \<in> W)\<close>
proof -
  have \<open>(\<nexists>W. W \<in> {W. known V i \<subseteq> W} \<and> p \<in> W) \<longrightarrow> (\<forall>W. W \<in> {W. known V i \<subseteq> W} \<longrightarrow> (\<^bold>\<not>p) \<in> W)\<close>
    by blast
  then have \<open>(\<forall>W. W \<in> {W. known V i \<subseteq> W} \<longrightarrow> (\<^bold>\<not>p) \<in> W) \<longrightarrow> (\<forall> W. W \<in> reach A i V \<longrightarrow> (\<^bold>\<not>p) \<in> W)\<close>
    by fastforce
  then have \<open>(\<forall> W. W \<in> reach A i V \<longrightarrow> (\<^bold>\<not>p) \<in> W) \<longrightarrow> ((K i (\<^bold>\<not>p)) \<in> V)\<close>
    by blast
  then have \<open>((K i (\<^bold>\<not>p)) \<in> V) \<longrightarrow> (\<not>((L i p) \<in> V))\<close>
    using assms(1) assms(2) exactly_one_in_maximal by blast
  then have \<open>(\<nexists>W. W \<in> {W. known V i \<subseteq> W} \<and> p \<in> W) \<longrightarrow> \<not>((L i p) \<in> V)\<close>
    by blast
  then show ?thesis
    by blast
qed

section  \<open>Ax.2\<close>

definition weakly_directed :: \<open>('i, 's) kripke \<Rightarrow> bool\<close> where
  \<open>weakly_directed M \<equiv> \<forall>i. \<forall>s \<in> \<W> M. \<forall>t \<in> \<W> M. \<forall>r \<in> \<W> M.
     (r \<in> \<K> M i s \<and> t \<in> \<K> M i s)\<longrightarrow>(\<exists> u \<in> \<W> M. (u \<in> \<K> M i r \<and> u \<in> \<K> M i t))\<close>

inductive Ax_2 :: \<open>'i fm \<Rightarrow> bool\<close> where
  \<open>Ax_2 (\<^bold>\<not> K i (\<^bold>\<not> K i p) \<^bold>\<longrightarrow> K i (\<^bold>\<not> K i (\<^bold>\<not> p)))\<close>

subsection \<open>Soundness\<close>

theorem weakly_directed:
  assumes \<open>weakly_directed M\<close> \<open>w \<in> \<W> M\<close>
  shows \<open>M, w \<Turnstile> (L i (K i p) \<^bold>\<longrightarrow> K i (L i p))\<close>
proof
  assume \<open>M, w \<Turnstile> (L i (K i p))\<close>
  then have \<open>\<exists>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> K i p\<close>
    by simp
  then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. \<exists>u \<in> \<W> M \<inter> \<K> M i v. M, u \<Turnstile> p\<close>
    using \<open>weakly_directed M\<close> \<open>w \<in> \<W> M\<close> unfolding weakly_directed_def
    by (metis IntE IntI semantics.simps(6))
  then have \<open>\<forall>v \<in> \<W> M \<inter> \<K> M i w. M, v \<Turnstile> L i p\<close>
    by simp
  then show \<open>M, w \<Turnstile> K i (L i p)\<close>
    by simp
qed

lemma soundness_Ax_2: \<open>Ax_2 p \<Longrightarrow> weakly_directed M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
  by (induct p rule: Ax_2.induct) (meson weakly_directed)

subsection \<open>Imply completeness\<close>

lemma Ax_2_weakly_directed:
  fixes A :: \<open>'i fm \<Rightarrow> bool\<close>
  assumes \<open>\<forall>p. Ax_2 p \<longrightarrow> A p\<close> \<open>consistent A V\<close> \<open>maximal A V\<close>
    and \<open>consistent A W\<close> \<open>maximal A W\<close> \<open>consistent A U\<close> \<open>maximal A U\<close>
    and \<open>W \<in> reach A i V\<close> \<open>U \<in> reach A i V\<close>
  shows \<open>\<exists>X. (consistent A X) \<and> (maximal A X) \<and> X \<in> (reach A i W) \<inter> (reach A i U)\<close>
proof (rule ccontr)
  assume \<open>\<not> ?thesis\<close>
  let ?S = \<open>(known W i) \<union> (known U i)\<close>
  have \<open>\<not> consistent A ?S\<close>
    by (smt (verit, best) Int_Collect \<open>\<nexists>X. consistent A X \<and> maximal A X \<and> X \<in> {Wa. known W i \<subseteq> Wa} \<inter> {W. known U i \<subseteq> W}\<close> maximal_extension mem_Collect_eq sup.bounded_iff)
  then obtain S' where *: \<open>A \<turnstile> imply S' \<^bold>\<bottom>\<close> \<open>set S' \<subseteq> ?S\<close> \<open>finite (set S')\<close>
    unfolding consistent_def by blast
  let ?U = \<open>filter (\<lambda>p. p \<in> (known U i)) S'\<close>
  let ?W = \<open>filter (\<lambda>p. p \<in> (known W i)) S'\<close>
  let ?p = \<open>conjunct ?U\<close> and ?q = \<open>conjunct ?W\<close>
  have \<open>(set ?U) \<union> (set ?W) = (set S')\<close>
    using * by auto
  then have \<open>A \<turnstile> imply ?U (imply ?W \<^bold>\<bottom>)\<close>
    using K_imply_weaken imply_append
    by (metis (mono_tags, lifting) "*"(1) set_append subset_refl)
  then have \<open>A \<turnstile> (?p \<^bold>\<longrightarrow> (imply ?W \<^bold>\<bottom>))\<close>
    using K_imply_conjunct by blast
  then have \<open>tautology ((imply ?W \<^bold>\<bottom>) \<^bold>\<longrightarrow> (?q \<^bold>\<longrightarrow> \<^bold>\<bottom>))\<close>
    using imply_conjunct by blast
  then have \<open>A \<turnstile> ((imply ?W \<^bold>\<bottom>) \<^bold>\<longrightarrow> (?q \<^bold>\<longrightarrow> \<^bold>\<bottom>))\<close>
    using A1 by blast
  then have \<open>A \<turnstile> (?p \<^bold>\<longrightarrow> (?q \<^bold>\<longrightarrow> \<^bold>\<bottom>))\<close>
    using K_imp_trans \<open>A \<turnstile> (conjunct (filter (\<lambda>p. p \<in> known U i) S') \<^bold>\<longrightarrow> imply (filter (\<lambda>p. p \<in> known W i) S') \<^bold>\<bottom>)\<close>
    by blast
  then have o1: \<open>A \<turnstile> ((?p \<^bold>\<and> ?q) \<^bold>\<longrightarrow> \<^bold>\<bottom>)\<close>
    by (meson K_multi_imply)
  moreover have \<open>set ?U \<subseteq> (known U i)\<close> and \<open>set ?W \<subseteq> (known W i)\<close>
                and \<open>\<forall> p. p \<in> set ?U \<longrightarrow> (K i p) \<in> U\<close> and \<open>\<forall> p. p \<in> set ?W \<longrightarrow> (K i p) \<in> W\<close>
    by auto
  then have \<open>set (map (K i) ?U) \<subseteq> U\<close> and c1: \<open>set (map (K i) ?W) \<subseteq> W\<close>
     apply (metis (mono_tags, lifting) imageE set_map subsetI)
    by auto
  then have c2: \<open>conjunct (map (K i) ?U) \<in> U\<close> and c2': \<open>conjunct (map (K i) ?W) \<in> W\<close>
    using assms(6) assms(7) mcs_conjunction_mult apply blast
    using assms(4) assms(5) c1 mcs_conjunction_mult by blast
  then have \<open>((conjunct (map (K i) ?U)) \<^bold>\<longrightarrow> (K i ?p)) \<in> U\<close>
        and c3: \<open>((conjunct (map (K i) ?W)) \<^bold>\<longrightarrow> (K i ?q)) \<in> W\<close>
    apply (meson K_conjunction_out_mult assms(6) assms(7) deriv_in_maximal)
    by (meson K_conjunction_out_mult assms(4) assms(5) deriv_in_maximal)
  then have c4: \<open>(K i ?p) \<in> U\<close> and c4': \<open>(K i ?q) \<in> W\<close>
    using assms(6) assms(7) c2 consequent_in_maximal apply blast
    using assms(4) assms(5) c2' c3 consequent_in_maximal by blast
  then have \<open>(L i (K i ?p)) \<in> V\<close> and c5: \<open>(L i (K i ?q)) \<in> V\<close>
    using assms(2) assms(3) assms(6) assms(7) assms(9) exactly_one_in_maximal apply blast
    using assms(2) assms(3) assms(4) assms(5) assms(8) c4' exactly_one_in_maximal by blast
  then have \<open>(K i (L i ?p)) \<in> V\<close>
    by (meson Ax_2.intros assms(1) assms(2) assms(3) ax_in_maximal consequent_in_maximal)
  then have \<open>((K i (L i ?p)) \<^bold>\<and> (L i (K i ?q))) \<in> V\<close>
    using assms(2) assms(3) c5 mcs_conjunction by blast
  then have \<open>(L i ((L i ?p) \<^bold>\<and> K i ?q)) \<in> V\<close>
    by (meson K_thm assms(2) assms(3) consequent_in_maximal deriv_in_maximal)
  then have \<open>(L i ((K i ?q) \<^bold>\<and> L i ?p)) \<in> V\<close>
    by (smt (z3) \<open>K i (L i (conjunct (filter (\<lambda>p. p \<in> known U i) S'))) \<in> V\<close> assms(2) assms(3) assms(4) assms(5) assms(8) c4' exactly_one_in_maximal mcs_conjunction mem_Collect_eq subset_iff)
  then obtain Z' where z1:\<open>(consistent A Z') \<and> (maximal A Z')\<close> and z2:\<open>Z' \<in> (reach A i V)\<close>
                  and z3: \<open>((K i ?q) \<^bold>\<and> L i ?p) \<in> Z'\<close>
    using \<open>K i (L i (conjunct (filter (\<lambda>p. p \<in> known U i) S'))) \<in> V\<close> assms(4) assms(5) assms(8) c4' mcs_conjunction by blast
  then have z4: \<open>(L i (?q \<^bold>\<and> ?p)) \<in> Z'\<close>
    by (metis K_thm consequent_in_maximal deriv_in_maximal)
  then have o2:\<open>(L i (L i (?q \<^bold>\<and> ?p))) \<in> V\<close>
    using assms(2) assms(3) mcs_properties(2) z1 z2 by blast
  then have \<open>A \<turnstile> K i (K i (((?p \<^bold>\<and> ?q) \<^bold>\<longrightarrow> \<^bold>\<bottom>)))\<close>
    by (metis R2 o1)
  then have o3:\<open>K i (K i (((?p \<^bold>\<and> ?q) \<^bold>\<longrightarrow> \<^bold>\<bottom>))) \<in> V\<close>
    using assms(2) assms(3) deriv_in_maximal by blast
  then obtain X1 where x1:\<open>(consistent A X1) \<and> (maximal A X1)\<close> and x2:\<open>X1 \<in> (reach A i V)\<close>
                  and x3: \<open>(L i (?q \<^bold>\<and> ?p)) \<in> X1\<close>
    using z1 z2 z4 by blast
  then have x4:\<open>(K i (((?p \<^bold>\<and> ?q) \<^bold>\<longrightarrow> \<^bold>\<bottom>))) \<in> X1\<close>
    using o3 by blast
  then have t:\<open>\<forall>x. \<forall>y. tautology (((x\<^bold>\<and>y)\<^bold>\<longrightarrow>\<^bold>\<bottom>)\<^bold>\<longrightarrow>\<^bold>\<not>(y\<^bold>\<and>x))\<close>
    by (metis eval.simps(4) eval.simps(5))
  then have \<open>(((?p\<^bold>\<and>?q)\<^bold>\<longrightarrow>\<^bold>\<bottom>)\<^bold>\<longrightarrow>\<^bold>\<not>(?q\<^bold>\<and>?p)) \<in> X1\<close>
    using A1 deriv_in_maximal x1 by blast
  then have \<open>K i (((?p\<^bold>\<and>?q)\<^bold>\<longrightarrow>\<^bold>\<bottom>)\<^bold>\<longrightarrow>\<^bold>\<not>(?q\<^bold>\<and>?p)) \<in> X1\<close>
    by (meson A1 R2 deriv_in_maximal t x1)
  then have \<open>(K i ((?p\<^bold>\<and>?q)\<^bold>\<longrightarrow>\<^bold>\<bottom>)\<^bold>\<longrightarrow> K i (\<^bold>\<not>(?q\<^bold>\<and>?p))) \<in> X1\<close>
    by (meson K_A2' consequent_in_maximal deriv_in_maximal x1)
  then have \<open>(K i ((?p\<^bold>\<and>?q)\<^bold>\<longrightarrow>\<^bold>\<bottom>)\<^bold>\<longrightarrow> (\<^bold>\<not> L i(?q\<^bold>\<and>?p))) \<in> X1\<close>
    using consequent_in_maximal exactly_one_in_maximal x1 x3 x4 by blast
  then have \<open>(\<^bold>\<not> L i(?q\<^bold>\<and>?p)) \<in> X1 \<and> (L i(?q\<^bold>\<and>?p)) \<in> X1\<close>
    using consequent_in_maximal x1 x4 x3 by blast
  then show False
    using exactly_one_in_maximal x1 by blast
qed

lemma mcs\<^sub>_\<^sub>2_weakly_directed:
  fixes A :: \<open>'i fm \<Rightarrow> bool\<close>
  assumes \<open>\<forall>p. Ax_2 p \<longrightarrow> A p\<close>
  shows \<open>weakly_directed \<lparr>\<W> = mcss A, \<K> = reach A, \<pi> = pi\<rparr>\<close>
  unfolding weakly_directed_def
proof (intro allI ballI, auto)
  fix i V U W
  assume \<open>consistent A V\<close> \<open>maximal A V\<close> \<open>consistent A U\<close> \<open>maximal A U\<close> \<open>consistent A W\<close>
      \<open>maximal A W\<close> \<open>known V i \<subseteq> U\<close> \<open>known V i \<subseteq> W\<close>
  then have \<open>\<exists>X. (consistent A X) \<and> (maximal A X) \<and> X \<in> (reach A i W) \<inter> (reach A i U)\<close>
    using Ax_2_weakly_directed [where A=A and V=V and W=W and U=U] assms IntD2
      by simp
  then have \<open>\<exists>X. (consistent A X) \<and> (maximal A X) \<and> X \<in> (reach A i W) \<and> X \<in> (reach A i U)\<close>
    by simp
  then show \<open>\<exists>X. (consistent A X) \<and> (maximal A X) \<and> known W i \<subseteq> X \<and> known U i \<subseteq> X\<close>
    by auto
qed

lemma imply_completeness_K_2:
  assumes valid: \<open>\<forall>(M :: ('i, 'i fm set) kripke). \<forall>w \<in> \<W> M.
    weakly_directed M \<longrightarrow> (\<forall>q \<in> G. M, w \<Turnstile> q) \<longrightarrow> M, w \<Turnstile> p\<close>
  shows \<open>\<exists>qs. set qs \<subseteq> G \<and> (Ax_2 \<turnstile> imply qs p)\<close>
proof (rule ccontr)
assume \<open>\<nexists>qs. set qs \<subseteq> G \<and> Ax_2 \<turnstile> imply qs p\<close>
  then have *: \<open>\<forall>qs. set qs \<subseteq> G \<longrightarrow> \<not> Ax_2 \<turnstile> imply ((\<^bold>\<not> p) # qs) \<^bold>\<bottom>\<close>
    using K_Boole by blast

  let ?S = \<open>{\<^bold>\<not> p} \<union> G\<close>
  let ?V = \<open>Extend Ax_2 ?S\<close>
  let ?M = \<open>\<lparr>\<W> = mcss Ax_2, \<K> = reach Ax_2, \<pi> = pi\<rparr>\<close>

  have \<open>consistent Ax_2 ?S\<close>
    using * by (metis K_imply_Cons consistent_def inconsistent_subset)
  then have \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> \<open>\<forall>q \<in> G. ?M, ?V \<Turnstile> q\<close> \<open>consistent Ax_2 ?V\<close> \<open>maximal Ax_2 ?V\<close>
    using canonical_model unfolding list_all_def by fastforce+
  moreover have \<open>weakly_directed ?M\<close>
    using mcs\<^sub>_\<^sub>2_weakly_directed [where A=Ax_2] by fast
  ultimately have \<open>?M, ?V \<Turnstile> p\<close>
    using valid by auto
  then show False
    using \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> by simp
qed

section \<open>System S4.2\<close>

abbreviation SystemS4_2 :: \<open>'i fm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>S\<^sub>4\<^sub>2 _" [50] 50) where
  \<open>\<turnstile>\<^sub>S\<^sub>4\<^sub>2 p \<equiv> AxT \<oplus> Ax4 \<oplus> Ax_2 \<turnstile> p\<close>

abbreviation AxS4_2 :: \<open>'i fm \<Rightarrow> bool\<close> where
  \<open>AxS4_2 \<equiv> AxT \<oplus> Ax4 \<oplus> Ax_2\<close>

subsection \<open>Soundness\<close>

abbreviation w_directed_preorder :: \<open>('i, 'w) kripke \<Rightarrow> bool\<close> where
  \<open>w_directed_preorder M \<equiv> reflexive M \<and> transitive M \<and> weakly_directed M\<close>

lemma soundness_AxS4_2: \<open>AxS4_2 p \<Longrightarrow> w_directed_preorder M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
  using soundness_AxT soundness_Ax4 soundness_Ax_2 by metis

lemma soundness\<^sub>S\<^sub>4\<^sub>2: \<open>\<turnstile>\<^sub>S\<^sub>4\<^sub>2 p \<Longrightarrow> w_directed_preorder M \<Longrightarrow> w \<in> \<W> M \<Longrightarrow> M, w \<Turnstile> p\<close>
  using soundness soundness_AxS4_2 .

subsection \<open>Completeness\<close>

lemma imply_completeness_S4_2:
  assumes valid: \<open>\<forall>(M :: ('i, 'i fm set) kripke). \<forall>w \<in> \<W> M.
    w_directed_preorder M \<longrightarrow> (\<forall>q \<in> G. M, w \<Turnstile> q) \<longrightarrow> M, w \<Turnstile> p\<close>
  shows \<open>\<exists>qs. set qs \<subseteq> G \<and> (AxS4_2 \<turnstile> imply qs p)\<close>
proof (rule ccontr)
  assume \<open>\<nexists>qs. set qs \<subseteq> G \<and> AxS4_2 \<turnstile> imply qs p\<close>
  then have *: \<open>\<forall>qs. set qs \<subseteq> G \<longrightarrow> \<not> AxS4_2 \<turnstile> imply ((\<^bold>\<not> p) # qs) \<^bold>\<bottom>\<close>
    using K_Boole by blast

  let ?S = \<open>{\<^bold>\<not> p} \<union> G\<close>
  let ?V = \<open>Extend AxS4_2 ?S\<close>
  let ?M = \<open>\<lparr>\<W> = mcss AxS4_2, \<K> = reach AxS4_2, \<pi> = pi\<rparr>\<close>

  have \<open>consistent AxS4_2 ?S\<close>
    using * by (metis (no_types, lifting) K_imply_Cons consistent_def inconsistent_subset)
  then have
    \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> \<open>\<forall>q \<in> G. ?M, ?V \<Turnstile> q\<close>
    \<open>consistent AxS4_2 ?V\<close> \<open>maximal AxS4_2 ?V\<close>
    using canonical_model unfolding list_all_def by fastforce+
  moreover have \<open>w_directed_preorder ?M\<close>
    using reflexive\<^sub>T[of AxS4_2] mcs\<^sub>_\<^sub>2_weakly_directed[of AxS4_2] transitive\<^sub>K\<^sub>4[of AxS4_2] by auto
  ultimately have \<open>?M, ?V \<Turnstile> p\<close>
    using valid by auto
  then show False
    using \<open>?M, ?V \<Turnstile> (\<^bold>\<not> p)\<close> by simp
qed

lemma completeness\<^sub>S\<^sub>4\<^sub>2:
  assumes \<open>\<forall>(M :: ('i, 'i fm set) kripke). \<forall>w \<in> \<W> M. w_directed_preorder M \<longrightarrow> M, w \<Turnstile> p\<close>
  shows \<open>\<turnstile>\<^sub>S\<^sub>4\<^sub>2 p\<close>
  using assms imply_completeness_S4_2[where G=\<open>{}\<close>] by auto

abbreviation \<open>valid\<^sub>S\<^sub>4\<^sub>2 p \<equiv> \<forall>(M :: (nat, nat fm set) kripke). \<forall>w \<in> \<W> M. w_directed_preorder M \<longrightarrow> M, w \<Turnstile> p\<close>

theorem main\<^sub>S\<^sub>4\<^sub>2: \<open>valid\<^sub>S\<^sub>4\<^sub>2 p \<longleftrightarrow> \<turnstile>\<^sub>S\<^sub>4\<^sub>2 p\<close>
  using soundness\<^sub>S\<^sub>4\<^sub>2 completeness\<^sub>S\<^sub>4\<^sub>2 by fast

corollary
  assumes \<open>w_directed_preorder M\<close> \<open>w \<in> \<W> M\<close>
  shows \<open>valid\<^sub>S\<^sub>4\<^sub>2 p \<longrightarrow> M, w \<Turnstile> p\<close>
  using assms soundness\<^sub>S\<^sub>4\<^sub>2 completeness\<^sub>S\<^sub>4\<^sub>2 by fast

section \<open>Topological S4 axioms\<close>

abbreviation DoubleImp (infixr "\<^bold>\<longleftrightarrow>" 25) where
  \<open>(p\<^bold>\<longleftrightarrow>q) \<equiv> ((p \<^bold>\<longrightarrow> q) \<^bold>\<and> (q \<^bold>\<longrightarrow> p))\<close>

inductive System_topoS4 :: \<open>'i fm \<Rightarrow> bool\<close> ("\<turnstile>\<^sub>T\<^sub>o\<^sub>p _" [50] 50) where
  A1': \<open>tautology p \<Longrightarrow> \<turnstile>\<^sub>T\<^sub>o\<^sub>p p\<close>
| AR: \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p ((K i (p \<^bold>\<and> q)) \<^bold>\<longleftrightarrow> ((K i p) \<^bold>\<and> K i q))\<close>
| AT': \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (K i p \<^bold>\<longrightarrow> p)\<close>
| A4': \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (K i p \<^bold>\<longrightarrow> K i (K i p))\<close>
| AN: \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p K i \<^bold>\<top>\<close>
| R1': \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p p \<Longrightarrow> \<turnstile>\<^sub>T\<^sub>o\<^sub>p (p \<^bold>\<longrightarrow> q) \<Longrightarrow> \<turnstile>\<^sub>T\<^sub>o\<^sub>p q\<close>
| RM: \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (p \<^bold>\<longrightarrow> q) \<Longrightarrow> \<turnstile>\<^sub>T\<^sub>o\<^sub>p ((K i p) \<^bold>\<longrightarrow> K i q)\<close>

lemma topoS4_trans: \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p ((p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> (q \<^bold>\<longrightarrow> r) \<^bold>\<longrightarrow> p \<^bold>\<longrightarrow> r)\<close>
  by (simp add: A1')

lemma topoS4_conjElim: \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (p \<^bold>\<and> q \<^bold>\<longrightarrow> q)\<close>
  by (simp add: A1')

lemma topoS4_AxK: \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (K i p \<^bold>\<and> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i q)\<close>
proof -
  have \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p ((p \<^bold>\<and> (p \<^bold>\<longrightarrow> q)) \<^bold>\<longrightarrow> q)\<close>
    using A1' by force
  then have *: \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (K i (p \<^bold>\<and> (p \<^bold>\<longrightarrow> q)) \<^bold>\<longrightarrow> K i q)\<close>
    using RM by fastforce
  then have \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (K i p \<^bold>\<and> K i (p \<^bold>\<longrightarrow> q) \<^bold>\<longrightarrow> K i (p \<^bold>\<and> (p \<^bold>\<longrightarrow> q)))\<close>
    using AR topoS4_conjElim System_topoS4.simps by fast
  then show ?thesis
    by (meson "*" System_topoS4.R1' topoS4_trans)
qed

lemma topoS4_NecR:
  assumes \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p p\<close>
  shows\<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p K i p\<close>
proof -
  have \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (\<^bold>\<top> \<^bold>\<longrightarrow> p)\<close>
    using assms by (metis System_topoS4.A1' System_topoS4.R1' conjunct.simps(1) imply.simps(1) imply_conjunct)
  then have \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p (K i \<^bold>\<top> \<^bold>\<longrightarrow> K i p)\<close>
    using RM by force
  then show ?thesis
    by (meson AN System_topoS4.R1')
qed

lemma empty_S4: "{} \<turnstile>\<^sub>S\<^sub>4 p \<longleftrightarrow> AxT \<oplus> Ax4 \<turnstile> p"
  by simp

lemma S4_topoS4: \<open>{} \<turnstile>\<^sub>S\<^sub>4 p \<Longrightarrow> \<turnstile>\<^sub>T\<^sub>o\<^sub>p p\<close>
  unfolding empty_S4
proof (induct p rule: AK.induct)
  case (A2 i p q)
  then show ?case using topoS4_AxK .
next
  case (Ax p)
    then show ?case
      using AT' A4' by (metis AxT.cases Ax4.cases)
next
  case (R2 p)
  then show ?case
    by (simp add: topoS4_NecR)
qed (meson System_topoS4.intros)+

lemma topoS4_S4:
  fixes p :: \<open>'i fm\<close>
  shows \<open>\<turnstile>\<^sub>T\<^sub>o\<^sub>p p \<Longrightarrow> {} \<turnstile>\<^sub>S\<^sub>4 p\<close>
  unfolding empty_S4
proof (induct p rule: System_topoS4.induct)
  case (AT' i p)
  then show ?case
    by (simp add: Ax AxT.intros)
next
  case (A4' i p)
  then show ?case
    by (simp add: Ax Ax4.intros)
next
  case (AR i p q)
    then show ?case
      by (meson K_conj_imply_factor K_conjunction_in K_conjunction_out K_imp_trans' K_imply_multi R1)
next
  case (AN i)
  then have *: \<open>AxT \<oplus> Ax4 \<turnstile> \<^bold>\<top>\<close>
    by (simp add: A1)
  then show ?case
    by (simp add: * R2)
next
  case (RM p q i)
  then have \<open>AxT \<oplus> Ax4 \<turnstile> K i (p \<^bold>\<longrightarrow> q)\<close>
    by (simp add: R2)
  then show ?case
    by (simp add: K_map RM.hyps(2))
qed (meson AK.intros)+

theorem main\<^sub>S\<^sub>4': \<open>{} \<TTurnstile>\<^sub>S\<^sub>4 p \<longleftrightarrow> (\<turnstile>\<^sub>T\<^sub>o\<^sub>p p)\<close>
  using main\<^sub>S\<^sub>4[of "{}"] S4_topoS4 topoS4_S4 by fast

end


section \<open>Helper Algorithms\<close>

text \<open>This theory contains several algorithms used to calculate components of a test suite.\<close>

theory Helper_Algorithms
imports State_Separator State_Preamble
begin

subsection \<open>Calculating r-distinguishable State Pairs with Separators\<close>

definition r_distinguishable_state_pairs_with_separators ::
  "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> (('a \<times> 'a) \<times> (('a \<times> 'a) + 'a,'b,'c) fsm) set"
  where
  "r_distinguishable_state_pairs_with_separators M =
    {((q1,q2),Sep) | q1 q2 Sep . q1 \<in> nodes M
                      \<and> q2 \<in> nodes M
                      \<and> ((q1 < q2 \<and> state_separator_from_s_states M q1 q2 = Some Sep)
                        \<or> (q2 < q1 \<and> state_separator_from_s_states M q2 q1 = Some Sep)) }"

lemma r_distinguishable_state_pairs_with_separators_alt_def :
  "r_distinguishable_state_pairs_with_separators M =
    \<Union> (image (\<lambda> ((q1,q2),A) . {((q1,q2),the A),((q2,q1),the A)})
              (Set.filter (\<lambda> (qq,A) . A \<noteq> None)
                          (image (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                 (Set.filter (\<lambda> (q1,q2) . q1 < q2) (nodes M \<times> nodes M)))))"
  (is "?P1 = ?P2")
proof -
  have "\<And> x . x \<in> ?P1 \<Longrightarrow> x \<in> ?P2"
  proof -
    fix x assume "x \<in> ?P1"
    then obtain q1 q2 A where "x = ((q1,q2),A)"
      by (metis eq_snd_iff)
    then have "((q1,q2),A) \<in> ?P1" using \<open>x \<in> ?P1\<close> by auto
    then have "q1 \<in> nodes M"
         and  "q2 \<in> nodes M"
         and  "((q1 < q2 \<and> state_separator_from_s_states M q1 q2 = Some A)
                  \<or> (q2 < q1 \<and> state_separator_from_s_states M q2 q1 = Some A))"
      unfolding r_distinguishable_state_pairs_with_separators_def by blast+

    then consider (a) "q1 < q2 \<and> state_separator_from_s_states M q1 q2 = Some A" |
                  (b) "q2 < q1 \<and> state_separator_from_s_states M q2 q1 = Some A"
      by blast
    then show "x \<in> ?P2"
      using \<open>q1 \<in> nodes M\<close> \<open>q2 \<in> nodes M\<close> unfolding \<open>x = ((q1,q2),A)\<close> by (cases; force)
  qed
  moreover have "\<And> x . x \<in> ?P2 \<Longrightarrow> x \<in> ?P1"
  proof -
    fix x assume "x \<in> ?P2"
    then obtain q1 q2 A where "x = ((q1,q2),A)"
      by (metis eq_snd_iff)
    then have "((q1,q2),A) \<in> ?P2" using \<open>x \<in> ?P2\<close> by auto
    then obtain q1' q2' A' where "((q1,q2),A) \<in> {((q1',q2'),the A'),((q2',q1'),the A')}"
                           and   "A' \<noteq> None"
                           and   "((q1',q2'), A') \<in> (image (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                                            (Set.filter (\<lambda> (q1,q2) . q1 < q2) (nodes M \<times> nodes M)))"
      by force

    then have "A' = Some A"
      by (metis (no_types, lifting) empty_iff insert_iff old.prod.inject option.collapse)

    moreover have "A' = state_separator_from_s_states M q1' q2'"
             and  "q1' < q2'"
             and  "q1' \<in> nodes M"
             and  "q2' \<in> nodes M"
      using \<open>((q1',q2'), A') \<in> (image (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                      (Set.filter (\<lambda> (q1,q2) . q1 < q2) (nodes M \<times> nodes M)))\<close>
      by force+
    ultimately have "state_separator_from_s_states M q1' q2' = Some A" by simp

    consider "((q1',q2'),the A') = ((q1,q2),A)" | "((q1',q2'),the A') = ((q2,q1),A)"
      using \<open>((q1,q2),A) \<in> {((q1',q2'),the A'),((q2',q1'),the A')}\<close>
      by force
    then show "x \<in> ?P1"
    proof cases
      case 1
      then have *: "q1' = q1" and **: "q2' = q2" by auto

      show ?thesis
        using \<open>q1' \<in> nodes M\<close> \<open>q2' \<in> nodes M\<close> \<open>q1' < q2'\<close> \<open>state_separator_from_s_states M q1' q2' = Some A\<close>
        unfolding r_distinguishable_state_pairs_with_separators_def
        unfolding * ** \<open>x = ((q1,q2),A)\<close> by blast
    next
      case 2
      then have *: "q1' = q2" and **: "q2' = q1" by auto

      show ?thesis
        using \<open>q1' \<in> nodes M\<close> \<open>q2' \<in> nodes M\<close> \<open>q1' < q2'\<close> \<open>state_separator_from_s_states M q1' q2' = Some A\<close>
        unfolding r_distinguishable_state_pairs_with_separators_def
        unfolding * ** \<open>x = ((q1,q2),A)\<close> by blast
    qed
  qed
  ultimately show ?thesis by blast
qed

lemma r_distinguishable_state_pairs_with_separators_code[code] :
  "r_distinguishable_state_pairs_with_separators M =
    set (concat (map
                  (\<lambda> ((q1,q2),A) . [((q1,q2),the A),((q2,q1),the A)])
                  (filter (\<lambda> (qq,A) . A \<noteq> None)
                          (map (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                               (filter (\<lambda> (q1,q2) . q1 < q2)
                                       (cartesian_product_list (nodes_as_list M) (nodes_as_list M)))))))"
  (is "r_distinguishable_state_pairs_with_separators M = ?C2")
proof -
  let ?C1 = "\<Union> (image (\<lambda> ((q1,q2),A) . {((q1,q2),the A),((q2,q1),the A)})
                       (Set.filter (\<lambda> (qq,A) . A \<noteq> None)
                                   (image (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                          (Set.filter (\<lambda> (q1,q2) . q1 < q2) (nodes M \<times> nodes M)))))"

  have "r_distinguishable_state_pairs_with_separators M = ?C1"
    using r_distinguishable_state_pairs_with_separators_alt_def by assumption
  also have "\<dots> = ?C2"
  proof
    show "?C1 \<subseteq> ?C2"
    proof
      fix x assume "x \<in> ?C1"
      then obtain q1 q2 A where "x = ((q1,q2),A)"
        by (metis eq_snd_iff)
      then have "((q1,q2),A) \<in> ?C1" using \<open>x \<in> ?C1\<close> by auto
      then obtain q1' q2' A' where "((q1,q2),A) \<in> {((q1',q2'),the A'),((q2',q1'),the A')}"
                             and   "A' \<noteq> None"
                             and   "((q1',q2'), A') \<in> (image (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                                             (Set.filter (\<lambda> (q1,q2) . q1 < q2) (nodes M \<times> nodes M)))"
        by force

      then have "A' = Some A"
        by (metis (no_types, lifting) empty_iff insert_iff old.prod.inject option.collapse)

      moreover have "A' = state_separator_from_s_states M q1' q2'"
               and  "q1' < q2'"
               and  "q1' \<in> nodes M"
               and  "q2' \<in> nodes M"
        using \<open>((q1',q2'), A') \<in> (image (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                        (Set.filter (\<lambda> (q1,q2) . q1 < q2) (nodes M \<times> nodes M)))\<close>
        by force+
      ultimately have "state_separator_from_s_states M q1' q2' = Some A"
                 and  "(q1',q2') \<in> set (filter (\<lambda> (q1,q2) . q1 < q2) (cartesian_product_list (nodes_as_list M) (nodes_as_list M)))"
        using cartesian_product_list_set' unfolding nodes_as_list_set[symmetric] by auto

      then have "((q1',q2'),A') \<in> set (filter (\<lambda> (qq,A) . A \<noteq> None)
                                              (map (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                                   (filter (\<lambda> (q1,q2) . q1 < q2)
                                                           (cartesian_product_list (nodes_as_list M) (nodes_as_list M)))))"
        using \<open>A' = state_separator_from_s_states M q1' q2'\<close> \<open>A' = Some A\<close> by force

      have scheme1: "\<And> f xs x . x \<in> set xs \<Longrightarrow> f x \<in> set (map f xs)" by auto
      have scheme2: "\<And> x xs xss . xs \<in> set xss \<Longrightarrow> x \<in> set xs \<Longrightarrow> x \<in> set (concat xss)" by auto
      have *:"[((q1',q2'),the A'),((q2',q1'),the A')] \<in>
                set (map (\<lambda> ((q1,q2),A) . [((q1,q2),the A),((q2,q1),the A)])
                         (filter (\<lambda> (qq,A) . A \<noteq> None)
                                 (map (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                      (filter (\<lambda> (q1,q2) . q1 < q2)
                                              (cartesian_product_list (nodes_as_list M) (nodes_as_list M))))))"
        using scheme1[OF \<open>((q1',q2'),A') \<in> set (filter (\<lambda> (qq,A) . A \<noteq> None) (map (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2)) (filter (\<lambda> (q1,q2) . q1 < q2) (cartesian_product_list (nodes_as_list M) (nodes_as_list M)))))\<close>, of "\<lambda> ((q1', q2'), A') . [((q1',q2'),the A'),((q2',q1'),the A')]"]
        by force
      have **: "((q1,q2),A) \<in> set [((q1',q2'),the A'),((q2',q1'),the A')]"
        using \<open>((q1,q2),A) \<in> {((q1',q2'),the A'),((q2',q1'),the A')}\<close> by auto

      show "x \<in> ?C2"
        unfolding \<open>x = ((q1,q2),A)\<close> using scheme2[OF * **] by assumption
    qed

    show "?C2 \<subseteq> ?C1"
    proof
      fix x assume "x \<in> ?C2"
      obtain q1q2A where "x \<in>  set ((\<lambda> ((q1', q2'), A') . [((q1',q2'),the A'),((q2',q1'),the A')]) q1q2A)"
                   and   "q1q2A \<in> set (filter (\<lambda> (qq,A) . A \<noteq> None)
                                              (map (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                                   (filter (\<lambda> (q1,q2) . q1 < q2)
                                                           (cartesian_product_list (nodes_as_list M) (nodes_as_list M)))))"
        using concat_map_elem[OF \<open>x \<in> ?C2\<close>] by blast

      moreover obtain q1 q2 A where "q1q2A = ((q1,q2),A)"
        by (metis prod.collapse)

      ultimately have "x \<in> set [((q1,q2),the A),((q2,q1),the A)]"
                 and  "((q1,q2),A) \<in> set (filter (\<lambda> (qq,A) . A \<noteq> None)
                                                 (map (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                                      (filter (\<lambda> (q1,q2) . q1 < q2)
                                                              (cartesian_product_list (nodes_as_list M) (nodes_as_list M)))))"
        by force+

      then have "A = state_separator_from_s_states M q1 q2"
           and  "A \<noteq> None"
           and  "(q1,q2) \<in> set (filter (\<lambda> (q1,q2) . q1 < q2) (cartesian_product_list (nodes_as_list M) (nodes_as_list M)))"
        by auto

      then have "q1 < q2" and "q1 \<in> nodes M" and "q2 \<in> nodes M"
        using cartesian_product_list_set' unfolding nodes_as_list_set[symmetric] by auto
      then have "(q1,q2) \<in> Set.filter (\<lambda>(q1, q2). q1 < q2) (FSM.nodes M \<times> FSM.nodes M)"
        by auto
      then have "((q1,q2),A) \<in> (Set.filter (\<lambda> (qq,A) . A \<noteq> None)
                                           (image (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                                  (Set.filter (\<lambda> (q1,q2) . q1 < q2) (nodes M \<times> nodes M))))"
        using \<open>A \<noteq> None\<close> unfolding \<open>A = state_separator_from_s_states M q1 q2\<close> by auto
      then have "{((q1,q2),the A),((q2,q1),the A)} \<in>
                      (image (\<lambda> ((q1,q2),A) . {((q1,q2),the A),((q2,q1),the A)})
                             (Set.filter (\<lambda> (qq,A) . A \<noteq> None)
                                         (image (\<lambda> (q1,q2) . ((q1,q2),state_separator_from_s_states M q1 q2))
                                                (Set.filter (\<lambda> (q1,q2) . q1 < q2) (nodes M \<times> nodes M)))))"
        by (metis (no_types, lifting) \<open>q1q2A = ((q1, q2), A)\<close> case_prod_conv image_iff)
      then show "x \<in> ?C1"
        using \<open>x \<in> set [((q1,q2),the A),((q2,q1),the A)]\<close>
        by (metis (no_types, lifting) UnionI list.simps(15) set_empty2)
    qed
  qed

  finally show ?thesis .
qed

lemma r_distinguishable_state_pairs_with_separators_same_pair_same_separator :
  assumes "((q1,q2),A) \<in> r_distinguishable_state_pairs_with_separators M"
  and     "((q1,q2),A') \<in> r_distinguishable_state_pairs_with_separators M"
shows "A = A'"
  using assms unfolding r_distinguishable_state_pairs_with_separators_def
  by force

lemma r_distinguishable_state_pairs_with_separators_sym_pair_same_separator :
  assumes "((q1,q2),A) \<in> r_distinguishable_state_pairs_with_separators M"
  and     "((q2,q1),A') \<in> r_distinguishable_state_pairs_with_separators M"
shows "A = A'"
  using assms unfolding r_distinguishable_state_pairs_with_separators_def
  by force

lemma r_distinguishable_state_pairs_with_separators_elem_is_separator:
  assumes "((q1,q2),A) \<in> r_distinguishable_state_pairs_with_separators M"
  and     "observable M"
  and     "completely_specified M"
shows "is_separator M q1 q2 A (Inr q1) (Inr q2)"
proof -
  have *:"q1 \<in> nodes M"
  and **:"q2 \<in> nodes M"
  and ***:"q1 \<noteq> q2"
  and ****: "q2\<noteq>q1"
  and *****: "state_separator_from_s_states M q1 q2 = Some A \<or> state_separator_from_s_states M q2 q1 = Some A"
    using assms(1) unfolding r_distinguishable_state_pairs_with_separators_def by auto

  from ***** have "is_state_separator_from_canonical_separator (canonical_separator M q1 q2) q1 q2 A
                    \<or> is_state_separator_from_canonical_separator (canonical_separator M q2 q1) q2 q1 A"
    using state_separator_from_s_states_soundness[of M q1 q2 A, OF _ * ** assms(3)]
    using state_separator_from_s_states_soundness[of M q2 q1 A, OF _ ** * assms(3)] by auto
  then show ?thesis
    using state_separator_from_canonical_separator_is_separator[of M q1 q2 A, OF _ \<open>observable M\<close> * ** ***]
    using state_separator_from_canonical_separator_is_separator[of M q2 q1 A, OF _ \<open>observable M\<close> ** * ****]
    using is_separator_sym[of M q2 q1 A "Inr q2" "Inr q1"] by auto
qed

subsection \<open>Calculating Pairwise r-distinguishable Sets of States\<close>

definition pairwise_r_distinguishable_state_sets_from_separators :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> 'a set set" where
  "pairwise_r_distinguishable_state_sets_from_separators M
    = { S . S \<subseteq> nodes M \<and> (\<forall> q1 \<in> S . \<forall> q2 \<in> S . q1 \<noteq> q2 \<longrightarrow> (q1,q2) \<in> image fst (r_distinguishable_state_pairs_with_separators M))}"

definition pairwise_r_distinguishable_state_sets_from_separators_list :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> 'a set list" where
  "pairwise_r_distinguishable_state_sets_from_separators_list M =
    (let RDS = image fst (r_distinguishable_state_pairs_with_separators M)
      in filter (\<lambda> S . \<forall> q1 \<in> S . \<forall> q2 \<in> S . q1 \<noteq> q2 \<longrightarrow> (q1,q2) \<in> RDS)
             (map set (pow_list (nodes_as_list M))))"

(* uses a list-based calculation to avoid storing the entire powerset *)
lemma pairwise_r_distinguishable_state_sets_from_separators_code[code] :
  "pairwise_r_distinguishable_state_sets_from_separators M = set (pairwise_r_distinguishable_state_sets_from_separators_list M)"
  using pow_list_set[of "nodes_as_list M"]
  unfolding nodes_as_list_set[of M]
            pairwise_r_distinguishable_state_sets_from_separators_def
            pairwise_r_distinguishable_state_sets_from_separators_list_def
  by auto

lemma pairwise_r_distinguishable_state_sets_from_separators_cover :
  assumes "q \<in> nodes M"
  shows "\<exists> S \<in> (pairwise_r_distinguishable_state_sets_from_separators M) . q \<in> S"
  unfolding pairwise_r_distinguishable_state_sets_from_separators_def using assms by blast

definition maximal_pairwise_r_distinguishable_state_sets_from_separators :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> 'a set set" where
  "maximal_pairwise_r_distinguishable_state_sets_from_separators M
    = { S . S \<in> (pairwise_r_distinguishable_state_sets_from_separators M)
            \<and> (\<nexists> S' . S' \<in> (pairwise_r_distinguishable_state_sets_from_separators M) \<and> S \<subset> S')}"

definition maximal_pairwise_r_distinguishable_state_sets_from_separators_list :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> 'a set list" where
  "maximal_pairwise_r_distinguishable_state_sets_from_separators_list M =
    remove_subsets (pairwise_r_distinguishable_state_sets_from_separators_list M)"

lemma maximal_pairwise_r_distinguishable_state_sets_from_separators_code[code] :
  "maximal_pairwise_r_distinguishable_state_sets_from_separators M
    = set (maximal_pairwise_r_distinguishable_state_sets_from_separators_list M)"
  unfolding maximal_pairwise_r_distinguishable_state_sets_from_separators_list_def
            Let_def remove_subsets_set pairwise_r_distinguishable_state_sets_from_separators_code[symmetric]
            maximal_pairwise_r_distinguishable_state_sets_from_separators_def
  by blast

lemma maximal_pairwise_r_distinguishable_state_sets_from_separators_cover :
  assumes "q \<in> nodes M"
  shows "\<exists> S \<in> (maximal_pairwise_r_distinguishable_state_sets_from_separators M ). q \<in> S"
proof -

  have *: "{q} \<in> (pairwise_r_distinguishable_state_sets_from_separators M)"
    unfolding pairwise_r_distinguishable_state_sets_from_separators_def using assms by blast
  have **: "finite (pairwise_r_distinguishable_state_sets_from_separators M)"
    unfolding pairwise_r_distinguishable_state_sets_from_separators_def by (simp add: fsm_nodes_finite)

  have "(maximal_pairwise_r_distinguishable_state_sets_from_separators M) =
        {S \<in> (pairwise_r_distinguishable_state_sets_from_separators M).
            \<not>(\<exists> S' \<in> (pairwise_r_distinguishable_state_sets_from_separators M) . S \<subset> S')}"
    unfolding maximal_pairwise_r_distinguishable_state_sets_from_separators_def
              pairwise_r_distinguishable_state_sets_from_separators_def
    by metis
  then have "(maximal_pairwise_r_distinguishable_state_sets_from_separators M) =
        {S \<in> (pairwise_r_distinguishable_state_sets_from_separators M) .
              (\<forall> S' \<in> (pairwise_r_distinguishable_state_sets_from_separators M) . \<not> S \<subset> S')}"
    by blast
  moreover have "\<exists> S \<in> {S \<in> (pairwise_r_distinguishable_state_sets_from_separators M) .
                      (\<forall> S' \<in> (pairwise_r_distinguishable_state_sets_from_separators M) . \<not> S \<subset> S')} . q \<in> S"
    using maximal_set_cover[OF ** *]
    by blast
  ultimately show ?thesis
    by blast
qed

subsection \<open>Calculating d-reachable States with Preambles\<close>

(* calculate d-reachable states and a fixed assignment of preambles *)
definition d_reachable_states_with_preambles :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> ('a \<times> ('a,'b,'c) fsm) set" where
  "d_reachable_states_with_preambles M =
    image (\<lambda> qp . (fst qp, the (snd qp)))
          (Set.filter (\<lambda> qp . snd qp \<noteq> None)
                      (image (\<lambda> q . (q, calculate_state_preamble_from_input_choices M q))
                             (nodes M)))"

lemma d_reachable_states_with_preambles_exhaustiveness :
  assumes "\<exists> P . is_preamble P M q"
  and     "q \<in> nodes M"
shows "\<exists> P . (q,P) \<in> (d_reachable_states_with_preambles M)"
  using calculate_state_preamble_from_input_choices_exhaustiveness[OF assms(1)] assms(2)
  unfolding d_reachable_states_with_preambles_def by force

lemma d_reachable_states_with_preambles_soundness :
  assumes "(q,P) \<in> (d_reachable_states_with_preambles M)"
  and     "observable M"
  shows "is_preamble P M q"
    and "q \<in> nodes M"
  using assms(1) calculate_state_preamble_from_input_choices_soundness[of M q P]
  unfolding d_reachable_states_with_preambles_def
  using imageE by auto

subsection \<open>Calculating Repetition Sets\<close>

text \<open>Repetition sets are sets of tuples each containing a maximal set of pairwise r-distinguishable
      states and the subset of those states that have a preamble.\<close>

definition maximal_repetition_sets_from_separators :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> ('a set \<times> 'a set) set" where
  "maximal_repetition_sets_from_separators M
    = {(S, S \<inter> (image fst (d_reachable_states_with_preambles M))) | S .
            S \<in> (maximal_pairwise_r_distinguishable_state_sets_from_separators M)}"

definition maximal_repetition_sets_from_separators_list_naive :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> ('a set \<times> 'a set) list" where
  "maximal_repetition_sets_from_separators_list_naive M
    = (let DR = (image fst (d_reachable_states_with_preambles M))
        in map (\<lambda> S . (S, S \<inter> DR)) (maximal_pairwise_r_distinguishable_state_sets_from_separators_list M))"

lemma maximal_repetition_sets_from_separators_code[code]:
  "maximal_repetition_sets_from_separators M = (let DR = (image fst (d_reachable_states_with_preambles M))
    in  image (\<lambda> S . (S, S \<inter> DR)) (maximal_pairwise_r_distinguishable_state_sets_from_separators M))"
  unfolding maximal_repetition_sets_from_separators_def Let_def by force

lemma maximal_repetition_sets_from_separators_code_alt:
  "maximal_repetition_sets_from_separators M = set (maximal_repetition_sets_from_separators_list_naive M)"
  unfolding maximal_repetition_sets_from_separators_def
            maximal_repetition_sets_from_separators_list_naive_def
            maximal_pairwise_r_distinguishable_state_sets_from_separators_code
  by force

subsubsection \<open>Calculating Sub-Optimal Repetition Sets\<close>

text \<open>Finding maximal pairwise r-distinguishable subsets of the node set of some FSM is likely too expensive
      for FSMs containing a large number of r-distinguishable pairs of states.
      The following functions calculate only subset of all repetition sets while maintaining the
      property that every state is contained in some repetition set.\<close>

fun extend_until_conflict :: "('a \<times> 'a) set \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'a list" where
  "extend_until_conflict non_confl_set candidates xs 0 = xs" |
  "extend_until_conflict non_confl_set candidates xs (Suc k) = (case dropWhile (\<lambda> x . find (\<lambda> y . (x,y) \<notin> non_confl_set) xs \<noteq> None) candidates of
    [] \<Rightarrow> xs |
    (c#cs) \<Rightarrow> extend_until_conflict non_confl_set cs (c#xs) k)"

lemma extend_until_conflict_retainment :
  assumes "x \<in> set xs"
  shows "x \<in> set (extend_until_conflict non_confl_set candidates xs k)"
using assms proof (induction k arbitrary: candidates xs)
  case 0
  then show ?case by auto
next
  case (Suc k)
  then show ?case proof (cases "dropWhile (\<lambda> x . find (\<lambda> y . (x,y) \<notin> non_confl_set) xs \<noteq> None) candidates")
    case Nil
    then show ?thesis
      by (metis Suc.prems extend_until_conflict.simps(2) list.simps(4))
  next
    case (Cons c cs)
    then show ?thesis
      by (simp add: Suc.IH Suc.prems)
  qed
qed

lemma extend_until_conflict_elem :
  assumes "x \<in> set (extend_until_conflict non_confl_set candidates xs k)"
  shows "x \<in> set xs \<or> x \<in> set candidates"
using assms proof (induction k arbitrary: candidates xs)
  case 0
  then show ?case by auto
next
  case (Suc k)
  then show ?case proof (cases "dropWhile (\<lambda> x . find (\<lambda> y . (x,y) \<notin> non_confl_set) xs \<noteq> None) candidates")
    case Nil
    then show ?thesis
      by (metis Suc.prems extend_until_conflict.simps(2) list.simps(4))
  next
    case (Cons c cs)
    then have "extend_until_conflict non_confl_set candidates xs (Suc k) = extend_until_conflict non_confl_set cs (c#xs) k"
      by auto
    then have "x \<in> set (c # xs) \<or> x \<in> set cs"
      using Suc.IH[of cs "(c#xs)"] Suc.prems by auto
    moreover have "set (c#cs) \<subseteq> set candidates"
      using Cons by (metis set_dropWhileD subsetI)
    ultimately show ?thesis
      using set_ConsD by auto
  qed
qed

lemma extend_until_conflict_no_conflicts :
  assumes "x \<in> set (extend_until_conflict non_confl_set candidates xs k)"
  and     "y \<in> set (extend_until_conflict non_confl_set candidates xs k)"
  and     "x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> (x,y) \<in> non_confl_set \<or> (y,x) \<in> non_confl_set"
  and     "x \<noteq> y"
shows "(x,y) \<in> non_confl_set \<or> (y,x) \<in> non_confl_set"
using assms proof (induction k arbitrary: candidates xs)
  case 0
  then show ?case by auto
next
  case (Suc k)
  then show ?case proof (cases "dropWhile (\<lambda> x . find (\<lambda> y . (x,y) \<notin> non_confl_set) xs \<noteq> None) candidates")
    case Nil
    then have "extend_until_conflict non_confl_set candidates xs (Suc k) = xs"
      by (metis extend_until_conflict.simps(2) list.simps(4))
    then show ?thesis
      using Suc.prems by auto
  next
    case (Cons c cs)
    then have "extend_until_conflict non_confl_set candidates xs (Suc k) = extend_until_conflict non_confl_set cs (c#xs) k"
      by auto
    then have xk: "x \<in> set (extend_until_conflict non_confl_set cs (c#xs) k)"
         and  yk: "y \<in> set (extend_until_conflict non_confl_set cs (c#xs) k)"
      using Suc.prems by auto

    have **: "x \<in> set (c#xs) \<Longrightarrow> y \<in> set (c#xs) \<Longrightarrow> (x,y) \<in> non_confl_set \<or> (y,x) \<in> non_confl_set"
    proof -
      have scheme: "\<And> P xs x xs' . dropWhile P xs = (x#xs') \<Longrightarrow> \<not> P x"
        by (simp add: dropWhile_eq_Cons_conv)
      have "find (\<lambda> y . (c,y) \<notin> non_confl_set) xs = None"
        using scheme[OF Cons] by simp
      then have *: "\<And> y . y \<in> set xs \<Longrightarrow> (c,y) \<in> non_confl_set"
        unfolding find_None_iff by blast

      assume "x \<in> set (c#xs)" and "y \<in> set (c#xs)"
      then consider (a1) "x = c \<and> y \<in> set xs" |
                    (a2) "y = c \<and> x \<in> set xs" |
                    (a3) "x \<in> set xs \<and> y \<in> set xs"
        using \<open>x \<noteq> y\<close> by auto
      then show ?thesis
        using * Suc.prems(3) by (cases; auto)
    qed

    show ?thesis using Suc.IH[OF xk yk ** Suc.prems(4)] by blast
  qed
qed

definition greedy_pairwise_r_distinguishable_state_sets_from_separators :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> 'a set list" where
  "greedy_pairwise_r_distinguishable_state_sets_from_separators M =
    (let pwrds = image fst (r_distinguishable_state_pairs_with_separators M);
         k     = size M;
         nL    = nodes_as_list M
     in map (\<lambda>q . set (extend_until_conflict pwrds (remove1 q nL) [q] k)) nL)"

definition maximal_repetition_sets_from_separators_list_greedy :: "('a::linorder,'b::linorder,'c) fsm \<Rightarrow> ('a set \<times> 'a set) list" where
  "maximal_repetition_sets_from_separators_list_greedy M = (let DR = (image fst (d_reachable_states_with_preambles M))
    in remdups (map (\<lambda> S . (S, S \<inter> DR)) (greedy_pairwise_r_distinguishable_state_sets_from_separators M)))"

lemma greedy_pairwise_r_distinguishable_state_sets_from_separators_cover :
  assumes "q \<in> nodes M"
shows "\<exists> S \<in> set (greedy_pairwise_r_distinguishable_state_sets_from_separators M). q \<in> S"
  using assms extend_until_conflict_retainment[of q "[q]"]
  unfolding nodes_as_list_set[symmetric] greedy_pairwise_r_distinguishable_state_sets_from_separators_def Let_def
  by auto

lemma r_distinguishable_state_pairs_with_separators_sym :
  assumes "(q1,q2) \<in> fst ` r_distinguishable_state_pairs_with_separators M"
  shows "(q2,q1) \<in> fst ` r_distinguishable_state_pairs_with_separators M"
  using assms
  unfolding r_distinguishable_state_pairs_with_separators_def
  by force

lemma greedy_pairwise_r_distinguishable_state_sets_from_separators_soundness :
  "set (greedy_pairwise_r_distinguishable_state_sets_from_separators M) \<subseteq> (pairwise_r_distinguishable_state_sets_from_separators M)"
proof
  fix S assume "S \<in> set (greedy_pairwise_r_distinguishable_state_sets_from_separators M)"
  then obtain q' where "q' \<in> nodes M"
                 and   *: "S = set (extend_until_conflict (image fst (r_distinguishable_state_pairs_with_separators M))
                                                          (remove1 q' (nodes_as_list M))
                                                          [q']
                                                          (size M))"
    unfolding greedy_pairwise_r_distinguishable_state_sets_from_separators_def Let_def nodes_as_list_set[symmetric]
    by auto

  have "S \<subseteq> nodes M"
  proof
    fix q assume "q \<in> S"
    then have "q \<in> set (extend_until_conflict (image fst (r_distinguishable_state_pairs_with_separators M)) (remove1 q' (nodes_as_list M)) [q'] (size M))"
      using * by auto
    then show "q \<in> nodes M"
      using extend_until_conflict_elem[of q "image fst (r_distinguishable_state_pairs_with_separators M)" "(remove1 q' (nodes_as_list M))" "[q']" "size M"]
      using nodes_as_list_set \<open>q' \<in> nodes M\<close> by auto
  qed

  moreover have "\<And> q1 q2 . q1 \<in> S \<Longrightarrow> q2 \<in> S \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> (q1,q2) \<in> image fst (r_distinguishable_state_pairs_with_separators M)"
  proof -
    fix q1 q2 assume "q1 \<in> S" and "q2 \<in> S" and "q1 \<noteq> q2"
    then have e1: "q1 \<in> set (extend_until_conflict (image fst (r_distinguishable_state_pairs_with_separators M)) (remove1 q' (nodes_as_list M)) [q'] (size M))"
         and  e2: "q2 \<in> set (extend_until_conflict (image fst (r_distinguishable_state_pairs_with_separators M)) (remove1 q' (nodes_as_list M)) [q'] (size M))"
      unfolding * by simp+
    have e3: "(q1 \<in> set [q'] \<Longrightarrow> q2 \<in> set [q']
              \<Longrightarrow> (q1, q2) \<in> fst ` r_distinguishable_state_pairs_with_separators M
                  \<or> (q2, q1) \<in> fst ` r_distinguishable_state_pairs_with_separators M)"
      using \<open>q1 \<noteq> q2\<close> by auto

    show "(q1,q2) \<in> image fst (r_distinguishable_state_pairs_with_separators M)"
      using extend_until_conflict_no_conflicts[OF e1 e2 e3 \<open>q1 \<noteq> q2\<close>]
            r_distinguishable_state_pairs_with_separators_sym[of q2 q1 M] by blast
  qed

  ultimately show "S \<in> (pairwise_r_distinguishable_state_sets_from_separators M)"
    unfolding pairwise_r_distinguishable_state_sets_from_separators_def by blast
qed

end


section {* Lists: extra functions and properties *}

theory List_extra
imports
  Main
  "~~/src/HOL/Library/Sublist"
  "~~/src/HOL/Library/Monad_Syntax"
  "~~/src/HOL/Library/Prefix_Order"
begin

subsection {* Extra list functions *}

text {*
The following variant of the standard @{text nth} function returns
@{text "\<bottom>"} if the index is out of range.
*}

primrec
  nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>\<^sub>l" [90, 0] 91)
where
  "[]\<langle>i\<rangle>\<^sub>l = None"
| "(x # xs)\<langle>i\<rangle>\<^sub>l = (case i of 0 \<Rightarrow> Some x | Suc j \<Rightarrow> xs \<langle>j\<rangle>\<^sub>l)"

fun sequence :: "'a option list \<Rightarrow> 'a list option" where
"sequence [] = Some []" |
"sequence (f # fs) = do { x \<leftarrow> f; xs \<leftarrow> sequence fs; Some (x # xs) }"

abbreviation "mapM f \<equiv> sequence \<circ> map f"

subsection {* List lemmas *}

lemma map_nth_Cons_atLeastLessThan:
  "map (nth (x # xs)) [Suc m..<n] = map (nth xs) [m..<n - 1]"
proof -
  have "nth xs = nth (x # xs) \<circ> Suc"
    by auto
  hence "map (nth xs) [m..<n - 1] = map (nth (x # xs) \<circ> Suc) [m..<n - 1]"
    by simp
  also have "... = map (nth (x # xs)) (map Suc [m..<n - 1])"
    by simp
  also have "... = map (nth (x # xs)) [Suc m..<n]"
    by (metis Suc_diff_1 le_0_eq length_upt list.simps(8) list.size(3) map_Suc_upt not_less upt_0)
  finally show ?thesis ..
qed

lemma nth_el_appendl[simp]: "i < length xs \<Longrightarrow> (xs @ ys)\<langle>i\<rangle>\<^sub>l = xs\<langle>i\<rangle>\<^sub>l"
  apply (induct xs arbitrary: i)
  apply simp
  apply (case_tac i)
  apply simp_all
done

lemma nth_el_appendr[simp]: "length xs \<le> i \<Longrightarrow> (xs @ ys)\<langle>i\<rangle>\<^sub>l = ys\<langle>i - length xs\<rangle>\<^sub>l"
  apply (induct xs arbitrary: i)
  apply simp
  apply (case_tac i)
  apply simp_all
done

lemma sorted_last [simp]: "\<lbrakk> x \<in> set xs; sorted xs \<rbrakk> \<Longrightarrow> x \<le> last xs"
  apply (induct xs)
  apply (auto)
  apply (metis last_in_set sorted_Cons)+
done

lemma sorted_map: "\<lbrakk> sorted xs; mono f \<rbrakk> \<Longrightarrow> sorted (map f xs)"
  by (simp add: monoD sorted_equals_nth_mono)

lemma prefix_length_eq:
  "\<lbrakk> length xs = length ys; prefix xs ys \<rbrakk> \<Longrightarrow> xs = ys"
  by (metis not_equal_is_parallel parallel_def)

lemma prefix_Cons_elim [elim]:
  assumes "prefix (x # xs) ys"
  obtains ys' where "ys = x # ys'" "prefix xs ys'"
  using assms
  by (metis Sublist.Cons_prefix_Cons prefix_code(1) prefix_order.eq_iff prefixes.cases)

lemma prefix_map_inj:
  "\<lbrakk> inj_on f (set xs \<union> set ys); prefix (map f xs) (map f ys) \<rbrakk> \<Longrightarrow>
   prefix xs ys"
  apply (induct xs arbitrary:ys)
  apply (simp_all)
  apply (erule prefix_Cons_elim)
  apply (auto)
  apply (metis image_insert insertI1 insert_Diff_if singletonE)
done

lemma prefix_map_inj_eq [simp]:
  "inj_on f (set xs \<union> set ys) \<Longrightarrow>
   prefix (map f xs) (map f ys) \<longleftrightarrow> prefix xs ys"
  by (metis map_prefixI prefix_map_inj)

lemma strict_prefix_Cons_elim [elim]:
  assumes "strict_prefix (x # xs) ys"
  obtains ys' where "ys = x # ys'" "strict_prefix xs ys'"
  using assms
  by (metis Sublist.strict_prefixE' Sublist.strict_prefixI' append_Cons)

lemma strict_prefix_map_inj:
  "\<lbrakk> inj_on f (set xs \<union> set ys); strict_prefix (map f xs) (map f ys) \<rbrakk> \<Longrightarrow>
   strict_prefix xs ys"
  apply (induct xs arbitrary:ys)
  apply (auto)
  using prefix_bot.bot.not_eq_extremum apply fastforce
  apply (erule strict_prefix_Cons_elim)
  apply (auto)
  apply (metis (hide_lams, full_types) image_insert insertI1 insert_Diff_if singletonE)
done

lemma strict_prefix_map_inj_eq [simp]:
  "inj_on f (set xs \<union> set ys) \<Longrightarrow>
   strict_prefix (map f xs) (map f ys) \<longleftrightarrow> strict_prefix xs ys"
  by (metis inj_on_map_eq_map map_prefixI prefix_map_inj prefix_order.less_le)

lemma prefix_drop:
  "\<lbrakk> drop (length xs) ys = zs; prefix xs ys \<rbrakk>
   \<Longrightarrow> ys = xs @ zs"
  by (metis append_eq_conv_conj prefix_def)

lemma list_append_prefixD: "x @ y \<le> z \<Longrightarrow> x \<le> z"
  using append_prefixD less_eq_list_def by blast

subsection {* Minus on lists *}

instantiation list :: (type) minus
begin

text {* We define list minus so that if the second list is not a prefix of the first, then an arbitrary
        list longer than the combined length is produced. Thus we can always determined from the output
        whether the minus is defined or not. *}

definition "xs - ys = (if (prefix ys xs) then drop (length ys) xs else [])"

instance ..
end

lemma minus_cancel [simp]: "xs - xs = []"
  by (simp add: minus_list_def)

lemma append_minus [simp]: "(xs @ ys) - xs = ys"
  by (simp add: minus_list_def)

lemma minus_right_nil [simp]: "xs - [] = xs"
  by (simp add: minus_list_def)

lemma list_concat_minus_list_concat: "(s @ t) - (s @ z) = t - z"
  by (simp add: minus_list_def)

lemma length_minus_list: "y \<le> x \<Longrightarrow> length(x - y) = length(x) - length(y)"
  by (simp add: less_eq_list_def minus_list_def)

lemma length_gt_zero_butlast_concat:
  assumes "length ys > 0"
  shows "butlast (xs @ ys) = xs @ (butlast ys)"
  using assms by (metis butlast_append length_greater_0_conv)

lemma length_eq_zero_butlast_concat:
  assumes "length ys = 0"
  shows "butlast (xs @ ys) = butlast xs"
  using assms by (metis append_Nil2 length_0_conv)

lemma butlast_single_element:
  shows "butlast [e] = []"
  by (metis butlast.simps(2))

lemma last_single_element:
  shows "last [e] = e"
  by (metis last.simps)

lemma length_zero_last_concat:
  assumes "length t = 0"
  shows "last (s @ t) = last s"
  by (metis append_Nil2 assms length_0_conv)

lemma length_gt_zero_last_concat:
  assumes "length t > 0"
  shows "last (s @ t) = last t"
  by (metis assms last_append length_greater_0_conv)

subsection {* Interleaving operations *}

fun interleave :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list set" where
"interleave [] ys = {ys}" |
"interleave (x # xs) (y # ys) = (Cons x) ` (interleave xs (y # ys))
                              \<union> (Cons y) ` (interleave (x # xs) ys)" |
"interleave xs [] = {xs}"

lemma interleave_finite [simp]:
  "finite (interleave xs ys)"
  apply (induct xs arbitrary: ys)
  apply (simp)
  apply (induct_tac ys)
  apply (auto)
done

lemma interleave_right_nil [simp]:
  "interleave xs [] = {xs}"
  by (induct xs, auto)

lemma interleave_headE [elim!]:
  "\<lbrakk> z # zs \<in> interleave xs ys
   ; \<And> xs'. xs = z # xs' \<Longrightarrow> P
   ; \<And> ys'. ys = z # ys' \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply (induct xs)
  apply (auto)
  apply (induct ys)
  apply (auto)
done

lemma interleave_member:
  "\<lbrakk> zs \<in> interleave xs ys; z \<in> set zs \<rbrakk> \<Longrightarrow> z \<in> set xs \<or> z \<in> set ys"
  apply (induct xs arbitrary: zs)
  apply (auto)
  apply (induct ys)
  apply (auto)
oops

(* FIXME: What happens if no progress can be made? *)
fun intersync :: "'a set \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list set" where
"intersync s (x # xs) (y # ys)
  = (case (x = y , x \<in> s , y \<in> s) of
          (True  , True   , _      ) \<Rightarrow> Cons x ` intersync s xs ys |
          (True  , False  , _      ) \<Rightarrow> ((Cons x ` intersync s xs (y # ys))
                                         \<union> (Cons y ` intersync s (x # xs) ys)) |
          (False , True   , True   ) \<Rightarrow> {[]} |
          (False , True   , False  ) \<Rightarrow> Cons y ` intersync s (x # xs) ys |
          (False , False  , True   ) \<Rightarrow> Cons x ` intersync s xs (y # ys) |
          (False , False  , False  ) \<Rightarrow> ((Cons x ` intersync s xs (y # ys))
                                         \<union> (Cons y ` intersync s (x # xs) ys)))" |
"intersync s [] (y # ys) =
   (if (y \<in> s) then {[]} else Cons y ` intersync s [] ys)" |
"intersync s (x # xs) [] =
   (if (x \<in> s) then {[]} else Cons x ` intersync s xs [])" |
"intersync s [] [] = {[]}"

(* FIXME: We should be able to prove this property... *)
lemma intersync_empty_interleave:
  "intersync {} xs ys = interleave xs ys"
oops

subsection {* Sorting of lists *}

definition is_sorted_list_of_set :: "('a::ord) set \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_sorted_list_of_set A xs = ((\<forall> i<length(xs) - 1. xs!i < xs!(i + 1)) \<and> set(xs) = A)"

lemma sorted_distinct [intro]: "\<lbrakk> sorted (xs); distinct(xs) \<rbrakk> \<Longrightarrow> (\<forall> i<length xs - 1. xs!i < xs!(i + 1))"
  apply (induct xs)
  apply (auto)
  apply (metis Suc_mono distinct.simps(2) length_Cons lessI less_SucI less_le nth_Cons_Suc nth_eq_iff_index_eq sorted_equals_nth_mono)
done

lemma sorted_is_sorted_list_of_set:
  assumes "is_sorted_list_of_set A xs"
  shows "sorted(xs)" and "distinct(xs)"
using assms proof (induct xs arbitrary: A)
  show "sorted []"
    by auto
next
  show "distinct []"
    by auto
next
  fix A :: "'a set"
  case (Cons x xs) note hyps = this
  assume isl: "is_sorted_list_of_set A (x # xs)"
  hence srt: "(\<forall>i<length xs - Suc 0. xs ! i < xs ! Suc i)"
    using less_diff_conv by (auto simp add: is_sorted_list_of_set_def)
  with hyps(1) have srtd: "sorted xs"
    by (simp add: is_sorted_list_of_set_def)
  with isl show "sorted (x # xs)"
    apply (auto simp add: is_sorted_list_of_set_def)
    apply (metis length_pos_if_in_set less_imp_le nth_Cons_0 sorted.simps sorted_many sorted_single)
  done
  from srt hyps(2) have "distinct xs"
    by (simp add: is_sorted_list_of_set_def)
  with isl show "distinct (x # xs)"
  proof -
    have "(\<forall>n. \<not> n < length (x # xs) - 1 \<or> (x # xs) ! n < (x # xs) ! (n + 1)) \<and> set (x # xs) = A"
      by (meson \<open>is_sorted_list_of_set A (x # xs)\<close> is_sorted_list_of_set_def)
  then show ?thesis
      by (metis Nat.add_0_right One_nat_def \<open>distinct xs\<close> \<open>sorted (x # xs)\<close> add_Suc_right diff_Suc_Suc diff_zero distinct.simps(2) insert_iff length_pos_if_in_set linorder_not_less list.set(2) list.simps(1) list.simps(3) list.size(3) list.size(4) not_less_iff_gr_or_eq nth_Cons_0 nth_Cons_Suc sorted.cases)
  qed
qed

lemma is_sorted_list_of_set_alt_def:
  "is_sorted_list_of_set A xs \<longleftrightarrow> sorted (xs) \<and> distinct (xs) \<and> set(xs) = A"
  apply (auto intro: sorted_is_sorted_list_of_set)
  apply (auto simp add: is_sorted_list_of_set_def)
  apply (metis Nat.add_0_right One_nat_def add_Suc_right sorted_distinct)
done

(*
lemma sorted_alt_def:
  "(\<forall> i<(length xs) - 1. xs!i < xs!(i + 1)) \<longleftrightarrow> sorted (xs) \<and> distinct (xs)"
  apply (auto)
  sledgehammer
oops
*)

definition sorted_list_of_set_alt :: "('a::ord) set \<Rightarrow> 'a list" where
"sorted_list_of_set_alt A =
  (if (A = {}) then [] else (THE xs. is_sorted_list_of_set A xs))"

lemma is_sorted_list_of_set:
  "finite A \<Longrightarrow> is_sorted_list_of_set A (sorted_list_of_set A)"
  apply (simp add: is_sorted_list_of_set_def)
  apply (metis One_nat_def add.right_neutral add_Suc_right sorted_distinct sorted_list_of_set)
done

lemma sorted_list_of_set_other_def:
  "finite A \<Longrightarrow> sorted_list_of_set(A) = (THE xs. sorted(xs) \<and> distinct(xs) \<and> set xs = A)"
  apply (rule sym)
  apply (rule the_equality)
  apply (auto)
  apply (simp add: sorted_distinct_set_unique)
done

lemma sorted_list_of_set_alt [simp]:
  "finite A \<Longrightarrow> sorted_list_of_set_alt(A) = sorted_list_of_set(A)"
  apply (rule sym)
  apply (auto simp add: sorted_list_of_set_alt_def is_sorted_list_of_set_alt_def sorted_list_of_set_other_def)
done

text {* Greatest common prefix *}

fun gcp :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"gcp [] ys = []" |
"gcp (x # xs) (y # ys) = (if (x = y) then x # gcp xs ys else [])" |
"gcp _ _ = []"

lemma gcp_right [simp]: "gcp xs [] = []"
  by (induct xs, auto)

lemma gcp_append [simp]: "gcp (xs @ ys) (xs @ zs) = xs @ gcp ys zs"
  by (induct xs, auto)

lemma gcp_lb1: "prefix (gcp xs ys) xs"
  apply (induct xs arbitrary: ys, auto)
  apply (case_tac ys, auto)
done

lemma gcp_lb2: "prefix (gcp xs ys) ys"
  apply (induct ys arbitrary: xs, auto)
  apply (case_tac xs, auto)
done

interpretation prefix_semilattice: semilattice_inf gcp prefix strict_prefix
proof
  fix xs ys :: "'a list"
  show "prefix (gcp xs ys) xs"
    by (induct xs arbitrary: ys, auto, case_tac ys, auto)
  show "prefix (gcp xs ys) ys"
    by (induct ys arbitrary: xs, auto, case_tac xs, auto)
next
  fix xs ys zs :: "'a list"
  assume "prefix xs ys" "prefix xs zs"
  thus "prefix xs (gcp ys zs)"
    by (simp add: prefix_def, auto)
qed

text {* Extra laws to do with prefix and order *}

lemma lexord_append:
  assumes "(xs\<^sub>1 @ ys\<^sub>1, xs\<^sub>2 @ ys\<^sub>2) \<in> lexord R" "length(xs\<^sub>1) = length(xs\<^sub>2)"
  shows "(xs\<^sub>1, xs\<^sub>2) \<in> lexord R \<or> (xs\<^sub>1 = xs\<^sub>2 \<and> (ys\<^sub>1, ys\<^sub>2) \<in> lexord R)"
using assms
proof (induct xs\<^sub>2 arbitrary: xs\<^sub>1)
  case (Cons x\<^sub>2 xs\<^sub>2') note hyps = this
  from hyps(3) obtain x\<^sub>1 xs\<^sub>1' where xs\<^sub>1: "xs\<^sub>1 = x\<^sub>1 # xs\<^sub>1'" "length(xs\<^sub>1') = length(xs\<^sub>2')"
    by (auto, metis Suc_length_conv)
  with hyps(2) have xcases: "(x\<^sub>1, x\<^sub>2) \<in> R \<or> (xs\<^sub>1' @ ys\<^sub>1, xs\<^sub>2' @ ys\<^sub>2) \<in> lexord R"
    by (auto)
  show ?case
  proof (cases "(x\<^sub>1, x\<^sub>2) \<in> R")
    case True with xs\<^sub>1 show ?thesis
      by (auto)
  next
    case False
    with xcases have "(xs\<^sub>1' @ ys\<^sub>1, xs\<^sub>2' @ ys\<^sub>2) \<in> lexord R"
      by (auto)
    with hyps(1) xs\<^sub>1 have dichot: "(xs\<^sub>1', xs\<^sub>2') \<in> lexord R \<or> (xs\<^sub>1' = xs\<^sub>2' \<and> (ys\<^sub>1, ys\<^sub>2) \<in> lexord R)"
      by (auto)
    have "x\<^sub>1 = x\<^sub>2"
      using False hyps(2) xs\<^sub>1(1) by auto
    with dichot xs\<^sub>1 show ?thesis
      by (simp)
  qed
next
  case Nil thus ?case
    by auto
qed

lemma strict_prefix_lexord_rel:
  "strict_prefix xs ys \<Longrightarrow> (xs, ys) \<in> lexord R"
  by (metis Sublist.strict_prefixE' lexord_append_rightI)

lemma strict_prefix_lexord_left:
  assumes "trans R" "(xs, ys) \<in> lexord R" "strict_prefix xs' xs"
  shows "(xs', ys) \<in> lexord R"
  by (metis assms lexord_trans strict_prefix_lexord_rel)

lemma prefix_lexord_right:
  assumes "trans R" "(xs, ys) \<in> lexord R" "strict_prefix ys ys'"
  shows "(xs, ys') \<in> lexord R"
  by (metis assms lexord_trans strict_prefix_lexord_rel)

lemma lexord_eq_length:
  assumes "(xs, ys) \<in> lexord R" "length xs = length ys"
  shows "\<exists> i. (xs!i, ys!i) \<in> R \<and> i < length xs \<and> (\<forall> j<i. xs!j = ys!j)"
using assms proof (induct xs arbitrary: ys)
  case (Cons x xs) note hyps = this
  then obtain y ys' where ys: "ys = y # ys'" "length ys' = length xs"
    by (metis Suc_length_conv)
  show ?case
  proof (cases "(x, y) \<in> R")
    case True with ys show ?thesis
      by (rule_tac x="0" in exI, simp)
  next
    case False
    with ys hyps(2) have xy: "x = y" "(xs, ys') \<in> lexord R"
      by auto
    with hyps(1,3) ys obtain i where "(xs!i, ys'!i) \<in> R" "i < length xs" "(\<forall> j<i. xs!j = ys'!j)"
      by force
    with xy ys show ?thesis
      apply (rule_tac x="Suc i" in exI)
      apply (auto simp add: less_Suc_eq_0_disj)
    done
  qed
next
  case Nil thus ?case by (auto)
qed

lemma lexord_intro_elems:
  assumes "length xs > i" "length ys > i" "(xs!i, ys!i) \<in> R" "\<forall> j<i. xs!j = ys!j"
  shows "(xs, ys) \<in> lexord R"
using assms proof (induct i arbitrary: xs ys)
  case 0 thus ?case
    by (auto, metis lexord_cons_cons list.exhaust nth_Cons_0)
next
  case (Suc i) note hyps = this
  then obtain x' y' xs' ys' where "xs = x' # xs'" "ys = y' # ys'"
    by (metis Suc_length_conv Suc_lessE)
  moreover with hyps(5) have "\<forall>j<i. xs' ! j = ys' ! j"
    by (auto)
  ultimately show ?case using hyps
    by (auto)
qed

text {* Extra lemmas about @{term prefix} and @{term strict_prefix} *}

lemma prefix_concat_minus:
  assumes "prefix xs ys"
  shows "xs @ (ys - xs) = ys"
  using assms by (metis minus_list_def prefix_drop)

lemma prefix_minus_concat:
  assumes "prefix s t"
  shows "(t - s) @ z = (t @ z) - s"
  using assms by (simp add: Sublist.prefix_length_le minus_list_def)

lemma strict_prefix_minus_not_empty:
  assumes "strict_prefix xs ys"
  shows "ys - xs \<noteq> []"
  using assms by (metis append_Nil2 prefix_concat_minus strict_prefix_def)

lemma strict_prefix_diff_minus:
  assumes "prefix xs ys" and "xs \<noteq> ys"
  shows "(ys - xs) \<noteq> []"
  using assms by (simp add: strict_prefix_minus_not_empty)

lemma prefix_not_empty:
  assumes "strict_prefix xs ys" and "xs \<noteq> []"
  shows "ys \<noteq> []"
  using Sublist.strict_prefix_simps(1) assms(1) by blast

lemma prefix_not_empty_length_gt_zero:
  assumes "strict_prefix xs ys" and "xs \<noteq> []"
  shows "length ys > 0"
  using assms prefix_not_empty by auto

lemma butlast_prefix_suffix_not_empty:
  assumes "strict_prefix (butlast xs) ys"
  shows "ys \<noteq> []"
  using assms prefix_not_empty_length_gt_zero by fastforce

lemma length_tl_list_minus_butlast_gt_zero:
  assumes "length s < length t" and "strict_prefix (butlast s) t" and "length s > 0"
  shows "length (tl (t - (butlast s))) > 0"
  using assms
  by (metis Nitpick.size_list_simp(2) butlast_snoc hd_Cons_tl length_butlast length_greater_0_conv length_tl less_trans nat_neq_iff strict_prefix_minus_not_empty prefix_order.dual_order.strict_implies_order prefix_concat_minus)

lemma prefix_and_concat_prefix_is_concat_prefix:
  assumes "prefix s t" "prefix (e @ t) u"
  shows "prefix (e @ s) u"
  using Sublist.same_prefix_prefix assms(1) assms(2) prefix_order.dual_order.trans by blast

lemma list_minus_butlast_eq_butlast_list:
  assumes "length t = length s" and "strict_prefix (butlast s) t"
  shows "t - (butlast s) = [last t]"
  using assms
  by (metis append_butlast_last_id append_eq_append_conv butlast.simps(1) length_butlast less_numeral_extra(3) list.size(3) prefix_order.dual_order.strict_implies_order prefix_concat_minus prefix_length_less)

lemma strict_prefix_eq_exists:
  "strict_prefix s t \<longleftrightarrow> (\<exists>xs . s @ xs = t \<and> (length xs) > 0)"
  by (metis append_minus length_greater_0_conv prefix_def strict_prefix_minus_not_empty strict_prefix_def)

lemma butlast_strict_prefix_eq_butlast:
  assumes "length s = length t" and "strict_prefix (butlast s) t"
  shows "strict_prefix (butlast s) t \<longleftrightarrow> (butlast s) = (butlast t)"
  by (metis append_butlast_last_id append_eq_append_conv assms(1) assms(2) length_0_conv length_butlast strict_prefix_eq_exists)

lemma butlast_eq_if_eq_length_and_prefix:
  assumes "length s > 0" "length z > 0"
          "length s = length z" "strict_prefix (butlast s) t" "strict_prefix (butlast z) t"
  shows   "(butlast s) = (butlast z)"
  using assms by (auto simp add:strict_prefix_eq_exists)

lemma prefix_imp_length_lteq:
  assumes "prefix s t"
  shows "length s \<le> length t"
  using assms by (simp add: Sublist.prefix_length_le)

lemma prefix_imp_length_not_gt:
  assumes "prefix s t"
  shows "\<not> length t < length s"
  using assms by (simp add: Sublist.prefix_length_le leD)

lemma prefix_and_eq_length_imp_eq_list:
  assumes "prefix s t" and "length t = length s"
  shows "s=t"
  using assms by (simp add: prefix_length_eq)

lemma butlast_strict_prefix_length_lt_imp_last_tl_minus_butlast_eq_last:
  assumes "length s > 0" "strict_prefix (butlast s) t" "length s < length t"
  shows "last (tl (t - (butlast s))) = (last t)"
  using assms by (metis last_append last_tl length_tl_list_minus_butlast_gt_zero less_numeral_extra(3) list.size(3) append_minus strict_prefix_eq_exists)

lemma tl_list_minus_butlast_not_empty:
  assumes "strict_prefix (butlast s) t" and "length s > 0" and "length t > length s"
  shows "tl (t - (butlast s)) \<noteq> []"
  using assms length_tl_list_minus_butlast_gt_zero by fastforce

lemma tl_list_minus_butlast_empty:
  assumes "strict_prefix (butlast s) t" and "length s > 0" and "length t = length s"
  shows "tl (t - (butlast s)) = []"
  using assms by (simp add: list_minus_butlast_eq_butlast_list)

lemma concat_minus_list_concat_butlast_eq_list_minus_butlast:
  assumes "prefix (butlast u) s"
  shows "(t @ s) - (t @ (butlast u)) = s - (butlast u)"
  using assms by (metis append_assoc prefix_concat_minus append_minus)

lemma tl_list_minus_butlast_eq_empty:
  assumes "strict_prefix (butlast s) t" and "length s = length t"
  shows "tl (t - (butlast s)) = []"
  using assms by (metis list.sel(3) list_minus_butlast_eq_butlast_list)

(* this can be shown using length_tl, but care is needed when list is empty? *)
lemma prefix_length_tl_minus:
  assumes "strict_prefix s t"
  shows "length (tl (t-s)) = (length (t-s)) - 1"
  by (auto)

lemma length_list_minus:
  assumes "strict_prefix s t"
  shows "length(t - s) = length(t) - length(s)"
  using assms by (simp add: minus_list_def prefix_order.dual_order.strict_implies_order)

lemma butlast_prefix_imp_length_not_gt:
  assumes "length s > 0" "strict_prefix (butlast s) t"
  shows "\<not> (length t < length s)"
  using assms prefix_length_less by fastforce

lemma length_not_gt_iff_eq_length:
  assumes "length s > 0" and "strict_prefix (butlast s) t"
  shows "(\<not> (length s < length t)) = (length s = length t)"
proof -
  have "(\<not> (length s < length t)) = ((length t < length s) \<or> (length s = length t))"
      by (metis not_less_iff_gr_or_eq)
  also have "... = (length s = length t)"
      using assms
      by (simp add:butlast_prefix_imp_length_not_gt)

  finally show ?thesis .
qed

lemma dropWhile_sorted_le_above:
  "\<lbrakk> sorted xs; x \<in> set (dropWhile (\<lambda> x. x \<le> n) xs) \<rbrakk> \<Longrightarrow> x > n"
  apply (induct xs)
  apply (auto)
  apply (rename_tac a xs)
  apply (case_tac "a \<le> n")
  apply (simp_all)
  using sorted_Cons apply blast
  apply (meson dual_order.trans not_less sorted_Cons)
done

lemma set_dropWhile_le:
  "sorted xs \<Longrightarrow> set (dropWhile (\<lambda> x. x \<le> n) xs) = {x\<in>set xs. x > n}"
  apply (induct xs)
  apply (simp)
  apply (rename_tac x xs)
  apply (subgoal_tac "sorted xs")
  apply (simp)
  apply (safe)
  apply (simp_all)
  apply (meson not_less order_trans sorted_Cons)
  using sorted_Cons apply auto
done

lemma set_takeWhile_less_sorted:
  "\<lbrakk> sorted I; x \<in> set I; x < n \<rbrakk> \<Longrightarrow> x \<in> set (takeWhile (\<lambda>x. x < n) I)"
proof (induct I arbitrary: x)
  case Nil thus ?case
    by (simp)
next
  case (Cons a I) thus ?case
    by (auto, (meson le_less_trans sorted_Cons)+)
qed

lemma nth_le_takeWhile_ord: "\<lbrakk> sorted xs; i \<ge> length (takeWhile (\<lambda> x. x \<le> n) xs); i < length xs \<rbrakk> \<Longrightarrow> n \<le> xs ! i"
  apply (induct xs arbitrary: i, auto)
  apply (rename_tac x xs i)
  apply (case_tac "x \<le> n")
  apply (auto simp add: sorted_Cons)
  apply (metis One_nat_def Suc_eq_plus1 le_less_linear le_less_trans less_imp_le list.size(4) nth_mem set_ConsD)
done

lemma length_takeWhile_less:
  "\<lbrakk> a \<in> set xs; \<not> P a \<rbrakk> \<Longrightarrow> length (takeWhile P xs) < length xs"
  by (metis in_set_conv_nth length_takeWhile_le nat_neq_iff not_less set_takeWhileD takeWhile_nth)

lemma nth_length_takeWhile_less:
  "\<lbrakk> sorted xs; distinct xs; (\<exists> a \<in> set xs. a \<ge> n) \<rbrakk> \<Longrightarrow> xs ! length (takeWhile (\<lambda>x. x < n) xs) \<ge> n"
  apply (induct xs, auto)
  using sorted_Cons by blast

text {* Sorting lists according to a relation *}

definition is_sorted_list_of_set_by :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_sorted_list_of_set_by R A xs = ((\<forall> i<length(xs) - 1. (xs!i, xs!(i + 1)) \<in> R) \<and> set(xs) = A)"

definition sorted_list_of_set_by :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a list" where
"sorted_list_of_set_by R A = (THE xs. is_sorted_list_of_set_by R A xs)"

definition fin_set_lexord :: "'a rel \<Rightarrow> 'a set rel" where
"fin_set_lexord R = {(A, B). finite A \<and> finite B \<and>
                             (\<exists> xs ys. is_sorted_list_of_set_by R A xs \<and> is_sorted_list_of_set_by R B ys
                              \<and> (xs, ys) \<in> lexord R)}"

lemma is_sorted_list_of_set_by_mono:
  "\<lbrakk> R \<subseteq> S; is_sorted_list_of_set_by R A xs \<rbrakk> \<Longrightarrow> is_sorted_list_of_set_by S A xs"
  by (auto simp add: is_sorted_list_of_set_by_def)

lemma lexord_mono':
  "\<lbrakk> (\<And> x y. f x y \<longrightarrow> g x y); (xs, ys) \<in> lexord {(x, y). f x y} \<rbrakk> \<Longrightarrow> (xs, ys) \<in> lexord {(x, y). g x y}"
  by (metis case_prodD case_prodI lexord_take_index_conv mem_Collect_eq)

lemma fin_set_lexord_mono [mono]:
  "(\<And> x y. f x y \<longrightarrow> g x y) \<Longrightarrow> (xs, ys) \<in> fin_set_lexord {(x, y). f x y} \<longrightarrow> (xs, ys) \<in> fin_set_lexord {(x, y). g x y}"
proof
  assume
    fin: "(xs, ys) \<in> fin_set_lexord {(x, y). f x y}" and
    hyp: "(\<And> x y. f x y \<longrightarrow> g x y)"

  from fin have "finite xs" "finite ys"
    using fin_set_lexord_def by fastforce+

  with fin hyp show "(xs, ys) \<in> fin_set_lexord {(x, y). g x y}"
    apply (auto simp add: fin_set_lexord_def)
    apply (rule_tac x="xsa" in exI)
    apply (auto)
    apply (metis case_prodD case_prodI is_sorted_list_of_set_by_def mem_Collect_eq)
    apply (metis case_prodD case_prodI is_sorted_list_of_set_by_def lexord_mono' mem_Collect_eq)
  done
qed

definition distincts :: "'a set \<Rightarrow> 'a list set" where
"distincts A = {xs \<in> lists A. distinct(xs)}"

lemma tl_element:
  "\<lbrakk> x \<in> set xs; x \<noteq> hd(xs) \<rbrakk> \<Longrightarrow> x \<in> set(tl(xs))"
  by (metis in_set_insert insert_Nil list.collapse list.distinct(2) set_ConsD)

subsection {* Z mathematical tool kit for sequences *}

abbreviation seq_dom :: "'a list \<Rightarrow> nat set" ("dom\<^sub>l") where
"seq_dom xs \<equiv> {0..<length xs}"

abbreviation seq_ran :: "'a list \<Rightarrow> 'a set" ("ran\<^sub>l") where
"seq_ran xs \<equiv> set xs"

definition seq_extract :: "nat set \<Rightarrow> 'a list \<Rightarrow> 'a list" (infix "\<upharpoonleft>\<^sub>l" 80) where
"seq_extract A xs = sublist xs A"

lemma seq_extract_Nil [simp]: "A \<upharpoonleft>\<^sub>l [] = []"
  by (simp add: seq_extract_def)

lemma seq_extract_Cons:
  "A \<upharpoonleft>\<^sub>l (x # xs) = (if 0 \<in> A then [x] else []) @ {j. Suc j \<in> A} \<upharpoonleft>\<^sub>l xs"
  by (simp add: seq_extract_def sublist_Cons)

lemma seq_extract_empty [simp]: "{} \<upharpoonleft>\<^sub>l xs = []"
  by (simp add: seq_extract_def)

lemma seq_extract_ident [simp]: "{0..<length xs} \<upharpoonleft>\<^sub>l xs = xs"
  unfolding list_eq_iff_nth_eq
  by (auto simp add: seq_extract_def length_sublist atLeast0LessThan)

lemma seq_extract_split:
  assumes "i \<le> length xs"
  shows "{0..<i} \<upharpoonleft>\<^sub>l xs @ {i..<length xs} \<upharpoonleft>\<^sub>l xs = xs"
using assms
proof (induct xs arbitrary: i)
  case Nil thus ?case by (simp add: seq_extract_def)
next
  case (Cons x xs) note hyp = this
  have "{j. Suc j < i} = {0..<i - 1}"
    by (auto)
  moreover have "{j. i \<le> Suc j \<and> j < length xs} = {i - 1..<length xs}"
    by (auto)
  ultimately show ?case
    using hyp by (force simp add: seq_extract_def sublist_Cons)
qed

lemma seq_extract_append:
  "A \<upharpoonleft>\<^sub>l (xs @ ys) = (A \<upharpoonleft>\<^sub>l xs) @ ({j. j + length xs \<in> A} \<upharpoonleft>\<^sub>l ys)"
  by (simp add: seq_extract_def sublist_append)

lemma seq_extract_range: "A \<upharpoonleft>\<^sub>l xs = (A \<inter> dom\<^sub>l(xs)) \<upharpoonleft>\<^sub>l xs"
  apply (auto simp add: seq_extract_def sublist_def)
  apply (metis (no_types, lifting) atLeastLessThan_iff filter_cong in_set_zip nth_mem set_upt)
done

lemma seq_extract_out_of_range:
  "A \<inter> dom\<^sub>l(xs) = {} \<Longrightarrow> A \<upharpoonleft>\<^sub>l xs = []"
  by (metis seq_extract_def seq_extract_range sublist_empty)

lemma seq_extract_length [simp]:
  "length (A \<upharpoonleft>\<^sub>l xs) = card (A \<inter> dom\<^sub>l(xs))"
proof -
  have "{i. i < length(xs) \<and> i \<in> A} = (A \<inter> {0..<length(xs)})"
    by (auto)
  thus ?thesis
    by (simp add: seq_extract_def length_sublist)
qed

lemma seq_extract_Cons_atLeastLessThan:
  assumes "m < n"
  shows "{m..<n} \<upharpoonleft>\<^sub>l (x # xs) = (if (m = 0) then x # ({0..<n-1} \<upharpoonleft>\<^sub>l xs) else {m-1..<n-1} \<upharpoonleft>\<^sub>l xs)"
proof -
  have "{j. Suc j < n} = {0..<n - Suc 0}"
    by (auto)
  moreover have "{j. m \<le> Suc j \<and> Suc j < n} = {m - Suc 0..<n - Suc 0}"
    by (auto)

  ultimately show ?thesis using assms
    by (auto simp add: seq_extract_Cons)
qed

lemma seq_extract_singleton:
  assumes "i < length xs"
  shows "{i} \<upharpoonleft>\<^sub>l xs = [xs ! i]"
  using assms
  apply (induct xs arbitrary: i)
  apply (auto simp add: seq_extract_Cons)
  apply (rename_tac xs i)
  apply (subgoal_tac "{j. Suc j = i} = {i - 1}")
  apply (auto)
done

lemma seq_extract_as_map:
  assumes "m < n" "n \<le> length xs"
  shows "{m..<n} \<upharpoonleft>\<^sub>l xs = map (nth xs) [m..<n]"
using assms proof (induct xs arbitrary: m n)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  have "[m..<n] = m # [m+1..<n]"
    using Cons.prems(1) upt_eq_Cons_conv by blast
  moreover have "map (nth (x # xs)) [Suc m..<n] = map (nth xs) [m..<n-1]"
    by (simp add: map_nth_Cons_atLeastLessThan)
  ultimately show ?case
    using Cons upt_rec
    by (auto simp add: seq_extract_Cons_atLeastLessThan)
qed

lemma seq_append_as_extract:
  "xs = ys @ zs \<longleftrightarrow> (\<exists> i\<le>length(xs). ys = {0..<i} \<upharpoonleft>\<^sub>l xs \<and> zs = {i..<length(xs)} \<upharpoonleft>\<^sub>l xs)"
proof
  assume xs: "xs = ys @ zs"
  moreover have "ys = {0..<length ys} \<upharpoonleft>\<^sub>l (ys @ zs)"
    by (simp add: seq_extract_append)
  moreover have "zs = {length ys..<length ys + length zs} \<upharpoonleft>\<^sub>l (ys @ zs)"
  proof -
    have "{length ys..<length ys + length zs} \<inter> {0..<length ys} = {}"
      by auto
    moreover have s1: "{j. j < length zs} = {0..<length zs}"
      by auto
    ultimately show ?thesis
      by (simp add: seq_extract_append seq_extract_out_of_range)
  qed
  ultimately show "(\<exists> i\<le>length(xs). ys = {0..<i} \<upharpoonleft>\<^sub>l xs \<and> zs = {i..<length(xs)} \<upharpoonleft>\<^sub>l xs)"
    by (rule_tac x="length ys" in exI, auto)
next
  assume "\<exists>i\<le>length xs. ys = {0..<i} \<upharpoonleft>\<^sub>l xs \<and> zs = {i..<length xs} \<upharpoonleft>\<^sub>l xs"
  thus "xs = ys @ zs"
    by (auto simp add: seq_extract_split)
qed

definition seq_filter :: "'a list \<Rightarrow> 'a set \<Rightarrow> 'a list" (infix "\<restriction>\<^sub>l" 80) where
"seq_filter xs A = filter (\<lambda> x. x \<in> A) xs"

lemma seq_filter_Nil [simp]: "[] \<restriction>\<^sub>l A = []"
  by (simp add: seq_filter_def)

lemma seq_filter_empty [simp]: "xs \<restriction>\<^sub>l {} = []"
  by (simp add: seq_filter_def)

lemma seq_filter_append: "(xs @ ys) \<restriction>\<^sub>l A = (xs \<restriction>\<^sub>l A) @ (ys \<restriction>\<^sub>l A)"
  by (simp add: seq_filter_def)

subsection {* Distributed Concatenation *}

definition uncurry :: "('a \<Rightarrow> 'b \<Rightarrow>  'c) \<Rightarrow> ('a \<times> 'b \<Rightarrow> 'c)" where
[simp]: "uncurry f = (\<lambda>(x, y). f x y)"

definition dist_concat ::
  "'a list set \<Rightarrow> 'a list set \<Rightarrow> 'a list set" (infixr "\<^sup>\<frown>" 100) where
"dist_concat ls1 ls2 = (uncurry (op @) ` (ls1 \<times> ls2))"

lemma dist_concat_left_empty [simp]:
  "{} \<^sup>\<frown> ys = {}"
  by (simp add: dist_concat_def)

lemma dist_concat_right_empty [simp]:
  "xs \<^sup>\<frown> {} = {}"
  by (simp add: dist_concat_def)

lemma dist_concat_insert [simp]:
"insert l ls1 \<^sup>\<frown> ls2 = ((op @ l) ` ( ls2)) \<union> (ls1 \<^sup>\<frown> ls2)"
  by (auto simp add: dist_concat_def)
end