section \<open>Implementations of the H-Method\<close>

theory H_Method_Implementations
imports Intermediate_Frameworks Pair_Framework "../Distinguishability" Test_Suite_Representations "../OFSM_Tables_Refined" "HOL-Library.List_Lexorder"
begin

subsection \<open>Using the H-Framework\<close>

definition h_method_via_h_framework :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "h_method_via_h_framework = h_framework_dynamic (\<lambda> M V t X l . False)"

definition h_method_via_h_framework_lists :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> (('b\<times>'c) \<times> bool) list list" where
  "h_method_via_h_framework_lists M m completeInputTraces useInputHeuristic = sorted_list_of_maximal_sequences_in_tree (test_suite_from_io_tree M (initial M) (h_method_via_h_framework M m completeInputTraces useInputHeuristic))"

lemma h_method_via_h_framework_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('e,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (h_method_via_h_framework M1 m completeInputTraces useInputHeuristic)) = (L M2 \<inter> set (h_method_via_h_framework M1 m completeInputTraces useInputHeuristic)))"
and "finite_tree (h_method_via_h_framework M1 m completeInputTraces useInputHeuristic)"
  using h_framework_dynamic_completeness_and_finiteness[OF assms]
  unfolding h_method_via_h_framework_def
  by blast+

lemma h_method_via_h_framework_lists_completeness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> list_all (passes_test_case M2 (initial M2)) (h_method_via_h_framework_lists M1 m completeInputTraces useInputHeuristic)"
  using h_framework_dynamic_lists_completeness[OF assms]
  unfolding h_method_via_h_framework_lists_def h_framework_dynamic_lists_def h_method_via_h_framework_def
  by blast

subsection \<open>Using the Pair-Framework\<close>

subsubsection \<open>Selection of Distinguishing Traces\<close>

fun add_distinguishing_sequence_if_required :: "('a \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list) \<Rightarrow> ('a,'b::linorder,'c::linorder) fsm \<Rightarrow> (('b\<times>'c) list \<times> 'a) \<times> (('b\<times>'c) list \<times> 'a) \<Rightarrow> ('b\<times>'c) prefix_tree \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "add_distinguishing_sequence_if_required dist_fun M ((\<alpha>,q1), (\<beta>,q2)) t = (if intersection_is_distinguishing M (after t \<alpha>) q1 (after t \<beta>) q2
    then empty
    else insert empty (dist_fun q1 q2))"

lemma add_distinguishing_sequence_if_required_distinguishes :
  assumes "observable M"
  and     "minimal M"
  and     "\<alpha> \<in> L M"
  and     "\<beta> \<in> L M"
  and     "after_initial M \<alpha> \<noteq> after_initial M \<beta>"
  and     "\<And> q1 q2 . q1 \<in> states M \<Longrightarrow> q2 \<in> states M \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> distinguishes M q1 q2 (dist_fun q1 q2)"
shows "\<exists> io \<in> set ((add_distinguishing_sequence_if_required dist_fun M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t) \<union> (set (after t \<alpha>) \<inter> set (after t \<beta>)) .  distinguishes M (after_initial M \<alpha>) (after_initial M \<beta>) io"
proof (cases "intersection_is_distinguishing M (after t \<alpha>) (after_initial M \<alpha>) (after t \<beta>) (after_initial M \<beta>)")
  case True
  then have "(add_distinguishing_sequence_if_required dist_fun M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t = empty"
    by auto
  then have "set ((add_distinguishing_sequence_if_required dist_fun M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t) \<union> (set (after t \<alpha>) \<inter> set (after t \<beta>)) = (set (after t \<alpha>) \<inter> set (after t \<beta>))"
    using Prefix_Tree.set_empty
    by (metis Int_insert_right inf.absorb_iff2 inf_bot_right insert_is_Un set_Nil sup_absorb2)
  moreover have "\<exists> io \<in> (set (after t \<alpha>) \<inter> set (after t \<beta>)) .  distinguishes M (after_initial M \<alpha>) (after_initial M \<beta>) io"
    using True unfolding intersection_is_distinguishing_correctness[OF assms(1) after_is_state[OF assms(1,3)] after_is_state[OF assms(1,4)]]
    by auto
  ultimately show ?thesis
    by blast
next
  case False
  then have "set ((add_distinguishing_sequence_if_required dist_fun M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t) = set (insert empty (dist_fun (after_initial M \<alpha>) (after_initial M \<beta>)))"
    by auto
  then have "dist_fun (after_initial M \<alpha>) (after_initial M \<beta>) \<in> set ((add_distinguishing_sequence_if_required dist_fun M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t) \<union> (set (after t \<alpha>) \<inter> set (after t \<beta>))"
    unfolding insert_set by auto
  then show ?thesis
    using assms(6)[OF after_is_state[OF assms(1,3)] after_is_state[OF assms(1,4)] assms(5)] by blast
qed

lemma add_distinguishing_sequence_if_required_finite :
  "finite_tree ((add_distinguishing_sequence_if_required dist_fun M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t)"
proof (cases "intersection_is_distinguishing M (after t \<alpha>) (after_initial M \<alpha>) (after t \<beta>) (after_initial M \<beta>)")
  case True
  then have "((add_distinguishing_sequence_if_required dist_fun M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t) = empty"
    by auto
  then show ?thesis
    using empty_finite_tree by simp
next
  case False
  then have "((add_distinguishing_sequence_if_required dist_fun M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t) = (insert empty (dist_fun (after_initial M \<alpha>) (after_initial M \<beta>)))"
    by auto
  then show ?thesis
    using insert_finite_tree[OF empty_finite_tree] by metis
qed

fun add_distinguishing_sequence_and_complete_if_required :: "('a \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list) \<Rightarrow> bool \<Rightarrow> ('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> (('b\<times>'c) list \<times> 'a) \<times> (('b\<times>'c) list \<times> 'a) \<Rightarrow> ('b\<times>'c) prefix_tree \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "add_distinguishing_sequence_and_complete_if_required distFun completeInputTraces M ((\<alpha>,q1), (\<beta>,q2)) t =
    (if intersection_is_distinguishing M (after t \<alpha>) q1 (after t \<beta>) q2
      then empty
      else let w = distFun q1 q2;
               T = insert empty w
            in if completeInputTraces
              then let T1 = from_list (language_for_input M q1 (map fst w));
                       T2 = from_list (language_for_input M q2 (map fst w))
                   in Prefix_Tree.combine T (Prefix_Tree.combine T1 T2)
              else T)"

lemma add_distinguishing_sequence_and_complete_if_required_distinguishes :
  assumes "observable M"
  and     "minimal M"
  and     "\<alpha> \<in> L M"
  and     "\<beta> \<in> L M"
  and     "after_initial M \<alpha> \<noteq> after_initial M \<beta>"
  and     "\<And> q1 q2 . q1 \<in> states M \<Longrightarrow> q2 \<in> states M \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> distinguishes M q1 q2 (dist_fun q1 q2)"
shows "\<exists> io \<in> set ((add_distinguishing_sequence_and_complete_if_required dist_fun c M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t) \<union> (set (after t \<alpha>) \<inter> set (after t \<beta>)) .  distinguishes M (after_initial M \<alpha>) (after_initial M \<beta>) io"
proof (cases "intersection_is_distinguishing M (after t \<alpha>) (after_initial M \<alpha>) (after t \<beta>) (after_initial M \<beta>)")
  case True
  then have "(add_distinguishing_sequence_if_required dist_fun M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t = empty"
    by auto
  then have "set ((add_distinguishing_sequence_if_required dist_fun M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t) \<union> (set (after t \<alpha>) \<inter> set (after t \<beta>)) = (set (after t \<alpha>) \<inter> set (after t \<beta>))"
    using Prefix_Tree.set_empty
    by (metis Int_insert_right inf.absorb_iff2 inf_bot_right insert_is_Un set_Nil sup_absorb2)
  moreover have "\<exists> io \<in> (set (after t \<alpha>) \<inter> set (after t \<beta>)) .  distinguishes M (after_initial M \<alpha>) (after_initial M \<beta>) io"
    using True unfolding intersection_is_distinguishing_correctness[OF assms(1) after_is_state[OF assms(1,3)] after_is_state[OF assms(1,4)]]
    by auto
  ultimately show ?thesis
    by blast
next
  case False
  then have "set (insert empty (dist_fun (after_initial M \<alpha>) (after_initial M \<beta>))) \<subseteq> set ((add_distinguishing_sequence_and_complete_if_required dist_fun c M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t)"
    using combine_set[of "insert empty (dist_fun (after_initial M \<alpha>) (after_initial M \<beta>))"]
    unfolding add_distinguishing_sequence_and_complete_if_required.simps Let_def
    by (cases c; fastforce)
  moreover have "dist_fun (after_initial M \<alpha>) (after_initial M \<beta>) \<in> set (insert empty (dist_fun (after_initial M \<alpha>) (after_initial M \<beta>)))"
    unfolding insert_set by auto
  ultimately have "dist_fun (after_initial M \<alpha>) (after_initial M \<beta>) \<in> set ((add_distinguishing_sequence_and_complete_if_required dist_fun c M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t) \<union> (set (after t \<alpha>) \<inter> set (after t \<beta>))"
    by blast
  then show ?thesis
    using assms(6)[OF after_is_state[OF assms(1,3)] after_is_state[OF assms(1,4)] assms(5)]
    by (meson distinguishes_def)
qed

lemma add_distinguishing_sequence_and_complete_if_required_finite :
  "finite_tree ((add_distinguishing_sequence_and_complete_if_required dist_fun c M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t)"
proof (cases "intersection_is_distinguishing M (after t \<alpha>) (after_initial M \<alpha>) (after t \<beta>) (after_initial M \<beta>)")
  case True
  then have "((add_distinguishing_sequence_and_complete_if_required dist_fun c M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t) = empty"
    by auto
  then show ?thesis
    using empty_finite_tree by simp
next
  case False

  define w where w: "w = dist_fun (after_initial M \<alpha>) (after_initial M \<beta>)"
  define T where T: "T = insert empty w"
  define T1 where T1: "T1 = from_list (language_for_input M (after_initial M \<alpha>) (map fst w))"
  define T2 where T2: "T2 = from_list (language_for_input M (after_initial M \<beta>) (map fst w))"

  have "finite_tree T"
    using insert_finite_tree[OF empty_finite_tree]
    unfolding T by auto
  moreover have "finite_tree (Prefix_Tree.combine T (Prefix_Tree.combine T1 T2))"
    using combine_finite_tree[OF \<open>finite_tree T\<close> combine_finite_tree[OF from_list_finite_tree from_list_finite_tree]]
    unfolding T1 T2
    by auto
  ultimately show ?thesis
    using False
    unfolding add_distinguishing_sequence_and_complete_if_required.simps w T T1 T2 Let_def
    by presburger
qed

function find_cheapest_distinguishing_trace :: "('a,'b::linorder,'c::linorder) fsm \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list) \<Rightarrow> ('b\<times>'c) list \<Rightarrow> ('b\<times>'c) prefix_tree \<Rightarrow> 'a \<Rightarrow> ('b\<times>'c) prefix_tree \<Rightarrow> 'a \<Rightarrow> (('b\<times>'c) list \<times> nat \<times> nat)" where
  "find_cheapest_distinguishing_trace M distFun ios (PT m1) q1 (PT m2) q2 =
    (let
      f = (\<lambda> (\<omega>,l,w) (x,y) . if (x,y) \<notin> list.set ios then (\<omega>,l,w) else
            (let
              w1L = if (PT m1) = empty then 0 else 1;
              w1C = if (x,y) \<in> dom m1 then 0 else 1;
              w1 = min w1L w1C;
              w2L = if (PT m2) = empty then 0 else 1;
              w2C = if (x,y) \<in> dom m2 then 0 else 1;
              w2 = min w2L w2C;
              w' = w1 + w2
            in
              case h_obs M q1 x y of
                None \<Rightarrow> (case h_obs M q2 x y of
                  None \<Rightarrow> (\<omega>,l,w) |
                  Some _ \<Rightarrow> if w' = 0 \<or> w' \<le> w then ([(x,y)],w1C+w2C,w') else (\<omega>,l,w)) |
                Some q1' \<Rightarrow> (case h_obs M q2 x y of
                  None \<Rightarrow> if w' = 0 \<or> w' \<le> w then ([(x,y)],w1C+w2C,w') else (\<omega>,l,w) |
                  Some q2' \<Rightarrow> (if q1' = q2'
                    then (\<omega>,l,w)
                    else (case m1 (x,y) of
                      None \<Rightarrow> (case m2 (x,y) of
                        None \<Rightarrow> let \<omega>' = distFun q1' q2';
                                    l' = 2 + 2 * length \<omega>'
                                in if (w' < w) \<or> (w' = w \<and> l' < l) then ((x,y)#\<omega>',l',w') else (\<omega>,l,w) |
                        Some t2' \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios empty q1' t2' q2'
                                    in if (w'' + w1 < w) \<or> (w'' + w1 = w \<and> l''+1 < l) then ((x,y)#\<omega>'',l''+1,w''+w1) else (\<omega>,l,w)) |
                      Some t1' \<Rightarrow> (case m2 (x,y) of
                        None \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios t1' q1' empty q2'
                                in if (w'' + w2 < w) \<or> (w'' + w2 = w \<and> l''+1 < l) then ((x,y)#\<omega>'',l''+1,w''+w2) else (\<omega>,l,w) |
                        Some t2' \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios t1' q1' t2' q2'
                                    in if (w'' < w) \<or> (w'' = w \<and> l'' < l) then ((x,y)#\<omega>'',l'',w'') else (\<omega>,l,w)))))))
     in
       foldl f (distFun q1 q2, 0, 3) ios)"
  by pat_completeness auto
termination
proof -

  let ?f = "(\<lambda>(M, dF, ios, t1, q1, t2, q2). height_over ios t1 + height_over ios t2)"

  have "\<And>(M::('a,'b::linorder,'c::linorder) fsm)
          (distFun :: ('a \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list))
          (ios :: ('b\<times>'c) list)
           m1 (q1::'a) m2 (q2::'a) x y t2' q1' q2'.
       \<not> (x, y) \<notin> list.set ios \<Longrightarrow>
       m1 (x, y) = None \<Longrightarrow>
       m2 (x, y) = Some t2' \<Longrightarrow>
       ((M, distFun, ios, Prefix_Tree.empty, q1', t2', q2'), M, distFun, ios,
        PT m1, q1, PT m2, q2)
       \<in> measure (\<lambda>(M, dF, ios, t1, q1, t2, q2). height_over ios t1 + height_over ios t2)"
  proof -
    fix M::"('a,'b::linorder,'c::linorder) fsm"
    fix distFun :: "('a \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list)"
    fix ios :: "('b\<times>'c) list"
    fix m1 m2 :: "('b\<times>'c) \<rightharpoonup> ('b\<times>'c) prefix_tree"
    fix t2'
    fix q1 q2 q1' q2' :: 'a
    fix x
    fix y

    assume "m1 (x, y) = None"
    assume "m2 (x, y) = Some t2'"
    assume "\<not> (x, y) \<notin> list.set ios"

    define pre where "pre = (M, distFun, ios, PT m1, q1, PT m2, q2)"
    define post where "post = (M, distFun, ios, Prefix_Tree.empty::('b\<times>'c) prefix_tree, q1', t2', q2')"

    have "height_over ios empty \<le> height_over ios (PT m1)"
      unfolding height_over.simps height_over_empty by auto
    then have "?f post < ?f pre"
      unfolding pre_def post_def case_prod_conv
      by (meson \<open>\<not> (x, y) \<notin> list.set ios\<close> \<open>m2 (x, y) = Some t2'\<close> add_le_less_mono height_over_subtree_less)
    then show "((M, distFun, ios, Prefix_Tree.empty, q1', t2', q2'), M, distFun, ios,
        PT m1, q1, PT m2, q2)
       \<in> measure (\<lambda>(M, dF, ios, t1, q1, t2, q2). height_over ios t1 + height_over ios t2)"
      unfolding pre_def[symmetric] post_def[symmetric]
      by simp
  qed

  moreover have "\<And>(M::('a,'b::linorder,'c::linorder) fsm)
          (distFun :: ('a \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list))
          (ios :: ('b\<times>'c) list)
           m1 (q1::'a) m2 (q2::'a) x y t1' q1' q2'.
       \<not> (x, y) \<notin> list.set ios \<Longrightarrow>
       m1 (x, y) = Some t1' \<Longrightarrow>
       m2 (x, y) = None \<Longrightarrow>
       ((M, distFun, ios, t1', q1', empty, q2'), M, distFun, ios,
        PT m1, q1, PT m2, q2)
       \<in> measure (\<lambda>(M, dF, ios, t1, q1, t2, q2). height_over ios t1 + height_over ios t2)"
  proof -
    fix M::"('a,'b::linorder,'c::linorder) fsm"
    fix distFun :: "('a \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list)"
    fix ios :: "('b\<times>'c) list"
    fix m1 m2 :: "('b\<times>'c) \<rightharpoonup> ('b\<times>'c) prefix_tree"
    fix t1'
    fix q1 q2 q1' q2' :: 'a
    fix x :: 'b
    fix y :: 'c

    assume "m1 (x, y) = Some t1'"
    assume "m2 (x, y) = None"
    assume "\<not> (x, y) \<notin> list.set ios"

    define pre where "pre = (M, distFun, ios, PT m1, q1, PT m2, q2)"
    define post where "post = (M, distFun, ios, t1', q1',  Prefix_Tree.empty::('b\<times>'c) prefix_tree, q2')"

    have "height_over ios empty \<le> height_over ios (PT m2)"
      unfolding height_over.simps height_over_empty by auto
    then have "?f post < ?f pre"
      unfolding pre_def post_def case_prod_conv
      by (meson \<open>\<not> (x, y) \<notin> list.set ios\<close> \<open>m1 (x, y) = Some t1'\<close> add_mono_thms_linordered_field(3) height_over_subtree_less)
    then show "((M, distFun, ios, t1', q1', Prefix_Tree.empty, q2'), M, distFun, ios,
        PT m1, q1, PT m2, q2)
       \<in> measure (\<lambda>(M, dF, ios, t1, q1, t2, q2). height_over ios t1 + height_over ios t2)"
      unfolding pre_def[symmetric] post_def[symmetric]
      by simp
  qed

  moreover have "\<And>(M::('a,'b::linorder,'c::linorder) fsm)
          (distFun :: ('a \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list))
          (ios :: ('b\<times>'c) list)
           m1 (q1::'a) m2 (q2::'a) x y t1' t2' q1' q2'.
       \<not> (x, y) \<notin> list.set ios \<Longrightarrow>
       m1 (x, y) = Some t1' \<Longrightarrow>
       m2 (x, y) = Some t2' \<Longrightarrow>
       ((M, distFun, ios, t1', q1', t2', q2'), M, distFun, ios,
        PT m1, q1, PT m2, q2)
       \<in> measure (\<lambda>(M, dF, ios, t1, q1, t2, q2). height_over ios t1 + height_over ios t2)"
  proof -
    fix M::"('a,'b::linorder,'c::linorder) fsm"
    fix distFun :: "('a \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list)"
    fix ios :: "('b\<times>'c) list"
    fix m1 m2 :: "('b\<times>'c) \<rightharpoonup> ('b\<times>'c) prefix_tree"
    fix t1' t2' :: "('b\<times>'c) prefix_tree"
    fix q1 q2 q1' q2' :: 'a
    fix x :: 'b
    fix y :: 'c

    define pre where "pre = (M, distFun, ios, PT m1, q1, PT m2, q2)"
    define post where "post = (M, distFun, ios, t1', q1', t2', q2')"

    assume "m1 (x, y) = Some t1'"
    moreover assume "m2 (x, y) = Some t2'"
    moreover assume "\<not> (x, y) \<notin> list.set ios"
    ultimately have "?f post < ?f pre"
      unfolding pre_def post_def case_prod_conv
      by (meson add_less_mono height_over_subtree_less)
    then show "((M, distFun, ios, t1', q1',t2', q2'), M, distFun, ios,
        PT m1, q1, PT m2, q2)
       \<in> measure (\<lambda>(M, dF, ios, t1, q1, t2, q2). height_over ios t1 + height_over ios t2)"
      unfolding pre_def[symmetric] post_def[symmetric]
      by simp
  qed

  ultimately show ?thesis
    by (relation "measure (\<lambda> (M,dF,ios,t1,q1,t2,q2) . height_over ios t1 + height_over ios t2)"; simp)
qed

(* removes the elem-check on (x,y) and ios *)
lemma find_cheapest_distinguishing_trace_alt_def :
  "find_cheapest_distinguishing_trace M distFun ios (PT m1) q1 (PT m2) q2 =
    (let
      f = (\<lambda> (\<omega>,l,w) (x,y).
            (let
              w1L = if (PT m1) = empty then 0 else 1;
              w1C = if (x,y) \<in> dom m1 then 0 else 1;
              w1 = min w1L w1C;
              w2L = if (PT m2) = empty then 0 else 1;
              w2C = if (x,y) \<in> dom m2 then 0 else 1;
              w2 = min w2L w2C;
              w' = w1 + w2
            in
              case h_obs M q1 x y of
                None \<Rightarrow> (case h_obs M q2 x y of
                  None \<Rightarrow> (\<omega>,l,w) |
                  Some _ \<Rightarrow> if w' = 0 \<or> w' \<le> w then ([(x,y)],w1C+w2C,w') else (\<omega>,l,w)) |
                Some q1' \<Rightarrow> (case h_obs M q2 x y of
                  None \<Rightarrow> if w' = 0 \<or> w' \<le> w then ([(x,y)],w1C+w2C,w') else (\<omega>,l,w) |
                  Some q2' \<Rightarrow> (if q1' = q2'
                    then (\<omega>,l,w)
                    else (case m1 (x,y) of
                      None \<Rightarrow> (case m2 (x,y) of
                        None \<Rightarrow> let \<omega>' = distFun q1' q2';
                                    l' = 2 + 2 * length \<omega>'
                                in if (w' < w) \<or> (w' = w \<and> l' < l) then ((x,y)#\<omega>',l',w') else (\<omega>,l,w) |
                        Some t2' \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios empty q1' t2' q2'
                                    in if (w'' + w1 < w) \<or> (w'' + w1 = w \<and> l''+1 < l) then ((x,y)#\<omega>'',l''+1,w''+w1) else (\<omega>,l,w)) |
                      Some t1' \<Rightarrow> (case m2 (x,y) of
                        None \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios t1' q1' empty q2'
                                in if (w'' + w2 < w) \<or> (w'' + w2 = w \<and> l''+1 < l) then ((x,y)#\<omega>'',l''+1,w''+w2) else (\<omega>,l,w) |
                        Some t2' \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios t1' q1' t2' q2'
                                    in if (w'' < w) \<or> (w'' = w \<and> l'' < l) then ((x,y)#\<omega>'',l'',w'') else (\<omega>,l,w)))))))
     in
       foldl f (distFun q1 q2, 0, 3) ios)"
  (is "find_cheapest_distinguishing_trace M distFun ios (PT m1) q1 (PT m2) q2 = ?find_cheapest_distinguishing_trace")

proof -
  define f' where "f' = (\<lambda> (\<omega>,l,w) (x,y) .
            (let
              w1L = if (PT m1) = empty then 0 else 1;
              w1C = if (x,y) \<in> dom m1 then 0 else 1;
              w1 = min w1L w1C;
              w2L = if (PT m2) = empty then 0 else 1;
              w2C = if (x,y) \<in> dom m2 then 0 else 1;
              w2 = min w2L w2C;
              w' = w1 + w2
            in
              case h_obs M q1 x y of
                None \<Rightarrow> (case h_obs M q2 x y of
                  None \<Rightarrow> (\<omega>,l,w) |
                  Some _ \<Rightarrow> if w' = 0 \<or> w' \<le> w then ([(x,y)],w1C+w2C,w') else (\<omega>,l,w)) |
                Some q1' \<Rightarrow> (case h_obs M q2 x y of
                  None \<Rightarrow> if w' = 0 \<or> w' \<le> w then ([(x,y)],w1C+w2C,w') else (\<omega>,l,w) |
                  Some q2' \<Rightarrow> (if q1' = q2'
                    then (\<omega>,l,w)
                    else (case m1 (x,y) of
                      None \<Rightarrow> (case m2 (x,y) of
                        None \<Rightarrow> let \<omega>' = distFun q1' q2';
                                    l' = 2 + 2 * length \<omega>'
                                in if (w' < w) \<or> (w' = w \<and> l' < l) then ((x,y)#\<omega>',l',w') else (\<omega>,l,w) |
                        Some t2' \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios empty q1' t2' q2'
                                    in if (w'' + w1 < w) \<or> (w'' + w1 = w \<and> l''+1 < l) then ((x,y)#\<omega>'',l''+1,w''+w1) else (\<omega>,l,w)) |
                      Some t1' \<Rightarrow> (case m2 (x,y) of
                        None \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios t1' q1' empty q2'
                                in if (w'' + w2 < w) \<or> (w'' + w2 = w \<and> l''+1 < l) then ((x,y)#\<omega>'',l''+1,w''+w2) else (\<omega>,l,w) |
                        Some t2' \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios t1' q1' t2' q2'
                                    in if (w'' < w) \<or> (w'' = w \<and> l'' < l) then ((x,y)#\<omega>'',l'',w'') else (\<omega>,l,w)))))))"

  define f where "f = (\<lambda> (\<omega>,l,w) (x,y) . if (x,y) \<notin> list.set ios then (\<omega>,l,w) else
            (let
              w1L = if (PT m1) = empty then 0 else 1;
              w1C = if (x,y) \<in> dom m1 then 0 else 1;
              w1 = min w1L w1C;
              w2L = if (PT m2) = empty then 0 else 1;
              w2C = if (x,y) \<in> dom m2 then 0 else 1;
              w2 = min w2L w2C;
              w' = w1 + w2
            in
              case h_obs M q1 x y of
                None \<Rightarrow> (case h_obs M q2 x y of
                  None \<Rightarrow> (\<omega>,l,w) |
                  Some _ \<Rightarrow> if w' = 0 \<or> w' \<le> w then ([(x,y)],w1C+w2C,w') else (\<omega>,l,w)) |
                Some q1' \<Rightarrow> (case h_obs M q2 x y of
                  None \<Rightarrow> if w' = 0 \<or> w' \<le> w then ([(x,y)],w1C+w2C,w') else (\<omega>,l,w) |
                  Some q2' \<Rightarrow> (if q1' = q2'
                    then (\<omega>,l,w)
                    else (case m1 (x,y) of
                      None \<Rightarrow> (case m2 (x,y) of
                        None \<Rightarrow> let \<omega>' = distFun q1' q2';
                                    l' = 2 + 2 * length \<omega>'
                                in if (w' < w) \<or> (w' = w \<and> l' < l) then ((x,y)#\<omega>',l',w') else (\<omega>,l,w) |
                        Some t2' \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios empty q1' t2' q2'
                                    in if (w'' + w1 < w) \<or> (w'' + w1 = w \<and> l''+1 < l) then ((x,y)#\<omega>'',l''+1,w''+w1) else (\<omega>,l,w)) |
                      Some t1' \<Rightarrow> (case m2 (x,y) of
                        None \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios t1' q1' empty q2'
                                in if (w'' + w2 < w) \<or> (w'' + w2 = w \<and> l''+1 < l) then ((x,y)#\<omega>'',l''+1,w''+w2) else (\<omega>,l,w) |
                        Some t2' \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios t1' q1' t2' q2'
                                    in if (w'' < w) \<or> (w'' = w \<and> l'' < l) then ((x,y)#\<omega>'',l'',w'') else (\<omega>,l,w)))))))"
  then have "f = (\<lambda> y x . if x \<notin> list.set ios then y else f' y x)"
    unfolding f'_def by fast
  moreover have "find_cheapest_distinguishing_trace M distFun ios (PT m1) q1 (PT m2) q2 = foldl f (distFun q1 q2, 0, 3) ios"
    unfolding find_cheapest_distinguishing_trace.simps f_def[symmetric] by auto
  ultimately have "find_cheapest_distinguishing_trace M distFun ios (PT m1) q1 (PT m2) q2 = foldl (\<lambda> y x . if x \<notin> list.set ios then y else f' y x) (distFun q1 q2, 0, 3) ios"
    by auto
  then show ?thesis
    unfolding f'_def[symmetric]
    using foldl_elem_check[of ios "list.set ios"]
    by auto
qed

lemma find_cheapest_distinguishing_trace_code[code] :
  "find_cheapest_distinguishing_trace M distFun ios (MPT m1) q1 (MPT m2) q2 =
    (let
      f = (\<lambda> (\<omega>,l,w) (x,y) .
            (let
              w1L = if is_leaf (MPT m1) then 0 else 1;
              w1C = if (x,y) \<in> Mapping.keys m1 then 0 else 1;
              w1 = min w1L w1C;
              w2L = if is_leaf (MPT m2) then 0 else 1;
              w2C = if(x,y) \<in> Mapping.keys m2 then 0 else 1;
              w2 = min w2L w2C;
              w' = w1 + w2
            in
              case h_obs M q1 x y of
                None \<Rightarrow> (case h_obs M q2 x y of
                  None \<Rightarrow> (\<omega>,l,w) |
                  Some _ \<Rightarrow> if w' = 0 \<or> w' \<le> w then ([(x,y)],w1C+w2C,w') else (\<omega>,l,w)) |
                Some q1' \<Rightarrow> (case h_obs M q2 x y of
                  None \<Rightarrow> if w' = 0 \<or> w' \<le> w then ([(x,y)],w1C+w2C,w') else (\<omega>,l,w) |
                  Some q2' \<Rightarrow> (if q1' = q2'
                    then (\<omega>,l,w)
                    else (case Mapping.lookup m1 (x,y) of
                      None \<Rightarrow> (case Mapping.lookup m2 (x,y) of
                        None \<Rightarrow> let \<omega>' = distFun q1' q2';
                                    l' = 2 + 2 * length \<omega>'
                                in if (w' < w) \<or> (w' = w \<and> l' < l) then ((x,y)#\<omega>',l',w') else (\<omega>,l,w) |
                        Some t2' \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios empty q1' t2' q2'
                                    in if (w'' + w1 < w) \<or> (w'' + w1 = w \<and> l''+1 < l) then ((x,y)#\<omega>'',l''+1,w''+w1) else (\<omega>,l,w)) |
                      Some t1' \<Rightarrow> (case Mapping.lookup m2 (x,y) of
                        None \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios t1' q1' empty q2'
                                in if (w'' + w2 < w) \<or> (w'' + w2 = w \<and> l''+1 < l) then ((x,y)#\<omega>'',l''+1,w''+w2) else (\<omega>,l,w) |
                        Some t2' \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios t1' q1' t2' q2'
                                    in if (w'' < w) \<or> (w'' = w \<and> l'' < l) then ((x,y)#\<omega>'',l'',w'') else (\<omega>,l,w)))))))
     in
       foldl f (distFun q1 q2, 0, 3) ios)"
  unfolding find_cheapest_distinguishing_trace_alt_def MPT_def
  by (simp add: keys_dom_lookup)

lemma find_cheapest_distinguishing_trace_is_distinguishing_trace :
  assumes "observable M"
  and     "minimal M"
  and     "q1 \<in> states M"
  and     "q2 \<in> states M"
  and     "q1 \<noteq> q2"
  and     "\<And> q1 q2 . q1 \<in> states M \<Longrightarrow> q2 \<in> states M \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> distinguishes M q1 q2 (distFun q1 q2)"
shows "distinguishes M q1 q2 (fst (find_cheapest_distinguishing_trace M distFun ios t1 q1 t2 q2))"
  using assms(3,4,5)
proof (induction "height_over ios t1 + height_over ios t2" arbitrary: t1 q1 t2 q2 rule: less_induct)
  case less

  obtain m1 where "t1 = PT m1"
    using prefix_tree.exhaust by blast
  obtain m2 where "t2 = PT m2"
    using prefix_tree.exhaust by blast

  define f where "f = (\<lambda> (\<omega>,l,w) (x,y) .
            (let
              w1L = if (PT m1) = empty then 0 else 1;
              w1C = if (x,y) \<in> dom m1 then 0 else 1;
              w1 = min w1L w1C;
              w2L = if (PT m2) = empty then 0 else 1;
              w2C = if (x,y) \<in> dom m2 then 0 else 1;
              w2 = min w2L w2C;
              w' = w1 + w2
            in
              case h_obs M q1 x y of
                None \<Rightarrow> (case h_obs M q2 x y of
                  None \<Rightarrow> (\<omega>,l,w) |
                  Some _ \<Rightarrow> if w' = 0 \<or> w' \<le> w then ([(x,y)],w1C+w2C,w') else (\<omega>,l,w)) |
                Some q1' \<Rightarrow> (case h_obs M q2 x y of
                  None \<Rightarrow> if w' = 0 \<or> w' \<le> w then ([(x,y)],w1C+w2C,w') else (\<omega>,l,w) |
                  Some q2' \<Rightarrow> (if q1' = q2'
                    then (\<omega>,l,w)
                    else (case m1 (x,y) of
                      None \<Rightarrow> (case m2 (x,y) of
                        None \<Rightarrow> let \<omega>' = distFun q1' q2';
                                    l' = 2 + 2 * length \<omega>'
                                in if (w' < w) \<or> (w' = w \<and> l' < l) then ((x,y)#\<omega>',l',w') else (\<omega>,l,w) |
                        Some t2' \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios empty q1' t2' q2'
                                    in if (w'' + w1 < w) \<or> (w'' + w1 = w \<and> l''+1 < l) then ((x,y)#\<omega>'',l''+1,w''+w1) else (\<omega>,l,w)) |
                      Some t1' \<Rightarrow> (case m2 (x,y) of
                        None \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios t1' q1' empty q2'
                                in if (w'' + w2 < w) \<or> (w'' + w2 = w \<and> l''+1 < l) then ((x,y)#\<omega>'',l''+1,w''+w2) else (\<omega>,l,w) |
                        Some t2' \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios t1' q1' t2' q2'
                                    in if (w'' < w) \<or> (w'' = w \<and> l'' < l) then ((x,y)#\<omega>'',l'',w'') else (\<omega>,l,w)))))))"

  then have "find_cheapest_distinguishing_trace M distFun ios t1 q1 t2 q2 = foldl f (distFun q1 q2, 0, 3) ios"
    unfolding \<open>t1 = PT m1\<close> \<open>t2 = PT m2\<close>
    unfolding find_cheapest_distinguishing_trace_alt_def Let_def
    by fast

  define ios' where "ios'=ios"

  have "list.set ios' \<subseteq> list.set ios \<Longrightarrow> distinguishes M q1 q2 (fst (foldl f (distFun q1 q2, 0, 3) ios'))"
  proof (induction ios' rule: rev_induct)
    case Nil
    then show ?case using assms(6)[OF less.prems] by auto
  next
    case (snoc xy ios')

    obtain x y where "xy = (x,y)"
      using prod.exhaust by metis
    moreover obtain \<omega> l w where "(foldl f (distFun q1 q2, 0, 3) ios') = (\<omega>,l,w)"
      using prod.exhaust by metis
    ultimately have "foldl f (distFun q1 q2, 0, 3) (ios'@[xy]) = f (\<omega>,l,w) (x,y)"
      by auto

    have "distinguishes M q1 q2 \<omega>"
      using \<open>(foldl f (distFun q1 q2, 0, 3) ios') = (\<omega>,l,w)\<close> snoc by auto

    have "(x,y) \<in> list.set ios"
      using snoc.prems unfolding \<open>xy = (x,y)\<close> by auto

    define w1L where "w1L = (if (PT m1) = empty then 0 else 1::nat)"
    define w1C where "w1C = (if (x,y) \<in> dom m1 then 0 else 1::nat)"
    define w1 where "w1 = min w1L w1C"
    define w2L where "w2L = (if (PT m2) = empty then 0 else 1::nat)"
    define w2C where "w2C = (if (x,y) \<in> dom m2 then 0 else 1::nat)"
    define w2 where "w2 = min w2L w2C"
    define w' where "w' = w1 + w2"

    have *:"f (\<omega>,l,w) (x,y) = (case h_obs M q1 x y of
                None \<Rightarrow> (case h_obs M q2 x y of
                  None \<Rightarrow> (\<omega>,l,w) |
                  Some _ \<Rightarrow> if w' = 0 \<or> w' \<le> w then ([(x,y)],w1C+w2C,w') else (\<omega>,l,w)) |
                Some q1' \<Rightarrow> (case h_obs M q2 x y of
                  None \<Rightarrow> if w' = 0 \<or> w' \<le> w then ([(x,y)],w1C+w2C,w') else (\<omega>,l,w) |
                  Some q2' \<Rightarrow> (if q1' = q2'
                    then (\<omega>,l,w)
                    else (case m1 (x,y) of
                      None \<Rightarrow> (case m2 (x,y) of
                        None \<Rightarrow> let \<omega>' = distFun q1' q2';
                                    l' = 2 + 2 * length \<omega>'
                                in if (w' < w) \<or> (w' = w \<and> l' < l) then ((x,y)#\<omega>',l',w') else (\<omega>,l,w) |
                        Some t2' \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios empty q1' t2' q2'
                                    in if (w'' + w1 < w) \<or> (w'' + w1 = w \<and> l''+1 < l) then ((x,y)#\<omega>'',l''+1,w''+w1) else (\<omega>,l,w)) |
                      Some t1' \<Rightarrow> (case m2 (x,y) of
                        None \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios t1' q1' empty q2'
                                in if (w'' + w2 < w) \<or> (w'' + w2 = w \<and> l''+1 < l) then ((x,y)#\<omega>'',l''+1,w''+w2) else (\<omega>,l,w) |
                        Some t2' \<Rightarrow> let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios t1' q1' t2' q2'
                                    in if (w'' < w) \<or> (w'' = w \<and> l'' < l) then ((x,y)#\<omega>'',l'',w'') else (\<omega>,l,w))))))"
      unfolding w1_def w2_def w'_def w1L_def w1C_def w2L_def w2C_def
      unfolding f_def case_prod_conv Let_def
      by fast

    have "distinguishes M q1 q2 (fst (f (\<omega>,l,w) (x,y)))"
    proof (cases "h_obs M q1 x y")
      case None
      then show ?thesis proof (cases "h_obs M q2 x y")
        case None
        have "f (\<omega>,l,w) (x,y) = (\<omega>,l,w)"
          unfolding *
          unfolding \<open>h_obs M q1 x y = None\<close> None by auto
        then show ?thesis
          using \<open>distinguishes M q1 q2 \<omega>\<close> by auto
      next
        case (Some a)
        have "f (\<omega>,l,w) (x,y) = (if w' = 0 \<or> w' \<le> w then ([(x,y)],w1C+w2C,w') else (\<omega>,l,w))"
          unfolding * None Some by auto
        moreover have "distinguishes M q1 q2 [(x,y)]"
          using distinguishes_sym[OF h_obs_distinguishes[OF assms(1) Some None]] .
        ultimately show ?thesis
          using \<open>distinguishes M q1 q2 \<omega>\<close> by auto
      qed
    next
      case (Some q1')
      then have "q1' \<in> states M"
        by (meson h_obs_state)

      show ?thesis proof (cases "h_obs M q2 x y")
        case None
        have "f (\<omega>,l,w) (x,y) = (if w' = 0 \<or> w' \<le> w then ([(x,y)],w1C+w2C,w') else (\<omega>,l,w))"
          unfolding * None Some by auto
        moreover have "distinguishes M q1 q2 [(x,y)]"
          using h_obs_distinguishes[OF assms(1) Some None] .
        ultimately show ?thesis
          using \<open>distinguishes M q1 q2 \<omega>\<close> by auto
      next
        case (Some q2')
        then have "q2' \<in> states M"
          by (meson h_obs_state)

        show ?thesis proof (cases "q1' = q2'")
          case True
          have "f (\<omega>,l,w) (x,y) = (\<omega>,l,w)"
            unfolding *
            unfolding \<open>h_obs M q1 x y = Some q1'\<close> Some True by auto
          then show ?thesis
            using \<open>distinguishes M q1 q2 \<omega>\<close> by auto
        next
          case False

          have dist': "\<And> \<omega> . distinguishes M q1' q2' \<omega> \<Longrightarrow> distinguishes M q1 q2 ((x,y)#\<omega>)"
            using distinguishes_after_prepend[OF assms(1), of q1 x y q2]
            using \<open>h_obs M q1 x y = Some q1'\<close> \<open>h_obs M q2 x y = Some q2'\<close>
            unfolding after_h_obs[OF assms(1) \<open>h_obs M q1 x y = Some q1'\<close>]
            unfolding after_h_obs[OF assms(1) \<open>h_obs M q2 x y = Some q2'\<close>]
            by auto

          show ?thesis proof (cases "m1 (x,y)")
            case None
            show ?thesis proof (cases "m2 (x,y)")
              case None

              have **: "f (\<omega>,l,w) (x,y) = (let \<omega>' = distFun q1' q2';  l' = 2 + 2 * length \<omega>'
                                       in if (w' < w) \<or> (w' = w \<and> l' < l) then ((x,y)#\<omega>',l',w') else (\<omega>,l,w))"
                unfolding *
                unfolding \<open>h_obs M q1 x y = Some q1'\<close> \<open>h_obs M q2 x y = Some q2'\<close> \<open>m1 (x, y) = None\<close> \<open>m2 (x, y) = None\<close>
                using False
                by auto

              have "distinguishes M q1' q2' (distFun q1' q2')"
                using \<open>q1' \<in> states M\<close> \<open>q2' \<in> states M\<close> assms(6) False by blast
              then have "distinguishes M q1 q2 ((x,y)#(distFun q1' q2'))"
                using dist' by auto
              then  show ?thesis
                using \<open>distinguishes M q1 q2 \<omega>\<close>
                unfolding ** Let_def by auto
            next
              case (Some t2')

              have **: "f (\<omega>,l,w) (x,y) = (let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios empty q1' t2' q2'
                                    in if (w'' + w1 < w) \<or> (w'' + w1 = w \<and> l''+1 < l) then ((x,y)#\<omega>'',l''+1,w''+w1) else (\<omega>,l,w))"
                unfolding *
                unfolding \<open>h_obs M q1 x y = Some q1'\<close> \<open>h_obs M q2 x y = Some q2'\<close> \<open>m1 (x, y) = None\<close> \<open>m2 (x, y) = Some t2'\<close>
                using False
                by auto

              obtain \<omega>'' l'' w'' where ***:"find_cheapest_distinguishing_trace M distFun ios Prefix_Tree.empty q1' t2' q2' = (\<omega>'', l'', w'')"
                using prod.exhaust by metis

              have "distinguishes M q1' q2' (fst (find_cheapest_distinguishing_trace M distFun ios empty q1' t2' q2'))"
              proof -

                have "height_over ios empty + height_over ios t2' < height_over ios t1 + height_over ios t2"
                  using height_over_subtree_less[of m2 "(x,y)", OF \<open>m2 (x,y) = Some t2'\<close> \<open>(x,y) \<in> list.set ios\<close> ]
                  unfolding height_over_empty \<open>t2 = PT m2\<close>[symmetric]
                  by (simp add: \<open>t1 = PT m1\<close>)
                then show ?thesis
                  using less.hyps[OF _ \<open>q1' \<in> states M\<close> \<open>q2' \<in> states M\<close> False]
                  by blast
              qed
              then have "distinguishes M q1 q2 ((x,y)#(fst (find_cheapest_distinguishing_trace M distFun ios empty q1' t2' q2')))"
                using dist' by blast
              then  show ?thesis
                using \<open>distinguishes M q1 q2 \<omega>\<close>
                unfolding ** *** Let_def fst_conv case_prod_conv by auto
            qed
          next
            case (Some t1')
            show ?thesis proof (cases "m2 (x,y)")
              case None

              have **: "f (\<omega>,l,w) (x,y) = (let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios t1' q1' empty q2'
                                in if (w'' + w2 < w) \<or> (w'' + w2 = w \<and> l''+1 < l) then ((x,y)#\<omega>'',l''+1,w''+w2) else (\<omega>,l,w))"
                unfolding *
                unfolding \<open>h_obs M q1 x y = Some q1'\<close> \<open>h_obs M q2 x y = Some q2'\<close> \<open>m1 (x, y) = Some t1'\<close> \<open>m2 (x, y) = None\<close>
                using False
                by auto

              obtain \<omega>'' l'' w'' where ***:"find_cheapest_distinguishing_trace M distFun ios t1' q1' empty q2' = (\<omega>'', l'', w'')"
                using prod.exhaust by metis

              have "distinguishes M q1' q2' (fst (find_cheapest_distinguishing_trace M distFun ios t1' q1' empty q2'))"
              proof -

                have "height_over ios t1' + height_over ios empty < height_over ios t1 + height_over ios t2"
                  using height_over_subtree_less[of m1 "(x,y)", OF \<open>m1 (x,y) = Some t1'\<close> \<open>(x,y) \<in> list.set ios\<close> ]
                  unfolding height_over_empty \<open>t1 = PT m1\<close>[symmetric]
                  by (simp add: \<open>t2 = PT m2\<close>)
                then show ?thesis
                  using less.hyps[OF _ \<open>q1' \<in> states M\<close> \<open>q2' \<in> states M\<close> False]
                  by blast
              qed
              then have "distinguishes M q1 q2 ((x,y)#(fst (find_cheapest_distinguishing_trace M distFun ios t1' q1' empty q2')))"
                using dist' by blast
              then  show ?thesis
                using \<open>distinguishes M q1 q2 \<omega>\<close>
                unfolding ** *** Let_def fst_conv case_prod_conv by auto
            next
              case (Some t2')

              have **: "f (\<omega>,l,w) (x,y) = (let (\<omega>'',l'',w'') = find_cheapest_distinguishing_trace M distFun ios t1' q1' t2' q2'
                                    in if (w'' < w) \<or> (w'' = w \<and> l'' < l) then ((x,y)#\<omega>'',l'',w'') else (\<omega>,l,w))"
                unfolding *
                unfolding \<open>h_obs M q1 x y = Some q1'\<close> \<open>h_obs M q2 x y = Some q2'\<close> \<open>m1 (x, y) = Some t1'\<close> \<open>m2 (x, y) = Some t2'\<close>
                using False
                by auto
              obtain \<omega>'' l'' w'' where ***:"find_cheapest_distinguishing_trace M distFun ios t1' q1' t2' q2' = (\<omega>'', l'', w'')"
                using prod.exhaust by metis

              have "distinguishes M q1' q2' (fst (find_cheapest_distinguishing_trace M distFun ios t1' q1' t2' q2'))"
              proof -

                have "height_over ios t1' + height_over ios t2' < height_over ios t1 + height_over ios t2"
                  using height_over_subtree_less[of m1 "(x,y)", OF \<open>m1 (x,y) = Some t1'\<close> \<open>(x,y) \<in> list.set ios\<close> ]
                  using height_over_subtree_less[of m2 "(x,y)", OF \<open>m2 (x,y) = Some t2'\<close> \<open>(x,y) \<in> list.set ios\<close> ]
                  unfolding \<open>t1 = PT m1\<close>[symmetric] \<open>t2 = PT m2\<close>[symmetric]
                  by auto
                then show ?thesis
                  using less.hyps[OF _ \<open>q1' \<in> states M\<close> \<open>q2' \<in> states M\<close> False]
                  by blast
              qed
              then have "distinguishes M q1 q2 ((x,y)#(fst (find_cheapest_distinguishing_trace M distFun ios t1' q1' t2' q2')))"
                using dist' by blast
              then  show ?thesis
                using \<open>distinguishes M q1 q2 \<omega>\<close>
                unfolding ** *** Let_def fst_conv case_prod_conv by auto
            qed
          qed
        qed
      qed
    qed
    then show ?case
      unfolding \<open>foldl f (distFun q1 q2, 0, 3) (ios'@[xy]) = f (\<omega>,l,w) (x,y)\<close> .
  qed

  then show ?case
    unfolding \<open>find_cheapest_distinguishing_trace M distFun ios t1 q1 t2 q2 = foldl f (distFun q1 q2, 0, 3) ios\<close>
              \<open>ios' = ios\<close>
    by blast
qed

fun add_cheapest_distinguishing_trace :: "('a \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list) \<Rightarrow> bool \<Rightarrow> ('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> (('b\<times>'c) list \<times> 'a) \<times> (('b\<times>'c) list \<times> 'a) \<Rightarrow> ('b\<times>'c) prefix_tree \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "add_cheapest_distinguishing_trace distFun completeInputTraces M ((\<alpha>,q1), (\<beta>,q2)) t =
    (let w = (fst (find_cheapest_distinguishing_trace M distFun (List.product (inputs_as_list M) (outputs_as_list M)) (after t \<alpha>) q1 (after t \<beta>) q2));
         T = insert empty w
      in if completeInputTraces
        then let T1 = complete_inputs_to_tree M q1 (outputs_as_list M) (map fst w);
                 T2 = complete_inputs_to_tree M q2 (outputs_as_list M) (map fst w)
             in Prefix_Tree.combine T (Prefix_Tree.combine T1 T2)
        else T)"

lemma add_cheapest_distinguishing_trace_distinguishes :
  assumes "observable M"
  and     "minimal M"
  and     "\<alpha> \<in> L M"
  and     "\<beta> \<in> L M"
  and     "after_initial M \<alpha> \<noteq> after_initial M \<beta>"
  and     "\<And> q1 q2 . q1 \<in> states M \<Longrightarrow> q2 \<in> states M \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> distinguishes M q1 q2 (dist_fun q1 q2)"
shows "\<exists> io \<in> set ((add_cheapest_distinguishing_trace dist_fun c M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t) \<union> (set (after t \<alpha>) \<inter> set (after t \<beta>)) .  distinguishes M (after_initial M \<alpha>) (after_initial M \<beta>) io"
proof -
  define w where "w = (fst (find_cheapest_distinguishing_trace M dist_fun (List.product (inputs_as_list M) (outputs_as_list M)) (after t \<alpha>) (after_initial M \<alpha>) (after t \<beta>) (after_initial M \<beta>)))"

  have "set (insert empty w) \<subseteq> set ((add_cheapest_distinguishing_trace dist_fun c M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t)"
    using combine_set[of "insert empty w"] w_def
    unfolding add_cheapest_distinguishing_trace.simps Let_def
    by (cases c; fastforce)
  moreover have "w \<in> set (insert empty w)"
    unfolding insert_set by auto
  ultimately have "w \<in> set ((add_cheapest_distinguishing_trace dist_fun c M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t) \<union> (set (after t \<alpha>) \<inter> set (after t \<beta>))"
    by blast
  moreover have "distinguishes M (after_initial M \<alpha>) (after_initial M \<beta>) w"
    using find_cheapest_distinguishing_trace_is_distinguishing_trace[OF assms(1,2) after_is_state[OF assms(1,3)] after_is_state[OF assms(1,4)] assms(5,6)]
    unfolding w_def
    by blast
  ultimately show ?thesis
    by blast
qed

lemma add_cheapest_distinguishing_trace_finite :
  "finite_tree ((add_cheapest_distinguishing_trace dist_fun c M) ((\<alpha>,after_initial M \<alpha>),(\<beta>,after_initial M \<beta>)) t)"
proof -

  define w where w: "w = (fst (find_cheapest_distinguishing_trace M dist_fun (List.product (inputs_as_list M) (outputs_as_list M)) (after t \<alpha>) (after_initial M \<alpha>) (after t \<beta>) (after_initial M \<beta>)))"
  define T where T: "T = insert empty w"
  define T1 where T1: "T1 = complete_inputs_to_tree M (after_initial M \<alpha>) (outputs_as_list M) (map fst w)"
  define T2 where T2: "T2 = complete_inputs_to_tree M (after_initial M \<beta>) (outputs_as_list M) (map fst w)"

  have "finite_tree T"
    using insert_finite_tree[OF empty_finite_tree]
    unfolding T by auto
  moreover have "finite_tree (Prefix_Tree.combine T (Prefix_Tree.combine T1 T2))"
    using combine_finite_tree[OF \<open>finite_tree T\<close> combine_finite_tree[OF complete_inputs_to_tree_finite_tree complete_inputs_to_tree_finite_tree]]
    unfolding T1 T2
    by auto
  ultimately show ?thesis
    unfolding add_cheapest_distinguishing_trace.simps w T T1 T2 Let_def
    by presburger
qed

subsubsection \<open>Implementation\<close>

definition h_method_via_pair_framework :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "h_method_via_pair_framework M m = pair_framework_h_components M m (add_distinguishing_sequence_if_required (get_distinguishing_sequence_from_ofsm_tables M))"

lemma h_method_via_pair_framework_completeness_and_finiteness :
  assumes "observable M"
  and     "observable I"
  and     "minimal M"
  and     "size I \<le> m"
  and     "m \<ge> size_r M"
  and     "inputs I = inputs M"
  and     "outputs I = outputs M"
shows "(L M = L I) \<longleftrightarrow> (L M \<inter> set (h_method_via_pair_framework M m) = L I \<inter> set (h_method_via_pair_framework M m))"
and   "finite_tree (h_method_via_pair_framework M m)"
  using pair_framework_h_components_completeness_and_finiteness[OF assms(1,2,3,5,4,6,7), where get_separating_traces="(add_distinguishing_sequence_if_required (get_distinguishing_sequence_from_ofsm_tables M))", OF add_distinguishing_sequence_if_required_distinguishes[OF assms(1,3), where dist_fun="(get_distinguishing_sequence_from_ofsm_tables M)"] add_distinguishing_sequence_if_required_finite[where dist_fun="(get_distinguishing_sequence_from_ofsm_tables M)"] ]
  using get_distinguishing_sequence_from_ofsm_tables_distinguishes[OF assms(1,3)]
  unfolding h_method_via_pair_framework_def[symmetric]
  by blast+

definition h_method_via_pair_framework_2 :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "h_method_via_pair_framework_2 M m c = pair_framework_h_components M m (add_distinguishing_sequence_and_complete_if_required (get_distinguishing_sequence_from_ofsm_tables M) c)"

lemma h_method_via_pair_framework_2_completeness_and_finiteness :
  assumes "observable M"
  and     "observable I"
  and     "minimal M"
  and     "size I \<le> m"
  and     "m \<ge> size_r M"
  and     "inputs I = inputs M"
  and     "outputs I = outputs M"
shows "(L M = L I) \<longleftrightarrow> (L M \<inter> set (h_method_via_pair_framework_2 M m c) = L I \<inter> set (h_method_via_pair_framework_2 M m c))"
and   "finite_tree (h_method_via_pair_framework_2 M m c)"
  using pair_framework_h_components_completeness_and_finiteness[OF assms(1,2,3,5,4,6,7), where get_separating_traces="(add_distinguishing_sequence_and_complete_if_required (get_distinguishing_sequence_from_ofsm_tables M) c)", OF add_distinguishing_sequence_and_complete_if_required_distinguishes[OF assms(1,3), where dist_fun="(get_distinguishing_sequence_from_ofsm_tables M)"] add_distinguishing_sequence_and_complete_if_required_finite[where dist_fun="(get_distinguishing_sequence_from_ofsm_tables M)"] ]
  using get_distinguishing_sequence_from_ofsm_tables_distinguishes[OF assms(1,3)]
  unfolding h_method_via_pair_framework_2_def[symmetric]
  by blast+

definition h_method_via_pair_framework_3 :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "h_method_via_pair_framework_3 M m c1 c2 = pair_framework_h_components_2 M m (add_cheapest_distinguishing_trace (get_distinguishing_sequence_from_ofsm_tables M) c2) c1"

lemma h_method_via_pair_framework_3_completeness_and_finiteness :
  assumes "observable M"
  and     "observable I"
  and     "minimal M"
  and     "size I \<le> m"
  and     "m \<ge> size_r M"
  and     "inputs I = inputs M"
  and     "outputs I = outputs M"
shows "(L M = L I) \<longleftrightarrow> (L M \<inter> set (h_method_via_pair_framework_3 M m c1 c2) = L I \<inter> set (h_method_via_pair_framework_3 M m c1 c2))"
and   "finite_tree (h_method_via_pair_framework_3 M m c1 c2)"
  using pair_framework_h_components_2_completeness_and_finiteness[OF assms(1,2,3,5,4,6,7), where get_separating_traces="(add_cheapest_distinguishing_trace (get_distinguishing_sequence_from_ofsm_tables M) c2)", OF add_cheapest_distinguishing_trace_distinguishes[OF assms(1,3), where dist_fun="(get_distinguishing_sequence_from_ofsm_tables M)"] add_cheapest_distinguishing_trace_finite[where dist_fun="(get_distinguishing_sequence_from_ofsm_tables M)"] ]
  using get_distinguishing_sequence_from_ofsm_tables_distinguishes[OF assms(1,3)]
  unfolding h_method_via_pair_framework_3_def[symmetric]
  by blast+

definition h_method_via_pair_framework_lists :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> (('b\<times>'c) \<times> bool) list list" where
  "h_method_via_pair_framework_lists M m = sorted_list_of_maximal_sequences_in_tree (test_suite_from_io_tree M (initial M) (h_method_via_pair_framework M m))"

lemma h_method_implementation_lists_completeness :
  assumes "observable M"
  and     "observable I"
  and     "minimal M"
  and     "size I \<le> m"
  and     "m \<ge> size_r M"
  and     "inputs I = inputs M"
  and     "outputs I = outputs M"
shows "(L M = L I) \<longleftrightarrow> list_all (passes_test_case I (initial I)) (h_method_via_pair_framework_lists M m)"
unfolding h_method_via_pair_framework_lists_def
            h_method_via_pair_framework_completeness_and_finiteness(1)[OF assms]
            passes_test_cases_from_io_tree[OF assms(1,2) fsm_initial fsm_initial h_method_via_pair_framework_completeness_and_finiteness(2)[OF assms]]
  by blast

subsubsection \<open>Code Equations\<close>

(* to avoid repeated computation of the same OFSM-tables by get_distinguishing_sequence_from_ofsm_tables,
   we pre-compute all distinguishing traces *)
lemma h_method_via_pair_framework_code[code] :
  "h_method_via_pair_framework M m = (let
    tables = (compute_ofsm_tables M (size M - 1));
    distMap = mapping_of (map (\<lambda> (q1,q2) . ((q1,q2), get_distinguishing_sequence_from_ofsm_tables_with_provided_tables tables M q1 q2))
                      (filter (\<lambda> qq . fst qq \<noteq> snd qq) (List.product (states_as_list M) (states_as_list M))));
    distHelper = (\<lambda> q1 q2 . if q1 \<in> states M \<and> q2 \<in> states M \<and> q1 \<noteq> q2 then the (Mapping.lookup distMap (q1,q2)) else get_distinguishing_sequence_from_ofsm_tables M q1 q2);
    distFun = add_distinguishing_sequence_if_required distHelper
  in pair_framework_h_components M m distFun)"
  unfolding h_method_via_pair_framework_def
  apply (subst get_distinguishing_sequence_from_ofsm_tables_precomputed[of M])
  unfolding Let_def
  by presburger

lemma h_method_via_pair_framework_2_code[code] :
  "h_method_via_pair_framework_2 M m c = (let
    tables = (compute_ofsm_tables M (size M - 1));
    distMap = mapping_of (map (\<lambda> (q1,q2) . ((q1,q2), get_distinguishing_sequence_from_ofsm_tables_with_provided_tables tables M q1 q2))
                      (filter (\<lambda> qq . fst qq \<noteq> snd qq) (List.product (states_as_list M) (states_as_list M))));
    distHelper = (\<lambda> q1 q2 . if q1 \<in> states M \<and> q2 \<in> states M \<and> q1 \<noteq> q2 then the (Mapping.lookup distMap (q1,q2)) else get_distinguishing_sequence_from_ofsm_tables M q1 q2);
    distFun = add_distinguishing_sequence_and_complete_if_required distHelper c
  in pair_framework_h_components M m distFun)"
  unfolding h_method_via_pair_framework_2_def
  apply (subst get_distinguishing_sequence_from_ofsm_tables_precomputed[of M])
  unfolding Let_def
  by presburger

lemma h_method_via_pair_framework_3_code[code] :
  "h_method_via_pair_framework_3 M m c1 c2 = (let
    tables = (compute_ofsm_tables M (size M - 1));
    distMap = mapping_of (map (\<lambda> (q1,q2) . ((q1,q2), get_distinguishing_sequence_from_ofsm_tables_with_provided_tables tables M q1 q2))
                      (filter (\<lambda> qq . fst qq \<noteq> snd qq) (List.product (states_as_list M) (states_as_list M))));
    distHelper = (\<lambda> q1 q2 . if q1 \<in> states M \<and> q2 \<in> states M \<and> q1 \<noteq> q2 then the (Mapping.lookup distMap (q1,q2)) else get_distinguishing_sequence_from_ofsm_tables M q1 q2);
    distFun = add_cheapest_distinguishing_trace distHelper c2
  in pair_framework_h_components_2 M m distFun c1)"
  unfolding h_method_via_pair_framework_3_def
  apply (subst get_distinguishing_sequence_from_ofsm_tables_precomputed[of M])
  unfolding Let_def
  by presburger

end


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

(*
 * Contributions by:
 *   2012 Lars Noschinski <noschinl@in.tum.de>
 *     Option monad while loop formalisation.
 *)

theory OptionMonad
imports "../Lib" (* FIXME: reduce dependencies *)
begin

type_synonym ('s,'a) lookup = "'s \<Rightarrow> 'a option"

text {* Similar to map_option but the second function returns option as well *}
definition
  opt_map :: "('s,'a) lookup \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> ('s,'b) lookup" (infixl "|>" 54)
where
  "f |> g \<equiv> \<lambda>s. case f s of None \<Rightarrow> None | Some x \<Rightarrow> g x"

lemma opt_map_cong [fundef_cong]:
  "\<lbrakk> f = f'; \<And>v s. f s = Some v \<Longrightarrow> g v = g' v\<rbrakk> \<Longrightarrow> f |> g = f' |> g'"
  by (rule ext) (simp add: opt_map_def split: option.splits)

lemma in_opt_map_eq:
  "((f |> g) s = Some v) = (\<exists>v'. f s = Some v' \<and> g v' = Some v)"
  by (simp add: opt_map_def split: option.splits)

lemma opt_mapE:
  "\<lbrakk> (f |> g) s = Some v; \<And>v'. \<lbrakk>f s = Some v'; g v' = Some v \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (auto simp: in_opt_map_eq)

definition
  obind :: "('s,'a) lookup \<Rightarrow> ('a \<Rightarrow> ('s,'b) lookup) \<Rightarrow> ('s,'b) lookup" (infixl "|>>" 53)
where
  "f |>> g \<equiv> \<lambda>s. case f s of None \<Rightarrow> None | Some x \<Rightarrow> g x s"

definition
  "ofail = K None"

definition
  "oreturn = K o Some"

definition
  "oassert P \<equiv> if P then oreturn () else ofail"

text {*
  If the result can be an exception.
  Corresponding bindE would be analogous to lifting in NonDetMonad.
*}

definition
  "oreturnOk x = K (Some (Inr x))"

definition
  "othrow e = K (Some (Inl e))"

definition
  "oguard G \<equiv> (\<lambda>s. if G s then Some () else None)"

definition
  "ocondition c L R \<equiv> (\<lambda>s. if c s then L s else R s)"

definition
  "oskip \<equiv> oreturn ()"

text {* Monad laws *}
lemma oreturn_bind [simp]: "(oreturn x |>> f) = f x"
  by (auto simp add: oreturn_def obind_def K_def)

lemma obind_return [simp]: "(m |>> oreturn) = m"
  by (auto simp add: oreturn_def obind_def K_def split: option.splits)

lemma obind_assoc:
  "(m |>> f) |>> g  =  m |>> (\<lambda>x. f x |>> g)"
  by (auto simp add: oreturn_def obind_def K_def split: option.splits)

text {* Binding fail *}

lemma obind_fail [simp]:
  "f |>> (\<lambda>_. ofail) = ofail"
  by (auto simp add: ofail_def obind_def K_def split: option.splits)

lemma ofail_bind [simp]:
  "ofail |>> m = ofail"
  by (auto simp add: ofail_def obind_def K_def split: option.splits)

text {* Function package setup *}
lemma opt_bind_cong [fundef_cong]:
  "\<lbrakk> f = f'; \<And>v s. f' s = Some v \<Longrightarrow> g v s = g' v s \<rbrakk> \<Longrightarrow> f |>> g = f' |>> g'"
  by (rule ext) (simp add: obind_def split: option.splits)

lemma opt_bind_cong_apply [fundef_cong]:
  "\<lbrakk> f s = f' s; \<And>v. f' s = Some v \<Longrightarrow> g v s = g' v s \<rbrakk> \<Longrightarrow> (f |>> g) s = (f' |>> g') s"
  by (simp add: obind_def split: option.splits)

lemma oassert_bind_cong [fundef_cong]:
  "\<lbrakk> P = P'; P' \<Longrightarrow> m = m' \<rbrakk> \<Longrightarrow> oassert P |>> m = oassert P' |>> m'"
  by (auto simp: oassert_def)

lemma oassert_bind_cong_apply [fundef_cong]:
  "\<lbrakk> P = P'; P' \<Longrightarrow> m () s = m' () s \<rbrakk> \<Longrightarrow> (oassert P |>> m) s = (oassert P' |>> m') s"
  by (auto simp: oassert_def)

lemma oreturn_bind_cong [fundef_cong]:
  "\<lbrakk> x = x'; m x' = m' x' \<rbrakk> \<Longrightarrow> oreturn x |>> m = oreturn x' |>> m'"
  by simp

lemma oreturn_bind_cong_apply [fundef_cong]:
  "\<lbrakk> x = x'; m x' s = m' x' s \<rbrakk> \<Longrightarrow> (oreturn x |>> m) s = (oreturn x' |>> m') s"
  by simp

lemma oreturn_bind_cong2 [fundef_cong]:
  "\<lbrakk> x = x'; m x' = m' x' \<rbrakk> \<Longrightarrow> (oreturn $ x) |>> m = (oreturn $ x') |>> m'"
  by simp

lemma oreturn_bind_cong2_apply [fundef_cong]:
  "\<lbrakk> x = x'; m x' s = m' x' s \<rbrakk> \<Longrightarrow> ((oreturn $ x) |>> m) s = ((oreturn $ x') |>> m') s"
  by simp

lemma ocondition_cong [fundef_cong]:
"\<lbrakk>c = c'; \<And>s. c' s \<Longrightarrow> l s = l' s; \<And>s. \<not>c' s \<Longrightarrow> r s = r' s\<rbrakk>
  \<Longrightarrow> ocondition c l r = ocondition c' l' r'"
  by (auto simp: ocondition_def)

text {* Decomposition *}

lemma ocondition_K_true [simp]:
  "ocondition (\<lambda>_. True) T F = T"
  by (simp add: ocondition_def)

lemma ocondition_K_false [simp]:
  "ocondition (\<lambda>_. False) T F = F"
  by (simp add: ocondition_def)

lemma ocondition_False:
    "\<lbrakk> \<And>s. \<not> P s \<rbrakk> \<Longrightarrow> ocondition P L R = R"
  by (rule ext, clarsimp simp: ocondition_def)

lemma ocondition_True:
    "\<lbrakk> \<And>s. P s \<rbrakk> \<Longrightarrow> ocondition P L R = L"
  by (rule ext, clarsimp simp: ocondition_def)

lemma in_oreturn [simp]:
  "(oreturn x s = Some v) = (v = x)"
  by (auto simp: oreturn_def K_def)

lemma oreturnE:
  "\<lbrakk>oreturn x s = Some v; v = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by simp

lemma in_ofail [simp]:
  "ofail s \<noteq> Some v"
  by (auto simp: ofail_def K_def)

lemma ofailE:
  "ofail s = Some v \<Longrightarrow> P"
  by simp

lemma in_oassert_eq [simp]:
  "(oassert P s = Some v) = P"
  by (simp add: oassert_def)

lemma oassertE:
  "\<lbrakk> oassert P s = Some v; P \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  by simp

lemma in_obind_eq:
  "((f |>> g) s = Some v) = (\<exists>v'. f s = Some v' \<and> g v' s = Some v)"
  by (simp add: obind_def split: option.splits)

lemma obindE:
  "\<lbrakk> (f |>> g) s = Some v;
     \<And>v'. \<lbrakk>f s = Some v'; g v' s = Some v\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (auto simp: in_obind_eq)

lemma in_othrow_eq [simp]:
  "(othrow e s = Some v) = (v = Inl e)"
  by (auto simp: othrow_def K_def)

lemma othrowE:
  "\<lbrakk>othrow e s = Some v; v = Inl e \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by simp

lemma in_oreturnOk_eq [simp]:
  "(oreturnOk x s = Some v) = (v = Inr x)"
  by (auto simp: oreturnOk_def K_def)

lemma oreturnOkE:
  "\<lbrakk>oreturnOk x s = Some v; v = Inr x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by simp

lemmas omonadE [elim!] =
  opt_mapE obindE oreturnE ofailE othrowE oreturnOkE oassertE

section {* "While" loops over option monad. *}

text {*
  This is an inductive definition of a while loop over the plain option monad
  (without passing through a state)
*}

inductive_set
  option_while' :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a option) \<Rightarrow> 'a option rel"
  for C B
where
    final: "\<not> C r \<Longrightarrow> (Some r, Some r) \<in> option_while' C B"
  | fail: "\<lbrakk> C r; B r = None \<rbrakk> \<Longrightarrow> (Some r, None) \<in> option_while' C B"
  | step: "\<lbrakk> C r;  B r = Some r'; (Some r', sr'') \<in> option_while' C B \<rbrakk>
           \<Longrightarrow> (Some r, sr'') \<in> option_while' C B"

definition
  "option_while C B r \<equiv>
    (if (\<exists>s. (Some r, s) \<in> option_while' C B) then
      (THE s. (Some r, s) \<in> option_while' C B) else None)"

lemma option_while'_inj:
  assumes "(s,s') \<in> option_while' C B" "(s, s'') \<in> option_while' C B"
  shows "s' = s''"
  using assms by (induct rule: option_while'.induct) (auto elim: option_while'.cases)

lemma option_while'_THE:
  assumes "(Some r, sr') \<in> option_while' C B"
  shows "(THE s. (Some r, s) \<in> option_while' C B) = sr'"
  using assms by (blast dest: option_while'_inj)

lemma option_while_simps:
  "\<not> C s \<Longrightarrow> option_while C B s = Some s"
  "C s \<Longrightarrow> B s = None \<Longrightarrow> option_while C B s = None"
  "C s \<Longrightarrow> B s = Some s' \<Longrightarrow> option_while C B s = option_while C B s'"
  "(Some s, ss') \<in> option_while' C B \<Longrightarrow> option_while C B s = ss'"
  using option_while'_inj_step[of C s B s']
  by (auto simp: option_while_def option_while'_THE
      intro: option_while'.intros
      dest: option_while'_inj
      elim: option_while'.cases)

lemma option_while_rule:
  assumes "option_while C B s = Some s'"
  assumes "I s"
  assumes istep: "\<And>s s'. C s \<Longrightarrow> I s \<Longrightarrow> B s = Some s' \<Longrightarrow> I s'"
  shows "I s' \<and> \<not> C s'"
proof -
  { fix ss ss' assume "(ss, ss') \<in> option_while' C B" "ss = Some s" "ss' = Some s'"
    then have ?thesis using `I s`
      by (induct arbitrary: s) (auto intro: istep) }
  then show ?thesis using assms(1)
    by (auto simp: option_while_def option_while'_THE split: if_split_asm)
qed

lemma option_while'_term:
  assumes "I r"
  assumes "wf M"
  assumes step_less: "\<And>r r'. \<lbrakk>I r; C r; B r = Some r'\<rbrakk> \<Longrightarrow> (r',r) \<in> M"
  assumes step_I: "\<And>r r'. \<lbrakk>I r; C r; B r = Some r'\<rbrakk> \<Longrightarrow> I r'"
  obtains sr' where "(Some r, sr') \<in> option_while' C B"
  apply atomize_elim
  using assms(2,1)
proof induct
  case (less r)
  show ?case
  proof (cases "C r" "B r" rule: bool.exhaust[case_product option.exhaust])
    case (True_Some r')
    then have "(r',r) \<in> M" "I r'"
      by (auto intro: less step_less step_I)
    then obtain sr' where "(Some r', sr') \<in> option_while' C B"
      by atomize_elim (rule less)
    then have "(Some r, sr') \<in> option_while' C B"
      using True_Some by (auto intro: option_while'.intros)
    then show ?thesis ..
  qed (auto intro: option_while'.intros)
qed

lemma option_while_rule':
  assumes "option_while C B s = ss'"
  assumes "wf M"
  assumes "I (Some s)"
  assumes less: "\<And>s s'. C s \<Longrightarrow> I (Some s) \<Longrightarrow> B s = Some s' \<Longrightarrow> (s', s) \<in> M"
  assumes step: "\<And>s s'. C s \<Longrightarrow> I (Some s) \<Longrightarrow> B s = Some s' \<Longrightarrow> I (Some s')"
  assumes final: "\<And>s. C s \<Longrightarrow> I (Some s) \<Longrightarrow> B s = None \<Longrightarrow> I None"
  shows "I ss' \<and> (case ss' of Some s' \<Rightarrow> \<not> C s' | _ \<Rightarrow> True)"
proof -
  def ss \<equiv> "Some s"
  obtain ss1' where "(Some s, ss1') \<in> option_while' C B"
    using assms(3,2,4,5) by (rule option_while'_term)
  then have *: "(ss, ss') \<in> option_while' C B" using `option_while C B s = ss'`
    by (auto simp: option_while_simps ss_def)
  show ?thesis
  proof (cases ss')
    case (Some s') with * ss_def show ?thesis using `I _`
      by (induct arbitrary:s) (auto intro: step)
  next
    case None with * ss_def show ?thesis using `I _`
      by (induct arbitrary:s) (auto intro: step final)
  qed
qed

section {* Lift @{term option_while} to the @{typ "('a,'s) lookup"} monad  *}

definition
  owhile :: "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('s,'a) lookup) \<Rightarrow> 'a \<Rightarrow> ('s,'a) lookup"
where
 "owhile c b a \<equiv> \<lambda>s. option_while (\<lambda>a. c a s) (\<lambda>a. b a s) a"

lemma owhile_unroll:
  "owhile C B r = ocondition (C r) (B r |>> owhile C B) (oreturn r)"
  by (auto simp: ocondition_def obind_def oreturn_def owhile_def
           option_while_simps K_def split: option.split)

text {* rule for terminating loops *}

lemma owhile_rule:
  assumes "I r s"
  assumes "wf M"
  assumes less: "\<And>r r'. \<lbrakk>I r s; C r s; B r s = Some r'\<rbrakk> \<Longrightarrow> (r',r) \<in> M"
  assumes step: "\<And>r r'. \<lbrakk>I r s; C r s; B r s = Some r'\<rbrakk> \<Longrightarrow> I r' s"
  assumes fail: "\<And>r r'. \<lbrakk>I r s; C r s; B r s = None\<rbrakk> \<Longrightarrow> Q None"
  assumes final: "\<And>r. \<lbrakk>I r s; \<not>C r s\<rbrakk> \<Longrightarrow> Q (Some r)"
  shows "Q (owhile C B r s)"
proof -
  let ?rs' = "owhile C B r s"
  have "(case ?rs' of Some r \<Rightarrow> I r s | _ \<Rightarrow> Q None)
      \<and> (case ?rs' of Some r' \<Rightarrow> \<not> C r' s | _ \<Rightarrow> True)"
    by (rule option_while_rule'[where B="\<lambda>r. B r s" and s=r, OF _ `wf _`])
       (auto simp: owhile_def intro: assms)
  then show ?thesis by (auto intro: final split: option.split_asm)
qed

end


theory GTT_Compose
  imports GTT
begin

subsection \<open>GTT closure under composition\<close>

inductive_set \<Delta>\<^sub>\<epsilon>_set :: "('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) set" for \<A> \<B> where
  \<Delta>\<^sub>\<epsilon>_set_cong: "TA_rule f ps p |\<in>| rules \<A> \<Longrightarrow> TA_rule f qs q |\<in>| rules \<B> \<Longrightarrow> length ps = length qs \<Longrightarrow>
   (\<And>i. i < length qs \<Longrightarrow> (ps ! i, qs ! i) \<in> \<Delta>\<^sub>\<epsilon>_set \<A> \<B>) \<Longrightarrow> (p, q) \<in> \<Delta>\<^sub>\<epsilon>_set \<A> \<B>"
| \<Delta>\<^sub>\<epsilon>_set_eps1: "(p, p') |\<in>| eps \<A> \<Longrightarrow> (p, q) \<in> \<Delta>\<^sub>\<epsilon>_set \<A> \<B> \<Longrightarrow> (p', q) \<in> \<Delta>\<^sub>\<epsilon>_set \<A> \<B>"
| \<Delta>\<^sub>\<epsilon>_set_eps2: "(q, q') |\<in>| eps \<B> \<Longrightarrow> (p, q) \<in> \<Delta>\<^sub>\<epsilon>_set \<A> \<B> \<Longrightarrow> (p, q') \<in> \<Delta>\<^sub>\<epsilon>_set \<A> \<B>"

lemma \<Delta>\<^sub>\<epsilon>_states: "\<Delta>\<^sub>\<epsilon>_set \<A> \<B> \<subseteq> fset (\<Q> \<A> |\<times>| \<Q> \<B>)"
proof -
  {fix p q assume "(p, q) \<in> \<Delta>\<^sub>\<epsilon>_set \<A> \<B>" then have "(p, q) \<in> fset (\<Q> \<A> |\<times>| \<Q> \<B>)"
      by (induct) (auto dest: rule_statesD eps_statesD simp flip: fmember_iff_member_fset)}
  then show ?thesis by auto
qed

lemma finite_\<Delta>\<^sub>\<epsilon> [simp]: "finite (\<Delta>\<^sub>\<epsilon>_set \<A> \<B>)"
  using finite_subset[OF \<Delta>\<^sub>\<epsilon>_states]
  by simp

context
includes fset.lifting
begin
lift_definition \<Delta>\<^sub>\<epsilon> :: "('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) fset" is \<Delta>\<^sub>\<epsilon>_set by simp
lemmas \<Delta>\<^sub>\<epsilon>_cong = \<Delta>\<^sub>\<epsilon>_set_cong [Transfer.transferred]
lemmas \<Delta>\<^sub>\<epsilon>_eps1 = \<Delta>\<^sub>\<epsilon>_set_eps1 [Transfer.transferred]
lemmas \<Delta>\<^sub>\<epsilon>_eps2 = \<Delta>\<^sub>\<epsilon>_set_eps2 [Transfer.transferred]
lemmas \<Delta>\<^sub>\<epsilon>_cases = \<Delta>\<^sub>\<epsilon>_set.cases[Transfer.transferred]
lemmas \<Delta>\<^sub>\<epsilon>_induct [consumes 1, case_names \<Delta>\<^sub>\<epsilon>_cong \<Delta>\<^sub>\<epsilon>_eps1  \<Delta>\<^sub>\<epsilon>_eps2] = \<Delta>\<^sub>\<epsilon>_set.induct[Transfer.transferred]
lemmas \<Delta>\<^sub>\<epsilon>_intros = \<Delta>\<^sub>\<epsilon>_set.intros[Transfer.transferred]
lemmas \<Delta>\<^sub>\<epsilon>_simps = \<Delta>\<^sub>\<epsilon>_set.simps[Transfer.transferred]
end

lemma finite_alt_def [simp]:
  "finite {(\<alpha>, \<beta>). (\<exists>t. ground t \<and> \<alpha> |\<in>| ta_der \<A> t \<and> \<beta> |\<in>| ta_der \<B> t)}" (is "finite ?S")
  by (auto dest: ground_ta_der_states[THEN fsubsetD] simp flip: fmember_iff_member_fset
           intro!: finite_subset[of ?S "fset (\<Q> \<A> |\<times>| \<Q> \<B>)"])

lemma \<Delta>\<^sub>\<epsilon>_def':
  "\<Delta>\<^sub>\<epsilon> \<A> \<B> = {|(\<alpha>, \<beta>). (\<exists>t. ground t \<and> \<alpha> |\<in>| ta_der \<A> t \<and> \<beta> |\<in>| ta_der \<B> t)|}"
proof (intro fset_eqI iffI, goal_cases lr rl)
  case (lr x) obtain p q where x [simp]: "x = (p, q)" by (cases x)
  have "\<exists>t. ground t \<and> p |\<in>| ta_der \<A> t \<and> q |\<in>| ta_der \<B> t" using lr unfolding x
  proof (induct rule: \<Delta>\<^sub>\<epsilon>_induct)
    case (\<Delta>\<^sub>\<epsilon>_cong f ps p qs q)
    obtain ts where ts: "ground (ts i) \<and> ps ! i |\<in>| ta_der \<A> (ts i) \<and> qs ! i |\<in>| ta_der \<B> (ts i)"
      if "i < length qs" for i using \<Delta>\<^sub>\<epsilon>_cong(5) by metis
    then show ?case using \<Delta>\<^sub>\<epsilon>_cong(1-3)
      by (auto intro!: exI[of _ "Fun f (map ts [0..<length qs])"]) blast+
  qed (meson ta_der_eps)+
  then show ?case by auto
next
  case (rl x) obtain p q where x [simp]: "x = (p, q)" by (cases x)
  obtain t where "ground t" "p |\<in>| ta_der \<A> t" "q |\<in>| ta_der \<B> t" using rl by auto
  then show ?case unfolding x
  proof (induct t arbitrary: p q)
    case (Fun f ts)
    obtain p' ps where p': "TA_rule f ps p' |\<in>| rules \<A>" "p' = p \<or> (p', p) |\<in>| (eps \<A>)|\<^sup>+|" "length ps = length ts"
      "\<And>i. i < length ts \<Longrightarrow> ps ! i |\<in>| ta_der \<A> (ts ! i)" using Fun(3) by auto
    obtain q' qs where q': "f qs \<rightarrow> q' |\<in>| rules \<B>" "q' = q \<or> (q', q) |\<in>| (eps \<B>)|\<^sup>+|" "length qs = length ts"
      "\<And>i. i < length ts \<Longrightarrow> qs ! i |\<in>| ta_der \<B> (ts ! i)" using Fun(4) by auto
    have st: "(p', q') |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B>"
      using Fun(1)[OF nth_mem _ p'(4) q'(4)] Fun(2) p'(3) q'(3)
      by (intro \<Delta>\<^sub>\<epsilon>_cong[OF p'(1) q'(1)]) auto
    {assume "(p', p) |\<in>| (eps \<A>)|\<^sup>+|" then have "(p, q') |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B>" using st
        by (induct rule: ftrancl_induct) (auto intro: \<Delta>\<^sub>\<epsilon>_eps1)}
    from st this p'(2) have st: "(p, q') |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B>" by auto
   {assume "(q', q) |\<in>| (eps \<B>)|\<^sup>+|" then have "(p, q) |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B>" using st
        by (induct rule: ftrancl_induct) (auto intro: \<Delta>\<^sub>\<epsilon>_eps2)}
    from st this q'(2) show "(p, q) |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B>" by auto
  qed auto
qed

lemma \<Delta>\<^sub>\<epsilon>_fmember:
  "(p, q) |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B> \<longleftrightarrow> (\<exists>t. ground t \<and> p |\<in>| ta_der \<A> t \<and> q |\<in>| ta_der \<B> t)"
  by (auto simp: \<Delta>\<^sub>\<epsilon>_def')

definition GTT_comp :: "('q, 'f) gtt \<Rightarrow> ('q, 'f) gtt \<Rightarrow> ('q, 'f) gtt" where
  "GTT_comp \<G>\<^sub>1 \<G>\<^sub>2 =
    (let \<Delta> = \<Delta>\<^sub>\<epsilon> (snd \<G>\<^sub>1) (fst \<G>\<^sub>2) in
    (TA (gtt_rules (fst \<G>\<^sub>1, fst \<G>\<^sub>2)) (eps (fst \<G>\<^sub>1) |\<union>| eps (fst \<G>\<^sub>2) |\<union>| \<Delta>),
     TA (gtt_rules (snd \<G>\<^sub>1, snd \<G>\<^sub>2)) (eps (snd \<G>\<^sub>1) |\<union>| eps (snd \<G>\<^sub>2) |\<union>| (\<Delta>|\<inverse>|))))"

lemma gtt_syms_GTT_comp:
  "gtt_syms (GTT_comp A B) = gtt_syms A |\<union>| gtt_syms B"
  by (auto simp: GTT_comp_def ta_sig_def Let_def)

lemma \<Delta>\<^sub>\<epsilon>_statesD:
  "(p, q) |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B> \<Longrightarrow> p |\<in>| \<Q> \<A>"
  "(p, q) |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B> \<Longrightarrow> q |\<in>| \<Q> \<B>"
  using subsetD[OF \<Delta>\<^sub>\<epsilon>_states, of "(p, q)" \<A> \<B>]
  by (auto simp flip: \<Delta>\<^sub>\<epsilon>.rep_eq fmember_iff_member_fset)

lemma \<Delta>\<^sub>\<epsilon>_statesD':
  "q |\<in>| eps_states (\<Delta>\<^sub>\<epsilon> \<A> \<B>) \<Longrightarrow> q |\<in>| \<Q> \<A> |\<union>| \<Q> \<B>"
  by (auto simp: eps_states_def fmember.abs_eq dest: \<Delta>\<^sub>\<epsilon>_statesD)

lemma \<Delta>\<^sub>\<epsilon>_swap:
  "prod.swap p |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B> \<longleftrightarrow> p |\<in>| \<Delta>\<^sub>\<epsilon> \<B> \<A>"
  by (auto simp: \<Delta>\<^sub>\<epsilon>_def')

lemma \<Delta>\<^sub>\<epsilon>_inverse [simp]:
  "(\<Delta>\<^sub>\<epsilon> \<A> \<B>)|\<inverse>| = \<Delta>\<^sub>\<epsilon> \<B> \<A>"
  by (auto simp: \<Delta>\<^sub>\<epsilon>_def')

lemma gtt_states_comp_union:
  "gtt_states (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2) |\<subseteq>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2"
proof (intro fsubsetI, goal_cases lr)
  case (lr q) then show ?case
    by (auto simp: GTT_comp_def gtt_states_def \<Q>_def dest: \<Delta>\<^sub>\<epsilon>_statesD')
qed

lemma GTT_comp_swap [simp]:
  "GTT_comp (prod.swap \<G>\<^sub>2) (prod.swap \<G>\<^sub>1) = prod.swap (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)"
  by (simp add: GTT_comp_def ac_simps)

lemma gtt_comp_complete_semi:
  assumes s: "q |\<in>| gta_der (fst \<G>\<^sub>1) s" and u: "q |\<in>| gta_der (snd \<G>\<^sub>1) u" and ut: "gtt_accept \<G>\<^sub>2 u t"
  shows "q |\<in>| gta_der (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) s" "q |\<in>| gta_der (snd (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) t"
proof (goal_cases L R)
  let ?\<G> = "GTT_comp \<G>\<^sub>1 \<G>\<^sub>2"
  have  sub1l: "rules (fst \<G>\<^sub>1) |\<subseteq>| rules (fst ?\<G>)" "eps (fst \<G>\<^sub>1) |\<subseteq>| eps (fst ?\<G>)"
    and sub1r: "rules (snd \<G>\<^sub>1) |\<subseteq>| rules (snd ?\<G>)" "eps (snd \<G>\<^sub>1) |\<subseteq>| eps (snd ?\<G>)"
    and sub2r: "rules (snd \<G>\<^sub>2) |\<subseteq>| rules (snd ?\<G>)" "eps (snd \<G>\<^sub>2) |\<subseteq>| eps (snd ?\<G>)"
    by (auto simp: GTT_comp_def)
  { case L then show ?case using s ta_der_mono[OF sub1l]
      by (auto simp: gta_der_def)
  next
    case R then show ?case using ut u unfolding gtt_accept_def
    proof (induct arbitrary: q s)
      case (base s t)
      from base(1) obtain p where p: "p |\<in>| gta_der (fst \<G>\<^sub>2) s" "p |\<in>| gta_der (snd \<G>\<^sub>2) t"
        by (auto simp: agtt_lang_def)
      then have "(p, q) |\<in>| eps (snd (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2))"
        using \<Delta>\<^sub>\<epsilon>_fmember[of p q "fst \<G>\<^sub>2" "snd \<G>\<^sub>1"] base(2)
        by (auto simp: GTT_comp_def gta_der_def)
      from ta_der_eps[OF this] show ?case using p ta_der_mono[OF sub2r]
        by (auto simp add: gta_der_def)
    next
      case (step ss ts f)
      from step(1, 4) obtain ps p where "TA_rule f ps p |\<in>| rules (snd \<G>\<^sub>1)" "p = q \<or> (p, q) |\<in>| (eps (snd \<G>\<^sub>1))|\<^sup>+|"
        "length ps = length ts" "\<And>i. i < length ts \<Longrightarrow> ps ! i |\<in>| gta_der (snd \<G>\<^sub>1) (ss ! i)"
        unfolding gta_der_def by auto
      then show ?case using step(1, 2) sub1r(1) ftrancl_mono[OF _ sub1r(2)]
        by (auto simp: gta_der_def intro!: exI[of _ p] exI[of _ ps])
    qed}
qed

lemmas gtt_comp_complete_semi' = gtt_comp_complete_semi[of _ "prod.swap \<G>\<^sub>2" _ _ "prod.swap \<G>\<^sub>1" for \<G>\<^sub>1 \<G>\<^sub>2,
  unfolded fst_swap snd_swap GTT_comp_swap gtt_accept_swap]

lemma gtt_comp_acomplete:
  "gcomp_rel UNIV (agtt_lang \<G>\<^sub>1) (agtt_lang \<G>\<^sub>2) \<subseteq> agtt_lang (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)"
proof (intro subrelI, goal_cases LR)
  case (LR s t)
  then consider
      q u where "q |\<in>| gta_der (fst \<G>\<^sub>1) s" "q |\<in>| gta_der (snd \<G>\<^sub>1) u" "gtt_accept \<G>\<^sub>2 u t"
    | q u where "q |\<in>| gta_der (snd \<G>\<^sub>2) t" "q |\<in>| gta_der (fst \<G>\<^sub>2) u" "gtt_accept \<G>\<^sub>1 s u"
    by (auto simp: gcomp_rel_def gtt_accept_def elim!: agtt_langE)
  then show ?case
  proof (cases)
    case 1 show ?thesis using gtt_comp_complete_semi[OF 1]
      by (auto simp: agtt_lang_def gta_der_def)
  next
    case 2 show ?thesis using gtt_comp_complete_semi'[OF 2]
      by (auto simp: agtt_lang_def gta_der_def)
  qed
qed

lemma \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>2:
  assumes "(q, q') |\<in>| (eps (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+|" "q |\<in>| gtt_states \<G>\<^sub>2"
    "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
  shows "(q, q') |\<in>| (eps (fst \<G>\<^sub>2))|\<^sup>+| \<and> q' |\<in>| gtt_states \<G>\<^sub>2"
  using assms(1-2)
proof (induct rule: converse_ftrancl_induct)
  case (Base y)
  then show ?case using assms(3)
    by (fastforce simp: GTT_comp_def gtt_states_def fmember.abs_eq dest: eps_statesD \<Delta>\<^sub>\<epsilon>_statesD(1))
next
  case (Step q p)
  have "(q, p) |\<in>| (eps (fst \<G>\<^sub>2))|\<^sup>+|" "p |\<in>| gtt_states \<G>\<^sub>2"
    using Step(1, 4) assms(3)
    by (auto simp: GTT_comp_def gtt_states_def fmember.abs_eq dest: eps_statesD \<Delta>\<^sub>\<epsilon>_statesD(1))
  then show ?case using Step(3)
    by (auto intro: ftrancl_trans)
qed

lemma \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>1:
  assumes "(p, r) |\<in>| (eps (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+|" "p |\<in>| gtt_states \<G>\<^sub>1"
    "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
  obtains "r |\<in>| gtt_states \<G>\<^sub>1" "(p, r) |\<in>| (eps (fst \<G>\<^sub>1))|\<^sup>+|"
  | q p' where "r |\<in>| gtt_states \<G>\<^sub>2" "p = p' \<or> (p, p') |\<in>| (eps (fst \<G>\<^sub>1))|\<^sup>+|" "(p', q) |\<in>| \<Delta>\<^sub>\<epsilon> (snd \<G>\<^sub>1) (fst \<G>\<^sub>2)"
    "q = r \<or> (q, r) |\<in>| (eps (fst \<G>\<^sub>2))|\<^sup>+|"
  using assms(1,2)
proof (induct arbitrary: thesis rule: converse_ftrancl_induct)
  case (Base p)
  from Base(1) consider (a) "(p, r) |\<in>| eps (fst \<G>\<^sub>1)" | (b) "(p, r) |\<in>| eps (fst \<G>\<^sub>2)" |
    (c) "(p, r) |\<in>| (\<Delta>\<^sub>\<epsilon> (snd \<G>\<^sub>1) (fst \<G>\<^sub>2))"
    by (auto simp: GTT_comp_def fmember.abs_eq)
  then show ?case using assms(3) Base
    by cases (auto simp: GTT_comp_def gtt_states_def fmember.abs_eq dest: eps_statesD \<Delta>\<^sub>\<epsilon>_statesD)
next
  case (Step q p)
  consider "(q, p) |\<in>| (eps (fst \<G>\<^sub>1))|\<^sup>+|" "p |\<in>| gtt_states \<G>\<^sub>1"
    | "(q, p) |\<in>| \<Delta>\<^sub>\<epsilon> (snd \<G>\<^sub>1) (fst \<G>\<^sub>2)" "p |\<in>| gtt_states \<G>\<^sub>2" using assms(3) Step(1, 6)
    by (auto simp: GTT_comp_def gtt_states_def fmember.abs_eq dest: eps_statesD \<Delta>\<^sub>\<epsilon>_statesD)
  then show ?case
  proof (cases)
    case 1 note a = 1 show ?thesis
    proof (cases rule: Step(3))
      case (2 p' q)
      then show ?thesis using assms a
        by (auto intro: Step(5) ftrancl_trans)
    qed (auto simp: a(2) intro: Step(4) ftrancl_trans[OF a(1)])
  next
    case 2 show ?thesis using \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>2[OF Step(2) 2(2) assms(3)] Step(5)[OF _ _ 2(1)] by auto
  qed
qed

lemma \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>1_\<G>\<^sub>2:
  assumes "(q, q') |\<in>| (eps (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+|" "q |\<in>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2"
    "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
  obtains "q |\<in>| gtt_states \<G>\<^sub>1" "q' |\<in>| gtt_states \<G>\<^sub>1" "(q, q') |\<in>| (eps (fst \<G>\<^sub>1))|\<^sup>+|"
  | p p' where "q |\<in>| gtt_states \<G>\<^sub>1" "q' |\<in>| gtt_states \<G>\<^sub>2" "q = p \<or> (q, p) |\<in>| (eps (fst \<G>\<^sub>1))|\<^sup>+|"
    "(p, p') |\<in>| \<Delta>\<^sub>\<epsilon> (snd \<G>\<^sub>1) (fst \<G>\<^sub>2)" "p' = q' \<or> (p', q') |\<in>| (eps (fst \<G>\<^sub>2))|\<^sup>+|"
  | "q |\<in>| gtt_states \<G>\<^sub>2" "(q, q') |\<in>| (eps (fst \<G>\<^sub>2))|\<^sup>+| \<and> q' |\<in>| gtt_states \<G>\<^sub>2"
  using assms \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>1 \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>2
  by (metis funion_iff)

lemma GTT_comp_eps_fst_statesD:
  "(p, q) |\<in>| eps (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) \<Longrightarrow> p |\<in>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2"
  "(p, q) |\<in>| eps (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) \<Longrightarrow> q |\<in>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2"
  by (auto simp: GTT_comp_def gtt_states_def fmember.abs_eq dest: eps_statesD \<Delta>\<^sub>\<epsilon>_statesD)

lemma GTT_comp_eps_ftrancl_fst_statesD:
  "(p, q) |\<in>| (eps (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+| \<Longrightarrow> p |\<in>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2"
  "(p, q) |\<in>| (eps (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+| \<Longrightarrow> q |\<in>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2"
  using GTT_comp_eps_fst_statesD[of _ _ \<G>\<^sub>1 \<G>\<^sub>2]
  by (meson converse_ftranclE ftranclE)+

lemma GTT_comp_first:
  assumes "q |\<in>| ta_der (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) t" "q |\<in>| gtt_states \<G>\<^sub>1"
    "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
  shows "q |\<in>| ta_der (fst \<G>\<^sub>1) t"
  using assms(1,2)
proof (induct t arbitrary: q)
  case (Var q')
  have "q \<noteq> q' \<Longrightarrow> q' |\<in>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2" using Var
    by (auto dest: GTT_comp_eps_ftrancl_fst_statesD)
  then show ?case using Var assms(3)
    by (auto elim: \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>1_\<G>\<^sub>2)
next
  case (Fun f ts)
  obtain q' qs where q': "TA_rule f qs q' |\<in>| rules (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2))"
    "q' = q \<or> (q', q) |\<in>| (eps (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+|" "length qs = length ts"
    "\<And>i. i < length ts \<Longrightarrow> qs ! i |\<in>| ta_der (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) (ts ! i)"
    using Fun(2) by auto
  have "q' |\<in>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2" using q'(1)
    by (auto simp: GTT_comp_def gtt_states_def dest: rule_statesD)
  then have st: "q' |\<in>| gtt_states \<G>\<^sub>1" and eps:"q' = q \<or> (q', q) |\<in>| (eps (fst \<G>\<^sub>1))|\<^sup>+|"
    using q'(2) Fun(3) assms(3)
    by (auto elim!: \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>1_\<G>\<^sub>2)
  from st have rule: "TA_rule f qs q' |\<in>| rules (fst \<G>\<^sub>1)" using assms(3) q'(1)
    by (auto simp: GTT_comp_def gtt_states_def dest: rule_statesD)
  have "i < length ts \<Longrightarrow> qs ! i |\<in>| ta_der (fst \<G>\<^sub>1) (ts ! i)" for i
    using rule q'(3, 4)
    by (intro Fun(1)[OF nth_mem]) (auto simp: gtt_states_def dest!: rule_statesD(4))
  then show ?case using q'(3) rule eps
    by auto
qed

lemma GTT_comp_second:
  assumes "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}" "q |\<in>| gtt_states \<G>\<^sub>2"
    "q |\<in>| ta_der (snd (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) t"
  shows "q |\<in>| ta_der (snd \<G>\<^sub>2) t"
  using assms GTT_comp_first[of q "prod.swap \<G>\<^sub>2" "prod.swap \<G>\<^sub>1"]
  by (auto simp: gtt_states_def)

lemma gtt_comp_sound_semi:
  fixes \<G>\<^sub>1 \<G>\<^sub>2 :: "('f, 'q) gtt"
  assumes as2: "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
  and 1: "q |\<in>| gta_der (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) s" "q |\<in>| gta_der (snd (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) t" "q |\<in>| gtt_states \<G>\<^sub>1"
  shows "\<exists>u. q |\<in>| gta_der (snd \<G>\<^sub>1) u \<and> gtt_accept \<G>\<^sub>2 u t" using 1(2,3) unfolding gta_der_def
proof (induct rule: ta_der_gterm_induct)
  case (GFun f ts ps p q)
  show ?case
  proof (cases "p |\<in>| gtt_states \<G>\<^sub>1")
    case True
    then have *: "TA_rule f ps p |\<in>| rules (snd \<G>\<^sub>1)" using GFun(1, 6) as2
      by (auto simp: GTT_comp_def gtt_states_def dest: rule_statesD)
    moreover have st: "i < length ps \<Longrightarrow> ps ! i |\<in>| gtt_states \<G>\<^sub>1" for i using *
      by (force simp: gtt_states_def dest: rule_statesD)
    moreover have "i < length ps \<Longrightarrow> \<exists>u. ps ! i |\<in>| ta_der (snd \<G>\<^sub>1) (term_of_gterm u) \<and> gtt_accept \<G>\<^sub>2 u (ts ! i)" for i
      using st GFun(2) by (intro GFun(5)) simp
    then obtain us where
      "\<And>i. i < length ps \<Longrightarrow> ps ! i |\<in>| ta_der (snd \<G>\<^sub>1) (term_of_gterm (us i)) \<and> gtt_accept \<G>\<^sub>2 (us i) (ts ! i)"
      by metis
    moreover have "p = q \<or> (p, q) |\<in>| (eps (snd \<G>\<^sub>1))|\<^sup>+|" using GFun(3, 6) True as2
      by (auto simp: gtt_states_def  elim!: \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>1_\<G>\<^sub>2[of p q "prod.swap \<G>\<^sub>2" "prod.swap \<G>\<^sub>1", simplified])
    ultimately show ?thesis using GFun(2)
      by (intro exI[of _ "GFun f (map us [0..<length ts])"])
         (auto simp: gtt_accept_def intro!: exI[of _ ps] exI[of _ p])
  next
    case False note nt_st = this
    then have False: "p \<noteq> q" using GFun(6) by auto
    then have eps: "(p, q) |\<in>| (eps (snd (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+|" using GFun(3) by simp
    show ?thesis using \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>1_\<G>\<^sub>2[of p q "prod.swap \<G>\<^sub>2" "prod.swap \<G>\<^sub>1", simplified, OF eps]
    proof (cases, goal_cases)
      case 1 then show ?case using False GFun(3)
        by (metis GTT_comp_eps_ftrancl_fst_statesD(1) GTT_comp_swap fst_swap funion_iff)
    next
      case 2 then show ?case using as2 by (auto simp: gtt_states_def)
    next
      case 3 then show ?case using as2 GFun(6) by (auto simp: gtt_states_def)
    next
      case (4 r p')
      have meet: "r |\<in>| ta_der (snd (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) (Fun f (map term_of_gterm ts))"
        using GFun(1 - 4) 4(3) False
        by (auto simp: GTT_comp_def in_ftrancl_UnI intro!: exI[ of _ ps] exI[ of _ p])
      then obtain u where wit: "ground u" "p' |\<in>| ta_der (snd \<G>\<^sub>1) u" "r |\<in>| ta_der (fst \<G>\<^sub>2) u"
        using 4(4-) unfolding \<Delta>\<^sub>\<epsilon>_def' by blast
      from wit(1, 3) have "gtt_accept \<G>\<^sub>2 (gterm_of_term u) (GFun f ts)"
        using GTT_comp_second[OF as2 _ meet] unfolding gtt_accept_def
        by (intro gmctxt_cl.base agtt_langI[of r])
           (auto simp add: gta_der_def gtt_states_def simp del: ta_der_Fun dest: ground_ta_der_states)
      then show ?case using 4(5) wit(1, 2)
        by (intro exI[of _ "gterm_of_term u"]) (auto simp add: ta_der_trancl_eps)
    next
      case 5
      then show ?case using nt_st as2
        by (simp add: gtt_states_def)
    qed
  qed
qed

lemma gtt_comp_asound:
  assumes "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
  shows "agtt_lang (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2) \<subseteq> gcomp_rel UNIV (agtt_lang \<G>\<^sub>1) (agtt_lang \<G>\<^sub>2)"
proof (intro subrelI, goal_cases LR)
  case (LR s t)
  obtain q where q: "q |\<in>| gta_der (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) s" "q |\<in>| gta_der (snd (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) t"
    using LR by (auto simp: agtt_lang_def)
  { (* prepare symmetric cases: q |\<in>| gtt_states \<G>\<^sub>1 and q |\<in>| gtt_states \<G>\<^sub>2 *)
    fix \<G>\<^sub>1 \<G>\<^sub>2 s t assume as2: "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
      and 1: "q |\<in>| ta_der (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) (term_of_gterm s)"
        "q |\<in>| ta_der (snd (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) (term_of_gterm t)" "q |\<in>| gtt_states \<G>\<^sub>1"
    note st = GTT_comp_first[OF 1(1,3) as2]
    obtain u where u: "q |\<in>| ta_der (snd \<G>\<^sub>1) (term_of_gterm u)" "gtt_accept \<G>\<^sub>2 u t"
      using gtt_comp_sound_semi[OF as2 1[folded gta_der_def]] by (auto simp: gta_der_def)
    have "(s, u) \<in> agtt_lang \<G>\<^sub>1" using st u(1)
      by (auto simp: agtt_lang_def gta_der_def)
    moreover have "(u, t) \<in> gtt_lang \<G>\<^sub>2" using u(2)
      by (auto simp: gtt_accept_def)
    ultimately have "(s, t) \<in> agtt_lang \<G>\<^sub>1 O gmctxt_cl UNIV (agtt_lang \<G>\<^sub>2)"
      by auto}
  note base = this
  consider "q |\<in>| gtt_states \<G>\<^sub>1" | "q |\<in>| gtt_states \<G>\<^sub>2" | "q |\<notin>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2" by blast
  then show ?case using q assms
  proof (cases, goal_cases)
    case 1 then show ?case using base[of \<G>\<^sub>1 \<G>\<^sub>2 s t]
      by (auto simp: gcomp_rel_def gta_der_def)
  next
    case 2 then show ?case using base[of "prod.swap \<G>\<^sub>2" "prod.swap \<G>\<^sub>1" t s, THEN converseI]
      by (auto simp: gcomp_rel_def converse_relcomp converse_agtt_lang gta_der_def gtt_states_def)
         (simp add: finter_commute funion_commute gtt_lang_swap prod.swap_def)+
  next
    case 3 then show ?case using fsubsetD[OF gtt_states_comp_union[of \<G>\<^sub>1 \<G>\<^sub>2], of q]
      by (auto simp: gta_der_def gtt_states_def)
  qed
qed

lemma gtt_comp_lang_complete:
  shows "gtt_lang \<G>\<^sub>1 O gtt_lang \<G>\<^sub>2 \<subseteq> gtt_lang (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)"
  using gmctxt_cl_mono_rel[OF gtt_comp_acomplete, of UNIV \<G>\<^sub>1 \<G>\<^sub>2]
  by (simp only: gcomp_rel[symmetric])

lemma gtt_comp_alang:
  assumes "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
  shows "agtt_lang (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2) = gcomp_rel UNIV (agtt_lang \<G>\<^sub>1) (agtt_lang \<G>\<^sub>2)"
  by (intro equalityI gtt_comp_asound[OF assms] gtt_comp_acomplete)

lemma gtt_comp_lang:
  assumes "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
  shows "gtt_lang (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2) = gtt_lang \<G>\<^sub>1 O gtt_lang \<G>\<^sub>2"
  by (simp only: arg_cong[OF gtt_comp_alang[OF assms], of "gmctxt_cl UNIV"] gcomp_rel)

abbreviation GTT_comp' where
  "GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2 \<equiv> GTT_comp (fmap_states_gtt Inl \<G>\<^sub>1) (fmap_states_gtt Inr \<G>\<^sub>2)"

lemma gtt_comp'_alang:
  shows "agtt_lang (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2) = gcomp_rel UNIV (agtt_lang \<G>\<^sub>1) (agtt_lang \<G>\<^sub>2)"
proof -
  have [simp]: "finj_on Inl (gtt_states \<G>\<^sub>1)" "finj_on Inr (gtt_states \<G>\<^sub>2)"
    by (auto simp add: finj_on.rep_eq)
  then show ?thesis
    by (subst gtt_comp_alang) (auto simp: agtt_lang_fmap_states_gtt)
qed

end