section \<open>Backwards Reachability Analysis\<close>

text \<open>This theory introduces function @{text "select_inputs"} which is used for the calculation of
      both state preambles and state separators.\<close>

theory Backwards_Reachability_Analysis
imports "../FSM"
begin

text \<open>Function @{text "select_inputs"} calculates an associative list that maps states to a single
      input each such that the FSM induced by this input selection is acyclic, single input and
      whose only deadlock states (if any) are contained in @{text "stateSet"}.
      The following parameters are used:
        1) transition function @{text "f"} (typically @{text "(h M)"} for some FSM @{text "M"})
        2) a source state @{text "q0"} (selection terminates as soon as this states is assigned some input)
        3) a list of inputs that may be assigned to states
        4) a list of states not yet taken (these are considered when searching for the next possible
          assignment)
        5) a set @{text "stateSet"} of all states that already have an input assigned to them by @{text "m"}
        6) an associative list @{text "m"} containing previously chosen assignments\<close>

function select_inputs :: "(('a \<times> 'b) \<Rightarrow> ('c \<times> 'a) set) \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> 'a list \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list" where
  "select_inputs f q0 inputList [] stateSet m = (case find (\<lambda> x . f (q0,x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q0,x) . (q'' \<in> stateSet))) inputList of
      Some x \<Rightarrow> m@[(q0,x)] |
      None   \<Rightarrow> m)" |
  "select_inputs f q0 inputList (n#nL) stateSet m =
    (case find (\<lambda> x . f (q0,x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q0,x) . (q'' \<in> stateSet))) inputList of
      Some x \<Rightarrow> m@[(q0,x)] |
      None   \<Rightarrow> (case find_remove_2 (\<lambda> q' x . f (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q',x) . (q'' \<in> stateSet))) (n#nL) inputList
          of None            \<Rightarrow> m |
             Some (q',x,stateList') \<Rightarrow> select_inputs f q0 inputList stateList' (insert q' stateSet) (m@[(q',x)])))"
  by pat_completeness auto
termination
proof -
  {
    fix f :: "(('a \<times> 'b) \<Rightarrow> ('c \<times> 'a) set)"
    fix q0 :: 'a
    fix inputList :: "'b list"
    fix n :: 'a
    fix nL :: "'a list"
    fix stateSet :: "'a set"
    fix m :: "('a \<times> 'b) list"
    fix qynL' q ynL' x nL'
    assume "find (\<lambda>x. f (q0, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q0, x). q'' \<in> stateSet)) inputList = None"
       and "find_remove_2 (\<lambda>q' x. f (q', x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q', x). q'' \<in> stateSet)) (n # nL) inputList = Some qynL'"
       and "(q, ynL') = qynL'"
       and "(x, nL') = ynL'"

    then have *: "find_remove_2 (\<lambda>q' x. f (q', x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q', x). q'' \<in> stateSet)) (n # nL) inputList = Some (q,x,nL')"
      by auto

    have "q \<in> set (n # nL)"
    and  "nL' = remove1 q (n # nL)"
      using find_remove_2_set(2,6)[OF *] by simp+

    then have "length nL' < length (n # nL)"
      using remove1_length by metis

    then have "((f, q0, inputList, nL', insert q stateSet, m @ [(q, x)]), f, q0, inputList, n # nL, stateSet, m)
                \<in> measure (\<lambda>(f, q0, iL, nL, nS, m). length nL)"
      by auto
  }
  then show ?thesis
    by (relation "measure (\<lambda> (f,q0,iL,nL,nS,m) . length nL)"; simp)
qed

lemma select_inputs_length :
  "length (select_inputs f q0 inputList stateList stateSet m) \<le> (length m) + Suc (length stateList)"
proof (induction "length stateList" arbitrary: stateList stateSet m)
  case 0
  then show ?case
    by (cases "find (\<lambda>x. f (q0, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q0, x). q'' \<in> stateSet)) inputList"; auto)
next
  case (Suc k)
  then obtain n nL where "stateList = n # nL"
    by (meson Suc_length_conv)

  show ?case
  proof (cases "find (\<lambda> x . f (q0,x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q0,x) . (q'' \<in> stateSet))) inputList")
    case None
    then show ?thesis
    proof (cases "find_remove_2 (\<lambda> q' x . f (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q',x) . (q'' \<in> stateSet))) stateList inputList")
      case None
      then show ?thesis
        using \<open>find (\<lambda>x. f (q0, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q0, x). q'' \<in> stateSet)) inputList = None\<close>
        unfolding \<open>stateList = n # nL\<close> by auto
    next
      case (Some a)
      then obtain q' x stateList' where *: "find_remove_2 (\<lambda> q' x . f (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q',x) . (q'' \<in> stateSet))) (n#nL) inputList
                                            = Some (q',x,stateList')"
        unfolding \<open>stateList = n # nL\<close> by (metis prod_cases3)
      have "k = length stateList'"
        using find_remove_2_length[OF *] \<open>Suc k = length stateList\<close>
        unfolding \<open>stateList = n # nL\<close>
        by simp
      show ?thesis
        using Suc.hyps(1)[of stateList' "insert q' stateSet" "m@[(q',x)]", OF \<open>k = length stateList'\<close>]
        unfolding \<open>stateList = n # nL\<close> select_inputs.simps None * find_remove_2_length[OF *]
        by simp
    qed
  next
    case (Some a)
    then show ?thesis
      unfolding \<open>stateList = n # nL\<close> by auto
  qed
qed

lemma select_inputs_length_min :
  "length (select_inputs f q0 inputList stateList stateSet m) \<ge> (length m)"
proof (induction "length stateList" arbitrary: stateList stateSet m)
  case 0
  then show ?case
    by (cases "find (\<lambda>x. f (q0, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q0, x). q'' \<in> stateSet)) inputList"; auto)
next
  case (Suc k)
  then obtain n nL where "stateList = n # nL"
    by (meson Suc_length_conv)

  show ?case
  proof (cases "find (\<lambda> x . f (q0,x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q0,x) . (q'' \<in> stateSet))) inputList")
    case None
    then show ?thesis
    proof (cases "find_remove_2 (\<lambda> q' x . f (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q',x) . (q'' \<in> stateSet))) stateList inputList")
      case None
      then show ?thesis using \<open>find (\<lambda>x. f (q0, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q0, x). q'' \<in> stateSet)) inputList = None\<close>
        unfolding \<open>stateList = n # nL\<close> by auto
    next
      case (Some a)
      then obtain q' x stateList' where *: "find_remove_2 (\<lambda> q' x . f (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q',x) . (q'' \<in> stateSet))) (n#nL) inputList
                                              = Some (q',x,stateList')"
        unfolding \<open>stateList = n # nL\<close> by (metis prod_cases3)
      have "k = length stateList'"
        using find_remove_2_length[OF *] \<open>Suc k = length stateList\<close>
        unfolding \<open>stateList = n # nL\<close>
        by simp
      show ?thesis
        unfolding \<open>stateList = n # nL\<close> select_inputs.simps None * find_remove_2_length[OF *]
        using Suc.hyps(1)[of stateList' "m@[(q',x)]" "insert q' stateSet" , OF \<open>k = length stateList'\<close>]
        by simp
    qed
  next
    case (Some a)
    then show ?thesis unfolding \<open>stateList = n # nL\<close> by auto
  qed
qed

lemma select_inputs_helper1 :
  "find (\<lambda>x. f (q0, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q0, x). q'' \<in> nS)) iL = Some x
    \<Longrightarrow> (select_inputs f q0 iL nL nS m) = m@[(q0,x)]"
  by (cases nL; auto)

lemma select_inputs_take :
  "take (length m) (select_inputs f q0 inputList stateList stateSet m) = m"
proof (induction "length stateList" arbitrary: stateList stateSet m)
  case 0
  then show ?case
    by (cases "find (\<lambda>x. f (q0, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q0, x). q'' \<in> stateSet)) inputList"; auto)
next
  case (Suc k)
  then obtain n nL where "stateList = n # nL"
    by (meson Suc_length_conv)

  show ?case proof (cases "find (\<lambda> x . f (q0,x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q0,x) . (q'' \<in> stateSet))) inputList")
    case None
    then show ?thesis
    proof (cases "find_remove_2 (\<lambda> q' x . f (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q',x) . (q'' \<in> stateSet))) stateList inputList")
      case None
      then show ?thesis using \<open>find (\<lambda>x. f (q0, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q0, x). q'' \<in> stateSet)) inputList = None\<close>
        unfolding \<open>stateList = n # nL\<close> by auto
    next
      case (Some a)
      then obtain q' x stateList' where *: "find_remove_2 (\<lambda> q' x . f (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q',x) . (q'' \<in> stateSet))) (n#nL) inputList
                                            = Some (q',x,stateList')"
        unfolding \<open>stateList = n # nL\<close>
        by (metis prod_cases3)
      have "k = length stateList'"
        using find_remove_2_length[OF *] \<open>Suc k = length stateList\<close>
        unfolding \<open>stateList = n # nL\<close>
        by simp

      have **: "(select_inputs f q0 inputList stateList stateSet m)
                  = select_inputs f q0 inputList stateList' (insert q' stateSet) (m @ [(q', x)])"
        unfolding \<open>stateList = n # nL\<close> select_inputs.simps None *
        by simp
      show ?thesis
        unfolding **
        using Suc.hyps(1)[of stateList' "m@[(q',x)]" "insert q' stateSet" , OF \<open>k = length stateList'\<close>]
        by (metis butlast_snoc butlast_take diff_Suc_1 length_append_singleton select_inputs_length_min)
    qed
  next
    case (Some a)
    then show ?thesis unfolding \<open>stateList = n # nL\<close> by auto
  qed
qed

lemma select_inputs_take' :
  "take (length m) (select_inputs f q0 iL nL nS (m@m')) = m"
  using select_inputs_take
  by (metis (no_types, lifting) add_leE append_eq_append_conv select_inputs_length_min length_append
        length_take min_absorb2 take_add)

lemma select_inputs_distinct :
  assumes "distinct (map fst m)"
  and     "set (map fst m) \<subseteq> nS"
  and     "q0 \<notin> nS"
  and     "distinct nL"
  and     "q0 \<notin> set nL"
  and     "set nL \<inter> nS = {}"
  shows "distinct (map fst (select_inputs f q0 iL nL nS m))"
using assms proof (induction "length nL" arbitrary: nL nS m)
  case 0
  then show ?case
    by (cases "find (\<lambda>x. f (q0, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q0, x). q'' \<in> nS)) iL"; auto)
next
  case (Suc k)
  then obtain n nL'' where "nL = n # nL''"
    by (meson Suc_length_conv)

  show ?case proof (cases "find (\<lambda> x . f (q0,x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q0,x) . (q'' \<in> nS))) iL")
    case None
    then show ?thesis
    proof (cases "find_remove_2 (\<lambda> q' x . f (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q',x) . (q'' \<in> nS))) nL iL")
      case None
      then have "(select_inputs f q0 iL nL nS m) = m"
        using \<open>find (\<lambda>x. f (q0, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q0, x). q'' \<in> nS)) iL = None\<close>
        unfolding \<open>nL = n # nL''\<close> by auto
      then show ?thesis
        using Suc.prems by auto
    next
      case (Some a)
      then obtain q' x nL' where *: "find_remove_2 (\<lambda> q' x . f (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q',x) . (q'' \<in> nS))) nL iL
                                      = Some (q',x,nL')"
        by (metis prod_cases3)

      have "k = length nL'"
        using find_remove_2_length[OF *] \<open>Suc k = length nL\<close>
        by simp

      have "select_inputs f q0 iL nL nS m = select_inputs f q0 iL nL' (insert q' nS) (m @ [(q', x)])"
        using *
        unfolding  \<open>nL = n # nL''\<close> select_inputs.simps None
        by auto

      have "q' \<in> set nL"
      and  "set nL' = set nL - {q'}"
      and  "distinct nL'"
        using find_remove_2_set[OF * ]  \<open>distinct nL\<close> by auto

      have "distinct (map fst (m@[(q',x)]))"
        using \<open>(set (map fst m)) \<subseteq> nS\<close> \<open>set nL \<inter> nS = {}\<close> \<open>q' \<in> set nL\<close> \<open>distinct (map fst m)\<close>
        by auto
      have "q0 \<notin> insert q' nS"
        using Suc.prems(3) Suc.prems(5) \<open>q' \<in> set nL\<close> by auto
      have "set (map fst (m@[(q',x)])) \<subseteq> insert q' nS"
        using \<open>(set (map fst m)) \<subseteq> nS\<close> by auto
      have "(set (map fst (m@[(q',x)]))) \<subseteq> insert q' nS"
        using\<open>(set (map fst m)) \<subseteq> nS\<close> by auto
      have "q0 \<notin> set nL'"
        by (simp add: Suc.prems(5) \<open>set nL' = set nL - {q'}\<close>)
      have "set nL' \<inter> insert q' nS = {}"
        using Suc.prems(6) \<open>set nL' = set nL - {q'}\<close> by auto

      show ?thesis
        unfolding select_inputs.simps None *
        using Suc.hyps(1)[OF \<open>k = length nL'\<close> \<open>distinct (map fst (m@[(q',x)]))\<close>
                               \<open>set (map fst (m@[(q',x)])) \<subseteq> insert q' nS\<close>
                               \<open>q0 \<notin> insert q' nS\<close>
                               \<open>distinct nL'\<close>
                               \<open>q0 \<notin> set nL'\<close>
                               \<open>set nL' \<inter> insert q' nS = {}\<close>]
        unfolding \<open>select_inputs f q0 iL nL nS m = select_inputs f q0 iL nL' (insert q' nS) (m @ [(q', x)])\<close>
        by assumption
    qed
  next
    case (Some a)
    then show ?thesis
      using Suc \<open>nL = n # nL''\<close> by auto
  qed
qed

lemma select_inputs_index_properties :
  assumes "i < length (select_inputs (h M) q0 iL nL nS m)"
  and     "i \<ge> length m"
  and     "distinct (map fst m)"
  and     "nS = nS0 \<union> set (map fst m)"
  and     "q0 \<notin> nS"
  and     "distinct nL"
  and     "q0 \<notin> set nL"
  and     "set nL \<inter> nS = {}"
shows "fst (select_inputs (h M) q0 iL nL nS m ! i) \<in> (insert q0 (set nL))"
      "fst (select_inputs (h M) q0 iL nL nS m ! i) \<notin> nS0"
      "snd (select_inputs (h M) q0 iL nL nS m ! i) \<in> set iL"
      "(\<forall> qx' \<in> set (take i (select_inputs (h M) q0 iL nL nS m)) . fst (select_inputs (h M) q0 iL nL nS m ! i) \<noteq> fst qx')"
      "(\<exists> t \<in> transitions M . t_source t = fst (select_inputs (h M) q0 iL nL nS m ! i) \<and> t_input t = snd (select_inputs (h M) q0 iL nL nS m ! i))"
      "(\<forall> t \<in> transitions M . (t_source t = fst (select_inputs (h M) q0 iL nL nS m ! i) \<and> t_input t = snd (select_inputs (h M) q0 iL nL nS m ! i)) \<longrightarrow> (t_target t \<in> nS0 \<or> (\<exists> qx' \<in> set (take i (select_inputs (h M) q0 iL nL nS m)) . fst qx' = (t_target t))))"
proof -
  have combined_props :
    "fst (select_inputs (h M) q0 iL nL nS m ! i) \<in> (insert q0 (set nL))
      \<and> snd (select_inputs (h M) q0 iL nL nS m ! i) \<in> set iL
      \<and> fst (select_inputs (h M) q0 iL nL nS m ! i) \<notin> nS0
      \<and> (\<exists> t \<in> transitions M . t_source t = fst (select_inputs (h M) q0 iL nL nS m ! i) \<and> t_input t = snd (select_inputs (h M) q0 iL nL nS m ! i))
      \<and> (\<forall> t \<in> transitions M . (t_source t = fst (select_inputs (h M) q0 iL nL nS m ! i) \<and> t_input t = snd (select_inputs (h M) q0 iL nL nS m ! i)) \<longrightarrow> (t_target t \<in> nS0 \<or> (\<exists> qx' \<in> set (take i (select_inputs (h M) q0 iL nL nS m)) . fst qx' = (t_target t))))"
  using assms proof (induction "length nL" arbitrary: nL nS m)
    case 0
    show ?case proof (cases "find (\<lambda> x . (h M) (q0,x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> (h M) (q0,x) . (q'' \<in> nS))) iL")
      case None
      then have "(select_inputs (h M) q0 iL nL nS m) = m" using 0 by auto
      then have "False" using "0.prems"(1,2) by auto
      then show ?thesis by simp
    next
      case (Some x)
      have "(select_inputs (h M) q0 iL nL nS m) = m@[(q0,x)]" using select_inputs_helper1[OF Some] by assumption
      then have "(select_inputs (h M) q0 iL nL nS m ! i) = (q0,x)" using "0.prems"(1,2)
        using antisym by fastforce

      have "fst (q0, x) \<in> insert q0 (set nL)" by auto
      moreover have "snd (q0, x) \<in> set iL" using find_set[OF Some] by auto
      moreover have "fst (select_inputs (h M) q0 iL nL nS m ! i) \<notin> nS0"
        using \<open>select_inputs (h M) q0 iL nL nS m ! i = (q0, x)\<close> assms(4) assms(5) by auto

      moreover have "(\<exists>t\<in>FSM.transitions M. t_source t = fst (q0, x) \<and> t_input t = snd (q0, x))"
        using find_condition[OF Some] unfolding fst_conv snd_conv h.simps
        by fastforce
      moreover have "\<And> t . t \<in> FSM.transitions M \<Longrightarrow>
          t_source t = fst (q0, x) \<Longrightarrow> t_input t = snd (q0, x) \<Longrightarrow>
          t_target t \<in> nS0 \<or> (\<exists>qx'\<in>set (take i (select_inputs (h M) q0 iL nL nS m)). fst qx' = t_target t)"
      proof -
        fix t assume "t \<in> FSM.transitions M" "t_source t = fst (q0, x)" "t_input t = snd (q0, x)"
        then have "t_target t \<in> nS"
          using find_condition[OF Some] unfolding h.simps fst_conv snd_conv
          by (metis (no_types, lifting) case_prod_beta' h_simps mem_Collect_eq prod.collapse)
        then show "t_target t \<in> nS0 \<or> (\<exists>qx'\<in>set (take i (select_inputs (h M) q0 iL nL nS m)). fst qx' = t_target t)"
          using \<open>nS = nS0 \<union> set (map fst m)\<close>
          using "0.prems"(1) "0.prems"(2) \<open>select_inputs (h M) q0 iL nL nS m = m @ [(q0, x)]\<close> by fastforce
      qed

      ultimately show ?thesis
        unfolding \<open>(select_inputs (h M) q0 iL nL nS m ! i) = (q0,x)\<close> by blast
    qed
  next
    case (Suc k)
    then obtain n nL'' where "nL = n # nL''"
      by (meson Suc_length_conv)

    show ?case proof (cases "find (\<lambda> x . (h M) (q0,x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> (h M) (q0,x) . (q'' \<in> nS))) iL")
      case None
      show ?thesis proof (cases "find_remove_2 (\<lambda> q' x . (h M) (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> (h M) (q',x) . (q'' \<in> nS))) nL iL")
        case None
        then have "(select_inputs (h M) q0 iL nL nS m) = m" using \<open>find (\<lambda>x. h M (q0, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>h M (q0, x). q'' \<in> nS)) iL = None\<close> \<open>nL = n # nL''\<close> by auto
        then have "False" using Suc.prems(1,2) by auto
        then show ?thesis by simp
      next
        case (Some a)
        then obtain q' x nL' where **: "find_remove_2 (\<lambda> q' x . (h M) (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> (h M) (q',x) . (q'' \<in> nS))) nL iL = Some (q',x,nL')"
          by (metis prod_cases3)

        have "k = length nL'"
          using find_remove_2_length[OF **] \<open>Suc k = length nL\<close> by simp

        have "select_inputs (h M) q0 iL nL nS m = select_inputs (h M) q0 iL nL' (insert q' nS) (m @ [(q', x)])"
          using **
          unfolding  \<open>nL = n # nL''\<close> select_inputs.simps None by auto
        then have "i < length (select_inputs (h M) q0 iL nL' (insert q' nS) (m@[(q',x)]))"
          using Suc.prems(1) by auto

        have "(set (map fst (m @ [(q', x)]))) \<subseteq> insert q' nS"
          using Suc.prems(4) by auto

        have "q' \<in> set nL"
        and  "set nL' = set nL - {q'}"
        and  "distinct nL'"
          using find_remove_2_set[OF ** ]  \<open>distinct nL\<close> by auto
        have "set nL' \<subseteq> set nL"
          using find_remove_2_set(4)[OF ** \<open>distinct nL\<close>] by blast

        have "distinct (map fst (m @ [(q', x)]))"
          using Suc.prems(4) \<open>set nL \<inter> nS = {}\<close> \<open>q' \<in> set nL\<close> \<open>distinct (map fst m)\<close> by auto
        have "distinct (map fst (m@[(q',x)]))"
          using Suc.prems(4) \<open>set nL \<inter> nS = {}\<close> \<open>q' \<in> set nL\<close> \<open>distinct (map fst m)\<close> by auto
        have "q0 \<notin> insert q' nS"
          using Suc.prems(7) Suc.prems(5) \<open>q' \<in> set nL\<close> by auto
        have "insert q' nS = nS0 \<union> set (map fst (m@[(q',x)]))"
          using Suc.prems(4) by auto
        have "q0 \<notin> set nL'"
          by (metis Suc.prems(7) \<open>set nL' \<subseteq> set nL\<close> subset_code(1))
        have "set nL' \<inter> insert q' nS = {}"
          using Suc.prems(8) \<open>set nL' = set nL - {q'}\<close> by auto

        show ?thesis proof (cases "length (m @ [(q', x)]) \<le> i")
          case True

          show ?thesis
            using Suc.hyps(1)[OF \<open>k = length nL'\<close> \<open>i < length (select_inputs (h M) q0 iL nL' (insert q' nS) (m@[(q',x)]))\<close>
                            True
                            \<open>distinct (map fst (m @ [(q', x)]))\<close>
                            \<open>insert q' nS = nS0 \<union> set (map fst (m@[(q',x)]))\<close>
                            \<open>q0 \<notin> insert q' nS\<close>
                            \<open>distinct nL'\<close>
                            \<open>q0 \<notin> set nL'\<close>
                            \<open>set nL' \<inter> insert q' nS = {}\<close> ]
            unfolding \<open>select_inputs (h M) q0 iL nL nS m = select_inputs (h M) q0 iL nL' (insert q' nS) (m@[(q',x)])\<close>
            using \<open>set nL' \<subseteq> set nL\<close> by blast
        next
          case False
          then have "i = length m"
            using Suc.prems(2) by auto
          then have ***: "select_inputs (h M) q0 iL nL nS m ! i = (q',x)"
            unfolding \<open>select_inputs (h M) q0 iL nL nS m = select_inputs (h M) q0 iL nL' (insert q' nS) (m@[(q',x)])\<close>
            using select_inputs_take
            by (metis length_append_singleton lessI nth_append_length nth_take)

          have "q' \<in> insert q0 (set nL)"
            by (simp add: \<open>q' \<in> set nL\<close>)
          moreover have "x \<in> set iL"
            using find_remove_2_set(3)[OF ** ] by auto
          moreover have "q' \<notin> nS0"
            using Suc.prems(4) Suc.prems(8) \<open>q' \<in> set nL\<close> by blast
          moreover have "(\<exists>t\<in>FSM.transitions M. t_source t = q' \<and> t_input t = x) "
            using find_remove_2_set(1)[OF ** ] unfolding h.simps by force
          moreover have "(\<forall>t\<in>FSM.transitions M. t_source t = q' \<and> t_input t = x \<longrightarrow> t_target t \<in> nS0 \<or> (\<exists>qx'\<in>set (take i (select_inputs (h M) q0 iL nL nS m)). fst qx' = t_target t))"
            unfolding \<open>i = length m\<close> select_inputs_take
            using find_remove_2_set(1)[OF ** ] unfolding h.simps \<open>nS = nS0 \<union> (set (map fst m))\<close> by force
          ultimately show ?thesis
            unfolding *** fst_conv snd_conv by blast
        qed
      qed
    next
      case (Some x)
      have "(select_inputs (h M) q0 iL nL nS m) = m@[(q0,x)]" using select_inputs_helper1[OF Some] by assumption
      then have "(select_inputs (h M) q0 iL nL nS m ! i) = (q0,x)" using Suc.prems(1,2)
        using antisym by fastforce

      have "fst (q0, x) \<in> insert q0 (set nL)" by auto
      moreover have "snd (q0, x) \<in> set iL" using find_set[OF Some] by auto
      moreover have "fst (q0, x) \<notin> nS0"
        using assms(4) assms(5) by auto
      moreover have "\<And> qx' . qx' \<in> set (take i (select_inputs (h M) q0 iL nL nS m)) - set (take (length m) (select_inputs (h M) q0 iL nL nS m)) \<Longrightarrow> fst (q0, x) \<noteq> fst qx'"
        using Suc.prems(1,2) \<open>select_inputs (h M) q0 iL nL nS m = m @ [(q0, x)]\<close> by auto
      moreover have "(\<exists>t\<in>FSM.transitions M. t_source t = fst (q0, x) \<and> t_input t = snd (q0, x))"
        using find_condition[OF Some] unfolding fst_conv snd_conv h.simps
        by fastforce
      moreover have "\<And> t . t \<in> FSM.transitions M \<Longrightarrow>
          t_source t = fst (q0, x) \<Longrightarrow> t_input t = snd (q0, x) \<Longrightarrow>
          t_target t \<in> nS0 \<or> (\<exists>qx'\<in>set (take i (select_inputs (h M) q0 iL nL nS m)). fst qx' = t_target t)"
      proof -
        fix t assume "t \<in> FSM.transitions M" "t_source t = fst (q0, x)" "t_input t = snd (q0, x)"
        then have "t_target t \<in> nS"
          using find_condition[OF Some] unfolding h.simps fst_conv snd_conv
          by (metis (no_types, lifting) case_prod_beta' h_simps mem_Collect_eq prod.collapse)
        then show "t_target t \<in> nS0 \<or> (\<exists>qx'\<in>set (take i (select_inputs (h M) q0 iL nL nS m)). fst qx' = t_target t)"
          using \<open>nS = nS0 \<union> (set (map fst m))\<close>
          using Suc.prems(1,2) \<open>select_inputs (h M) q0 iL nL nS m = m @ [(q0, x)]\<close> by fastforce
      qed

      ultimately show ?thesis
        unfolding \<open>(select_inputs (h M) q0 iL nL nS m ! i) = (q0,x)\<close> by blast
    qed
  qed

  then show "fst (select_inputs (h M) q0 iL nL nS m ! i) \<in> (insert q0 (set nL))"
            "snd (select_inputs (h M) q0 iL nL nS m ! i) \<in> set iL"
            "fst (select_inputs (h M) q0 iL nL nS m ! i) \<notin> nS0"
            "(\<exists> t \<in> transitions M . t_source t = fst (select_inputs (h M) q0 iL nL nS m ! i) \<and> t_input t = snd (select_inputs (h M) q0 iL nL nS m ! i))"
            "(\<forall> t \<in> transitions M . (t_source t = fst (select_inputs (h M) q0 iL nL nS m ! i) \<and> t_input t = snd (select_inputs (h M) q0 iL nL nS m ! i)) \<longrightarrow> (t_target t \<in> nS0 \<or> (\<exists> qx' \<in> set (take i (select_inputs (h M) q0 iL nL nS m)) . fst qx' = (t_target t))))"
    by blast+

  show "(\<forall> qx' \<in> set (take i (select_inputs (h M) q0 iL nL nS m)) . fst (select_inputs (h M) q0 iL nL nS m ! i) \<noteq> fst qx')"
  proof
    fix qx' assume "qx' \<in> set (take i (select_inputs (h M) q0 iL nL nS m))"
    then obtain j where "(take i (select_inputs (h M) q0 iL nL nS m)) ! j = qx'" and "j < length (take i (select_inputs (h M) q0 iL nL nS m))"
      by (meson in_set_conv_nth)
    then have "fst qx' = (map fst (select_inputs (h M) q0 iL nL nS m)) ! j" and "j < length (select_inputs (h M) q0 iL nL nS m)" by auto

    moreover have "fst (select_inputs (h M) q0 iL nL nS m ! i) = (map fst (select_inputs (h M) q0 iL nL nS m)) ! i"
      using assms(1) by auto

    moreover have "j \<noteq> i"
      using \<open>j < length (take i (select_inputs (h M) q0 iL nL nS m))\<close> by auto

    moreover have "set (map fst m) \<subseteq> nS"
      using \<open>nS = nS0 \<union> set (map fst m)\<close> by blast

    ultimately show "fst (select_inputs (h M) q0 iL nL nS m ! i) \<noteq> fst qx'"
      using assms(1)
      using select_inputs_distinct[OF \<open>distinct (map fst m)\<close> _ \<open>q0 \<notin> nS\<close> \<open>distinct nL\<close> \<open>q0 \<notin> set nL\<close> \<open>set nL \<inter> nS = {}\<close>]
      by (metis distinct_Ex1 in_set_conv_nth length_map)
  qed
qed

lemma select_inputs_initial :
  assumes "qx \<in> set (select_inputs f q0 iL nL nS m) - set m"
  and     "fst qx = q0"
  shows "(last (select_inputs f q0 iL nL nS m)) = qx"
using assms(1) proof (induction "length nL" arbitrary: nS nL m)
  case 0
  then have "nL = []" by auto

  have "find (\<lambda>x. f (q0, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q0, x). q'' \<in> nS)) iL \<noteq> None"
    using 0 unfolding \<open>nL = []\<close> select_inputs.simps
    by (metis Diff_cancel empty_iff option.simps(4))
  then obtain x where *: "find (\<lambda>x. f (q0, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q0, x). q'' \<in> nS)) iL = Some x"
    by auto

  have "set (select_inputs f q0 iL nL nS m) - set m = {qx}"
    using "0.prems"(1) unfolding select_inputs_helper1[OF *]
    by auto

  then show ?case unfolding select_inputs_helper1[OF *]
    by (metis DiffD1 DiffD2 UnE empty_iff empty_set insert_iff last_snoc list.simps(15) set_append)
next
  case (Suc k)
  then obtain n nL'' where "nL = n # nL''"
    by (meson Suc_length_conv)

  show ?case proof (cases "find (\<lambda>x. f (q0, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q0, x). q'' \<in> nS)) iL")
    case None
    show ?thesis proof (cases "find_remove_2 (\<lambda> q' x . f (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q',x) . (q'' \<in> nS))) nL iL")
      case None
      have "(select_inputs f q0 iL nL nS m) = m"
        using \<open>find (\<lambda>x. f (q0, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q0, x). q'' \<in> nS)) iL = None\<close> None \<open>nL = n # nL''\<close> by auto
      then have "False"
        using Suc.prems(1)
        by simp
      then show ?thesis by simp
    next
      case (Some a)
      then obtain q' x nL' where **: "find_remove_2 (\<lambda> q' x . f (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q',x) . (q'' \<in> nS))) nL iL = Some (q',x,nL')"
        by (metis prod_cases3)

      have "k = length nL'"
        using find_remove_2_length[OF **] \<open>Suc k = length nL\<close> by simp

      have "select_inputs f q0 iL nL nS m = select_inputs f q0 iL nL' (insert q' nS) (m @ [(q', x)])"
        using **
        unfolding  \<open>nL = n # nL''\<close> select_inputs.simps None by auto
      then have "qx \<in> set (select_inputs f q0 iL nL' (insert q' nS) (m@[(q',x)])) - set m"
        using Suc.prems by auto
      moreover have "q0 \<noteq> q'"
        using None unfolding find_None_iff
        using find_remove_2_set(1,2,3)[OF **]
        by blast
      ultimately have "qx \<in> set (select_inputs f q0 iL nL' (insert q' nS) (m@[(q',x)])) - set (m@[(q',x)])"
        using \<open>fst qx = q0\<close> by auto
      then show ?thesis
        using Suc.hyps unfolding \<open>(select_inputs f q0 iL nL nS m) = (select_inputs f q0 iL nL' (insert q' nS) (m@[(q',x)]))\<close>
        using \<open>k = length nL'\<close> by blast
    qed
  next
    case (Some a)

    have "set (select_inputs f q0 iL nL nS m ) - set m = {qx}"
      using Suc.prems(1) unfolding select_inputs_helper1[OF Some]
      by auto

    then show ?thesis unfolding select_inputs_helper1[OF Some]
      by (metis DiffD1 DiffD2 UnE empty_iff empty_set insert_iff last_snoc list.simps(15) set_append)
  qed
qed

lemma select_inputs_max_length :
  assumes "distinct nL"
  shows "length (select_inputs f q0 iL nL nS m) \<le> length m + Suc (length nL)"
using assms proof (induction "length nL" arbitrary: nL nS m)
  case 0
  then show ?case by (cases "find (\<lambda> x . f (q0,x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q0,x) . (q'' \<in> nS))) iL"; auto)
next
  case (Suc k)
  then obtain n nL'' where "nL = n # nL''"
    by (meson Suc_length_conv)

  show ?case proof (cases "find (\<lambda> x . f (q0,x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q0,x) . (q'' \<in> nS))) iL")
    case None
    show ?thesis proof (cases "find_remove_2 (\<lambda> q' x . f (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q',x) . (q'' \<in> nS))) nL iL")
      case None
      show ?thesis unfolding \<open>nL = n # nL''\<close> select_inputs.simps None \<open>find (\<lambda>x. f (q0, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q0, x). q'' \<in> nS)) iL = None\<close>
        using None \<open>nL = n # nL''\<close> by auto
    next
      case (Some a)
      then obtain q' x nL' where **: "find_remove_2 (\<lambda> q' x . f (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q',x) . (q'' \<in> nS))) nL iL = Some (q',x,nL')"
        by (metis prod_cases3)
      have "k = length nL'"
        using find_remove_2_length[OF **] \<open>Suc k = length nL\<close> by simp

      have "select_inputs f q0 iL nL nS m = select_inputs f q0 iL nL' (insert q' nS) (m @ [(q', x)])"
        using **
        unfolding  \<open>nL = n # nL''\<close> select_inputs.simps None by auto

      have "length nL = Suc (length nL') \<and> distinct nL'"
        using find_remove_2_set(2,4,5)[OF **] \<open>distinct nL\<close>
        by (metis One_nat_def Suc_pred distinct_card distinct_remove1 equals0D length_greater_0_conv length_remove1 set_empty2 set_remove1_eq)
      then have "length (select_inputs f q0 iL nL' (insert q' nS) (m@[(q',x)])) \<le> length m + Suc (length nL)"
        using Suc.hyps(1)[OF \<open>k = length nL'\<close>]
        by (metis add_Suc_shift length_append_singleton)
      then show ?thesis
        using \<open>(select_inputs f q0 iL nL nS m) = select_inputs f q0 iL nL' (insert q' nS) (m@[(q',x)])\<close> by simp
    qed
  next
    case (Some a)
    show ?thesis unfolding select_inputs_helper1[OF Some] by auto
  qed
qed

lemma select_inputs_q0_containment :
  assumes "f (q0,x) \<noteq> {}"
  and     "(\<forall> (y,q'') \<in> f (q0,x) . (q'' \<in> nS))"
  and     "x \<in> set iL"
shows "(\<exists> qx \<in> set (select_inputs f q0 iL nL nS m) . fst qx = q0)"
proof -
  have "find (\<lambda> x . f (q0,x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q0,x) . (q'' \<in> nS))) iL \<noteq> None"
    using assms unfolding find_None_iff by blast
  then obtain x' where *: "find (\<lambda> x . f (q0,x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q0,x) . (q'' \<in> nS))) iL = Some x'"
    by auto
  show ?thesis
    unfolding select_inputs_helper1[OF *] by auto
qed

lemma select_inputs_from_submachine :
  assumes "single_input S"
  and     "acyclic S"
  and     "is_submachine S M"
  and     "\<And> q x . q \<in> reachable_states S \<Longrightarrow> h S (q,x) \<noteq> {} \<Longrightarrow> h S (q,x) = h M (q,x)"
  and     "\<And> q . q \<in> reachable_states S \<Longrightarrow> deadlock_state S q \<Longrightarrow> q \<in> nS0 \<union> set (map fst m)"
  and     "states M = insert (initial S) (set nL \<union> nS0 \<union> set (map fst m))"
  and     "(initial S) \<notin> (set nL \<union> nS0 \<union> set (map fst m))"
shows "fst (last (select_inputs (h M) (initial S) (inputs_as_list M) nL (nS0 \<union> set (map fst m)) m)) = (initial S)"
and   "length (select_inputs (h M) (initial S) (inputs_as_list M) nL (nS0 \<union> set (map fst m)) m) > 0"
proof -
  have "fst (last (select_inputs (h M) (initial S) (inputs_as_list M) nL (nS0 \<union> set (map fst m)) m)) = (initial S) \<and> length (select_inputs (h M) (initial S) (inputs_as_list M) nL (nS0 \<union> set (map fst m)) m) > 0"
  using assms(5,6,7) proof (induction "length nL" arbitrary: nL m)
    case 0
    then have "nL = []" by auto

    have "\<not> (deadlock_state S (initial S))"
      using assms(5,6,3,7) reachable_states_initial by blast
    then obtain x where "x \<in> set (inputs_as_list M)" and "h S ((initial S),x) \<noteq> {}"
      using assms(3) unfolding deadlock_state.simps h.simps inputs_as_list_set
      by fastforce

    then have "h M ((initial S),x) \<noteq> {}"
      using assms(4)[OF reachable_states_initial]  by fastforce

    have "(initial S) \<in> reachable_states M"
      using assms(3) reachable_states_initial by auto

    then have "(initial S) \<in> states M"
      using reachable_state_is_state by force

    have "\<And> y q'' . (y,q'') \<in> h M ((initial S),x) \<Longrightarrow> q'' \<in> (nS0 \<union> set (map fst m))"
    proof -
      fix y q'' assume "(y,q'') \<in> h M ((initial S),x)"
      then have "q'' \<in> reachable_states M" using fsm_transition_target unfolding h.simps
        using \<open>FSM.initial S \<in> reachable_states M\<close> reachable_states_next by fastforce
      then have "q'' \<in> insert (initial S) (nS0 \<union> set (map fst m))" using "0.prems"(2) \<open>nL = []\<close>
        using reachable_state_is_state by force
      moreover have "q'' \<noteq> (initial S)"
        using acyclic_no_self_loop[OF \<open>acyclic S\<close> reachable_states_initial]
        using \<open>(y,q'') \<in> h M ((initial S),x)\<close> assms(4)[OF reachable_states_initial \<open>h S ((initial S),x) \<noteq> {}\<close>] unfolding h_simps
        by blast
      ultimately show "q'' \<in> (nS0 \<union> set (map fst m))" by blast
    qed
    then have "x \<in> set (inputs_as_list M) \<and> h M ((initial S), x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>h M ((initial S), x). q'' \<in> nS0 \<union> set (map fst m))"
      using \<open>x \<in> set (inputs_as_list M) \<close> \<open>h M ((initial S), x) \<noteq> {}\<close> by blast
    then have "find (\<lambda> x . (h M) ((initial S),x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> (h M) ((initial S),x) . (q'' \<in> (nS0 \<union> set (map fst m))))) (inputs_as_list M) \<noteq> None"
      unfolding find_None_iff by blast
    then show ?case
      unfolding \<open>nL = []\<close> select_inputs.simps by auto
  next
    case (Suc k)
    then obtain n nL'' where "nL = n # nL''"
      by (meson Suc_length_conv)

    have "\<exists> q x . q \<in> reachable_states S - (nS0 \<union> set (map fst m)) \<and> h M (q,x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> h M (q,x) . q'' \<in> (nS0 \<union> set (map fst m)))"
    proof -
      define ndlps where ndlps_def: "ndlps = {p . path S (initial S) p \<and> target (initial S) p \<notin> (nS0 \<union> set (map fst m))}"

      have "path S (initial S) [] \<and> target (initial S) [] \<notin> (nS0 \<union> set (map fst m))"
        using Suc.prems(3) by auto
      then have "[] \<in> ndlps"
        unfolding ndlps_def by blast
      then have "ndlps \<noteq> {}" by auto
      moreover have "finite ndlps"
        using acyclic_finite_paths_from_reachable_state[OF \<open>acyclic S\<close>, of "[]"] unfolding ndlps_def by fastforce
      ultimately have "\<exists> p \<in> ndlps . \<forall> p' \<in> ndlps . length p' \<le> length p"
        by (meson max_length_elem not_le_imp_less)
      then obtain p where "path S (initial S) p"
                          and "target (initial S) p \<notin> (nS0 \<union> set (map fst m))"
                          and "\<And> p' . path S (initial S) p' \<Longrightarrow> target (initial S) p' \<notin> (nS0 \<union> set (map fst m)) \<Longrightarrow> length p' \<le> length p"
        unfolding ndlps_def by blast

      let ?q = "target (initial S) p"
      have "\<not> deadlock_state S ?q"
        using Suc.prems(1) reachable_states_intro[OF \<open>path S (initial S) p\<close>] using \<open>?q \<notin> (nS0 \<union> set (map fst m))\<close> by blast
      then obtain x where "h S (?q,x) \<noteq> {}"
        unfolding deadlock_state.simps h.simps by fastforce
      then have "h M (?q,x) \<noteq> {}"
        using assms(4)[of ?q _] reachable_states_intro[OF \<open>path S (initial S) p\<close>]
        by blast

      moreover have "\<And> y q'' . (y,q'') \<in> h M (?q,x) \<Longrightarrow> q'' \<in> (nS0 \<union> set (map fst m))"
      proof (rule ccontr)
        fix y q'' assume "(y,q'') \<in> h M (?q,x)" and "q'' \<notin> nS0 \<union> set (map fst m)"
        then have "(?q,x,y,q'') \<in> transitions S"
          using assms(4)[OF reachable_states_intro[OF \<open>path S (initial S) p\<close>] \<open>h S (?q,x) \<noteq> {}\<close>] unfolding h_simps
          by blast
        then have "path S (initial S) (p@[(?q,x,y,q'')])"
          using \<open>path S (initial S) p\<close> by (simp add: path_append_transition)
        moreover have "target (initial S) (p@[(?q,x,y,q'')]) \<notin> (nS0 \<union> set (map fst m))"
          using \<open>q'' \<notin> nS0 \<union> set (map fst m)\<close> by auto
        ultimately show "False"
          using \<open>\<And> p' . path S (initial S) p' \<Longrightarrow> target (initial S) p' \<notin> (nS0 \<union> set (map fst m)) \<Longrightarrow> length p' \<le> length p\<close>[of "(p@[(?q,x,y,q'')])"] by simp
      qed

      moreover have "?q \<in> reachable_states S - (nS0 \<union> set (map fst m))"
        using  \<open>?q \<notin> (nS0 \<union> set (map fst m))\<close> \<open>path S (initial S) p\<close>  by blast

      ultimately show ?thesis by blast
    qed

    then obtain q x where "q \<in> reachable_states S" and "q \<notin> (nS0 \<union> set (map fst m))" and "h M (q,x) \<noteq> {}" and "(\<forall> (y,q'') \<in> h M (q,x) . q'' \<in> (nS0 \<union> set (map fst m)))"
      by blast
    then have "x \<in> set (inputs_as_list M)"
      unfolding h.simps using fsm_transition_input inputs_as_list_set by fastforce

    show ?case proof (cases "q = initial S")
      case True
      have "find (\<lambda>x. h M (FSM.initial S, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>h M (FSM.initial S, x). q'' \<in> nS0 \<union> set (map fst m))) (inputs_as_list M) \<noteq> None"
        using \<open>h M (q,x) \<noteq> {}\<close> \<open>(\<forall> (y,q'') \<in> h M (q,x) . q'' \<in> (nS0 \<union> set (map fst m)))\<close> \<open>x \<in> set (inputs_as_list M)\<close>
        unfolding True find_None_iff by blast
      then show ?thesis unfolding \<open>nL = n # nL''\<close> by auto
    next
      case False
      then have "q \<in> set nL"
        using submachine_reachable_subset[OF \<open>is_submachine S M\<close>]
        unfolding is_submachine.simps \<open>states M = insert (initial S) (set nL \<union> nS0 \<union> set (map fst m))\<close>
        using \<open>q \<in> reachable_states S\<close>  \<open>q \<notin> (nS0 \<union> set (map fst m))\<close>
        by (metis (no_types, lifting) Suc.prems(2) UnE insertE reachable_state_is_state subsetD sup_assoc)

      show ?thesis proof (cases "find (\<lambda>x. h M (FSM.initial S, x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>h M (FSM.initial S, x). q'' \<in> nS0 \<union> set (map fst m))) (inputs_as_list M)")
        case None

        have "find_remove_2 (\<lambda> q' x . (h M) (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> (h M) (q',x) . (q'' \<in> nS0 \<union> set (map fst m)))) (nL) (inputs_as_list M) \<noteq> None"
          using \<open>q \<in> set nL\<close> \<open>h M (q,x) \<noteq> {}\<close> \<open>(\<forall> (y,q'') \<in> h M (q,x) . q'' \<in> (nS0 \<union> set (map fst m)))\<close> \<open>x \<in> set (inputs_as_list M)\<close>
          unfolding find_remove_2_None_iff \<open>nL = n # nL''\<close>
          by blast
        then obtain q' x' nL' where *: "find_remove_2 (\<lambda> q' x . (h M) (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> (h M) (q',x) . (q'' \<in> nS0 \<union> set (map fst m)))) (n#nL'') (inputs_as_list M) = Some (q',x',nL')"
          unfolding \<open>nL = n # nL''\<close> by auto
        have "k = length nL'"
          using find_remove_2_length[OF *] \<open>Suc k = length nL\<close>  \<open>nL = n # nL''\<close> by simp

        have **: "select_inputs (h M) (initial S) (inputs_as_list M) nL (nS0 \<union> set (map fst m)) m
                  = select_inputs (h M) (initial S) (inputs_as_list M) nL' (nS0 \<union> set (map fst (m@[(q',x')]))) (m@[(q',x')])"
          unfolding \<open>nL = n # nL''\<close> select_inputs.simps None * by auto

        have p1: "(\<And>q. q \<in> reachable_states S \<Longrightarrow> deadlock_state S q \<Longrightarrow> q \<in> nS0 \<union> set (map fst (m@[(q',x')])))"
          using Suc.prems(1) by fastforce

        have "set nL = insert q' (set nL')" using find_remove_2_set(2,6)[OF *] unfolding \<open>nL = n # nL''\<close> by auto
        then have "(set nL \<union> set (map fst m)) = (set nL' \<union> set (map fst (m @ [(q', x')])))" by auto
        then have p2: "states M = insert (initial S) (set nL' \<union> nS0 \<union> set (map fst (m @ [(q', x')])))"
          using Suc.prems(2) by auto

        have p3: "initial S \<notin> set nL' \<union> nS0 \<union> set (map fst (m @ [(q', x')]))"
          using Suc.prems(3) False \<open>set nL = insert q' (set nL')\<close> by auto

        show ?thesis unfolding **
          using Suc.hyps(1)[OF \<open>k = length nL'\<close> p1 p2 p3] by blast
      next
        case (Some a)
        then show ?thesis unfolding \<open>nL = n # nL''\<close> by auto
      qed
    qed
  qed
  then show "fst (last (select_inputs (h M) (initial S) (inputs_as_list M) nL (nS0 \<union> set (map fst m)) m)) = (initial S)"
       and  "length (select_inputs (h M) (initial S) (inputs_as_list M) nL (nS0 \<union> set (map fst m)) m) > 0"
    by blast+
qed

end


(*  Title:      HOL/Imperative_HOL/ex/Imperative_Quicksort.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section \<open>An imperative implementation of Quicksort on arrays\<close>

theory Imperative_Quicksort
imports
  "~~/src/HOL/Imperative_HOL/Imperative_HOL"
  Subarray
  "~~/src/HOL/Library/Multiset"
  "~~/src/HOL/Library/Code_Target_Numeral"
begin

text \<open>We prove QuickSort correct in the Relational Calculus.\<close>

definition swap :: "'a::heap array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap"
where
  "swap arr i j =
     do {
       x \<leftarrow> Array.nth arr i;
       y \<leftarrow> Array.nth arr j;
       Array.upd i y arr;
       Array.upd j x arr;
       return ()
     }"

lemma effect_swapI [effect_intros]:
  assumes "i < Array.length h a" "j < Array.length h a"
    "x = Array.get h a ! i" "y = Array.get h a ! j"
    "h' = Array.update a j x (Array.update a i y h)"
  shows "effect (swap a i j) h h' r"
  unfolding swap_def using assms by (auto intro!: effect_intros)

lemma swap_permutes:
  assumes "effect (swap a i j) h h' rs"
  shows "mset (Array.get h' a)
  = mset (Array.get h a)"
  using assms
  unfolding swap_def
  by (auto simp add: Array.length_def mset_swap dest: sym [of _ "h'"] elim!: effect_bindE effect_nthE effect_returnE effect_updE)

function part1 :: "'a::{heap,ord} array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> nat Heap"
where
  "part1 a left right p = (
     if (right \<le> left) then return right
     else do {
       v \<leftarrow> Array.nth a left;
       (if (v \<le> p) then (part1 a (left + 1) right p)
                    else (do { swap a left right;
  part1 a left (right - 1) p }))
     })"
by pat_completeness auto

termination
by (relation "measure (\<lambda>(_,l,r,_). r - l )") auto

declare part1.simps[simp del]

lemma part_permutes:
  assumes "effect (part1 a l r p) h h' rs"
  shows "mset (Array.get h' a)
  = mset (Array.get h a)"
  using assms
proof (induct a l r p arbitrary: h h' rs rule:part1.induct)
  case (1 a l r p h h' rs)
  thus ?case
    unfolding part1.simps [of a l r p]
    by (elim effect_bindE effect_ifE effect_returnE effect_nthE) (auto simp add: swap_permutes)
qed

lemma part_returns_index_in_bounds:
  assumes "effect (part1 a l r p) h h' rs"
  assumes "l \<le> r"
  shows "l \<le> rs \<and> rs \<le> r"
using assms
proof (induct a l r p arbitrary: h h' rs rule:part1.induct)
  case (1 a l r p h h' rs)
  note cr = \<open>effect (part1 a l r p) h h' rs\<close>
  show ?case
  proof (cases "r \<le> l")
    case True (* Terminating case *)
    with cr \<open>l \<le> r\<close> show ?thesis
      unfolding part1.simps[of a l r p]
      by (elim effect_bindE effect_ifE effect_returnE effect_nthE) auto
  next
    case False (* recursive case *)
    note rec_condition = this
    let ?v = "Array.get h a ! l"
    show ?thesis
    proof (cases "?v \<le> p")
      case True
      with cr False
      have rec1: "effect (part1 a (l + 1) r p) h h' rs"
        unfolding part1.simps[of a l r p]
        by (elim effect_bindE effect_nthE effect_ifE effect_returnE) auto
      from rec_condition have "l + 1 \<le> r" by arith
      from 1(1)[OF rec_condition True rec1 \<open>l + 1 \<le> r\<close>]
      show ?thesis by simp
    next
      case False
      with rec_condition cr
      obtain h1 where swp: "effect (swap a l r) h h1 ()"
        and rec2: "effect (part1 a l (r - 1) p) h1 h' rs"
        unfolding part1.simps[of a l r p]
        by (elim effect_bindE effect_nthE effect_ifE effect_returnE) auto
      from rec_condition have "l \<le> r - 1" by arith
      from 1(2) [OF rec_condition False rec2 \<open>l \<le> r - 1\<close>] show ?thesis by fastforce
    qed
  qed
qed

lemma part_length_remains:
  assumes "effect (part1 a l r p) h h' rs"
  shows "Array.length h a = Array.length h' a"
using assms
proof (induct a l r p arbitrary: h h' rs rule:part1.induct)
  case (1 a l r p h h' rs)
  note cr = \<open>effect (part1 a l r p) h h' rs\<close>

  show ?case
  proof (cases "r \<le> l")
    case True (* Terminating case *)
    with cr show ?thesis
      unfolding part1.simps[of a l r p]
      by (elim effect_bindE effect_ifE effect_returnE effect_nthE) auto
  next
    case False (* recursive case *)
    with cr 1 show ?thesis
      unfolding part1.simps [of a l r p] swap_def
      by (auto elim!: effect_bindE effect_ifE effect_nthE effect_returnE effect_updE) fastforce
  qed
qed

lemma part_outer_remains:
  assumes "effect (part1 a l r p) h h' rs"
  shows "\<forall>i. i < l \<or> r < i \<longrightarrow> Array.get h (a::'a::{heap,linorder} array) ! i = Array.get h' a ! i"
  using assms
proof (induct a l r p arbitrary: h h' rs rule:part1.induct)
  case (1 a l r p h h' rs)
  note cr = \<open>effect (part1 a l r p) h h' rs\<close>

  show ?case
  proof (cases "r \<le> l")
    case True (* Terminating case *)
    with cr show ?thesis
      unfolding part1.simps[of a l r p]
      by (elim effect_bindE effect_ifE effect_returnE effect_nthE) auto
  next
    case False (* recursive case *)
    note rec_condition = this
    let ?v = "Array.get h a ! l"
    show ?thesis
    proof (cases "?v \<le> p")
      case True
      with cr False
      have rec1: "effect (part1 a (l + 1) r p) h h' rs"
        unfolding part1.simps[of a l r p]
        by (elim effect_bindE effect_nthE effect_ifE effect_returnE) auto
      from 1(1)[OF rec_condition True rec1]
      show ?thesis by fastforce
    next
      case False
      with rec_condition cr
      obtain h1 where swp: "effect (swap a l r) h h1 ()"
        and rec2: "effect (part1 a l (r - 1) p) h1 h' rs"
        unfolding part1.simps[of a l r p]
        by (elim effect_bindE effect_nthE effect_ifE effect_returnE) auto
      from swp rec_condition have
        "\<forall>i. i < l \<or> r < i \<longrightarrow> Array.get h a ! i = Array.get h1 a ! i"
        unfolding swap_def
        by (elim effect_bindE effect_nthE effect_updE effect_returnE) auto
      with 1(2) [OF rec_condition False rec2] show ?thesis by fastforce
    qed
  qed
qed

lemma part_partitions:
  assumes "effect (part1 a l r p) h h' rs"
  shows "(\<forall>i. l \<le> i \<and> i < rs \<longrightarrow> Array.get h' (a::'a::{heap,linorder} array) ! i \<le> p)
  \<and> (\<forall>i. rs < i \<and> i \<le> r \<longrightarrow> Array.get h' a ! i \<ge> p)"
  using assms
proof (induct a l r p arbitrary: h h' rs rule:part1.induct)
  case (1 a l r p h h' rs)
  note cr = \<open>effect (part1 a l r p) h h' rs\<close>

  show ?case
  proof (cases "r \<le> l")
    case True (* Terminating case *)
    with cr have "rs = r"
      unfolding part1.simps[of a l r p]
      by (elim effect_bindE effect_ifE effect_returnE effect_nthE) auto
    with True
    show ?thesis by auto
  next
    case False (* recursive case *)
    note lr = this
    let ?v = "Array.get h a ! l"
    show ?thesis
    proof (cases "?v \<le> p")
      case True
      with lr cr
      have rec1: "effect (part1 a (l + 1) r p) h h' rs"
        unfolding part1.simps[of a l r p]
        by (elim effect_bindE effect_nthE effect_ifE effect_returnE) auto
      from True part_outer_remains[OF rec1] have a_l: "Array.get h' a ! l \<le> p"
        by fastforce
      have "\<forall>i. (l \<le> i = (l = i \<or> Suc l \<le> i))" by arith
      with 1(1)[OF False True rec1] a_l show ?thesis
        by auto
    next
      case False
      with lr cr
      obtain h1 where swp: "effect (swap a l r) h h1 ()"
        and rec2: "effect (part1 a l (r - 1) p) h1 h' rs"
        unfolding part1.simps[of a l r p]
        by (elim effect_bindE effect_nthE effect_ifE effect_returnE) auto
      from swp False have "Array.get h1 a ! r \<ge> p"
        unfolding swap_def
        by (auto simp add: Array.length_def elim!: effect_bindE effect_nthE effect_updE effect_returnE)
      with part_outer_remains [OF rec2] lr have a_r: "Array.get h' a ! r \<ge> p"
        by fastforce
      have "\<forall>i. (i \<le> r = (i = r \<or> i \<le> r - 1))" by arith
      with 1(2)[OF lr False rec2] a_r show ?thesis
        by auto
    qed
  qed
qed

fun partition :: "'a::{heap,linorder} array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat Heap"
where
  "partition a left right = do {
     pivot \<leftarrow> Array.nth a right;
     middle \<leftarrow> part1 a left (right - 1) pivot;
     v \<leftarrow> Array.nth a middle;
     m \<leftarrow> return (if (v \<le> pivot) then (middle + 1) else middle);
     swap a m right;
     return m
   }"

declare partition.simps[simp del]

lemma partition_permutes:
  assumes "effect (partition a l r) h h' rs"
  shows "mset (Array.get h' a)
  = mset (Array.get h a)"
proof -
    from assms part_permutes swap_permutes show ?thesis
      unfolding partition.simps
      by (elim effect_bindE effect_returnE effect_nthE effect_ifE effect_updE) fastforce
qed

lemma partition_length_remains:
  assumes "effect (partition a l r) h h' rs"
  shows "Array.length h a = Array.length h' a"
proof -
  from assms part_length_remains show ?thesis
    unfolding partition.simps swap_def
    by (elim effect_bindE effect_returnE effect_nthE effect_ifE effect_updE) auto
qed

lemma partition_outer_remains:
  assumes "effect (partition a l r) h h' rs"
  assumes "l < r"
  shows "\<forall>i. i < l \<or> r < i \<longrightarrow> Array.get h (a::'a::{heap,linorder} array) ! i = Array.get h' a ! i"
proof -
  from assms part_outer_remains part_returns_index_in_bounds show ?thesis
    unfolding partition.simps swap_def
    by (elim effect_bindE effect_returnE effect_nthE effect_ifE effect_updE) fastforce
qed

lemma partition_returns_index_in_bounds:
  assumes effect: "effect (partition a l r) h h' rs"
  assumes "l < r"
  shows "l \<le> rs \<and> rs \<le> r"
proof -
  from effect obtain middle h'' p where part: "effect (part1 a l (r - 1) p) h h'' middle"
    and rs_equals: "rs = (if Array.get h'' a ! middle \<le> Array.get h a ! r then middle + 1
         else middle)"
    unfolding partition.simps
    by (elim effect_bindE effect_returnE effect_nthE effect_ifE effect_updE) simp
  from \<open>l < r\<close> have "l \<le> r - 1" by arith
  from part_returns_index_in_bounds[OF part this] rs_equals \<open>l < r\<close> show ?thesis by auto
qed

lemma partition_partitions:
  assumes effect: "effect (partition a l r) h h' rs"
  assumes "l < r"
  shows "(\<forall>i. l \<le> i \<and> i < rs \<longrightarrow> Array.get h' (a::'a::{heap,linorder} array) ! i \<le> Array.get h' a ! rs) \<and>
  (\<forall>i. rs < i \<and> i \<le> r \<longrightarrow> Array.get h' a ! rs \<le> Array.get h' a ! i)"
proof -
  let ?pivot = "Array.get h a ! r"
  from effect obtain middle h1 where part: "effect (part1 a l (r - 1) ?pivot) h h1 middle"
    and swap: "effect (swap a rs r) h1 h' ()"
    and rs_equals: "rs = (if Array.get h1 a ! middle \<le> ?pivot then middle + 1
         else middle)"
    unfolding partition.simps
    by (elim effect_bindE effect_returnE effect_nthE effect_ifE effect_updE) simp
  from swap have h'_def: "h' = Array.update a r (Array.get h1 a ! rs)
    (Array.update a rs (Array.get h1 a ! r) h1)"
    unfolding swap_def
    by (elim effect_bindE effect_returnE effect_nthE effect_updE) simp
  from swap have in_bounds: "r < Array.length h1 a \<and> rs < Array.length h1 a"
    unfolding swap_def
    by (elim effect_bindE effect_returnE effect_nthE effect_updE) simp
  from swap have swap_length_remains: "Array.length h1 a = Array.length h' a"
    unfolding swap_def by (elim effect_bindE effect_returnE effect_nthE effect_updE) auto
  from \<open>l < r\<close> have "l \<le> r - 1" by simp
  note middle_in_bounds = part_returns_index_in_bounds[OF part this]
  from part_outer_remains[OF part] \<open>l < r\<close>
  have "Array.get h a ! r = Array.get h1 a ! r"
    by fastforce
  with swap
  have right_remains: "Array.get h a ! r = Array.get h' a ! rs"
    unfolding swap_def
    by (auto simp add: Array.length_def elim!: effect_bindE effect_returnE effect_nthE effect_updE) (cases "r = rs", auto)
  from part_partitions [OF part]
  show ?thesis
  proof (cases "Array.get h1 a ! middle \<le> ?pivot")
    case True
    with rs_equals have rs_equals: "rs = middle + 1" by simp
    {
      fix i
      assume i_is_left: "l \<le> i \<and> i < rs"
      with swap_length_remains in_bounds middle_in_bounds rs_equals \<open>l < r\<close>
      have i_props: "i < Array.length h' a" "i \<noteq> r" "i \<noteq> rs" by auto
      from i_is_left rs_equals have "l \<le> i \<and> i < middle \<or> i = middle" by arith
      with part_partitions[OF part] right_remains True
      have "Array.get h1 a ! i \<le> Array.get h' a ! rs" by fastforce
      with i_props h'_def in_bounds have "Array.get h' a ! i \<le> Array.get h' a ! rs"
        unfolding Array.update_def Array.length_def by simp
    }
    moreover
    {
      fix i
      assume "rs < i \<and> i \<le> r"

      hence "(rs < i \<and> i \<le> r - 1) \<or> (rs < i \<and> i = r)" by arith
      hence "Array.get h' a ! rs \<le> Array.get h' a ! i"
      proof
        assume i_is: "rs < i \<and> i \<le> r - 1"
        with swap_length_remains in_bounds middle_in_bounds rs_equals
        have i_props: "i < Array.length h' a" "i \<noteq> r" "i \<noteq> rs" by auto
        from part_partitions[OF part] rs_equals right_remains i_is
        have "Array.get h' a ! rs \<le> Array.get h1 a ! i"
          by fastforce
        with i_props h'_def show ?thesis by fastforce
      next
        assume i_is: "rs < i \<and> i = r"
        with rs_equals have "Suc middle \<noteq> r" by arith
        with middle_in_bounds \<open>l < r\<close> have "Suc middle \<le> r - 1" by arith
        with part_partitions[OF part] right_remains
        have "Array.get h' a ! rs \<le> Array.get h1 a ! (Suc middle)"
          by fastforce
        with i_is True rs_equals right_remains h'_def
        show ?thesis using in_bounds
          unfolding Array.update_def Array.length_def
          by auto
      qed
    }
    ultimately show ?thesis by auto
  next
    case False
    with rs_equals have rs_equals: "middle = rs" by simp
    {
      fix i
      assume i_is_left: "l \<le> i \<and> i < rs"
      with swap_length_remains in_bounds middle_in_bounds rs_equals
      have i_props: "i < Array.length h' a" "i \<noteq> r" "i \<noteq> rs" by auto
      from part_partitions[OF part] rs_equals right_remains i_is_left
      have "Array.get h1 a ! i \<le> Array.get h' a ! rs" by fastforce
      with i_props h'_def have "Array.get h' a ! i \<le> Array.get h' a ! rs"
        unfolding Array.update_def by simp
    }
    moreover
    {
      fix i
      assume "rs < i \<and> i \<le> r"
      hence "(rs < i \<and> i \<le> r - 1) \<or> i = r" by arith
      hence "Array.get h' a ! rs \<le> Array.get h' a ! i"
      proof
        assume i_is: "rs < i \<and> i \<le> r - 1"
        with swap_length_remains in_bounds middle_in_bounds rs_equals
        have i_props: "i < Array.length h' a" "i \<noteq> r" "i \<noteq> rs" by auto
        from part_partitions[OF part] rs_equals right_remains i_is
        have "Array.get h' a ! rs \<le> Array.get h1 a ! i"
          by fastforce
        with i_props h'_def show ?thesis by fastforce
      next
        assume i_is: "i = r"
        from i_is False rs_equals right_remains h'_def
        show ?thesis using in_bounds
          unfolding Array.update_def Array.length_def
          by auto
      qed
    }
    ultimately
    show ?thesis by auto
  qed
qed

function quicksort :: "'a::{heap,linorder} array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap"
where
  "quicksort arr left right =
     (if (right > left)  then
        do {
          pivotNewIndex \<leftarrow> partition arr left right;
          pivotNewIndex \<leftarrow> assert (\<lambda>x. left \<le> x \<and> x \<le> right) pivotNewIndex;
          quicksort arr left (pivotNewIndex - 1);
          quicksort arr (pivotNewIndex + 1) right
        }
     else return ())"
by pat_completeness auto

(* For termination, we must show that the pivotNewIndex is between left and right *)
termination
by (relation "measure (\<lambda>(a, l, r). (r - l))") auto

declare quicksort.simps[simp del]

lemma quicksort_permutes:
  assumes "effect (quicksort a l r) h h' rs"
  shows "mset (Array.get h' a)
  = mset (Array.get h a)"
  using assms
proof (induct a l r arbitrary: h h' rs rule: quicksort.induct)
  case (1 a l r h h' rs)
  with partition_permutes show ?case
    unfolding quicksort.simps [of a l r]
    by (elim effect_ifE effect_bindE effect_assertE effect_returnE) auto
qed

lemma length_remains:
  assumes "effect (quicksort a l r) h h' rs"
  shows "Array.length h a = Array.length h' a"
using assms
proof (induct a l r arbitrary: h h' rs rule: quicksort.induct)
  case (1 a l r h h' rs)
  with partition_length_remains show ?case
    unfolding quicksort.simps [of a l r]
    by (elim effect_ifE effect_bindE effect_assertE effect_returnE) fastforce+
qed

lemma quicksort_outer_remains:
  assumes "effect (quicksort a l r) h h' rs"
   shows "\<forall>i. i < l \<or> r < i \<longrightarrow> Array.get h (a::'a::{heap,linorder} array) ! i = Array.get h' a ! i"
  using assms
proof (induct a l r arbitrary: h h' rs rule: quicksort.induct)
  case (1 a l r h h' rs)
  note cr = \<open>effect (quicksort a l r) h h' rs\<close>
  thus ?case
  proof (cases "r > l")
    case False
    with cr have "h' = h"
      unfolding quicksort.simps [of a l r]
      by (elim effect_ifE effect_returnE) auto
    thus ?thesis by simp
  next
  case True
   {
      fix h1 h2 p ret1 ret2 i
      assume part: "effect (partition a l r) h h1 p"
      assume qs1: "effect (quicksort a l (p - 1)) h1 h2 ret1"
      assume qs2: "effect (quicksort a (p + 1) r) h2 h' ret2"
      assume pivot: "l \<le> p \<and> p \<le> r"
      assume i_outer: "i < l \<or> r < i"
      from  partition_outer_remains [OF part True] i_outer
      have 2: "Array.get h a !i = Array.get h1 a ! i" by fastforce
      moreover
      from 1(1) [OF True pivot qs1] pivot i_outer 2
      have 3: "Array.get h1 a ! i = Array.get h2 a ! i" by auto
      moreover
      from qs2 1(2) [of p h2 h' ret2] True pivot i_outer 3
      have "Array.get h2 a ! i = Array.get h' a ! i" by auto
      ultimately have "Array.get h a ! i= Array.get h' a ! i" by simp
    }
    with cr show ?thesis
      unfolding quicksort.simps [of a l r]
      by (elim effect_ifE effect_bindE effect_assertE effect_returnE) auto
  qed
qed

lemma quicksort_is_skip:
  assumes "effect (quicksort a l r) h h' rs"
  shows "r \<le> l \<longrightarrow> h = h'"
  using assms
  unfolding quicksort.simps [of a l r]
  by (elim effect_ifE effect_returnE) auto

lemma quicksort_sorts:
  assumes "effect (quicksort a l r) h h' rs"
  assumes l_r_length: "l < Array.length h a" "r < Array.length h a"
  shows "sorted (subarray l (r + 1) a h')"
  using assms
proof (induct a l r arbitrary: h h' rs rule: quicksort.induct)
  case (1 a l r h h' rs)
  note cr = \<open>effect (quicksort a l r) h h' rs\<close>
  thus ?case
  proof (cases "r > l")
    case False
    hence "l \<ge> r + 1 \<or> l = r" by arith
    with length_remains[OF cr] 1(5) show ?thesis
      by (auto simp add: subarray_Nil subarray_single)
  next
    case True
    {
      fix h1 h2 p
      assume part: "effect (partition a l r) h h1 p"
      assume qs1: "effect (quicksort a l (p - 1)) h1 h2 ()"
      assume qs2: "effect (quicksort a (p + 1) r) h2 h' ()"
      from partition_returns_index_in_bounds [OF part True]
      have pivot: "l\<le> p \<and> p \<le> r" .
     note length_remains = length_remains[OF qs2] length_remains[OF qs1] partition_length_remains[OF part]
      from quicksort_outer_remains [OF qs2] quicksort_outer_remains [OF qs1] pivot quicksort_is_skip[OF qs1]
      have pivot_unchanged: "Array.get h1 a ! p = Array.get h' a ! p" by (cases p, auto)
        (*-- First of all, by induction hypothesis both sublists are sorted. *)
      from 1(1)[OF True pivot qs1] length_remains pivot 1(5)
      have IH1: "sorted (subarray l p a h2)"  by (cases p, auto simp add: subarray_Nil)
      from quicksort_outer_remains [OF qs2] length_remains
      have left_subarray_remains: "subarray l p a h2 = subarray l p a h'"
        by (simp add: subarray_eq_samelength_iff)
      with IH1 have IH1': "sorted (subarray l p a h')" by simp
      from 1(2)[OF True pivot qs2] pivot 1(5) length_remains
      have IH2: "sorted (subarray (p + 1) (r + 1) a h')"
        by (cases "Suc p \<le> r", auto simp add: subarray_Nil)
           (* -- Secondly, both sublists remain partitioned. *)
      from partition_partitions[OF part True]
      have part_conds1: "\<forall>j. j \<in> set (subarray l p a h1) \<longrightarrow> j \<le> Array.get h1 a ! p "
        and part_conds2: "\<forall>j. j \<in> set (subarray (p + 1) (r + 1) a h1) \<longrightarrow> Array.get h1 a ! p \<le> j"
        by (auto simp add: all_in_set_subarray_conv)
      from quicksort_outer_remains [OF qs1] quicksort_permutes [OF qs1] True
        length_remains 1(5) pivot mset_sublist [of l p "Array.get h1 a" "Array.get h2 a"]
      have multiset_partconds1: "mset (subarray l p a h2) = mset (subarray l p a h1)"
        unfolding Array.length_def subarray_def by (cases p, auto)
      with left_subarray_remains part_conds1 pivot_unchanged
      have part_conds2': "\<forall>j. j \<in> set (subarray l p a h') \<longrightarrow> j \<le> Array.get h' a ! p"
        by (simp, subst set_mset_mset[symmetric], simp)
          (* -- These steps are the analogous for the right sublist \<dots> *)
      from quicksort_outer_remains [OF qs1] length_remains
      have right_subarray_remains: "subarray (p + 1) (r + 1) a h1 = subarray (p + 1) (r + 1) a h2"
        by (auto simp add: subarray_eq_samelength_iff)
      from quicksort_outer_remains [OF qs2] quicksort_permutes [OF qs2] True
        length_remains 1(5) pivot mset_sublist [of "p + 1" "r + 1" "Array.get h2 a" "Array.get h' a"]
      have multiset_partconds2: "mset (subarray (p + 1) (r + 1) a h') = mset (subarray (p + 1) (r + 1) a h2)"
        unfolding Array.length_def subarray_def by auto
      with right_subarray_remains part_conds2 pivot_unchanged
      have part_conds1': "\<forall>j. j \<in> set (subarray (p + 1) (r + 1) a h') \<longrightarrow> Array.get h' a ! p \<le> j"
        by (simp, subst set_mset_mset[symmetric], simp)
          (* -- Thirdly and finally, we show that the array is sorted
          following from the facts above. *)
      from True pivot 1(5) length_remains have "subarray l (r + 1) a h' = subarray l p a h' @ [Array.get h' a ! p] @ subarray (p + 1) (r + 1) a h'"
        by (simp add: subarray_nth_array_Cons, cases "l < p") (auto simp add: subarray_append subarray_Nil)
      with IH1' IH2 part_conds1' part_conds2' pivot have ?thesis
        unfolding subarray_def
        apply (auto simp add: sorted_append sorted_Cons all_in_set_sublist'_conv)
        by (auto simp add: set_sublist' dest: order.trans [of _ "Array.get h' a ! p"])
    }
    with True cr show ?thesis
      unfolding quicksort.simps [of a l r]
      by (elim effect_ifE effect_returnE effect_bindE effect_assertE) auto
  qed
qed

lemma quicksort_is_sort:
  assumes effect: "effect (quicksort a 0 (Array.length h a - 1)) h h' rs"
  shows "Array.get h' a = sort (Array.get h a)"
proof (cases "Array.get h a = []")
  case True
  with quicksort_is_skip[OF effect] show ?thesis
  unfolding Array.length_def by simp
next
  case False
  from quicksort_sorts [OF effect] False have "sorted (sublist' 0 (List.length (Array.get h a)) (Array.get h' a))"
    unfolding Array.length_def subarray_def by auto
  with length_remains[OF effect] have "sorted (Array.get h' a)"
    unfolding Array.length_def by simp
  with quicksort_permutes [OF effect] properties_for_sort show ?thesis by fastforce
qed

subsection \<open>No Errors in quicksort\<close>
text \<open>We have proved that quicksort sorts (if no exceptions occur).
We will now show that exceptions do not occur.\<close>

lemma success_part1I:
  assumes "l < Array.length h a" "r < Array.length h a"
  shows "success (part1 a l r p) h"
  using assms
proof (induct a l r p arbitrary: h rule: part1.induct)
  case (1 a l r p)
  thus ?case unfolding part1.simps [of a l r]
  apply (auto intro!: success_intros simp add: not_le)
  apply (auto intro!: effect_intros)
  done
qed

lemma success_bindI' [success_intros]: (*FIXME move*)
  assumes "success f h"
  assumes "\<And>h' r. effect f h h' r \<Longrightarrow> success (g r) h'"
  shows "success (f \<bind> g) h"
using assms(1) proof (rule success_effectE)
  fix h' r
  assume *: "effect f h h' r"
  with assms(2) have "success (g r) h'" .
  with * show "success (f \<bind> g) h" by (rule success_bind_effectI)
qed

lemma success_partitionI:
  assumes "l < r" "l < Array.length h a" "r < Array.length h a"
  shows "success (partition a l r) h"
using assms unfolding partition.simps swap_def
apply (auto intro!: success_bindI' success_ifI success_returnI success_nthI success_updI success_part1I elim!: effect_bindE effect_updE effect_nthE effect_returnE simp add:)
apply (frule part_length_remains)
apply (frule part_returns_index_in_bounds)
apply auto
apply (frule part_length_remains)
apply (frule part_returns_index_in_bounds)
apply auto
apply (frule part_length_remains)
apply auto
done

lemma success_quicksortI:
  assumes "l < Array.length h a" "r < Array.length h a"
  shows "success (quicksort a l r) h"
using assms
proof (induct a l r arbitrary: h rule: quicksort.induct)
  case (1 a l ri h)
  thus ?case
    unfolding quicksort.simps [of a l ri]
    apply (auto intro!: success_ifI success_bindI' success_returnI success_nthI success_updI success_assertI success_partitionI)
    apply (frule partition_returns_index_in_bounds)
    apply auto
    apply (frule partition_returns_index_in_bounds)
    apply auto
    apply (auto elim!: effect_assertE dest!: partition_length_remains length_remains)
    apply (subgoal_tac "Suc r \<le> ri \<or> r = ri")
    apply (erule disjE)
    apply auto
    unfolding quicksort.simps [of a "Suc ri" ri]
    apply (auto intro!: success_ifI success_returnI)
    done
qed

subsection \<open>Example\<close>

definition "qsort a = do {
    k \<leftarrow> Array.len a;
    quicksort a 0 (k - 1);
    return a
  }"

code_reserved SML upto

definition "example = do {
    a \<leftarrow> Array.of_list ([42, 2, 3, 5, 0, 1705, 8, 3, 15] :: nat list);
    qsort a
  }"

ML_val \<open>@{code example} ()\<close>

export_code qsort checking SML SML_imp OCaml? OCaml_imp? Haskell? Scala Scala_imp

end


section \<open>Induction of Menger's Theorem\<close>

theory MengerInduction imports Separations DisjointPaths begin

subsection \<open>No Small Separations\<close>

text \<open>
  In this section we set up the general structure of the proof of Menger's Theorem.
  The proof is based on induction over @{term sep_size} (called @{term n} in McCuaig's proof), the
  minimum size of a separator.
\<close>

locale NoSmallSeparationsInduct = v0_v1_Digraph +
  fixes sep_size :: nat
  \<comment> \<open>The size of a minimum separator.\<close>
  assumes no_small_separations: "\<And>S. Separation G v0 v1 S \<Longrightarrow> card S \<ge> Suc sep_size"
  \<comment> \<open>The induction hypothesis.\<close>
  and no_small_separations_hyp: "\<And>G' :: ('a, 'b) Graph_scheme.
    (\<And>S. Separation G' v0 v1 S \<Longrightarrow> card S \<ge> sep_size)
    \<Longrightarrow> v0_v1_Digraph G' v0 v1
    \<Longrightarrow> \<exists>paths. DisjointPaths G' v0 v1 paths \<and> card paths = sep_size"

text \<open>
  Next, we want to combine this with @{locale DisjointPathsPlusOne}.

  If a minimum separator has size at least @{term "Suc sep_size"}, then it follows immediately from
  the induction hypothesis that we have @{term sep_size} many disjoint paths.  We then observe
  that @{term second_vertices} of these paths is not a separator because
  @{term "card second_vertices = sep_size"}.  So there exists a new path from @{term v0} to
  @{term v1} whose second vertex is not in @{term second_vertices}.

  If this path is disjoint from the other paths, we have found @{term "Suc sep_size"} many disjoint
  paths, so assume it is not disjoint.  Then there exist a vertex @{term x} on the new path that is
  not @{term v0} or @{term v1} such that @{term new_last} hits one of the other paths.  Let
  @{term P_new} be the initial segment of the new path up to @{term x}.  We call @{term x},
  the last vertex of @{term P_new}, now @{term new_last}.

  We then assume that @{term paths} and @{term P_new} have been chosen in such a way that
  @{term "distance new_last v1"} is minimal.

  First, we define a locale that expresses that we have no small separators (with the corresponding
  induction hypothesis) as well as @{term sep_size} many internally vertex-disjoint paths (with
  @{term "sep_size \<noteq> (0 :: nat)"} because the other case is trivial) and also one additional path
  that starts in @{term v1}, whose second vertex is not among @{term second_vertices} and whose last
  vertex is @{term new_last}.

  We will add the assumption @{term "new_last \<noteq> v1"} soon.
\<close>

locale ProofStepInduct =
  NoSmallSeparationsInduct G v0 v1 sep_size + DisjointPathsPlusOne G v0 v1 paths P_new
  for G (structure) and v0 v1 paths P_new sep_size +
  assumes sep_size_not0: "sep_size \<noteq> 0"
    and paths_sep_size: "card paths = sep_size"

lemma (in ProofStepInduct) hitting_paths_v1: "hitting_paths v1"
  unfolding hitting_paths_def using paths v0_neq_v1 by force

subsection \<open>Choosing Paths Avoiding $new\_last$\<close>

text \<open>Let us now consider only the non-trivial case that @{term "new_last \<noteq> v1"}.\<close>

locale ProofStepInduct_NonTrivial = ProofStepInduct +
  assumes new_last_neq_v1: "new_last \<noteq> v1"
begin

text \<open>
  The next step is the observation that in the graph @{term "remove_vertex new_last"}, which
  we called @{term H_x}, there are also @{term sep_size} many internally vertex-disjoint paths,
  again by the induction hypothesis.
\<close>
lemma Q_exists: "\<exists>Q. DisjointPaths H_x v0 v1 Q \<and> card Q = sep_size"
proof-
  have "\<And>S. Separation H_x v0 v1 S \<Longrightarrow> card S \<ge> sep_size"
    using subgraph_separation_min_size paths walk_in_V P_hit new_last_neq_v1 no_small_separations
      by (metis H_x_def new_last_in_V new_last_neq_v0)
  then show ?thesis using H_x_v0_v1_Digraph new_last_neq_v1 by (meson no_small_separations_hyp)
qed

text \<open>
  We want to choose these paths in a clever way, too.  Our goal is to choose these paths such that
  the number of edges in @{term "(\<Union>(edges_of_walk ` Q) \<inter> (E - \<Union>(edges_of_walk ` paths_with_new)))"}
  is minimal.
\<close>

definition B where "B \<equiv> E - \<Union>(edges_of_walk ` paths_with_new)"

definition Q_weight where "Q_weight \<equiv> \<lambda>Q. card (\<Union>(edges_of_walk ` Q) \<inter> B)"

definition Q_good where "Q_good \<equiv> \<lambda>Q. DisjointPaths H_x v0 v1 Q \<and> card Q = sep_size \<and>
  (\<forall>Q'. DisjointPaths H_x v0 v1 Q' \<and> card Q' = sep_size \<longrightarrow> Q_weight Q \<le> Q_weight Q')"

definition Q where "Q \<equiv> SOME Q. Q_good Q"

text \<open>It is easy to show that such a @{const Q} exists.\<close>

lemma Q: "DisjointPaths H_x v0 v1 Q" "card Q = sep_size"
  and Q_min: "\<And>Q'. DisjointPaths H_x v0 v1 Q' \<and> card Q' = sep_size \<Longrightarrow> Q_weight Q \<le> Q_weight Q'"
proof-
  obtain Q' where "DisjointPaths H_x v0 v1 Q'" "card Q' = sep_size"
    "\<And>Q''. DisjointPaths H_x v0 v1 Q'' \<and> card Q'' = sep_size \<Longrightarrow> Q_weight Q' \<le> Q_weight Q''"
    using arg_min_ex[of "\<lambda>Q. DisjointPaths H_x v0 v1 Q \<and> card Q = sep_size" Q_weight]
      new_last_neq_v1 Q_exists by metis
  then have "Q_good Q'" unfolding Q_good_def by blast
  then show "DisjointPaths H_x v0 v1 Q" "card Q = sep_size"
    "\<And>Q'. DisjointPaths H_x v0 v1 Q' \<and> card Q' = sep_size \<Longrightarrow> Q_weight Q \<le> Q_weight Q'"
    using someI[of Q_good] by (simp_all add: Q_def Q_good_def)
qed

sublocale Q: DisjointPaths H_x v0 v1 Q using Q(1) .

subsection \<open>Finding a Path Avoiding $Q$\<close>

text \<open>
  Because @{const Q} contains only @{term sep_size} many paths, we have
  @{term "card Q.second_vertices = sep_size"}.  So there exists a path @{term P_k} among the
  @{term "Suc sep_size"} many paths in @{term paths_with_new} such that the second vertex of
  @{term P_k} is not among @{term Q.second_vertices}.
\<close>
definition P_k where
  "P_k \<equiv> SOME P_k. P_k \<in> paths_with_new \<and> hd (tl P_k) \<notin> Q.second_vertices"

lemma P_k: "P_k \<in> paths_with_new" "hd (tl P_k) \<notin> Q.second_vertices" proof-
  obtain y where "y \<in> insert (hd (tl P_new)) second_vertices" "y \<notin> Q.second_vertices" proof-
    have "hd (tl P_new) \<notin> second_vertices" using P_new_decomp tl_P_new(2) by simp
    moreover have "card second_vertices = card Q.second_vertices" using Q(2) paths_sep_size
      using Q.second_vertices_card second_vertices_card by (simp add: new_last_neq_v1)
    ultimately have "card (insert (hd (tl P_new)) second_vertices) = Suc (card Q.second_vertices)"
      using finite_paths second_vertices_def by auto
    then show ?thesis
      using that card_finite_less_ex
      by (metis Q.finite_paths Q.second_vertices_def Zero_not_Suc card_infinite finite_imageI lessI)
  qed
  then have "\<exists>P_k. P_k \<in> paths_with_new \<and> hd (tl P_k) \<notin> Q.second_vertices"
    by (metis (mono_tags, lifting) image_iff insertCI insertE paths_with_new_def second_vertex_def
        second_vertices_def)
  then show "P_k \<in> paths_with_new" "hd (tl P_k) \<notin> Q.second_vertices"
    using someI[of "\<lambda>P_k. P_k \<in> paths_with_new \<and> hd (tl P_k) \<notin> Q.second_vertices"] P_k_def by auto
qed

lemma path_P_k [simp]: "path P_k" by (simp add: P_k(1) paths_with_new_path)
lemma hd_P_k_v0 [simp]: "hd P_k = v0" by (simp add: P_k(1) paths_with_new_start_in_v0)

definition hitting_Q_or_new_last where
  "hitting_Q_or_new_last \<equiv> \<lambda>y. y \<noteq> v0 \<and> (y = new_last \<or> (\<exists>Q_hit \<in> Q. y \<in> set Q_hit))"

text \<open>
  @{term P_k} hits a vertex in @{term Q} or it hits @{term new_last} because it either ends in
  @{term v1} or in @{term new_last}.
\<close>

lemma P_k_hits_Q: "\<exists>y \<in> set P_k. hitting_Q_or_new_last y" proof (cases)
  assume "P_k \<noteq> P_new"
  then have "v1 \<in> set P_k"
    by (metis P_k(1) insertE last_in_set path_from_toE paths paths_with_new_def)
  moreover have "\<exists>Q_witness. Q_witness \<in> Q" using Q(2) sep_size_not0 finite.simps by fastforce
  ultimately show ?thesis
    using Q.paths path_from_toE hitting_Q_or_new_last_def v0_neq_v1 by fastforce
qed (metis P_new new_last_neq_v0 hitting_Q_or_new_last_def last_in_set path_from_toE new_last_def)

end \<comment> \<open>locale @{locale ProofStepInduct_NonTrivial}\<close>

subsection \<open>Decomposing $P_k$\<close>

text \<open>
  Having established with the previous lemma that @{term P_k} hits @{term Q} or @{term new_last},
  let @{term y} be the first such vertex on @{term P_k}.  Then we can split @{term P_k} at
  this vertex.
\<close>

locale ProofStepInduct_NonTrivial_P_k_pre = ProofStepInduct_NonTrivial +
  fixes P_k_pre y P_k_post
  assumes P_k_decomp: "P_k = P_k_pre @ y # P_k_post"
      and y: "hitting_Q_or_new_last y"
      and y_min: "\<And>y'. y' \<in> set P_k_pre \<Longrightarrow> \<not>hitting_Q_or_new_last y'"

text \<open>
  We can always go from @{locale ProofStepInduct_NonTrivial} to @{locale ProofStepInduct_NonTrivial_P_k_pre}.
\<close>
lemma (in ProofStepInduct_NonTrivial) ProofStepInduct_NonTrivial_P_k_pre_exists:
  shows "\<exists>P_k_pre y P_k_post.
     ProofStepInduct_NonTrivial_P_k_pre G v0 v1 paths P_new sep_size P_k_pre y P_k_post"
proof-
  obtain y P_k_pre P_k_post where
    "P_k = P_k_pre @ y # P_k_post" "hitting_Q_or_new_last y"
    "\<And>y'. y' \<in> set P_k_pre \<Longrightarrow> \<not>hitting_Q_or_new_last y'"
    using P_k_hits_Q split_list_first_prop[of P_k hitting_Q_or_new_last] by blast
  then have "ProofStepInduct_NonTrivial_P_k_pre G v0 v1 paths P_new sep_size P_k_pre y P_k_post"
    by unfold_locales
  then show ?thesis by blast
qed

context ProofStepInduct_NonTrivial_P_k_pre begin
  lemma y_neq_v0: "y \<noteq> v0" using hitting_Q_or_new_last_def y by auto

  lemma P_k_pre_not_Nil: "P_k_pre \<noteq> Nil"
    using P_k_decomp hd_P_k_v0 hitting_Q_or_new_last_def y by auto

  lemma second_P_k_pre_not_in_Q: "hd (tl (P_k_pre @ [y])) \<notin> Q.second_vertices"
    using P_k(2) P_k_decomp P_k_pre_not_Nil
    by (metis append_eq_append_conv2 append_self_conv hd_append2 list.sel(1) tl_append2)

  definition H where "H \<equiv> remove_vertex v0"
  sublocale H: Digraph H unfolding H_def using remove_vertex_Digraph .

  text \<open>If @{term "y = v1"}, then we are done.\<close>
  lemma y_eq_v1_solves:
    assumes "y = v1"
    shows "\<exists>paths. DisjointPaths G v0 v1 paths \<and> card paths = Suc sep_size"
  proof-
    have "P_k \<noteq> P_new" using y_eq_v1_implies_P_k_neq_P_new assms by blast
    then have "P_k = P_k_pre @ [y]"
      using P_k(1) P_k_decomp paths assms paths_with_new_def by fastforce
    then have "v0 \<leadsto>(P_k_pre @ [y])\<leadsto> v1"
      using paths P_k(1) \<open>P_k \<noteq> P_new\<close> by (simp add: paths_with_new_def)
    moreover have "new_last \<notin> set P_k_pre"
      using hitting_Q_or_new_last_def y_min new_last_neq_v0 by auto
    ultimately have "v0 \<leadsto>(P_k_pre @ [y])\<leadsto>\<^bsub>H_x\<^esub> v1" using remove_vertex_path_from_to
        by (simp add: H_x_def assms new_last_in_V new_last_neq_v1)
    moreover {
      fix xs v assume "xs \<in> Q" "v \<in> set xs" "v \<in> set (P_k_pre @ [y])" "v \<noteq> v0" "v \<noteq> v1"
      then have "v \<in> set P_k_pre" using assms by simp
      then have "\<not>hitting_Q_or_new_last v" using y_min by blast
      then have "False" using \<open>v \<in> set xs\<close> \<open>xs \<in> Q\<close> hitting_Q_or_new_last_def \<open>v \<noteq> v0\<close> by auto
    }
    ultimately have "DisjointPaths H_x v0 v1 (insert (P_k_pre @ [y]) Q)"
      using Q.DisjointPaths_extend by blast
    then have "DisjointPaths G v0 v1 (insert (P_k_pre @ [y]) Q)"
      using DisjointPaths_supergraph H_x_def new_last_in_V new_last_neq_v0 new_last_neq_v1 by auto
    moreover have "card (insert (P_k_pre @ [y]) Q) = Suc sep_size" proof-
      have "P_k_pre @ [y] \<notin> Q"
        by (metis P_k(2) Q.second_vertices_def \<open>P_k = P_k_pre @ [y]\<close> image_iff second_vertex_def)
      then show ?thesis by (simp add: Q(2) Q.finite_paths)
    qed
    ultimately show ?thesis by blast
  qed
end \<comment> \<open>locale @{locale ProofStepInduct_NonTrivial_P_k_pre}\<close>

end