theory ASC_Sufficiency
  imports ASC_Suite
begin

section {* Sufficiency of the test suite to test for reduction *}

text \<open>
This section provides a proof that the test suite generated by the adaptive state counting algorithm
is sufficient to test for reduction.
\<close>

subsection {* Properties of minimal sequences to failures extending the deterministic state cover *}

text \<open>
The following two lemmata show that minimal sequences to failures extending the deterministic state
cover do not with their extending suffix visit any state twice or visit a state also reached by a
sequence in the chosen permutation of reactions to the deterministic state cover.
\<close>

lemma minimal_sequence_to_failure_extending_implies_Rep_Pre :
  assumes "minimal_sequence_to_failure_extending V M1 M2 vs xs"
  and     "OFSM M1"
  and     "OFSM M2"
  and     "test_tools M2 M1 FAIL PM V \<Omega>"
  and     "V'' \<in> N (vs@xs') M1 V"
  and     "prefix xs' xs"
  shows "\<not> Rep_Pre M2 M1 vs xs'"
proof
  assume "Rep_Pre M2 M1 vs xs'"
  then obtain xs1 xs2 s1 s2 where  "prefix xs1 xs2"
                                   "prefix xs2 xs'"
                                   "xs1 \<noteq> xs2"
                                   "io_targets M2 (initial M2) (vs @ xs1) = {s2}"
                                   "io_targets M2 (initial M2) (vs @ xs2) = {s2}"
                                   "io_targets M1 (initial M1) (vs @ xs1) = {s1}"
                                   "io_targets M1 (initial M1) (vs @ xs2) = {s1}"
    by auto
  then have "s2 \<in> io_targets M2 (initial M2) (vs @ xs1)"
            "s2 \<in> io_targets M2 (initial M2) (vs @ xs2)"
            "s1 \<in> io_targets M1 (initial M1) (vs @ xs1)"
            "s1 \<in> io_targets M1 (initial M1) (vs @ xs2)"
    by auto

  have "vs@xs1 \<in> L M1"
    using io_target_implies_L[OF \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs1)\<close>] by assumption
  have "vs@xs2 \<in> L M1"
    using io_target_implies_L[OF \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs2)\<close>] by assumption
  have "vs@xs1 \<in> L M2"
    using io_target_implies_L[OF \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs1)\<close>] by assumption
  have "vs@xs2 \<in> L M2"
    using io_target_implies_L[OF \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs2)\<close>] by assumption

  obtain tr1_1 where "path M1 (vs@xs1 || tr1_1) (initial M1)"
                     "length tr1_1 = length (vs@xs1)"
                     "target (vs@xs1 || tr1_1) (initial M1) = s1"
    using \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs1)\<close> by auto
  obtain tr1_2 where "path M1 (vs@xs2 || tr1_2) (initial M1)"
                     "length tr1_2 = length (vs@xs2)"
                     "target (vs@xs2 || tr1_2) (initial M1) = s1"
    using \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs2)\<close> by auto
  obtain tr2_1 where "path M2 (vs@xs1 || tr2_1) (initial M2)"
                     "length tr2_1 = length (vs@xs1)"
                     "target (vs@xs1 || tr2_1) (initial M2) = s2"
    using \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs1)\<close> by auto
  obtain tr2_2 where "path M2 (vs@xs2 || tr2_2) (initial M2)"
                     "length tr2_2 = length (vs@xs2)"
                     "target (vs@xs2 || tr2_2) (initial M2) = s2"
    using \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs2)\<close> by auto

  have "productF M2 M1 FAIL PM"
    using assms(4) by auto
  have "well_formed M1"
    using assms(2) by auto
  have "well_formed M2"
    using assms(3) by auto
  have "observable PM"
    by (meson assms(2) assms(3) assms(4) observable_productF)

  have "length (vs@xs1) = length tr2_1"
    using \<open>length tr2_1 = length (vs @ xs1)\<close> by presburger
  then have "length tr2_1 = length tr1_1"
    using \<open>length tr1_1 = length (vs@xs1)\<close> by presburger

  have "vs@xs1 \<in> L PM"
    using productF_path_inclusion[OF \<open>length (vs@xs1) = length tr2_1\<close> \<open>length tr2_1 = length tr1_1\<close>
                                     \<open>productF M2 M1 FAIL PM\<close> \<open>well_formed M2\<close> \<open>well_formed M1\<close>]
    by (meson Int_iff \<open>productF M2 M1 FAIL PM\<close> \<open>vs @ xs1 \<in> L M1\<close> \<open>vs @ xs1 \<in> L M2\<close> \<open>well_formed M1\<close>
        \<open>well_formed M2\<close> productF_language)

  have "length (vs@xs2) = length tr2_2"
    using \<open>length tr2_2 = length (vs @ xs2)\<close> by presburger
  then have "length tr2_2 = length tr1_2"
    using \<open>length tr1_2 = length (vs@xs2)\<close> by presburger

  have "vs@xs2 \<in> L PM"
    using productF_path_inclusion[OF \<open>length (vs@xs2) = length tr2_2\<close> \<open>length tr2_2 = length tr1_2\<close>
                                     \<open>productF M2 M1 FAIL PM\<close> \<open>well_formed M2\<close> \<open>well_formed M1\<close>]
    by (meson Int_iff \<open>productF M2 M1 FAIL PM\<close> \<open>vs @ xs2 \<in> L M1\<close> \<open>vs @ xs2 \<in> L M2\<close> \<open>well_formed M1\<close>
        \<open>well_formed M2\<close> productF_language)

  have "io_targets PM (initial M2, initial M1) (vs @ xs1) = {(s2, s1)}"
    using productF_path_io_targets_reverse
          [OF \<open>productF M2 M1 FAIL PM\<close> \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs1)\<close>
              \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs1)\<close> \<open>vs @ xs1 \<in> L M2\<close> \<open>vs @ xs1 \<in> L M1\<close> ]
  proof -
    have "\<forall>c f. c \<noteq> initial (f::('a, 'b, 'c) FSM) \<or> c \<in> nodes f"
      by blast
    then show ?thesis
      by (metis (no_types) \<open>\<lbrakk>observable M2; observable M1; well_formed M2; well_formed M1;
                             initial M2 \<in> nodes M2; initial M1 \<in> nodes M1\<rbrakk>
                            \<Longrightarrow> io_targets PM (initial M2, initial M1) (vs @ xs1) = {(s2, s1)}\<close>
          assms(2) assms(3))
  qed

  have "io_targets PM (initial M2, initial M1) (vs @ xs2) = {(s2, s1)}"
    using productF_path_io_targets_reverse
          [OF \<open>productF M2 M1 FAIL PM\<close> \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs2)\<close>
              \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs2)\<close> \<open>vs @ xs2 \<in> L M2\<close> \<open>vs @ xs2 \<in> L M1\<close> ]
  proof -
    have "\<forall>c f. c \<noteq> initial (f::('a, 'b, 'c) FSM) \<or> c \<in> nodes f"
      by blast
    then show ?thesis
      by (metis (no_types) \<open>\<lbrakk>observable M2; observable M1; well_formed M2; well_formed M1;
                             initial M2 \<in> nodes M2; initial M1 \<in> nodes M1\<rbrakk>
                            \<Longrightarrow> io_targets PM (initial M2, initial M1) (vs @ xs2) = {(s2, s1)}\<close>
          assms(2) assms(3))
  qed

  have "prefix (vs @ xs1) (vs @ xs2)"
    using \<open>prefix xs1 xs2\<close> by auto

  have "sequence_to_failure M1 M2 (vs@xs)"
    using assms(1) by auto

  have "prefix (vs@xs1) (vs@xs')"
    using \<open>prefix xs1 xs2\<close> \<open>prefix xs2 xs'\<close> prefix_order.dual_order.trans same_prefix_prefix
    by blast
  have "prefix (vs@xs2) (vs@xs')"
    using \<open>prefix xs2 xs'\<close> prefix_order.dual_order.trans same_prefix_prefix by blast

  have "io_targets PM (initial PM) (vs @ xs1) = {(s2,s1)}"
    using \<open>io_targets PM (initial M2, initial M1) (vs @ xs1) = {(s2, s1)}\<close> assms(4) by auto
  have "io_targets PM (initial PM) (vs @ xs2) = {(s2,s1)}"
    using \<open>io_targets PM (initial M2, initial M1) (vs @ xs2) = {(s2, s1)}\<close> assms(4) by auto

  have "(vs @ xs2) @ (drop (length xs2) xs) = vs@xs"
    by (metis \<open>prefix xs2 xs'\<close>  append_eq_appendI append_eq_conv_conj assms(6) prefixE)
  moreover have "io_targets PM (initial PM) (vs@xs) = {FAIL}"
    using sequence_to_failure_reaches_FAIL_ob[OF \<open>sequence_to_failure M1 M2 (vs@xs)\<close> assms(2,3)
                                                 \<open>productF M2 M1 FAIL PM\<close>]
    by assumption
  ultimately have "io_targets PM (initial PM) ((vs @ xs2) @ (drop (length xs2) xs)) = {FAIL}"
    by auto

  have "io_targets PM (s2,s1) (drop (length xs2) xs) = {FAIL}"
    using observable_io_targets_split
          [OF \<open>observable PM\<close>
              \<open>io_targets PM (initial PM) ((vs @ xs2) @ (drop (length xs2) xs)) = {FAIL}\<close>
              \<open>io_targets PM (initial PM) (vs @ xs2) = {(s2, s1)}\<close>]
    by assumption

  have "io_targets PM (initial PM) (vs@xs1@(drop (length xs2) xs)) = {FAIL}"
    using observable_io_targets_append
          [OF \<open>observable PM\<close> \<open>io_targets PM (initial PM) (vs @ xs1) = {(s2,s1)}\<close>
              \<open>io_targets PM (s2,s1) (drop (length xs2) xs) = {FAIL}\<close>]
    by simp
  have "sequence_to_failure M1 M2 (vs@xs1@(drop (length xs2) xs))"
    using sequence_to_failure_alt_def
          [OF \<open>io_targets PM (initial PM) (vs@xs1@(drop (length xs2) xs)) = {FAIL}\<close> assms(2,3)]
          assms(4)
    by blast

  have "length xs1 < length xs2"
    using \<open>prefix xs1 xs2\<close> \<open>xs1 \<noteq> xs2\<close> prefix_length_prefix by fastforce
  have "xs = (xs1 @ (drop (length xs1) xs))"
    by (metis (no_types) \<open>(vs @ xs2) @ drop (length xs2) xs = vs @ xs\<close> \<open>prefix xs1 xs2\<close>
        append_assoc append_eq_conv_conj prefixE)
  have "length xs1 < length xs"
    using \<open>prefix xs1 xs2\<close> \<open>prefix xs2 xs'\<close> \<open>xs = xs1 @ drop (length xs1) xs\<close> \<open>xs1 \<noteq> xs2\<close>
          assms(6) leI
    by fastforce
  have "length (xs1@(drop (length xs2) xs)) < length xs"
    using \<open>length xs1 < length xs2\<close> \<open>length xs1 < length xs\<close> by auto

  have "vs \<in> L\<^sub>i\<^sub>n M1 V
        \<and> sequence_to_failure M1 M2 (vs @ xs1@(drop (length xs2) xs))
        \<and> length (xs1@(drop (length xs2) xs)) < length xs"
    using \<open>length (xs1 @ drop (length xs2) xs) < length xs\<close>
          \<open>sequence_to_failure M1 M2 (vs @ xs1 @ drop (length xs2) xs)\<close>
          assms(1) minimal_sequence_to_failure_extending.simps
    by blast

  then have "\<not> minimal_sequence_to_failure_extending V M1 M2 vs xs"
    by (meson minimal_sequence_to_failure_extending.elims(2))

  then show "False"
    using assms(1) by linarith
qed

lemma minimal_sequence_to_failure_extending_implies_Rep_Cov :
  assumes "minimal_sequence_to_failure_extending V M1 M2 vs xs"
  and     "OFSM M1"
  and     "OFSM M2"
  and     "test_tools M2 M1 FAIL PM V \<Omega>"
  and     "V'' \<in> N (vs@xsR) M1 V"
  and     "prefix xsR xs"
shows "\<not> Rep_Cov M2 M1 V'' vs xsR"
proof
  assume "Rep_Cov M2 M1 V'' vs xsR"
  then obtain xs' vs' s2 s1 where "xs' \<noteq> []"
                                  "prefix xs' xsR"
                                  "vs' \<in> V''"
                                  "io_targets M2 (initial M2) (vs @ xs') = {s2}"
                                  "io_targets M2 (initial M2) (vs') = {s2}"
                                  "io_targets M1 (initial M1) (vs @ xs') = {s1}"
                                  "io_targets M1 (initial M1) (vs') = {s1}"
    by auto

  then have "s2 \<in> io_targets M2 (initial M2) (vs @ xs')"
            "s2 \<in> io_targets M2 (initial M2) (vs')"
            "s1 \<in> io_targets M1 (initial M1) (vs @ xs')"
            "s1 \<in> io_targets M1 (initial M1) (vs')"
    by auto

  have "vs@xs' \<in> L M1"
    using io_target_implies_L[OF \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs')\<close>] by assumption
  have "vs' \<in> L M1"
    using io_target_implies_L[OF \<open>s1 \<in> io_targets M1 (initial M1) (vs')\<close>] by assumption
  have "vs@xs' \<in> L M2"
    using io_target_implies_L[OF \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs')\<close>] by assumption
  have "vs' \<in> L M2"
    using io_target_implies_L[OF \<open>s2 \<in> io_targets M2 (initial M2) (vs')\<close>] by assumption

  obtain tr1_1 where "path M1 (vs@xs' || tr1_1) (initial M1)"
                     "length tr1_1 = length (vs@xs')"
                     "target (vs@xs' || tr1_1) (initial M1) = s1"
    using \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs')\<close> by auto
  obtain tr1_2 where "path M1 (vs' || tr1_2) (initial M1)"
                     "length tr1_2 = length (vs')"
                     "target (vs' || tr1_2) (initial M1) = s1"
    using \<open>s1 \<in> io_targets M1 (initial M1) (vs')\<close> by auto
  obtain tr2_1 where "path M2 (vs@xs' || tr2_1) (initial M2)"
                     "length tr2_1 = length (vs@xs')"
                     "target (vs@xs' || tr2_1) (initial M2) = s2"
    using \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs')\<close> by auto
  obtain tr2_2 where "path M2 (vs' || tr2_2) (initial M2)"
                     "length tr2_2 = length (vs')"
                     "target (vs' || tr2_2) (initial M2) = s2"
    using \<open>s2 \<in> io_targets M2 (initial M2) (vs')\<close> by auto

  have "productF M2 M1 FAIL PM"
    using assms(4) by auto
  have "well_formed M1"
    using assms(2) by auto
  have "well_formed M2"
    using assms(3) by auto
  have "observable PM"
    by (meson assms(2) assms(3) assms(4) observable_productF)

  have "length (vs@xs') = length tr2_1"
    using \<open>length tr2_1 = length (vs @ xs')\<close> by presburger
  then have "length tr2_1 = length tr1_1"
    using \<open>length tr1_1 = length (vs@xs')\<close> by presburger

  have "vs@xs' \<in> L PM"
    using productF_path_inclusion[OF \<open>length (vs@xs') = length tr2_1\<close> \<open>length tr2_1 = length tr1_1\<close>
                                     \<open>productF M2 M1 FAIL PM\<close> \<open>well_formed M2\<close> \<open>well_formed M1\<close>]
    by (meson Int_iff \<open>productF M2 M1 FAIL PM\<close> \<open>vs @ xs' \<in> L M1\<close> \<open>vs @ xs' \<in> L M2\<close> \<open>well_formed M1\<close>
        \<open>well_formed M2\<close> productF_language)

  have "length (vs') = length tr2_2"
    using \<open>length tr2_2 = length (vs')\<close> by presburger
  then have "length tr2_2 = length tr1_2"
    using \<open>length tr1_2 = length (vs')\<close> by presburger

  have "vs' \<in> L PM"
    using productF_path_inclusion[OF \<open>length (vs') = length tr2_2\<close> \<open>length tr2_2 = length tr1_2\<close>
                                     \<open>productF M2 M1 FAIL PM\<close> \<open>well_formed M2\<close> \<open>well_formed M1\<close>]
    by (meson Int_iff \<open>productF M2 M1 FAIL PM\<close> \<open>vs' \<in> L M1\<close> \<open>vs' \<in> L M2\<close> \<open>well_formed M1\<close>
        \<open>well_formed M2\<close> productF_language)

  have "io_targets PM (initial M2, initial M1) (vs @ xs') = {(s2, s1)}"
    using productF_path_io_targets_reverse
          [OF \<open>productF M2 M1 FAIL PM\<close> \<open>s2 \<in> io_targets M2 (initial M2) (vs @ xs')\<close>
              \<open>s1 \<in> io_targets M1 (initial M1) (vs @ xs')\<close> \<open>vs @ xs' \<in> L M2\<close> \<open>vs @ xs' \<in> L M1\<close> ]
  proof -
    have "\<forall>c f. c \<noteq> initial (f::('a, 'b, 'c) FSM) \<or> c \<in> nodes f"
      by blast
    then show ?thesis
      by (metis (no_types) \<open>\<lbrakk>observable M2; observable M1; well_formed M2; well_formed M1;
                              initial M2 \<in> nodes M2; initial M1 \<in> nodes M1\<rbrakk>
                            \<Longrightarrow> io_targets PM (initial M2, initial M1) (vs @ xs') = {(s2, s1)}\<close>
          assms(2) assms(3))
  qed

  have "io_targets PM (initial M2, initial M1) (vs') = {(s2, s1)}"
    using productF_path_io_targets_reverse
          [OF \<open>productF M2 M1 FAIL PM\<close> \<open>s2 \<in> io_targets M2 (initial M2) (vs')\<close>
              \<open>s1 \<in> io_targets M1 (initial M1) (vs')\<close> \<open>vs' \<in> L M2\<close> \<open>vs' \<in> L M1\<close> ]
  proof -
    have "\<forall>c f. c \<noteq> initial (f::('a, 'b, 'c) FSM) \<or> c \<in> nodes f"
      by blast
    then show ?thesis
      by (metis (no_types) \<open>\<lbrakk>observable M2; observable M1; well_formed M2; well_formed M1;
                              initial M2 \<in> nodes M2; initial M1 \<in> nodes M1\<rbrakk>
                            \<Longrightarrow> io_targets PM (initial M2, initial M1) (vs') = {(s2, s1)}\<close>
          assms(2) assms(3))
  qed
  have "io_targets PM (initial PM) (vs') = {(s2, s1)}"
    by (metis (no_types) \<open>io_targets PM (initial M2, initial M1) vs' = {(s2, s1)}\<close>
        \<open>productF M2 M1 FAIL PM\<close> productF_simps(4))

  have "sequence_to_failure M1 M2 (vs@xs)"
    using assms(1) by auto

  have "xs = xs' @ (drop (length xs') xs)"
    by (metis \<open>prefix xs' xsR\<close> append_assoc append_eq_conv_conj assms(6) prefixE)
  then have "io_targets PM (initial M2, initial M1) (vs @ xs' @ (drop (length xs') xs)) = {FAIL}"
    by (metis \<open>productF M2 M1 FAIL PM\<close> \<open>sequence_to_failure M1 M2 (vs @ xs)\<close> assms(2) assms(3)
        productF_simps(4) sequence_to_failure_reaches_FAIL_ob)
  then have "io_targets PM (initial M2, initial M1) ((vs @ xs') @ (drop (length xs') xs)) = {FAIL}"
    by auto
  have "io_targets PM (s2, s1) (drop (length xs') xs) = {FAIL}"
    using observable_io_targets_split
          [OF \<open>observable PM\<close>
              \<open>io_targets PM (initial M2,initial M1) ((vs @ xs') @ (drop (length xs') xs)) = {FAIL}\<close>
              \<open>io_targets PM (initial M2, initial M1) (vs @ xs') = {(s2, s1)}\<close>]
    by assumption

  have "io_targets PM (initial PM) (vs' @ (drop (length xs') xs)) = {FAIL}"
    using observable_io_targets_append
          [OF \<open>observable PM\<close> \<open>io_targets PM (initial PM) (vs') = {(s2, s1)}\<close>
              \<open>io_targets PM (s2, s1) (drop (length xs') xs) = {FAIL}\<close>]
    by assumption

  have "sequence_to_failure M1 M2 (vs' @ (drop (length xs') xs))"
    using sequence_to_failure_alt_def
          [OF \<open>io_targets PM (initial PM) (vs' @ (drop (length xs') xs)) = {FAIL}\<close> assms(2,3)]
          assms(4)
    by blast

  have "length (drop (length xs') xs) < length xs"
    by (metis (no_types) \<open>xs = xs' @ drop (length xs') xs\<close> \<open>xs' \<noteq> []\<close> length_append
        length_greater_0_conv less_add_same_cancel2)

  have "vs' \<in> L\<^sub>i\<^sub>n M1 V"
  proof -
    have "V'' \<in> Perm V M1"
      using assms(5) unfolding N.simps by blast

    then obtain f where f_def : "V'' = image f V
                                  \<and> (\<forall> v \<in> V . f v \<in> language_state_for_input M1 (initial M1) v)"
      unfolding Perm.simps by blast
    then obtain v where "v \<in> V" "vs' = f v"
      using \<open>vs' \<in> V''\<close> by auto
    then have "vs' \<in> language_state_for_input M1 (initial M1) v"
      using f_def by auto

    have "language_state_for_input M1 (initial M1) v = L\<^sub>i\<^sub>n M1 {v}"
      by auto
    moreover have "{v} \<subseteq> V"
      using \<open>v \<in> V\<close> by blast
    ultimately have "language_state_for_input M1 (initial M1) v \<subseteq> L\<^sub>i\<^sub>n M1 V"
      unfolding language_state_for_inputs.simps language_state_for_input.simps by blast
    then show ?thesis
      using\<open>vs' \<in> language_state_for_input M1 (initial M1) v\<close> by blast
  qed

  have "\<not> minimal_sequence_to_failure_extending V M1 M2 vs xs"
    using \<open>vs' \<in> L\<^sub>i\<^sub>n M1 V\<close>
          \<open>sequence_to_failure M1 M2 (vs' @ (drop (length xs') xs))\<close>
          \<open>length (drop (length xs') xs) < length xs\<close>
    using minimal_sequence_to_failure_extending.elims(2) by blast
  then show "False"
    using assms(1) by linarith
qed

lemma mstfe_no_repetition :
  assumes "minimal_sequence_to_failure_extending V M1 M2 vs xs"
  and     "OFSM M1"
  and     "OFSM M2"
  and     "test_tools M2 M1 FAIL PM V \<Omega>"
  and     "V'' \<in> N (vs@xs') M1 V"
  and     "prefix xs' xs"
shows "\<not> Rep_Pre M2 M1 vs xs'"
  and "\<not> Rep_Cov M2 M1 V'' vs xs'"
  using minimal_sequence_to_failure_extending_implies_Rep_Pre[OF assms]
        minimal_sequence_to_failure_extending_implies_Rep_Cov[OF assms]
  by linarith+

subsection {* Sufficiency of the test suite to test for reduction *}

text \<open>
The following lemma proves that set of input sequences generated in the final iteration of the
@{verbatim TS} function constitutes a test suite sufficient to test for reduction the FSMs it has
been generated for.

This proof is performed by contradiction: If the test suite is not sufficient, then some minimal
sequence to a failure extending the deterministic state cover must exist. Due to the test suite
being assumed insufficient, this sequence cannot be contained in it and hence a prefix of it must
have been contained in one of the sets calculated by the @{verbatim R} function. This is only
possible if the prefix is not a minimal sequence to a failure extending the deterministic state
cover or if the test suite observes a failure, both of which violates the assumptions.
\<close>

lemma asc_sufficiency :
  assumes "OFSM M1"
  and     "OFSM M2"
  and     "asc_fault_domain M2 M1 m"
  and     "test_tools M2 M1 FAIL PM V \<Omega>"
  and     "final_iteration M2 M1 \<Omega> V m i"
shows "M1 \<preceq>\<lbrakk>(TS M2 M1 \<Omega> V m i) . \<Omega>\<rbrakk> M2 \<longrightarrow> M1 \<preceq> M2"
proof
  assume "atc_io_reduction_on_sets M1 (TS M2 M1 \<Omega> V m i) \<Omega> M2"
  show "M1 \<preceq> M2"
  proof (rule ccontr)

    let ?TS = "\<lambda> n . TS M2 M1 \<Omega> V m n"
    let ?C = "\<lambda> n . C M2 M1 \<Omega> V m n"
    let ?RM = "\<lambda> n . RM M2 M1 \<Omega> V m n"

    assume "\<not> M1 \<preceq> M2"
    obtain vs xs where "minimal_sequence_to_failure_extending V M1 M2 vs xs"
      using  assms(1) assms(2) assms(4)
             minimal_sequence_to_failure_extending_det_state_cover_ob[OF _ _ _  \<open>\<not> M1 \<preceq> M2\<close>, of V]
      by blast

    then have "vs \<in> L\<^sub>i\<^sub>n M1 V"
              "sequence_to_failure M1 M2 (vs @ xs)"
              "\<not> (\<exists> io' . \<exists> w' \<in> L\<^sub>i\<^sub>n M1 V . sequence_to_failure M1 M2 (w' @ io')
                                                          \<and> length io' < length xs)"
      by auto

    then have "vs@xs \<in> L M1 - L M2"
      by auto

    have "vs@xs \<in> L\<^sub>i\<^sub>n M1 {map fst (vs@xs)}"
      by (metis (full_types) Diff_iff \<open>vs @ xs \<in> L M1 - L M2\<close> insertI1
          language_state_for_inputs_map_fst)

    have "vs@xs \<notin> L\<^sub>i\<^sub>n M2 {map fst (vs@xs)}"
      by (meson Diff_iff \<open>vs @ xs \<in> L M1 - L M2\<close> language_state_for_inputs_in_language_state
          subsetCE)

    have "finite V"
      using det_state_cover_finite assms(4,2) by auto
    then have "finite (?TS i)"
      using TS_finite[of V M2] assms(2) by auto
    then have "io_reduction_on M1 (?TS i) M2"
      using io_reduction_from_atc_io_reduction
            [OF \<open>atc_io_reduction_on_sets M1 (TS M2 M1 \<Omega> V m i) \<Omega> M2\<close>]
      by auto

    have "map fst (vs@xs) \<notin> ?TS i"
    proof -
      have f1: "\<forall>ps P Pa. (ps::('a \<times> 'b) list) \<notin> P - Pa \<or> ps \<in> P \<and> ps \<notin> Pa"
        by blast
      have "\<forall>P Pa ps. \<not> P \<subseteq> Pa \<or> (ps::('a \<times> 'b) list) \<in> Pa \<or> ps \<notin> P"
        by blast
      then show ?thesis
        using f1 by (metis (no_types) \<open>vs @ xs \<in> L M1 - L M2\<close> \<open>io_reduction_on M1 (?TS i) M2\<close>
                     language_state_for_inputs_in_language_state language_state_for_inputs_map_fst)
    qed

    have "map fst vs \<in> V"
      using \<open>vs \<in> L\<^sub>i\<^sub>n M1 V\<close> by auto

    let ?stf = "map fst (vs@xs)"
    let ?stfV = "map fst vs"
    let ?stfX = "map fst xs"
    have "?stf = ?stfV @ ?stfX"
      by simp

    then have "?stfV @ ?stfX \<notin> ?TS i"
      using \<open>?stf \<notin> ?TS i\<close> by auto

    have "mcp (?stfV @ ?stfX) V ?stfV"
      by (metis \<open>map fst (vs @ xs) = map fst vs @ map fst xs\<close>
          \<open>minimal_sequence_to_failure_extending V M1 M2 vs xs\<close> assms(1) assms(2) assms(4)
          minimal_sequence_to_failure_extending_mcp)

    have "set ?stf \<subseteq> inputs M1"
      by (meson DiffD1 \<open>vs @ xs \<in> L M1 - L M2\<close> assms(1) language_state_inputs)
    then have "set ?stf \<subseteq> inputs M2"
      using assms(3) by blast
    moreover have "set ?stf = set ?stfV \<union> set ?stfX"
      by simp
    ultimately have "set ?stfX \<subseteq> inputs M2"
      by blast

    obtain xr j where "xr \<noteq> ?stfX"
                      "prefix xr ?stfX"
                      "Suc j \<le> i"
                      "?stfV@xr \<in> RM M2 M1 \<Omega> V m (Suc j)"
      using TS_non_containment_causes_final_suc[OF \<open>?stfV @ ?stfX \<notin> ?TS i\<close>
            \<open>mcp (?stfV @ ?stfX) V ?stfV\<close> \<open>set ?stfX \<subseteq> inputs M2\<close> assms(5,2)]
      by blast

    let ?yr = "take (length xr) (map snd xs)"
    have "length ?yr = length xr"
      using \<open>prefix xr (map fst xs)\<close> prefix_length_le by fastforce
    have "(xr || ?yr) = take (length xr) xs"
      by (metis (no_types, hide_lams) \<open>prefix xr (map fst xs)\<close> append_eq_conv_conj prefixE take_zip
          zip_map_fst_snd)

    have "prefix (vs@(xr || ?yr)) (vs@xs)"
      by (simp add: \<open>xr || take (length xr) (map snd xs) = take (length xr) xs\<close> take_is_prefix)

    have "xr = take (length xr) (map fst xs)"
      by (metis \<open>length (take (length xr) (map snd xs)) = length xr\<close>
          \<open>xr || take (length xr) (map snd xs) = take (length xr) xs\<close> map_fst_zip take_map)

    have "vs@(xr || ?yr) \<in> L M1"
      by (metis DiffD1 \<open>prefix (vs @ (xr || take (length xr) (map snd xs))) (vs @ xs)\<close>
          \<open>vs @ xs \<in> L M1 - L M2\<close> language_state_prefix prefixE)

    then have "vs@(xr || ?yr) \<in> L\<^sub>i\<^sub>n M1 {?stfV @ xr}"
      by (metis \<open>length (take (length xr) (map snd xs)) = length xr\<close> insertI1
          language_state_for_inputs_map_fst map_append map_fst_zip)

    have "length xr < length xs"
      by (metis \<open>xr = take (length xr) (map fst xs)\<close> \<open>xr \<noteq> map fst xs\<close> not_le_imp_less take_all
          take_map)

    from \<open>?stfV@xr \<in> RM M2 M1 \<Omega> V m (Suc j)\<close> have "?stfV@xr \<in> {xs' \<in> C M2 M1 \<Omega> V m (Suc j) .
        (\<not> atc_io_reduction_on M1 M2 xs' \<Omega>)
        \<or> (\<forall> io \<in> L\<^sub>i\<^sub>n M1 {xs'} .
            (\<exists> V'' \<in> N io M1 V .
              (\<exists> S1 .
                (\<exists> vs xs .
                  io = (vs@xs)
                  \<and> mcp (vs@xs) V'' vs
                  \<and> S1 \<subseteq> nodes M2
                  \<and> (\<forall> s1 \<in> S1 . \<forall> s2 \<in> S1 .
                    s1 \<noteq> s2 \<longrightarrow>
                      (\<forall> io1 \<in> RP M2 s1 vs xs V'' .
                         \<forall> io2 \<in> RP M2 s2 vs xs V'' .
                           B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega> ))
                  \<and> m < LB M2 M1 vs xs (TS M2 M1 \<Omega> V m j \<union> V) S1 \<Omega> V'' ))))}"
      unfolding RM.simps by blast

    moreover have "\<forall> xs' \<in> ?C (Suc j) . (atc_io_reduction_on M1 M2 xs' \<Omega>)"
    proof -
      have "\<forall>as. atc_io_reduction_on M1 M2 as \<Omega> \<or> as \<notin> C M2 M1 \<Omega> V m (Suc j)"
        by (meson C_subset TS_subset \<open>M1 \<preceq>\<lbrakk>(TS M2 M1 \<Omega> V m i).\<Omega>\<rbrakk> M2\<close> \<open>Suc j \<le> i\<close> atc_io_reduction_on_sets.simps subsetCE)
      then show ?thesis
        by blast
    qed

    ultimately have "(\<forall> io \<in> L\<^sub>i\<^sub>n M1 {?stfV@xr} .
            (\<exists> V'' \<in> N io M1 V .
              (\<exists> S1 .
                (\<exists> vs xs .
                  io = (vs@xs)
                  \<and> mcp (vs@xs) V'' vs
                  \<and> S1 \<subseteq> nodes M2
                  \<and> (\<forall> s1 \<in> S1 . \<forall> s2 \<in> S1 .
                    s1 \<noteq> s2 \<longrightarrow>
                      (\<forall> io1 \<in> RP M2 s1 vs xs V'' .
                         \<forall> io2 \<in> RP M2 s2 vs xs V'' .
                           B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega> ))
                  \<and> m < LB M2 M1 vs xs (TS M2 M1 \<Omega> V m j \<union> V) S1 \<Omega> V'' ))))"
      by blast

    then have "
            (\<exists> V'' \<in> N (vs@(xr || ?yr)) M1 V .
              (\<exists> S1 .
                (\<exists> vs' xs' .
                  vs@(xr || ?yr) = (vs'@xs')
                  \<and> mcp (vs'@xs') V'' vs'
                  \<and> S1 \<subseteq> nodes M2
                  \<and> (\<forall> s1 \<in> S1 . \<forall> s2 \<in> S1 .
                    s1 \<noteq> s2 \<longrightarrow>
                      (\<forall> io1 \<in> RP M2 s1 vs' xs' V'' .
                         \<forall> io2 \<in> RP M2 s2 vs' xs' V'' .
                           B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega> ))
                  \<and> m < LB M2 M1 vs' xs' (TS M2 M1 \<Omega> V m j \<union> V) S1 \<Omega> V'' )))"
      using \<open>vs@(xr || ?yr) \<in> L\<^sub>i\<^sub>n M1 {?stfV @ xr}\<close>
      by blast

    then obtain V'' S1 vs' xs' where RM_impl :
                                     "V'' \<in> N (vs@(xr || ?yr)) M1 V"
                                     "vs@(xr || ?yr) = (vs'@xs')"
                                     "mcp (vs'@xs') V'' vs'"
                                     "S1 \<subseteq> nodes M2"
                                     "(\<forall> s1 \<in> S1 . \<forall> s2 \<in> S1 .
                                       s1 \<noteq> s2 \<longrightarrow>
                                          (\<forall> io1 \<in> RP M2 s1 vs' xs' V'' .
                                             \<forall> io2 \<in> RP M2 s2 vs' xs' V'' .
                                               B M1 io1 \<Omega> \<noteq> B M1 io2 \<Omega> ))"
                                     " m < LB M2 M1 vs' xs' (TS M2 M1 \<Omega> V m j \<union> V) S1 \<Omega> V''"
      by blast

    have "?stfV = mcp' (map fst (vs @ (xr || take (length xr) (map snd xs)))) V"
      by (metis (full_types) \<open>length (take (length xr) (map snd xs)) = length xr\<close>
          \<open>mcp (map fst vs @ map fst xs) V (map fst vs)\<close> \<open>prefix xr (map fst xs)\<close> map_append
          map_fst_zip mcp'_intro mcp_prefix_of_suffix)

    have "is_det_state_cover M2 V"
      using assms(4) by blast
    moreover have "well_formed M2"
      using assms(2) by auto
    moreover have "finite V"
      using det_state_cover_finite assms(4,2) by auto
    ultimately have "vs \<in> V''"
                    "vs = mcp' (vs @ (xr || take (length xr) (map snd xs))) V''"
      using N_mcp_prefix[OF \<open>?stfV = mcp' (map fst (vs @ (xr || take (length xr) (map snd xs)))) V\<close>
            \<open>V'' \<in> N (vs@(xr || ?yr)) M1 V\<close>, of M2]
      by simp+

    have "vs' = vs"
      by (metis (no_types) \<open>mcp (vs' @ xs') V'' vs'\<close>
          \<open>vs = mcp' (vs @ (xr || take (length xr) (map snd xs))) V''\<close>
          \<open>vs @ (xr || take (length xr) (map snd xs)) = vs' @ xs'\<close> mcp'_intro)

    then have "xs' = (xr || ?yr)"
      using \<open>vs @ (xr || take (length xr) (map snd xs)) = vs' @ xs'\<close> by blast

    have "V \<subseteq> ?TS i"
    proof -
      have "1 \<le> i"
        using \<open>Suc j \<le> i\<close> by linarith
      then have "?TS 1 \<subseteq> ?TS i"
        using TS_subset by blast
      then show ?thesis
        by auto
    qed

    have "?stfV@xr \<in> ?C (Suc j)"
      using \<open>?stfV@xr \<in> RM M2 M1 \<Omega> V m (Suc j)\<close> unfolding RM.simps by blast

    \<comment> \<open>show that the prerequisites (@{verbatim Prereq}) for @{verbatim LB} are met by construction\<close>

    have "(\<forall>vs'a\<in>V''. prefix vs'a (vs' @ xs') \<longrightarrow> length vs'a \<le> length vs')"
      using \<open>mcp (vs' @ xs') V'' vs'\<close> by auto

    moreover have "atc_io_reduction_on_sets M1 (?TS j \<union> V) \<Omega> M2"
    proof -
      have "j < i"
        using \<open>Suc j \<le> i\<close> by auto
      then have "?TS j \<subseteq> ?TS i"
        by (simp add: TS_subset)
      then show ?thesis
        using atc_io_reduction_on_subset
              [OF \<open>atc_io_reduction_on_sets M1 (TS M2 M1 \<Omega> V m i) \<Omega> M2\<close>, of "?TS j"]
        by (meson Un_subset_iff \<open>V \<subseteq> ?TS i\<close> \<open>atc_io_reduction_on_sets M1 (TS M2 M1 \<Omega> V m i) \<Omega> M2\<close>
            atc_io_reduction_on_subset)
    qed

    moreover have "finite (?TS j \<union> V)"
    proof -
      have "finite (?TS j)"
        using TS_finite[OF \<open>finite V\<close>, of M2 M1 \<Omega> m j] assms(2) by auto
      then show ?thesis
        using \<open>finite V\<close> by blast
    qed

    moreover have "V \<subseteq> ?TS j \<union> V"
      by blast

    moreover have "(\<forall> p . (prefix p xs' \<and> p \<noteq> xs') \<longrightarrow> map fst (vs' @ p) \<in> ?TS j \<union> V)"
    proof
      fix p
      show "prefix p xs' \<and> p \<noteq> xs' \<longrightarrow> map fst (vs' @ p) \<in> TS M2 M1 \<Omega> V m j \<union> V"
      proof
        assume "prefix p xs' \<and> p \<noteq> xs'"

        have "prefix (map fst (vs' @ p)) (map fst (vs' @ xs'))"
          by (simp add: \<open>prefix p xs' \<and> p \<noteq> xs'\<close> map_mono_prefix)
        have "prefix (map fst (vs' @ p)) (?stfV @ xr)"
          using \<open>length (take (length xr) (map snd xs)) = length xr\<close>
                \<open>prefix (map fst (vs' @ p)) (map fst (vs' @ xs'))\<close>
                \<open>vs' = vs\<close> \<open>xs' = xr || take (length xr) (map snd xs)\<close>
          by auto
        then have "prefix (map fst vs' @ map fst p) (?stfV @ xr)"
          by simp
        then have "prefix (map fst p) xr"
          by (simp add: \<open>vs' = vs\<close>)

        have "?stfV @ xr \<in> ?TS (Suc j)"
        proof (cases j)
          case 0
          then show ?thesis
            using \<open>map fst vs @ xr \<in> C M2 M1 \<Omega> V m (Suc j)\<close> by auto
        next
          case (Suc nat)
          then show ?thesis
            using TS.simps(3) \<open>map fst vs @ xr \<in> C M2 M1 \<Omega> V m (Suc j)\<close> by blast
        qed

        have "mcp (map fst vs @ xr) V (map fst vs)"
          using \<open>mcp (map fst vs @ map fst xs) V (map fst vs)\<close> \<open>prefix xr (map fst xs)\<close>
                mcp_prefix_of_suffix
          by blast

        have "map fst vs @ map fst p \<in> TS M2 M1 \<Omega> V m (Suc j)"
          using TS_prefix_containment[OF \<open>?stfV @ xr \<in> ?TS (Suc j)\<close>
                                         \<open>mcp (map fst vs @ xr) V (map fst vs)\<close>
                                         \<open>prefix (map fst p) xr\<close>]
          by assumption

        have "Suc (length xr) = (Suc j)"
          using C_index[OF \<open>?stfV@xr \<in> ?C (Suc j)\<close> \<open>mcp (map fst vs @ xr) V (map fst vs)\<close>]
          by assumption

        have"Suc (length p) < (Suc j)"
        proof -
          have "map fst xs' = xr"
            by (metis \<open>xr = take (length xr) (map fst xs)\<close>
                \<open>xr || take (length xr) (map snd xs) = take (length xr) xs\<close>
                \<open>xs' = xr || take (length xr) (map snd xs)\<close> take_map)
          then show ?thesis
            by (metis (no_types) Suc_less_eq \<open>Suc (length xr) = Suc j\<close> \<open>prefix p xs' \<and> p \<noteq> xs'\<close>
                append_eq_conv_conj length_map nat_less_le prefixE prefix_length_le take_all)
        qed

        have "mcp (map fst vs @ map fst p) V (map fst vs)"
          using \<open>mcp (map fst vs @ xr) V (map fst vs)\<close> \<open>prefix (map fst p) xr\<close> mcp_prefix_of_suffix
          by blast

        then have "map fst vs @ map fst p \<in> ?C (Suc (length (map fst p)))"
          using TS_index(2)[OF \<open>map fst vs @ map fst p \<in> TS M2 M1 \<Omega> V m (Suc j)\<close>] by auto

        have "map fst vs @ map fst p \<in> ?TS j"
          using TS_union[of M2 M1 \<Omega> V m j]
        proof -
          have "Suc (length p) \<in> {0..<Suc j}"
            using \<open>Suc (length p) < Suc j\<close> by force
          then show ?thesis
            by (metis UN_I \<open>TS M2 M1 \<Omega> V m j = (\<Union>j\<in>set [0..<Suc j]. C M2 M1 \<Omega> V m j)\<close>
                \<open>map fst vs @ map fst p \<in> C M2 M1 \<Omega> V m (Suc (length (map fst p)))\<close>
                length_map set_upt)
        qed

        then show "map fst (vs' @ p) \<in> TS M2 M1 \<Omega> V m j \<union> V"
          by (simp add: \<open>vs' = vs\<close>)
      qed
    qed

    moreover have "vs' @ xs' \<in> L M2 \<inter> L M1"
    proof -
      have "\<forall>xs'\<in>C M2 M1 \<Omega> V m (Suc j). L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'}"
        using \<open>\<forall>xs'\<in>C M2 M1 \<Omega> V m (Suc j). atc_io_reduction_on M1 M2 xs' \<Omega>\<close>
        unfolding atc_io_reduction_on.simps
        by auto
      show ?thesis
        by (metis (no_types, lifting) IntI RM_impl(2)
            \<open>\<forall>xs'\<in>C M2 M1 \<Omega> V m (Suc j). L\<^sub>i\<^sub>n M1 {xs'} \<subseteq> L\<^sub>i\<^sub>n M2 {xs'}\<close>
            \<open>map fst vs @ xr \<in> C M2 M1 \<Omega> V m (Suc j)\<close>
            \<open>vs @ (xr || take (length xr) (map snd xs)) \<in> L\<^sub>i\<^sub>n M1 {map fst vs @ xr}\<close>
            language_state_for_inputs_in_language_state subsetCE)
    qed

    ultimately have "Prereq M2 M1 vs' xs' (?TS j \<union> V) S1 \<Omega> V''"
      using RM_impl(4,5) unfolding Prereq.simps by blast

    have "V'' \<in> Perm V M1"
      using \<open>V'' \<in> N (vs@(xr || ?yr)) M1 V\<close> unfolding N.simps by blast

    have \<open>prefix (xr || ?yr) xs\<close>
      by (simp add: \<open>xr || take (length xr) (map snd xs) = take (length xr) xs\<close> take_is_prefix)

    \<comment> \<open> show that furthermore neither @{verbatim Rep_Pre} nor @{verbatim Rep_Cov} holds \<close>

    have "\<not> Rep_Pre M2 M1 vs (xr || ?yr)"
      using minimal_sequence_to_failure_extending_implies_Rep_Pre
            [OF \<open>minimal_sequence_to_failure_extending V M1 M2 vs xs\<close> assms(1,2)
                \<open>test_tools M2 M1 FAIL PM V \<Omega>\<close> RM_impl(1)
                \<open>prefix (xr || take (length xr) (map snd xs)) xs\<close>]
      by assumption
    then have "\<not> Rep_Pre M2 M1 vs' xs'"
      using \<open>vs' = vs\<close> \<open>xs' = xr || ?yr\<close> by blast

    have "\<not> Rep_Cov M2 M1 V'' vs (xr || ?yr)"
      using minimal_sequence_to_failure_extending_implies_Rep_Cov
            [OF \<open>minimal_sequence_to_failure_extending V M1 M2 vs xs\<close> assms(1,2)
                \<open>test_tools M2 M1 FAIL PM V \<Omega>\<close> RM_impl(1)
                \<open>prefix (xr || take (length xr) (map snd xs)) xs\<close>]
      by assumption
    then have "\<not> Rep_Cov M2 M1 V'' vs' xs'"
      using \<open>vs' = vs\<close> \<open>xs' = xr || ?yr\<close> by blast

    have "vs'@xs' \<in> L M1"
      using \<open>vs @ (xr || take (length xr) (map snd xs)) \<in> L M1\<close>
            \<open>vs' = vs\<close> \<open>xs' = xr || take (length xr) (map snd xs)\<close>
      by blast

    \<comment> \<open> therefore it is impossible to remove the prefix of the minimal sequence to a failure,
         as this would require @{verbatim M1} to have more than m states \<close>

    have "LB M2 M1 vs' xs' (?TS j \<union> V) S1 \<Omega> V'' \<le> card (nodes M1)"
      using LB_count[OF \<open>vs'@xs' \<in> L M1\<close> assms(1,2,3) \<open>test_tools M2 M1 FAIL PM V \<Omega>\<close>
                        \<open>V'' \<in> Perm V M1\<close> \<open>Prereq M2 M1 vs' xs' (?TS j \<union> V) S1 \<Omega> V''\<close>
                        \<open>\<not> Rep_Pre M2 M1 vs' xs'\<close> \<open> \<not> Rep_Cov M2 M1 V'' vs' xs'\<close>]
      by assumption
    then have "LB M2 M1 vs' xs' (?TS j \<union> V) S1 \<Omega> V'' \<le> m"
      using assms(3) by linarith

    then show "False"
      using \<open>m < LB M2 M1 vs' xs' (?TS j \<union> V) S1 \<Omega> V''\<close> by linarith
  qed
qed

subsection {* Main result *}

text \<open>
The following lemmata add to the previous result to show that some FSM @{verbatim M1} is a reduction
of FSM @{verbatim M2} if and only if it is a reduction on the test suite generated by the adaptive
state counting algorithm for these FSMs.
\<close>

lemma asc_soundness :
  assumes     "OFSM M1"
  and         "OFSM M2"
shows "M1 \<preceq> M2 \<longrightarrow> atc_io_reduction_on_sets M1 T \<Omega> M2"
  using atc_io_reduction_on_sets_reduction assms by blast

lemma asc_main_theorem :
  assumes "OFSM M1"
  and     "OFSM M2"
  and     "asc_fault_domain M2 M1 m"
  and     "test_tools M2 M1 FAIL PM V \<Omega>"
  and     "final_iteration M2 M1 \<Omega> V m i"
shows     "M1 \<preceq> M2 \<longleftrightarrow> atc_io_reduction_on_sets M1 (TS M2 M1 \<Omega> V m i) \<Omega> M2"
by (metis asc_sufficiency assms(1-5) atc_io_reduction_on_sets_reduction)

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory SubMonadLib
imports
  EmptyFailLib
  Corres_UL
begin

locale submonad_args =
  fixes fetch :: "'a \<Rightarrow> 'b"
  fixes replace :: "'b \<Rightarrow> 'a \<Rightarrow> 'a"
  fixes guard :: "'a \<Rightarrow> bool"

  assumes args:
   "\<forall>x s. guard s \<longrightarrow> fetch (replace x s) = x"
   "\<forall>x y s. replace x (replace y s) = replace x s"
   "\<forall>s. replace (fetch s) s = s"

  assumes replace_preserves_guard:
   "\<And>s x. guard (replace x s) = guard s"

definition
  submonad_fn :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow>
                  ('b, 'c) nondet_monad \<Rightarrow> ('a, 'c) nondet_monad"
where
 "submonad_fn fetch replace guard m \<equiv> do
    stateAssert guard [];
    substate \<leftarrow> gets fetch;
    (rv, substate') \<leftarrow> select_f (m substate);
    modify (replace substate');
    return rv
  od"

locale submonad = submonad_args +
  fixes fn :: "('b, 'c) nondet_monad \<Rightarrow> ('a, 'c) nondet_monad"

  assumes fn_is_sm: "fn = submonad_fn fetch replace guard"

lemma (in submonad_args) argsD1:
  "\<And>x s. guard s \<Longrightarrow> fetch (replace x s) = x"
  by (simp add: args)

lemma (in submonad) guarded_sm:
  "\<And>s. guard s \<Longrightarrow>
   fn m s = (do
     substate \<leftarrow> gets fetch;
     (rv, substate') \<leftarrow> select_f (m substate);
     modify (replace substate');
     return rv
   od) s"
  unfolding fn_is_sm submonad_fn_def
  by (simp add: stateAssert_def get_def assert_def bind_def return_def)

lemma modify_modify:
  "modify fn1 >>= (\<lambda>x. modify fn2) = modify (fn2 \<circ> fn1)"
  by (simp add: bind_def modify_def get_def put_def)

lemma select_f_walk:
  assumes m1: "empty_fail m1"
  assumes S: "fst S = {} \<Longrightarrow> snd S"
  shows "(do a \<leftarrow> m1; b \<leftarrow> select_f S; m2 a b od) = (do b \<leftarrow> select_f S; a \<leftarrow> m1; m2 a b od)"
  apply (rule ext)
  apply (rule prod.expand)
  apply (rule conjI)
   apply (simp add: select_f_def bind_def split_def)
   apply fastforce
  apply (simp add: select_f_def bind_def split_def)
  apply (case_tac "fst S = {}")
   apply clarsimp
   apply (case_tac "fst (m1 x) = {}")
    apply (simp add: empty_failD [OF m1] S)
   apply (frule S)
   apply force
  apply safe
     apply clarsimp
     apply force
    apply force
   apply clarsimp
   apply force
  apply clarsimp
  apply (case_tac "fst (m1 x) = {}", simp add: empty_failD [OF m1])
  apply force
  done

lemma stateAssert_stateAssert:
  "(stateAssert g [] >>= (\<lambda>u. stateAssert g' [])) = stateAssert (g and g') []"
  by (simp add: ext stateAssert_def bind_def get_def assert_def fail_def return_def)

lemma modify_stateAssert:
  "\<lbrakk> \<And>s x. g (r x s) = g s \<rbrakk> \<Longrightarrow>
   (modify (r x) >>= (\<lambda>u. stateAssert g []))
            = (stateAssert g [] >>= (\<lambda>u. modify (r x)))"
  by (simp add: ext stateAssert_def bind_def get_def assert_def fail_def
                return_def modify_def put_def)

lemma gets_stateAssert:
  "(gets f >>= (\<lambda>x. stateAssert g' [] >>= (\<lambda>u. m x)))
            = (stateAssert g' [] >>= (\<lambda>u. gets f >>= (\<lambda>x. m x)))"
  by (simp add: ext stateAssert_def bind_def gets_def get_def
                assert_def fail_def return_def)

lemma select_f_stateAssert:
  "empty_fail m \<Longrightarrow>
   (select_f (m a) >>= (\<lambda>x. stateAssert g [] >>= (\<lambda>u. n x))) =
   (stateAssert g [] >>= (\<lambda>u. select_f (m a) >>= (\<lambda>x. n x)))"
  apply (rule ext)
  apply (clarsimp simp: stateAssert_def bind_def select_f_def get_def
                        assert_def return_def fail_def split_def image_image)
  apply (simp only: image_def)
  apply (clarsimp simp: stateAssert_def bind_def select_f_def get_def
                        assert_def return_def fail_def split_def image_image)
  apply (simp only: image_def mem_simps empty_fail_def simp_thms)
  apply fastforce
  done

lemma bind_select_f_bind':
  shows "(select_f (m s) >>= (\<lambda>x. select_f (split n x))) = (select_f ((m >>= n) s))"
  apply (rule ext)
  apply (force simp: select_f_def bind_def split_def)
  done

lemma bind_select_f_bind:
  "(select_f (m1 s) >>= (\<lambda>x. select_f (m2 (fst x) (snd x)))) = (select_f ((m1 >>= m2) s))"
  by (insert bind_select_f_bind' [where m=m1 and n=m2 and s=s],
      simp add: split_def)

lemma select_from_gets: "select_f (gets f s) = return (f s, s)"
  apply (rule ext)
  apply (simp add: select_f_def return_def simpler_gets_def)
  done

lemma select_from_gets':
  "(select_f \<circ> gets f) = (\<lambda>s. return (f s, s))"
  apply (rule ext)
  apply (simp add: o_def select_from_gets)
  done

lemma bind_subst_lift:
  "(f >>= g) = h \<Longrightarrow> (do x \<leftarrow> f; y \<leftarrow> g x; j y od) = (h >>= j)"
  by (simp add: bind_assoc[symmetric])

lemma modify_gets:
  "\<lbrakk> \<And>x s. g (r x s) = g s; \<And>x s. g s \<longrightarrow> f (r x s) = x \<rbrakk>
   \<Longrightarrow> (modify (r x) >>= (\<lambda>u. stateAssert g [] >>= (\<lambda>u'. gets f)))
            = (stateAssert g [] >>= (\<lambda>u'. modify (r x) >>= (\<lambda>u. return x)))"
  by (simp add: ext stateAssert_def assert_def modify_def bind_def get_def
                put_def gets_def return_def fail_def)

lemma (in submonad_args) gets_modify:
  "\<And>s. guard s \<Longrightarrow>
   (do x \<leftarrow> gets fetch; u \<leftarrow> modify (replace x); f x od) s = ((gets fetch) >>= f) s"
  by (clarsimp simp: modify_def gets_def return_def bind_def
                     put_def args get_def
              split: option.split)

lemma submonad_bind:
  "\<lbrakk> submonad f r g m; submonad f r g m'; submonad f r g m'';
     empty_fail a; \<And>x. empty_fail (b x) \<rbrakk> \<Longrightarrow>
   m (a >>= b) = (m' a) >>= (\<lambda>rv. m'' (b rv))"
  apply (subst submonad.fn_is_sm, assumption)+
  apply (clarsimp simp: submonad_def bind_assoc split_def submonad_fn_def)
  apply (subst bind_subst_lift [OF modify_gets, unfolded bind_assoc])
    apply (simp add: submonad_args.args submonad_args.replace_preserves_guard)+
  apply (subst select_f_stateAssert, assumption)
  apply (subst gets_stateAssert)
  apply (subst bind_subst_lift [OF stateAssert_stateAssert])
  apply (clarsimp simp: pred_conj_def)
  apply (clarsimp simp: bind_assoc split_def select_f_walk
                empty_fail_stateAssert empty_failD
                bind_subst_lift[OF modify_modify] submonad_args.args o_def
                bind_subst_lift[OF bind_select_f_bind])
  done

lemma (in submonad) guard_preserved:
  "\<And>s s'. \<lbrakk> (rv, s') \<in> fst (fn m s) \<rbrakk> \<Longrightarrow> guard s'"
  unfolding fn_is_sm submonad_fn_def
  by (clarsimp simp: stateAssert_def gets_def get_def bind_def modify_def put_def
                     return_def select_f_def replace_preserves_guard in_monad)

lemma fst_stateAssertD:
  "\<And>s s' v. (v, s') \<in> fst (stateAssert g [] s) \<Longrightarrow> s' = s \<and> g s"
  by (clarsimp simp: stateAssert_def in_monad)

lemma(in submonad) guarded_gets:
  "\<And>s. guard s \<Longrightarrow> fn (gets f) s = gets (f \<circ> fetch) s"
  apply (simp add: guarded_sm select_from_gets gets_modify)
  apply (simp add: gets_def)
  done

lemma (in submonad) guarded_return:
  "\<And>s. guard s \<Longrightarrow> fn (return x) s = return x s"
  using args guarded_gets
  by (fastforce simp: gets_def bind_def get_def)

lemma (in submonad_args) submonad_fn_gets:
  "submonad_fn fetch replace guard (gets f) =
   (stateAssert guard [] >>= (\<lambda>u. gets (f \<circ> fetch)))"
  apply (simp add: ext select_from_gets submonad_fn_def)
  apply (rule bind_cong [OF refl])
  apply (clarsimp simp: gets_modify dest!: fst_stateAssertD)
  apply (simp add: gets_def)
  done

lemma(in submonad) gets:
  "fn (gets f) = (stateAssert guard [] >>= (\<lambda>u. gets (f \<circ> fetch)))"
  unfolding fn_is_sm submonad_fn_gets
  by (rule refl)

lemma (in submonad) return:
  "fn (return x) = (stateAssert guard [] >>= (\<lambda>u. return x))"
  using args gets
  by (fastforce simp: gets_def bind_def get_def)

lemma (in submonad) mapM_guard_preserved:
  "\<And>s s'. \<lbrakk> guard s; \<exists>rv. (rv, s') \<in> fst (mapM (fn \<circ> m) xs s)\<rbrakk> \<Longrightarrow> guard s'"
proof (induct xs)
  case Nil
  thus ?case
    by (simp add: mapM_def sequence_def return_def)
  next
  case (Cons x xs)
  thus ?case
    apply (clarsimp simp: o_def mapM_Cons return_def bind_def)
    apply (drule guard_preserved)
    apply fastforce
    done
qed

lemma (in submonad) mapM_x_guard_preserved:
  "\<And>s s'. \<lbrakk> guard s; \<exists>rv. (rv, s') \<in> fst (mapM_x (fn \<circ> m) xs s)\<rbrakk> \<Longrightarrow> guard s'"
proof (induct xs)
  case Nil
  thus ?case
    by (simp add: mapM_x_def sequence_x_def return_def)
  next
  case (Cons x xs)
  thus ?case
    apply (clarsimp simp: o_def mapM_x_Cons return_def bind_def)
    apply (drule guard_preserved)
    apply fastforce
    done
qed

lemma (in submonad) stateAssert_fn:
  "stateAssert guard [] >>= (\<lambda>u. fn m) = fn m"
  by (simp add: fn_is_sm submonad_fn_def pred_conj_def
                bind_subst_lift [OF stateAssert_stateAssert])

lemma (in submonad) fn_stateAssert:
  "fn m >>= (\<lambda>x. stateAssert guard [] >>= (\<lambda>u. n x)) = (fn m >>= n)"
  apply (simp add: fn_is_sm submonad_fn_def bind_assoc split_def)
  apply (rule ext)
  apply (rule bind_apply_cong [OF refl])+
  apply (clarsimp simp: stateAssert_def bind_assoc in_monad select_f_def)
  apply (drule iffD2 [OF replace_preserves_guard])
  apply (fastforce simp: bind_def assert_def get_def return_def)
  done

lemma submonad_mapM:
  assumes sm: "submonad f r g sm" and sm': "submonad f r g sm'"
  assumes efm: "\<And>x. empty_fail (m x)"
  shows
  "(sm (mapM m l)) = (stateAssert g [] >>= (\<lambda>u. mapM (sm' \<circ> m) l))"
proof (induct l)
  case Nil
  thus ?case
    by (simp add: mapM_def sequence_def bind_def submonad.return [OF sm])
  next
  case (Cons x xs)
  thus ?case
    using sm sm' efm
    apply (simp add: mapM_Cons)
    apply (simp add: bind_subst_lift [OF submonad.stateAssert_fn])
    apply (simp add: bind_assoc submonad_bind submonad.return)
    apply (subst submonad.fn_stateAssert [OF sm'])
    apply (intro ext bind_apply_cong [OF refl])
    apply (subgoal_tac "g sta")
     apply (clarsimp simp: stateAssert_def bind_def get_def assert_def return_def)
    apply (frule(1) submonad.guard_preserved)
    apply (erule(1) submonad.mapM_guard_preserved, fastforce simp: o_def)
    done
qed

lemma submonad_mapM_x:
  assumes sm: "submonad f r g sm" and sm': "submonad f r g sm'"
  assumes efm: "\<And>x. empty_fail (m x)"
  shows
  "(sm (mapM_x m l)) = (stateAssert g [] >>= (\<lambda>u. mapM_x (sm' \<circ> m) l))"
proof (induct l)
  case Nil
  thus ?case
    by (simp add: mapM_x_def sequence_x_def bind_def submonad.return [OF sm])
  next
  case (Cons x xs)
  thus ?case
    using sm sm' efm
    apply (simp add: mapM_x_Cons)
    apply (simp add: bind_subst_lift [OF submonad.stateAssert_fn])
    apply (simp add: bind_assoc submonad_bind submonad.return)
    apply (subst submonad.fn_stateAssert [OF sm'])
    apply (intro ext bind_apply_cong [OF refl])
    apply (subgoal_tac "g st")
     apply (clarsimp simp: stateAssert_def bind_def get_def assert_def return_def)
    apply (frule(1) submonad.guard_preserved, simp)
    done
qed

lemma corres_select:
  "(\<forall>s' \<in> S'. \<exists>s \<in> S. rvr s s') \<Longrightarrow> corres_underlying sr nf nf' rvr \<top> \<top> (select S) (select S')"
  by (clarsimp simp: select_def corres_underlying_def)

lemma corres_select_f:
  "\<lbrakk> \<forall>s' \<in> fst S'. \<exists>s \<in> fst S. rvr s s'; nf' \<Longrightarrow> \<not> snd S' \<rbrakk>
      \<Longrightarrow> corres_underlying sr nf nf' rvr \<top> \<top> (select_f S) (select_f S')"
  by (clarsimp simp: select_f_def corres_underlying_def)

lemma corres_modify':
  "\<lbrakk> (\<forall>s s'. (s, s') \<in> sr \<longrightarrow> (f s, f' s') \<in> sr); r () () \<rbrakk>
      \<Longrightarrow> corres_underlying sr nf nf' r \<top> \<top> (modify f) (modify f')"
  by (clarsimp simp: modify_def corres_underlying_def bind_def get_def put_def)

(* FIXME: this should only be used for the lemma below *)
lemma corres_select_f_stronger:
  "\<lbrakk> \<forall>s' \<in> fst S'. \<exists>s \<in> fst S. rvr s s'; nf' \<Longrightarrow> \<not> snd S' \<rbrakk>
      \<Longrightarrow> corres_underlying sr nf nf' rvr \<top> \<top> (select_f S) (select_f S')"
  by (clarsimp simp: select_f_def corres_underlying_def)

lemma stateAssert_sp:
  "\<lbrace>P\<rbrace> stateAssert Q l \<lbrace>\<lambda>_. P and Q\<rbrace>"
  by (clarsimp simp: valid_def stateAssert_def in_monad)

lemma corres_submonad:
  "\<lbrakk> submonad f r g fn; submonad f' r' g' fn';
     \<forall>s s'. (s, s') \<in> sr \<and> g s \<and> g' s' \<longrightarrow> (f s, f' s') \<in> ssr;
     \<forall>s s' ss ss'. ((s, s') \<in> sr \<and> (ss, ss') \<in> ssr) \<longrightarrow> (r ss s, r' ss' s') \<in> sr;
     corres_underlying ssr False nf' rvr \<top> \<top> x x'\<rbrakk>
   \<Longrightarrow> corres_underlying sr False nf' rvr g g' (fn x) (fn' x')"
  apply (subst submonad.fn_is_sm, assumption)+
  apply (clarsimp simp: submonad_fn_def)
  apply (rule corres_split' [OF _ _ stateAssert_sp stateAssert_sp])
   apply (fastforce simp: corres_underlying_def stateAssert_def get_def
                         assert_def return_def bind_def)
  apply (rule corres_split' [where r'="\<lambda>x y. (x, y) \<in> ssr",
                             OF _ _ hoare_post_taut hoare_post_taut])
   apply clarsimp
  apply (rule corres_split' [where r'="\<lambda>(x, x') (y, y'). rvr x y \<and> (x', y') \<in> ssr",
                             OF _ _ hoare_post_taut hoare_post_taut])
   defer
   apply clarsimp
   apply (rule corres_split' [where r'=dc, OF _ _ hoare_post_taut hoare_post_taut])
    apply (simp add: corres_modify')
   apply clarsimp
  apply (rule corres_select_f_stronger)
   apply (clarsimp simp: corres_underlying_def)
   apply (drule (1) bspec, clarsimp)
   apply (drule (1) bspec, simp)
   apply blast
  apply (clarsimp simp: corres_underlying_def)
  apply (drule (1) bspec, clarsimp)
  done

lemma stateAssert_top [simp]:
  "stateAssert \<top> l >>= f = f ()"
  by (clarsimp simp add: stateAssert_def get_def bind_def return_def)

lemma stateAssert_A_top [simp]:
  "stateAssert \<top> l = return ()"
  by (simp add: stateAssert_def get_def bind_def return_def)

text \<open>Use of the submonad concept to demonstrate commutativity.\<close>

lemma gets_modify_comm:
  "\<And> s. \<lbrakk> g (f s) = g s \<rbrakk> \<Longrightarrow>
   (do x \<leftarrow> modify f; y \<leftarrow> gets g; m x y od) s =
   (do y \<leftarrow> gets g; x \<leftarrow> modify f; m x y od) s"
  by (simp add: modify_def gets_def get_def bind_def put_def return_def)

lemma bind_subst_lhs_inv:
  "\<And>s. \<lbrakk> \<And>x s'. P s' \<Longrightarrow> (f x >>= g x) s' = h x s'; \<lbrace>P\<rbrace> a \<lbrace>\<lambda>_. P\<rbrace>; P s \<rbrakk> \<Longrightarrow>
   (do x \<leftarrow> a; y \<leftarrow> f x; g x y od) s = (a >>= h) s"
  apply (rule bind_apply_cong [OF refl])
  apply (drule(2) use_valid)
  apply simp
  done

lemma gets_comm:
  "do x \<leftarrow> gets f; y \<leftarrow> gets g; m x y od = do y \<leftarrow> gets g; x \<leftarrow> gets f; m x y od"
  by (simp add: gets_def get_def return_def bind_def)

lemma submonad_comm:
  assumes x1: "submonad_args f r g" and x2: "submonad_args f' r' g'"
  assumes y: "m = submonad_fn f r g im" "m' = submonad_fn f' r' g' im'"
  assumes z: "\<And>s x x'. r x (r' x' s) = r' x' (r x s)"
  assumes gp: "\<And>s x. g (r' x s) = g s" and gp': "\<And>s x. g' (r x s) = g' s"
  assumes efim: "empty_fail im" and efim': "empty_fail im'"
  shows      "(do x \<leftarrow> m; y \<leftarrow> m'; n x y od) = (do y \<leftarrow> m'; x \<leftarrow> m; n x y od)"
proof -
  have P: "\<And>x s. g s \<Longrightarrow> f (r' x s) = f s"
    apply (subgoal_tac "f (r' x (r (f s) s)) = f s")
     apply (simp add: submonad_args.args[OF x1])
    apply (simp add: z[symmetric])
    apply (subst(asm) gp [symmetric])
    apply (fastforce dest: submonad_args.argsD1[OF x1])
    done
  have Q: "\<And>x s. g' s \<Longrightarrow> f' (r x s) = f' s"
    apply (subgoal_tac "f' (r x (r' (f' s) s)) = f' s")
     apply (simp add: submonad_args.args[OF x2])
    apply (simp add: z)
    apply (subst(asm) gp' [symmetric])
    apply (fastforce dest: submonad_args.argsD1[OF x2])
    done
  note empty_failD [OF efim, simp]
  note empty_failD [OF efim', simp]
  show ?thesis
    apply (clarsimp simp: submonad_fn_def y bind_assoc split_def)
    apply (subst bind_subst_lift [OF modify_stateAssert], rule gp gp')+
    apply (simp add: bind_assoc)
    apply (subst select_f_stateAssert, rule efim efim')+
    apply (subst gets_stateAssert bind_subst_lift [OF stateAssert_stateAssert])+
    apply (rule bind_cong)
     apply (simp add: pred_conj_def conj_comms)
    apply (simp add: bind_assoc select_f_walk[symmetric])
    apply (clarsimp dest!: fst_stateAssertD)
    apply (subst bind_assoc[symmetric],
           subst bind_subst_lhs_inv [OF gets_modify_comm],
           erule P Q, wp, simp, simp)+
    apply (simp add: bind_assoc)
    apply (simp add: select_f_walk[symmetric])
    apply (subst gets_comm)
    apply (rule bind_apply_cong [OF refl])+
    apply (subst select_f_walk, simp, simp,
           subst select_f_walk, simp, simp,
           rule bind_apply_cong [OF refl])
    apply (subst select_f_walk, simp, simp, rule bind_apply_cong [OF refl])
    apply (clarsimp simp: simpler_gets_def select_f_def)
    apply (simp add: bind_def get_def put_def modify_def z)
    done
qed

lemma submonad_comm2:
  assumes x1: "submonad_args f r g" and x2: "m = submonad_fn f r g im"
  assumes y: "submonad f' r' g' m'"
  assumes z: "\<And>s x x'. r x (r' x' s) = r' x' (r x s)"
  assumes gp: "\<And>s x. g (r' x s) = g s" and gp': "\<And>s x. g' (r x s) = g' s"
  assumes efim: "empty_fail im" and efim': "empty_fail im'"
  shows      "do x \<leftarrow> m; y \<leftarrow> m' im'; n x y od = do y \<leftarrow> m' im'; x \<leftarrow> m; n x y od"
  apply (rule submonad_comm[where f'=f' and r'=r', OF x1 _ x2 _ z])
       apply (insert y)
       apply (fastforce simp add: submonad_def)
      apply (fastforce dest: submonad.fn_is_sm)
     apply (simp add: efim efim' gp gp')+
  done

lemma submonad_bind_alt:
  assumes x: "submonad_args f r g"
  assumes y: "a = submonad_fn f r g a'" "\<And>rv. b rv = submonad_fn f r g (b' rv)"
  assumes efa: "empty_fail a'" and efb: "\<And>x. empty_fail (b' x)"
  shows      "(a >>= b) = submonad_fn f r g (a' >>= b')"
proof -
  have P: "submonad f r g (submonad_fn f r g)"
    by (simp add: x submonad_def submonad_axioms_def)
  have Q: "b = (\<lambda>rv. submonad_fn f r g (b' rv))"
    by (rule ext) fact+
  show ?thesis
    by (simp add: y Q submonad_bind [OF P P P efa efb])
qed

lemma submonad_singleton:
  "submonad_fn fetch replace \<top> (\<lambda>s. ({(rv s, s' s)}, False))
     = (\<lambda>s. ({(rv (fetch s), replace (s' (fetch s)) s)}, False))"
  apply (rule ext)
  apply (simp add: submonad_fn_def bind_def gets_def
                put_def get_def modify_def return_def
                select_f_def UNION_eq)
  done

lemma gets_submonad:
  "\<lbrakk> submonad_args fetch replace \<top>; \<And>s. f s = f' (fetch s); m = gets f' \<rbrakk>
   \<Longrightarrow> gets f = submonad_fn fetch replace \<top> m"
  apply (drule submonad_args.args(3))
  apply (clarsimp simp add: simpler_gets_def submonad_singleton)
  done

lemma modify_submonad:
  "\<lbrakk> \<And>s. f s = replace (K_record (f' (fetch s))) s; m = modify f' \<rbrakk>
     \<Longrightarrow> modify f = submonad_fn fetch (replace o K_record) \<top> m"
  by (simp add: simpler_modify_def submonad_singleton)

lemma fail_submonad:
  "fail = submonad_fn fetch replace \<top> fail"
  by (simp add: submonad_fn_def simpler_gets_def return_def
                simpler_modify_def select_f_def bind_def fail_def)

lemma return_submonad:
  "submonad_args fetch replace guard \<Longrightarrow>
   return v = submonad_fn fetch replace \<top> (return v)"
  by (simp add: return_def submonad_singleton submonad_args.args)

lemma assert_opt_submonad:
  "submonad_args fetch replace \<top> \<Longrightarrow>
   assert_opt v = submonad_fn fetch replace \<top> (assert_opt v)"
  apply (case_tac v, simp_all add: assert_opt_def)
   apply (rule fail_submonad)
  apply (rule return_submonad)
  apply assumption
  done

lemma is_stateAssert_gets:
  "\<lbrakk> \<forall>s. \<lbrace>(=) s\<rbrace> f \<lbrace>\<lambda>_. (=) s\<rbrace>; \<lbrace>\<top>\<rbrace> f \<lbrace>\<lambda>_. guard\<rbrace>;
     empty_fail f; no_fail guard f; \<lbrace>guard\<rbrace> f \<lbrace>\<lambda>rv s. fetch s = rv\<rbrace> \<rbrakk>
    \<Longrightarrow> f = do stateAssert guard []; gets fetch od"
  apply (rule ext)
  apply (clarsimp simp: bind_def empty_fail_def valid_def no_fail_def
                        stateAssert_def assert_def gets_def get_def
                        return_def fail_def image_def split_def)
  apply (case_tac "f x")
  apply (intro conjI impI)
   apply (drule_tac x=x in spec)+
   apply (subgoal_tac "\<forall>xa\<in>fst (f x). fst xa = fetch x \<and> snd xa = x")
    apply fastforce
   apply clarsimp
  apply (drule_tac x=x in spec)+
  apply fastforce
  done

lemma is_modify:
  "\<And>s. \<lbrakk> \<lbrace>(=) s\<rbrace> f \<lbrace>\<lambda>_. (=) (replace s)\<rbrace>; empty_fail f;
          no_fail guard f; guard s \<rbrakk>
    \<Longrightarrow> f s = modify replace s"
  apply (clarsimp simp: bind_def empty_fail_def valid_def no_fail_def
                        stateAssert_def assert_def modify_def get_def put_def
                        return_def fail_def image_def split_def)
  apply (case_tac "f s")
  apply force
  done

lemma submonad_comm':
  assumes sm1: "submonad f r g m" and sm2: "submonad f' r' g' m'"
  assumes z: "\<And>s x x'. r x (r' x' s) = r' x' (r x s)"
  assumes gp: "\<And>s x. g (r' x s) = g s" and gp': "\<And>s x. g' (r x s) = g' s"
  assumes efim: "empty_fail im" and efim': "empty_fail im'"
  shows      "(do x \<leftarrow> m im; y \<leftarrow> m' im'; n x y od) =
              (do y \<leftarrow> m' im'; x \<leftarrow> m im; n x y od)"
  apply (rule submonad_comm [where f'=f' and r'=r', OF _ _ _ _ z])
         apply (insert sm1 sm2)
         apply (fastforce dest: submonad.fn_is_sm simp: submonad_def)+
     apply (simp add: efim efim' gp gp')+
  done

end


section "Solution to Day 4 of AoC 2020"

theory day4
  imports Main "HOL.Code_Numeral" string_utils list_natural_utils natural_utils list_utils
begin

text "This is a solution to the puzzle for day 4"

subsection "Input parsing"

text "The input for this puzzle has records separated by two newlines, where each record is split
across multiple lines. We parse it by joining together the multiline records into single lines
and collapsing the double newlines into single newlines, then splitting on newlines and parsing each
line as a record"

definition join_records :: "string \<Rightarrow> string"
  where "join_records = join_lines CHR '' ''"

text "Passport information is stored as a record of string options, since some fields can be missing"

record passport =
  byr :: "string option"
  iyr :: "string option"
  eyr :: "string option"
  hgt :: "string option"
  hcl :: "string option"
  ecl :: "string option"
  pid :: "string option"
  cid :: "string option"

definition Blank_Passport :: "passport"
  where "Blank_Passport = \<lparr>
    byr = None
    ,iyr = None
    ,eyr = None
    ,hgt = None
    ,hcl = None
    ,ecl = None
    ,pid = None
    ,cid = None
  \<rparr>"

fun update_passport :: "passport \<Rightarrow> string \<Rightarrow> passport"
  where "update_passport p s = (let (field, value) = (split_once CHR '':'' s) in
    case field of
      ''byr'' \<Rightarrow> p\<lparr> byr:=Some value \<rparr>
      |''iyr'' \<Rightarrow> p\<lparr> iyr:=Some value \<rparr>
      |''eyr'' \<Rightarrow> p\<lparr> eyr:=Some value \<rparr>
      |''hgt'' \<Rightarrow> p\<lparr> hgt:=Some value \<rparr>
      |''hcl'' \<Rightarrow> p\<lparr> hcl:=Some value \<rparr>
      |''ecl'' \<Rightarrow> p\<lparr> ecl:=Some value \<rparr>
      |''pid'' \<Rightarrow> p\<lparr> pid:=Some value \<rparr>
      |''cid'' \<Rightarrow> p\<lparr> cid:=Some value \<rparr>
  )"

text "this representation, plus the update\\_passport function which updates an arbitraty field in
a passport record, enables us to define passport parsing as simply reducing the list of fields to
parse over the update function"

definition parse_passport :: "string \<Rightarrow> passport"
  where "parse_passport r = reduce update_passport Blank_Passport (split CHR '' '' r)"

definition parse_all :: "string \<Rightarrow> passport list"
  where "parse_all s = map parse_passport (split CHR ''\<newline>'' (join_records (trim s)))"

subsection "Solution Algorithm"

text "Passports must have all fields present, or have only cid missing, the task for part1 is simply
to count the valid ones according to those rules"

definition is_some :: "'a option \<Rightarrow> bool"
  where "is_some a = (a \<noteq> None)"

definition is_valid :: "passport \<Rightarrow> bool"
  where "is_valid p = (
    is_some (byr p)
    \<and> is_some (iyr p)
    \<and> is_some (eyr p)
    \<and> is_some (hgt p)
    \<and> is_some (hcl p)
    \<and> is_some (ecl p)
    \<and> is_some (pid p)
  )"

definition num_valid :: "(passport \<Rightarrow> bool) \<Rightarrow> string \<Rightarrow> natural"
  where "num_valid f = sum_list \<circ> (map count_bool) \<circ> (map f) \<circ> parse_all"

definition part1 :: "string \<Rightarrow> natural"
  where "part1 = num_valid is_valid"

text "In part 2 we do the same but with lots of extra rules. The rules suck and you would never get
away with implementing these rules in the real world, but I guess I'll look past that for now."

definition all :: "bool list \<Rightarrow> bool"
  where "all = reduce (\<and>) True"

definition is_number_between :: "natural \<Rightarrow> natural \<Rightarrow> string \<Rightarrow> bool"
  where "is_number_between n_min n_max num = ((all (map is_digit num)) \<and> (let n = str_to_nat num in ((n_min \<le> n) \<and> (n \<le> n_max))))"

definition valid_height :: "string \<Rightarrow> bool"
  where "valid_height s = (let l = length s in
    if l = 4 then is_number_between 59 76 (fst (split_once CHR ''i'' s)) else
    if l = 5 then is_number_between 150 193 (fst (split_once CHR ''c'' s)) else
    False
  )"

fun valid_color :: "string \<Rightarrow> bool"
  where "valid_color (Cons CHR ''#'' digits) = (length digits = 6 \<and> (all (map is_hexit digits)))"
  | "valid_color s = False"

definition valid_eye_color :: "string \<Rightarrow> bool"
  where "valid_eye_color s = (
    s = ''amb''
    \<or> s = ''blu''
    \<or> s = ''brn''
    \<or> s = ''gry''
    \<or> s = ''grn''
    \<or> s = ''hzl''
    \<or> s = ''oth''
  )"

definition valid_pid :: "string \<Rightarrow> bool"
  where "valid_pid a = ((length a = 9) \<and> (all (map is_digit a)))"

fun present_and_matches :: "('a \<Rightarrow> bool) \<Rightarrow> 'a option \<Rightarrow> bool"
  where "present_and_matches _ None = False"
  | "present_and_matches f (Some a) = f a"

definition is_valid_2 :: "passport \<Rightarrow> bool"
  where "is_valid_2 p = (
    present_and_matches (is_number_between 1920 2002) (byr p)
    \<and> present_and_matches (is_number_between 2010 2020) (iyr p)
    \<and> present_and_matches (is_number_between 2020 2030) (eyr p)
    \<and> present_and_matches valid_height (hgt p)
    \<and> present_and_matches valid_color (hcl p)
    \<and> present_and_matches valid_eye_color (ecl p)
    \<and> present_and_matches valid_pid (pid p)
  )"

definition part2 :: "string \<Rightarrow> natural"
  where "part2 = num_valid is_valid_2"

subsection "Testing"

text "We expect our test case to return 2"

definition example_input::string where "example_input = ''
ecl:gry pid:860033327 eyr:2020 hcl:#fffffd
byr:1937 iyr:2017 cid:147 hgt:183cm

iyr:2013 ecl:amb cid:350 eyr:2023 pid:028048884
hcl:#cfa07d byr:1929

hcl:#ae17e1 iyr:2013
eyr:2024
ecl:brn pid:760753108 byr:1931
hgt:179cm

hcl:#cfa07d eyr:2025 pid:166559648
iyr:2011 ecl:brn hgt:59in
''"

lemma "part1 example_input = 2"
  by eval

text "For part 2 the example also returns 2"

lemma "part2 example_input = 2"
  by eval

export_code "part1" "part2" in Haskell module_name Solution

end


theory func_cor_other
imports func_cor_lemma
begin

section \<open>Functional correctness of Schedule\<close>

thm Schedule_def
lemma Schedule_satRG_h1:
  "\<Gamma> \<turnstile>\<^sub>I Some (IF \<exists>y. \<acute>cur = Some y THEN \<acute>thd_state := \<acute>thd_state(the \<acute>cur := READY);; Basic (cur_update Map.empty) FI;;
           Basic (cur_update (\<lambda>_. Some t));;
           \<acute>thd_state := \<acute>thd_state
           (t := RUNNING)) sat\<^sub>p [\<lbrace>\<acute>inv\<rbrace> \<inter> \<lbrace>\<acute>thd_state t = READY\<rbrace> \<inter>
                                 {V}, {(s, t). s = t}, UNIV, \<lbrace>\<acute>(Pair V) \<in> Schedule_guar\<rbrace> \<inter> \<lbrace>\<acute>inv\<rbrace>]"
  apply(case_tac "\<lbrace>\<acute>inv\<rbrace> \<inter> \<lbrace>\<acute>thd_state t = READY\<rbrace> \<inter> {V} = {}")
    using Emptyprecond apply auto[1]
    apply simp
    apply(case_tac "\<exists>y. cur V = Some y")

    apply(rule Seq[where mid = "{V\<lparr>thd_state := (thd_state V)(the (cur V) := READY), cur := Some t\<rparr>}"])
      apply(rule Seq[where mid = "{V\<lparr>thd_state := (thd_state V)(the (cur V) := READY), cur := None\<rparr>}"])
        apply(rule Cond)
          apply(simp add:stable_def)
          apply(rule Seq[where mid = "{V\<lparr>thd_state := (thd_state V)(the (cur V) := READY)\<rparr>}"])
          apply(rule Basic)
            apply auto[1]
            apply(simp add:stable_def)+
          apply(rule Basic)
            apply auto[1]
            apply(simp add:stable_def)+
          apply(simp add:Skip_def) apply(rule Basic) apply(simp add:stable_def)+

        apply(rule Basic)
         apply auto[1]
          apply(simp add:stable_def)+

        apply(rule Basic)
         apply(simp add:Schedule_guar_def)
         apply(subgoal_tac "inv (V\<lparr>cur := Some t, thd_state := (thd_state V)(the (cur V) := READY, t := RUNNING)\<rparr>) \<and>
                (\<forall>x. (V, V\<lparr>cur := Some t, thd_state := (thd_state V)(the (cur V) := READY, t := RUNNING)\<rparr>) \<in> lvars_nochange_rel x)")
         apply simp
         apply(rule conjI) apply(simp add:inv_def) apply clarify
         apply(rule conjI) apply(simp add:inv_cur_def) apply force
          apply(simp add:inv_thd_waitq_def inv_cur_def)
            apply (metis Thread_State_Type.distinct(3) Thread_State_Type.distinct(6))
         apply auto[1] using lvars_nochange_rel_def lvars_nochange_def apply simp
          apply(simp add: stable_def)+

    apply(rule Seq[where mid = "{V\<lparr>cur := Some t\<rparr>}"])
      apply(rule Seq[where mid = "{V}"])
        apply(rule Cond)
          apply(simp add:stable_def)
          apply(rule Seq[where mid = "{}"])
          apply(rule Basic)
            apply auto[1]
            apply(simp add:stable_def)+
          apply(rule Basic)
            apply auto[1]
            apply(simp add:stable_def)+
          apply(simp add:Skip_def) apply(rule Basic) apply(simp add:stable_def)+
        apply(rule Basic)
         apply auto[1]
          apply(simp add:stable_def)+
         apply(rule Basic)
           apply(simp add:Schedule_guar_def)
           apply(subgoal_tac "inv (V\<lparr>cur := Some t, thd_state := (thd_state V)(t := RUNNING)\<rparr>) \<and>
              (\<forall>x. (V, V\<lparr>cur := Some t, thd_state := (thd_state V)(t := RUNNING)\<rparr>) \<in> lvars_nochange_rel x)")
           apply simp
           apply(rule conjI) apply(simp add:inv_def) apply clarify
           apply(rule conjI) apply(simp add:inv_cur_def)
           apply(simp add:inv_thd_waitq_def) apply auto[1]

          apply auto[1] using lvars_nochange_rel_def lvars_nochange_def apply simp
          apply(simp add:stable_def)+
done

lemma Schedule_satRG: "\<Gamma> (Schedule t) \<turnstile> Schedule_RGCond t"
  apply(simp add:Evt_sat_RG_def)
  apply (simp add: Schedule_def Schedule_RGCond_def)
  apply(rule BasicEvt)
    apply(simp add:body_def Pre\<^sub>f_def Post\<^sub>f_def guard_def
                  Rely\<^sub>f_def Guar\<^sub>f_def getrgformula_def)
    apply(rule Await)
      using stable_inv_sched_rely1 apply simp using stable_inv_sched_rely1 apply simp
      using Schedule_satRG_h1 apply simp

    apply(simp add:Pre\<^sub>f_def Rely\<^sub>f_def getrgformula_def)
    using stable_inv_sched_rely1 apply simp

    by(simp add:Guar\<^sub>f_def getrgformula_def Schedule_guar_def)

section \<open>Functional correctness of Tick\<close>
lemma Tick_satRG: "\<Gamma> Tick \<turnstile> Tick_RGCond"
  apply(simp add:Evt_sat_RG_def)
  apply (simp add: Tick_def Tick_RGCond_def Tick_rely_def Tick_guar_def)
  apply(rule BasicEvt)
    apply(simp add:body_def Pre\<^sub>f_def Post\<^sub>f_def guard_def
                  Rely\<^sub>f_def Guar\<^sub>f_def getrgformula_def)
    apply(rule Basic)
      apply simp
      using lvars_nochange_rel_def lvars_nochange_def apply simp apply auto[1]
      apply(simp add:stable_def)+
    apply(simp add: stable_def Pre\<^sub>f_def getrgformula_def Rely\<^sub>f_def) apply auto[1]
    by (simp add: Guar\<^sub>f_def getrgformula_def)

end


section {*FUNCTION\_\_DPDA\_EA\_STD\_\_DPDA\_ENFORCE\_ACCESSIBLE\_STD*}
theory
  FUNCTION__DPDA_EA_STD__DPDA_ENFORCE_ACCESSIBLE_STD

imports
  PRJ_12_08_02__ENTRY

begin

lemma F_DPDA_EA_STD__preserves_DPDA: "
  valid_dpda G
  \<Longrightarrow> valid_dpda (F_DPDA_EA_STD G)"
  apply(simp add: F_DPDA_EA_STD_def)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G="G" and E="(F_DPDA_DAE G)" in F_EPDA_RE__SOUND)
   apply(simp add: F_EPDA_RE__SpecInput_def)
   apply(subgoal_tac "X" for X)
    prefer 2
    apply(rule_tac G="G" in F_DPDA_DAE__SOUND)
    apply(simp add: F_DPDA_DAE__SpecInput_def)
   apply(simp add: F_DPDA_DAE__SpecOutput_def)
   apply(thin_tac "F_DPDA_DAE G = epdaH_accessible_edges G")
   apply (metis epdaH_accessible_edges_vs_epdaS_accessible_edges valid_dpda_def valid_pda_def)
  apply(simp add: F_EPDA_RE__SpecOutput_def)
  done

lemma F_DPDA_EA_STD__preserves_lang: "
  valid_dpda G
  \<Longrightarrow> epdaS.marked_language G = epdaS.marked_language (F_DPDA_EA_STD G)"
  apply(simp add: F_DPDA_EA_STD_def)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G="G" and E="(F_DPDA_DAE G)" in F_EPDA_RE__SOUND)
   apply(simp add: F_EPDA_RE__SpecInput_def)
   apply(subgoal_tac "X" for X)
    prefer 2
    apply(rule_tac G="G" in F_DPDA_DAE__SOUND)
    apply(simp add: F_DPDA_DAE__SpecInput_def)
   apply(simp add: F_DPDA_DAE__SpecOutput_def)
   apply(thin_tac "F_DPDA_DAE G = epdaH_accessible_edges G")
   apply (metis epdaH_accessible_edges_vs_epdaS_accessible_edges valid_dpda_def valid_pda_def)
  apply(simp add: F_EPDA_RE__SpecOutput_def)
  done

lemma F_DPDA_EA_STD__preserves_unmarked_language: "
  valid_dpda G
  \<Longrightarrow> epdaS.unmarked_language G = epdaS.unmarked_language (F_DPDA_EA_STD G)"
  apply(simp add: F_DPDA_EA_STD_def)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G="G" and E="(F_DPDA_DAE G)" in F_EPDA_RE__SOUND)
   apply(simp add: F_EPDA_RE__SpecInput_def)
   apply(subgoal_tac "X" for X)
    prefer 2
    apply(rule_tac G="G" in F_DPDA_DAE__SOUND)
    apply(simp add: F_DPDA_DAE__SpecInput_def)
   apply(simp add: F_DPDA_DAE__SpecOutput_def)
   apply(thin_tac "F_DPDA_DAE G = epdaH_accessible_edges G")
   apply (metis epdaH_accessible_edges_vs_epdaS_accessible_edges valid_dpda_def valid_pda_def)
  apply(simp add: F_EPDA_RE__SpecOutput_def)
  done

lemma F_DPDA_EA_STD__enforces_accessible: "
  valid_dpda G
  \<Longrightarrow> epdaS.accessible (F_DPDA_EA_STD G)"
  apply(simp add: F_DPDA_EA_STD_def)
  apply(subgoal_tac "X" for X)
   prefer 2
   apply(rule_tac G="G" and E="(F_DPDA_DAE G)" in F_EPDA_RE__SOUND)
   apply(simp add: F_EPDA_RE__SpecInput_def)
   apply(subgoal_tac "X" for X)
    prefer 2
    apply(rule_tac G="G" in F_DPDA_DAE__SOUND)
    apply(simp add: F_DPDA_DAE__SpecInput_def)
   apply(simp add: F_DPDA_DAE__SpecOutput_def)
   apply(thin_tac "F_DPDA_DAE G = epdaH_accessible_edges G")
   apply (metis epdaH_accessible_edges_vs_epdaS_accessible_edges valid_dpda_def valid_pda_def)
  apply(simp add: F_EPDA_RE__SpecOutput_def)
  done

lemma F_DPDA_EA_STD__preserves_epdaH_no_livelocks_from_marking_states: "
  valid_dpda G
  \<Longrightarrow> epdaH_no_livelocks_from_marking_states G
  \<Longrightarrow> epdaH_no_livelocks_from_marking_states (F_DPDA_EA_STD G)"
  apply(simp add: epdaH_no_livelocks_from_marking_states_def F_DPDA_EA_STD_def)
  apply(clarsimp)
  apply(rename_tac d n e c)(*strict*)
  apply(erule_tac
      x="d"
      in allE)
  apply(erule_tac
      x="n"
      in allE)
  apply(clarsimp)
  apply(erule impE)
   apply(rename_tac d n e c)(*strict*)
   prefer 2
   apply(simp add: F_EPDA_R_def F_EPDA_RE_def F_DPDA_DAE_def Let_def)
  apply(rename_tac d n e c)(*strict*)
  apply(rule epdaH.derivation_initialI)
   apply(rename_tac d n e c)(*strict*)
   prefer 2
   apply(clarsimp)
   apply(rename_tac d n e c ca)(*strict*)
   apply(simp add: get_configuration_def epdaH_initial_configurations_def epdaH.derivation_initial_def)
   apply(rule conjI)
    apply(rename_tac d n e c ca)(*strict*)
    apply(simp add: F_ALT_EPDA_RE_def F_DPDA_DAE_def Let_def F_EPDA_R_def F_EPDA_RE_def)
   apply(rename_tac d n e c ca)(*strict*)
   apply(rule conjI)
    apply(rename_tac d n e c ca)(*strict*)
    apply(simp add: F_ALT_EPDA_RE_def F_DPDA_DAE_def Let_def F_EPDA_R_def F_EPDA_RE_def)
   apply(rename_tac d n e c ca)(*strict*)
   apply(simp add: F_ALT_EPDA_RE_def F_DPDA_DAE_def Let_def epdaH_configurations_def valid_dpda_def valid_pda_def valid_epda_def)
   apply(clarsimp)
   apply(simp add: F_ALT_EPDA_RE_def F_DPDA_DAE_def Let_def F_EPDA_R_def F_EPDA_RE_def)
  apply(rename_tac d n e c)(*strict*)
  apply(simp add: epdaH.derivation_initial_def)
  apply(clarsimp)
  apply(thin_tac "d n = Some (pair (Some e) c)")
  apply(thin_tac "case d 0 of None \<Rightarrow> False | Some (pair a b) \<Rightarrow> b \<in> epdaH_initial_configurations (F_EPDA_RE G (F_DPDA_DAE G)) \<and> a = None")
  apply(rename_tac d n e c)(*strict*)
  apply(thin_tac "edge_src e \<in> epda_marking (F_EPDA_RE G (F_DPDA_DAE G))")
  apply(thin_tac "edge_event e = None")
  apply(simp (no_asm) add: epdaH.derivation_def)
  apply(rename_tac d)(*strict*)
  apply(clarsimp)
  apply(rename_tac d i)(*strict*)
  apply(case_tac i)
   apply(rename_tac d i)(*strict*)
   apply(clarsimp)
   apply(rename_tac d)(*strict*)
   apply(simp add: epdaH.derivation_def)
   apply(erule_tac
      x="0"
      in allE)
   apply(clarsimp)
  apply(rename_tac d i nat)(*strict*)
  apply(clarsimp)
  apply(rename_tac d nat)(*strict*)
  apply(case_tac "d (Suc nat)")
   apply(rename_tac d nat)(*strict*)
   apply(clarsimp)
  apply(rename_tac d nat a)(*strict*)
  apply(subgoal_tac "X" for X)
   apply(rename_tac d nat a)(*strict*)
   prefer 2
   apply(rule_tac
      n="nat"
      and m="Suc nat"
      in epdaH.step_detail_before_some_position)
     apply(rename_tac d nat a)(*strict*)
     apply(force)
    apply(rename_tac d nat a)(*strict*)
    apply(force)
   apply(rename_tac d nat a)(*strict*)
   apply(force)
  apply(rename_tac d nat a)(*strict*)
  apply(clarsimp)
  apply(rename_tac d nat e1 e2 c1 c2)(*strict*)
  apply(simp add: epdaH_step_relation_def)
  apply(clarsimp)
  apply(rename_tac d nat e1 e2 c1 c2 w)(*strict*)
  apply(simp add: F_ALT_EPDA_RE_def F_DPDA_DAE_def Let_def F_EPDA_R_def F_EPDA_RE_def)
  done

definition F_DPDA_EA_STD__SpecInput :: "
  ('state, 'event, 'stack) epda
  \<Rightarrow> bool"
  where
    "F_DPDA_EA_STD__SpecInput G \<equiv>
  valid_dpda G
  \<and> nonblockingness_language (epdaS.unmarked_language G) (epdaS.marked_language G)
  \<and> epdaH_no_livelocks_from_marking_states G"

definition F_DPDA_EA_STD__SpecOutput :: "
  ('p, 'event, 'stack) epda
  \<Rightarrow> ('state, 'event, 'stackx) epda
  \<Rightarrow> bool"
  where
    "F_DPDA_EA_STD__SpecOutput Gi Go \<equiv>
  valid_dpda Go
  \<and> epdaS.marked_language Gi = epdaS.marked_language Go
  \<and> epdaS.unmarked_language Gi = epdaS.unmarked_language Go
  \<and> nonblockingness_language (epdaS.unmarked_language Go) (epdaS.marked_language Go)
  \<and> epdaS.accessible Go
  \<and> epdaH_no_livelocks_from_marking_states Go"

theorem F_DPDA_EA_STD__SOUND: "
  F_DPDA_EA_STD__SpecInput G
  \<Longrightarrow> F_DPDA_EA_STD__SpecOutput G (F_DPDA_EA_STD G)"
  apply(simp add: F_DPDA_EA_STD__SpecInput_def F_DPDA_EA_STD__SpecOutput_def)
  apply(rule conjI)
   apply (metis F_DPDA_EA_STD__preserves_DPDA)
  apply(rule context_conjI)
   apply(rule F_DPDA_EA_STD__preserves_lang)
   apply(force)
  apply(rule context_conjI)
   apply(subgoal_tac "epdaS.unmarked_language G = epdaS.unmarked_language (F_DPDA_EA_STD G)")
    apply(force)
   apply(rule F_DPDA_EA_STD__preserves_unmarked_language)
   apply(force)
  apply(rule context_conjI)
   apply(subgoal_tac "epdaS.unmarked_language G = epdaS.unmarked_language (F_DPDA_EA_STD G)")
    apply(force)
   apply(rule F_DPDA_EA_STD__preserves_unmarked_language)
   apply(force)
  apply(rule conjI)
   apply(rule F_DPDA_EA_STD__enforces_accessible)
   apply(force)
  apply(rule F_DPDA_EA_STD__preserves_epdaH_no_livelocks_from_marking_states)
   apply(force)
  apply(force)
  done

hide_fact F_DPDA_EA_STD__preserves_DPDA
hide_fact F_DPDA_EA_STD__preserves_lang
hide_fact F_DPDA_EA_STD__preserves_unmarked_language
hide_fact F_DPDA_EA_STD__enforces_accessible
hide_fact F_DPDA_EA_STD__preserves_epdaH_no_livelocks_from_marking_states

end