theory MPI_Code
  imports
    Code_Setup
    "../Modified_Policy_Iteration"
    "HOL-Library.Code_Target_Numeral"
begin

sublocale MDP_nat_disc \<subseteq> MDP_MPI
  by unfold_locales

context MDP_Code begin

definition "d0 = D_Map.from_list' (\<lambda>s. fst (hd (a_inorder (s_lookup mdp s)))) [0..<states]"

definition "r_min_code =
  min 0 (MIN s \<in> set [0..<states]. MIN (_, r, _) \<in> set (a_inorder (s_lookup mdp s)). r)"

definition "v0_code = V_Map.arr_tabulate (\<lambda>s. r_min_code / (1 - l)) states"

definition "d0_code = D_Map.from_list' (\<lambda>s. fst (hd (a_inorder (s_lookup mdp s)))) [0..<states]"

definition "find_policy_L_code v =
  fold (\<lambda>s (d', v').
    let (ds, vs) = find_policy_state_code_aux' v s in
    (d_update s ds d', v_update s vs v')) [0..<states] (d_empty, V_Map.arr_tabulate (\<lambda>_. 0) states)"

definition "find_policy_L_code' v =
  fold (\<lambda>s (d', v').
    let (ds, vs) = find_policy_state_code_aux' v s in
    (d_update s ds d', v_update s vs v')) [0..<states] (d_empty, v)"

lemma fold_prod: "fold (\<lambda>x (a1, a2). (f x a1, g x a2)) xs (z1, z2) =
    (fold f xs z1, fold g xs z2)"
  by (induction xs arbitrary: z1 z2) auto

lemma s_lookup_entries_eq:
  assumes "s < states"
  shows "{(a, r, pmf_of_list k) | a r k. (a, r, k) \<in> A_Map.entries (s_lookup mdp s)}
     = {(a, MDP_r (s,a), MDP_K (s,a)) | a . a \<in> MDP_A s}"
proof -
  have "\<exists>k. MDP_K (s, a) = pmf_of_list k \<and> (a, MDP_r (s, a), k) \<in> A_Map.entries (s_lookup mdp s)"
    if "a \<in> MDP_A s" for a
    by (metis a_map_entries_lookup fst_sa_lookup'_eq assms prod.collapse snd_sa_lookup'_eq that)
  thus ?thesis
    using entries_A_eq_K assms entries_A_eq_r
    by (auto simp: a_inorderD(1))
qed

lemma a_lookup_entries: "A_Map.invar m \<Longrightarrow> kv \<in> A_Map.entries m \<Longrightarrow> a_lookup' m (fst kv) = snd kv"
  by (metis A_Map.inorder_lookup_Some a_lookup'_def option.case(2) prod.collapse)

lemma a_inorder_eq_MDP_A: "x < states \<Longrightarrow> fst ` set (a_inorder (s_lookup mdp x)) = MDP_A x"
  using A_Map.keys_def MDP_A_def by presburger

lemma find_policy_L_code_split:
  assumes "v_len v = states" "v_invar v"
  shows "fst (find_policy_L_code v) = vi_find_policy_code v"
    "\<And>i. i < states \<Longrightarrow> v_lookup (snd (find_policy_L_code v)) i = v_lookup (\<L>_code v) i "
    "v_len (snd (find_policy_L_code v)) = states"
    "v_invar (snd (find_policy_L_code v))"
proof (goal_cases)
  have **: "(x,y) \<in> A_Map.entries ( (s_lookup mdp i)) \<Longrightarrow> (a_lookup' (s_lookup mdp i) x) = y"
    if "i < states" for i x y
    by (simp add: A_Map.inorder_lookup_Some a_lookup'_def invar_s_lookup that)

  have *: "find_policy_L_code v =
    (vi_find_policy_code v,
     fold (\<lambda>s. v_update s (snd (find_policy_state_code_aux' v s))) [0..<states]
      (V_Map.arr_tabulate (\<lambda>_.0) states))"
    unfolding find_policy_L_code_def vi_find_policy_code_def
    by (simp add: foldl_conv_fold case_prod_beta fold_prod D_Map.from_list'_def)

  have **:
    "v_lookup (fold (\<lambda>s. v_update s (snd (find_policy_state_code_aux' v s))) [0..<states] v0) i =
      v_lookup (\<L>_code v) i"
    if "i < states" for i
    unfolding \<L>_code_def \<L>_GS_code_def V_Map.arr_tabulate_def
    using V_Map.invar_array v0_correct
    using A_Map.is_empty_def A_Map.invar_def A_Map.entries_def
    using ne_s_lookup invar_s_lookup a_lookup_entries
    using that
    by (auto simp: fold_max_eq_arg_max' image_image case_prod_beta find_policy_state_code_aux_eq
        V_Map.lookup_array v_lookup_fold)
  case 1
  thus ?case using * by auto

  case 3
  show ?case
    unfolding *
    by (auto simp: V_len_fold)
  case 4
  show ?case
    unfolding *
    by (auto simp: V_invar_fold)
  case (2 i) thus ?case
    using **
    by (auto simp: * v0_def)
qed

definition "L_code d v =
  V_Map.arr_tabulate (\<lambda>s.  L\<^sub>a_code (a_lookup' (s_lookup mdp s) (d_lookup' d s)) v) states"

lemma L_code_correct:
  assumes "s < states" "v_len v = states" "v_invar v"
    "D_Map.keys d = MDP.state_space" "D_Map.invar d" "(\<And>s. s < states \<Longrightarrow> d_lookup' d s \<in> MDP_A s)"
  shows
    "v_lookup (L_code d v) s = MDP.L (MDP.mk_dec_det (D_Map.map_to_fun d)) (V_Map.map_to_bfun v) s"
  using assms
  unfolding L_code_def MDP.L_eq_L\<^sub>a_det
  by (auto simp: map_to_fun_lookup L_GS_code_correct')

lemma L_code_invar: "v_invar (L_code d v)"
  by (simp add: L_code_def)

lemma L_code_keys:
  assumes "v_len v = states" "v_invar v"
    "D_Map.keys d = MDP.state_space" "D_Map.invar d" "(\<And>s. s < states \<Longrightarrow> d_lookup' d s \<in> MDP_A s)"
  shows "v_len (L_code d v) = states"
  by (simp add: L_code_def)

definition "L_pow_code v d m = (L_code d ^^ m) v"

lemma L_pow_code_Suc: "L_pow_code v d (Suc m) = L_code d (L_pow_code v d m)"
  by (auto simp: L_pow_code_def)

lemma L_code_to_bfun:
  assumes "v_len v = states" "v_invar v"
    "D_Map.keys d = MDP.state_space" "D_Map.invar d" "(\<And>s. s < states \<Longrightarrow> d_lookup' d s \<in> MDP_A s)"
  shows "V_Map.map_to_bfun (L_code d v) =
      MDP.L (MDP.mk_dec_det  (D_Map.map_to_fun d)) (V_Map.map_to_bfun v)"
proof (rule bfun_eqI)
  fix s
  show "(V_Map.map_to_bfun (L_code d v)) s =
    (MDP.L (MDP.mk_dec_det (D_Map.map_to_fun d)) (V_Map.map_to_bfun v)) s"
  proof (cases "s < states")
    case True
    then show ?thesis
      using L_code_correct assms
      by (auto simp: L_code_def v_lookup_map_to_bfun)
  next
    case False
    then show ?thesis
      using assms
      by (subst MDP.L_zero) (auto simp: L_code_def V_Map.map_to_bfun.rep_eq split: option.splits)
  qed
qed

lemma L_pow_code_correct:
  assumes "v_len v = states" "v_invar v"
    "D_Map.keys d = MDP.state_space" "D_Map.invar d" "(\<And>s. s < states \<Longrightarrow> d_lookup' d s \<in> MDP_A s)"
  shows
    "v_len (L_pow_code v d m) = states"
    "v_invar (L_pow_code v d m)"
    "V_Map.map_to_bfun (L_pow_code v d m) = ((MDP.L_pow (V_Map.map_to_bfun v) ((D_Map.map_to_fun d))) m) "
  using assms
proof (induction m arbitrary: v)
  case (Suc m)
  {
    case 3
    then show ?case
      using Suc
      by (auto simp: L_pow_code_def L_code_to_bfun  MDP.L_pow_def)
  }
qed (auto simp add: L_pow_code_def L_code_to_bfun L_code_def MDP.L_pow_def)

partial_function (tailrec) mpi_partial_code  where
  "mpi_partial_code eps d v m =
  (let (d', v') = find_policy_L_code v in (
    if l = 0 \<or> check_dist v v' eps
    then (d', v)
    else mpi_partial_code eps d' (L_pow_code v' d' m) m))"

lemmas mpi_partial_code.simps[code]

lemma vi_find_policy_code_correct':
  assumes "v_len v_code = states" "v_invar v_code"
  shows "d_lookup (vi_find_policy_code v_code) s = (
  if s < states then Some (MDP.find_policy' (V_Map.map_to_bfun v_code) s) else None)"
  using assms vi_find_policy_code_correct[of v_code s] d_invar_vi_find_policy_code
  using d_keys_vi_find_policy_code D_Map.lookup_None_set_inorder[of "vi_find_policy_code v_code" s]
  unfolding MDP.find_policy'_def D_Map.map_to_fun_def
  by (auto simp: least_arg_max_def MDP.is_opt_act_def vi_find_policy_code_notin split: option.splits)

lemma L\<^sub>a_equiv: "(L\<^sub>a_code (a_lookup' (s_lookup mdp s) (d_lookup' d s)) v) = (L\<^sub>a_code (a_lookup' (s_lookup mdp s) (d_lookup' d s)) v')"
  if "\<And>i. i < states \<Longrightarrow> v_lookup v i = v_lookup v' i" "s < states" "v_len v = states" "v_len v' = states" "v_invar v" "v_invar v'"
    "D_Map.keys d = MDP.state_space" "D_Map.invar d" "(\<And>s. s < states \<Longrightarrow> d_lookup' d s \<in> MDP_A s)"
  for s v v' d
proof -
  have "V_Map.map_to_bfun v = V_Map.map_to_bfun v'"
    using that
    by (auto simp: V_Map.map_to_bfun.rep_eq)
  moreover have *: "L\<^sub>a_code (a_lookup' (s_lookup mdp s) (d_lookup' d s)) v = MDP.L\<^sub>a (d_lookup' d s) (apply_bfun (V_Map.map_to_bfun v)) s"
    using that snd_sa_lookup'_eq pmf_of_list_wf_mdp set_list_pmf_in_states[of s "(d_lookup' d s)"]
    by (subst L\<^sub>a_code_correct[of s _ _ "(d_lookup' d s)"]) (fastforce simp add: fst_sa_lookup'_eq)+
  ultimately show ?thesis
    unfolding *
    using that snd_sa_lookup'_eq pmf_of_list_wf_mdp set_list_pmf_in_states[of s " d_lookup' d s"]
    by (subst L\<^sub>a_code_correct[of s _ _ "(d_lookup' d s)"]) (auto simp add: fst_sa_lookup'_eq )
qed

lemma L_code_equiv: "v_lookup (L_code d v) i = v_lookup (L_code d v') i"
  if "\<And>i. i < states \<Longrightarrow> v_lookup v i = v_lookup v' i" "i < states" "D_Map.keys d = MDP.state_space" "D_Map.invar d" "(\<And>s. s < states \<Longrightarrow> d_lookup' d s \<in> MDP_A s)"
    "v_len v = states" "v_len v' = states" "v_invar v" "v_invar v'"
  unfolding L_code_def
  using that
  by (auto intro!: L\<^sub>a_equiv)

lemma L_pow_code_equiv: "v_lookup (L_pow_code v d m) i = v_lookup (L_pow_code v' d m) i" if "\<And>i. i < states \<Longrightarrow> v_lookup v i = v_lookup v' i" "i < states"
  "D_Map.keys d = MDP.state_space" "D_Map.invar d" "(\<And>s. s < states \<Longrightarrow> d_lookup' d s \<in> MDP_A s)" "v_len v = states" "v_len v' = states" "v_invar v" "v_invar v'"
for v v' d i m
  using that L_code_invar
proof (induction m arbitrary: v v' i)
  case 0
  then show ?case by (simp add: L_pow_code_def)
next
  case (Suc m)
  thus ?case
    unfolding L_pow_code_Suc
    using L_pow_code_correct L_code_equiv
    by presburger
qed

lemma map_to_bfun_snd_find_policy_L_code:
  assumes "v_len v_code = states" "v_invar v_code"
  shows "V_Map.map_to_bfun (snd (find_policy_L_code v_code)) = V_Map.map_to_bfun(\<L>_code v_code)"
  using invar_\<L>_code
  by (auto simp: V_Map.map_to_bfun.rep_eq assms find_policy_L_code_split)

lemma mpi_partial_code_correct:
  fixes eps d_code v_code m_code

assumes "MDP.mpi_algo_dom eps (d, v, m)"
assumes "v = V_Map.map_to_bfun v_code"
assumes "d = D_Map.map_to_fun d_code"
assumes "m = (\<lambda>(a::nat) (b:: nat \<Rightarrow>\<^sub>b real). m_code)"
assumes "eps > 0"
assumes "d \<in> MDP.D\<^sub>D"
assumes "v \<le> MDP.\<L>\<^sub>b v"
assumes "v_invar v_code"
assumes "v_len v_code = states"
shows
  "D_Map.map_to_fun (fst (mpi_partial_code eps d_code v_code m_code)) = fst (MDP.mpi_algo eps d v m)"
  "V_Map.map_to_bfun (snd (mpi_partial_code eps d_code v_code m_code)) = snd (MDP.mpi_algo eps d v m)"
proof -
  have "MDP.mpi_algo eps d v m = (D_Map.map_to_fun (fst (mpi_partial_code eps d_code v_code m_code)),
    V_Map.map_to_bfun (snd (mpi_partial_code eps d_code v_code m_code)))"
    using assms
  proof (induction d v m arbitrary: d_code v_code m_code rule: MDP.mpi_algo.pinduct)
    case (1 d v m)
    then show ?case
    proof (cases "l = 0")
      case True
      have *: "mpi_partial_code eps d_code v_code m_code = (let (d', v') = find_policy_L_code v_code in (d', v_code))" for v_code
        using True mpi_partial_code.simps by presburger
      have "MDP.mpi_algo eps (D_Map.map_to_fun d_code) (V_Map.map_to_bfun v_code) (\<lambda>a b. m_code) = (MDP.find_policy' v, v)"
        using 1 True MDP.mpi_algo.psimps
        by auto
      also have "\<dots> = (D_Map.map_to_fun (fst (mpi_partial_code eps d_code v_code m_code)), V_Map.map_to_bfun (snd (mpi_partial_code eps d_code v_code m_code)))"
        using "1.prems"
        by (auto simp: * case_prod_beta vi_find_policy_correct find_policy_L_code_split)
      finally show ?thesis
        unfolding 1
        by auto
    next
      case False
      hence "check_dist v_code (\<L>_code v_code) eps \<longleftrightarrow> dist v (MDP.\<L>\<^sub>b v) <  (eps * (1 - l)) / (2 * l)"
        using 1 invar_\<L>_code assms(6) \<L>_code_correct'
        by (auto simp: check_dist_correct)
      hence *: "check_dist v_code (\<L>_code v_code) eps \<longleftrightarrow> 2 * l * dist v (MDP.\<L>\<^sub>b v) <  eps * (1 - l)"
        using zero_le_disc_locale False
        by (auto simp: algebra_simps less_divide_eq)
      then show ?thesis
      proof (cases "check_dist v_code (\<L>_code v_code) eps")
        case True
        hence "2 * l * dist v (MDP.\<L>\<^sub>b v) <  eps * (1 - l)"
          using * by auto
        hence *: "MDP.mpi_algo eps d v m = (MDP.find_policy' v, v)"
          by (simp add: MDP.mpi_algo.domintros MDP.mpi_algo.psimps)
        moreover have **:
          "(mpi_partial_code eps d_code v_code m_code) = (fst (find_policy_L_code v_code), v_code)"
          using "1.prems" True False
          by (simp add: mpi_partial_code.simps check_dist_def find_policy_L_code_split case_prod_beta)
        ultimately show ?thesis
          using "1.prems"
          by (simp add: find_policy_L_code_split vi_find_policy_correct)
      next
        case False
        hence not_check: "\<not>2 * l * dist v (MDP.\<L>\<^sub>b v) <  eps * (1 - l)"
          using * by auto

        have d_in_A: "\<And>s. s < states \<Longrightarrow> d_lookup' (vi_find_policy_code v_code) s \<in> MDP_A s"
          unfolding d_lookup'_def
          using "1.prems" MDP.find_policy'_is_dec_det MDP.is_dec_det_def
          by (auto simp: vi_find_policy_code_correct' )
        have aux: "V_Map.map_to_bfun (L_pow_code  v_code (vi_find_policy_code v_code) (Suc m_code)) =
          V_Map.map_to_bfun (L_pow_code (\<L>_code v_code) (vi_find_policy_code v_code) m_code)"
        proof -
          have **: "i < states \<Longrightarrow> v_lookup (L_code (vi_find_policy_code v_code) v_code) i = v_lookup (\<L>_code v_code) i" for i
            using  d_in_A d_invar_vi_find_policy_code d_keys_vi_find_policy_code
            using "1.prems"(7,8) MDP.\<nu>_improving_imp_\<L>\<^sub>b[OF MDP.find_policy'_improving]
            by (auto simp: L_code_correct \<L>_code_correct vi_find_policy_correct)

          have *: "V_Map.map_to_bfun (L_pow_code  v_code (vi_find_policy_code v_code) (Suc m_code)) =
            V_Map.map_to_bfun (L_pow_code (L_code (vi_find_policy_code v_code) v_code) (vi_find_policy_code v_code) m_code)"
            by (simp add: L_pow_code_def funpow_swap1)
          show ?thesis
            unfolding *
            by (auto intro!: bfun_eqI L_pow_code_equiv simp: L_pow_code_correct(1,2)
                d_invar_vi_find_policy_code d_keys_vi_find_policy_code
                L_code_keys L_code_invar invar_\<L>_code keys_\<L>_code
                V_Map.map_to_bfun.rep_eq ** "1.prems"(7,8) d_in_A)
        qed
        have "MDP.mpi_algo eps d v m = MDP.mpi_algo eps (D_Map.map_to_fun d_code) (V_Map.map_to_bfun v_code) (\<lambda>a b. m_code)"
          using 1 by auto
        also have "\<dots> =
           MDP.mpi_algo eps (MDP.find_policy' v) (MDP.L_pow v (MDP.find_policy' v) (Suc m_code)) m"
          using 1 not_check by (auto simp: MDP.mpi_algo.psimps)
        also have "\<dots> = MDP.mpi_algo eps (D_Map.map_to_fun (vi_find_policy_code v_code)) (MDP.L_pow (V_Map.map_to_bfun v_code) (D_Map.map_to_fun (vi_find_policy_code v_code)) (Suc m_code)) m"
          using 1 by (auto simp: vi_find_policy_correct[symmetric])
        also have "\<dots> = MDP.mpi_algo eps (D_Map.map_to_fun (vi_find_policy_code v_code)) (V_Map.map_to_bfun (L_pow_code  v_code (vi_find_policy_code v_code) (Suc m_code))) m"
          using 1 L_pow_code_correct(3) d_in_A d_invar_vi_find_policy_code d_keys_vi_find_policy_code
          by auto
        also have "\<dots> = MDP.mpi_algo eps (D_Map.map_to_fun (vi_find_policy_code v_code)) (V_Map.map_to_bfun (L_pow_code (\<L>_code v_code) (vi_find_policy_code v_code) m_code)) m"
          using aux by auto
        also have "\<dots> = (let (d', v') = (mpi_partial_code eps (vi_find_policy_code v_code) (L_pow_code (\<L>_code v_code) (vi_find_policy_code v_code) m_code) m_code) in
        (D_Map.map_to_fun d', V_Map.map_to_bfun v'))"
        proof -
          have
            [simp]: "v_invar (L_pow_code (\<L>_code v_code) (vi_find_policy_code v_code) m_code)"
            and [simp]: "v_len (L_pow_code (\<L>_code v_code) (vi_find_policy_code v_code) m_code) = states"
            and L_pow_code_eq:
            "MDP.L_pow (V_Map.map_to_bfun v_code) (MDP.find_policy' (V_Map.map_to_bfun v_code)) (Suc m_code) = V_Map.map_to_bfun (L_pow_code (\<L>_code v_code) (vi_find_policy_code v_code) m_code)"
            using d_in_A keys_\<L>_code invar_\<L>_code 1 d_keys_vi_find_policy_code d_invar_vi_find_policy_code L_pow_code_correct
            by (auto simp: aux[symmetric] vi_find_policy_correct)
          show ?thesis
            unfolding Let_def case_prod_beta
            using MDP.find_policy'_is_dec_det not_check "1.prems"(6)
            by (subst 1(2)[symmetric]) (auto simp: "1.prems" L_pow_code_eq[symmetric] vi_find_policy_correct intro!: MDP.L_pow_\<L>\<^sub>b_mono_inv')
        qed
        also have "\<dots> = MDP.mpi_algo eps (MDP.find_policy' v) (MDP.L_pow v (MDP.find_policy' v) (Suc (m 0 v))) (\<lambda>a. m (Suc a))"
          unfolding Let_def case_prod_beta
          using \<open>l\<noteq> 0\<close> not_check
          using MDP.find_policy'_is_dec_det d_invar_vi_find_policy_code d_keys_vi_find_policy_code
          using MDP.L_pow_\<L>\<^sub>b_mono_inv'  vi_find_policy_correct
          using "1.prems" L_pow_code_correct d_in_A   invar_\<L>_code keys_\<L>_code
          by (auto simp: 1(2)[symmetric] aux[symmetric])
        also have "\<dots> = (D_Map.map_to_fun (fst (mpi_partial_code eps d_code v_code m_code)), V_Map.map_to_bfun (snd (mpi_partial_code eps d_code v_code m_code)))"
        proof -
          have *: "MDP.L_pow (V_Map.map_to_bfun v_code) (MDP.find_policy' (V_Map.map_to_bfun v_code)) (Suc m_code) =
        V_Map.map_to_bfun (L_pow_code (snd (find_policy_L_code v_code)) (fst (find_policy_L_code v_code)) m_code)"
            using d_keys_vi_find_policy_code d_invar_vi_find_policy_code d_in_A
            using "1.prems" L_pow_code_correct aux invar_\<L>_code map_to_bfun_snd_find_policy_L_code vi_find_policy_correct
            by (auto simp: find_policy_L_code_split)
          show ?thesis
            unfolding mpi_partial_code.simps[of _ _ v_code]
            using not_check False "1.prems"
            using d_in_A d_invar_vi_find_policy_code d_keys_vi_find_policy_code
              find_policy_L_code_split MDP.L_pow_\<L>\<^sub>b_mono_inv' *[symmetric]
            using MDP.find_policy'_is_dec_det
            by (auto simp: case_prod_beta check_dist_def 1(2)[symmetric] L_pow_code_correct vi_find_policy_correct)
        qed
        finally show "MDP.mpi_algo eps d v m = (D_Map.map_to_fun (fst (mpi_partial_code eps d_code v_code m_code)), V_Map.map_to_bfun (snd (mpi_partial_code eps d_code v_code m_code)))"
          by auto
      qed
    qed
  qed
  thus "D_Map.map_to_fun (fst (mpi_partial_code eps d_code v_code m_code)) = fst (MDP.mpi_algo eps d v m)" " V_Map.map_to_bfun (snd (mpi_partial_code eps d_code v_code m_code)) = snd (MDP.mpi_algo eps d v m)"
    using assms
    by (auto simp: MDP.termination_mpi_algo)
qed

lemma d_map_to_fun_from_list': "D_Map.map_to_fun (D_Map.from_list' f xs) a = (if a \<in> set xs then f a else 0)"
  by (simp add: d_lookup'_def map_to_fun_lookup map_to_fun_notin)

definition "MPI_code eps m =
  (if eps \<le> 0 then undefined else
    let (d, v) = mpi_partial_code eps d0_code v0_code m in d)"

lemma d0_code_is_dec_det: "MDP.is_dec_det (D_Map.map_to_fun d0_code)"
  unfolding d0_code_def  A_Map.keys_def  MDP.is_dec_det_def MDP_A_def
  using MDP_A_outside ne_s_lookup A_Map.is_empty_def
  by (auto split: option.splits simp: d_map_to_fun_from_list')

lemma Min_cong: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> f x = g x) \<Longrightarrow> (MIN x \<in> X. f x) = (MIN x \<in> X. g x)"
  by force

lemma r_min_code_correct:
  assumes "states > 0"
  shows "r_min_code = MDP.r_min"
proof -
  have bounded_r': "bounded ((\<lambda>a. MDP_r (x, a)) ` MDP_A x)" for x
    using MDP.r_bounded'
    unfolding bounded_def
    by simp (meson UNIV_I)
  have *: "(\<Sqinter>a\<in>MDP_A x. MDP_r (x, a)) \<le> MDP_r (x,a)" if "a \<in> MDP_A x" for  a x
    using  bounded_r' that
    by (auto intro!: cInf_lower bounded_imp_bdd_below)
  have ****: "MDP_r (s,a) \<le> MDP.r\<^sub>M" for s a
    using abs_le_iff MDP.abs_r_le_r\<^sub>M by blast
  have **: "bounded (range (\<lambda>s'. \<Sqinter>a\<in>MDP_A s'. MDP_r (s', a)))"
    using MDP.abs_r_le_r\<^sub>M  MDP.ex_dec_det MDP.is_dec_det_def MDP.A_ne
    by (auto simp add: minus_le_iff abs_le_iff intro!: cINF_greatest order.trans[OF *]  boundedI[of _ "MDP.r\<^sub>M"])
  have "MDP.r_min \<le> MDP_r (s, a)" if "a \<in> MDP_A s" for s a
    using  MDP.r_bounded' that **
    by (auto intro!: bounded_imp_bdd_below cInf_lower2[OF _ *])
  have bdd: "bdd_below ((\<lambda>x. \<Sqinter>a\<in>MDP_A x. MDP_r (x, a)) ` {states..})"
    using "**" bounded_real by (auto intro!: bounded_imp_bdd_below)
  have "(\<Sqinter>x. (\<Sqinter>a\<in>MDP_A x. MDP_r (x, a))) =  (\<Sqinter>x\<in>{0..<states} \<union> {states..}. (\<Sqinter>a\<in>MDP_A x. MDP_r (x, a)))"
    by (simp add: ivl_disj_un_one(8))
  also have "\<dots> = min (\<Sqinter>x\<in>{0..<states}. (\<Sqinter>a\<in>MDP_A x. MDP_r (x, a))) (\<Sqinter>x\<in>{states..}. (\<Sqinter>a\<in>MDP_A x. MDP_r (x, a)))"
    using bdd
    by (auto simp add: image_Un cInf_union_distrib inf_min assms)
  also have "\<dots> = min (\<Sqinter>x\<in>{0..<states}. (\<Sqinter>a\<in>MDP_A x. MDP_r (x, a))) (\<Sqinter>x\<in>{states..}. (\<Sqinter>a\<in>MDP_A x. 0))"
    using MDP_r_zero_notin_states by auto
  also have "\<dots> = min (\<Sqinter>x\<in>{0..<states}. (\<Sqinter>a\<in>MDP_A x. MDP_r (x, a))) 0"
    by auto
  also have "\<dots> = min (MIN x\<in>{0..<states}. (MIN a\<in>MDP_A x. MDP_r (x, a))) 0"
    using assms
    by (simp add: cInf_eq_Min)
  also have "\<dots> = r_min_code"
    unfolding r_min_code_def
    using assms A_Map.is_empty_def ne_s_lookup A_Map.entries_def entries_A_eq_r
    by (auto simp: case_prod_beta MDP_A_def A_Map.keys_def min.commute image_image
        intro!: Min_cong cong[of "min 0", OF refl])
  finally show ?thesis..
qed

lemma v0_code_correct: "s < states \<Longrightarrow> v_lookup v0_code s = (MDP.v0_mpi\<^sub>b s)"
  unfolding v0_code_def MDP.v0_mpi\<^sub>b.rep_eq  MDP.v0_mpi_def
  by (auto simp add: not_less MDP_r_zero_notin_states r_min_code_correct)

lemma v0_invar: "v_invar v0_code"
  by (simp add: v0_code_def)

lemma v0_keys: "v_len v0_code = states"
  by (simp add: v0_code_def)

lemma L\<^sub>a_indep_notin:
  assumes "s < states"
  shows "MDP.L\<^sub>a d (apply_bfun v) s = MDP.L\<^sub>a d (bfun_if (\<lambda>s. s < states) v u) s"
proof -
  have " measure_pmf.expectation (MDP_K (s, d)) v =
    measure_pmf.expectation (MDP_K (s, d)) (\<lambda>s. if s < states then v s else u s)"
    using MDP_K_closed assms
    by (auto intro!: AE_pmfI integral_cong_AE simp: subset_eq)
  thus ?thesis
    by (auto simp: bfun_if.rep_eq)
qed

lemma \<L>\<^sub>b_indep_notin: "s < states \<Longrightarrow> MDP.\<L>\<^sub>b v s = MDP.\<L>\<^sub>b (bfun_if (\<lambda>s. s < states) v u) s"
  unfolding MDP.\<L>\<^sub>b_eq_SUP_L\<^sub>a'
  using L\<^sub>a_indep_notin by presburger

lemma
  v0_code_inc_\<L>\<^sub>b:
  "V_Map.map_to_bfun v0_code \<le> MDP.\<L>\<^sub>b (V_Map.map_to_bfun v0_code)"
proof (rule less_eq_bfunI)
  fix x
  show "(V_Map.map_to_bfun v0_code) x \<le> (MDP.\<L>\<^sub>b (V_Map.map_to_bfun v0_code)) x"
  proof (cases "x < states")
    case True
    have "(V_Map.map_to_bfun v0_code) x = MDP.v0_mpi\<^sub>b x"
      using True v0_keys
      by (simp add: True V_Map.map_to_bfun.rep_eq v0_code_correct v0_invar)
    also have "\<dots> \<le> MDP.\<L>\<^sub>b MDP.v0_mpi\<^sub>b x"
      using MDP.v0_mpi\<^sub>b_le_\<L>\<^sub>b by blast
    also have "\<dots> = MDP.\<L>\<^sub>b ((bfun_if (\<lambda>s. s < states) (V_Map.map_to_bfun v0_code)) (MDP.v0_mpi\<^sub>b)) x"
      using v0_invar
      by (auto simp: apply_bfun_inverse bfun_if_def V_Map.map_to_bfun.rep_eq v0_code_correct MDP.L_def v0_keys MDP.\<L>_def cong: if_cong)
    also have "\<dots> =  MDP.\<L>\<^sub>b (V_Map.map_to_bfun v0_code) x"
      using True \<L>\<^sub>b_indep_notin by presburger
    finally show ?thesis.
  next
    case False
    then show ?thesis
      by (simp add: MDP.\<L>\<^sub>b_zero v0_code_def V_Map.map_to_bfun.rep_eq)
  qed
qed

lemma
  fixes eps m_code
  defines "d_opt_code \<equiv> (MPI_code eps m_code)"
  defines "m \<equiv> (\<lambda>(a::nat) (b:: nat \<Rightarrow>\<^sub>b real). m_code)"
  assumes "eps > 0"
  defines "v \<equiv> V_Map.map_to_bfun v0_code"
  defines "d \<equiv> D_Map.map_to_fun d0_code"
  defines "m \<equiv> (\<lambda>(a::nat) (b:: nat \<Rightarrow>\<^sub>b real). m_code)"
  shows
    "D_Map.map_to_fun d_opt_code = fst (MDP.mpi_algo eps d v m)"
  unfolding d_def v_def m_def d_opt_code_def MPI_code_def
  using assms d0_code_is_dec_det v0_code_inc_\<L>\<^sub>b v0_invar MDP.termination_mpi_algo
  by (auto simp: v0_keys case_prod_beta intro!: mpi_partial_code_correct(1))
end

global_interpretation MPI_Code: MDP_Code
(* state map (transition system) *)
"IArray.sub" "\<lambda>n x arr. IArray ((IArray.list_of arr)[n:= x])" "IArray.length" "IArray" "IArray.list_of" "\<lambda>_. True"

(* action map *)
RBT_Set.empty RBT_Map.update RBT_Map.delete Lookup2.lookup Tree2.inorder rbt

"MDP.transitions (Rep_Valid_MDP mdp)" "MDP.states (Rep_Valid_MDP mdp)"

(* value map *)
starray_get "\<lambda>i x arr. starray_set arr i x"  starray_length starray_of_list  "\<lambda>arr. starray_foldr (\<lambda>x xs. x # xs) arr []" "\<lambda>_. True"

(* decision rule map *)
RBT_Set.empty RBT_Map.update RBT_Map.delete Lookup2.lookup Tree2.inorder rbt

"MDP.disc (Rep_Valid_MDP mdp)"
for mdp
defines MPI_code = MPI_Code.MPI_code
  and a_lookup' = MPI_Code.a_lookup'
  and d_lookup' = MPI_Code.d_lookup'

and check_dist = MPI_Code.check_dist

and entries = M.entries
and from_list' = M.from_list'

and mpi_partial_code = MPI_Code.mpi_partial_code
and L\<^sub>a_code = MPI_Code.L\<^sub>a_code
and L_pow_code = MPI_Code.L_pow_code
and L_code = MPI_Code.L_code

and find_policy_state_code_aux' = MPI_Code.find_policy_state_code_aux'
and find_policy_state_code_aux = MPI_Code.find_policy_state_code_aux
and find_policy_L_code = MPI_Code.find_policy_L_code

and r_min_code = MPI_Code.r_min_code
and v0_code = MPI_Code.v0_code
and d0_code = MPI_Code.d0_code
and arr_tabulate = starray_Array.arr_tabulate
  using Rep_Valid_MDP
  by unfold_locales
    (auto simp: pmf_of_list_wf_def Ball_set_list_all[symmetric] case_prod_beta is_MDP_def
      RBT_Set.empty_def M.invar_def empty_def M.entries_def M.is_empty_def length_0_conv[symmetric])

lemmas entries_def[unfolded M.entries_def, code]
lemmas from_list'_def[unfolded M.from_list'_def, code]
lemmas arr_tabulate_def[unfolded starray_Array.arr_tabulate_def, code]

end


(*  Title:      HOL/Hahn_Banach/Bounds.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>Bounds\<close>

theory Bounds
imports Main "HOL-Analysis.Continuum_Not_Denumerable"
begin

locale lub =
  fixes A and x
  assumes least [intro?]: "(\<And>a. a \<in> A \<Longrightarrow> a \<le> b) \<Longrightarrow> x \<le> b"
    and upper [intro?]: "a \<in> A \<Longrightarrow> a \<le> x"

lemmas [elim?] = lub.least lub.upper

definition the_lub :: "'a::order set \<Rightarrow> 'a"  ("\<Squnion>_" [90] 90)
  where "the_lub A = The (lub A)"

lemma the_lub_equality [elim?]:
  assumes "lub A x"
  shows "\<Squnion>A = (x::'a::order)"
proof -
  interpret lub A x by fact
  show ?thesis
  proof (unfold the_lub_def)
    from \<open>lub A x\<close> show "The (lub A) = x"
    proof
      fix x' assume lub': "lub A x'"
      show "x' = x"
      proof (rule order_antisym)
        from lub' show "x' \<le> x"
        proof
          fix a assume "a \<in> A"
          then show "a \<le> x" ..
        qed
        show "x \<le> x'"
        proof
          fix a assume "a \<in> A"
          with lub' show "a \<le> x'" ..
        qed
      qed
    qed
  qed
qed

lemma the_lubI_ex:
  assumes ex: "\<exists>x. lub A x"
  shows "lub A (\<Squnion>A)"
proof -
  from ex obtain x where x: "lub A x" ..
  also from x have [symmetric]: "\<Squnion>A = x" ..
  finally show ?thesis .
qed

lemma real_complete: "\<exists>a::real. a \<in> A \<Longrightarrow> \<exists>y. \<forall>a \<in> A. a \<le> y \<Longrightarrow> \<exists>x. lub A x"
  by (intro exI[of _ "Sup A"]) (auto intro!: cSup_upper cSup_least simp: lub_def)

end


(*  Title:      HOL/HOLCF/Domain_Aux.thy
    Author:     Brian Huffman
*)

section \<open>Domain package support\<close>

theory Domain_Aux
imports Map_Functions Fixrec
begin

subsection \<open>Continuous isomorphisms\<close>

text \<open>A locale for continuous isomorphisms\<close>

locale iso =
  fixes abs :: "'a \<rightarrow> 'b"
  fixes rep :: "'b \<rightarrow> 'a"
  assumes abs_iso [simp]: "rep\<cdot>(abs\<cdot>x) = x"
  assumes rep_iso [simp]: "abs\<cdot>(rep\<cdot>y) = y"
begin

lemma swap: "iso rep abs"
  by (rule iso.intro [OF rep_iso abs_iso])

lemma abs_below: "(abs\<cdot>x \<sqsubseteq> abs\<cdot>y) = (x \<sqsubseteq> y)"
proof
  assume "abs\<cdot>x \<sqsubseteq> abs\<cdot>y"
  then have "rep\<cdot>(abs\<cdot>x) \<sqsubseteq> rep\<cdot>(abs\<cdot>y)" by (rule monofun_cfun_arg)
  then show "x \<sqsubseteq> y" by simp
next
  assume "x \<sqsubseteq> y"
  then show "abs\<cdot>x \<sqsubseteq> abs\<cdot>y" by (rule monofun_cfun_arg)
qed

lemma rep_below: "(rep\<cdot>x \<sqsubseteq> rep\<cdot>y) = (x \<sqsubseteq> y)"
  by (rule iso.abs_below [OF swap])

lemma abs_eq: "(abs\<cdot>x = abs\<cdot>y) = (x = y)"
  by (simp add: po_eq_conv abs_below)

lemma rep_eq: "(rep\<cdot>x = rep\<cdot>y) = (x = y)"
  by (rule iso.abs_eq [OF swap])

lemma abs_strict: "abs\<cdot>\<bottom> = \<bottom>"
proof -
  have "\<bottom> \<sqsubseteq> rep\<cdot>\<bottom>" ..
  then have "abs\<cdot>\<bottom> \<sqsubseteq> abs\<cdot>(rep\<cdot>\<bottom>)" by (rule monofun_cfun_arg)
  then have "abs\<cdot>\<bottom> \<sqsubseteq> \<bottom>" by simp
  then show ?thesis by (rule bottomI)
qed

lemma rep_strict: "rep\<cdot>\<bottom> = \<bottom>"
  by (rule iso.abs_strict [OF swap])

lemma abs_defin': "abs\<cdot>x = \<bottom> \<Longrightarrow> x = \<bottom>"
proof -
  have "x = rep\<cdot>(abs\<cdot>x)" by simp
  also assume "abs\<cdot>x = \<bottom>"
  also note rep_strict
  finally show "x = \<bottom>" .
qed

lemma rep_defin': "rep\<cdot>z = \<bottom> \<Longrightarrow> z = \<bottom>"
  by (rule iso.abs_defin' [OF swap])

lemma abs_defined: "z \<noteq> \<bottom> \<Longrightarrow> abs\<cdot>z \<noteq> \<bottom>"
  by (erule contrapos_nn, erule abs_defin')

lemma rep_defined: "z \<noteq> \<bottom> \<Longrightarrow> rep\<cdot>z \<noteq> \<bottom>"
  by (rule iso.abs_defined [OF iso.swap]) (rule iso_axioms)

lemma abs_bottom_iff: "(abs\<cdot>x = \<bottom>) = (x = \<bottom>)"
  by (auto elim: abs_defin' intro: abs_strict)

lemma rep_bottom_iff: "(rep\<cdot>x = \<bottom>) = (x = \<bottom>)"
  by (rule iso.abs_bottom_iff [OF iso.swap]) (rule iso_axioms)

lemma casedist_rule: "rep\<cdot>x = \<bottom> \<or> P \<Longrightarrow> x = \<bottom> \<or> P"
  by (simp add: rep_bottom_iff)

lemma compact_abs_rev: "compact (abs\<cdot>x) \<Longrightarrow> compact x"
proof (unfold compact_def)
  assume "adm (\<lambda>y. abs\<cdot>x \<notsqsubseteq> y)"
  with cont_Rep_cfun2
  have "adm (\<lambda>y. abs\<cdot>x \<notsqsubseteq> abs\<cdot>y)" by (rule adm_subst)
  then show "adm (\<lambda>y. x \<notsqsubseteq> y)" using abs_below by simp
qed

lemma compact_rep_rev: "compact (rep\<cdot>x) \<Longrightarrow> compact x"
  by (rule iso.compact_abs_rev [OF iso.swap]) (rule iso_axioms)

lemma compact_abs: "compact x \<Longrightarrow> compact (abs\<cdot>x)"
  by (rule compact_rep_rev) simp

lemma compact_rep: "compact x \<Longrightarrow> compact (rep\<cdot>x)"
  by (rule iso.compact_abs [OF iso.swap]) (rule iso_axioms)

lemma iso_swap: "(x = abs\<cdot>y) = (rep\<cdot>x = y)"
proof
  assume "x = abs\<cdot>y"
  then have "rep\<cdot>x = rep\<cdot>(abs\<cdot>y)" by simp
  then show "rep\<cdot>x = y" by simp
next
  assume "rep\<cdot>x = y"
  then have "abs\<cdot>(rep\<cdot>x) = abs\<cdot>y" by simp
  then show "x = abs\<cdot>y" by simp
qed

end

subsection \<open>Proofs about take functions\<close>

text \<open>
  This section contains lemmas that are used in a module that supports
  the domain isomorphism package; the module contains proofs related
  to take functions and the finiteness predicate.
\<close>

lemma deflation_abs_rep:
  fixes abs and rep and d
  assumes abs_iso: "\<And>x. rep\<cdot>(abs\<cdot>x) = x"
  assumes rep_iso: "\<And>y. abs\<cdot>(rep\<cdot>y) = y"
  shows "deflation d \<Longrightarrow> deflation (abs oo d oo rep)"
by (rule ep_pair.deflation_e_d_p) (simp add: ep_pair.intro assms)

lemma deflation_chain_min:
  assumes chain: "chain d"
  assumes defl: "\<And>n. deflation (d n)"
  shows "d m\<cdot>(d n\<cdot>x) = d (min m n)\<cdot>x"
proof (rule linorder_le_cases)
  assume "m \<le> n"
  with chain have "d m \<sqsubseteq> d n" by (rule chain_mono)
  then have "d m\<cdot>(d n\<cdot>x) = d m\<cdot>x"
    by (rule deflation_below_comp1 [OF defl defl])
  moreover from \<open>m \<le> n\<close> have "min m n = m" by simp
  ultimately show ?thesis by simp
next
  assume "n \<le> m"
  with chain have "d n \<sqsubseteq> d m" by (rule chain_mono)
  then have "d m\<cdot>(d n\<cdot>x) = d n\<cdot>x"
    by (rule deflation_below_comp2 [OF defl defl])
  moreover from \<open>n \<le> m\<close> have "min m n = n" by simp
  ultimately show ?thesis by simp
qed

lemma lub_ID_take_lemma:
  assumes "chain t" and "(\<Squnion>n. t n) = ID"
  assumes "\<And>n. t n\<cdot>x = t n\<cdot>y" shows "x = y"
proof -
  have "(\<Squnion>n. t n\<cdot>x) = (\<Squnion>n. t n\<cdot>y)"
    using assms(3) by simp
  then have "(\<Squnion>n. t n)\<cdot>x = (\<Squnion>n. t n)\<cdot>y"
    using assms(1) by (simp add: lub_distribs)
  then show "x = y"
    using assms(2) by simp
qed

lemma lub_ID_reach:
  assumes "chain t" and "(\<Squnion>n. t n) = ID"
  shows "(\<Squnion>n. t n\<cdot>x) = x"
using assms by (simp add: lub_distribs)

lemma lub_ID_take_induct:
  assumes "chain t" and "(\<Squnion>n. t n) = ID"
  assumes "adm P" and "\<And>n. P (t n\<cdot>x)" shows "P x"
proof -
  from \<open>chain t\<close> have "chain (\<lambda>n. t n\<cdot>x)" by simp
  from \<open>adm P\<close> this \<open>\<And>n. P (t n\<cdot>x)\<close> have "P (\<Squnion>n. t n\<cdot>x)" by (rule admD)
  with \<open>chain t\<close> \<open>(\<Squnion>n. t n) = ID\<close> show "P x" by (simp add: lub_distribs)
qed

subsection \<open>Finiteness\<close>

text \<open>
  Let a ``decisive'' function be a deflation that maps every input to
  either itself or bottom.  Then if a domain's take functions are all
  decisive, then all values in the domain are finite.
\<close>

definition
  decisive :: "('a::pcpo \<rightarrow> 'a) \<Rightarrow> bool"
where
  "decisive d \<longleftrightarrow> (\<forall>x. d\<cdot>x = x \<or> d\<cdot>x = \<bottom>)"

lemma decisiveI: "(\<And>x. d\<cdot>x = x \<or> d\<cdot>x = \<bottom>) \<Longrightarrow> decisive d"
  unfolding decisive_def by simp

lemma decisive_cases:
  assumes "decisive d" obtains "d\<cdot>x = x" | "d\<cdot>x = \<bottom>"
using assms unfolding decisive_def by auto

lemma decisive_bottom: "decisive \<bottom>"
  unfolding decisive_def by simp

lemma decisive_ID: "decisive ID"
  unfolding decisive_def by simp

lemma decisive_ssum_map:
  assumes f: "decisive f"
  assumes g: "decisive g"
  shows "decisive (ssum_map\<cdot>f\<cdot>g)"
  apply (rule decisiveI)
  subgoal for s
    apply (cases s, simp_all)
     apply (rule_tac x=x in decisive_cases [OF f], simp_all)
    apply (rule_tac x=y in decisive_cases [OF g], simp_all)
    done
  done

lemma decisive_sprod_map:
  assumes f: "decisive f"
  assumes g: "decisive g"
  shows "decisive (sprod_map\<cdot>f\<cdot>g)"
  apply (rule decisiveI)
  subgoal for s
    apply (cases s, simp)
    subgoal for x y
      apply (rule decisive_cases [OF f, where x = x], simp_all)
      apply (rule decisive_cases [OF g, where x = y], simp_all)
      done
    done
  done

lemma decisive_abs_rep:
  fixes abs rep
  assumes iso: "iso abs rep"
  assumes d: "decisive d"
  shows "decisive (abs oo d oo rep)"
  apply (rule decisiveI)
  subgoal for s
    apply (rule decisive_cases [OF d, where x="rep\<cdot>s"])
     apply (simp add: iso.rep_iso [OF iso])
    apply (simp add: iso.abs_strict [OF iso])
    done
  done

lemma lub_ID_finite:
  assumes chain: "chain d"
  assumes lub: "(\<Squnion>n. d n) = ID"
  assumes decisive: "\<And>n. decisive (d n)"
  shows "\<exists>n. d n\<cdot>x = x"
proof -
  have 1: "chain (\<lambda>n. d n\<cdot>x)" using chain by simp
  have 2: "(\<Squnion>n. d n\<cdot>x) = x" using chain lub by (rule lub_ID_reach)
  have "\<forall>n. d n\<cdot>x = x \<or> d n\<cdot>x = \<bottom>"
    using decisive unfolding decisive_def by simp
  hence "range (\<lambda>n. d n\<cdot>x) \<subseteq> {x, \<bottom>}"
    by auto
  hence "finite (range (\<lambda>n. d n\<cdot>x))"
    by (rule finite_subset, simp)
  with 1 have "finite_chain (\<lambda>n. d n\<cdot>x)"
    by (rule finite_range_imp_finch)
  then have "\<exists>n. (\<Squnion>n. d n\<cdot>x) = d n\<cdot>x"
    unfolding finite_chain_def by (auto simp add: maxinch_is_thelub)
  with 2 show "\<exists>n. d n\<cdot>x = x" by (auto elim: sym)
qed

lemma lub_ID_finite_take_induct:
  assumes "chain d" and "(\<Squnion>n. d n) = ID" and "\<And>n. decisive (d n)"
  shows "(\<And>n. P (d n\<cdot>x)) \<Longrightarrow> P x"
using lub_ID_finite [OF assms] by metis

subsection \<open>Proofs about constructor functions\<close>

text \<open>Lemmas for proving nchotomy rule:\<close>

lemma ex_one_bottom_iff:
  "(\<exists>x. P x \<and> x \<noteq> \<bottom>) = P ONE"
by simp

lemma ex_up_bottom_iff:
  "(\<exists>x. P x \<and> x \<noteq> \<bottom>) = (\<exists>x. P (up\<cdot>x))"
by (safe, case_tac x, auto)

lemma ex_sprod_bottom_iff:
 "(\<exists>y. P y \<and> y \<noteq> \<bottom>) =
  (\<exists>x y. (P (:x, y:) \<and> x \<noteq> \<bottom>) \<and> y \<noteq> \<bottom>)"
by (safe, case_tac y, auto)

lemma ex_sprod_up_bottom_iff:
 "(\<exists>y. P y \<and> y \<noteq> \<bottom>) =
  (\<exists>x y. P (:up\<cdot>x, y:) \<and> y \<noteq> \<bottom>)"
by (safe, case_tac y, simp, case_tac x, auto)

lemma ex_ssum_bottom_iff:
 "(\<exists>x. P x \<and> x \<noteq> \<bottom>) =
 ((\<exists>x. P (sinl\<cdot>x) \<and> x \<noteq> \<bottom>) \<or>
  (\<exists>x. P (sinr\<cdot>x) \<and> x \<noteq> \<bottom>))"
by (safe, case_tac x, auto)

lemma exh_start: "p = \<bottom> \<or> (\<exists>x. p = x \<and> x \<noteq> \<bottom>)"
  by auto

lemmas ex_bottom_iffs =
   ex_ssum_bottom_iff
   ex_sprod_up_bottom_iff
   ex_sprod_bottom_iff
   ex_up_bottom_iff
   ex_one_bottom_iff

text \<open>Rules for turning nchotomy into exhaust:\<close>

lemma exh_casedist0: "\<lbrakk>R; R \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P" (* like make_elim *)
  by auto

lemma exh_casedist1: "((P \<or> Q \<Longrightarrow> R) \<Longrightarrow> S) \<equiv> (\<lbrakk>P \<Longrightarrow> R; Q \<Longrightarrow> R\<rbrakk> \<Longrightarrow> S)"
  by rule auto

lemma exh_casedist2: "(\<exists>x. P x \<Longrightarrow> Q) \<equiv> (\<And>x. P x \<Longrightarrow> Q)"
  by rule auto

lemma exh_casedist3: "(P \<and> Q \<Longrightarrow> R) \<equiv> (P \<Longrightarrow> Q \<Longrightarrow> R)"
  by rule auto

lemmas exh_casedists = exh_casedist1 exh_casedist2 exh_casedist3

text \<open>Rules for proving constructor properties\<close>

lemmas con_strict_rules =
  sinl_strict sinr_strict spair_strict1 spair_strict2

lemmas con_bottom_iff_rules =
  sinl_bottom_iff sinr_bottom_iff spair_bottom_iff up_defined ONE_defined

lemmas con_below_iff_rules =
  sinl_below sinr_below sinl_below_sinr sinr_below_sinl con_bottom_iff_rules

lemmas con_eq_iff_rules =
  sinl_eq sinr_eq sinl_eq_sinr sinr_eq_sinl con_bottom_iff_rules

lemmas sel_strict_rules =
  cfcomp2 sscase1 sfst_strict ssnd_strict fup1

lemma sel_app_extra_rules:
  "sscase\<cdot>ID\<cdot>\<bottom>\<cdot>(sinr\<cdot>x) = \<bottom>"
  "sscase\<cdot>ID\<cdot>\<bottom>\<cdot>(sinl\<cdot>x) = x"
  "sscase\<cdot>\<bottom>\<cdot>ID\<cdot>(sinl\<cdot>x) = \<bottom>"
  "sscase\<cdot>\<bottom>\<cdot>ID\<cdot>(sinr\<cdot>x) = x"
  "fup\<cdot>ID\<cdot>(up\<cdot>x) = x"
by (cases "x = \<bottom>", simp, simp)+

lemmas sel_app_rules =
  sel_strict_rules sel_app_extra_rules
  ssnd_spair sfst_spair up_defined spair_defined

lemmas sel_bottom_iff_rules =
  cfcomp2 sfst_bottom_iff ssnd_bottom_iff

lemmas take_con_rules =
  ssum_map_sinl' ssum_map_sinr' sprod_map_spair' u_map_up
  deflation_strict deflation_ID ID1 cfcomp2

subsection \<open>ML setup\<close>

named_theorems domain_deflation "theorems like deflation a ==> deflation (foo_map$a)"
  and domain_map_ID "theorems like foo_map$ID = ID"

ML_file \<open>Tools/Domain/domain_take_proofs.ML\<close>
ML_file \<open>Tools/cont_consts.ML\<close>
ML_file \<open>Tools/cont_proc.ML\<close>
ML_file \<open>Tools/Domain/domain_constructors.ML\<close>
ML_file \<open>Tools/Domain/domain_induction.ML\<close>

end


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 "nodeSet"}.
      The following parameters are used:
        - transition function @{text "f"} (typically @{text "(h M)"} for some FSM @{text "M"})
        - a source state @{text "q0"} (selection terminates as soon as this states is assigned some input)
        - a list of inputs that may be assigned to states
        - a list of states not yet taken (these are considered when searching for the next possible
          assignment)
        - a set @{text "nodeSet"} of all nodes that already have an input assigned to them by @{text "m"}
        - 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 [] nodeSet m = (case find (\<lambda> x . f (q0,x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q0,x) . (q'' \<in> nodeSet))) inputList of
      Some x \<Rightarrow> m@[(q0,x)] |
      None   \<Rightarrow> m)" |
  "select_inputs f q0 inputList (n#nL) nodeSet m =
    (case find (\<lambda> x . f (q0,x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q0,x) . (q'' \<in> nodeSet))) 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> nodeSet))) (n#nL) inputList
          of None            \<Rightarrow> m |
             Some (q',x,nodeList') \<Rightarrow> select_inputs f q0 inputList nodeList' (insert q' nodeSet) (m@[(q',x)])))"
  by pat_completeness auto
termination
apply (relation "measure (\<lambda> (f,q0,iL,nL,nS,m) . length nL)")
 apply simp
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 nodeSet :: "'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> nodeSet)) inputList = None"
     and "find_remove_2 (\<lambda>q' x. f (q', x) \<noteq> {} \<and> (\<forall>(y, q'')\<in>f (q', x). q'' \<in> nodeSet)) (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> nodeSet)) (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 show "((f, q0, inputList, nL', insert q nodeSet, m @ [(q, x)]), f, q0, inputList, n # nL, nodeSet, m)
              \<in> measure (\<lambda>(f, q0, iL, nL, nS, m). length nL)"
    by auto
qed

lemma select_inputs_length :
  "length (select_inputs f q0 inputList nodeList nodeSet m) \<le> (length m) + Suc (length nodeList)"
proof (induction "length nodeList" arbitrary: nodeList nodeSet 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> nodeSet)) inputList"; auto)
next
  case (Suc k)
  then obtain n nL where "nodeList = 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> nodeSet))) 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> nodeSet))) nodeList 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> nodeSet)) inputList = None\<close>
        unfolding \<open>nodeList = n # nL\<close> by auto
    next
      case (Some a)
      then obtain q' x nodeList' where *: "find_remove_2 (\<lambda> q' x . f (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q',x) . (q'' \<in> nodeSet))) (n#nL) inputList
                                            = Some (q',x,nodeList')"
        unfolding \<open>nodeList = n # nL\<close> by (metis prod_cases3)
      have "k = length nodeList'"
        using find_remove_2_length[OF *] \<open>Suc k = length nodeList\<close>
        unfolding \<open>nodeList = n # nL\<close>
        by simp
      show ?thesis
        using Suc.hyps(1)[of nodeList' "insert q' nodeSet" "m@[(q',x)]", OF \<open>k = length nodeList'\<close>]
        unfolding \<open>nodeList = n # nL\<close> select_inputs.simps None * find_remove_2_length[OF *]
        by simp
    qed
  next
    case (Some a)
    then show ?thesis
      unfolding \<open>nodeList = n # nL\<close> by auto
  qed
qed

lemma select_inputs_length_min :
  "length (select_inputs f q0 inputList nodeList nodeSet m) \<ge> (length m)"
proof (induction "length nodeList" arbitrary: nodeList nodeSet 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> nodeSet)) inputList"; auto)
next
  case (Suc k)
  then obtain n nL where "nodeList = 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> nodeSet))) 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> nodeSet))) nodeList 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> nodeSet)) inputList = None\<close>
        unfolding \<open>nodeList = n # nL\<close> by auto
    next
      case (Some a)
      then obtain q' x nodeList' where *: "find_remove_2 (\<lambda> q' x . f (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q',x) . (q'' \<in> nodeSet))) (n#nL) inputList
                                              = Some (q',x,nodeList')"
        unfolding \<open>nodeList = n # nL\<close> by (metis prod_cases3)
      have "k = length nodeList'"
        using find_remove_2_length[OF *] \<open>Suc k = length nodeList\<close>
        unfolding \<open>nodeList = n # nL\<close>
        by simp
      show ?thesis
        unfolding \<open>nodeList = n # nL\<close> select_inputs.simps None * find_remove_2_length[OF *]
        using Suc.hyps(1)[of nodeList' "m@[(q',x)]" "insert q' nodeSet" , OF \<open>k = length nodeList'\<close>]
        by simp
    qed
  next
    case (Some a)
    then show ?thesis unfolding \<open>nodeList = 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 nodeList nodeSet m) = m"
proof (induction "length nodeList" arbitrary: nodeList nodeSet 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> nodeSet)) inputList"; auto)
next
  case (Suc k)
  then obtain n nL where "nodeList = 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> nodeSet))) 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> nodeSet))) nodeList 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> nodeSet)) inputList = None\<close>
        unfolding \<open>nodeList = n # nL\<close> by auto
    next
      case (Some a)
      then obtain q' x nodeList' where *: "find_remove_2 (\<lambda> q' x . f (q',x) \<noteq> {} \<and> (\<forall> (y,q'') \<in> f (q',x) . (q'' \<in> nodeSet))) (n#nL) inputList
                                            = Some (q',x,nodeList')"
        unfolding \<open>nodeList = n # nL\<close>
        by (metis prod_cases3)
      have "k = length nodeList'"
        using find_remove_2_length[OF *] \<open>Suc k = length nodeList\<close>
        unfolding \<open>nodeList = n # nL\<close>
        by simp

      have **: "(select_inputs f q0 inputList nodeList nodeSet m)
                  = select_inputs f q0 inputList nodeList' (insert q' nodeSet) (m @ [(q', x)])"
        unfolding \<open>nodeList = n # nL\<close> select_inputs.simps None *
        by simp
      show ?thesis
        unfolding **
        using Suc.hyps(1)[of nodeList' "m@[(q',x)]" "insert q' nodeSet" , OF \<open>k = length nodeList'\<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>nodeList = 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 (mono_tags, lifting) case_prod_beta' 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 (mono_tags, lifting) case_prod_beta' 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_nodes S \<Longrightarrow> h S (q,x) \<noteq> {} \<Longrightarrow> h S (q,x) = h M (q,x)"
  and     "\<And> q . q \<in> reachable_nodes S \<Longrightarrow> deadlock_state S q \<Longrightarrow> q \<in> nS0 \<union> set (map fst m)"
  and     "nodes 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_nodes_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_nodes_initial]  by fastforce

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

    then have "(initial S) \<in> nodes M"
      using reachable_node_is_node 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_nodes M" using fsm_transition_target unfolding h.simps
        using \<open>FSM.initial S \<in> reachable_nodes M\<close> reachable_nodes_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_node_is_node by force
      moreover have "q'' \<noteq> (initial S)"
        using acyclic_no_self_loop[OF \<open>acyclic S\<close> reachable_nodes_initial]
        using \<open>(y,q'') \<in> h M ((initial S),x)\<close> assms(4)[OF reachable_nodes_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_nodes 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_node[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_nodes_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_nodes_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_nodes_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_nodes 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_nodes 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>nodes M = insert (initial S) (set nL \<union> nS0 \<union> set (map fst m))\<close>
        using \<open>q \<in> reachable_nodes S\<close>  \<open>q \<notin> (nS0 \<union> set (map fst m))\<close>
        by (metis (no_types, lifting) Suc.prems(2) UnE insertE reachable_node_is_node 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_nodes 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: "nodes 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