section \<open>Traversal Set\<close>

text \<open>This theory defines the calculation of m-traversal paths.
      These are paths extended from some state until they visit pairwise r-distinguishable states
      a number of times dependent on m.\<close>

theory Traversal_Set
imports Helper_Algorithms
begin

definition m_traversal_paths_with_witness_up_to_length ::
  "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('a set \<times> 'a set) list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (('a\<times>'b\<times>'c\<times>'a) list \<times> ('a set \<times> 'a set)) set"
  where
  "m_traversal_paths_with_witness_up_to_length M q D m k
    = paths_up_to_length_or_condition_with_witness M (\<lambda> p . find (\<lambda> d . length (filter (\<lambda>t . t_target t \<in> fst d) p) \<ge> Suc (m - (card (snd d)))) D) k q"

definition m_traversal_paths_with_witness ::
  "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('a set \<times> 'a set) list \<Rightarrow> nat \<Rightarrow> (('a\<times>'b\<times>'c\<times>'a) list \<times> ('a set \<times> 'a set)) set"
  where
  "m_traversal_paths_with_witness M q D m = m_traversal_paths_with_witness_up_to_length M q D m (Suc (size M * m))"

lemma m_traversal_paths_with_witness_finite : "finite (m_traversal_paths_with_witness M q D m)"
  unfolding m_traversal_paths_with_witness_def m_traversal_paths_with_witness_up_to_length_def
  by (simp add: paths_up_to_length_or_condition_with_witness_finite)

lemma m_traversal_paths_with_witness_up_to_length_max_length :
  assumes "\<And> q . q \<in> states M \<Longrightarrow> \<exists> d \<in> set D . q \<in> fst d"
  and     "\<And> d . d \<in> set D \<Longrightarrow> snd d \<subseteq> fst d"
  and     "q \<in> states M"
  and     "(p,d) \<in> (m_traversal_paths_with_witness_up_to_length M q D m k)"
shows "length p \<le> Suc ((size M) * m)"
proof (rule ccontr)
  assume "\<not> length p \<le> Suc (FSM.size M * m)"

  let ?f = "(\<lambda> p . find (\<lambda> d . length (filter (\<lambda>t . t_target t \<in> fst d) p) \<ge> Suc (m - (card (snd d)))) D)"

  have "path M q []" using assms(3) by auto

  have "path M q p"
        and "length p \<le> k"
        and "?f p = Some d"
        and "\<forall>p' p''. p = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow> ?f p' = None"
    using assms(4)
    unfolding m_traversal_paths_with_witness_up_to_length_def paths_up_to_length_or_condition_with_witness_def
    by auto

  let ?p = "take (Suc (m * size M)) p"
  let ?p' = "drop (Suc (m * size M)) p"
  have "path M q ?p"
    using \<open>path M q p\<close> using path_prefix[of M q ?p "drop (Suc (m * size M)) p"]
    by simp
  have "?p' \<noteq> []"
    using \<open>\<not> length p \<le> Suc (FSM.size M * m)\<close>
    by (simp add: mult.commute)

  have "\<exists> q \<in> states M . length (filter (\<lambda>t . t_target t = q) ?p) \<ge> Suc m"
  proof (rule ccontr)
    assume "\<not> (\<exists>q\<in>states M. Suc m \<le> length (filter (\<lambda>t. t_target t = q) ?p))"
    then have "\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) ?p) < Suc m"
      by auto
    then have "\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) ?p) \<le> m"
      by auto

    have "(\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) ?p)) \<le> (\<Sum>q\<in>states M . m)"
      using \<open>\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) ?p) \<le> m\<close> by (meson sum_mono)
    then have "length ?p \<le> m * (size M)"
      using path_length_sum[OF \<open>path M q ?p\<close>]
      using fsm_states_finite[of M]
      by (simp add: mult.commute)

    then show "False"
      using \<open>\<not> length p \<le> Suc (FSM.size M * m)\<close>
      by (simp add: mult.commute)
  qed

  then obtain q where "q \<in> states M"
                  and "length (filter (\<lambda> t . t_target t = q) ?p) \<ge> Suc m"
    by blast
  then obtain d where "d \<in> set D"
                  and "q \<in> fst d"
    using assms(1) by blast
  then have "\<And> t . t_target t = q \<Longrightarrow> t_target t \<in> fst d" by auto
  then have "length (filter (\<lambda> t . t_target t = q) ?p) \<le> length (filter (\<lambda> t . t_target t \<in> fst d) ?p)"
    using filter_length_weakening[of "\<lambda> t . t_target t = q" "\<lambda> t . t_target t \<in> fst d"] by auto
  then have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) ?p)"
    using \<open>length (filter (\<lambda> t . t_target t = q) ?p) \<ge> Suc m\<close> by auto
  then have "?f ?p \<noteq> None"
    using assms(2)
  proof -
    have "\<forall>p. find p D \<noteq> None \<or> \<not> p d"
      by (metis \<open>d \<in> set D\<close> find_from)
    then show ?thesis
      using \<open>Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take (Suc (m * FSM.size M)) p))\<close>
            diff_le_self le_trans not_less_eq_eq
      by blast
  qed
  then obtain d' where "?f ?p = Some d'"
    by blast

  then have "p = ?p@?p' \<and> ?p' \<noteq> [] \<and> ?f ?p = Some d'"
    using \<open>?p' \<noteq> []\<close> by auto

  then show "False"
    using \<open>\<forall>p' p''. p = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow> (?f p') = None\<close>
    by (metis (no_types) option.distinct(1))
qed

lemma m_traversal_paths_with_witness_set :
  assumes "\<And> q . q \<in> states M \<Longrightarrow> \<exists> d \<in> set D . q \<in> fst d"
  and     "\<And> d .  d \<in> set D \<Longrightarrow> snd d \<subseteq> fst d"
  and     "q \<in> states M"
shows "(m_traversal_paths_with_witness M q D m)
          = {(p,d) | p d . path M q p
                            \<and> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p)) D = Some d
                            \<and> (\<forall>p' p''. p = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None)}"
        (is "?MTP = ?P")
proof -
  let ?f = "(\<lambda> p . find (\<lambda> d . length (filter (\<lambda>t . t_target t \<in> fst d) p) \<ge> Suc (m - (card (snd d)))) D)"

  have "path M q []"
    using assms(3) by auto

  have "\<And> p . p \<in> ?MTP \<Longrightarrow> p \<in> ?P"
    unfolding m_traversal_paths_with_witness_def m_traversal_paths_with_witness_up_to_length_def
              paths_up_to_length_or_condition_with_witness_def
    by force
  moreover have "\<And> p . p \<in> ?P \<Longrightarrow> p \<in> ?MTP"
  proof -
    fix px assume "px \<in> ?P"
    then obtain p x where "px = (p,x)"
          and p1: "path M q p"
          and **: "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p)) D = Some x"
          and ***:"(\<forall>p' p''.
                     p = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow>
                     find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None)"
      using prod.collapse by force

    then have "(p,x) \<in> (m_traversal_paths_with_witness_up_to_length M q D m (length p))"
      unfolding m_traversal_paths_with_witness_up_to_length_def paths_up_to_length_or_condition_with_witness_def
      by force
    then have "length p \<le> Suc (size M * m)"
      using m_traversal_paths_with_witness_up_to_length_max_length[OF assms] by blast

    have "(p,x) \<in> ?MTP"
      using \<open>path M q p\<close> \<open>length p \<le> Suc (size M * m)\<close> \<open>?f p = Some x\<close>
            \<open>\<forall>p' p''. p = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow> (?f p') = None\<close>
      unfolding m_traversal_paths_with_witness_def m_traversal_paths_with_witness_up_to_length_def
                paths_up_to_length_or_condition_with_witness_def
      by force
    then show "px \<in> ?MTP"
      using \<open>px = (p,x)\<close> by simp
  qed
  ultimately show ?thesis
    by (meson subsetI subset_antisym)
qed

lemma maximal_repetition_sets_from_separators_cover :
  assumes "q \<in> states M"
  shows "\<exists> d \<in> (maximal_repetition_sets_from_separators M) . q \<in> fst d"
  unfolding maximal_repetition_sets_from_separators_def
  using maximal_pairwise_r_distinguishable_state_sets_from_separators_cover[OF assms] by auto

lemma maximal_repetition_sets_from_separators_d_reachable_subset :
  shows "\<And> d . d \<in> (maximal_repetition_sets_from_separators M) \<Longrightarrow> snd d \<subseteq> fst d"
  unfolding maximal_repetition_sets_from_separators_def
  by auto

(* Sufficient conditions for a path to be contained in the m-traversal paths *)
lemma m_traversal_paths_with_witness_set_containment :
  assumes "q \<in> states M"
  and     "path M q p"
  and     "d \<in> set repSets"
  and     "Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p)"
  and     "\<And> p' p''.
                  p = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow>
                  \<not> (\<exists>d\<in>set repSets.
                         Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'))"
  and     "\<And> q . q\<in>states M \<Longrightarrow> \<exists>d\<in>set repSets. q \<in> fst d"
  and     "\<And> d . d\<in>set repSets \<Longrightarrow> snd d \<subseteq> fst d"
shows "\<exists> d' . (p,d') \<in> (m_traversal_paths_with_witness M q repSets m)"
proof -
  obtain d' where "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p)) repSets = Some d'"
    using assms(3,4) find_None_iff[of "(\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p))" repSets]
    by auto
  moreover have "(\<And> p' p''. p = p' @ p'' \<Longrightarrow> p'' \<noteq> []
                  \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) repSets = None)"
    using assms(5) find_None_iff[of _ repSets] by force
  ultimately show ?thesis
    using m_traversal_paths_with_witness_set[of M repSets q m, OF  assms(6,7,1)]
    using assms(2) by blast
qed

lemma m_traversal_path_exist :
  assumes "completely_specified M"
  and     "q \<in> states M"
  and     "inputs M \<noteq> {}"
  and     "\<And> q . q\<in>states M \<Longrightarrow> \<exists>d\<in>set D. q \<in> fst d"
  and     "\<And> d . d \<in> set D \<Longrightarrow> snd d \<subseteq> fst d"
shows "\<exists> p' d' . (p',d') \<in> (m_traversal_paths_with_witness M q D m)"
proof -

  obtain p where "path M q p" and "length p = Suc ((size M) * m)"
    using path_of_length_ex[OF assms(1-3)] by blast

  let ?f = "(\<lambda> p . find (\<lambda> d . length (filter (\<lambda>t . t_target t \<in> fst d) p) \<ge> Suc (m - (card (snd d)))) D)"

  have "\<exists> q \<in> states M . length (filter (\<lambda>t . t_target t = q) p) \<ge> Suc m"
  proof (rule ccontr)
    assume "\<not> (\<exists>q\<in>states M. Suc m \<le> length (filter (\<lambda>t. t_target t = q) p))"
    then have "\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) p) < Suc m"
      by auto
    then have "\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) p) \<le> m"
      by auto

    have "(\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) p)) \<le> (\<Sum>q\<in>states M . m)"
      using \<open>\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) p) \<le> m\<close> by (meson sum_mono)
    then have "length p \<le> m * (size M)"
      using path_length_sum[OF \<open>path M q p\<close>]
      using fsm_states_finite[of M]
      by (simp add: mult.commute)

    then show "False"
      using \<open>length p = Suc ((size M) * m)\<close>
      by (simp add: mult.commute)
  qed

  then obtain q' where "q' \<in> states M"
                   and "length (filter (\<lambda> t . t_target t = q') p) \<ge> Suc m"
    by blast
  then obtain d where "d \<in> set D"
                  and "q' \<in> fst d"
    using assms(4) by blast
  then have "\<And> t . t_target t = q' \<Longrightarrow> t_target t \<in> fst d" by auto
  then have "length (filter (\<lambda> t . t_target t = q') p) \<le> length (filter (\<lambda> t . t_target t \<in> fst d) p)"
    using filter_length_weakening[of "\<lambda> t . t_target t = q'" "\<lambda> t . t_target t \<in> fst d"] by auto
  then have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p)"
    using \<open>length (filter (\<lambda> t . t_target t = q') p) \<ge> Suc m\<close> by auto
  then have "?f p \<noteq> None"
    using assms(2)
  proof -
    have "\<forall>p. find p D \<noteq> None \<or> \<not> p d"
      by (metis \<open>d \<in> set D\<close> find_from)
    have "Suc (m - card (snd d)) \<le> length (filter (\<lambda>p. t_target p \<in> fst d) p)"
      using \<open>Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p)\<close> by linarith
    then show ?thesis
      using \<open>\<forall>p. find p D \<noteq> None \<or> \<not> p d\<close> by blast
  qed
  then obtain d' where "?f p = Some d'"
    by blast

  show ?thesis proof (cases "(\<forall>p' p''. p = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None)")
    case True
    then show ?thesis
      using m_traversal_paths_with_witness_set[OF assms(4,5,2), of m] \<open>path M q p\<close> \<open>?f p = Some d'\<close>
      by blast
  next
    case False

    define ps where ps_def: "ps = {p' . \<exists> p''. p = p' @ p'' \<and> p'' \<noteq> []
                                              \<and> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None}"
    have "ps \<noteq> {}"
      using False ps_def
      by blast
    moreover have "finite ps"
    proof -
      have "ps \<subseteq> set (prefixes p)"
        unfolding prefixes_set ps_def
        by blast
      then show ?thesis
        by (meson List.finite_set rev_finite_subset)
    qed
    ultimately obtain p' where "p' \<in> ps" and "\<And> p'' . p'' \<in> ps \<Longrightarrow> length p' \<le> length p''"
      by (meson leI min_length_elem)
    then have "\<And>p'' p''' . p' = p'' @ p''' \<Longrightarrow> p''' \<noteq> []
                \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None"
    proof -
      fix p'' p''' assume "p' = p'' @ p'''" and "p''' \<noteq> []"
      show "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None"
      proof (rule ccontr)
        assume "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D \<noteq> None"
        moreover have "\<exists>p'''. p = p'' @ p''' \<and> p''' \<noteq> []"
          using \<open>p' \<in> ps\<close> \<open>p' = p'' @ p'''\<close> unfolding ps_def by auto
        ultimately have "p'' \<in> ps"
          unfolding ps_def by auto
        moreover have "length p'' < length p'"
          using \<open>p''' \<noteq> []\<close> \<open>p' = p'' @ p'''\<close> by auto
        ultimately show "False"
          using \<open>\<And> p'' . p'' \<in> ps \<Longrightarrow> length p' \<le> length p''\<close>
          using leD by auto
      qed
    qed

    have "path M q p'" and "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None"
      using \<open>path M q p\<close> \<open>p' \<in> ps\<close> unfolding ps_def by auto
    then obtain d' where "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = Some d'"
      by auto

    then have "path M q p' \<and>
               find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = Some d' \<and>
               (\<forall>p'' p'''. p' = p'' @ p''' \<and> p''' \<noteq> [] \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None)"
      using \<open>\<And>p'' p''' . p' = p'' @ p''' \<Longrightarrow> p''' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None\<close>
            \<open>path M q p'\<close>
      by blast
    then have "(p',d') \<in> (m_traversal_paths_with_witness M q D m)"
      using m_traversal_paths_with_witness_set[OF assms(4,5,2), of m] by blast
    then show ?thesis by blast
  qed
qed

lemma m_traversal_path_extension_exist :
  assumes "completely_specified M"
  and     "q \<in> states M"
  and     "inputs M \<noteq> {}"
  and     "\<And> q . q\<in>states M \<Longrightarrow> \<exists>d\<in>set D. q \<in> fst d"
  and     "\<And> d . d \<in> set D \<Longrightarrow> snd d \<subseteq> fst d"
  and     "path M q p1"
  and     "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)) D = None"
shows "\<exists> p2 d' . (p1@p2,d') \<in> (m_traversal_paths_with_witness M q D m)"
proof -
  obtain p2 where "path M (target q p1) p2" and "length p2 = (Suc ((size M) * m)) - length p1"
    using path_of_length_ex[OF assms(1) path_target_is_state[OF assms(6)] assms(3)]
    by blast

  have "path M q (p1@p2)"
    using assms(6) \<open>path M (target q p1) p2\<close> by auto

  let ?f = "(\<lambda> p . find (\<lambda> d . length (filter (\<lambda>t . t_target t \<in> fst d) p) \<ge> Suc (m - (card (snd d)))) D)"

  have "length p1 < Suc ((size M) * m)"
  proof (rule ccontr)
    assume "\<not> length p1 < Suc (FSM.size M * m)"
    then have "length (take (Suc (FSM.size M * m)) p1) = Suc (FSM.size M * m)"
      by auto
    let ?p = "(take (Suc (FSM.size M * m)) p1)"

    have "path M q ?p"
      using \<open>path M q p1\<close>
      by (metis append_take_drop_id path_append_elim)

    have "\<exists> q \<in> states M . length (filter (\<lambda>t . t_target t = q) ?p) \<ge> Suc m"
    proof (rule ccontr)
      assume "\<not> (\<exists>q\<in>states M. Suc m \<le> length (filter (\<lambda>t. t_target t = q) ?p))"
      then have "\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) ?p) < Suc m"
        by auto
      then have "\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) ?p) \<le> m"
        by auto

      have "(\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) ?p)) \<le> (\<Sum>q\<in>states M . m)"
        using \<open>\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) ?p) \<le> m\<close> by (meson sum_mono)
      then have "length ?p \<le> m * (size M)"
        using path_length_sum[OF \<open>path M q ?p\<close>]
        using fsm_states_finite[of M]
        by (simp add: mult.commute)

      then show "False"
        using \<open>length ?p = Suc ((size M) * m)\<close>
        by (simp add: mult.commute)
    qed
    then obtain q' where "q' \<in> states M"
                   and "length (filter (\<lambda> t . t_target t = q') ?p) \<ge> Suc m"
      by blast
    then obtain d where "d \<in> set D"
                    and "q' \<in> fst d"
      using assms(4) by blast
    then have "\<And> t . t_target t = q' \<Longrightarrow> t_target t \<in> fst d" by auto
    then have "length (filter (\<lambda> t . t_target t = q') ?p) \<le> length (filter (\<lambda> t . t_target t \<in> fst d) ?p)"
      using filter_length_weakening[of "\<lambda> t . t_target t = q'" "\<lambda> t . t_target t \<in> fst d"] by auto
    then have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) ?p)"
      using \<open>length (filter (\<lambda> t . t_target t = q') ?p) \<ge> Suc m\<close> by auto
    moreover have "length (filter (\<lambda>t. t_target t \<in> fst d) ?p) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)"
    proof -
      have "\<And> xs P n . length (filter P (take n xs)) \<le> length (filter P xs)"
        by (metis append_take_drop_id filter_append le0 le_add_same_cancel1 length_append)
      then show ?thesis by auto
    qed
    ultimately have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)"
      by auto
    then have "?f p1 \<noteq> None"
      using assms(2)
    proof -
      have "\<forall>p. find p D \<noteq> None \<or> \<not> p d"
        by (metis \<open>d \<in> set D\<close> find_from)
      have "Suc (m - card (snd d)) \<le> length (filter (\<lambda>p. t_target p \<in> fst d) p1)"
        using \<open>Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)\<close> by linarith
      then show ?thesis
        using \<open>\<forall>p. find p D \<noteq> None \<or> \<not> p d\<close> by blast
    qed
    then obtain d' where "?f p1 = Some d'"
      by blast
    then show "False"
      using assms(7) by simp
  qed

  have "length (p1@p2) = (Suc ((size M) * m))"
    using \<open>length p2 = (Suc ((size M) * m)) - length p1\<close>
          \<open>length p1 < Suc ((size M) * m)\<close>
    by simp

  have "\<exists> q \<in> states M . length (filter (\<lambda>t . t_target t = q) (p1@p2)) \<ge> Suc m"
  proof (rule ccontr)
    assume "\<not> (\<exists>q\<in>states M. Suc m \<le> length (filter (\<lambda>t. t_target t = q) (p1@p2)))"
    then have "\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) (p1@p2)) < Suc m"
      by auto
    then have "\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) (p1@p2)) \<le> m"
      by auto

    have "(\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) (p1@p2))) \<le> (\<Sum>q\<in>states M . m)"
      using \<open>\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) (p1@p2)) \<le> m\<close> by (meson sum_mono)
    then have "length (p1@p2) \<le> m * (size M)"
      using path_length_sum[OF \<open>path M q (p1@p2)\<close>]
      using fsm_states_finite[of M]
      by (simp add: mult.commute)

    then show "False"
      using \<open>length (p1@p2) = Suc ((size M) * m)\<close>
      by (simp add: mult.commute)
  qed
  then obtain q' where "q' \<in> states M"
                   and "length (filter (\<lambda> t . t_target t = q') (p1@p2)) \<ge> Suc m"
    by blast
  then obtain d where "d \<in> set D"
                  and "q' \<in> fst d"
    using assms(4) by blast
  then have "\<And> t . t_target t = q' \<Longrightarrow> t_target t \<in> fst d" by auto
  then have "length (filter (\<lambda> t . t_target t = q') (p1@p2)) \<le> length (filter (\<lambda> t . t_target t \<in> fst d) (p1@p2))"
    using filter_length_weakening[of "\<lambda> t . t_target t = q'" "\<lambda> t . t_target t \<in> fst d"]
    by blast
  then have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (p1@p2))"
    using \<open>length (filter (\<lambda> t . t_target t = q') (p1@p2)) \<ge> Suc m\<close> by auto
  then have "?f (p1@p2) \<noteq> None"
    using assms(2)
  proof -
    have "\<forall>p. find p D \<noteq> None \<or> \<not> p d"
      by (metis \<open>d \<in> set D\<close> find_from)
    have "Suc (m - card (snd d)) \<le> length (filter (\<lambda>p. t_target p \<in> fst d) (p1@p2))"
      using \<open>Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (p1@p2))\<close> by linarith
    then show ?thesis
      using \<open>\<forall>p. find p D \<noteq> None \<or> \<not> p d\<close> by blast
  qed
  then obtain d' where "?f (p1@p2) = Some d'"
    by blast

  show ?thesis proof (cases "(\<forall>p' p''. (p1@p2) = p' @ p'' \<and> p'' \<noteq> []
                                 \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None)")
    case True
    then show ?thesis
      using m_traversal_paths_with_witness_set[OF assms(4,5,2), of m] \<open>path M q (p1@p2)\<close> \<open>?f (p1@p2) = Some d'\<close>
      by blast
  next
    case False

    define ps where ps_def: "ps = {p' . \<exists> p''. (p1@p2) = p' @ p'' \<and> p'' \<noteq> []
                                                \<and> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None}"
    have "ps \<noteq> {}" using False ps_def by blast
    moreover have "finite ps"
    proof -
      have "ps \<subseteq> set (prefixes (p1@p2))"
        unfolding prefixes_set ps_def
        by auto
      then show ?thesis
        by (meson List.finite_set rev_finite_subset)
    qed
    ultimately obtain p' where "p' \<in> ps" and "\<And> p'' . p'' \<in> ps \<Longrightarrow> length p' \<le> length p''"
      by (meson leI min_length_elem)
    then have "\<And>p'' p''' . p' = p'' @ p''' \<Longrightarrow> p''' \<noteq> []
                            \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None"
    proof -
      fix p'' p''' assume "p' = p'' @ p'''" and "p''' \<noteq> []"
      show "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None"
      proof (rule ccontr)
        assume "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D \<noteq> None"
        moreover have "\<exists>p'''. (p1@p2) = p'' @ p''' \<and> p''' \<noteq> []"
          using \<open>p' \<in> ps\<close> \<open>p' = p'' @ p'''\<close> unfolding ps_def by auto
        ultimately have "p'' \<in> ps"
          unfolding ps_def by auto
        moreover have "length p'' < length p'"
          using \<open>p''' \<noteq> []\<close> \<open>p' = p'' @ p'''\<close> by auto
        ultimately show "False"
          using \<open>\<And> p'' . p'' \<in> ps \<Longrightarrow> length p' \<le> length p''\<close>
          using leD by auto
      qed
    qed

    obtain p'' where "(p1@p2) = p' @ p''"
               and   "p'' \<noteq> []"
               and   "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None"
      using \<open>p' \<in> ps\<close> unfolding ps_def by blast
    then obtain d' where "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = Some d'"
      by auto

    have "path M q p'"
      using \<open>path M q (p1@p2)\<close>  unfolding \<open>(p1@p2) = p' @ p''\<close> by auto

    have "length p' > length p1"
    proof (rule ccontr)
      assume "\<not> length p1 < length p'"
      then obtain i where "p' = take i p1"
        by (metis \<open>p1 @ p2 = p' @ p''\<close> append_eq_append_conv_if less_le)

      have "\<And> i . find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i p1))) D = None"
      proof -
        fix i
        show "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i p1))) D = None"
        proof (rule ccontr)
          assume "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i p1))) D \<noteq> None"
          then obtain d where "d \<in> set D"
                        and   "Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i p1))"
            using find_None_iff[of "(\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i p1)))" D]
            by meson

          moreover have "length (filter (\<lambda>t. t_target t \<in> fst d) (take i p1)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)"
            using filter_take_length by metis
          ultimately have "Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)"
            using le_trans by blast
          then show "False"
            using \<open>d \<in> set D\<close> assms(7) unfolding find_None_iff
            by blast
        qed
      qed

      then have "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None"
        unfolding \<open>p' = take i p1\<close> by blast
      then show "False"
        using \<open>find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None\<close>
        by auto
    qed

    moreover have "p' = take (length p') (p1@p2)"
      using \<open>(p1@p2) = p' @ p''\<close> by auto

    ultimately obtain p where "p' = p1 @ p"
      by auto

    have "path M q p' \<and>
           find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = Some d' \<and>
           (\<forall>p'' p'''. p' = p'' @ p''' \<and> p''' \<noteq> [] \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None)"
      using \<open>\<And>p'' p''' . p' = p'' @ p''' \<Longrightarrow> p''' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None\<close>
            \<open>path M q p'\<close> \<open>find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = Some d'\<close>
      by blast
    then have "(p',d') \<in> (m_traversal_paths_with_witness M q D m)"
      using m_traversal_paths_with_witness_set[OF assms(4,5,2), of m] by blast
    then show ?thesis unfolding \<open>p' = p1 @ p\<close> by blast
  qed
qed

lemma m_traversal_path_extension_exist_for_transition :
  assumes "completely_specified M"
  and     "q \<in> states M"
  and     "inputs M \<noteq> {}"
  and     "\<And> q . q\<in>states M \<Longrightarrow> \<exists>d\<in>set D. q \<in> fst d"
  and     "\<And> d . d \<in> set D \<Longrightarrow> snd d \<subseteq> fst d"
  and     "path M q p1"
  and     "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)) D = None"
  and     "t \<in> transitions M"
  and     "t_source t = target q p1"
shows "\<exists> p2 d' . (p1@[t]@p2,d') \<in> (m_traversal_paths_with_witness M q D m)"
proof -
  let ?q = "(target q (p1 @ [t]))"
  let ?p = "p1 @ [t]"

  have "path M q ?p"
    using \<open>path M q p1\<close> \<open>t \<in> transitions M\<close> \<open>t_source t = target q p1\<close> path_append_transition by simp

  obtain p2 where "path M ?q p2" and "length p2 = (Suc ((size M) * m)) - (length ?p)"
    using path_of_length_ex[OF assms(1) path_target_is_state[OF \<open>path M q (p1@[t])\<close>] assms(3)]
    by blast

  have "path M q (?p@p2)"
    using \<open>path M q ?p\<close> \<open>path M ?q p2\<close> by auto

  let ?f = "(\<lambda> p . find (\<lambda> d . length (filter (\<lambda>t . t_target t \<in> fst d) p) \<ge> Suc (m - (card (snd d)))) D)"

  have "length p1 < Suc ((size M) * m)"
  proof (rule ccontr)
    assume "\<not> length p1 < Suc (FSM.size M * m)"
    then have "length (take (Suc (FSM.size M * m)) p1) = Suc (FSM.size M * m)"
      by auto
    let ?p = "(take (Suc (FSM.size M * m)) p1)"

    have "path M q ?p"
      using \<open>path M q p1\<close>
      by (metis append_take_drop_id path_append_elim)

    have "\<exists> q \<in> states M . length (filter (\<lambda>t . t_target t = q) ?p) \<ge> Suc m"
    proof (rule ccontr)
      assume "\<not> (\<exists>q\<in>states M. Suc m \<le> length (filter (\<lambda>t. t_target t = q) ?p))"
      then have "\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) ?p) < Suc m"
        by auto
      then have "\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) ?p) \<le> m"
        by auto

      have "(\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) ?p)) \<le> (\<Sum>q\<in>states M . m)"
        using \<open>\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) ?p) \<le> m\<close> by (meson sum_mono)
      then have "length ?p \<le> m * (size M)"
        using path_length_sum[OF \<open>path M q ?p\<close>]
        using fsm_states_finite[of M]
        by (simp add: mult.commute)

      then show "False"
        using \<open>length ?p = Suc ((size M) * m)\<close>
        by (simp add: mult.commute)
    qed
    then obtain q' where "q' \<in> states M"
                   and "length (filter (\<lambda> t . t_target t = q') ?p) \<ge> Suc m"
      by blast
    then obtain d where "d \<in> set D"
                    and "q' \<in> fst d"
      using assms(4) by blast
    then have "\<And> t . t_target t = q' \<Longrightarrow> t_target t \<in> fst d" by auto
    then have "length (filter (\<lambda> t . t_target t = q') ?p) \<le> length (filter (\<lambda> t . t_target t \<in> fst d) ?p)"
      using filter_length_weakening[of "\<lambda> t . t_target t = q'" "\<lambda> t . t_target t \<in> fst d"] by auto
    then have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) ?p)"
      using \<open>length (filter (\<lambda> t . t_target t = q') ?p) \<ge> Suc m\<close> by auto
    moreover have "length (filter (\<lambda>t. t_target t \<in> fst d) ?p) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)"
    proof -
      have "\<And> xs P n . length (filter P (take n xs)) \<le> length (filter P xs)"
        by (metis append_take_drop_id filter_append le0 le_add_same_cancel1 length_append)
      then show ?thesis by auto
    qed
    ultimately have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)"
      by auto
    then have "?f p1 \<noteq> None"
      using assms(2)
    proof -
      have "\<forall>p. find p D \<noteq> None \<or> \<not> p d"
        by (metis \<open>d \<in> set D\<close> find_from)
      have "Suc (m - card (snd d)) \<le> length (filter (\<lambda>p. t_target p \<in> fst d) p1)"
        using \<open>Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)\<close> by linarith
      then show ?thesis
        using \<open>\<forall>p. find p D \<noteq> None \<or> \<not> p d\<close> by blast
    qed
    then obtain d' where "?f p1 = Some d'"
      by blast
    then show "False"
      using assms(7) by simp
  qed

  have "length (?p@p2) = (Suc ((size M) * m))"
    using \<open>length p2 = (Suc ((size M) * m)) - length ?p\<close>
          \<open>length p1 < Suc ((size M) * m)\<close>
    by simp

  have "\<exists> q \<in> states M . length (filter (\<lambda>t . t_target t = q) (?p@p2)) \<ge> Suc m"
  proof (rule ccontr)
    assume "\<not> (\<exists>q\<in>states M. Suc m \<le> length (filter (\<lambda>t. t_target t = q) (?p@p2)))"
    then have "\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) (?p@p2)) < Suc m"
      by auto
    then have "\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) (?p@p2)) \<le> m"
      by auto

    have "(\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) (?p@p2))) \<le> (\<Sum>q\<in>states M . m)"
      using \<open>\<forall> q \<in> states M . length (filter (\<lambda>t. t_target t = q) (?p@p2)) \<le> m\<close> by (meson sum_mono)
    then have "length (?p@p2) \<le> m * (size M)"
      using path_length_sum[OF \<open>path M q (?p@p2)\<close>]
      using fsm_states_finite[of M]
      by (simp add: mult.commute)

    then show "False"
      using \<open>length (?p@p2) = Suc ((size M) * m)\<close>
      by (simp add: mult.commute)
  qed

  then obtain q' where "q' \<in> states M"
                   and "length (filter (\<lambda> t . t_target t = q') (?p@p2)) \<ge> Suc m"
    by blast
  then obtain d where "d \<in> set D"
                  and "q' \<in> fst d"
    using assms(4) by blast
  then have "\<And> t . t_target t = q' \<Longrightarrow> t_target t \<in> fst d" by auto
  then have "length (filter (\<lambda> t . t_target t = q') (?p@p2)) \<le> length (filter (\<lambda> t . t_target t \<in> fst d) (?p@p2))"
    using filter_length_weakening[of "\<lambda> t . t_target t = q'" "\<lambda> t . t_target t \<in> fst d"]
    by blast
  then have "Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (?p@p2))"
    using \<open>length (filter (\<lambda> t . t_target t = q') (?p@p2)) \<ge> Suc m\<close> by auto
  then have "?f (?p@p2) \<noteq> None"
    using assms(2)
  proof -
    have "\<forall>p. find p D \<noteq> None \<or> \<not> p d"
      by (metis \<open>d \<in> set D\<close> find_from)
    have "Suc (m - card (snd d)) \<le> length (filter (\<lambda>p. t_target p \<in> fst d) (?p@p2))"
      using \<open>Suc m \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (?p@p2))\<close> by linarith
    then show ?thesis
      using \<open>\<forall>p. find p D \<noteq> None \<or> \<not> p d\<close> by blast
  qed
  then obtain d' where "?f (?p@p2) = Some d'"
    by blast

  show ?thesis proof (cases "(\<forall>p' p''. (?p@p2) = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None)")
    case True
    obtain d' where "((?p@p2), d') \<in> m_traversal_paths_with_witness M q D m"
      using m_traversal_paths_with_witness_set[OF assms(4,5,2), of m] \<open>path M q (?p@p2)\<close> \<open>?f (?p@p2) = Some d'\<close> True by force
    then show ?thesis
      unfolding append.assoc[symmetric] by blast
  next
    case False

    show ?thesis proof (cases "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) ?p)) D")
      case (Some a)

      have *: "(\<forall>p' p''. ?p = p' @ p'' \<and> p'' \<noteq> [] \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None)"
      proof -
        have "\<And> p' p''. ?p = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None"
        proof -
          fix p' p'' assume "?p = p' @ p''" and "p'' \<noteq> []"
          then have "length p' \<le> length p1" by (induction p'' rule: rev_induct; auto)
          moreover have "p' = take (length p') ?p"
            unfolding \<open>?p = p' @ p''\<close> by auto
          ultimately have "p' = take (length p') p1"
            by auto

          show "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None"
          proof (rule ccontr)
            assume "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None"
            moreover have "\<And> x . length (filter (\<lambda>t. t_target t \<in> fst x) p') \<le> length (filter (\<lambda>t. t_target t \<in> fst x) p1)"
              using \<open>p' = take (length p') p1\<close>
              by (metis filter_take_length)
            ultimately have "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p1)) D \<noteq> None"
              unfolding find_None_iff
              using le_trans by blast
            then show "False"
              using assms(7) by simp
          qed
        qed
        then show ?thesis by blast
      qed

      obtain d' where "(?p, d') \<in> m_traversal_paths_with_witness M q D m"
        using m_traversal_paths_with_witness_set[OF assms(4,5,2), of m] \<open>path M q ?p\<close> Some * by force
      then show ?thesis
        by fastforce
    next
      case None

      define ps where ps_def: "ps = {p' . \<exists> p''. (?p@p2) = p' @ p''
                                                  \<and> p'' \<noteq> []
                                                  \<and> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None}"
      have "ps \<noteq> {}" using False ps_def by blast
      moreover have "finite ps"
      proof -
        have "ps \<subseteq> set (prefixes (?p@p2))"
          unfolding prefixes_set ps_def
          by auto
        then show ?thesis
          by (meson List.finite_set rev_finite_subset)
      qed
      ultimately obtain p' where "p' \<in> ps" and "\<And> p'' . p'' \<in> ps \<Longrightarrow> length p' \<le> length p''"
        by (meson leI min_length_elem)
      then have "\<And>p'' p''' . p' = p'' @ p''' \<Longrightarrow> p''' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None"
      proof -
        fix p'' p''' assume "p' = p'' @ p'''" and "p''' \<noteq> []"
        show "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None"
        proof (rule ccontr)
          assume "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D \<noteq> None"
          moreover have "\<exists>p'''. (?p@p2) = p'' @ p''' \<and> p''' \<noteq> []"
            using \<open>p' \<in> ps\<close> \<open>p' = p'' @ p'''\<close> unfolding ps_def by auto
          ultimately have "p'' \<in> ps"
            unfolding ps_def by auto
          moreover have "length p'' < length p'"
            using \<open>p''' \<noteq> []\<close> \<open>p' = p'' @ p'''\<close> by auto
          ultimately show "False"
            using \<open>\<And> p'' . p'' \<in> ps \<Longrightarrow> length p' \<le> length p''\<close>
            using leD by auto
        qed
      qed

      obtain p'' where "(?p@p2) = p' @ p''"
                 and   "p'' \<noteq> []"
                 and   "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None"
        using \<open>p' \<in> ps\<close> unfolding ps_def by blast
      then obtain d' where "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = Some d'"
        by auto

      have "path M q p'"
        using \<open>path M q (?p@p2)\<close>  unfolding \<open>(?p@p2) = p' @ p''\<close> by auto

      have "length p' > length ?p"
      proof (rule ccontr)

        assume "\<not> length ?p < length p'"
        then obtain i where "p' = take i ?p"
          by (metis \<open>?p @ p2 = p' @ p''\<close> append_eq_append_conv_if less_le)

        have "\<And> i . find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i ?p))) D = None"
        proof -
          fix i
          show "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i ?p))) D = None"
          proof (rule ccontr)
            assume "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i ?p))) D \<noteq> None"
            then obtain d where "d \<in> set D"
                          and   "Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i ?p))"
              using find_None_iff[of "(\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) (take i ?p)))" D]
              by meson

            moreover have "length (filter (\<lambda>t. t_target t \<in> fst d) (take i ?p)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) ?p)"
              using filter_take_length by metis
            ultimately have "Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) ?p)"
              using le_trans by blast
            then show "False"
              using \<open>d \<in> set D\<close> None unfolding find_None_iff
              by blast
          qed
        qed

        then have "find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = None"
          unfolding \<open>p' = take i ?p\<close> by blast
        then show "False"
          using \<open>find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D \<noteq> None\<close>
          by auto
      qed

      moreover have "p' = take (length p') (?p@p2)"
        using \<open>(?p@p2) = p' @ p''\<close> by auto

      ultimately obtain p where "p' = ?p @ p"
        by (metis dual_order.strict_implies_order take_all take_append)

      have "path M q p' \<and>
             find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = Some d' \<and>
             (\<forall>p'' p'''. p' = p'' @ p''' \<and> p''' \<noteq> [] \<longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None)"
        using \<open>\<And>p'' p''' . p' = p'' @ p''' \<Longrightarrow> p''' \<noteq> [] \<Longrightarrow> find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p'')) D = None\<close> \<open>path M q p'\<close> \<open>find (\<lambda>d. Suc (m - card (snd d)) \<le> length (filter (\<lambda>t. t_target t \<in> fst d) p')) D = Some d'\<close>
        by blast
      then have "(p',d') \<in> (m_traversal_paths_with_witness M q D m)"
        using m_traversal_paths_with_witness_set[OF assms(4,5,2), of m] by blast
      then show ?thesis unfolding \<open>p' = ?p @ p\<close> by fastforce
    qed
  qed
qed

end


theory basic
imports Main Complex
begin

(*The type for representing matrices, and three special sets of matrices*)
typedecl Mat
consts uMat :: "Mat set"
consts rhoMat :: "Mat set"
consts predMat::"Mat set"

type_synonym number=nat
type_synonym measurement="Mat list"
type_synonym nT="nat\<Rightarrow>Mat"

consts  infinity::"nat"
(*   the trace of matrix  *)
consts Tr::"Mat\<Rightarrow>real"
(*multiplication of matrix*)
consts mat_mult::"Mat\<Rightarrow>Mat\<Rightarrow>Mat"
(*   addition of matrix  *)
consts mat_add::"Mat\<Rightarrow>Mat\<Rightarrow>Mat"
(*   subtraction of matrix    *)
consts mat_sub::"Mat\<Rightarrow>Mat\<Rightarrow>Mat"
(*    all 0 matrix   *)
consts zero::"Mat"
(*    M\<dagger>   *)
consts dag::"Mat\<Rightarrow>Mat"
(*    |0><n|  *)
consts f::"nat\<Rightarrow>Mat"
(*    |n><0|  *)
consts g::"nat\<Rightarrow>Mat"
(*   identity matrix *)
consts I::"Mat"
(*   a\<sqsubseteq>b      *)
consts less::"Mat\<Rightarrow>Mat\<Rightarrow>bool"
(*  fixpoint    *)
consts fixPoint::"Mat"
consts fixPoint_wlp::"Mat"
(*  a^n   a is type of matrix,b is type of int *)
consts pow::"Mat\<Rightarrow>nat\<Rightarrow>Mat"

(*The axioms for matrices we assume. These are the basic axioms of matrices accepted by us for a long time. *)
axiomatization where
(* Tr a*b= Tr b*a *)
exchange:"Tr (mat_mult a b) =Tr (mat_mult b a)"and
(*  (m1*m2)*m3=m1*(m2*m3)   *)
mult_exchange:"mat_mult (mat_mult m1 m2) m3=mat_mult m1 (mat_mult m2 m3)"and
(*zero*)
zero_add:"mat_add a zero=a"and
zero_mult_r:"mat_mult a zero=zero"and
zero_mult_l:"mat_mult zero b=zero"and
zero_tr: "Tr zero = 0" and
rho_zero:"\<forall> a. a \<in> rhoMat \<longrightarrow> less zero  a" and
a:"less zero a\<Longrightarrow>a\<in>rhoMat"and
I_zero:"less zero I" and
pred:"\<forall> a. a\<in>predMat\<longrightarrow>less a I" and
(*(a+b)*c=ac+bc*)
mult_allo1:"mat_mult (mat_add a b) c=mat_add (mat_mult a c)  (mat_mult b c)" and
(* (a-b)*c=a*c-b*c    *)
mult_sub_allo1:"mat_mult (mat_sub a b) c=mat_sub (mat_mult a c) (mat_mult b c)" and
(*  c(a+b) =ca+cb       *)
mult_allo2:"mat_mult c (mat_add a b) =mat_add (mat_mult c a )  (mat_mult c b)"and
(* Tr (a+b) =Tr a+Tr b  *)
tr_allo:"Tr (mat_add a b) =Tr a+Tr b"and
(*Tr (a-b) =Tr a - Tr b*)
tr_allo1:"Tr (mat_sub a b) =Tr a -Tr b"and
(*dag U * U=I*)
U_dag:"\<forall> a. a \<in> uMat \<longrightarrow> mat_mult (dag a) a=I"and
(*I*a=a*)
Ident:"mat_mult I a=a"and
(* less a b \<Rightarrow> less (a+c) (b+c)*)
less1:"less a b\<Longrightarrow>less (mat_add c a) (mat_add c b )"and
less5:"less a b\<Longrightarrow>less (mat_sub a c) (mat_sub b c)" and
sub_self:"mat_sub a a=zero"and
(*  a\<sqsubseteq>b\<Longrightarrow>tr ac\<le>tr bc for all \<rho> mats  *)
less2:"less a b\<Longrightarrow>(\<forall> c. c \<in> rhoMat \<longrightarrow> tr (mat_mult a c) \<le>tr (mat_mult b c)) "and
(* a\<ge>0\<Longrightarrow>m*a*m.T\<ge>0  *)
less3:" less zero  a\<Longrightarrow>less zero (mat_mult (mat_mult b a) (dag b))"and
(*a>0 b>0\<Longrightarrow>Tr (ab)\<ge>0*)
less4:"less zero a\<Longrightarrow>less zero b\<Longrightarrow>Tr (mat_mult a b) \<ge>0"and
(* a\<ge>b c\<ge>d\<Longrightarrow>a+c\<ge>b+d*)
 less6:"less a b\<Longrightarrow>less c d\<Longrightarrow>less (mat_add a c) (mat_add b d)"

lemma rho_tr:"\<forall> c. c \<in> rhoMat \<longrightarrow>  0 <=Tr c"
by (metis I_zero Ident less2 zero_mult_l zero_tr)

end


theory Impl_Uv_Set
imports
  "../../Iterator/Iterator"
  "../Intf/Intf_Set"
  Native_Word.Uint
begin

  subsection \<open>Bit-Vectors as Lists of Words\<close>

  subsubsection \<open>Lookup\<close>

  primrec lookup :: "nat \<Rightarrow> ('a::len) word list \<Rightarrow> bool" where
    "lookup _ [] \<longleftrightarrow> False"
  | "lookup n (w#ws)
      \<longleftrightarrow> (if n<LENGTH('a) then bit w n else lookup (n-LENGTH('a)) ws)"

  lemma lookup_append[simp]: "lookup n (w1@w2 :: 'a::len word list)
    \<longleftrightarrow> (
      if n < LENGTH('a) * length w1 then
        lookup n w1
      else lookup (n - LENGTH('a) * length w1) w2)"
    by (induction w1 arbitrary: n) auto

  lemma lookup_zeroes[simp]: "lookup i (replicate n (0::'a::len word)) = False"
    by (induction n arbitrary: i) auto

  subsubsection \<open>Empty\<close>

  definition empty :: "'a::len word list" where "empty = []"

  subsubsection \<open>Set and Reset Bit\<close>

  function single_bit :: "nat \<Rightarrow> ('a::len) word list"
    where "single_bit n = (
      if (n<LENGTH('a)) then
        [set_bit 0 n True]
      else 0#single_bit (n-LENGTH('a)))"
    by pat_completeness auto
  termination
    apply (relation "measure id")
    apply simp
    apply (simp add: not_less less_diff_conv2)
    done

  declare single_bit.simps[simp del]

  lemma lookup_single_bit[simp]: "lookup i ((single_bit n)::'a::len word list) \<longleftrightarrow> i = n"
    apply (induction n arbitrary: i rule: single_bit.induct)
    apply (subst single_bit.simps)
    apply (auto simp: bin_nth_sc_gen bit_simps)
    done

  primrec set_bit :: "nat \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list" where
    "set_bit i [] = single_bit i"
  | "set_bit i (w#ws) = (
      if i<LENGTH('a) then
        Bit_Operations.set_bit i w # ws
      else
        w # set_bit (i - LENGTH('a)) ws)"

  lemma set_bit_lookup[simp]: "lookup i (set_bit j ws) \<longleftrightarrow> (lookup i ws \<or> i=j)"
    apply (induction ws arbitrary: i j)
     apply (auto simp add: word_size Bit_Operations.bit_set_bit_iff)
    done

  primrec reset_bit :: "nat \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list" where
    "reset_bit i [] = []"
  | "reset_bit i (w#ws) = (
      if i<LENGTH('a) then
        unset_bit i w # ws
      else
        w # reset_bit (i - LENGTH('a)) ws)"

  lemma reset_bit_lookup[simp]: "lookup i (reset_bit j ws) \<longleftrightarrow> (lookup i ws \<and> i\<noteq>j)"
    apply (induction ws arbitrary: i j)
    apply (auto simp: word_size bit_unset_bit_iff)
    done

  subsubsection \<open>Binary Operations\<close>

  definition
    is_bin_op_impl
    :: "(bool\<Rightarrow>bool\<Rightarrow>bool) \<Rightarrow> ('a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word) \<Rightarrow> bool"
    where "is_bin_op_impl f g \<equiv>
    (\<forall>w v.  \<forall>i<LENGTH('a). bit (g w v) i \<longleftrightarrow> f (bit w i) (bit v i))"

  definition "is_strict_bin_op_impl f g \<equiv> is_bin_op_impl f g \<and> f False False = False"

  fun binary :: "('a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word)
    \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list"
    where
    "binary f [] [] = []"
  | "binary f [] (w#ws) = f 0 w # binary f [] ws"
  | "binary f (v#vs) [] = f v 0 # binary f vs []"
  | "binary f (v#vs) (w#ws) = f v w # binary f vs ws"

  lemma binary_lookup:
    assumes "is_strict_bin_op_impl f g"
    shows "lookup i (binary g ws vs) \<longleftrightarrow> f (lookup i ws) (lookup i vs)"
    using assms
    apply (induction g ws vs arbitrary: i rule: binary.induct)
    apply (auto simp: is_strict_bin_op_impl_def is_bin_op_impl_def)
    done

  subsection \<open>Abstraction to Sets of Naturals\<close>

  definition "\<alpha> uv \<equiv> {n. lookup n uv}"

  lemma memb_correct: "lookup i ws \<longleftrightarrow> i\<in>\<alpha> ws"
    by (auto simp: \<alpha>_def)

  lemma empty_correct: "\<alpha> empty = {}"
    by (simp add: \<alpha>_def empty_def)

  lemma single_bit_correct: "\<alpha> (single_bit n) = {n}"
    by (simp add: \<alpha>_def)

  lemma insert_correct: "\<alpha> (set_bit i ws) = Set.insert i (\<alpha> ws)"
    by (auto simp add: \<alpha>_def)

  lemma delete_correct: "\<alpha> (reset_bit i ws) = (\<alpha> ws) - {i}"
    by (auto simp add: \<alpha>_def)

  lemma binary_correct:
    assumes "is_strict_bin_op_impl f g"
    shows "\<alpha> (binary g ws vs) = { i . f (i\<in>\<alpha> ws) (i\<in>\<alpha> vs) }"
    unfolding \<alpha>_def
    by (auto simp add: binary_lookup[OF assms])

  fun union :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list"
    where
    "union [] ws = ws"
  | "union vs [] = vs"
  | "union (v#vs) (w#ws) = (v OR w) # union vs ws"

  lemma union_lookup[simp]:
    fixes vs :: "'a::len word list"
    shows "lookup i (union vs ws) \<longleftrightarrow> lookup i vs \<or> lookup i ws"
    apply (induction vs ws arbitrary: i rule: union.induct)
    apply (auto simp: word_ao_nth)
    done

  lemma union_correct: "\<alpha> (union ws vs) = \<alpha> ws \<union> \<alpha> vs"
    by (auto simp add: \<alpha>_def)

  fun inter :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list"
    where
    "inter [] ws = []"
  | "inter vs [] = []"
  | "inter (v#vs) (w#ws) = (v AND w) # inter vs ws"

  lemma inter_lookup[simp]:
    fixes vs :: "'a::len word list"
    shows "lookup i (inter vs ws) \<longleftrightarrow> lookup i vs \<and> lookup i ws"
    apply (induction vs ws arbitrary: i rule: inter.induct)
    apply (auto simp: word_ao_nth)
    done

  lemma inter_correct: "\<alpha> (inter ws vs) = \<alpha> ws \<inter> \<alpha> vs"
    by (auto simp add: \<alpha>_def)

  fun diff :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> 'a::len word list"
    where
    "diff [] ws = []"
  | "diff vs [] = vs"
  | "diff (v#vs) (w#ws) = (v AND NOT w) # diff vs ws"

  lemma diff_lookup[simp]:
    fixes vs :: "'a::len word list"
    shows "lookup i (diff vs ws) \<longleftrightarrow> lookup i vs - lookup i ws"
    apply (induction vs ws arbitrary: i rule: diff.induct)
    apply (auto simp: word_ops_nth_size word_size)
    done

  lemma diff_correct: "\<alpha> (diff ws vs) = \<alpha> ws - \<alpha> vs"
    by (auto simp add: \<alpha>_def)

  fun zeroes :: "'a::len word list \<Rightarrow> bool" where
    "zeroes [] \<longleftrightarrow> True"
  | "zeroes (w#ws) \<longleftrightarrow> w=0 \<and> zeroes ws"

  lemma zeroes_lookup: "zeroes ws \<longleftrightarrow> (\<forall>i. \<not>lookup i ws)"
    apply (induction ws)
    apply (auto simp: word_eq_iff)
    by (metis diff_add_inverse2 not_add_less2)

  lemma isEmpty_correct: "zeroes ws \<longleftrightarrow> \<alpha> ws = {}"
    by (auto simp: zeroes_lookup \<alpha>_def)

  fun equal :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> bool" where
    "equal [] [] \<longleftrightarrow> True"
  | "equal [] ws \<longleftrightarrow> zeroes ws"
  | "equal vs [] \<longleftrightarrow> zeroes vs"
  | "equal (v#vs) (w#ws) \<longleftrightarrow> v=w \<and> equal vs ws"

  lemma equal_lookup:
    fixes vs ws :: "'a::len word list"
    shows "equal vs ws \<longleftrightarrow> (\<forall>i. lookup i vs = lookup i ws)"
  proof (induction vs ws rule: equal.induct)
    fix v w and vs ws :: "'a::len word list"
    assume IH: "equal vs ws = (\<forall>i. lookup i vs = lookup i ws)"
    show "equal (v # vs) (w # ws) = (\<forall>i. lookup i (v # vs) = lookup i (w # ws))"
    proof (rule iffI, rule allI)
      fix i
      assume "equal (v#vs) (w#ws)"
      thus "lookup i (v # vs) = lookup i (w # ws)"
        by (auto simp: IH)
    next
      assume "\<forall>i. lookup i (v # vs) = lookup i (w # ws)"
      thus "equal (v # vs) (w # ws)"
        apply (auto simp: word_eq_iff IH)
        apply metis
        apply metis
        apply (drule_tac x="i + LENGTH('a)" in spec)
        apply auto []
        apply (drule_tac x="i + LENGTH('a)" in spec)
        apply auto []
        done
    qed
  qed (auto simp: zeroes_lookup)

  lemma equal_correct: "equal vs ws \<longleftrightarrow> \<alpha> vs = \<alpha> ws"
    by (auto simp: \<alpha>_def equal_lookup)

  fun subseteq :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> bool" where
    "subseteq [] ws \<longleftrightarrow> True"
  | "subseteq vs [] \<longleftrightarrow> zeroes vs"
  | "subseteq (v#vs) (w#ws) \<longleftrightarrow> (v AND NOT w = 0) \<and> subseteq vs ws"

  lemma subseteq_lookup:
    fixes vs ws :: "'a::len word list"
    shows "subseteq vs ws \<longleftrightarrow> (\<forall>i. lookup i vs \<longrightarrow> lookup i ws)"
    apply (induction vs ws rule: subseteq.induct)
    apply simp
    apply (auto simp: zeroes_lookup) []
    apply (auto simp: word_ops_nth_size word_size word_eq_iff)
    by (metis diff_add_inverse2 not_add_less2)

  lemma subseteq_correct: "subseteq vs ws \<longleftrightarrow> \<alpha> vs \<subseteq> \<alpha> ws"
    by (auto simp: \<alpha>_def subseteq_lookup)

  fun subset :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> bool" where
    "subset [] ws \<longleftrightarrow> \<not>zeroes ws"
  | "subset vs [] \<longleftrightarrow> False"
  | "subset (v#vs) (w#ws) \<longleftrightarrow> (if v=w then subset vs ws else subseteq (v#vs) (w#ws))"

  lemma subset_lookup:
    fixes vs ws :: "'a::len word list"
    shows "subset vs ws \<longleftrightarrow> ((\<forall>i. lookup i vs \<longrightarrow> lookup i ws)
      \<and> (\<exists>i. \<not>lookup i vs \<and> lookup i ws))"
    apply (induction vs ws rule: subset.induct)
    apply (simp add: zeroes_lookup)
    apply (simp add: zeroes_lookup) []
    apply (simp add: subseteq_lookup)
    apply safe
    apply simp_all
    apply (auto simp: word_ops_nth_size word_size word_eq_iff)
    done

  lemma subset_correct: "subset vs ws \<longleftrightarrow> \<alpha> vs \<subset> \<alpha> ws"
    by (auto simp: \<alpha>_def subset_lookup)

  fun disjoint :: "'a::len word list \<Rightarrow> 'a::len word list \<Rightarrow> bool" where
    "disjoint [] ws \<longleftrightarrow> True"
  | "disjoint vs [] \<longleftrightarrow> True"
  | "disjoint (v#vs) (w#ws) \<longleftrightarrow> (v AND w = 0) \<and> disjoint vs ws"

  lemma disjoint_lookup:
    fixes vs ws :: "'a::len word list"
    shows "disjoint vs ws \<longleftrightarrow> (\<forall>i. \<not>(lookup i vs \<and> lookup i ws))"
    apply (induction vs ws rule: disjoint.induct)
    apply simp
    apply simp
    apply (auto simp: word_ops_nth_size word_size word_eq_iff)
    by (metis diff_add_inverse2 not_add_less2)

  lemma disjoint_correct: "disjoint vs ws \<longleftrightarrow> \<alpha> vs \<inter> \<alpha> ws = {}"
    by (auto simp: \<alpha>_def disjoint_lookup)

subsection \<open>Lifting to Uint\<close>
  type_synonym uint_vector = "uint list"

  lift_definition uv_\<alpha> :: "uint_vector \<Rightarrow> nat set" is \<alpha> .
  lift_definition uv_lookup :: "nat \<Rightarrow> uint_vector \<Rightarrow> bool" is lookup .
  lift_definition uv_empty :: "uint_vector" is empty .
  lift_definition uv_single_bit :: "nat \<Rightarrow> uint_vector" is single_bit .
  lift_definition uv_set_bit :: "nat \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is set_bit .
  lift_definition uv_reset_bit :: "nat \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is reset_bit .
  lift_definition uv_union :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is union .
  lift_definition uv_inter :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is inter .
  lift_definition uv_diff :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> uint_vector" is diff .
  lift_definition uv_zeroes :: "uint_vector \<Rightarrow> bool" is zeroes .
  lift_definition uv_equal :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> bool" is equal .
  lift_definition uv_subseteq :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> bool" is subseteq .
  lift_definition uv_subset :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> bool" is subset .
  lift_definition uv_disjoint :: "uint_vector \<Rightarrow> uint_vector \<Rightarrow> bool" is disjoint .

  lemmas uv_memb_correct = memb_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_empty_correct = empty_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_single_bit_correct = single_bit_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_insert_correct = insert_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_delete_correct = delete_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_union_correct = union_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_inter_correct = inter_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_diff_correct = diff_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_isEmpty_correct = isEmpty_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_equal_correct = equal_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_subseteq_correct = subseteq_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_subset_correct = subset_correct[where 'a=dflt_size, Transfer.transferred]
  lemmas uv_disjoint_correct = disjoint_correct[where 'a=dflt_size, Transfer.transferred]

  lemmas [where 'a=dflt_size, Transfer.transferred, code] =
    lookup.simps
    empty_def
    single_bit.simps
    set_bit.simps
    reset_bit.simps
    union.simps
    inter.simps
    diff.simps
    zeroes.simps
    equal.simps
    subseteq.simps
    subset.simps
    disjoint.simps

  hide_const (open) \<alpha> lookup empty single_bit set_bit reset_bit union inter diff zeroes
    equal subseteq subset disjoint

subsection \<open>Autoref Setup\<close>

  definition uv_set_rel_def_internal:
    "uv_set_rel Rk \<equiv>
      if Rk=nat_rel then br uv_\<alpha> (\<lambda>_. True) else {}"
  lemma uv_set_rel_def:
    "\<langle>nat_rel\<rangle>uv_set_rel \<equiv> br uv_\<alpha> (\<lambda>_. True)"
    unfolding uv_set_rel_def_internal relAPP_def by simp

  lemmas [autoref_rel_intf] = REL_INTFI[of "uv_set_rel" i_set]

  lemma uv_set_rel_sv[relator_props]: "single_valued (\<langle>nat_rel\<rangle>uv_set_rel)"
    unfolding uv_set_rel_def by auto

  lemma uv_autoref[autoref_rules,param]:
    "(uv_lookup,(\<in>)) \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_empty,{}) \<in> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_set_bit,insert) \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_reset_bit,op_set_delete) \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_union,(\<union>)) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_inter,(\<inter>)) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_diff,(-)) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel"
    "(uv_zeroes,op_set_isEmpty) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_equal,(=)) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_subseteq,(\<subseteq>)) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_subset,(\<subset>)) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    "(uv_disjoint,op_set_disjoint) \<in> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> \<langle>nat_rel\<rangle>uv_set_rel \<rightarrow> bool_rel"
    by (auto
      simp: uv_set_rel_def br_def
      simp: uv_memb_correct uv_empty_correct uv_insert_correct uv_delete_correct
      simp: uv_union_correct uv_inter_correct uv_diff_correct uv_isEmpty_correct
      simp: uv_equal_correct uv_subseteq_correct uv_subset_correct uv_disjoint_correct)

  export_code
    uv_lookup
    uv_empty
    uv_single_bit
    uv_set_bit
    uv_reset_bit
    uv_union
    uv_inter
    uv_diff
    uv_zeroes
    uv_equal
    uv_subseteq
    uv_subset
    uv_disjoint
  checking SML Scala Haskell? OCaml?

end


(*  Title:   AnalyticTestFunction.thy
    Authors: Filip Smola and Jacques D. Fleuriot, University of Edinburgh, 2019-2021
*)

theory AnalyticTestFunction
  imports HyperdualFunctionExtension "HOL-Decision_Procs.Approximation"
begin

subsection\<open>Analytic Test Function\<close>
text\<open>
  We investigate the analytic test function used by Fike and Alonso in their
  2011 paper~\<^cite>\<open>"fike_alonso-2011"\<close> as a relatively non-trivial example.
  The function is defined as: @{term "\<lambda>x. exp x / (sqrt (sin x ^ 3 + cos x ^ 3))"}.
\<close>
definition fa_test :: "real \<Rightarrow> real"
  where "fa_test x = exp x / (sqrt (sin x ^ 3 + cos x ^ 3))"

text\<open>
  We define the same composition of functions but using the relevant hyperdual versions.
  Note that we implicitly use the facts that hyperdual extensions of plus, times and inverse are the
  same operations on hyperduals.
\<close>
definition hyp_fa_test :: "real hyperdual \<Rightarrow> real hyperdual"
  where "hyp_fa_test x = ((*h* exp) x) / ((*h* sqrt) (((*h* sin) x) ^ 3 + ((*h* cos) x) ^ 3))"

text\<open>We prove lemmas useful to show when this function is well defined.\<close>
lemma sin_cube_plus_cos_cube:
  "sin x ^ 3 + cos x ^ 3 = 1/2 * (sin x + cos x) * (2 - sin (2 * x))"
  for x :: "'a::{real_normed_field,banach}"
proof -
  have "sin x ^ 3 + cos x ^ 3 = (sin x + cos x) * (cos x ^ 2 - cos x * sin x + sin x ^ 2)"
    by (smt (z3) add.commute combine_common_factor diff_add_cancel distrib_left
          mult.commute mult.left_commute power2_eq_square power3_eq_cube)
  also have "\<dots> = (sin x + cos x) * (1 - cos x * sin x)"
    by simp
  finally show ?thesis
    by (smt (z3) mult.commute mult.left_neutral mult_2 nonzero_mult_div_cancel_left
          right_diff_distrib' sin_add times_divide_eq_left zero_neq_numeral)
qed

lemma sin_cube_plus_cos_cube_gt_zero_iff:
  "(sin x ^ 3 + cos x ^ 3 > 0) = (sin x + cos x > 0)"
  for x ::real
  by (smt (verit, best) cos_zero power3_eq_cube power_zero_numeral sin_cube_plus_cos_cube
       sin_le_one sin_zero zero_less_mult_iff)

lemma sin_plus_cos_eq_45:
  "sin x + cos x = sqrt 2 * sin (x + pi/4)"
  apply (simp add: sin_add sin_45 cos_45 )
  by (simp add: field_simps)

lemma sin_cube_plus_cos_cube_gt_zero_iff':
  "(sin x ^ 3 + cos x ^ 3 > 0) = (sin (x + pi/4) > 0)"
  by (smt (verit, best) mult_pos_pos real_sqrt_gt_0_iff
      sin_cube_plus_cos_cube_gt_zero_iff sin_plus_cos_eq_45 zero_less_mult_pos)

lemma sin_less_zero_pi:
  "\<lbrakk>- pi < x; x < 0\<rbrakk> \<Longrightarrow> sin x < 0"
  by (metis add.inverse_inverse add.inverse_neutral neg_less_iff_less sin_gt_zero sin_minus)

lemma sin_45_positive_intervals:
  "(sin (x + pi/4) > 0) = (x \<in> (\<Union>n::int. {-pi/4 + 2*pi*n <..< 3*pi/4 + 2*pi*n}))"
proof (standard ; (elim UnionE rangeE | -))
  obtain y :: real and n :: int
    where "x = y + 2*pi*n" and "- pi \<le> y" and "y \<le> pi"
    using sincos_principal_value sin_cos_eq_iff less_eq_real_def by metis
  note yn = this

  assume "0 < sin (x + pi / 4)"
  then have a: "0 < sin (y + pi / 4)"
    using yn by (metis sin_add sin_cos_eq_iff)
  then have "y \<in> {- pi / 4<..<3 * pi / 4}"
  proof (unfold greaterThanLessThan_iff, safe)
    show "- pi / 4 < y"
    proof (rule ccontr)
      assume "\<not> - pi / 4 < y"
      then have "y < - pi / 4 \<or> y = - pi / 4"
        by (simp add: not_less le_less)
      then show False
        using a sin_less_zero_pi[where x = "y + pi/4"] yn sin_zero
        by force
    qed
    show "y < 3 * pi / 4"
    proof (rule ccontr)
      assume "\<not> y < 3 * pi / 4"
      then have "pi \<le> y + pi/4"
        by (simp add: not_less)
      then show False
        using a sin_le_zero yn pi_ge_two by fastforce
    qed
  qed
  then have "x \<in> {- pi / 4 + 2*pi*n<..<3 * pi / 4 + 2*pi*n}"
    using yn greaterThanLessThan_iff by simp
  then show "x \<in> (\<Union>n::int. {- pi / 4 + 2*pi*n<..<3 * pi / 4 + 2*pi*n})"
    by blast
next
  fix X and n :: int
  assume "x \<in> X"
     and "X = {- pi / 4 + 2*pi*n<..<3 * pi / 4 + 2*pi*n}"
  then have "x \<in> {- pi / 4 + 2*pi*n<..<3 * pi / 4 + 2*pi*n}"
    by simp
  then obtain y :: real and n :: int
    where "x = y + 2*pi*n" and "- pi / 4 < y" and "y < 3 * pi / 4"
    by (smt (z3) greaterThanLessThan_iff)
  note yn = this

  have "0 < sin (y + pi / 4)"
    using sin_gt_zero yn by force
  then show "0 < sin (x + pi / 4)"
    using yn sin_cos_eq_iff[of "x + pi / 4" "y + pi / 4"] by simp
qed

text\<open>When the function is well defined our hyperdual definition is equal to the hyperdual extension.\<close>
lemma hypext_fa_test:
  assumes "Base x \<in> (\<Union>n::int. {-pi/4 + 2*pi*n <..< 3*pi/4 + 2*pi*n})"
  shows "(*h* fa_test) x = hyp_fa_test x"
proof -
  have inverse_sqrt_valid: "0 < sin (Base x) ^ 3 + cos (Base x) ^ 3"
    using assms sin_45_positive_intervals sin_cube_plus_cos_cube_gt_zero_iff' by force

  have "\<And>f. (\<lambda>x. (sin x) ^ 3) twice_field_differentiable_at Base x"
   and "\<And>f. (\<lambda>x. (cos x) ^ 3) twice_field_differentiable_at Base x"
    by (simp_all add: twice_field_differentiable_at_compose[OF _ twice_field_differentiable_at_power])
  then have "(*h* (\<lambda>x. sin x ^ 3 + cos x ^ 3)) x = (*h* sin) x ^ 3 + (*h* cos) x ^ 3"
        and d_sincos: "(\<lambda>x. sin x ^ 3 + cos x ^ 3) twice_field_differentiable_at Base x"
    using hypext_fun_add[of "\<lambda>x. sin x ^ 3" x "\<lambda>x. cos x ^ 3"]
    by (simp_all add: hypext_fun_power twice_field_differentiable_at_add)
  then have "(*h* (\<lambda>x. sqrt (sin x ^ 3 + cos x ^ 3))) x = (*h* sqrt) ((*h* sin) x ^ 3 + (*h* cos) x ^ 3)"
    using inverse_sqrt_valid hypext_compose[of "\<lambda>x. sin x ^ 3 + cos x ^ 3" x] by simp
  moreover have d_sqrt: "(\<lambda>x. sqrt (sin x ^ 3 + cos x ^ 3)) twice_field_differentiable_at Base x"
    using inverse_sqrt_valid d_sincos twice_field_differentiable_at_compose twice_field_differentiable_at_sqrt
    by blast
  ultimately have "(*h* (\<lambda>x. inverse (sqrt (sin x ^ 3 + cos x ^ 3)))) x = inverse ((*h* sqrt) ((*h* sin) x ^ 3 + (*h* cos) x ^ 3))"
    using inverse_sqrt_valid hypext_fun_inverse[of "\<lambda>x. sqrt (sin x ^ 3 + cos x ^ 3)" x]
    by simp
  moreover have "(\<lambda>x. inverse (sqrt (sin x ^ 3 + cos x ^ 3))) twice_field_differentiable_at Base x"
    using inverse_sqrt_valid d_sqrt real_sqrt_eq_zero_cancel_iff
          twice_field_differentiable_at_compose twice_field_differentiable_at_inverse
          less_numeral_extra(3)
    by force
  ultimately have
    "(*h* (\<lambda>x. exp x * inverse (sqrt (sin x ^ 3 + cos x ^ 3)))) x =
     (*h* exp) x * inverse ((*h* sqrt) ((*h* sin) x ^ 3 + (*h* cos) x ^ 3))"
    by (simp add: hypext_fun_mult)
  then have
    "(*h* (\<lambda>x. exp x / sqrt (sin x ^ 3 + cos x ^ 3))) x =
     (*h* exp) x / (*h* sqrt) ((*h* sin) x ^ 3 + (*h* cos) x ^ 3)"
    by (simp add: inverse_eq_divide hyp_divide_inverse)
  then show ?thesis
    unfolding fa_test_def hyp_fa_test_def .
qed

text\<open>
  We can show that our hyperdual extension gives (approximately) the same values as those found by
  Fike and Alonso when evaluated at @{term "1.5"}.
\<close>
lemma
  assumes "x = hyp_fa_test (\<beta> 1.5)"
  shows "\<bar>Base x - 4.4978\<bar> \<le> 0.00005"
    and "\<bar>Eps1 x - 4.0534\<bar> \<le> 0.00005"
    and "\<bar>Eps12 x - 9.4631\<bar> \<le> 0.00005"
proof -
  show "\<bar>Base x - 4.4978\<bar> \<le> 0.00005"
    by (simp add: assms hyp_fa_test_def, approximation 20)
  have d: "0 < sin (3/2 :: real) ^ 3 + cos (3/2 :: real) ^ 3"
    using sin_cube_plus_cos_cube_gt_zero_iff' sin_gt_zero pos_add_strict pi_gt3 by force
  show "\<bar>Eps1 x - 4.0534\<bar> \<le> 0.00005"
    by (simp add: assms hyp_fa_test_def d, approximation 22)
  show "\<bar>Eps12 x - 9.4631\<bar> \<le> 0.00005"
    by (simp add: assms hyp_fa_test_def d, approximation 24)
qed

text\<open>A number of additional lemmas that will be required to prove the derivatives:\<close>
lemma hypext_sqrt_hyperdual_parts:
      "a > 0 \<Longrightarrow>  (*h* sqrt) (a *\<^sub>H ba + b *\<^sub>H e1 + c *\<^sub>H e2 + d *\<^sub>H e12) =
       sqrt a *\<^sub>H ba + (b * inverse (sqrt a) / 2) *\<^sub>H e1 + (c * inverse (sqrt a) / 2) *\<^sub>H e2 +
       (d * inverse (sqrt a) / 2 - b * c * inverse (sqrt a ^ 3) / 4) *\<^sub>H e12"
  by (metis Hyperdual_eq hypext_sqrt_Hyperdual)

lemma cos_multiple: "cos (n * x) = 2 * cos x * cos ((n - 1) * x) - cos ((n - 2) * x)"
  for x :: "'a :: {banach,real_normed_field}"
proof -
  have "cos ((n - 1) * x + x) + cos ((n - 1) * x - x) = 2 * cos ((n - 1) * x) * cos x"
    by (simp add: cos_add cos_diff)
  then show ?thesis
    by (simp add: left_diff_distrib' eq_diff_eq)
qed

lemma sin_multiple: "sin (n * x) = 2 * cos x * sin ((n - 1) * x) - sin ((n - 2) * x)"
  for x :: "'a :: {banach,real_normed_field}"
proof -
  have "sin ((n - 1) * x + x) + sin ((n - 1) * x - x) = 2 * cos x * sin ((n - 1) * x)"
    by (simp add: sin_add sin_diff)
  then show ?thesis
    by (simp add: left_diff_distrib' eq_diff_eq)
qed

lemma power5:
  fixes z :: "'a :: monoid_mult"
  shows "z ^ 5 = z * z * z * z * z"
  by (simp add: mult.assoc power2_eq_square power_numeral_odd)

lemma power6:
  fixes z :: "'a :: monoid_mult"
  shows "z ^ 6 = z * z * z * z * z * z"
  by (simp add: mult.assoc power3_eq_cube power_numeral_even)

text\<open>
  We find the derivatives of @{const fa_test} by applying a Wengert list approach, as done by Fike
  and Alonso, to make the same composition but in hyperduals.
  We know that this is equal to the hyperdual extension which in turn gives us the derivatives.
\<close>
lemma Wengert_autodiff_fa_test:
  assumes "x \<in> (\<Union>n::int. {-pi/4 + 2*pi*n <..< 3*pi/4 + 2*pi*n})"
  shows "First (autodiff fa_test x) =
    (exp x * (3 * cos x + 5 * cos (3 * x) + 9 * sin x + sin (3 * x))) /
        (8 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 3)"
    and "Second (autodiff fa_test x) =
    (exp x * (130 - 12 * cos (2 * x) +
              30 * cos (4 * x) + 12 * cos (6 * x) -
              111 * sin (2 * x) +
              48 * sin (4 * x) + 5 * sin (6 * x))) /
                (64 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 5)"
proof -
  have s3_c3_gt_zero: "(sin x) ^ 3 + (cos x) ^ 3 > 0"
    using assms sin_45_positive_intervals sin_cube_plus_cos_cube_gt_zero_iff' sin_gt_zero
    by force
   \<comment> \<open>Work out @{const hyp_fa_test} as Wengert list of basic operations\<close>
  let ?w0 = "\<beta> x"
  have w0: "?w0 = x *\<^sub>H ba + 1 *\<^sub>H e1 + 1 *\<^sub>H e2 + 0 *\<^sub>H e12"
    by (simp add: Hyperdual_eq hyperdualx_def)

  let ?w1 = "(*h* exp) ?w0"
  have w1: "?w1 = exp x *\<^sub>H ba + exp x *\<^sub>H e1 + exp x *\<^sub>H e2 + exp x *\<^sub>H e12"
    using hypext_exp_extract by blast

  let ?w2 = "(*h* sin) ?w0"
  have w2: "?w2 = sin x *\<^sub>H ba + cos x *\<^sub>H e1 + cos x *\<^sub>H e2 + - sin x *\<^sub>H e12"
    by (simp add: hypext_sin_extract of_comp_minus scaleH_times)

  let ?w3 = "(*h* (\<lambda>x. x ^ 3)) ?w2"
  have w3: "?w3 = (sin x) ^ 3 *\<^sub>H ba + (3 * cos x * (sin x)\<^sup>2) *\<^sub>H e1 + (3 * cos x * (sin x)\<^sup>2) *\<^sub>H e2 + - (3/4 * (sin x - 3 * sin (3 * x))) *\<^sub>H e12"
    by (simp add: w2 hypext_power_Hyperdual_parts power2_eq_square cos_times_cos sin_times_sin
          sin_times_cos distrib_left right_diff_distrib' divide_simps)

  let ?w4 = "(*h* cos) ?w0"
  have w4: "?w4 = cos x *\<^sub>H ba + - sin x *\<^sub>H e1 + - sin x *\<^sub>H e2 + - cos x *\<^sub>H e12"
    by (simp add: hypext_cos_extract of_comp_minus scaleH_times)

  let ?w5 = "(*h* (\<lambda>x. x ^ 3)) ?w4"
  have w5: "?w5 = (cos x) ^ 3 *\<^sub>H ba + - (3 * sin x * (cos x)\<^sup>2) *\<^sub>H e1 + - (3 * sin x * (cos x)\<^sup>2) *\<^sub>H e2 + - (3/4 * (cos x + 3 * cos (3 * x))) *\<^sub>H e12"
    by (simp add: w4 hypext_power_Hyperdual_parts sin_times_sin right_diff_distrib' cos_times_cos
              power2_eq_square distrib_left sin_times_cos divide_simps)

  let ?w6 = "?w3 + ?w5"
  have sqrt_pos: "Base ?w6 > 0"
      using s3_c3_gt_zero by auto
  have w6: "?w6 = (sin x ^ 3 + cos x ^ 3) *\<^sub>H ba +
                  (3 * cos x * sin x * (sin x - cos x)) *\<^sub>H e1 +
                  (3 * cos x * sin x * (sin x - cos x)) *\<^sub>H e2 +
                  - (3/4 * (sin x + cos x + 3 * cos (3 * x) - 3 * sin (3 * x))) *\<^sub>H e12"
    by (auto simp add: w3 w5 add_hyperdual_parts power2_eq_square right_diff_distrib' divide_simps)

  let ?w7 = "inverse ((*h* sqrt) ?w6)"
  have w7: "?w7 = inverse(sqrt(sin x ^ 3 + cos x ^ 3)) *\<^sub>H ba +
                  - ((3 * cos x * sin x * (sin x - cos x))/(2 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 3)) *\<^sub>H e1 +
                  - ((3 * cos x * sin x * (sin x - cos x))/(2 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 3)) *\<^sub>H e2 +
                  ((3 * (30 + 2 * cos (4 * x) - 41 * sin (2 * x) + 3 * sin (6 * x)))/(64 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 5)) *\<^sub>H e12"
    \<comment> \<open>Apply the functions in two steps, then simplify the result to match\<close>
  proof -
    let ?w7a = "(*h* sqrt) ?w6"
    have w7a: "?w7a =
      sqrt (sin x ^ 3 + cos x ^ 3) *\<^sub>H ba +
      ((3 * (cos x * (sin x * (sin x - cos x)))) * inverse (sqrt (sin x ^ 3 + cos x ^ 3)) / 2) *\<^sub>H e1 +
      ((3 * (cos x * (sin x * (sin x - cos x)))) * inverse (sqrt (sin x ^ 3 + cos x ^ 3)) / 2) *\<^sub>H e2 +
      (- ((3 * sin x + 3 * cos x + 9 * cos (3 * x) - 9 * sin (3 * x)) * inverse (sqrt (sin x ^ 3 + cos x ^ 3)) / 8) +
       - 9 * (cos x * (sin x * ((sin x - cos x) * (cos x * (sin x * (sin x - cos x)))))) * inverse (sqrt (sin x ^ 3 + cos x ^ 3) ^ 3) / 4) *\<^sub>H e12"
      unfolding w6
      using sqrt_pos by (simp add: hypext_sqrt_hyperdual_parts mult.assoc)

    let ?w7b = "inverse ?w7a"
    have "?w7b =
      (1 / sqrt (sin x ^ 3 + cos x ^ 3)) *\<^sub>H ba +
      - (3 * (cos x * (sin x * (sin x - cos x))) * inverse (sqrt (sin x ^ 3 + cos x ^ 3)) / (2 * (sqrt (sin x ^ 3 + cos x ^ 3))\<^sup>2)) *\<^sub>H e1 +
      - (3 * (cos x * (sin x * (sin x - cos x))) * inverse (sqrt (sin x ^ 3 + cos x ^ 3)) / (2 * (sqrt (sin x ^ 3 + cos x ^ 3))\<^sup>2)) *\<^sub>H e2 +
      (9 * (cos x * (cos x * (sin x * (sin x * ((sin x - cos x) * ((sin x - cos x) * (inverse (sqrt (sin x ^ 3 + cos x ^ 3)) * inverse (sqrt (sin x ^ 3 + cos x ^ 3))))))))) / (2 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 3) -
        (- ((3 * sin x + 3 * cos x + 9 * cos (3 * x) - 9 * sin (3 * x)) * inverse (sqrt (sin x ^ 3 + cos x ^ 3)) / 8) -
        9 * (cos x * (sin x * ((sin x - cos x) * (cos x * (sin x * (sin x - cos x)))))) * inverse (sqrt (sin x ^ 3 + cos x ^ 3) ^ 3) / 4) /
     (sqrt (sin x ^ 3 + cos x ^ 3))\<^sup>2) *\<^sub>H e12"
      \<comment> \<open>Push the inverse in\<close>
      by (simp add: w7a inverse_hyperdual_parts)
    then have w7b: "?w7b =
      (inverse (sqrt (sin x ^ 3 + cos x ^ 3))) *\<^sub>H ba +
      - (3 * cos x * sin x * (sin x - cos x) / (2 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 3)) *\<^sub>H e1 +
      - (3 * cos x * sin x * (sin x - cos x) / (2 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 3)) *\<^sub>H e2 +
      (9 * cos x * cos x * sin x * sin x * ((sin x - cos x) * (sin x - cos x) / ((sqrt (sin x ^ 3 + cos x ^ 3)) ^ 2)) / (2 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 3) -
        (- ((3 * sin x + 3 * cos x + 9 * cos (3 * x) - 9 * sin (3 * x)) / (8 * sqrt (sin x ^ 3 + cos x ^ 3))) -
         9 * cos x * sin x * (sin x - cos x) * cos x * sin x * (sin x - cos x) / (4 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 3))
        / (sqrt (sin x ^ 3 + cos x ^ 3))\<^sup>2) *\<^sub>H e12"
      \<comment> \<open>Simplify powers and parents\<close>
      by (simp add: power2_eq_square power3_eq_cube field_simps)

    have
      "9 * cos x * cos x * sin x * sin x * ((sin x - cos x) * (sin x - cos x)) / ((sqrt (sin x ^ 3 + cos x ^ 3))\<^sup>2 * (2 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 3)) -
       (- ((3 * sin x + 3 * cos x + 9 * cos (3 * x) - 9 * sin (3 * x)) / (8 * sqrt (sin x ^ 3 + cos x ^ 3))) -
          9 * cos x * sin x * (sin x - cos x) * cos x * sin x * (sin x - cos x) / (4 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 3)) /
       (sqrt (sin x ^ 3 + cos x ^ 3))\<^sup>2 =
       (90 + 6 * cos (4 * x) - 123 * sin (2 * x) + 9 * sin (6 * x)) / (64 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 5)"
      \<comment> \<open>Equate the last component's coefficients\<close>
    proof -
      have
        "9 * cos x * cos x * sin x * sin x * ((sin x - cos x) * (sin x - cos x)) / ((sqrt (sin x ^ 3 + cos x ^ 3))\<^sup>2 * (2 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 3)) -
         (- ((3 * sin x + 3 * cos x + 9 * cos (3 * x) - 9 * sin (3 * x)) / (8 * sqrt (sin x ^ 3 + cos x ^ 3))) -
           9 * cos x * sin x * (sin x - cos x) * cos x * sin x * (sin x - cos x) / (4 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 3)) /
         (sqrt (sin x ^ 3 + cos x ^ 3))\<^sup>2 =
         9 * cos x * cos x * sin x * sin x * (sin x - cos x) * (sin x - cos x) / (2 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 5) +
         ( (3 * sin x + 3 * cos x + 9 * cos (3 * x) - 9 * sin (3 * x)) / (8 * sqrt (sin x ^ 3 + cos x ^ 3)) +
           9 * cos x * sin x * (sin x - cos x) * cos x * sin x * (sin x - cos x) / (4 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 3)) /
         (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 2"
          by (simp add: divide_simps)
      also have "... =
         9 * cos x * cos x * sin x * sin x * (sin x - cos x) * (sin x - cos x) / (2 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 5) +
         ( (3 * sin x + 3 * cos x + 9 * cos (3 * x) - 9 * sin (3 * x)) / (8 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 3) +
           9 * cos x * sin x * (sin x - cos x) * cos x * sin x * (sin x - cos x) / (4 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 3 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 2))"
        by (simp add: add_divide_distrib power2_eq_square power3_eq_cube mult.commute mult.left_commute)
      also have "... =
         9 * cos x * cos x * sin x * sin x * (sin x - cos x) * (sin x - cos x) / (2 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 5) +
         ( (3 * sin x + 3 * cos x + 9 * cos (3 * x) - 9 * sin (3 * x)) / (8 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 3) +
           9 * cos x * sin x * (sin x - cos x) * cos x * sin x * (sin x - cos x) / (4 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 5))"
        by (simp add: mult.commute mult.left_commute)
      also have "... =
         9 * cos x * cos x * sin x * sin x * (sin x - cos x) * (sin x - cos x) / (2 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 5) +
         ( (3 * sin x + 3 * cos x + 9 * cos (3 * x) - 9 * sin (3 * x)) * (sin x ^ 3 + cos x ^ 3) / (8 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 5) +
           9 * cos x * sin x * (sin x - cos x) * cos x * sin x * (sin x - cos x) / (4 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 5))"
      proof -
        have "(sin x ^ 3 + cos x ^ 3) * inverse ((sqrt (sin x ^ 3 + cos x ^ 3)) ^ 2) = 1"
          using s3_c3_gt_zero by auto
        then have
          "1 / (8 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 3) =
           (sin x ^ 3 + cos x ^ 3) / ((sqrt (sin x ^ 3 + cos x ^ 3)) ^ 2) / (8 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 3)"
          by (simp add: field_simps)
        then have
          "1 / (8 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 3) =
           (sin x ^ 3 + cos x ^ 3) / (8 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 5)"
          by auto
        then show ?thesis
          by (metis (mono_tags, lifting) divide_real_def inverse_eq_divide times_divide_eq_right)
      qed
      also have "... =
         ( 288 * cos x * cos x * sin x * sin x * (sin x - cos x) * (sin x - cos x) +
           (3 * sin x + 3 * cos x + 9 * cos (3 * x) - 9 * sin (3 * x)) * (sin x ^ 3 + cos x ^ 3) * 8 +
           144 * cos x * sin x * (sin x - cos x) * cos x * sin x * (sin x - cos x))
         / (64 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 5)"
        by (simp add: divide_simps)
      also have "... =
         ( 432 * cos x * cos x * sin x * sin x * (sin x - cos x) * (sin x - cos x) +
           (24 * sin x + 24 * cos x + 72 * cos (3 * x) - 72 * sin (3 * x)) * (sin x ^ 3 + cos x ^ 3))
         / (64 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 5)"
        by (simp add: divide_simps)
      finally show ?thesis
        \<comment> \<open>Having matched the denominators, prove the numerators equal\<close>
        by (simp, force intro:  disjI2 simp add: power2_eq_square power4_eq_xxxx power3_eq_cube cos_times_sin
            sin_times_cos cos_times_cos sin_times_sin right_diff_distrib power6 power5
            distrib_left distrib_right left_diff_distrib divide_simps)
    qed
    then show ?thesis
      \<comment> \<open>Put it all together\<close>
      by (simp add: w7b)
  qed

  let ?w8 = "?w1 * ?w7"
  have w8: "?w8 =
    ((exp x)/(sqrt(sin x ^ 3 + cos x ^ 3))) *\<^sub>H ba +
    ((exp x * (3 * cos x + 5 * cos (3 * x) + 9 * sin x + sin (3 * x)))/(8 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 3)) *\<^sub>H e1 +
    ((exp x * (3 * cos x + 5 * cos (3 * x) + 9 * sin x + sin (3 * x)))/(8 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 3)) *\<^sub>H e2 +
    ((exp x * (130 - 12 * cos (2 * x) + 30 * cos (4 * x) + 12 * cos (6 * x) - 111 * sin (2 * x) + 48 * sin (4 * x) +
               5 * sin (6 * x)))/(64 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 5)) *\<^sub>H e12"
  proof (auto simp add: w7 w1 times_hyperdual_parts)
    show "exp x * inverse (sqrt (sin x ^ 3 + cos x ^ 3)) = exp x / sqrt (sin x ^ 3 + cos x ^ 3)"
      by (simp add: divide_inverse)

    have sqrt_sc3: "sqrt (sin x ^ 3 + cos x ^ 3) ^ 3 = (sin x ^ 3 + cos x ^ 3) * sqrt (sin x ^ 3 + cos x ^ 3)"
      using s3_c3_gt_zero
      by (simp add: power3_eq_cube)
    then have "inverse (sqrt (sin x ^ 3 + cos x ^ 3)) -
          (3 * cos x * sin x * (sin x - cos x)) / (2 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 3) =
          (3 * cos x + 5 * cos (3 * x) + 9 * sin x + sin (3 * x)) / (8 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 3)"
      using sqrt_pos
      apply (simp add: right_diff_distrib' sin_times_sin cos_times_cos sin_times_cos cos_times_sin power3_eq_cube left_diff_distrib' divide_simps)
      by (simp add: distrib_right cos_times_cos)
    then show " exp x * inverse (sqrt (sin x ^ 3 + cos x ^ 3)) -
           exp x * (3 * cos x * sin x * (sin x - cos x)) / (2 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 3) =
          exp x * (3 * cos x + 5 * cos (3 * x) + 9 * sin x + sin (3 * x)) / (8 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 3)"
      by (simp add: algebra_simps)

    have "sqrt (sin x ^ 3 + cos x ^ 3) ^ 8 =  (sin x ^ 3 + cos x ^ 3) ^ 4"
      using s3_c3_gt_zero
      by (smt mult_2 numeral_Bit0 power2_eq_square power_even_eq real_sqrt_mult_self)
    moreover have "sqrt (sin x ^ 3 + cos x ^ 3) ^ 5 =  (sin x ^ 3 + cos x ^ 3) ^ 2 * sqrt (sin x ^ 3 + cos x ^ 3)"
      by (simp add: mult.assoc power2_eq_square power5)
    ultimately
    have "(90 + 6 * cos (4 * x) - 123 * sin (2 * x) + 9 * sin (6 * x)) / (64 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 5) -
           3 * (cos x * ((sin x * (sin x - cos x)))) / sqrt (sin x ^ 3 + cos x ^ 3) ^ 3 +
           inverse (sqrt (sin x ^ 3 + cos x ^ 3)) =
           (130 - 12 * cos (2 * x) + 30 * cos (4 * x) + 12 * cos (6 * x) - 111 * sin (2 * x) + 48 * sin (4 * x) + 5 * sin (6 * x)) /
           (64 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 5)"
      using sqrt_pos
      apply (simp add: sqrt_sc3 power2_eq_square divide_simps)
      by (simp add: distrib_right distrib_left power3_eq_cube sin_times_sin sin_times_cos
              cos_times_cos cos_times_sin right_diff_distrib' left_diff_distrib' divide_simps)
    moreover have "\<forall>r a b c. (a::real) * b - c * (a * r) = a * (b - c * r)"
      by (simp add: right_diff_distrib)
    ultimately show "exp x * (90 + 6 * cos (4 * x) - 123 * sin (2 * x) + 9 * sin (6 * x)) / (64 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 5) -
               3 * (cos x * (exp x * (sin x * (sin x - cos x)))) / sqrt (sin x ^ 3 + cos x ^ 3) ^ 3 +
              exp x * inverse (sqrt (sin x ^ 3 + cos x ^ 3)) =
              exp x *
              (130 - 12 * cos (2 * x) + 30 * cos (4 * x) + 12 * cos (6 * x) - 111 * sin (2 * x) + 48 * sin (4 * x) + 5 * sin (6 * x)) /
              (64 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 5)"
      by (metis (mono_tags, opaque_lifting) distrib_left mult.left_commute times_divide_eq_right)
  qed

  \<comment> \<open>Check that we have indeed computed the hyperdual extension of our analytic test function \<close>
  moreover have w8_eq_hyp_fa_test: "?w8 = (*h* fa_test) (\<beta> x)"
    using assms
    by (simp add: hyp_divide_inverse hyp_fa_test_def hypext_fa_test hypext_power)

  \<comment> \<open>Now simply show that "extraction" of first and second derivatives are as expected\<close>
  ultimately
  show "First (autodiff fa_test x) =
          (exp x * (3 * cos x + 5 * cos (3 * x) + 9 * sin x + sin (3 * x))) /
            (8 * (sqrt (sin x ^ 3 + cos x ^ 3)) ^ 3)"
  and
    "Second (autodiff fa_test x) =
        exp x * (130 - 12 * cos (2 * x) +
                  30 * cos (4 * x) + 12 * cos (6 * x) -
                   111 * sin (2 * x) + 48 * sin (4 * x) + 5 * sin (6 * x)) /
       (64 * sqrt (sin x ^ 3 + cos x ^ 3) ^ 5)"
    by (metis autodiff_sel hyperdual_comb_sel)+
qed

end