theory Test_Suite_ATC
imports Adaptive_Test_Case State_Preamble Traversal_Set
begin

section \<open>Test Suites as (Preamble, m-Traversal-Sequence, ATC set) sets\<close>

subsection \<open>Preliminary Definitions\<close>

type_synonym 'a Preamble = "'a FSM"
type_synonym 'a Traversal_Path = "'a Transition list"
type_synonym 'a ATC = "'a FSM"

(* todo: rename *)
fun get_atc :: "'a FSM \<Rightarrow> 'a \<Rightarrow> 'a Traversal_Path \<Rightarrow> 'a \<Rightarrow> 'a Traversal_Path \<Rightarrow> (('a \<times> 'a) \<times> 'c ATC) list \<Rightarrow> 'c ATC option" where
  "get_atc M q1 p1 q2 p2 dists = (case find (\<lambda> ((q1',q2'),A) . q1' = target p1 q1 \<and> q2' = target p2 q2) dists of
                              Some ((q1'',q2''),A) \<Rightarrow> Some A |
                              None             \<Rightarrow> None)"

(* todo: move *)
lemma r_distinguishable_state_pairs_with_separators_elem_is_separator:
  assumes "((q1,q2),A) \<in> r_distinguishable_state_pairs_with_separators M"
  and     "observable M"
  and     "completely_specified M"
shows "is_separator M q1 q2 A (Inr q1) (Inr q2)"
proof -
  have *:"q1 \<in> nodes M" and **:"q2 \<in> nodes M" and ***:"q1 \<noteq> q2" and ****: "q2\<noteq>q1" and *****: "calculate_state_separator_from_s_states M q1 q2 = Some A \<or> calculate_state_separator_from_s_states M q2 q1 = Some A"
    using assms(1) unfolding r_distinguishable_state_pairs_with_separators_def by auto

  from ***** have "is_state_separator_from_canonical_separator (canonical_separator M q1 q2) q1 q2 A \<or> is_state_separator_from_canonical_separator (canonical_separator M q2 q1) q2 q1 A"
    using calculate_state_separator_from_s_states_soundness[of M q1 q2 A, OF _ * ** *** \<open>completely_specified M\<close>]
    using calculate_state_separator_from_s_states_soundness[of M q2 q1 A, OF _ ** * **** \<open>completely_specified M\<close>] by auto
  then show ?thesis
    using state_separator_from_canonical_separator_is_separator[of M q1 q2 A, OF _ \<open>observable M\<close> * ** ***]
    using state_separator_from_canonical_separator_is_separator[of M q2 q1 A, OF _ \<open>observable M\<close> ** * ****]
    using is_separator_sym[of M q2 q1 A "Inr q2" "Inr q1"] by auto
qed

lemma get_atc_soundness :
  assumes "get_atc M q1 p1 q2 p2 (r_distinguishable_state_pairs_with_separators_naive M) = Some A"
  and     "q1 \<in> nodes M"
  and     "q2 \<in> nodes M"
  and     "path M q1 p1"
  and     "path M q2 p2"
  and     "observable M"
  and     "completely_specified M"
shows "is_separator M (target p1 q1) (target p2 q2) A (Inr (target p1 q1)) (Inr (target p2 q2))"
proof -

  have "find (\<lambda>((q1', q2'), A). q1' = target p1 q1 \<and> q2' = target p2 q2) (r_distinguishable_state_pairs_with_separators_naive M) \<noteq> None"
    using assms(1) unfolding get_atc.simps
    by (metis option.case_eq_if option.simps(3))
  then obtain q1' q2' where *: "find (\<lambda>((q1', q2'), A). q1' = target p1 q1 \<and> q2' = target p2 q2) (r_distinguishable_state_pairs_with_separators_naive M) = Some ((q1',q2'),A)"
    using assms(1) unfolding get_atc.simps by auto
  have "((target p1 q1, target p2 q2),A) \<in> r_distinguishable_state_pairs_with_separators M"
    using find_condition[OF *]
    using find_set[OF *]
    using r_distinguishable_state_pairs_with_separators_code[of M] by auto

  then show ?thesis
    using r_distinguishable_state_pairs_with_separators_elem_is_separator[OF _ \<open>observable M\<close> \<open>completely_specified M\<close>] by auto
qed

(* TODO: move to Util *)

fun prefix_pairs :: "'a list \<Rightarrow> ('a list \<times> 'a list) list"
  where "prefix_pairs [] = []" |
        "prefix_pairs xs = prefix_pairs (butlast xs) @ (map (\<lambda> ys. (ys,xs)) (butlast (prefixes xs)))"

value "prefix_pairs [1,2,3::nat]"

lemma prefixes_butlast :
  "set (butlast (prefixes xs)) = {ys . \<exists> zs . ys@zs = xs \<and> zs \<noteq> []}"
proof (cases xs rule: rev_cases)
  case Nil
  then show ?thesis by auto
next
  case (snoc ys y)

  have "prefixes (ys@[y]) = (prefixes ys) @ [ys@[y]]"
    by (metis prefixes.elims snoc_eq_iff_butlast)
  then have "butlast (prefixes xs) = prefixes ys"
    using snoc by auto
  then have "set (butlast (prefixes xs)) = {xs'. \<exists>xs''. xs' @ xs'' = ys}"
    using prefixes_set by auto
  also have "... = {xs'. \<exists>xs''. xs' @ xs'' = ys@[y] \<and> xs'' \<noteq> []}"
    by (metis (no_types, lifting) Nil_is_append_conv append.assoc butlast_append butlast_snoc not_Cons_self2)
  finally show ?thesis
    using snoc by simp
qed

lemma prefix_pairs_set :
  "set (prefix_pairs xs) = {(zs,ys) | zs ys . \<exists> xs1 xs2 . zs@xs1 = ys \<and> ys@xs2 = xs \<and> xs1 \<noteq> []}"
proof (induction xs rule: rev_induct)
  case Nil
  then show ?case by auto
next
  case (snoc x xs)
  have "prefix_pairs (xs @ [x]) = prefix_pairs (butlast (xs @ [x])) @ (map (\<lambda> ys. (ys,(xs @ [x]))) (butlast (prefixes (xs @ [x]))))"
    by (cases "(xs @ [x])"; auto)
  then have *: "prefix_pairs (xs @ [x]) = prefix_pairs xs @ (map (\<lambda> ys. (ys,(xs @ [x]))) (butlast (prefixes (xs @ [x]))))"
    by auto

  have "set (prefix_pairs xs) = {(zs, ys) |zs ys. \<exists>xs1 xs2. zs @ xs1 = ys \<and> ys @ xs2 = xs \<and> xs1 \<noteq> []}"
    using snoc.IH by assumption
  then have "set (prefix_pairs xs) = {(zs, ys) |zs ys. \<exists>xs1 xs2. zs @ xs1 = ys \<and> ys @ xs2 @ [x] = xs@[x] \<and> xs1 \<noteq> []}"
    by auto
  also have "... = {(zs, ys) |zs ys. \<exists>xs1 xs2. zs @ xs1 = ys \<and> ys @ xs2 = xs @[x] \<and> xs1 \<noteq> [] \<and> xs2 \<noteq> []}"
  proof -
    let ?P1 = "\<lambda> zs ys . (\<exists>xs1 xs2. zs @ xs1 = ys \<and> ys @ xs2 @ [x] = xs@[x] \<and> xs1 \<noteq> [])"
    let ?P2 = "\<lambda> zs ys . (\<exists>xs1 xs2. zs @ xs1 = ys \<and> ys @ xs2 = xs @[x] \<and> xs1 \<noteq> [] \<and> xs2 \<noteq> [])"

    have "\<And> ys zs . ?P2 zs ys \<Longrightarrow> ?P1 zs ys"
      by (metis append_assoc butlast_append butlast_snoc)
    then have "\<And> ys zs . ?P1 ys zs = ?P2 ys zs"
      by blast
    then show ?thesis by force
  qed
  finally have "set (prefix_pairs xs) = {(zs, ys) |zs ys. \<exists>xs1 xs2. zs @ xs1 = ys \<and> ys @ xs2 = xs @ [x] \<and> xs1 \<noteq> [] \<and> xs2 \<noteq> []}"
    by assumption

  moreover have "set (map (\<lambda> ys. (ys,(xs @ [x]))) (butlast (prefixes (xs @ [x])))) = {(zs, ys) |zs ys. \<exists>xs1 xs2. zs @ xs1 = ys \<and> ys @ xs2 = xs @ [x] \<and> xs1 \<noteq> [] \<and> xs2 = []}"
    using prefixes_butlast[of "xs@[x]"] by force

  ultimately show ?case using * by force
qed

(* functions to create functions that avoid recalculations, possibly incorrect ... *)
fun update_fun_for_list :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<times>'b) list \<Rightarrow> ('a \<Rightarrow> 'b)" where
  "update_fun_for_list f [] = f" |
  "update_fun_for_list f (x#xs) = update_fun_for_list (f((fst x):=(snd x))) xs"

fun update_fun_for_fun_on :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> ('a \<Rightarrow> 'b)" where
  "update_fun_for_fun_on f g [] = f" |
  "update_fun_for_fun_on f g (x#xs) = update_fun_for_fun_on (f(x := g x)) g xs"

value "map (\<lambda>x . x) [1,2,3,4::nat]"
value "map (update_fun_for_list (\<lambda>x . x) [(1,2),(2,7)]) [1,2,3,4::nat]"
value "map (update_fun_for_fun_on (\<lambda>x . x) (\<lambda> x . 7 * x) [2,4]) [1,2,3,4::nat]"

lemma update_fun_for_fun_on_other :
  assumes "x \<notin> set xs"
  shows "(update_fun_for_fun_on f g xs) x = f x"
  using assms by (induction xs arbitrary: f; auto)

lemma update_fun_for_fun_on_some :
  assumes "x \<in> set xs"
  shows "(update_fun_for_fun_on f g xs) x = g x"
using assms proof (induction xs arbitrary: f)
  case Nil
  then show ?case by auto
next
  case (Cons y ys)
  then have "x \<in> set ys \<Longrightarrow> (update_fun_for_fun_on f g (y#ys)) x = g x"
    by auto
  moreover have "x = y \<Longrightarrow> (update_fun_for_fun_on f g (y#ys)) x = g x"
  proof -
    assume "x = y"
    then show "(update_fun_for_fun_on f g (y#ys)) x = g x"
    proof (cases "x \<in> set ys")
      case True
      then show ?thesis using Cons.IH by auto
    next
      case False
      show ?thesis using update_fun_for_fun_on_other[OF False, of f g] \<open>x = y\<close>
        by (metis calculation fun_upd_apply update_fun_for_fun_on.simps(2) update_fun_for_fun_on_other)
    qed
  qed
  ultimately show ?case using \<open>x : set (y#ys)\<close> by auto
qed

fun list_as_fun :: "('a \<times> 'b) list \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b)" where
  "list_as_fun xs defaultValue = (\<lambda> x . (case find (\<lambda>(a,b) . a = x) xs of Some (a,b) \<Rightarrow> b | None \<Rightarrow> defaultValue))"

fun list_as_fun' :: "('a \<times> 'b) list \<Rightarrow> ('a \<Rightarrow> 'b)" where
  "list_as_fun' xs = (\<lambda> x . (case find (\<lambda>(a,b) . a = x) xs of Some (a,b) \<Rightarrow> b ))"

value "(list_as_fun' [(1::nat,2::nat)]) 1"

lemma list_as_fun_on :
  assumes "a \<in> set xs"
shows "(list_as_fun (map (\<lambda> x . (x, f x)) xs) y) a = f a"
  using assms by (induction xs; auto)

(*
lemma rdssl_list_as_fun_helper :
  assumes "((q1,q2),A) \<in> set (r_distinguishable_state_pairs_with_separators_naive M)"
  shows "(list_as_fun (r_distinguishable_state_pairs_with_separators_naive M) (THE A. False)) (q1,q2) = A"
proof -
  have "find (\<lambda>(a,b) . a = (q1,q2)) (r_distinguishable_state_pairs_with_separators_naive M) \<noteq> None"
    using assms find_None_iff[of "(\<lambda>(a,b) . a = (q1,q2))" "r_distinguishable_state_pairs_with_separators_naive M"] by auto
  then obtain q1' q2' A' where *:"find (\<lambda>(a,b) . a = (q1,q2)) (r_distinguishable_state_pairs_with_separators_naive M) = Some ((q1',q2'),A')"
    by auto

  have "q1' = q1" and "q2' = q2"
    using find_condition[OF *] by auto
  then have "((q1,q2),A') \<in> set (r_distinguishable_state_pairs_with_separators_naive M)"
    using find_set[OF *] by auto
  then have "A' = A"
    using r_distinguishable_state_pairs_with_separators_same_pair_same_separator[of q1 q2 A' M A] assms
    unfolding r_distinguishable_state_pairs_with_separators_code by blast
  then show ?thesis using * by auto
qed
*)

lemma fRD_helper :
  assumes "((q1,q2),A) \<in> r_distinguishable_state_pairs_with_separators M"
  shows "(\<lambda> q1 q2 . snd (the (find (\<lambda> qqA . fst qqA = (q1,q2)) (r_distinguishable_state_pairs_with_separators_naive M)))) q1 q2 = A"
proof -
  have "\<And> qqA . fst qqA = (q1, q2) \<Longrightarrow> qqA \<in> r_distinguishable_state_pairs_with_separators M \<Longrightarrow> qqA = ((q1,q2),A)"
    using r_distinguishable_state_pairs_with_separators_same_pair_same_separator[OF assms]
    by auto

  then have "(find (\<lambda>qqA. fst qqA = (q1, q2)) (r_distinguishable_state_pairs_with_separators_naive M)) = Some ((q1,q2),A)"

    using find_None_iff[of "(\<lambda>qqA. fst qqA = (q1, q2))" "r_distinguishable_state_pairs_with_separators_naive M"]
    using assms
  proof -
    have f1: "find (\<lambda>p. fst p = (q1, q2)) (r_distinguishable_state_pairs_with_separators_naive M) = Some (the (find (\<lambda>p. fst p = (q1, q2)) (r_distinguishable_state_pairs_with_separators_naive M)))"
      by (metis \<open>((q1, q2), A) \<in> r_distinguishable_state_pairs_with_separators M\<close> \<open>(find (\<lambda>qqA. fst qqA = (q1, q2)) (r_distinguishable_state_pairs_with_separators_naive M) = None) = (\<nexists>x. x \<in> set (r_distinguishable_state_pairs_with_separators_naive M) \<and> fst x = (q1, q2))\<close> fst_conv option.exhaust_sel r_distinguishable_state_pairs_with_separators_code)
    then have f2: "fst (the (find (\<lambda>p. fst p = (q1, q2)) (r_distinguishable_state_pairs_with_separators_naive M))) = (q1, q2)"
      by (meson find_condition)
    have "the (find (\<lambda>p. fst p = (q1, q2)) (r_distinguishable_state_pairs_with_separators_naive M)) \<in> r_distinguishable_state_pairs_with_separators M"
      using f1 by (simp add: find_set r_distinguishable_state_pairs_with_separators_code)
    then show ?thesis
      using f2 f1 \<open>\<And>qqA. \<lbrakk>fst qqA = (q1, q2); qqA \<in> r_distinguishable_state_pairs_with_separators M\<rbrakk> \<Longrightarrow> qqA = ((q1, q2), A)\<close> by presburger
  qed

  then show ?thesis by auto
qed

(*
lemma fTP_helper :
  fixes m :: nat
  assumes "q \<in> set (map fst (d_reachable_states_with_preambles M))"
  shows "True"
proof -
  note list_as_fun_on[OF assms, of "\<lambda> q . m_traversal_paths_with_witness M q (map (\<lambda>S. (S, S \<inter> set (map fst (d_reachable_states_with_preambles M)))) (filter (\<lambda> S . \<not>(\<exists> S' \<in> set (filter (\<lambda> S . \<forall> q1 \<in> S . \<forall> q2 \<in> S . q1 \<noteq> q2 \<longrightarrow> (q1,q2) \<in> (image fst (set (r_distinguishable_state_pairs_with_separators_naive M)))) (map set (pow_list (nodes_from_distinct_paths M)))) . S \<subset> S')) (filter (\<lambda> S . \<forall> q1 \<in> S . \<forall> q2 \<in> S . q1 \<noteq> q2 \<longrightarrow> (q1,q2) \<in> (image fst (set (r_distinguishable_state_pairs_with_separators_naive M)))) (map set (pow_list (nodes_from_distinct_paths M)))))) m" "[]" ]
  *)

(* Test cases between two prefixes of some traversal sequence *)
(* Assumes that states in rd are pairwise r-d and uses fRD to retrieve a separator *)
fun calculate_test_case_for_prefixes :: "'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'c ATC) \<Rightarrow> 'a Traversal_Path \<Rightarrow> ('a set \<times> 'a set) \<Rightarrow> (('a Traversal_Path \<times> 'a Traversal_Path) \<times> 'c ATC) list" where
  "calculate_test_case_for_prefixes q fRD p (rd,dr) = (map (\<lambda> (p1,p2) . ((p1,p2), fRD (target p1 q) (target p2 q)))      \<comment> \<open>retrieve separator using fRD\<close>
                                                 (filter (\<lambda> (p1,p2) . (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd) \<comment> \<open>ensure that a separator exists, assuming that the states in rd are pairwise r-d\<close>
                                                         (prefix_pairs p)))"

fun calculate_test_cases_for_prefixes :: "'a \<Rightarrow> 'a Preamble \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'c ATC) \<Rightarrow> ('a Traversal_Path \<times> ('a set \<times> 'a set)) list \<Rightarrow> ('a Preamble \<times> 'a Traversal_Path \<times> 'c ATC) list" where
  "calculate_test_cases_for_prefixes q P fRD pds = concat (map (\<lambda> (p,d) . concat (map (\<lambda>((p1,p2),A) . [(P,p1,A),(P,p2,A)]) (calculate_test_case_for_prefixes q fRD p d))) pds)"

lemma calculate_test_case_for_prefixes_set :
  "set (calculate_test_case_for_prefixes q fRD p (rd,dr)) = {((p1,p2), fRD (target p1 q) (target p2 q)) | p1 p2 . (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (\<exists>p' p''. p1 @ p' = p2 \<and> p2 @ p'' = p \<and> p' \<noteq> [])}"
proof -
  have "set (prefix_pairs p) = {(p1, p2) | p1 p2 . \<exists>p' p''. p1 @ p' = p2 \<and> p2 @ p'' = p \<and> p' \<noteq> []}"
    using prefix_pairs_set[of p] by assumption
  then have "set (filter (\<lambda> (p1,p2) . (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd) (prefix_pairs p)) =  {(p1, p2) | p1 p2 . (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (\<exists>p' p''. p1 @ p' = p2 \<and> p2 @ p'' = p \<and> p' \<noteq> [])}"
    by fastforce
  moreover have "image (\<lambda> (p1,p2) . ((p1,p2), fRD (target p1 q) (target p2 q))) {(p1, p2) | p1 p2 . (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (\<exists>p' p''. p1 @ p' = p2 \<and> p2 @ p'' = p \<and> p' \<noteq> [])} = {((p1,p2), fRD (target p1 q) (target p2 q)) | p1 p2 . (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (\<exists>p' p''. p1 @ p' = p2 \<and> p2 @ p'' = p \<and> p' \<noteq> [])}"
    by fast
  ultimately show ?thesis unfolding calculate_test_case_for_prefixes.simps by force
qed

(*
lemma calculate_test_cases_for_prefixes_set :
  "set (calculate_test_cases_for_prefixes q fRD pds) = (\<Union> (p,d) \<in> set pds . (\<Union> {{(P,p1,fRD (target p1 q) (target p2 q)),(P,p2,fRD (target p1 q) (target p2 q))} | p1 p2 . (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (\<exists>p' p''. p1 @ p' = p2 \<and> p2 @ p'' = p \<and> p' \<noteq> []) }))"
proof -
  thm concat_map_elem

  have scheme : "\<And> f xs . set (concat (map f xs)) = \<Union>(image (set o f) (set xs))" by auto

  have "\<And> p rd dr . set (calculate_test_case_for_prefixes q fRD p (rd,dr)) = {((p1,p2), fRD (target p1 q) (target p2 q)) | p1 p2 . (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (\<exists>p' p''. p1 @ p' = p2 \<and> p2 @ p'' = p \<and> p' \<noteq> [])}"
    using calculate_test_case_for_prefixes_set[of q fRD] by blast

  have "\<And> p rd dr . set (concat (map (\<lambda>((p1,p2),A) . [(P,p1,A),(P,p2,A)]) (calculate_test_case_for_prefixes q fRD p (rd,dr)))) = \<Union> (image (\<lambda>((p1,p2),A) . set [(P,p1,A),(P,p2,A)]) (set (calculate_test_case_for_prefixes q fRD p (rd,dr))))"
  proof -
    fix p rd dr

    have "UNION
   {((p1, p2), fRD (target p1 q) (target p2 q)) |p1 p2. target p1 q \<in> rd \<and> target p2 q \<in> rd \<and> (\<exists>p' p''. p1 @ p' = p2 \<and> p2 @ p'' = p \<and> p' \<noteq> [])}
   (set \<circ> (\<lambda>((p1, p2), A). [(P, p1, A), (P, p2, A)])) = (\<Union>((p1, p2), A)\<in>set (calculate_test_case_for_prefixes q fRD p (rd, dr)). set [(P, p1, A), (P, p2, A)])"
      unfolding calculate_test_case_for_prefixes_set[of q fRD p rd dr]
    proof -
      { fix pp :: "(('a \<times> integer \<times> integer \<times> 'a) list \<times> ('a \<times> integer \<times> integer \<times> 'a) list) \<times> ('c, 'd) FSM_scheme"
        have "UNION {((ps, psa), fRD (target ps q) (target psa q)) |ps psa. target ps q \<in> rd \<and> target psa q \<in> rd \<and> (\<exists>psaa psaaa. ps @ psaa = psa \<and> psa @ psaaa = p \<and> psaa \<noteq> [])} (set \<circ> (\<lambda>((ps, psa), f). [(P, ps, f), (P, psa, f)])) = (\<Union>((ps, psa), f)\<in>{((ps, psa), fRD (target ps q) (target psa q)) |ps psa. target ps q \<in> rd \<and> target psa q \<in> rd \<and> (\<exists>psaa psaaa. ps @ psaa = psa \<and> psa @ psaaa = p \<and> psaa \<noteq> [])}. set [(P, ps, f), (P, psa, f)]) \<or> (set \<circ> (\<lambda>((ps, psa), f). [(P, ps, f), (P, psa, f)])) pp = (case pp of (x, xa) \<Rightarrow> (case x of (ps, psa) \<Rightarrow> \<lambda>f. set [(P, ps, f), (P, psa, f)]) xa)"
          by fastforce }
      then show "UNION {((ps, psa), fRD (target ps q) (target psa q)) |ps psa. target ps q \<in> rd \<and> target psa q \<in> rd \<and> (\<exists>psb psc. ps @ psb = psa \<and> psa @ psc = p \<and> psb \<noteq> [])} (set \<circ> (\<lambda>((psa, ps), f). [(P, psa, f), (P, ps, f)])) = (\<Union>((psa, ps), f)\<in>{((ps, psa), fRD (target ps q) (target psa q)) |ps psa. target ps q \<in> rd \<and> target psa q \<in> rd \<and> (\<exists>psb psc. ps @ psb = psa \<and> psa @ psc = p \<and> psb \<noteq> [])}. set [(P, psa, f), (P, ps, f)])"
        by meson
    qed

    then show "set (concat (map (\<lambda>((p1,p2),A) . [(P,p1,A),(P,p2,A)]) (calculate_test_case_for_prefixes q fRD p (rd,dr)))) = \<Union> (image (\<lambda>((p1,p2),A) . set [(P,p1,A),(P,p2,A)]) (set (calculate_test_case_for_prefixes q fRD p (rd,dr))))"
      using scheme[of "(\<lambda>((p1,p2),A) . [(P,p1,A),(P,p2,A)])" "calculate_test_case_for_prefixes q fRD p (rd,dr)"]
      unfolding calculate_test_case_for_prefixes_set[of q fRD p rd dr] by force
  qed
  then have "\<And> p rd dr . set (concat (map (\<lambda>((p1,p2),A) . [(P,p1,A),(P,p2,A)]) (calculate_test_case_for_prefixes q fRD p (rd,dr)))) = \<Union> (image (\<lambda>((p1,p2),A) . {(P,p1,A),(P,p2,A)}) (set (calculate_test_case_for_prefixes q fRD p (rd,dr))))"
    by simp
  then have "set (map (\<lambda> (p,d) . concat (map (\<lambda>((p1,p2),A) . [(P,p1,A),(P,p2,A)]) (calculate_test_case_for_prefixes q fRD p d))) pds) = {\<Union> (image (\<lambda>((p1,p2),A) . {(P,p1,A),(P,p2,A)}) (set (calculate_test_case_for_prefixes q fRD p (rd,dr)))) | p rd dr . (p,(rd,dr)) \<in> set pds}"

  ultimately show ?thesis

  then have "\<And> p rd dr . set (map (\<lambda>((p1,p2),A) . [(P,p1,A),(P,p2,A)]) (calculate_test_case_for_prefixes q fRD p (rd,dr))) = {[(P, p1, fRD (target p1 q) (target p2 q)), (P, p2, fRD (target p1 q) (target p2 q))] | p1 p2 . (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (\<exists>p' p''. p1 @ p' = p2 \<and> p2 @ p'' = p \<and> p' \<noteq> [])}"

  define xs1 where "xs1 = concat (map (\<lambda>((p1,p2),A) . [(P,p1,A),(P,p2,A)]) (calculate_test_case_for_prefixes q fRD p d))"
  unfolding calculate_test_cases_for_prefixes.simps
  using calculate_test_case_for_prefixes_set

*)

(* TODO: review Petrenko/Yevtushenko *)

(* rework sketch:
  1.) calculate d-r states with preambles (set DR of (q,P))
  2.) calculate traversal sequences from d-r states (set DRT of (q,p,D) where D is the set satisfying the abortion criterion)
  3.1.) for all (q,p,D) calculate prefixes p1 < p2 of p s.t. their targets (from q) are in D
        \<rightarrow> store (q,p1,p2,A), where A is an ATC r-d-ing the targets
  3.2.) for all (q,p,D) calculate prefixes p1 of p and (q',P') such that the target of p1 (from q) and q1 are in D
        \<rightarrow> store (q,p1,q',P',A)
  3.3.) for all (q,P) and (q',P') such that q and q' are r-d (better: in some D actually used)
        \<rightarrow> store (q,P,q',P',A)
*)

subsubsection "Calculating Tests along m-Traversal-Paths"

(*
fun prefix_pair_tests :: "'a \<Rightarrow> (('a \<times> 'a) \<rightharpoonup> 'c ATC) \<Rightarrow> 'a Traversal_Path \<times> ('a set \<times> 'a set) \<Rightarrow> (('a \<times> 'a Traversal_Path) \<rightharpoonup> 'c ATC set)" where
  "prefix_pair_tests q fRD (p, (rd,dr)) =
    foldl (\<lambda> prev (p1,p2) . prev)
          (insert (q,p) {} Map.empty)
          (filter (\<lambda> (p1,p2) . (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (target p1 q) \<noteq> (target p2 q)) \<comment> \<open>ensure that a separator exists, assuming that the states in rd are pairwise r-d\<close>
                  (prefix_pairs p))"

*)

fun prefix_pair_tests'' :: "'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'c ATC) \<Rightarrow> 'a Traversal_Path \<times> ('a set \<times> 'a set) \<Rightarrow> ('a \<times> 'a Traversal_Path \<times> 'c ATC) list list" where
  "prefix_pair_tests'' q fRD (p, (rd,dr)) = (map (\<lambda> (p1,p2) . [(q,p1,fRD (target p1 q) (target p2 q)), (q,p2,fRD (target p1 q) (target p2 q))])      \<comment> \<open>retrieve separator using fRD\<close>
                                                 (filter (\<lambda> (p1,p2) . (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (target p1 q) \<noteq> (target p2 q)) \<comment> \<open>ensure that a separator exists, assuming that the states in rd are pairwise r-d\<close>
                                                         (prefix_pairs p)))"

lemma prefix_pair_tests''_set :
  "set (prefix_pair_tests'' q fRD (p, (rd,dr))) = {[(q,p1,fRD (target p1 q) (target p2 q)), (q,p2,fRD (target p1 q) (target p2 q))] | p1 p2 . (p1,p2) \<in> set (prefix_pairs p) \<and> (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (target p1 q) \<noteq> (target p2 q)}"
proof -

  have scheme: "\<And> S f P . image f {(p1,p2) | p1 p2 . P p1 p2} = {f (p1,p2) | p1 p2 . P p1 p2}" by auto

  have "set (filter (\<lambda> (p1,p2) . (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (target p1 q) \<noteq> (target p2 q)) (prefix_pairs p)) = {(p1,p2) | p1 p2 . (p1,p2) \<in> set (prefix_pairs p) \<and> (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (target p1 q) \<noteq> (target p2 q)}"
    by auto
  moreover have "set (prefix_pair_tests'' q fRD (p, (rd,dr))) = image (\<lambda> (p1,p2) . [(q,p1,fRD (target p1 q) (target p2 q)), (q,p2,fRD (target p1 q) (target p2 q))]) (set (filter (\<lambda> (p1,p2) . (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (target p1 q) \<noteq> (target p2 q)) (prefix_pairs p)))"
    by auto
  ultimately have "set (prefix_pair_tests'' q fRD (p, (rd,dr))) = image (\<lambda> (p1,p2) . [(q,p1,fRD (target p1 q) (target p2 q)), (q,p2,fRD (target p1 q) (target p2 q))]) {(p1,p2) | p1 p2 . (p1,p2) \<in> set (prefix_pairs p) \<and> (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (target p1 q) \<noteq> (target p2 q)}"
    by auto
  moreover have "image (\<lambda> (p1,p2) . [(q,p1,fRD (target p1 q) (target p2 q)), (q,p2,fRD (target p1 q) (target p2 q))]) {(p1,p2) | p1 p2 . (p1,p2) \<in> set (prefix_pairs p) \<and> (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (target p1 q) \<noteq> (target p2 q)} = {[(q,p1,fRD (target p1 q) (target p2 q)), (q,p2,fRD (target p1 q) (target p2 q))] | p1 p2 . (p1,p2) \<in> set (prefix_pairs p) \<and> (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (target p1 q) \<noteq> (target p2 q)}"
    using scheme[of "(\<lambda> (p1,p2) . [(q,p1,fRD (target p1 q) (target p2 q)), (q,p2,fRD (target p1 q) (target p2 q))])" "\<lambda> p1 p2 . (p1,p2) \<in> set (prefix_pairs p) \<and> (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (target p1 q) \<noteq> (target p2 q)"] by auto
  ultimately show ?thesis by force
qed

fun prefix_pair_tests' :: "'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'c ATC) \<Rightarrow> ('a Traversal_Path \<times> ('a set \<times> 'a set)) list \<Rightarrow> ('a \<times> 'a Traversal_Path \<times> 'c ATC) list" where
  "prefix_pair_tests' q fRD pds = concat (concat (map (prefix_pair_tests'' q fRD) pds))"

fun prefix_pair_tests :: "'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'c ATC) \<Rightarrow> ('a Traversal_Path \<times> ('a set \<times> 'a set)) list \<Rightarrow> ('a \<times> 'a Traversal_Path \<times> 'c ATC) set" where
  "prefix_pair_tests q fRD pds = \<Union>{{(q,p1,fRD (target p1 q) (target p2 q)), (q,p2,fRD (target p1 q) (target p2 q))} | p1 p2 . \<exists> (p,(rd,dr)) \<in> set pds . (p1,p2) \<in> set (prefix_pairs p) \<and> (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (target p1 q) \<noteq> (target p2 q)}"

lemma prefix_pair_tests_containment :
  assumes "(p,(rd,dr)) \<in> set pds"
  and     "(p1,p2) \<in> set (prefix_pairs p)"
  and     "(target p1 q) \<in> rd"
  and     "(target p2 q) \<in> rd"
  and     "(target p1 q) \<noteq> (target p2 q)"
shows "(q,p1,fRD (target p1 q) (target p2 q)) \<in> prefix_pair_tests q fRD pds"
and   "(q,p2,fRD (target p1 q) (target p2 q)) \<in> prefix_pair_tests q fRD pds"
  using assms unfolding prefix_pair_tests.simps by blast+

(* TODO: move and rename *)
lemma union_pair_exists_helper : "\<And> x xs f P . \<Union>{f y1 y2 | y1 y2 . \<exists> z \<in> set (x#xs) . P y1 y2 z} = (\<Union>{f y1 y2 | y1 y2 . \<exists> z \<in> set xs . P y1 y2 z}) \<union> (\<Union>{f y1 y2 | y1 y2 . P y1 y2 x})"
proof -
  have "\<And> x xs f P . {f y1 y2 | y1 y2 . \<exists> z \<in> set (x#xs) . P y1 y2 z} = ({f y1 y2 | y1 y2 . \<exists> z \<in> set xs . P y1 y2 z}) \<union> ({f y1 y2 | y1 y2 . P y1 y2 x})" by auto
  then have "\<And> x xs f P . \<Union>{f y1 y2 | y1 y2 . \<exists> z \<in> set (x#xs) . P y1 y2 z} = \<Union>(({f y1 y2 | y1 y2 . \<exists> z \<in> set xs . P y1 y2 z}) \<union> ({f y1 y2 | y1 y2 . P y1 y2 x}))" by metis
  moreover have "\<And> x xs f P . (\<Union>{f y1 y2 | y1 y2 . \<exists> z \<in> set xs . P y1 y2 z}) \<union> (\<Union>{f y1 y2 | y1 y2 . P y1 y2 x}) = \<Union>(({f y1 y2 | y1 y2 . \<exists> z \<in> set xs . P y1 y2 z}) \<union> ({f y1 y2 | y1 y2 . P y1 y2 x}))"
    by auto
  ultimately show "\<And> x xs f P . \<Union>{f y1 y2 | y1 y2 . \<exists> z \<in> set (x#xs) . P y1 y2 z} = (\<Union>{f y1 y2 | y1 y2 . \<exists> z \<in> set xs . P y1 y2 z}) \<union> (\<Union>{f y1 y2 | y1 y2 . P y1 y2 x})" by metis
qed

lemma prefix_pair_tests_code[code] :
  "prefix_pair_tests q fRD pds = set (prefix_pair_tests' q fRD pds)"
  unfolding prefix_pair_tests'.simps
proof (induction pds)
  case Nil
  then show ?case by auto
next
  case (Cons a pds)
  obtain p rd dr where "a = (p,(rd,dr))"
    using prod_cases3 by blast

  have "prefix_pair_tests q fRD ((p,(rd,dr))#pds) = (prefix_pair_tests q fRD pds) \<union> (\<Union>{{(q,p1,fRD (target p1 q) (target p2 q)), (q,p2,fRD (target p1 q) (target p2 q))} | p1 p2 . (p1,p2) \<in> set (prefix_pairs p) \<and> (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (target p1 q) \<noteq> (target p2 q)})"
    using union_pair_exists_helper[of "\<lambda> p1 p2 . {(q,p1, fRD (target p1 q) (target p2 q)), (q,p2, fRD (target p1 q) (target p2 q))}" "(p,(rd,dr))" pds "\<lambda> p1 p2 (p,(rd,dr)) . (p1,p2) \<in> set (prefix_pairs p) \<and> (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (target p1 q) \<noteq> (target p2 q)"]
    unfolding prefix_pair_tests.simps by force

  moreover have "\<Union> (set (map set (concat (map (prefix_pair_tests'' q fRD) ((p,(rd,dr))#pds))))) = (\<Union> (set (map set (concat (map (prefix_pair_tests'' q fRD) pds))))) \<union> (\<Union> (set (map set (prefix_pair_tests'' q fRD (p,(rd,dr))))))"
    by auto

  moreover have "(\<Union>{{(q,p1,fRD (target p1 q) (target p2 q)), (q,p2,fRD (target p1 q) (target p2 q))} | p1 p2 . (p1,p2) \<in> set (prefix_pairs p) \<and> (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (target p1 q) \<noteq> (target p2 q)}) = (\<Union> (set (map set (prefix_pair_tests'' q fRD (p,(rd,dr))))))"
  proof -
    have scheme1 : "\<And> xs . set (map set xs) = image set (set xs)" by auto
    have scheme2 : "\<And> f xs P . {set (f x1 x2) | x1 x2 . P x1 x2} = image set {f x1 x2 | x1 x2 . P x1 x2}" by auto

    have "{{(q,p1,fRD (target p1 q) (target p2 q)), (q,p2,fRD (target p1 q) (target p2 q))} | p1 p2 . (p1,p2) \<in> set (prefix_pairs p) \<and> (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (target p1 q) \<noteq> (target p2 q)} = (set (map set (prefix_pair_tests'' q fRD (p,(rd,dr)))))"
      unfolding scheme1
      unfolding prefix_pair_tests''_set[of q fRD p rd dr]
      using scheme2[of "\<lambda> p1 p2 . [(q,p1, fRD (target p1 q) (target p2 q)), (q,p2, fRD (target p1 q) (target p2 q))]" "\<lambda> p1 p2 . (p1,p2) \<in> set (prefix_pairs p) \<and> (target p1 q) \<in> rd \<and> (target p2 q) \<in> rd \<and> (target p1 q) \<noteq> (target p2 q)"] by force
    then show ?thesis by force
  qed

  ultimately show ?case
    using Cons.IH unfolding \<open>a = (p,(rd,dr))\<close> by force
qed

subsubsection "Calculating Tests between Preambles"

fun preamble_prefix_tests' :: "'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'c ATC) \<Rightarrow> ('a Traversal_Path \<times> ('a set \<times> 'a set)) list \<Rightarrow> ('a \<times> 'a Preamble) list \<Rightarrow> ('a \<times> 'a Traversal_Path \<times> 'c ATC) list" where
  "preamble_prefix_tests' q fRD pds PS =
    concat (map (\<lambda>((p,(rd,dr)),(q2,P2),p1) . [(q,p1,fRD (target p1 q) q2), (q2,[],fRD (target p1 q) q2)])
                (filter (\<lambda>((p,(rd,dr)),(q2,P2),p1) . (target p1 q) \<in> rd \<and> q2 \<in> rd \<and> (target p1 q) \<noteq> q2)
                        (concat (map (\<lambda>((p,(rd,dr)),(q2,P2)) . map (\<lambda>p1 . ((p,(rd,dr)),(q2,P2),p1)) (prefixes p)) (cartesian_product_list pds PS)))))"

fun preamble_prefix_tests :: "'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'c ATC) \<Rightarrow> ('a Traversal_Path \<times> ('a set \<times> 'a set)) list \<Rightarrow> ('a \<times> 'a Preamble) list \<Rightarrow> ('a \<times> 'a Traversal_Path \<times> 'c ATC) set" where
  "preamble_prefix_tests q fRD pds PS = \<Union>{{(q,p1,fRD (target p1 q) q2), (q2,[],fRD (target p1 q) q2)} | p1 q2 . \<exists> (p,(rd,dr)) \<in> set pds . \<exists> (q2,P2) \<in> set PS . \<exists> p2 . p = p1@p2 \<and> (target p1 q) \<in> rd \<and> q2 \<in> rd \<and> (target p1 q) \<noteq> q2}"

(* TODO: code
lemma preamble_prefix_tests_code[code]:
  "preamble_prefix_tests q fRD pds PS = set (preamble_prefix_tests' q fRD pds PS)"
  sorry
*)

subsubsection "Calculating Tests between m-Traversal-Paths Prefixes and Preambles"

fun preamble_pair_tests' :: "('a \<times> 'a Preamble) list \<Rightarrow> (('a \<times> 'a) \<times> 'c ATC) list \<Rightarrow> ('a \<times> 'a Traversal_Path \<times> 'c ATC) list" where
  "preamble_pair_tests' PS RDS =
    concat (map (\<lambda>((q1,P1),(q2,P2)) . (case (find (\<lambda> qqA . fst qqA = (q1,q2)) RDS) of
                                         Some ((q1',q2'),A) \<Rightarrow> [(q1,[],A),(q2,[],A)] |
                                         None \<Rightarrow> []))
           (cartesian_product_list PS PS))"

fun preamble_pair_tests :: "('a \<times> 'a Preamble) list \<Rightarrow> (('a \<times> 'a) \<times> 'c ATC) list \<Rightarrow> ('a \<times> 'a Preamble \<times> 'a Traversal_Path \<times> 'c ATC) set" where
  "preamble_pair_tests PS RDS = \<Union>{{(q1,P1,[],A),(q2,P2,[],A)} | P1 P2 A q1 q2 . (q1,P1) \<in> set PS \<and> (q2,P2) \<in> set PS \<and> ((q1,q2),A) \<in> set RDS}"

(* TODO: code
lemma preamble_pair_tests_code[code]:
  "preamble_pair_tests PS RDS = set (preamble_pair_tests' PS RDS)"
  sorry
*)

subsubsection "Collecting Tests"

fun collect_ATCs' :: "('a \<times> 'b \<times> 'c) list \<Rightarrow> ('a \<times> 'b \<times> 'c \<times> 'd) list \<Rightarrow> ('a \<times> 'b \<times> 'c \<times> ('d set)) list" where
  "collect_ATCs' [] ts = []" |
  "collect_ATCs' ((a,b,c)#xs) ts = (a,b,c, set (map (\<lambda>(x,y,z,d) . d) (filter (\<lambda>(x,y,z,d) . x = a \<and> y = b \<and> z = c) ts))) # (collect_ATCs' xs ts)"

lemma collect_ATCs'_set :
  "set (collect_ATCs' xs ts) = {(a,b,c,{d . (a,b,c,d) \<in> set ts}) | a b c . (a,b,c) \<in> set xs}"
proof (induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons x xs)

  obtain a b c where "x=(a,b,c)"
    using prod_cases3 by blast
  have "(a,b,c, set (map (\<lambda>(x,y,z,d) . d) (filter (\<lambda>(x,y,z,d) . x = a \<and> y = b \<and> z = c) ts))) = (a,b,c,{d . (a,b,c,d) \<in> set ts})"
    by force
  moreover have "set (collect_ATCs' ((a,b,c)#xs) ts) = insert (a,b,c, set (map (\<lambda>(x,y,z,d) . d) (filter (\<lambda>(x,y,z,d) . x = a \<and> y = b \<and> z = c) ts))) (set (collect_ATCs' xs ts))"
    by auto
  moreover have "{(a',b',c',{d . (a',b',c',d) \<in> set ts}) | a' b' c'. (a',b',c') \<in> set ((a,b,c)#xs)} = insert (a,b,c,{d . (a,b,c,d) \<in> set ts}) {(a',b',c',{d . (a',b',c',d) \<in> set ts}) | a' b' c' . (a',b',c') \<in> set xs}"
    by auto
  ultimately show ?case using Cons.IH unfolding \<open>x=(a,b,c)\<close> by auto
qed

fun collect_ATCs :: "('a \<times> 'b \<times> 'c) list \<Rightarrow> ('a \<times> 'b \<times> 'c \<times> 'd) list \<Rightarrow> ('a \<times> 'b \<times> 'c \<times> ('d set)) list" where
  "collect_ATCs xs ts = collect_ATCs' (remdups xs) (remdups ts)"

lemma collect_ATCs_set :
  "set (collect_ATCs xs ts) = {(a,b,c,{d . (a,b,c,d) \<in> set ts}) | a b c . (a,b,c) \<in> set xs}"
  using collect_ATCs'_set[of "remdups xs" "remdups ts"]
  unfolding collect_ATCs.simps set_remdups by assumption

subsection \<open>Calculating the Test Suite\<close>

(* how to build with comments?
definition calculate_test_suite' :: "'a FSM \<Rightarrow> nat \<Rightarrow> ('a \<times> 'a Preamble \<times> 'a Traversal_Path \<times> ('a \<times> 'a + 'a,'b) ATC set) list" where
  "calculate_test_suite' M m =
    (let
         RDSSL \<comment> \<open>R-D States with Separators\<close>
              = r_distinguishable_state_pairs_with_separators_naive M;
         RDSS \<comment> \<open>R-D States with Separators\<close>
              = set RDSSL; \<comment> \<open>corresponds to r_distinguishable_state_pairs_with_separators\<close>
         RDS  \<comment> \<open>R-D States\<close>
              = image fst RDSS;
         RDP  \<comment> \<open>R-D Pairs\<close>
              = filter (\<lambda> S . \<forall> q1 \<in> S . \<forall> q2 \<in> S . q1 \<noteq> q2 \<longrightarrow> (q1,q2) \<in> RDS) (map set (pow_list (nodes_from_distinct_paths M))); \<comment> \<open>corresponds to pairwise_r_distinguishable_state_sets_from_separators\<close>
         MPRD \<comment> \<open>Maximal Pairwise R-D sets\<close>
              = filter (\<lambda> S . \<not>(\<exists> S' \<in> set RDP . S \<subset> S')) RDP;  \<comment> \<open>corresponds to maximal_pairwise_r_distinguishable_state_sets_from_separators\<close>
         DRSP \<comment> \<open>D-R States with Preambles\<close>
              = d_reachable_states_with_preambles M;
         DRS  \<comment> \<open>D-R States\<close>
              = map fst DRSP; \<comment> \<open>corresponds to d_reachable_states\<close>
         MRS  \<comment> \<open>Maximal Repetition sets (maximal pairwise r-d sets with their d-r subsets)\<close>
              = map (\<lambda>S. (S, S \<inter> set DRS)) MPRD; \<comment> \<open>corresponds to maximal_repetition_sets_from_separators\<close>
         MTP  \<comment> \<open>states and their outgoing m-Traversal Paths\<close>
              = map (\<lambda> q . (q,m_traversal_paths_with_witness M q MRS m)) DRS;
         fTP  \<comment> \<open>function to get Traversal Paths with witnesses for states\<close>
              = list_as_fun MTP []; \<comment> \<open>see list_as_fun_on and the sketch following fRD_helper\<close>
         fRD  \<comment> \<open>function to get separators for R-D states\<close>
              = \<lambda> q1 q2 . snd (the (find (\<lambda> qqA . fst qqA = (q1,q2)) RDSSL)); \<comment> \<open>see fRD_helper\<close>
         PMTP
              = concat (map (\<lambda> (q,P) . map (\<lambda>(p,d) . (q,p)) (fTP q)) DRSP);
         PrefixPairTests
              = concat (map (\<lambda> (q,P) . prefix_pair_tests' q fRD (fTP q)) DRSP);
         PreamblePrefixTests
              = concat (map (\<lambda> (q,P) . preamble_prefix_tests' q fRD (fTP q) DRSP) DRSP);
         PreamblePairTests
              = preamble_pair_tests' DRSP RDSSL

    in collect_ATCs PMTP (PrefixPairTests @ PreamblePrefixTests @ PreamblePairTests))"
*)

definition calculate_test_suite :: "'a FSM \<Rightarrow> nat \<Rightarrow> (('a \<times> 'a Traversal_Path \<times> ('a \<times> 'a + 'a) ATC) list \<times> ('a \<times> 'a Preamble) list)" where
  "calculate_test_suite M m =
    (let
         RDSSL = r_distinguishable_state_pairs_with_separators_naive M;
         RDS  = set (map fst RDSSL);
         RDP  = filter (\<lambda> S . \<forall> q1 \<in> S . \<forall> q2 \<in> S . q1 \<noteq> q2 \<longrightarrow> (q1,q2) \<in> RDS) (map set (pow_list (nodes_from_distinct_paths M)));
         MPRD = filter (\<lambda> S . \<not>(\<exists> S' \<in> set RDP . S \<subset> S')) RDP;
         DRSP = d_reachable_states_with_preambles M;
         DRS  = map fst DRSP;
         MRS  = map (\<lambda>S. (S, S \<inter> set DRS)) MPRD;
         MTP  = map (\<lambda> q . (q,m_traversal_paths_with_witness M q MRS m)) DRS;
         fTP  = list_as_fun MTP [];
         fRD  = \<lambda> q1 q2 . snd (the (find (\<lambda> qqA . fst qqA = (q1,q2)) RDSSL));
         PMTP = concat (map (\<lambda> (q,P) . map (\<lambda>(p,d) . (q,p)) (fTP q)) DRSP);
         PrefixPairTests
              = concat (map (\<lambda> (q,P) . prefix_pair_tests' q fRD (fTP q)) DRSP);
         PreamblePrefixTests
              = concat (map (\<lambda> (q,P) . preamble_prefix_tests' q fRD (fTP q) DRSP) DRSP);
         PreamblePairTests
              = preamble_pair_tests' DRSP RDSSL

    in  (PrefixPairTests @ PreamblePrefixTests @ PreamblePairTests, DRSP))"

value "calculate_test_suite M_ex_H 4"

definition calculate_test_suite_set :: "'a FSM \<Rightarrow> nat \<Rightarrow> (('a \<times> 'a Traversal_Path \<times> ('a \<times> 'a + 'a) ATC) set \<times> ('a \<times> 'a Preamble) list)" where
  "calculate_test_suite_set M m = (case calculate_test_suite M m of (ts,ps) \<Rightarrow> (set ts,ps))"

(* TODO:

fun convert_test_suite_elem :: "(('a::linorder \<times> 'a Traversal_Path \<times> ('a \<times> 'a + 'a,'b) ATC) list \<times> ('a \<times> 'a Preamble)) \<Rightarrow> ('a \<times> 'a Preamble) list \<Rightarrow> 'a Transition list avl_tree" where
  "convert_test_suite_elem (q,p,atcs) preambles = empty"

thm foldl.simps

fun convert_test_suite :: "(('a::linorder \<times> 'a Traversal_Path \<times> ('a \<times> 'a + 'a,'b) ATC) list \<times> ('a \<times> 'a Preamble) list) \<Rightarrow> 'a Transition list avl_tree" where
  "convert_test_suite (elems,preambles) = foldl (\<lambda> prev elem . AVL_Set.union prev prev ) empty elems"
*)

end


(*  Title:      Word_Misc.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

header {* More about words *}

theory Word_Misc imports
  "~~/src/HOL/Word/Word"
  More_Bits_Int
begin

text {*
  The separate code target @{text SML_word} collects setups for the
  code generator that PolyML does not provide.
*}

setup {* Code_Target.extend_target ("SML_word", (Code_ML.target_SML, I)) *}

code_identifier code_module Word_Misc \<rightharpoonup>
  (SML) Word and (Haskell) Word and (OCaml) Word and (Scala) Word

context
includes integer.lifting
begin
lift_definition word_of_integer :: "integer \<Rightarrow> 'a :: len0 word" is word_of_int .

lemma word_of_integer_code [code]: "word_of_integer n = word_of_int (int_of_integer n)"
by(simp add: word_of_integer.rep_eq)
end

lemma shiftr_zero_size: "size x \<le> n \<Longrightarrow> x >> n = (0 :: 'a :: len0 word)"
by(rule word_eqI)(auto simp add: nth_shiftr dest: test_bit_size)

lemma mask_full [simp]: "mask (len_of TYPE('a :: len)) = (-1 :: 'a word)"
by(simp add: mask_def word_pow_0)

lemma set_bit_beyond: fixes x :: "'a :: len0 word" shows
  "size x \<le> n \<Longrightarrow> set_bit x n b = x"
by(auto intro: word_eqI simp add: test_bit_set_gen word_size)

lemma word_of_int_code [code abstract]:
  "uint (word_of_int x :: 'a word) = x AND bin_mask (len_of TYPE('a :: len0))"
by(simp add: uint_word_of_int and_bin_mask_conv_mod)

context begin interpretation lifting_syntax .

lemma shiftl_transfer [transfer_rule]:
  "(pcr_word ===> op = ===> pcr_word) op << op <<"
by(auto intro!: rel_funI word_eqI simp add: word.pcr_cr_eq cr_word_def word_size nth_shiftl)

end

lemma set_bits_K_False [simp]: "set_bits (\<lambda>_. False) = (0 :: 'a :: len0 word)"
by(rule word_eqI)(simp add: test_bit.eq_norm)

lemma test_bit_1' [simp]: "(1 :: 'a :: len0 word) !! n \<longleftrightarrow> 0 < len_of TYPE('a) \<and> n = 0"
by(cases n)(simp_all only: one_word_def test_bit_wi bin_nth.simps, simp_all)

lemma mask_0 [simp]: "mask 0 = 0"
by(simp add: Word.mask_def)

lemma shiftl0 [simp]: "x << 0 = (x :: 'a :: len0 word)"
by (metis shiftl_rev shiftr_x_0 word_rev_gal)

lemma mask_1: "mask 1 = 1"
by(simp add: mask_def)

lemma mask_Suc_0: "mask (Suc 0) = 1"
by(simp add: mask_def)

lemma mask_numeral: "mask (numeral n) = 2 * mask (pred_numeral n) + 1"
unfolding mask_def by transfer(simp, simp add: shiftl_int_def)

lemma bin_last_bintrunc: "bin_last (bintrunc l n) = (l > 0 \<and> bin_last n)"
by(cases l) simp_all

lemma word_and_1:
  fixes n :: "_ word"
  shows "n AND 1 = (if n !! 0 then 1 else 0)"
by transfer(rule bin_rl_eqI, simp_all add: bin_rest_trunc bin_last_bintrunc)

lemma bintrunc_shiftl: "bintrunc n (m << i) = bintrunc (n - i) m << i"
proof(induct i arbitrary: n)
  case (Suc i)
  thus ?case by(cases n) simp_all
qed simp

lemma uint_shiftl: "uint (n << i) = bintrunc (size n) (uint n << i)"
unfolding word_size by transfer(simp add: bintrunc_shiftl)

context fixes f :: "nat \<Rightarrow> bool" begin

fun set_bits_aux :: "'a word \<Rightarrow> nat \<Rightarrow> 'a :: len0 word"
where
  "set_bits_aux w 0 = w"
| "set_bits_aux w (Suc n) = set_bits_aux ((w << 1) OR (if f n then 1 else 0)) n"

lemma set_bits_aux_conv: "set_bits_aux w n = (w << n) OR (set_bits f AND mask n)"
apply(induct w n rule: set_bits_aux.induct)
apply(auto 4 3 intro: word_eqI simp add: word_ao_nth nth_shiftl test_bit.eq_norm word_size not_less less_Suc_eq)
done

corollary set_bits_conv_set_bits_aux:
  "set_bits f = (set_bits_aux 0 (len_of TYPE('a)) :: 'a :: len word)"
by(simp add: set_bits_aux_conv)

end

lemma word_test_bit_set_bits: "(BITS n. f n :: 'a :: len0 word) !! n \<longleftrightarrow> n < len_of TYPE('a) \<and> f n"
by(auto simp add: word_set_bits_def test_bit_bl word_bl.Abs_inverse word_size)

lemma word_of_int_conv_set_bits: "word_of_int i = (BITS n. i !! n)"
by(rule word_eqI)(simp add: word_test_bit_set_bits)

text {*
  Division on @{typ "'a word"} is unsigned, but Scala and OCaml only have signed division and modulus.
*}
definition word_sdiv :: "'a :: len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixl "sdiv" 70)
where [code]:
  "x sdiv y =
   (let x' = sint x; y' = sint y;
        negative = (x' < 0) \<noteq> (y' < 0);
        result = abs x' div abs y'
    in word_of_int (if negative then -result else result))"

definition word_smod :: "'a :: len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixl "smod" 70)
where [code]:
  "x smod y =
   (let x' = sint x; y' = sint y;
        negative = (x' < 0);
        result = abs x' mod abs y'
    in word_of_int (if negative then -result else result))"

lemma sdiv_smod_id: "(a sdiv b) * b + (a smod b) = a"
proof -
  note [simp] = word_sdiv_def word_smod_def
  have F5: "\<forall>u\<Colon>'a word. - (- u) = u" by (metis word_sint.Rep_inverse' minus_minus wi_hom_neg)
  have F7: "\<forall>v u\<Colon>'a word. u + v = v + u" by(metis add.left_commute add_0_right)
  have F8: "\<forall>(w\<Colon>'a word) (v\<Colon>int) u\<Colon>int. word_of_int u + word_of_int v * w = word_of_int (u + v * sint w)"
    by (metis word_sint.Rep_inverse wi_hom_syms(1) wi_hom_syms(3))
  have "\<exists>u. u = - sint b \<and> word_of_int (sint a mod u + - (- u * (sint a div u))) = a"
    using F5 by (metis minus_minus word_sint.Rep_inverse' mult_minus_left add.commute zmod_zdiv_equality)
  hence "word_of_int (sint a mod - sint b + - (sint b * (sint a div - sint b))) = a" by (metis equation_minus_iff)
  hence "word_of_int (sint a mod - sint b) + word_of_int (- (sint a div - sint b)) * b = a"
    using F8 by(metis mult.commute mult_minus_left)
  hence eq: "word_of_int (- (sint a div - sint b)) * b + word_of_int (sint a mod - sint b) = a" using F7 by metis

  show ?thesis
  proof(cases "sint a < 0")
    case True note a = this
    show ?thesis
    proof(cases "sint b < 0")
      case True
      with a show ?thesis
        by simp (metis F7 F8 eq minus_equation_iff minus_mult_minus semiring_div_class.mod_div_equality')
    next
      case False
      from eq have "word_of_int (- (- sint a div sint b)) * b + word_of_int (- (- sint a mod sint b)) = a"
        by (metis div_minus_right mod_minus_right)
      with a False show ?thesis by simp
    qed
  next
    case False note a = this
    show ?thesis
    proof(cases "sint b < 0")
      case True
      with a eq show ?thesis by simp
    next
      case False with a show ?thesis
        by simp (metis wi_hom_add wi_hom_mult add.commute mult.commute word_sint.Rep_inverse add.commute zmod_zdiv_equality)
    qed
  qed
qed

lemma nat_div_eq_Suc_0_iff: "n div m = Suc 0 \<longleftrightarrow> n \<ge> m \<and> n < 2 * (m :: nat)"
by(metis div_less n_not_Suc_n not_leE Suc_1 div_by_0 lessI td_gal_lt One_nat_def Suc_1 comm_semiring_1_class.normalizing_semiring_rules(11) less_nat_zero_code mult_0 mult.commute neq0_conv sdl)

lemma word_div_lt_eq_0:
  fixes x :: "'a :: len word"
  shows "x < y \<Longrightarrow> x div y = 0"
by(simp only: word_div_def zero_word_def uint_nat zdiv_int[symmetric] transfer_int_nat_numerals(1) word_less_def div_less)

lemma Suc_0_lt_2p_len_of: "Suc 0 < 2 ^ len_of TYPE('a :: len)"
by (metis One_nat_def len_gt_0 one_less_numeral_iff one_less_power semiring_norm(76))

lemma unat_p2: "n < len_of TYPE('a :: len) \<Longrightarrow> unat (2 ^ n :: 'a word) = 2 ^ n"
proof(induct n)
  case 0 thus ?case by simp
next
  case (Suc n)
  then obtain n' where "len_of TYPE('a) = Suc n'" by(cases "len_of TYPE('a)") simp_all
  with Suc show ?case by(simp add: unat_word_ariths bintrunc_mod2p int_mod_eq')
qed

lemma div_half_nat:
  fixes x y :: nat
  assumes "y \<noteq> 0"
  shows "(x div y, x mod y) = (let q = 2 * (x div 2 div y); r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
proof -
  let ?q = "2 * (x div 2 div y)"
  have q: "?q = x div y - x div y mod 2"
    by(metis div_mult2_eq mult.commute mult_div_cancel)
  let ?r = "x - ?q * y"
  have r: "?r = x mod y + x div y mod 2 * y"
    by(simp add: q diff_mult_distrib div_mod_equality')(metis diff_diff_cancel mod_less_eq_dividend mod_mult2_eq add.commute mult.commute)

  show ?thesis
  proof(cases "y \<le> x - ?q * y")
    case True
    hence "x div y mod 2 \<noteq> 0" unfolding r
      by(metis Divides.mod_div_equality' True assms diff_is_0_eq div_le_mono mod_by_0 mod_div_trivial mod_self mod_simps(1) mult_div_cancel q)
    hence "x div y = ?q + 1" unfolding q
      by(metis le_add_diff_inverse mod_2_not_eq_zero_eq_one_nat mod_less_eq_dividend add.commute)
    moreover hence "x mod y = ?r - y"
      by simp(metis Divides.mod_div_equality' diff_commute diff_diff_left mult_Suc)
    ultimately show ?thesis using True by(simp add: Let_def)
  next
    case False
    hence "x div y mod 2 = 0" unfolding r
      by(simp add: not_le)(metis Nat.add_0_right assms div_less div_mult_self2 mod_div_trivial mult.commute)
    hence "x div y = ?q" unfolding q by simp
    moreover hence "x mod y = ?r" by (metis mod_div_equality')
    ultimately show ?thesis using False by(simp add: Let_def)
  qed
qed

lemma div_half_word:
  fixes x y :: "'a :: len word"
  assumes "y \<noteq> 0"
  shows "(x div y, x mod y) = (let q = (x >> 1) div y << 1; r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
proof -
  obtain n where n: "x = of_nat n" "n < 2 ^ len_of TYPE('a)" by(cases x)
  obtain m where m: "y = of_nat m" "m < 2 ^ len_of TYPE('a)" by(cases y)
  let ?q = "(x >> 1) div y << 1"
  let ?q' = "2 * (n div 2 div m)"
  have "n div 2 div m < 2 ^ len_of TYPE('a)" using n by (metis of_nat_inverse unat_lt2p uno_simps(2))
  hence q: "?q = of_nat ?q'" using n m
    by(simp add: shiftr_def shiftr1_def bin_rest_def uint_nat unat_of_nat shiftl_def shiftl1_def Bit_def word_div_def)(simp only: int_numeral[symmetric] zdiv_int[symmetric] word_of_nat[symmetric] zdiff_int zmult_int unat_of_nat mod_less)

  from assms have "m \<noteq> 0" using m by -(rule notI, simp)

  from n have "2 * (n div 2 div m) < 2 ^ len_of TYPE('a)"
    by(metis mult.commute div_mult2_eq mult_div_cancel less_imp_diff_less of_nat_inverse unat_lt2p uno_simps(2))
  moreover
  have "2 * (n div 2 div m) * m < 2 ^ len_of TYPE('a)" using n unfolding div_mult2_eq[symmetric]
    by(subst (2) mult.commute)(simp add: div_mod_equality' diff_mult_distrib mult_div_cancel div_mult2_eq)
  moreover have "2 * (n div 2 div m) * m \<le> n"
    by(metis div_mult2_eq div_mult_le mult.assoc mult.commute)
  ultimately
  have r: "x - ?q * y = of_nat (n - ?q' * m)"
    and "y \<le> x - ?q * y \<Longrightarrow> of_nat (n - ?q' * m) - y = of_nat (n - ?q' * m - m)"
    using n m unfolding q
    by(simp_all add: word_sub_wi word_mult_def uint_nat unat_of_nat zmult_int word_of_nat[symmetric] zdiff_int word_le_nat_alt)
  thus ?thesis using n m div_half_nat[OF `m \<noteq> 0`, of n] unfolding q
    by(simp add: word_le_nat_alt word_div_def word_mod_def uint_nat unat_of_nat zmod_int[symmetric] zdiv_int[symmetric] word_of_nat[symmetric])(simp add: Let_def split del: split_if split: split_if_asm)
qed

lemma word_div_eq_1_iff: "n div m = 1 \<longleftrightarrow> n \<ge> m \<and> unat n < 2 * unat (m :: 'a :: len word)"
apply(simp only: word_arith_nat_defs word_le_nat_alt nat_div_eq_Suc_0_iff[symmetric])
apply(rule word_unat.Abs_inject)
 apply(simp only: unat_div[symmetric] word_unat.Rep)
apply(simp add: unats_def Suc_0_lt_2p_len_of)
done

text {*
  This algorithm implements unsigned division in terms of signed division.
  Taken from Hacker's Delight.
*}

lemma divmod_via_sdivmod:
  fixes x y :: "'a :: len word"
  assumes "y \<noteq> 0"
  shows
  "(x div y, x mod y) =
  (if 1 << (len_of TYPE('a) - 1) \<le> y then if x < y then (0, x) else (1, x - y)
   else let q = ((x >> 1) sdiv y) << 1;
            r = x - q * y
        in if r \<ge> y then (q + 1, r - y) else (q, r))"
proof(cases "1 << (len_of TYPE('a) - 1) \<le> y")
  case True
  note y = this
  show ?thesis
  proof(cases "x < y")
    case True
    hence "x mod y = x"
      by(cases x)(cases y, simp add: word_mod_def uint_nat unat_of_nat zmod_int[symmetric] word_of_nat[symmetric] mod_less word_less_nat_alt)
    thus ?thesis using True y by(simp add: word_div_lt_eq_0)
  next
    case False
    obtain n where n: "y = of_nat n" "n < 2 ^ len_of TYPE('a)" by(cases y)
    have "unat x < 2 ^ len_of TYPE('a)" by(rule unat_lt2p)
    also have "\<dots> = 2 * 2 ^ (len_of TYPE('a) - 1)"
      by(metis Suc_pred len_gt_0 power_Suc One_nat_def)
    also have "\<dots> \<le> 2 * n" using y n
      by(simp add: word_le_nat_alt unat_of_nat unat_p2)
    finally have div: "x div of_nat n = 1" using False n
      by(simp add: word_div_eq_1_iff not_less word_le_nat_alt unat_of_nat)
    moreover have "x mod y = x - x div y * y"
      by (metis add_diff_cancel2 word_mod_div_equality)
    with div n have "x mod y = x - y" by simp
    ultimately show ?thesis using False y n by simp
  qed
next
  case False
  note y = this
  obtain n where n: "x = of_nat n" "n < 2 ^ len_of TYPE('a)" by(cases x)
  hence "int n div 2 + 2 ^ (len_of TYPE('a) - Suc 0) < 2 ^ len_of TYPE('a)"
    by(cases "len_of TYPE('a)")(simp_all, simp only: int_numeral[symmetric] zdiv_int[symmetric] zpower_int)
  with y n have "sint (x >> 1) = uint (x >> 1)"
    by(simp add: sint_uint sbintrunc_mod2p shiftr_div_2n)(simp add: int_mod_eq' uint_nat unat_of_nat)
  moreover have "uint y + 2 ^ (len_of TYPE('a) - Suc 0) < 2 ^ len_of TYPE('a)" using y
    by(cases "len_of TYPE('a)")(simp_all add: not_le, metis lessI word_2p_lem word_less_def word_size)
  hence "sint y = uint y" by(simp add: sint_uint sbintrunc_mod2p int_mod_eq')
  ultimately show ?thesis using y
    by(subst div_half_word[OF assms])(simp add: word_sdiv_def uint_div[symmetric])
qed

lemma word_of_int_via_signed:
  fixes mask
  assumes mask_def: "mask = bin_mask (len_of TYPE('a))"
  and shift_def: "shift = 1 << len_of TYPE('a)"
  and index_def: "index = len_of TYPE('a) - 1"
  and overflow_def:"overflow = 1 << (len_of TYPE('a) - 1)"
  and least_def: "least = - overflow"
  shows
  "(word_of_int i :: 'a :: len word) =
   (let i' = i AND mask
    in if i' !! index then
         if i' - shift < least \<or> overflow \<le> i' - shift then arbitrary1 i' else word_of_int (i' - shift)
       else if i' < least \<or> overflow \<le> i' then arbitrary2 i' else word_of_int i')"
proof -
  def i' \<equiv> "i AND mask"
  have "shift = mask + 1" unfolding assms by(simp add: bin_mask_p1_conv_shift)
  hence "i' < shift" by(simp add: mask_def i'_def int_and_le)
  show ?thesis
  proof(cases "i' !! index")
    case True
    hence unf: "i' = overflow OR i'" unfolding assms i'_def
      by(auto intro!: bin_eqI simp add: bin_nth_ops)
    have "overflow \<le> i'" by(subst unf)(rule le_int_or, simp add: bin_sign_and assms i'_def)
    hence "i' - shift < least \<longleftrightarrow> False" unfolding assms
      by(cases "len_of TYPE('a)")(simp_all add: not_less Bit_def)
    moreover
    have "overflow \<le> i' - shift \<longleftrightarrow> False" using `i' < shift` unfolding assms
      by(cases "len_of TYPE('a)")(auto simp add: not_le Bit_def elim: less_le_trans)
    moreover
    have "word_of_int (i' - shift) = (word_of_int i :: 'a word)" using `i' < shift`
      by(auto intro!: word_eqI simp add: i'_def shift_def mask_def bin_nth_ops bin_nth_minus_p2 bin_sign_and)
    ultimately show ?thesis using True by(simp add: Let_def i'_def)
  next
    case False
    hence "i' = i AND bin_mask (len_of TYPE('a) - 1)" unfolding assms i'_def
      by(clarsimp simp add: i'_def bin_nth_ops intro!: bin_eqI)(cases "len_of TYPE('a)", auto simp add: less_Suc_eq)
    also have "\<dots> \<le> bin_mask (len_of TYPE('a) - 1)" by(rule int_and_le) simp
    also have "\<dots> < overflow" unfolding overflow_def
      by(simp add: bin_mask_p1_conv_shift[symmetric])
    also
    have "least \<le> 0" unfolding least_def overflow_def by simp
    have "0 \<le> i'" by(simp add: i'_def mask_def bin_mask_ge0)
    hence "least \<le> i'" using `least \<le> 0` by simp
    moreover
    have "word_of_int i' = (word_of_int i :: 'a word)"
      by(rule word_eqI)(auto simp add: i'_def bin_nth_ops mask_def)
    ultimately show ?thesis using False by(simp add: Let_def i'_def)
  qed
qed

lemma word_and_mask_or_conv_and_mask:
  "n !! index \<Longrightarrow> (n AND mask index) OR (1 << index) = n AND mask (index + 1)"
by(rule word_eqI)(auto simp add: word_ao_nth word_size nth_shiftl simp del: shiftl_1)

lemma uint_and_mask_or_full:
  fixes n :: "'a :: len word"
  assumes "n !! (len_of TYPE('a) - 1)"
  and "mask1 = mask (len_of TYPE('a) - 1)"
  and "mask2 = 1 << len_of TYPE('a) - 1"
  shows "uint (n AND mask1) OR mask2 = uint n"
proof -
  have "mask2 = uint (1 << len_of TYPE('a) - 1 :: 'a word)" using assms
    by(simp add: uint_shiftl word_size bintrunc_shiftl del: shiftl_1)(metis One_nat_def Suc_diff_Suc bintrunc_minus bintrunc_shiftl diff_self_eq_0 len_gt_0 len_num1 lessI uint_1 uint_word_arith_bintrs(8))
  hence "uint (n AND mask1) OR mask2 = uint (n AND mask1 OR (1 << len_of TYPE('a) - 1 :: 'a word))"
    by(simp add: uint_or)
  also have "\<dots> = uint (n AND mask (len_of TYPE('a) - 1 + 1))"
    using assms by(simp only: word_and_mask_or_conv_and_mask)
  also have "\<dots> = uint n" by simp
  finally show ?thesis .
qed

section {* Quickcheck conversion functions *}

notation scomp (infixl "\<circ>\<rightarrow>" 60)

definition qc_random_cnv ::
  "(natural \<Rightarrow> 'a::term_of) \<Rightarrow> natural \<Rightarrow> Random.seed
    \<Rightarrow> ('a \<times> (unit \<Rightarrow> Code_Evaluation.term)) \<times> Random.seed"
  where "qc_random_cnv a_of_natural i = Random.range (i + 1) \<circ>\<rightarrow> (\<lambda>k. Pair (
       let n = a_of_natural k
       in (n, \<lambda>_. Code_Evaluation.term_of n)))"

no_notation scomp (infixl "\<circ>\<rightarrow>" 60)

definition qc_exhaustive_cnv :: "(natural \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> (bool \<times> term list) option)
  \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
where
  "qc_exhaustive_cnv a_of_natural f d =
   Quickcheck_Exhaustive.exhaustive (%x. f (a_of_natural x)) d"

definition qc_full_exhaustive_cnv ::
  "(natural \<Rightarrow> ('a::term_of)) \<Rightarrow> ('a \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option)
  \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
where
  "qc_full_exhaustive_cnv a_of_natural f d = Quickcheck_Exhaustive.full_exhaustive
  (%(x, xt). f (a_of_natural x, %_. Code_Evaluation.term_of (a_of_natural x))) d"

declare [[quickcheck_narrowing_ghc_options = "-XTypeSynonymInstances"]]

definition qc_narrowing_drawn_from :: "'a list \<Rightarrow> integer \<Rightarrow> _"
where
  "qc_narrowing_drawn_from xs =
   foldr Quickcheck_Narrowing.sum (map Quickcheck_Narrowing.cons (butlast xs)) (Quickcheck_Narrowing.cons (last xs))"

locale quickcheck_narrowing_samples =
  fixes a_of_integer :: "integer \<Rightarrow> 'a \<times> 'a :: {partial_term_of, term_of}"
  and zero :: "'a"
  and tr :: "typerep"
begin

function narrowing_samples :: "integer \<Rightarrow> 'a list"
where
  "narrowing_samples i =
   (if i > 0 then let (a, a') = a_of_integer i in narrowing_samples (i - 1) @ [a, a'] else [zero])"
by pat_completeness auto
termination including integer.lifting
proof(relation "measure nat_of_integer")
  fix i :: integer
  assume "0 < i"
  thus "(i - 1, i) \<in> measure nat_of_integer"
    by simp(transfer, simp)
qed simp

definition partial_term_of_sample :: "integer \<Rightarrow> 'a"
where
  "partial_term_of_sample i =
  (if i < 0 then undefined
   else if i = 0 then zero
   else if i mod 2 = 0 then snd (a_of_integer (i div 2))
   else fst (a_of_integer (i div 2 + 1)))"

lemma partial_term_of_code:
  "partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_variable p t) \<equiv>
    Code_Evaluation.Free (STR ''_'') tr"
  "partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_constructor i []) \<equiv>
   Code_Evaluation.term_of (partial_term_of_sample i)"
by (rule partial_term_of_anything)+

end

lemmas [code] =
  quickcheck_narrowing_samples.narrowing_samples.simps
  quickcheck_narrowing_samples.partial_term_of_sample_def

end


section "Enqueue Proofs"

theory RealTimeDeque_Enqueue_Proof
imports Deque RealTimeDeque_Aux States_Proof
begin

lemma list_enqL: "invar deque \<Longrightarrow> listL (enqL x deque) = x # listL deque"
proof(induction x deque rule: enqL.induct)
  case (5 x left right length_right)

  obtain left' length_left' where pushed [simp]:
      "Idle.push x left = idle.Idle left' length_left'"
    using is_empty_idle.cases by blast

  then have invar_left': "invar (idle.Idle left' length_left')"
    using Idle_Proof.invar_push[of left x] 5 by auto

  show ?case
  proof(cases "length_left' \<le> 3 * length_right")
    case True
    then show ?thesis
      using Idle_Proof.push_list[of x left]
      by(auto simp: Let_def)
  next
    case False
    let ?length_left = "length_left' - length_right - 1"
    let ?length_right = "2 * length_right + 1"
    let ?big = "Reverse  (Current [] 0 left' ?length_left) left' [] ?length_left"
    let ?small = "Reverse1 (Current [] 0 right ?length_right) right []"
    let ?states = "States Right ?big ?small"
    let ?states_stepped = "(step^^6) ?states"

    from False 5 invar_left' have invar: "invar ?states"
      by(auto simp: rev_drop rev_take)

    then have "States_Aux.listL ?states = x # Idle_Aux.list left @ rev (Stack_Aux.list right)"
      using Idle_Proof.push_list[of x left]
      by(auto)

    then have "States_Aux.listL ?states_stepped = x # Idle_Aux.list left @ rev (Stack_Aux.list right)"
      by (metis invar step_n_listL)

    with False show ?thesis
      by(auto simp: Let_def)
  qed
next
  case (6 x big small)
  let ?small = "Small.push x small"
  let ?states = "States Left big ?small"
  let ?states_stepped = "(step^^4) ?states"

  obtain big_stepped small_stepped where stepped:
      "?states_stepped = States Left big_stepped small_stepped"
    by (metis remaining_steps_states.cases step_n_same)

  from 6 have "invar ?states"
    using invar_push_small[of Left big small x]
    by auto

  then have
      "States_Aux.listL ?states_stepped =
       x # Small_Aux.list_current small @ rev (Big_Aux.list_current big)"
    using step_n_listL by fastforce

  with 6 show ?case
    by(cases big_stepped; cases small_stepped)
      (auto simp: Let_def stepped split!: Common.state.split)
next
  case (7 x big small)

  let ?big = "Big.push x big"
  let ?states = "States Right ?big small"
  let ?states_stepped = "(step^^4) ?states"

  obtain big_stepped small_stepped where stepped:
      "?states_stepped = States Right big_stepped small_stepped"
    by (metis remaining_steps_states.cases step_n_same)

   from 7 have list_invar:
    "list_current_small_first (States Right big small) = list_small_first (States Right big small)"
    by auto

  from 7 have invar: "invar ?states"
    using invar_push_big[of Right big small x]
    by auto

  then have
      "States_Aux.listL ?states = x # Big_Aux.list_current big @ rev (Small_Aux.list_current small)"
    using app_rev[of _ _ _ "x # Big_Aux.list_current big"]
    by(auto split: prod.split)

  then have
      "States_Aux.listL ?states_stepped =
       x # Big_Aux.list_current big @ rev (Small_Aux.list_current small)"
    by (metis invar step_n_listL)

  with list_invar show ?case
    using app_rev[of "Small_Aux.list_current small" "Big_Aux.list_current big"]
    by(cases big_stepped; cases small_stepped)
      (auto simp: Let_def stepped split!: prod.split Common.state.split)
qed auto

lemma invar_enqL: "invar deque \<Longrightarrow> invar (enqL x deque)"
proof(induction x deque rule: enqL.induct)
  case (5 x left right length_right)
  obtain left' length_left' where pushed [simp]:
      "Idle.push x left = idle.Idle left' length_left'"
    using is_empty_idle.cases by blast

  then have invar_left': "invar (idle.Idle left' length_left')"
    using Idle_Proof.invar_push[of left x] 5 by auto

  have [simp]: "size left' = Suc (size left)"
    using Idle_Proof.size_push[of x left]
    by auto

  show ?case
  proof(cases "length_left' \<le> 3 * length_right")
    case True
    with 5 show ?thesis
      using invar_left' Idle_Proof.size_push[of x left] Stack_Proof.size_not_empty[of left']
      by auto
  next
    case False
    let ?length_left = "length_left' - length_right - 1"
    let ?length_right = "Suc (2 * length_right)"
    let ?states = "States Right
          (Reverse (Current [] 0 left' ?length_left) left' [] ?length_left)
          (Reverse1 (Current [] 0 right ?length_right) right [])"
    let ?states_stepped = "(step^^6) ?states"

    from invar_left' 5 False have invar: "invar ?states"
      by(auto simp: rev_drop rev_take)

    then have invar_stepped: "invar ?states_stepped"
      using invar_step_n by blast

    from False invar_left' 5 have remaining_steps: "6 < remaining_steps ?states"
      using Stack_Proof.size_not_empty[of right]
      by auto

    then have remaining_steps_stepped: "0 < remaining_steps ?states_stepped"
      using invar remaining_steps_n_steps_sub
      by (metis zero_less_diff)

    from False invar_left' 5 have "size_ok' ?states (remaining_steps ?states - 6)"
      using Stack_Proof.size_not_empty[of right]
            size_not_empty
      by auto

    then have size_ok_stepped: "size_ok ?states_stepped"
      using size_ok_steps[of ?states 6] remaining_steps invar
      by blast

    from False show ?thesis
      using invar_stepped remaining_steps_stepped size_ok_stepped
      by(auto simp: Let_def)
  qed
next
  case (6 x big small)
  let ?small = "Small.push x small"
  let ?states = "States Left big ?small"
  let ?states_stepped = "(step^^4) ?states"

  from 6 have invar: "invar ?states"
    using invar_push_small[of Left big small x]
    by auto

  then have invar_stepped: "invar ?states_stepped"
    using invar_step_n by blast

  show ?case
   proof(cases "4 < remaining_steps ?states")
     case True

     obtain big_stepped small_stepped where stepped [simp]:
       "?states_stepped = States Left big_stepped small_stepped"
       by (metis remaining_steps_states.cases step_n_same)

     from True have remaining_steps: "0 < remaining_steps ?states_stepped"
       using invar remaining_steps_n_steps_sub[of ?states 4]
       by simp

     from True 6(1) have size_ok: "size_ok ?states_stepped"
       using
          step_4_push_small_size_ok[of Left big small x]
          remaining_steps_push_small[of Left big small x]
       by auto

     from remaining_steps size_ok invar_stepped show ?thesis
       by(cases big_stepped; cases small_stepped)
         (auto simp: Let_def split!: Common.state.split)
   next
     case False
     then have remaining_steps_stepped: "remaining_steps ?states_stepped = 0"
       using invar by auto

     then obtain small_current small_idle big_current big_idle where idle [simp]: "
      ?states_stepped =
      States Left
          (Big.state.Common (state.Idle big_current big_idle))
          (Small.state.Common (state.Idle small_current small_idle))
      "
       using remaining_steps_idle' invar_stepped remaining_steps_stepped step_n_same
       by (smt (verit) invar_states.elims(2))

     from 6 have [simp]: "size_new (Small.push x small) = Suc (size_new small)"
       using Small_Proof.size_new_push by auto

     have [simp]: "size small_idle = size_new (Small.push x small)"
       using invar invar_stepped step_n_size_new_small[of Left big "Small.push x small" 4]
       by auto

     then have [simp]: "\<not>is_empty small_idle"
       using Idle_Proof.size_not_empty[of small_idle]
       by auto

     have size_new_big [simp]: "0 < size_new big"
       using 6
       by auto

     then have [simp]: "size big_idle = size_new big"
       using invar invar_stepped step_n_size_new_big[of Left big "Small.push x small" 4]
       by auto

     then have [simp]: "\<not>is_empty big_idle"
       using Idle_Proof.size_not_empty size_new_big
       by metis

     have size_ok_1: "size small_idle \<le> 3 * size big_idle"
       using 6 by auto

     have size_ok_2: "size big_idle \<le> 3 * size small_idle"
      using 6 by auto

     from False show ?thesis
       using invar_stepped size_ok_1 size_ok_2
       by auto
   qed
next
  case (7 x big small)
  let ?big = "Big.push x big"
  let ?states = "States Right ?big small"
  let ?states_stepped = "(step^^4) ?states"

  from 7 have invar: "invar ?states"
    using invar_push_big[of Right big small x]
    by auto

  then have invar_stepped: "invar ?states_stepped"
    using invar_step_n by blast

  show ?case
   proof(cases "4 < remaining_steps ?states")
     case True

     obtain big_stepped small_stepped where stepped [simp]:
       "?states_stepped = States Right big_stepped small_stepped"
       by (metis remaining_steps_states.cases step_n_same)

     from True have remaining_steps: "0 < remaining_steps ?states_stepped"
       using invar remaining_steps_n_steps_sub[of ?states 4]
       by simp

     from True 7(1) have size_ok: "size_ok ?states_stepped"
       using
          step_4_push_big_size_ok[of Right big small x]
          remaining_steps_push_big[of Right big small x]
       by auto

     from remaining_steps size_ok invar_stepped show ?thesis
       by(cases big_stepped; cases small_stepped)
         (auto simp: Let_def split!: Common.state.split)
   next
     case False
     then have remaining_steps_stepped: "remaining_steps ?states_stepped = 0"
       using invar by auto

     then obtain small_current small_idle big_current big_idle where idle [simp]: "
      ?states_stepped =
      States Right
          (Big.state.Common (state.Idle big_current big_idle))
          (Small.state.Common (state.Idle small_current small_idle))
      "
       using remaining_steps_idle' invar_stepped remaining_steps_stepped step_n_same
       by (smt (verit) invar_states.elims(2))

     from 7 have [simp]: "size_new (Big.push x big) = Suc (size_new big)"
       using Big_Proof.size_new_push by auto

     have [simp]: "size big_idle = size_new (Big.push x big)"
       using invar invar_stepped step_n_size_new_big[of Right "Big.push x big" small 4]
       by auto

     then have [simp]: "\<not>is_empty big_idle"
       using Idle_Proof.size_not_empty[of big_idle]
       by auto

     have size_new_small [simp]: "0 < size_new small"
       using 7
       by auto

     then have [simp]: "size small_idle = size_new small"
       using invar invar_stepped step_n_size_new_small[of Right "Big.push x big" small 4]
       by auto

     then have [simp]: "\<not>is_empty small_idle"
       using Idle_Proof.size_not_empty size_new_small
       by metis

     have size_ok_1: "size small_idle \<le> 3 * size big_idle"
       using 7 by auto

     have size_ok_2: "size big_idle \<le> 3 * size small_idle"
      using 7 by auto

     from False show ?thesis
       using invar_stepped size_ok_1 size_ok_2
       by auto
   qed
qed auto

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Subsemicategory\<close>
theory CZH_SMC_Subsemicategory
  imports
    CZH_DG_Subdigraph
    CZH_SMC_Semifunctor
begin

subsection\<open>Background\<close>

named_theorems smc_sub_cs_intros
named_theorems smc_sub_bw_cs_intros
named_theorems smc_sub_fw_cs_intros
named_theorems smc_sub_bw_cs_simps

subsection\<open>Simple subsemicategory\<close>

subsubsection\<open>Definition and elementary properties\<close>

text\<open>See Chapter I-3 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

locale subsemicategory =
  sdg: semicategory \<alpha> \<BB> + dg: semicategory \<alpha> \<CC> for \<alpha> \<BB> \<CC> +
  assumes subsmc_subdigraph[slicing_intros]: "smc_dg \<BB> \<subseteq>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> smc_dg \<CC>"
    and subsmc_Comp[smc_sub_fw_cs_intros]:
      "\<lbrakk> g : b \<mapsto>\<^bsub>\<BB>\<^esub> c; f : a \<mapsto>\<^bsub>\<BB>\<^esub> b \<rbrakk> \<Longrightarrow> g \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> f = g \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f"

abbreviation is_subsemicategory ("(_/ \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<index> _)" [51, 51] 50)
  where "\<BB> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC> \<equiv> subsemicategory \<alpha> \<BB> \<CC>"

lemmas [smc_sub_fw_cs_intros] = subsemicategory.subsmc_Comp

text\<open>Rules.\<close>

lemma (in subsemicategory) subsemicategory_axioms'[smc_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<BB>' = \<BB>"
  shows "\<BB>' \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>'\<^esub> \<CC>"
  unfolding assms by (rule subsemicategory_axioms)

lemma (in subsemicategory) subsemicategory_axioms''[smc_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<CC>' = \<CC>"
  shows "\<BB> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule subsemicategory_axioms)

mk_ide rf subsemicategory_def[unfolded subsemicategory_axioms_def]
  |intro subsemicategoryI|
  |dest subsemicategoryD[dest]|
  |elim subsemicategoryE[elim!]|

lemmas [smc_sub_cs_intros] = subsemicategoryD(1,2)

lemma subsemicategoryI':
  assumes "semicategory \<alpha> \<BB>"
    and "semicategory \<alpha> \<CC>"
    and "\<And>a. a \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr> \<Longrightarrow> a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "\<And>a b f. f : a \<mapsto>\<^bsub>\<BB>\<^esub> b \<Longrightarrow> f : a \<mapsto>\<^bsub>\<CC>\<^esub> b"
    and "\<And>b c g a f. \<lbrakk> g : b \<mapsto>\<^bsub>\<BB>\<^esub> c; f : a \<mapsto>\<^bsub>\<BB>\<^esub> b \<rbrakk> \<Longrightarrow>
      g \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> f = g \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f"
  shows "\<BB> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
proof-
  interpret \<BB>: semicategory \<alpha> \<BB> by (rule assms(1))
  interpret \<CC>: semicategory \<alpha> \<CC> by (rule assms(2))
  show ?thesis
    by
      (
        intro subsemicategoryI subdigraphI,
        unfold slicing_simps;
        (intro \<BB>.smc_digraph \<CC>.smc_digraph assms)?
      )
qed

text\<open>Subsemicategory is a subdigraph.\<close>

context subsemicategory
begin

interpretation subdg: subdigraph \<alpha> \<open>smc_dg \<BB>\<close> \<open>smc_dg \<CC>\<close>
  by (rule subsmc_subdigraph)

lemmas_with [unfolded slicing_simps]:
  subsmc_Obj_vsubset = subdg.subdg_Obj_vsubset
  and subsmc_is_arr_vsubset = subdg.subdg_is_arr_vsubset
  and subsmc_subdigraph_op_dg_op_dg = subdg.subdg_subdigraph_op_dg_op_dg
  and subsmc_objD = subdg.subdg_objD
  and subsmc_arrD = subdg.subdg_arrD
  and subsmc_dom_simp = subdg.subdg_dom_simp
  and subsmc_cod_simp = subdg.subdg_cod_simp
  and subsmc_is_arrD = subdg.subdg_is_arrD
  and subsmc_dghm_inc_op_dg_is_dghm = subdg.subdg_dghm_inc_op_dg_is_dghm
  and subsmc_op_dg_dghm_inc = subdg.subdg_op_dg_dghm_inc
  and subsmc_inc_is_ft_dghm_axioms = subdg.inc.is_ft_dghm_axioms

end

lemmas subsmc_subdigraph_op_dg_op_dg[intro] =
  subsemicategory.subsmc_subdigraph_op_dg_op_dg

lemmas [smc_sub_fw_cs_intros] =
  subsemicategory.subsmc_Obj_vsubset
  subsemicategory.subsmc_is_arr_vsubset
  subsemicategory.subsmc_objD
  subsemicategory.subsmc_arrD
  subsemicategory.subsmc_is_arrD

lemmas [smc_sub_bw_cs_simps] =
  subsemicategory.subsmc_dom_simp
  subsemicategory.subsmc_cod_simp

text\<open>The opposite subsemicategory.\<close>

lemma (in subsemicategory) subsmc_subsemicategory_op_smc:
  "op_smc \<BB> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> op_smc \<CC>"
proof(rule subsemicategoryI)
  fix g b c f a assume prems: "g : b \<mapsto>\<^bsub>op_smc \<BB>\<^esub> c" "f : a \<mapsto>\<^bsub>op_smc \<BB>\<^esub> b"
  then have "g : c \<mapsto>\<^bsub>\<BB>\<^esub> b" and "f : b \<mapsto>\<^bsub>\<BB>\<^esub> a"
    by (simp_all add: smc_op_simps)
  with subsemicategory_axioms have g: "g : c \<mapsto>\<^bsub>\<CC>\<^esub> b" and f: "f : b \<mapsto>\<^bsub>\<CC>\<^esub> a"
    by (cs_concl cs_shallow cs_intro: smc_sub_fw_cs_intros)+
  from dg.op_smc_Comp[OF this(2,1)] have "g \<circ>\<^sub>A\<^bsub>op_smc \<CC>\<^esub> f = f \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> g".
  with prems show "g \<circ>\<^sub>A\<^bsub>op_smc \<BB>\<^esub> f = g \<circ>\<^sub>A\<^bsub>op_smc \<CC>\<^esub> f"
    by (simp add: smc_op_simps subsmc_Comp)
qed
  (
    auto
      simp:
        smc_op_simps slicing_commute[symmetric] subsmc_subdigraph_op_dg_op_dg
      intro: smc_op_intros
  )

lemmas subsmc_subsemicategory_op_smc[intro, smc_op_intros] =
  subsemicategory.subsmc_subsemicategory_op_smc

text\<open>Further rules.\<close>

lemma (in subsemicategory) subsmc_Comp_simp:
  assumes "g : b \<mapsto>\<^bsub>\<BB>\<^esub> c" and "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b"
  shows "g \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> f = g \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f"
  using assms subsmc_Comp by auto

lemmas [smc_sub_bw_cs_simps] = subsemicategory.subsmc_Comp_simp

lemma (in subsemicategory) subsmc_is_idem_arrD:
  assumes "f : \<mapsto>\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<BB>\<^esub> b"
  shows "f : \<mapsto>\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<CC>\<^esub> b"
  using assms subsemicategory_axioms
  by (intro is_idem_arrI; elim is_idem_arrE)
    (
      cs_concl cs_shallow
        cs_simp: smc_sub_bw_cs_simps[symmetric] cs_intro: smc_sub_fw_cs_intros
    )

lemmas [smc_sub_fw_cs_intros] = subsemicategory.subsmc_is_idem_arrD

subsubsection\<open>Subsemicategory relation is a partial order\<close>

lemma subsmc_refl:
  assumes "semicategory \<alpha> \<AA>"
  shows "\<AA> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA>"
proof-
  interpret semicategory \<alpha> \<AA> by (rule assms)
  show ?thesis
    by (auto intro: smc_cs_intros slicing_intros subdg_refl subsemicategoryI)
qed

lemma subsmc_trans[trans]:
  assumes "\<AA> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>" and "\<BB> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<AA> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
proof-
  interpret \<AA>\<BB>: subsemicategory \<alpha> \<AA> \<BB> by (rule assms(1))
  interpret \<BB>\<CC>: subsemicategory \<alpha> \<BB> \<CC> by (rule assms(2))
  show ?thesis
  proof(rule subsemicategoryI)
    from \<AA>\<BB>.subsmc_subdigraph \<BB>\<CC>.subsmc_subdigraph
    show "smc_dg \<AA> \<subseteq>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> smc_dg \<CC>" by (meson subdg_trans)
    show "g \<circ>\<^sub>A\<^bsub>\<AA>\<^esub> f = g \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f"
      if "g : b \<mapsto>\<^bsub>\<AA>\<^esub> c" and "f : a \<mapsto>\<^bsub>\<AA>\<^esub> b" for g b c f a
      by
        (
          metis
            that
            \<AA>\<BB>.subsmc_is_arr_vsubset
            \<AA>\<BB>.subsmc_Comp_simp
            \<BB>\<CC>.subsmc_Comp_simp
        )
  qed (auto intro: smc_cs_intros)
qed

lemma subsmc_antisym:
  assumes "\<AA> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>" and "\<BB> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<AA>"
  shows "\<AA> = \<BB>"
proof-
  interpret \<AA>\<BB>: subsemicategory \<alpha> \<AA> \<BB> by (rule assms(1))
  interpret \<BB>\<AA>: subsemicategory \<alpha> \<BB> \<AA> by (rule assms(2))
  show ?thesis
  proof(rule smc_eqI)
    from subdg_antisym[OF \<AA>\<BB>.subsmc_subdigraph \<BB>\<AA>.subsmc_subdigraph] have
      "smc_dg \<AA>\<lparr>Obj\<rparr> = smc_dg \<BB>\<lparr>Obj\<rparr>" "smc_dg \<AA>\<lparr>Arr\<rparr> = smc_dg \<BB>\<lparr>Arr\<rparr>"
      by simp_all
    then show "\<AA>\<lparr>Obj\<rparr> = \<BB>\<lparr>Obj\<rparr>" and Arr: "\<AA>\<lparr>Arr\<rparr> = \<BB>\<lparr>Arr\<rparr>"
      unfolding slicing_simps by simp_all
    show "\<AA>\<lparr>Dom\<rparr> = \<BB>\<lparr>Dom\<rparr>"
      by (rule vsv_eqI) (auto simp: smc_cs_simps \<AA>\<BB>.subsmc_dom_simp Arr)
    show "\<AA>\<lparr>Cod\<rparr> = \<BB>\<lparr>Cod\<rparr>"
      by (rule vsv_eqI) (auto simp: smc_cs_simps \<BB>\<AA>.subsmc_cod_simp Arr)
    show "\<AA>\<lparr>Comp\<rparr> = \<BB>\<lparr>Comp\<rparr>"
    proof(rule vsv_eqI)
      show "\<D>\<^sub>\<circ> (\<AA>\<lparr>Comp\<rparr>) = \<D>\<^sub>\<circ> (\<BB>\<lparr>Comp\<rparr>)"
      proof(intro vsubset_antisym vsubsetI)
        fix gf assume "gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<AA>\<lparr>Comp\<rparr>)"
        then obtain g f b c a
          where gf_def: "gf = [g, f]\<^sub>\<circ>"
            and g: "g : b \<mapsto>\<^bsub>\<AA>\<^esub> c"
            and f: "f : a \<mapsto>\<^bsub>\<AA>\<^esub> b"
          by (auto simp: \<AA>\<BB>.sdg.smc_Comp_vdomain)
        from g f show "gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<BB>\<lparr>Comp\<rparr>)"
          unfolding gf_def by (meson \<AA>\<BB>.dg.smc_Comp_vdomainI \<AA>\<BB>.subsmc_is_arrD)
      next
        fix gf assume "gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<BB>\<lparr>Comp\<rparr>)"
        then obtain g f b c a
          where gf_def: "gf = [g, f]\<^sub>\<circ>"
            and g: "g : b \<mapsto>\<^bsub>\<BB>\<^esub> c"
            and f: "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b"
          by (auto simp: \<AA>\<BB>.dg.smc_Comp_vdomain)
        from g f show "gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<AA>\<lparr>Comp\<rparr>)"
          unfolding gf_def by (meson \<AA>\<BB>.sdg.smc_Comp_vdomainI \<BB>\<AA>.subsmc_is_arrD)
      qed
      show "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<AA>\<lparr>Comp\<rparr>) \<Longrightarrow> \<AA>\<lparr>Comp\<rparr>\<lparr>a\<rparr> = \<BB>\<lparr>Comp\<rparr>\<lparr>a\<rparr>" for a
        by (metis \<AA>\<BB>.sdg.smc_Comp_vdomain \<AA>\<BB>.subsmc_Comp_simp)
    qed auto
  qed (auto intro: smc_cs_intros)
qed

subsection\<open>Inclusion semifunctor\<close>

subsubsection\<open>Definition and elementary properties\<close>

text\<open>See Chapter I-3 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

abbreviation (input) smcf_inc :: "V \<Rightarrow> V \<Rightarrow> V"
  where "smcf_inc \<equiv> dghm_inc"

text\<open>Slicing.\<close>

lemma dghm_smcf_inc[slicing_commute]:
  "dghm_inc (smc_dg \<BB>) (smc_dg \<CC>) = smcf_dghm (smcf_inc \<BB> \<CC>)"
  unfolding
    smcf_dghm_def dghm_inc_def smc_dg_def dg_field_simps dghm_field_simps
  by (simp_all add: nat_omega_simps)

text\<open>Elementary properties.\<close>

lemmas [smc_cs_simps] =
  dghm_inc_ObjMap_app
  dghm_inc_ArrMap_app

subsubsection\<open>Canonical inclusion semifunctor associated with a subsemicategory\<close>

sublocale subsemicategory \<subseteq> inc: is_ft_semifunctor \<alpha> \<BB> \<CC> \<open>smcf_inc \<BB> \<CC>\<close>
proof(rule is_ft_semifunctorI)
  show "smcf_inc \<BB> \<CC> : \<BB> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<CC>"
  proof(rule is_semifunctorI)
    show "vfsequence (dghm_inc \<BB> \<CC>)" unfolding dghm_inc_def by auto
    show "vcard (dghm_inc \<BB> \<CC>) = 4\<^sub>\<nat>"
      unfolding dghm_inc_def by (simp add: nat_omega_simps)
    fix g b c f a assume prems: "g : b \<mapsto>\<^bsub>\<BB>\<^esub> c" "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b"
    then have "g \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> f : a \<mapsto>\<^bsub>\<BB>\<^esub> c" by (simp add: smc_cs_intros)
    with subsemicategory_axioms prems have [simp]:
      "vid_on (\<BB>\<lparr>Arr\<rparr>)\<lparr>g \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> f\<rparr> = g \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f"
      by (auto simp: smc_sub_bw_cs_simps)
    from prems show "dghm_inc \<BB> \<CC>\<lparr>ArrMap\<rparr>\<lparr>g \<circ>\<^sub>A\<^bsub>\<BB>\<^esub> f\<rparr> =
      dghm_inc \<BB> \<CC>\<lparr>ArrMap\<rparr>\<lparr>g\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> dghm_inc \<BB> \<CC>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr>"
      by
        (
          cs_concl
            cs_simp: smc_cs_simps cs_intro: smc_cs_intros smc_sub_fw_cs_intros
        )
  qed
    (
      insert subsmc_inc_is_ft_dghm_axioms,
      auto simp: slicing_commute[symmetric] dghm_inc_components smc_cs_intros
    )
qed (auto simp: slicing_commute[symmetric] subsmc_inc_is_ft_dghm_axioms)

lemmas (in subsemicategory) subsmc_smcf_inc_is_ft_semifunctor =
  inc.is_ft_semifunctor_axioms

subsubsection\<open>Inclusion semifunctor for the opposite semicategories\<close>

lemma (in subsemicategory)
  subsemicategory_smcf_inc_op_smc_is_semifunctor[smc_sub_cs_intros]:
  "smcf_inc (op_smc \<BB>) (op_smc \<CC>) : op_smc \<BB> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>f\<^sub>a\<^sub>i\<^sub>t\<^sub>h\<^sub>f\<^sub>u\<^sub>l\<^bsub>\<alpha>\<^esub> op_smc \<CC>"
  by
    (
      intro
        subsemicategory.subsmc_smcf_inc_is_ft_semifunctor
        subsmc_subsemicategory_op_smc
    )

lemmas [smc_sub_cs_intros] =
  subsemicategory.subsemicategory_smcf_inc_op_smc_is_semifunctor

lemma (in subsemicategory) subdg_op_smc_smcf_inc[smc_op_simps]:
  "op_smcf (smcf_inc \<BB> \<CC>) = smcf_inc (op_smc \<BB>) (op_smc \<CC>)"
  by
    (
      rule smcf_eqI[of \<alpha> \<open>op_smc \<BB>\<close> \<open>op_smc \<CC>\<close>],
      unfold smc_op_simps dghm_inc_components
    )
    (
      auto simp:
        is_ft_semifunctorD
        subsemicategory_smcf_inc_op_smc_is_semifunctor
        inc.is_semifunctor_op
    )

lemmas [smc_op_simps] = subsemicategory.subdg_op_smc_smcf_inc

subsection\<open>Full subsemicategory\<close>

text\<open>See Chapter I-3 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

locale fl_subsemicategory = subsemicategory +
  assumes fl_subsemicategory_fl_subdigraph: "smc_dg \<BB> \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>f\<^sub>u\<^sub>l\<^sub>l\<^bsub>\<alpha>\<^esub> smc_dg \<CC>"

abbreviation is_fl_subsemicategory ("(_/ \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>f\<^sub>u\<^sub>l\<^sub>l\<index> _)" [51, 51] 50)
  where "\<BB> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>f\<^sub>u\<^sub>l\<^sub>l\<^bsub>\<alpha>\<^esub> \<CC> \<equiv> fl_subsemicategory \<alpha> \<BB> \<CC>"

text\<open>Rules.\<close>

lemma (in fl_subsemicategory) fl_subsemicategory_axioms'[smc_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<BB>' = \<BB>"
  shows "\<BB>' \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>f\<^sub>u\<^sub>l\<^sub>l\<^bsub>\<alpha>'\<^esub> \<CC>"
  unfolding assms by (rule fl_subsemicategory_axioms)

lemma (in fl_subsemicategory) fl_subsemicategory_axioms''[smc_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<CC>' = \<CC>"
  shows "\<BB> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>f\<^sub>u\<^sub>l\<^sub>l\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule fl_subsemicategory_axioms)

mk_ide rf fl_subsemicategory_def[unfolded fl_subsemicategory_axioms_def]
  |intro fl_subsemicategoryI|
  |dest fl_subsemicategoryD[dest]|
  |elim fl_subsemicategoryE[elim!]|

lemmas [smc_sub_cs_intros] = fl_subsemicategoryD(1)

text\<open>Full subsemicategory.\<close>

sublocale fl_subsemicategory \<subseteq> inc: is_fl_semifunctor \<alpha> \<BB> \<CC> \<open>smcf_inc \<BB> \<CC>\<close>
  using fl_subsemicategory_fl_subdigraph inc.is_semifunctor_axioms
  by (intro is_fl_semifunctorI) (auto simp: slicing_commute[symmetric])

subsection\<open>Wide subsemicategory\<close>

subsubsection\<open>Definition and elementary properties\<close>

text\<open>
See \<^cite>\<open>"noauthor_nlab_nodate"\<close>\footnote{
\url{https://ncatlab.org/nlab/show/wide+subcategory}
}).
\<close>

locale wide_subsemicategory = subsemicategory +
  assumes wide_subsmc_wide_subdigraph: "smc_dg \<BB> \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> smc_dg \<CC>"

abbreviation is_wide_subsemicategory ("(_/ \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<index> _)" [51, 51] 50)
  where "\<BB> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> \<CC> \<equiv> wide_subsemicategory \<alpha> \<BB> \<CC>"

text\<open>Rules.\<close>

lemma (in wide_subsemicategory) wide_subsemicategory_axioms'[smc_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<BB>' = \<BB>"
  shows "\<BB>' \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>'\<^esub> \<CC>"
  unfolding assms by (rule wide_subsemicategory_axioms)

lemma (in wide_subsemicategory) wide_subsemicategory_axioms''[smc_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<CC>' = \<CC>"
  shows "\<BB> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule wide_subsemicategory_axioms)

mk_ide rf wide_subsemicategory_def[unfolded wide_subsemicategory_axioms_def]
  |intro wide_subsemicategoryI|
  |dest wide_subsemicategoryD[dest]|
  |elim wide_subsemicategoryE[elim!]|

lemmas [smc_sub_cs_intros] = wide_subsemicategoryD(1)

text\<open>Wide subsemicategory is wide subdigraph.\<close>

context wide_subsemicategory
begin

interpretation wide_subdg: wide_subdigraph \<alpha> \<open>smc_dg \<BB>\<close> \<open>smc_dg \<CC>\<close>
  by (rule wide_subsmc_wide_subdigraph)

lemmas_with [unfolded slicing_simps]:
  wide_subsmc_Obj[dg_sub_bw_cs_intros] = wide_subdg.wide_subdg_Obj
  and wide_subsmc_obj_eq[dg_sub_bw_cs_simps] = wide_subdg.wide_subdg_obj_eq

end

lemmas [dg_sub_bw_cs_intros] = wide_subsemicategory.wide_subsmc_Obj
lemmas [dg_sub_bw_cs_simps] = wide_subsemicategory.wide_subsmc_obj_eq

subsubsection\<open>The wide subsemicategory relation is a partial order\<close>

lemma wide_subsmc_refl:
  assumes "semicategory \<alpha> \<AA>"
  shows "\<AA> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> \<AA>"
proof-
  interpret semicategory \<alpha> \<AA> by (rule assms)
  show ?thesis
    by
      (
        auto intro:
          assms
          slicing_intros
          wide_subdg_refl
          wide_subsemicategoryI
          subsmc_refl
      )
qed

lemma wide_subsmc_trans[trans]:
  assumes "\<AA> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> \<BB>" and "\<BB> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<AA> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> \<CC>"
proof-
  interpret \<AA>\<BB>: wide_subsemicategory \<alpha> \<AA> \<BB> by (rule assms(1))
  interpret \<BB>\<CC>: wide_subsemicategory \<alpha> \<BB> \<CC> by (rule assms(2))
  show ?thesis
    by
      (
        intro
          wide_subsemicategoryI
          subsmc_trans[
            OF \<AA>\<BB>.subsemicategory_axioms \<BB>\<CC>.subsemicategory_axioms
            ],
        rule wide_subdg_trans,
        rule \<AA>\<BB>.wide_subsmc_wide_subdigraph,
        rule \<BB>\<CC>.wide_subsmc_wide_subdigraph
     )
qed

lemma wide_subsmc_antisym:
  assumes "\<AA> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> \<BB>" and "\<BB> \<subseteq>\<^sub>S\<^sub>M\<^sub>C\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> \<AA>"
  shows "\<AA> = \<BB>"
proof-
  interpret \<AA>\<BB>: wide_subsemicategory \<alpha> \<AA> \<BB> by (rule assms(1))
  interpret \<BB>\<AA>: wide_subsemicategory \<alpha> \<BB> \<AA> by (rule assms(2))
  show ?thesis
    by
      (
        rule subsmc_antisym[
          OF \<AA>\<BB>.subsemicategory_axioms \<BB>\<AA>.subsemicategory_axioms
          ]
      )
qed

text\<open>\newpage\<close>

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)
 *)

(* Author: Thomas Sewell *)

section "Enumeration Instances for Words"

theory Word_Enum
imports Enumeration Word_Lib
begin

instantiation word :: (len) enum
begin

definition
  "(enum_class.enum :: ('a :: len) word list) \<equiv> map of_nat [0 ..< 2 ^ len_of TYPE('a)]"

definition
  "enum_class.enum_all (P :: ('a :: len) word \<Rightarrow> bool) \<longleftrightarrow> Ball UNIV P"

definition
  "enum_class.enum_ex (P :: ('a :: len) word \<Rightarrow> bool) \<longleftrightarrow> Bex UNIV P"

instance
  apply (intro_classes)
     apply (simp add: enum_word_def)
     apply force
    apply (simp add: distinct_map enum_word_def)
    apply (rule subset_inj_on, rule word_unat.Abs_inj_on)
    apply (clarsimp simp add: unats_def)
   apply (simp add: enum_all_word_def)
  apply (simp add: enum_ex_word_def)
  done

end

lemma fromEnum_unat[simp]: "fromEnum (x :: ('a :: len) word) = unat x"
  apply (subgoal_tac "x \<in> set enum")
   defer
   apply simp
  apply (unfold fromEnum_def enum_word_def)
  apply (subgoal_tac "\<forall>n. n < 2 ^ len_of TYPE('a) \<longrightarrow> (map of_nat [0..< 2 ^ len_of TYPE('a)] ! n) = x --> n = unat x")
   apply (subgoal_tac "(map of_nat [0..< 2 ^ len_of TYPE('a)]) ! (the_index (map of_nat [0..< 2 ^ len_of TYPE('a)]) x) = x")
    apply (subgoal_tac "the_index (map of_nat [0..< 2 ^ len_of TYPE('a)]) x < 2 ^ len_of TYPE('a)")
     apply simp
    apply (subgoal_tac "the_index (map of_nat [0..< 2 ^ len_of TYPE('a)]) x < length (map of_nat [0..< 2 ^ len_of TYPE('a)])")
     apply simp
    apply (rule the_index_bounded)
    apply (simp add: enum_word_def)
   apply (rule nth_the_index)
   apply (simp add: enum_word_def)
  apply safe
  apply (simp add: unat_of_nat)
  done

lemma length_word_enum: "length (enum :: ('a :: len) word list) = 2 ^ len_of TYPE('a)"
  apply (simp add: enum_word_def)
  done

lemma toEnum_of_nat[simp]: "n < 2 ^ len_of TYPE('a) \<Longrightarrow> ((toEnum n) :: ('a :: len) word) = of_nat n"
  apply (subst toEnum_def)
  apply (simp add: length_word_enum)
  apply (subst enum_word_def)
  apply simp
  done

declare of_nat_diff [simp]

lemma "(maxBound :: ('a :: len) word) = -1"
  apply (unfold maxBound_def enum_word_def)
  apply (subst last_map)
   apply simp
  apply simp
  done

lemma "(minBound :: ('a :: len) word) = 0"
  apply (unfold minBound_def enum_word_def)
  apply (simp add: hd_conv_nth)
  done

instantiation word :: (len) enumeration_both
begin

definition
  enum_alt_word_def: "enum_alt \<equiv> alt_from_ord (enum :: ('a :: len) word list)"

instance
  by (intro_classes, simp add: enum_alt_word_def)

end

definition
  upto_enum_step :: "('a :: len) word \<Rightarrow> 'a word \<Rightarrow> 'a word \<Rightarrow> 'a word list" ("[_ , _ .e. _]")
where
  "upto_enum_step a b c \<equiv>
      if c < a then [] else map (\<lambda>x. a + x * (b - a)) [0 .e. (c - a) div (b - a)]"
  (* in the wraparound case, bad things happen. *)

lemma maxBound_word:
  "(maxBound::'a::len word) = -1"
  by (simp add: maxBound_def enum_word_def last_map)

lemma minBound_word:
  "(minBound::'a::len word) = 0"
  by (simp add: minBound_def enum_word_def upt_conv_Cons)

lemma maxBound_max_word:
  "(maxBound::'a::len word) = max_word"
  apply (subst maxBound_word)
  apply (subst max_word_minus [symmetric])
  apply (rule refl)
  done

end