Theory Intermediate_Implementations
section ‹Intermediate Implementations›
text ‹This theory implements various functions to be supplied to the H, SPY, and Pair-Frameworks.›
theory Intermediate_Implementations
imports H_Framework SPY_Framework Pair_Framework "../Distinguishability" Automatic_Refinement.Misc
begin
subsection ‹Functions for the Pair Framework›
definition get_initial_test_suite_H :: "('a,'b,'c) state_cover_assignment ⇒
('a::linorder,'b::linorder,'c::linorder) fsm ⇒
nat ⇒
('b×'c) prefix_tree"
where
"get_initial_test_suite_H V M m =
(let
rstates = reachable_states_as_list M;
n = size_r M;
iM = inputs_as_list M;
T = from_list (concat (map (λq . map (λτ. (V q)@τ) (h_extensions M q (m-n))) rstates))
in T)"
lemma get_initial_test_suite_H_set_and_finite :
shows "{(V q)@io@[(x,y)] | q io x y . q ∈ reachable_states M ∧ io ∈ LS M q ∧ length io ≤ m - size_r M ∧ x ∈ inputs M ∧ y ∈ outputs M} ⊆ set (get_initial_test_suite_H V M m)"
and "finite_tree (get_initial_test_suite_H V M m)"
proof -
define rstates where "rstates = reachable_states_as_list M"
moreover define n where "n = size_r M"
moreover define iM where "iM = inputs_as_list M"
moreover define T where "T = from_list (concat (map (λq . map (λτ. (V q)@τ) (h_extensions M q (m-n))) rstates))"
ultimately have res: "get_initial_test_suite_H V M m = T"
unfolding get_initial_test_suite_H_def Let_def by auto
define 𝒳 where 𝒳: "𝒳 = (λ q . {io@[(x,y)] | io x y . io ∈ LS M q ∧ length io ≤ m-n ∧ x ∈ inputs M ∧ y ∈ outputs M})"
have "list.set rstates = reachable_states M"
unfolding rstates_def reachable_states_as_list_set by simp
have "{ (V q) @ τ | q τ . q ∈ reachable_states M ∧ τ ∈ 𝒳 q} ⊆ set T"
proof
fix io assume "io ∈ { (V q) @ τ | q τ . q ∈ reachable_states M ∧ τ ∈ 𝒳 q}"
then obtain q τ where "io = (V q) @ τ"
and "q ∈ reachable_states M"
and "τ ∈ 𝒳 q"
by blast
have "τ ∈ list.set (h_extensions M q (m - n))"
using ‹τ ∈ 𝒳 q› unfolding 𝒳
using h_extensions_set[OF reachable_state_is_state[OF ‹q ∈ reachable_states M›]]
by auto
then have "io ∈ list.set (map ((@) (V q)) (h_extensions M q (m - n)))"
unfolding ‹io = (V q) @ τ› by auto
moreover have "q ∈ list.set rstates"
using ‹list.set rstates = reachable_states M› ‹q ∈ reachable_states M› by auto
ultimately have "io ∈ list.set (concat (map (λq. map ((@) (V q)) (h_extensions M q (m - n))) rstates))"
by auto
then show "io ∈ set T"
unfolding T_def from_list_set by blast
qed
moreover have "{ (V q) @ τ | q τ . q ∈ reachable_states M ∧ τ ∈ 𝒳 q} = {(V q)@io@[(x,y)] | q io x y . q ∈ reachable_states M ∧ io ∈ LS M q ∧ length io ≤ m - size_r M ∧ x ∈ inputs M ∧ y ∈ outputs M}"
unfolding 𝒳 n_def[symmetric] by force
ultimately show "{(V q)@io@[(x,y)] | q io x y . q ∈ reachable_states M ∧ io ∈ LS M q ∧ length io ≤ m - size_r M ∧ x ∈ inputs M ∧ y ∈ outputs M} ⊆ set (get_initial_test_suite_H V M m)"
unfolding res by simp
show "finite_tree (get_initial_test_suite_H V M m)"
unfolding res T_def
using from_list_finite_tree by auto
qed
fun complete_inputs_to_tree :: "('a::linorder,'b::linorder,'c::linorder) fsm ⇒ 'a ⇒ 'c list ⇒ 'b list ⇒ ('b × 'c) prefix_tree" where
"complete_inputs_to_tree M q ys [] = Prefix_Tree.empty" |
"complete_inputs_to_tree M q ys (x#xs) = foldl (λ t y . case h_obs M q x y of None ⇒ insert t [(x,y)] |
Some q' ⇒ combine_after t [(x,y)] (complete_inputs_to_tree M q' ys xs)) Prefix_Tree.empty ys"
lemma complete_inputs_to_tree_finite_tree :
"finite_tree (complete_inputs_to_tree M q ys xs)"
proof (induction xs arbitrary: q ys)
case Nil
then show ?case using empty_finite_tree by auto
next
case (Cons x xs)
define ys' where "ys' = ys"
moreover define f where "f = (λ t y . case h_obs M q x y of None ⇒ insert t [(x,y)] | Some q' ⇒ combine_after t [(x,y)] (complete_inputs_to_tree M q' ys' xs))"
ultimately have *:"complete_inputs_to_tree M q ys (x # xs)
= foldl f Prefix_Tree.empty ys"
by auto
moreover have "finite_tree (foldl f Prefix_Tree.empty ys)"
proof (induction ys rule: rev_induct)
case Nil
then show ?case using empty_finite_tree by auto
next
case (snoc y ys)
define t where "t = foldl (λ t y . case h_obs M q x y of None ⇒ insert t [(x,y)] | Some q' ⇒ combine_after t [(x,y)] (complete_inputs_to_tree M q' ys' xs)) Prefix_Tree.empty ys"
then have *:"foldl f Prefix_Tree.empty (ys@[y])
= (case h_obs M q x y of None ⇒ insert t [(x,y)] | Some q' ⇒ combine_after t [(x,y)] (complete_inputs_to_tree M q' ys' xs))"
unfolding f_def by auto
have "finite_tree t"
using snoc unfolding t_def f_def by force
have "finite_tree (insert t [(x,y)])"
using ‹finite_tree t› insert_finite_tree by blast
moreover have "⋀ q' . finite_tree (combine_after t [(x,y)] (complete_inputs_to_tree M q' ys' xs))"
using ‹finite_tree t› ‹⋀ q ys . finite_tree (complete_inputs_to_tree M q ys xs)› combine_after_finite_tree by blast
ultimately show ?case
unfolding * by auto
qed
ultimately show ?case by auto
qed
fun complete_inputs_to_tree_initial :: "('a::linorder,'b::linorder,'c::linorder) fsm ⇒ 'b list ⇒ ('b × 'c) prefix_tree" where
"complete_inputs_to_tree_initial M xs = complete_inputs_to_tree M (initial M) (outputs_as_list M) xs"
definition get_initial_test_suite_H_2 :: "bool ⇒ ('a,'b,'c) state_cover_assignment ⇒
('a::linorder,'b::linorder,'c::linorder) fsm ⇒
nat ⇒
('b×'c) prefix_tree" where
"get_initial_test_suite_H_2 c V M m =
(if c then get_initial_test_suite_H V M m
else let TS = get_initial_test_suite_H V M m;
xss = map (map fst) (sorted_list_of_maximal_sequences_in_tree TS);
ys = outputs_as_list M
in
foldl (λ t xs . combine t (complete_inputs_to_tree_initial M xs)) TS xss)"
lemma get_initial_test_suite_H_2_set_and_finite :
shows "{(V q)@io@[(x,y)] | q io x y . q ∈ reachable_states M ∧ io ∈ LS M q ∧ length io ≤ m - size_r M ∧ x ∈ inputs M ∧ y ∈ outputs M} ⊆ set (get_initial_test_suite_H_2 c V M m)" (is ?P1)
and "finite_tree (get_initial_test_suite_H_2 c V M m)" (is ?P2)
proof -
have "?P1 ∧ ?P2"
proof (cases c)
case True
then have "get_initial_test_suite_H_2 c V M m = get_initial_test_suite_H V M m"
unfolding get_initial_test_suite_H_2_def by auto
then show ?thesis
using get_initial_test_suite_H_set_and_finite
by fastforce
next
case False
define TS where "TS = get_initial_test_suite_H V M m"
moreover define xss where "xss = map (map fst) (sorted_list_of_maximal_sequences_in_tree TS)"
moreover define ys where "ys = outputs_as_list M"
ultimately have "get_initial_test_suite_H_2 c V M m = foldl (λ t xs . combine t (complete_inputs_to_tree M (initial M) ys xs)) TS xss"
unfolding get_initial_test_suite_H_2_def Let_def using False by auto
moreover have "set TS ⊆ set (foldl (λ t xs . combine t (complete_inputs_to_tree M (initial M) ys xs)) TS xss)"
using combine_set by (induction xss rule: rev_induct; auto)
moreover have "finite_tree (foldl (λ t xs . combine t (complete_inputs_to_tree M (initial M) ys xs)) TS xss)"
using complete_inputs_to_tree_finite_tree get_initial_test_suite_H_set_and_finite(2)[of V M m] combine_finite_tree
unfolding TS_def[symmetric] by (induction xss rule: rev_induct; auto; blast)
ultimately show ?thesis
using get_initial_test_suite_H_set_and_finite(1)[of V M m] unfolding TS_def[symmetric]
by force
qed
then show ?P1 and ?P2
by blast+
qed
definition get_pairs_H :: "('a,'b,'c) state_cover_assignment ⇒
('a::linorder,'b::linorder,'c::linorder) fsm ⇒
nat ⇒
((('b × 'c) list × 'a) × (('b × 'c) list × 'a)) list"
where
"get_pairs_H V M m =
(let
rstates = reachable_states_as_list M;
n = size_r M;
iM = inputs_as_list M;
hMap = mapping_of (map (λ(q,x) . ((q,x), map (λ(y,q') . (q,x,y,q')) (sorted_list_of_set (h M (q,x))))) (List.product (states_as_list M) iM));
hM = (λ q x . case Mapping.lookup hMap (q,x) of Some ts ⇒ ts | None ⇒ []);
pairs = pairs_to_distinguish M V (λq . paths_up_to_length_with_targets q hM iM ((m-n)+1)) rstates
in
pairs)"
lemma get_pairs_H_set :
assumes "observable M"
and "is_state_cover_assignment M V"
shows
"⋀ α β . (α,β) ∈ (V ` reachable_states M) × (V ` reachable_states M)
∪ (V ` reachable_states M) × { (V q) @ τ | q τ . q ∈ reachable_states M ∧ τ ∈ {io@[(x,y)] | io x y . io ∈ LS M q ∧ length io ≤ m-size_r M ∧ x ∈ inputs M ∧ y ∈ outputs M}}
∪ (⋃ q ∈ reachable_states M . ⋃ τ ∈ {io@[(x,y)] | io x y . io ∈ LS M q ∧ length io ≤ m-size_r M ∧ x ∈ inputs M ∧ y ∈ outputs M} . { (V q) @ τ' | τ' . τ' ∈ list.set (prefixes τ)} × {(V q)@τ}) ⟹
α ∈ L M ⟹ β ∈ L M ⟹ after_initial M α ≠ after_initial M β ⟹
((α,after_initial M α),(β,after_initial M β)) ∈ list.set (get_pairs_H V M m)"
and "⋀ α q' β q'' . ((α,q'),(β,q'')) ∈ list.set (get_pairs_H V M m) ⟹ α ∈ L M ∧ β ∈ L M ∧ after_initial M α ≠ after_initial M β ∧ q' = after_initial M α ∧ q'' = after_initial M β"
proof -
define rstates where "rstates = reachable_states_as_list M"
moreover define n where "n = size_r M"
moreover define iM where "iM = inputs_as_list M"
moreover define hMap' where "hMap' = mapping_of (map (λ(q,x) . ((q,x), map (λ(y,q') . (q,x,y,q')) (sorted_list_of_set (h M (q,x))))) (List.product (states_as_list M) iM))"
moreover define hM' where "hM' = (λ q x . case Mapping.lookup hMap' (q,x) of Some ts ⇒ ts | None ⇒ [])"
ultimately have "get_pairs_H V M m = pairs_to_distinguish M V (λq . paths_up_to_length_with_targets q hM' iM ((m-n)+1)) rstates"
unfolding get_pairs_H_def Let_def by force
define hMap where "hMap = map_of (map (λ(q,x) . ((q,x), map (λ(y,q') . (q,x,y,q')) (sorted_list_of_set (h M (q,x))))) (List.product (states_as_list M) iM))"
define hM where "hM = (λ q x . case hMap (q,x) of Some ts ⇒ ts | None ⇒ [])"
have "distinct (List.product (states_as_list M) iM)"
using states_as_list_distinct inputs_as_list_distinct distinct_product
unfolding iM_def
by blast
then have "Mapping.lookup hMap' = hMap"
using mapping_of_map_of
unfolding hMap_def hMap'_def
using map_pair_fst_helper[of "λ q x . map (λ(y,q') . (q,x,y,q')) (sorted_list_of_set (h M (q,x)))"]
by (metis (no_types, lifting))
then have "hM' = hM"
unfolding hM'_def hM_def
by meson
moreover define pairs where "pairs = pairs_to_distinguish M V (λq . paths_up_to_length_with_targets q hM iM ((m-n)+1)) rstates"
ultimately have res: "get_pairs_H V M m = pairs"
unfolding ‹get_pairs_H V M m = pairs_to_distinguish M V (λq . paths_up_to_length_with_targets q hM' iM ((m-n)+1)) rstates›
by force
have *:"list.set rstates = reachable_states M"
unfolding rstates_def reachable_states_as_list_set by simp
define 𝒳' where 𝒳': "𝒳' = (λq . paths_up_to_length_with_targets q hM iM ((m-n)+1))"
have **: "⋀ q p q' . q ∈ reachable_states M ⟹ (p,q') ∈ list.set (𝒳' q) ⟷ path M q p ∧ target q p = q' ∧ length p ≤ m-n+1"
proof -
fix q p q' assume "q ∈ reachable_states M"
define qxPairs where qxPairs: "qxPairs = (List.product (states_as_list M) iM)"
moreover define mapList where mapList: "mapList = (map (λ(q,x) . ((q,x), map (λ(y,q') . (q,x,y,q')) (sorted_list_of_set (h M (q,x))))) qxPairs)"
ultimately have hMap': "hMap = map_of mapList"
unfolding hMap_def by simp
have "distinct (states_as_list M)" and "distinct iM"
unfolding iM_def
by auto
then have "distinct qxPairs"
unfolding qxPairs by (simp add: distinct_product)
moreover have "(map fst mapList) = qxPairs"
unfolding mapList by (induction qxPairs; auto)
ultimately have "distinct (map fst mapList)"
by auto
have "⋀ q x . hM q x = map (λ(y, q'). (q, x, y, q')) (sorted_list_of_set (h M (q, x)))"
proof -
fix q x
show "hM q x = map (λ(y, q'). (q, x, y, q')) (sorted_list_of_set (h M (q, x)))"
proof (cases "q ∈ states M ∧ x ∈ inputs M")
case False
then have "(h M (q, x)) = {}"
unfolding h_simps using fsm_transition_source fsm_transition_input by fastforce
then have "map (λ(y, q'). (q, x, y, q')) (sorted_list_of_set (h M (q, x))) = []"
by auto
have "q ∉ list.set (states_as_list M) ∨ x ∉ list.set iM"
using False unfolding states_as_list_set iM_def inputs_as_list_set by simp
then have "(q,x) ∉ list.set qxPairs"
unfolding qxPairs by auto
then have "∄ y . ((q,x),y) ∈ list.set mapList"
unfolding mapList by auto
then have "hMap (q,x) = None"
unfolding hMap' using map_of_eq_Some_iff[OF ‹distinct (map fst mapList)›]
by (meson option.exhaust)
then show ?thesis
using ‹map (λ(y, q'). (q, x, y, q')) (sorted_list_of_set (h M (q, x))) = []›
unfolding hM_def by auto
next
case True
then have "q ∈ list.set (states_as_list M) ∧ x ∈ list.set iM"
unfolding states_as_list_set iM_def inputs_as_list_set by simp
then have "(q,x) ∈ list.set qxPairs"
unfolding qxPairs by auto
then have "((q,x),map (λ(y, q'). (q, x, y, q')) (sorted_list_of_set (h M (q, x)))) ∈ list.set mapList"
unfolding mapList by auto
then have "hMap (q,x) = Some (map (λ(y, q'). (q, x, y, q')) (sorted_list_of_set (h M (q, x))))"
unfolding hMap' using map_of_eq_Some_iff[OF ‹distinct (map fst mapList)›]
by (meson option.exhaust)
then show ?thesis
unfolding hM_def by auto
qed
qed
then have hM_alt_def: "hM = (λ q x . map (λ(y, q'). (q, x, y, q')) (sorted_list_of_set (h M (q, x))))"
by auto
show "(p,q') ∈ list.set (𝒳' q) ⟷ path M q p ∧ target q p = q' ∧ length p ≤ m-n+1"
unfolding 𝒳' hM_alt_def iM_def
paths_up_to_length_with_targets_set[OF reachable_state_is_state[OF ‹q ∈ reachable_states M›]]
by blast
qed
show "⋀ α β . (α,β) ∈ (V ` reachable_states M) × (V ` reachable_states M)
∪ (V ` reachable_states M) × { (V q) @ τ | q τ . q ∈ reachable_states M ∧ τ ∈ {io@[(x,y)] | io x y . io ∈ LS M q ∧ length io ≤ m-size_r M ∧ x ∈ inputs M ∧ y ∈ outputs M}}
∪ (⋃ q ∈ reachable_states M . ⋃ τ ∈ {io@[(x,y)] | io x y . io ∈ LS M q ∧ length io ≤ m-size_r M ∧ x ∈ inputs M ∧ y ∈ outputs M} . { (V q) @ τ' | τ' . τ' ∈ list.set (prefixes τ)} × {(V q)@τ}) ⟹
α ∈ L M ⟹ β ∈ L M ⟹ after_initial M α ≠ after_initial M β ⟹
((α,after_initial M α),(β,after_initial M β)) ∈ list.set (get_pairs_H V M m)"
using pairs_to_distinguish_containment[OF assms(1,2) * **]
unfolding res pairs_def 𝒳'[symmetric] n_def[symmetric]
by presburger
show "⋀ α q' β q'' . ((α,q'),(β,q'')) ∈ list.set (get_pairs_H V M m) ⟹ α ∈ L M ∧ β ∈ L M ∧ after_initial M α ≠ after_initial M β ∧ q' = after_initial M α ∧ q'' = after_initial M β"
using pairs_to_distinguish_elems(3,4,5,6,7)[OF assms(1,2) * **]
unfolding res pairs_def 𝒳'[symmetric] n_def[symmetric]
by blast
qed
subsection ‹Functions of the SPYH-Method›
subsubsection ‹Heuristic Functions for Selecting Traces to Extend›
fun estimate_growth :: "('a::linorder,'b::linorder,'c::linorder) fsm ⇒ ('a ⇒ 'a ⇒ ('b × 'c) list) ⇒ 'a ⇒ 'a ⇒ 'b ⇒ 'c ⇒ nat ⇒ nat" where
"estimate_growth M dist_fun q1 q2 x y errorValue= (case h_obs M q1 x y of
None ⇒ (case h_obs M q1 x y of
None ⇒ errorValue |
Some q2' ⇒ 1) |
Some q1' ⇒ (case h_obs M q2 x y of
None ⇒ 1 |
Some q2' ⇒ if q1' = q2' ∨ {q1',q2'} = {q1,q2}
then errorValue
else 1 + 2 * (length (dist_fun q1 q2))))"
lemma estimate_growth_result :
assumes "observable M"
and "minimal M"
and "q1 ∈ states M"
and "q2 ∈ states M"
and "estimate_growth M dist_fun q1 q2 x y errorValue < errorValue"
shows "∃ γ . distinguishes M q1 q2 ([(x,y)]@γ)"
proof (cases "h_obs M q1 x y")
case None
show ?thesis proof (cases "h_obs M q2 x y")
case None
then show ?thesis
using ‹h_obs M q1 x y = None› assms(5)
by auto
next
case (Some a)
then have "distinguishes M q1 q2 [(x,y)]"
using h_obs_distinguishes[OF assms(1) _ None] distinguishes_sym
by metis
then show ?thesis
by auto
qed
next
case (Some q1')
show ?thesis proof (cases "h_obs M q2 x y")
case None
then have "distinguishes M q1 q2 [(x,y)]"
using h_obs_distinguishes[OF assms(1) Some]
by metis
then show ?thesis
by auto
next
case (Some q2')
then have "q1' ≠ q2'"
using ‹h_obs M q1 x y = Some q1'› assms(5)
by auto
then obtain γ where "distinguishes M q1' q2' γ"
using h_obs_state[OF ‹h_obs M q1 x y = Some q1'›]
using h_obs_state[OF Some]
using ‹minimal M› unfolding minimal.simps distinguishes_def
by blast
then have "distinguishes M q1 q2 ([(x,y)]@γ)"
using h_obs_language_iff[OF assms(1), of x y γ]
using ‹h_obs M q1 x y = Some q1'› Some
unfolding distinguishes_def
by force
then show ?thesis
by blast
qed
qed
fun shortest_list_or_default :: "'a list list ⇒ 'a list ⇒ 'a list" where
"shortest_list_or_default xs x = foldl (λ a b . if length a < length b then a else b) x xs"
lemma shortest_list_or_default_elem :
"shortest_list_or_default xs x ∈ Set.insert x (list.set xs)"
by (induction xs rule: rev_induct; auto)
fun shortest_list :: "'a list list ⇒ 'a list" where
"shortest_list [] = undefined" |
"shortest_list (x#xs) = shortest_list_or_default xs x"
lemma shortest_list_elem :
assumes "xs ≠ []"
shows "shortest_list xs ∈ list.set xs"
using assms shortest_list_or_default_elem
by (metis list.simps(15) shortest_list.elims)
fun shortest_list_in_tree_or_default :: "'a list list ⇒ 'a prefix_tree ⇒ 'a list ⇒ 'a list" where
"shortest_list_in_tree_or_default xs T x = foldl (λ a b . if isin T a ∧ length a < length b then a else b) x xs"
lemma shortest_list_in_tree_or_default_elem :
"shortest_list_in_tree_or_default xs T x ∈ Set.insert x (list.set xs)"
by (induction xs rule: rev_induct; auto)
fun has_leaf :: "('b×'c) prefix_tree ⇒ 'd ⇒ ('d ⇒ ('b×'c) list ⇒ ('b×'c) list list) ⇒ ('b×'c) list ⇒ bool" where
"has_leaf T G cg_lookup α =
(find (λ β . is_maximal_in T β) (α # cg_lookup G α) ≠ None)"
fun has_extension :: "('b×'c) prefix_tree ⇒ 'd ⇒ ('d ⇒ ('b×'c) list ⇒ ('b×'c) list list) ⇒ ('b×'c) list ⇒ 'b ⇒ 'c ⇒ bool" where
"has_extension T G cg_lookup α x y =
(find (λ β . isin T (β@[(x,y)])) (α # cg_lookup G α) ≠ None)"
fun get_extension :: "('b×'c) prefix_tree ⇒ 'd ⇒ ('d ⇒ ('b×'c) list ⇒ ('b×'c) list list) ⇒ ('b×'c) list ⇒ 'b ⇒ 'c ⇒ ('b×'c) list option" where
"get_extension T G cg_lookup α x y =
(find (λ β . isin T (β@[(x,y)])) (α # cg_lookup G α))"
fun get_prefix_of_separating_sequence :: "('a::linorder,'b::linorder,'c::linorder) fsm ⇒ ('b×'c) prefix_tree ⇒ 'd ⇒ ('d ⇒ ('b×'c) list ⇒ ('b×'c) list list) ⇒ ('a ⇒ 'a ⇒ ('b×'c) list) ⇒ ('b×'c) list ⇒ ('b×'c) list ⇒ nat ⇒ (nat × ('b×'c) list)" where
"get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u v 0 = (1,[])" |
"get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u v (Suc k)= (let
u' = shortest_list_or_default (cg_lookup G u) u;
v' = shortest_list_or_default (cg_lookup G v) v;
su = after_initial M u;
sv = after_initial M v;
bestPrefix0 = get_distinguishing_trace su sv;
minEst0 = length bestPrefix0 + (if (has_leaf T G cg_lookup u') then 0 else length u') + (if (has_leaf T G cg_lookup v') then 0 else length v');
errorValue = Suc minEst0;
XY = List.product (inputs_as_list M) (outputs_as_list M);
tryIO = (λ (minEst,bestPrefix) (x,y) .
if minEst = 0
then (minEst,bestPrefix)
else (case get_extension T G cg_lookup u' x y of
Some u'' ⇒ (case get_extension T G cg_lookup v' x y of
Some v'' ⇒ if (h_obs M su x y = None) ≠ (h_obs M sv x y = None)
then (0,[])
else if h_obs M su x y = h_obs M sv x y
then (minEst,bestPrefix)
else (let (e,w) = get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace (u''@[(x,y)]) (v''@[(x,y)]) k
in if e = 0
then (0,[])
else if e ≤ minEst
then (e,(x,y)#w)
else (minEst,bestPrefix)) |
None ⇒ (let e = estimate_growth M get_distinguishing_trace su sv x y errorValue;
e' = if e ≠ 1
then if has_leaf T G cg_lookup u''
then e + 1
else if ¬(has_leaf T G cg_lookup (u''@[(x,y)]))
then e + length u' + 1
else e
else e;
e'' = e' + (if ¬(has_leaf T G cg_lookup v') then length v' else 0)
in if e'' ≤ minEst
then (e'',[(x,y)])
else (minEst,bestPrefix))) |
None ⇒ (case get_extension T G cg_lookup v' x y of
Some v'' ⇒ (let e = estimate_growth M get_distinguishing_trace su sv x y errorValue;
e' = if e ≠ 1
then if has_leaf T G cg_lookup v''
then e + 1
else if ¬(has_leaf T G cg_lookup (v''@[(x,y)]))
then e + length v' + 1
else e
else e;
e'' = e' + (if ¬(has_leaf T G cg_lookup u') then length u' else 0)
in if e'' ≤ minEst
then (e'',[(x,y)])
else (minEst,bestPrefix)) |
None ⇒ (minEst,bestPrefix))))
in if ¬ isin T u' ∨ ¬ isin T v'
then (errorValue,[])
else foldl tryIO (minEst0,[]) XY)"
lemma estimate_growth_Suc :
assumes "errorValue > 0"
shows "estimate_growth M get_distinguishing_trace q1 q2 x y errorValue > 0"
using assms unfolding estimate_growth.simps
by (cases "FSM.h_obs M q1 x y"; cases "FSM.h_obs M q2 x y"; fastforce)
lemma get_extension_result:
assumes "u ∈ L M1" and "u ∈ L M2"
and "convergence_graph_lookup_invar M1 M2 cg_lookup G"
and "get_extension T G cg_lookup u x y = Some u'"
shows "converge M1 u u'" and "u' ∈ L M2 ⟹ converge M2 u u'" and "u'@[(x,y)] ∈ set T"
proof -
have "find (λ β . isin T (β@[(x,y)])) (u # cg_lookup G u) = Some u'"
using assms(4)
by auto
then have "isin T (u'@[(x,y)])"
using find_condition by metis
then show "u'@[(x,y)] ∈ set T"
by auto
have "u' ∈ Set.insert u (list.set (cg_lookup G u))"
using ‹find (λ β . isin T (β@[(x,y)])) (u # cg_lookup G u) = Some u'›
by (metis find_set list.simps(15))
then show "converge M1 u u'" and "u' ∈ L M2 ⟹ converge M2 u u'"
using assms(1,2,3)
by (metis converge.elims(3) convergence_graph_lookup_invar_def insert_iff)+
qed
lemma get_prefix_of_separating_sequence_result :
fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
assumes "observable M1"
and "observable M2"
and "minimal M1"
and "u ∈ L M1" and "u ∈ L M2"
and "v ∈ L M1" and "v ∈ L M2"
and "after_initial M1 u ≠ after_initial M1 v"
and "⋀ α β q1 q2 . q1 ∈ states M1 ⟹ q2 ∈ states M1 ⟹ q1 ≠ q2 ⟹ distinguishes M1 q1 q2 (get_distinguishing_trace q1 q2)"
and "convergence_graph_lookup_invar M1 M2 cg_lookup G"
and "L M1 ∩ set T = L M2 ∩ set T"
shows "fst (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u v k) = 0 ⟹ ¬ converge M2 u v"
and "fst (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u v k) ≠ 0 ⟹ ∃ γ . distinguishes M1 (after_initial M1 u) (after_initial M1 v) ((snd (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u v k))@γ)"
proof -
have "(fst (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u v k) = 0 ⟶ ¬ converge M2 u v)
∧ (fst (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u v k) ≠ 0 ⟶ (∃ γ . distinguishes M1 (after_initial M1 u) (after_initial M1 v) ((snd (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u v k))@γ)))"
using assms(4,5,6,7,8)
proof (induction k arbitrary: u v)
case 0
then have "∃ γ . distinguishes M1 (after_initial M1 u) (after_initial M1 v) γ"
using ‹minimal M1› unfolding minimal.simps
by (meson after_is_state assms(1) assms(9))
then show ?case
unfolding get_prefix_of_separating_sequence.simps fst_conv snd_conv
by auto
next
case (Suc k)
define u' where u': "u' = shortest_list_or_default (cg_lookup G u) u"
define v' where v': "v' = shortest_list_or_default (cg_lookup G v) v"
define su where su: "su = after_initial M1 u"
define sv where sv: "sv = after_initial M1 v"
define bestPrefix0 where bestPrefix0: "bestPrefix0 = get_distinguishing_trace su sv"
define minEst0 where minEst0: "minEst0 = length bestPrefix0 + (if (has_leaf T G cg_lookup u') then 0 else length u') + (if (has_leaf T G cg_lookup v') then 0 else length v')"
define errorValue where errorValue: "errorValue = Suc minEst0"
define XY where XY: "XY = List.product (inputs_as_list M1) (outputs_as_list M1)"
define tryIO where tryIO: "tryIO = (λ (minEst,bestPrefix) (x,y) .
if minEst = 0
then (minEst,bestPrefix)
else (case get_extension T G cg_lookup u' x y of
Some u'' ⇒ (case get_extension T G cg_lookup v' x y of
Some v'' ⇒ if (h_obs M1 su x y = None) ≠ (h_obs M1 sv x y = None)
then (0,[])
else if h_obs M1 su x y = h_obs M1 sv x y
then (minEst,bestPrefix)
else (let (e,w) = get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace (u''@[(x,y)]) (v''@[(x,y)]) k
in if e = 0
then (0,[])
else if e ≤ minEst
then (e,(x,y)#w)
else (minEst,bestPrefix)) |
None ⇒ (let e = estimate_growth M1 get_distinguishing_trace su sv x y errorValue;
e' = if e ≠ 1
then if has_leaf T G cg_lookup u''
then e + 1
else if ¬(has_leaf T G cg_lookup (u''@[(x,y)]))
then e + length u' + 1
else e
else e;
e'' = e' + (if ¬(has_leaf T G cg_lookup v') then length v' else 0)
in if e'' ≤ minEst
then (e'',[(x,y)])
else (minEst,bestPrefix))) |
None ⇒ (case get_extension T G cg_lookup v' x y of
Some v'' ⇒ (let e = estimate_growth M1 get_distinguishing_trace su sv x y errorValue;
e' = if e ≠ 1
then if has_leaf T G cg_lookup v''
then e + 1
else if ¬(has_leaf T G cg_lookup (v''@[(x,y)]))
then e + length v' + 1
else e
else e;
e'' = e' + (if ¬(has_leaf T G cg_lookup u') then length u' else 0)
in if e'' ≤ minEst
then (e'',[(x,y)])
else (minEst,bestPrefix)) |
None ⇒ (minEst,bestPrefix))))"
have res': "(get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u v (Suc k)) =
(if ¬ isin T u' ∨ ¬ isin T v' then (errorValue,[]) else foldl tryIO (minEst0,[]) XY)"
unfolding tryIO XY errorValue minEst0 bestPrefix0 sv su v' u'
unfolding get_prefix_of_separating_sequence.simps Let_def
by force
show ?case proof (cases "¬ isin T u' ∨ ¬ isin T v'")
case True
then have *:"(get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u v (Suc k)) = (errorValue,[])"
using res' by auto
show ?thesis
unfolding * fst_conv snd_conv errorValue
by (metis Suc.prems(1,3,5) Zero_not_Suc after_is_state append_Nil assms(1) assms(9))
next
case False
then have res: "(get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u v (Suc k)) = foldl tryIO (minEst0,[]) XY"
using res' by auto
have "converge M1 u u'" and "converge M2 u u'"
unfolding u'
using shortest_list_or_default_elem[of "cg_lookup G u" u] assms(10) Suc.prems(1,2,3)
by (metis converge.elims(3) convergence_graph_lookup_invar_def insertE)+
have "converge M1 v v'" and "converge M2 v v'"
unfolding v'
using shortest_list_or_default_elem[of "cg_lookup G v" v] assms(10) Suc.prems
by (metis converge.elims(3) convergence_graph_lookup_invar_def insertE)+
have "su ∈ states M1"
unfolding su
using after_is_state[OF assms(1) Suc.prems(1)] .
have "sv ∈ states M1"
unfolding sv
using after_is_state[OF assms(1) Suc.prems(3)] .
define P where P: "P = (λ (ew :: (nat × ('b × 'c) list)) .
(fst ew = 0 ⟶ ¬ converge M2 u v)
∧ (fst ew ≠ 0 ⟶ (∃ γ . distinguishes M1 (after_initial M1 u) (after_initial M1 v) ((snd ew)@γ))))"
have "P (minEst0,[])"
proof -
have "distinguishes M1 (after_initial M1 u) (after_initial M1 v) bestPrefix0"
using assms(9)[of su sv]
using ‹su ∈ states M1› ‹sv ∈ states M1›
using Suc.prems(5)
unfolding bestPrefix0 su sv
by blast
moreover have "minEst0 ≠ 0"
unfolding minEst0
using calculation distinguishes_not_Nil[OF _ after_is_state[OF assms(1) Suc.prems(1)] after_is_state[OF assms(1) Suc.prems(3)]]
by auto
ultimately show ?thesis
unfolding P fst_conv snd_conv
by (metis append.left_neutral)
qed
have "errorValue > 0"
unfolding errorValue by auto
have "⋀ x y e w . e < errorValue ⟹ P (e,w) ⟹ P (tryIO (e,w) (x,y)) ∧ fst (tryIO (e,w) (x,y)) ≤ e"
proof -
fix x y e w
assume "e < errorValue" and "P (e,w)"
have *:"⋀ x y a b f . (case (x, y) of (x, y) ⇒ (λ(a, b). f x y a b)) (a,b) = f x y a b"
by auto
show "P (tryIO (e,w) (x,y)) ∧ fst (tryIO (e,w) (x,y)) ≤ e"
proof (cases "e = 0")
case True
then have "tryIO (e,w) (x,y) = (e,w)"
unfolding P tryIO fst_conv snd_conv case_prod_conv
by auto
then show ?thesis
using ‹P (e,w)›
by auto
next
case False
show ?thesis
proof (cases "get_extension T G cg_lookup u' x y")
case None
show ?thesis
proof (cases "get_extension T G cg_lookup v' x y")
case None
then have "tryIO (e,w) (x,y) = (e,w)"
using ‹get_extension T G cg_lookup u' x y = None›
unfolding tryIO by auto
then show ?thesis
using ‹P (e,w)›
by auto
next
case (Some v'')
define c where c: "c = estimate_growth M1 get_distinguishing_trace su sv x y errorValue"
define c' where c': "c' = (if c ≠ 1 then if has_leaf T G cg_lookup v'' then c + 1 else if ¬(has_leaf T G cg_lookup (v''@[(x,y)])) then c + length v' + 1 else c else c)"
define c'' where c'': "c'' = c' + (if ¬(has_leaf T G cg_lookup u') then length u' else 0)"
have "tryIO (e,w) (x,y) = (if c'' ≤ e then (c'',[(x,y)]) else (e,w))"
unfolding c c' c'' tryIO Let_def
using None Some False
by auto
show ?thesis proof (cases "c'' ≤ e")
case True
then have "c'' < errorValue"
using ‹e < errorValue› by auto
then have "c' < errorValue"
unfolding c'' by auto
then have "estimate_growth M1 get_distinguishing_trace su sv x y errorValue < errorValue"
unfolding c' c
using add_lessD1 by presburger
have "c > 0"
using estimate_growth_Suc[OF ‹errorValue > 0›] unfolding c
by blast
then have "c'' > 0"
unfolding c' c''
using add_gr_0 by presburger
then have "c'' ≠ 0"
by auto
then have "P (c'',[(x,y)])"
using True estimate_growth_result[OF assms(1,3) ‹su ∈ states M1› ‹sv ∈ states M1› ‹estimate_growth M1 get_distinguishing_trace su sv x y errorValue < errorValue›]
unfolding P fst_conv su sv snd_conv
by blast
then show ?thesis
using ‹tryIO (e,w) (x,y) = (if c'' ≤ e then (c'',[(x,y)]) else (e,w))› True
by auto
next
case False
then show ?thesis
using ‹tryIO (e,w) (x,y) = (if c'' ≤ e then (c'',[(x,y)]) else (e,w))› ‹P (e,w)›
by auto
qed
qed
next
case (Some u'')
show ?thesis proof (cases "get_extension T G cg_lookup v' x y")
case None
define c where c: "c = estimate_growth M1 get_distinguishing_trace su sv x y errorValue"
define c' where c': "c' = (if c ≠ 1 then if has_leaf T G cg_lookup u'' then c + 1 else if ¬(has_leaf T G cg_lookup (u''@[(x,y)])) then c + length u' + 1 else c else c)"
define c'' where c'': "c'' = c' + (if ¬(has_leaf T G cg_lookup v') then length v' else 0)"
have "tryIO (e,w) (x,y) = (if c'' ≤ e then (c'',[(x,y)]) else (e,w))"
unfolding c c' c'' tryIO Let_def
using None Some False
by auto
show ?thesis proof (cases "c'' ≤ e")
case True
then have "c'' < errorValue"
using ‹e < errorValue› by auto
then have "c' < errorValue"
unfolding c'' by auto
then have "estimate_growth M1 get_distinguishing_trace su sv x y errorValue < errorValue"
unfolding c' c
using add_lessD1 by presburger
have "c > 0"
using estimate_growth_Suc[OF ‹errorValue > 0›] unfolding c
by blast
then have "c'' > 0"
unfolding c' c''
using add_gr_0 by presburger
then have "c'' ≠ 0"
by auto
then have "P (c'',[(x,y)])"
using True estimate_growth_result[OF assms(1,3) ‹su ∈ states M1› ‹sv ∈ states M1› ‹estimate_growth M1 get_distinguishing_trace su sv x y errorValue < errorValue›]
unfolding P fst_conv su sv snd_conv
by blast
then show ?thesis
using ‹tryIO (e,w) (x,y) = (if c'' ≤ e then (c'',[(x,y)]) else (e,w))› True
by auto
next
case False
then show ?thesis
using ‹tryIO (e,w) (x,y) = (if c'' ≤ e then (c'',[(x,y)]) else (e,w))› ‹P (e,w)›
by auto
qed
next
case (Some v'')
have "u' ∈ L M1"
using ‹converge M1 u u'› converge.simps by blast
have "v' ∈ L M1"
using ‹converge M1 v v'› converge.simps by blast
have "u' ∈ L M2"
using ‹converge M2 u u'› converge.simps by blast
have "v' ∈ L M2"
using ‹converge M2 v v'› converge.simps by blast
have "converge M1 u' u''" and "u'' @ [(x, y)] ∈ set T"
using get_extension_result(1,3)[OF ‹u' ∈ L M1› ‹u' ∈ L M2› assms(10) ‹get_extension T G cg_lookup u' x y = Some u''›]
by blast+
then have "converge M1 u u''"
using ‹converge M1 u u'› by auto
then have "u'' ∈ set T ∩ L M1"
using set_prefix[OF ‹u'' @ [(x, y)] ∈ set T›] by auto
have "converge M1 v' v''" and "v'' @ [(x, y)] ∈ set T"
using get_extension_result[OF ‹v' ∈ L M1› ‹v' ∈ L M2› assms(10) ‹get_extension T G cg_lookup v' x y = Some v''›]
by blast+
then have "converge M1 v v''"
using ‹converge M1 v v'› by auto
then have "v'' ∈ set T ∩ L M1"
using set_prefix[OF ‹v'' @ [(x, y)] ∈ set T›] by auto
show ?thesis proof (cases "(h_obs M1 su x y = None) ≠ (h_obs M1 sv x y = None)")
case True
then have "tryIO (e,w) (x,y) = (0,[])"
using Some ‹get_extension T G cg_lookup u' x y = Some u''› False
unfolding tryIO Let_def by auto
have "¬ converge M2 u v"
proof -
note ‹L M1 ∩ set T = L M2 ∩ set T›
then have "u' ∈ L M2" and "v' ∈ L M2"
using False ‹u' ∈ L M1› ‹v' ∈ L M1› ‹¬ (¬ isin T u' ∨ ¬ isin T v')›
by auto
have "u'' ∈ L M2"
using ‹L M1 ∩ set T = L M2 ∩ set T› ‹u'' ∈ set T ∩ L M1›
by blast
then have "converge M2 u' u''"
using get_extension_result(2)[OF ‹u' ∈ L M1› ‹u' ∈ L M2› assms(10) ‹get_extension T G cg_lookup u' x y = Some u''›]
by blast
moreover note ‹converge M2 u u'›
ultimately have "converge M2 u u''"
by auto
have "v'' ∈ L M2"
using ‹L M1 ∩ set T = L M2 ∩ set T› ‹v'' ∈ set T ∩ L M1›
by blast
then have "converge M2 v' v''"
using get_extension_result(2)[OF ‹v' ∈ L M1› ‹v' ∈ L M2› assms(10) ‹get_extension T G cg_lookup v' x y = Some v''›]
by blast
moreover note ‹converge M2 v v'›
ultimately have "converge M2 v v''"
by auto
have "distinguishes M1 su sv ([(x,y)])"
using h_obs_distinguishes[OF assms(1), of su x y _ sv]
using distinguishes_sym[OF h_obs_distinguishes[OF assms(1), of sv x y _ su]]
using True
by (cases "h_obs M1 su x y"; cases "h_obs M1 sv x y"; metis)
then have "distinguishes M1 (after_initial M1 u) (after_initial M1 v) ([(x,y)])"
unfolding su sv by auto
show "¬ converge M2 u v"
using distinguish_converge_diverge[OF assms(1-3) _ _ ‹converge M1 u u''› ‹converge M1 v v''› ‹converge M2 u u''› ‹converge M2 v v''› ‹distinguishes M1 (after_initial M1 u) (after_initial M1 v) ([(x,y)])› ‹u'' @ [(x, y)] ∈ set T› ‹v'' @ [(x, y)] ∈ set T› ‹L M1 ∩ set T = L M2 ∩ set T›]
‹u'' ∈ set T ∩ L M1› ‹v'' ∈ set T ∩ L M1›
by blast
qed
then show ?thesis
unfolding P ‹tryIO (e,w) (x,y) = (0,[])› fst_conv snd_conv su sv
by blast
next
case False
show ?thesis proof (cases "h_obs M1 su x y = h_obs M1 sv x y")
case True
then have "tryIO (e,w) (x,y) = (e,w)"
using ‹get_extension T G cg_lookup u' x y = Some u''› Some
unfolding tryIO by auto
then show ?thesis
using ‹P (e,w)›
by auto
next
case False
then have "h_obs M1 su x y ≠ None" and "h_obs M1 sv x y ≠ None"
using ‹¬ (h_obs M1 su x y = None) ≠ (h_obs M1 sv x y = None)›
by metis+
have "u''@[(x,y)] ∈ L M1"
by (metis ‹converge M1 u u''› ‹h_obs M1 su x y ≠ None› after_language_iff assms(1) converge.elims(2) h_obs_language_single_transition_iff su)
have "v''@[(x,y)] ∈ L M1"
by (metis ‹converge M1 v v''› ‹h_obs M1 sv x y ≠ None› after_language_iff assms(1) converge.elims(2) h_obs_language_single_transition_iff sv)
have "u''@[(x,y)] ∈ L M2"
using ‹u''@[(x,y)] ∈ L M1› ‹u''@[(x,y)] ∈ set T› ‹L M1 ∩ set T = L M2 ∩ set T›
by blast
have "v''@[(x,y)] ∈ L M2"
using ‹v''@[(x,y)] ∈ L M1› ‹v''@[(x,y)] ∈ set T› ‹L M1 ∩ set T = L M2 ∩ set T›
by blast
have "FSM.after M1 (FSM.initial M1) (u'' @ [(x, y)]) ≠ FSM.after M1 (FSM.initial M1) (v'' @ [(x, y)])"
using False ‹converge M1 u u''› ‹converge M1 v v''› unfolding su sv
proof -
assume a1: "h_obs M1 (FSM.after M1 (FSM.initial M1) u) x y ≠ h_obs M1 (FSM.after M1 (FSM.initial M1) v) x y"
have f2: "∀f ps psa. converge (f::('a, 'b, 'c) fsm) ps psa = (ps ∈ L f ∧ psa ∈ L f ∧ LS f (FSM.after f (FSM.initial f) ps) = LS f (FSM.after f (FSM.initial f) psa))"
by (meson converge.simps)
then have f3: "u ∈ L M1 ∧ u'' ∈ L M1 ∧ LS M1 (FSM.after M1 (FSM.initial M1) u) = LS M1 (FSM.after M1 (FSM.initial M1) u'')"
using ‹converge M1 u u''› by presburger
have f4: "∀f ps psa. ¬ minimal (f::('a, 'b, 'c) fsm) ∨ ¬ observable f ∨ ps ∉ L f ∨ psa ∉ L f ∨ converge f ps psa = (FSM.after f (FSM.initial f) ps = FSM.after f (FSM.initial f) psa)"
using convergence_minimal by blast
have f5: "v ∈ L M1 ∧ v'' ∈ L M1 ∧ LS M1 (FSM.after M1 (FSM.initial M1) v) = LS M1 (FSM.after M1 (FSM.initial M1) v'')"
using f2 ‹converge M1 v v''› by blast
then have f6: "FSM.after M1 (FSM.initial M1) v = FSM.after M1 (FSM.initial M1) v''"
using f4 ‹converge M1 v v''› assms(1) assms(3) by blast
have "FSM.after M1 (FSM.initial M1) u = FSM.after M1 (FSM.initial M1) u''"
using f4 f3 ‹converge M1 u u''› assms(1) assms(3) by blast
then show ?thesis
using f6 f5 f3 a1 by (metis (no_types) ‹u'' @ [(x, y)] ∈ L M1› ‹v'' @ [(x, y)] ∈ L M1› after_h_obs after_language_iff after_split assms(1) h_obs_from_LS)
qed
obtain e' w' where "get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace (u''@[(x,y)]) (v''@[(x,y)]) k = (e',w')"
using prod.exhaust by metis
then have "tryIO (e,w) (x,y) = (if e' = 0 then (0,[]) else if e' ≤ e then (e',(x,y)#w') else (e,w))"
using ‹get_extension T G cg_lookup u' x y = Some u''› Some False ‹¬ (h_obs M1 su x y = None) ≠ (h_obs M1 sv x y = None)› ‹e ≠ 0›
unfolding tryIO Let_def by auto
show ?thesis proof (cases "e' = 0")
case True
have "¬ converge M2 u v"
proof -
note ‹L M1 ∩ set T = L M2 ∩ set T›
then have "u' ∈ L M2" and "v' ∈ L M2"
using ‹¬ (¬ isin T u' ∨ ¬ isin T v')› ‹u' ∈ L M1› ‹v' ∈ L M1›
by auto
have "u'' ∈ L M2"
using ‹L M1 ∩ set T = L M2 ∩ set T› ‹u'' ∈ set T ∩ L M1›
by blast
then have "converge M2 u' u''"
using get_extension_result(2)[OF ‹u' ∈ L M1› ‹u' ∈ L M2› assms(10) ‹get_extension T G cg_lookup u' x y = Some u''›]
by blast
moreover note ‹converge M2 u u'›
ultimately have "converge M2 u u''"
by auto
have "v'' ∈ L M2"
using ‹L M1 ∩ set T = L M2 ∩ set T› ‹v'' ∈ set T ∩ L M1›
by blast
then have "converge M2 v' v''"
using get_extension_result(2)[OF ‹v' ∈ L M1› ‹v' ∈ L M2› assms(10) ‹get_extension T G cg_lookup v' x y = Some v''›]
by blast
moreover note ‹converge M2 v v'›
ultimately have "converge M2 v v''"
by auto
have "fst (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace (u'' @ [(x, y)]) (v'' @ [(x, y)]) k) = 0"
using True ‹get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace (u''@[(x,y)]) (v''@[(x,y)]) k = (e',w')›
by auto
then have "¬ converge M2 (u'' @ [(x, y)]) (v'' @ [(x, y)])"
using Suc.IH[OF ‹u''@[(x,y)] ∈ L M1› ‹u''@[(x,y)] ∈ L M2› ‹v''@[(x,y)] ∈ L M1› ‹v''@[(x,y)] ∈ L M2› ‹FSM.after M1 (FSM.initial M1) (u'' @ [(x, y)]) ≠ FSM.after M1 (FSM.initial M1) (v'' @ [(x, y)])›]
using ‹L M1 ∩ Prefix_Tree.set T = L M2 ∩ Prefix_Tree.set T›
by blast
then have "¬ converge M2 u'' v''"
using diverge_prefix[OF assms(2) ‹u''@[(x,y)] ∈ L M2› ‹v''@[(x,y)] ∈ L M2›]
by blast
then show "¬ converge M2 u v"
using ‹converge M2 u u''› ‹converge M2 v v''›
by fastforce
qed
then show ?thesis
unfolding P ‹tryIO (e,w) (x,y) = (if e' = 0 then (0,[]) else if e' ≤ e then (e',(x,y)#w') else (e,w))› True fst_conv snd_conv su sv
by simp
next
case False
show ?thesis proof (cases "e' ≤ e")
case True
then have "fst (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace (u'' @ [(x, y)]) (v'' @ [(x, y)]) k) ≠ 0"
using ‹get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace (u''@[(x,y)]) (v''@[(x,y)]) k = (e',w')› False
by auto
then have "(∃γ. distinguishes M1 (FSM.after M1 (FSM.initial M1) (u'' @ [(x, y)])) (FSM.after M1 (FSM.initial M1) (v'' @ [(x, y)]))
(snd (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace (u'' @ [(x, y)]) (v'' @ [(x, y)]) k) @ γ))"
using Suc.IH[OF ‹u''@[(x,y)] ∈ L M1› ‹u''@[(x,y)] ∈ L M2› ‹v''@[(x,y)] ∈ L M1› ‹v''@[(x,y)] ∈ L M2› ‹FSM.after M1 (FSM.initial M1) (u'' @ [(x, y)]) ≠ FSM.after M1 (FSM.initial M1) (v'' @ [(x, y)])›]
by blast
then obtain γ where "distinguishes M1 (FSM.after M1 (FSM.initial M1) (u'' @ [(x, y)])) (FSM.after M1 (FSM.initial M1) (v'' @ [(x, y)])) (w'@γ)"
unfolding ‹get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace (u''@[(x,y)]) (v''@[(x,y)]) k = (e',w')› snd_conv
by blast
have "distinguishes M1 (after_initial M1 u'') (after_initial M1 v'') ((x,y)#(w'@γ))"
using distinguishes_after_initial_prepend[OF assms(1) language_prefix[OF ‹u''@[(x,y)] ∈ L M1›] language_prefix[OF ‹v''@[(x,y)] ∈ L M1›]]
by (metis Suc.prems(1) Suc.prems(3) ‹converge M1 u u'› ‹converge M1 u' u''› ‹converge M1 v v''› ‹distinguishes M1 (after_initial M1 (u'' @ [(x, y)])) (after_initial M1 (v'' @ [(x, y)])) (w' @ γ)› ‹h_obs M1 su x y ≠ None› ‹h_obs M1 sv x y ≠ None› ‹u' ∈ L M1› ‹u'' @ [(x, y)] ∈ L M1› ‹v'' @ [(x, y)] ∈ L M1› assms(1) assms(3) convergence_minimal language_prefix su sv)
then have "distinguishes M1 (after_initial M1 u) (after_initial M1 v) (((x,y)#w')@γ)"
by (metis Cons_eq_appendI Suc.prems(1) Suc.prems(3) ‹converge M1 u u''› ‹converge M1 v v''› ‹u'' @ [(x, y)] ∈ L M1› ‹v'' @ [(x, y)] ∈ L M1› assms(1) assms(3) convergence_minimal language_prefix)
have "tryIO (e,w) (x,y) = (e',(x,y)#w')"
using ‹tryIO (e,w) (x,y) = (if e' = 0 then (0,[]) else if e' ≤ e then (e',(x,y)#w') else (e,w))› True False
by auto
show ?thesis
unfolding P ‹tryIO (e,w) (x,y) = (e',(x,y)#w')› fst_conv snd_conv
using ‹distinguishes M1 (after_initial M1 u) (after_initial M1 v) (((x,y)#w')@γ)›
False True
by blast
next
case False
then have "tryIO (e,w) (x,y) = (e,w)"
using ‹e' ≠ 0› ‹tryIO (e,w) (x,y) = (if e' = 0 then (0,[]) else if e' ≤ e then (e',(x,y)#w') else (e,w))›
by auto
then show ?thesis
using ‹P (e,w)›
by auto
qed
qed
qed
qed
qed
qed
qed
qed
have "minEst0 < errorValue"
unfolding errorValue by auto
have "P (foldl tryIO (minEst0,[]) XY) ∧ fst (foldl tryIO (minEst0,[]) XY) ≤ minEst0"
proof (induction XY rule: rev_induct)
case Nil
then show ?case
using ‹P (minEst0,[])›
by auto
next
case (snoc a XY)
obtain x y where "a = (x,y)"
using prod.exhaust by metis
moreover obtain e w where "(foldl tryIO (minEst0,[]) XY) = (e,w)"
using prod.exhaust by metis
ultimately have "(foldl tryIO (minEst0, []) (XY@[a])) = tryIO (e,w) (x,y)"
by auto
have "P (e,w)" and "e ≤ minEst0" and "e < errorValue"
using snoc.IH ‹minEst0 < errorValue›
unfolding ‹(foldl tryIO (minEst0,[]) XY) = (e,w)›
by auto
then show ?case
unfolding ‹(foldl tryIO (minEst0, []) (XY@[a])) = tryIO (e,w) (x,y)›
using ‹⋀ x y e w . e < errorValue ⟹ P (e,w) ⟹ P (tryIO (e,w) (x,y)) ∧ fst (tryIO (e,w) (x,y)) ≤ e›
using dual_order.trans by blast
qed
then have "P (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u v (Suc k))"
unfolding res by blast
then show ?thesis
unfolding P by blast
qed
qed
then show "fst (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u v k) = 0 ⟹ ¬ converge M2 u v"
and "fst (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u v k) ≠ 0 ⟹ ∃ γ . distinguishes M1 (after_initial M1 u) (after_initial M1 v) ((snd (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u v k))@γ)"
by blast+
qed
subsubsection ‹Distributing Convergent Traces›
fun append_heuristic_io :: "('b×'c) prefix_tree ⇒ ('b×'c) list ⇒ (('b×'c) list × int) ⇒ ('b×'c) list ⇒ (('b×'c) list × int)" where
"append_heuristic_io T w (uBest,lBest) u' = (let t' = after T u';
w' = maximum_prefix t' w
in if w' = w
then (u',0::int)
else if (is_maximal_in t' w' ∧ (int (length w') > lBest ∨ (int (length w') = lBest ∧ length u' < length uBest)))
then (u', int (length w'))
else (uBest,lBest))"
lemma append_heuristic_io_in :
"fst (append_heuristic_io T w (uBest,lBest) u') ∈ {u',uBest}"
unfolding append_heuristic_io.simps Let_def by auto
fun append_heuristic_input :: "('a::linorder,'b::linorder,'c::linorder) fsm ⇒ ('b×'c) prefix_tree ⇒ ('b×'c) list ⇒ (('b×'c) list × int) ⇒ ('b×'c) list ⇒ (('b×'c) list × int)" where
"append_heuristic_input M T w (uBest,lBest) u' = (let t' = after T u';
ws = maximum_fst_prefixes t' (map fst w) (outputs_as_list M)
in
foldr (λ w' (uBest',lBest'::int) .
if w' = w
then (u',0::int)
else if (int (length w') > lBest' ∨ (int (length w') = lBest' ∧ length u' < length uBest'))
then (u',int (length w'))
else (uBest',lBest'))
ws (uBest,lBest))"
lemma append_heuristic_input_in :
"fst (append_heuristic_input M T w (uBest,lBest) u') ∈ {u',uBest}"
proof -
define ws where ws: "ws = maximum_fst_prefixes (after T u') (map fst w) (outputs_as_list M)"
define f where f: "f = (λ w' (uBest',lBest'::int) .
if w' = w
then (u',0::int)
else if (int (length w') > lBest' ∨ (int (length w') = lBest' ∧ length u' < length uBest'))
then (u',int (length w'))
else (uBest',lBest'))"
have "⋀ w' b' . fst b' ∈ {u',uBest} ⟹ fst (f w' b') ∈ {u',uBest}"
unfolding f by auto
then have "fst (foldr f ws (uBest,lBest)) ∈ {u',uBest}"
by (induction ws; auto)
moreover have "append_heuristic_input M T w (uBest,lBest) u' = foldr f ws (uBest,lBest)"
unfolding append_heuristic_input.simps Let_def ws f by force
ultimately show ?thesis
by simp
qed
fun distribute_extension :: "('a::linorder,'b::linorder,'c::linorder) fsm ⇒ ('b×'c) prefix_tree ⇒ 'd ⇒ ('d ⇒ ('b×'c) list ⇒ ('b×'c) list list) ⇒ ('d ⇒ ('b×'c) list ⇒ 'd) ⇒('b×'c) list ⇒ ('b×'c) list ⇒ bool ⇒ (('b×'c) prefix_tree ⇒ ('b×'c) list ⇒ (('b×'c) list × int) ⇒ ('b×'c) list ⇒ (('b×'c) list × int)) ⇒ (('b×'c) prefix_tree ×'d)" where
"distribute_extension M T G cg_lookup cg_insert u w completeInputTraces append_heuristic = (let
cu = cg_lookup G u;
u0 = shortest_list_in_tree_or_default cu T u;
l0 = -1::int;
u' = fst ((foldl (append_heuristic T w) (u0,l0) (filter (isin T) cu)) :: (('b×'c) list × int));
T' = insert T (u'@w);
G' = cg_insert G (maximal_prefix_in_language M (initial M) (u'@w))
in if completeInputTraces
then let TC = complete_inputs_to_tree M (initial M) (outputs_as_list M) (map fst (u'@w));
T'' = Prefix_Tree.combine T' TC
in (T'',G')
else (T',G'))"
lemma distribute_extension_subset :
"set T ⊆ set (fst (distribute_extension M T G cg_lookup cg_insert u w b heuristic))"
proof -
define u0 where u0: "u0 = shortest_list_in_tree_or_default (cg_lookup G u) T u"
define l0 where l0: "l0 = (-1::int)"
define u' where u': "u' = fst (foldl (heuristic T w) (u0,l0) (filter (isin T) (cg_lookup G u)))"
define T' where T': "T' = insert T (u'@w)"
define G' where G': "G' = cg_insert G (maximal_prefix_in_language M (initial M) (u'@w))"
have "set T ⊆ set T'"
unfolding T' insert_set
by blast
show ?thesis proof (cases b)
case True
then show ?thesis
using ‹set T ⊆ set T'›
unfolding distribute_extension.simps u0 l0 u' T' G' Let_def
using combine_set
by force
next
case False
then have "fst (distribute_extension M T G cg_lookup cg_insert u w b heuristic) = T'"
unfolding distribute_extension.simps u0 l0 u' T' G' Let_def by force
then show ?thesis
using ‹set T ⊆ set T'›
by blast
qed
qed
lemma distribute_extension_finite :
assumes "finite_tree T"
shows "finite_tree (fst (distribute_extension M T G cg_lookup cg_insert u w b heuristic))"
proof -
define u0 where u0: "u0 = shortest_list_in_tree_or_default (cg_lookup G u) T u"
define l0 where l0: "l0 = (-1::int)"
define u' where u': "u' = fst (foldl (heuristic T w) (u0,l0) (filter (isin T) (cg_lookup G u)))"
define T' where T': "T' = insert T (u'@w)"
define G' where G': "G' = cg_insert G (maximal_prefix_in_language M (initial M) (u'@w))"
have "finite_tree T'"
unfolding T'
using insert_finite_tree[OF assms]
by blast
show ?thesis proof (cases b)
case True
then show ?thesis
using ‹finite_tree T'›
unfolding distribute_extension.simps u0 l0 u' T' G' Let_def
by (simp add: combine_finite_tree complete_inputs_to_tree_finite_tree)
next
case False
then have "fst (distribute_extension M T G cg_lookup cg_insert u w b heuristic) = T'"
unfolding distribute_extension.simps u0 l0 u' T' G' Let_def by force
then show ?thesis
using ‹finite_tree T'›
by blast
qed
qed
lemma distribute_extension_adds_sequence :
fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
assumes "observable M1"
and "minimal M1"
and "u ∈ L M1" and "u ∈ L M2"
and "convergence_graph_lookup_invar M1 M2 cg_lookup G"
and "convergence_graph_insert_invar M1 M2 cg_lookup cg_insert"
and "(L M1 ∩ set (fst (distribute_extension M1 T G cg_lookup cg_insert u w b heuristic)) = L M2 ∩ set (fst (distribute_extension M1 T G cg_lookup cg_insert u w b heuristic)))"
and "⋀ u' uBest lBest . fst (heuristic T w (uBest,lBest) u') ∈ {u',uBest}"
shows "∃ u' . converge M1 u u' ∧ u'@w ∈ set (fst (distribute_extension M1 T G cg_lookup cg_insert u w b heuristic)) ∧ converge M2 u u'"
and "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (distribute_extension M1 T G cg_lookup cg_insert u w b heuristic))"
proof -
define u0 where u0: "u0 = shortest_list_in_tree_or_default (cg_lookup G u) T u"
define l0 where l0: "l0 = (-1::int)"
define u' where u': "u' = fst (foldl (heuristic T w) (u0,l0) (filter (isin T) (cg_lookup G u)))"
define T' where T': "T' = insert T (u'@w)"
define G' where G': "G' = cg_insert G (maximal_prefix_in_language M1 (initial M1) (u'@w))"
define TC where TC: "TC = complete_inputs_to_tree M1 (initial M1) (outputs_as_list M1) (map fst (u'@w))"
define T'' where T'': "T'' = Prefix_Tree.combine T' TC"
have "distribute_extension M1 T G cg_lookup cg_insert u w b heuristic = (T',G') ∨
distribute_extension M1 T G cg_lookup cg_insert u w b heuristic = (T'',G')"
unfolding distribute_extension.simps u0 l0 u' T' G' TC T'' Let_def by force
moreover have "set T' ⊆ set T''"
unfolding T'' combine_set by blast
ultimately have "set T' ⊆ set (fst (distribute_extension M1 T G cg_lookup cg_insert u w b heuristic))"
by force
have "⋀ xs . fst (foldl (heuristic T w) (u0,l0) xs) ∈ Set.insert u0 (list.set xs)"
proof -
fix xs
show "fst (foldl (heuristic T w) (u0,l0) xs) ∈ Set.insert u0 (list.set xs)"
proof (induction xs rule: rev_induct)
case Nil
then show ?case
by auto
next
case (snoc x xs)
have "⋀ u' uBest lBest . (fst ((heuristic T w) (uBest,lBest) u')) = u' ∨ (fst ((heuristic T w) (uBest,lBest) u')) = uBest"
using assms(8) by blast
then have "(fst ((heuristic T w) (foldl (heuristic T w) (u0, l0) xs) x)) = x ∨ (fst ((heuristic T w) (foldl (heuristic T w) (u0, l0) xs) x)) = fst (foldl (heuristic T w) (u0, l0) xs)"
by (metis prod.exhaust_sel)
then show ?case
using snoc.IH by auto
qed
qed
then have "u' ∈ Set.insert u0 (list.set (filter (isin T) (cg_lookup G u)))"
unfolding u'
by blast
then have "u' ∈ Set.insert u0 (list.set (cg_lookup G u))"
by auto
moreover have "converge M1 u u0"
unfolding u'
using shortest_list_in_tree_or_default_elem[of "cg_lookup G u" T u]
by (metis assms(1-5) convergence_graph_lookup_invar_def convergence_minimal insert_iff u0)
moreover have "⋀ u' . u' ∈ list.set (cg_lookup G u) ⟹ converge M1 u u'"
using assms(3,4,5)
by (metis convergence_graph_lookup_invar_def)
ultimately have "converge M1 u u'"
by blast
moreover have "u'@w ∈ set (fst (distribute_extension M1 T G cg_lookup cg_insert u w b heuristic))"
using ‹set T' ⊆ set (fst (distribute_extension M1 T G cg_lookup cg_insert u w b heuristic))›
unfolding T' insert_set fst_conv
by blast
moreover have "converge M2 u u'"
by (metis ‹u' ∈ Set.insert u0 (list.set (cg_lookup G u))› assms(3) assms(4) assms(5) converge.elims(3) convergence_graph_lookup_invar_def insertE shortest_list_in_tree_or_default_elem u0)
ultimately show "∃ u' . converge M1 u u' ∧ u'@w ∈ set (fst (distribute_extension M1 T G cg_lookup cg_insert u w b heuristic)) ∧ converge M2 u u'"
by blast
have "(maximal_prefix_in_language M1 (initial M1) (u'@w)) ∈ L M1"
and "(maximal_prefix_in_language M1 (initial M1) (u'@w)) ∈ list.set (prefixes (u'@w))"
using maximal_prefix_in_language_properties[OF assms(1) fsm_initial]
by auto
moreover have "(maximal_prefix_in_language M1 (initial M1) (u'@w)) ∈ set (fst (distribute_extension M1 T G cg_lookup cg_insert u w b heuristic))"
using ‹u'@w ∈ set (fst (distribute_extension M1 T G cg_lookup cg_insert u w b heuristic))› set_prefix
by (metis (no_types, lifting) ‹maximal_prefix_in_language M1 (FSM.initial M1) (u' @ w) ∈ list.set (prefixes (u' @ w))› prefixes_set_ob)
ultimately have "(maximal_prefix_in_language M1 (initial M1) (u'@w)) ∈ L M2"
using assms(7)
by blast
have "convergence_graph_lookup_invar M1 M2 cg_lookup G'"
using assms(5,6) ‹(maximal_prefix_in_language M1 (initial M1) (u'@w)) ∈ L M1› ‹(maximal_prefix_in_language M1 (initial M1) (u'@w)) ∈ L M2›
unfolding G' convergence_graph_insert_invar_def
by blast
show "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (distribute_extension M1 T G cg_lookup cg_insert u w b heuristic))"
using ‹convergence_graph_lookup_invar M1 M2 cg_lookup G'›
unfolding distribute_extension.simps u0 l0 u' T' G' Let_def by force
qed
subsubsection ‹Distinguishing a Trace from Other Traces›
fun spyh_distinguish :: "('a::linorder,'b::linorder,'c::linorder) fsm ⇒ ('b×'c) prefix_tree ⇒ 'd ⇒ ('d ⇒ ('b×'c) list ⇒ ('b×'c) list list) ⇒ ('d ⇒ ('b×'c) list ⇒ 'd) ⇒ ('a ⇒ 'a ⇒ ('b×'c) list) ⇒ ('b×'c) list ⇒ ('b×'c) list list ⇒ nat ⇒ bool ⇒ (('b×'c) prefix_tree ⇒ ('b×'c) list ⇒ (('b×'c) list × int) ⇒ ('b×'c) list ⇒ (('b×'c) list × int)) ⇒ (('b×'c) prefix_tree × 'd)" where
"spyh_distinguish M T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic = (let
dist_helper = (λ (T,G) v . if after_initial M u = after_initial M v
then (T,G)
else (let ew = get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u v k
in if fst ew = 0
then (T,G)
else (let u' = (u@(snd ew));
v' = (v@(snd ew));
w' = if does_distinguish M (after_initial M u) (after_initial M v) (snd ew) then (snd ew) else (snd ew)@(get_distinguishing_trace (after_initial M u') (after_initial M v'));
TG' = distribute_extension M T G cg_lookup cg_insert u w' completeInputTraces append_heuristic
in distribute_extension M (fst TG') (snd TG') cg_lookup cg_insert v w' completeInputTraces append_heuristic)))
in foldl dist_helper (T,G) X)"
lemma spyh_distinguish_subset :
"set T ⊆ set (fst (spyh_distinguish M T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic))"
proof (induction X rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc a X)
have "set (fst (spyh_distinguish M T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic))
⊆ set (fst (spyh_distinguish M T G cg_lookup cg_insert get_distinguishing_trace u (X@[a]) k completeInputTraces append_heuristic))"
proof -
define dh where dh: "dh = (λ (T,G) v . if after_initial M u = after_initial M v
then (T,G)
else (let ew = get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u v k
in if fst ew = 0
then (T,G)
else (let u' = (u@(snd ew));
v' = (v@(snd ew));
w' = if does_distinguish M (after_initial M u) (after_initial M v) (snd ew) then (snd ew) else (snd ew)@(get_distinguishing_trace (after_initial M u') (after_initial M v'));
TG' = distribute_extension M T G cg_lookup cg_insert u w' completeInputTraces append_heuristic
in distribute_extension M (fst TG') (snd TG') cg_lookup cg_insert v w' completeInputTraces append_heuristic)))"
have "spyh_distinguish M T G cg_lookup cg_insert get_distinguishing_trace u (X@[a]) k completeInputTraces append_heuristic
= dh (spyh_distinguish M T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic) a"
unfolding dh spyh_distinguish.simps Let_def
unfolding foldl_append
by auto
moreover have "⋀ T G . set T ⊆ set (fst (dh (T,G) a))"
proof -
fix T G
show "set T ⊆ set (fst (dh (T,G) a))"
proof (cases "after_initial M u = after_initial M a")
case True
then show ?thesis using dh by auto
next
case False
then show ?thesis proof (cases "fst (get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u a k) = 0")
case True
then show ?thesis using False dh by auto
next
case False
define u' where u': "u' = (u@(snd (get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u a k)))"
define v' where v': "v' = (a@(snd (get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u a k)))"
define w where w: "w = get_distinguishing_trace (after_initial M u') (after_initial M v')"
define w' where w': "w' = (if does_distinguish M (after_initial M u) (after_initial M a) (snd (get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u a k)) then (snd (get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u a k)) else (snd (get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u a k))@w)"
define TG' where TG': "TG' = distribute_extension M T G cg_lookup cg_insert u w' completeInputTraces append_heuristic"
have "dh (T,G) a = distribute_extension M (fst (distribute_extension M T G cg_lookup cg_insert u w' completeInputTraces append_heuristic)) (snd (distribute_extension M T G cg_lookup cg_insert u w' completeInputTraces append_heuristic)) cg_lookup cg_insert a w' completeInputTraces append_heuristic"
using False ‹FSM.after M (FSM.initial M) u ≠ FSM.after M (FSM.initial M) a›
unfolding dh u' v' w w' TG' Let_def case_prod_conv by metis
then show ?thesis
using distribute_extension_subset
by (metis (no_types, lifting) subset_trans)
qed
qed
qed
ultimately show ?thesis
by (metis eq_fst_iff)
qed
then show ?case
using snoc.IH by blast
qed
lemma spyh_distinguish_finite :
fixes T :: "('b::linorder×'c::linorder) prefix_tree"
assumes "finite_tree T"
shows "finite_tree (fst (spyh_distinguish M T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic))"
proof (induction X rule: rev_induct)
case Nil
then show ?case using assms by auto
next
case (snoc a X)
define dh where dh: "dh = (λ (T,G) v . if after_initial M u = after_initial M v
then (T,G)
else (let ew = get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u v k
in if fst ew = 0
then (T,G)
else (let u' = (u@(snd ew));
v' = (v@(snd ew));
w' = if does_distinguish M (after_initial M u) (after_initial M v) (snd ew) then (snd ew) else (snd ew)@(get_distinguishing_trace (after_initial M u') (after_initial M v'));
TG' = distribute_extension M T G cg_lookup cg_insert u w' completeInputTraces append_heuristic
in distribute_extension M (fst TG') (snd TG') cg_lookup cg_insert v w' completeInputTraces append_heuristic)))"
have *: "spyh_distinguish M T G cg_lookup cg_insert get_distinguishing_trace u (X@[a]) k completeInputTraces append_heuristic
= dh (spyh_distinguish M T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic) a"
unfolding dh spyh_distinguish.simps Let_def
unfolding foldl_append
by auto
have **:"⋀ T G . finite_tree T ⟹ finite_tree (fst (dh (T,G) a))"
proof -
fix T :: "('b×'c) prefix_tree"
fix G
assume "finite_tree T"
show "finite_tree (fst (dh (T,G) a))"
proof (cases "after_initial M u = after_initial M a")
case True
then show ?thesis using dh ‹finite_tree T› by auto
next
case False
then show ?thesis proof (cases "fst (get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u a k) = 0")
case True
then show ?thesis using False dh ‹finite_tree T› by auto
next
case False
define u' where u': "u' = (u@(snd (get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u a k)))"
define v' where v': "v' = (a@(snd (get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u a k)))"
define w where w: "w = get_distinguishing_trace (after_initial M u') (after_initial M v')"
define w' where w': "w' = (if does_distinguish M (after_initial M u) (after_initial M a) (snd (get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u a k)) then (snd (get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u a k)) else (snd (get_prefix_of_separating_sequence M T G cg_lookup get_distinguishing_trace u a k))@w)"
define TG' where TG': "TG' = distribute_extension M T G cg_lookup cg_insert u w'"
have *:"dh (T,G) a = distribute_extension M (fst (distribute_extension M T G cg_lookup cg_insert u w' completeInputTraces append_heuristic)) (snd (distribute_extension M T G cg_lookup cg_insert u w' completeInputTraces append_heuristic)) cg_lookup cg_insert a w' completeInputTraces append_heuristic"
using False ‹FSM.after M (FSM.initial M) u ≠ FSM.after M (FSM.initial M) a›
unfolding dh u' v' w w' TG' Let_def case_prod_conv by metis
show ?thesis
unfolding *
using distribute_extension_finite[OF distribute_extension_finite[OF ‹finite_tree T›]]
by metis
qed
qed
qed
show ?case
unfolding *
using **[OF snoc]
by (metis eq_fst_iff)
qed
lemma spyh_distinguish_establishes_divergence :
fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
assumes "observable M1"
and "observable M2"
and "minimal M1"
and "minimal M2"
and "u ∈ L M1" and "u ∈ L M2"
and "⋀ α β q1 q2 . q1 ∈ states M1 ⟹ q2 ∈ states M1 ⟹ q1 ≠ q2 ⟹ distinguishes M1 q1 q2 (get_distinguishing_trace q1 q2)"
and "convergence_graph_lookup_invar M1 M2 cg_lookup G"
and "convergence_graph_insert_invar M1 M2 cg_lookup cg_insert"
and "list.set X ⊆ L M1"
and "list.set X ⊆ L M2"
and "L M1 ∩ set (fst (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic)) = L M2 ∩ set (fst (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic))"
and "⋀ T w u' uBest lBest . fst (append_heuristic T w (uBest,lBest) u') ∈ {u',uBest}"
shows "∀ v . v ∈ list.set X ⟶ ¬ converge M1 u v ⟶ ¬ converge M2 u v"
(is "?P1 X")
and "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic))"
(is "?P2 X")
proof -
have "?P1 X ∧ ?P2 X"
using assms(10,11,12)
proof (induction X rule: rev_induct)
case Nil
have *: "spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u [] k completeInputTraces append_heuristic = (T,G)"
by auto
show ?case
using Nil assms(8)
unfolding * fst_conv snd_conv by auto
next
case (snoc a X)
define dh where dh: "dh = (λ (T,G) v . if after_initial M1 u = after_initial M1 v
then (T,G)
else (let ew = get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u v k
in if fst ew = 0
then (T,G)
else (let u' = (u@(snd ew));
v' = (v@(snd ew));
w' = (if does_distinguish M1 (after_initial M1 u) (after_initial M1 v) (snd ew) then (snd ew) else (snd ew)@(get_distinguishing_trace (after_initial M1 u') (after_initial M1 v')));
TG' = distribute_extension M1 T G cg_lookup cg_insert u w' completeInputTraces append_heuristic
in distribute_extension M1 (fst TG') (snd TG') cg_lookup cg_insert v w' completeInputTraces append_heuristic)))"
have "spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u (X@[a]) k completeInputTraces append_heuristic
= dh (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic) a"
unfolding dh spyh_distinguish.simps Let_def
unfolding foldl_append
by auto
have "⋀ T G . set T ⊆ set (fst (dh (T,G) a))"
proof -
fix T G
show "set T ⊆ set (fst (dh (T,G) a))"
proof (cases "after_initial M1 u = after_initial M1 a")
case True
then show ?thesis using dh by auto
next
case False
then show ?thesis proof (cases "fst (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u a k) = 0")
case True
then show ?thesis using False dh by auto
next
case False
define u' where u': "u' = (u@(snd (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u a k)))"
define v' where v': "v' = (a@(snd (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u a k)))"
define w where w: "w = get_distinguishing_trace (after_initial M1 u') (after_initial M1 v')"
define w' where w': "w' = (if does_distinguish M1 (after_initial M1 u) (after_initial M1 a) (snd (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u a k)) then (snd (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u a k)) else (snd (get_prefix_of_separating_sequence M1 T G cg_lookup get_distinguishing_trace u a k))@w)"
define TG' where TG': "TG' = distribute_extension M1 T G cg_lookup cg_insert u w'"
have "dh (T,G) a = distribute_extension M1 (fst (distribute_extension M1 T G cg_lookup cg_insert u w' completeInputTraces append_heuristic)) (snd (distribute_extension M1 T G cg_lookup cg_insert u w' completeInputTraces append_heuristic)) cg_lookup cg_insert a w' completeInputTraces append_heuristic"
using False ‹FSM.after M1 (FSM.initial M1) u ≠ FSM.after M1 (FSM.initial M1) a›
unfolding dh u' v' w w' TG' Let_def case_prod_conv by metis
then show ?thesis
using distribute_extension_subset
by (metis (no_types, lifting) subset_trans)
qed
qed
qed
then have "set (fst (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic)) ⊆ set (fst (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u (X@[a]) k completeInputTraces append_heuristic))"
unfolding ‹spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u (X@[a]) k completeInputTraces append_heuristic = dh (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic) a›
by (metis prod.exhaust_sel)
then have "L M1 ∩ Prefix_Tree.set (fst (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic)) = L M2 ∩ Prefix_Tree.set (fst (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic))"
using snoc.prems(3) by blast
moreover have "list.set X ⊆ L M1"
using snoc.prems(1) by auto
moreover have "list.set X ⊆ L M2"
using snoc.prems(2) by auto
ultimately have "?P1 X" and "?P2 X"
using snoc.IH by blast+
obtain T' G' where "(spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic) = (T',G')"
using prod.exhaust by metis
then have "convergence_graph_lookup_invar M1 M2 cg_lookup G'"
using ‹?P2 X› by auto
have "L M1 ∩ set T' = L M2 ∩ set T'"
using ‹L M1 ∩ Prefix_Tree.set (fst (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic)) = L M2 ∩ Prefix_Tree.set (fst (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic))›
‹(spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic) = (T',G')›
by auto
have "¬converge M1 u a ⟹ ¬converge M2 u a" and "?P2 (X@[a])"
proof -
have "a ∈ L M1"
using snoc.prems(1) by auto
then have "¬converge M1 u a ⟹ after_initial M1 u ≠ after_initial M1 a"
using ‹u ∈ L M1›
using assms(1) assms(3) convergence_minimal by blast
have "a ∈ L M2"
using snoc.prems(2) by auto
define ew where ew: "ew = get_prefix_of_separating_sequence M1 T' G' cg_lookup get_distinguishing_trace u a k"
have "(¬converge M1 u a ⟶ ¬converge M2 u a) ∧ ?P2 (X@[a])"
proof (cases "fst ew = 0")
case True
then have *: "fst (get_prefix_of_separating_sequence M1 T' G' cg_lookup get_distinguishing_trace u a k) = 0"
unfolding ew by auto
have "L M1 ∩ Prefix_Tree.set T' = L M2 ∩ Prefix_Tree.set T' ⟹ ¬ converge M1 u a ⟹ ¬ converge M2 u a"
using get_prefix_of_separating_sequence_result(1)[OF assms(1,2,3) ‹u ∈ L M1› ‹u ∈ L M2› ‹a ∈ L M1› ‹a ∈ L M2› ‹¬converge M1 u a ⟹ after_initial M1 u ≠ after_initial M1 a› assms(7) ‹convergence_graph_lookup_invar M1 M2 cg_lookup G'› _ *]
by fast
then have "(¬converge M1 u a ⟶ ¬converge M2 u a)"
using ‹L M1 ∩ set T' = L M2 ∩ set T'›
by blast
have "(snd (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u (X@[a]) k completeInputTraces append_heuristic)) = (snd (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic))"
unfolding ‹spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u (X@[a]) k completeInputTraces append_heuristic = dh (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic) a›
unfolding ‹(spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic) = (T',G')›
unfolding dh case_prod_conv snd_conv
using True ew
by fastforce
then have "?P2 (X@[a])"
using ‹?P2 X›
by auto
then show ?thesis
using ‹(¬converge M1 u a ⟶ ¬converge M2 u a)›
by auto
next
case False
then have *: "fst (get_prefix_of_separating_sequence M1 T' G' cg_lookup get_distinguishing_trace u a k) ≠ 0"
unfolding ew by auto
define w where w: "w = get_distinguishing_trace (after_initial M1 (u@(snd ew))) (after_initial M1 (a@(snd ew)))"
define w' where w': "w' = (if does_distinguish M1 (after_initial M1 u) (after_initial M1 a) (snd ew) then (snd ew) else (snd ew)@w)"
define TG' where TG': "TG' = distribute_extension M1 T' G' cg_lookup cg_insert u w' completeInputTraces append_heuristic"
show ?thesis proof (cases "¬ converge M1 u a")
case True
then have "after_initial M1 u ≠ after_initial M1 a"
using ‹u ∈ L M1› ‹a ∈ L M1›
using assms(1) assms(3) convergence_minimal by blast
obtain γ where "distinguishes M1 (after_initial M1 u) (after_initial M1 a) (snd ew @ γ)"
unfolding ‹ew = get_prefix_of_separating_sequence M1 T' G' cg_lookup get_distinguishing_trace u a k›
using get_prefix_of_separating_sequence_result(2)[OF assms(1,2,3) ‹u ∈ L M1› ‹u ∈ L M2› ‹a ∈ L M1› ‹a ∈ L M2› ‹after_initial M1 u ≠ after_initial M1 a› assms(7) ‹convergence_graph_lookup_invar M1 M2 cg_lookup G'› _ *]
using ‹L M1 ∩ Prefix_Tree.set T' = L M2 ∩ Prefix_Tree.set T'› by presburger
have "dh (T',G') a = distribute_extension M1 (fst TG') (snd TG') cg_lookup cg_insert a w' completeInputTraces append_heuristic"
unfolding dh w w' TG' case_prod_conv
unfolding ew[symmetric] Let_def
using ew False ‹after_initial M1 u ≠ after_initial M1 a›
by meson
have "L M1 ∩ set (fst (dh (T',G') a)) = L M2 ∩ set (fst (dh (T',G') a))"
using snoc.prems(3)
using ‹spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u (X@[a]) k completeInputTraces append_heuristic = dh (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic) a› ‹spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic = (T', G')›
by auto
moreover have "set (fst (distribute_extension M1 T' G' cg_lookup cg_insert u w' completeInputTraces append_heuristic)) ⊆ set (fst (dh (T',G') a))"
by (metis TG' ‹dh (T', G') a = distribute_extension M1 (fst TG') (snd TG') cg_lookup cg_insert a w' completeInputTraces append_heuristic› distribute_extension_subset)
ultimately have "(L M1 ∩ set (fst (distribute_extension M1 T' G' cg_lookup cg_insert u w' completeInputTraces append_heuristic)) = L M2 ∩ set (fst (distribute_extension M1 T' G' cg_lookup cg_insert u w' completeInputTraces append_heuristic)))"
by blast
obtain u' where "converge M1 u u'" and "converge M2 u u'"
and "u' @ w' ∈ set (fst (distribute_extension M1 T' G' cg_lookup cg_insert u w' completeInputTraces append_heuristic))"
and "convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')"
using distribute_extension_adds_sequence[OF assms(1,3) ‹u ∈ L M1› ‹u ∈ L M2› ‹convergence_graph_lookup_invar M1 M2 cg_lookup G'› ‹convergence_graph_insert_invar M1 M2 cg_lookup cg_insert›, of _ _ completeInputTraces append_heuristic, OF _ assms(13) ]
‹(L M1 ∩ set (fst (distribute_extension M1 T' G' cg_lookup cg_insert u w' completeInputTraces append_heuristic)) = L M2 ∩ set (fst (distribute_extension M1 T' G' cg_lookup cg_insert u w' completeInputTraces append_heuristic)))›
unfolding TG'
by blast
then have "u' @ w' ∈ set (fst (dh (T',G') a))"
unfolding ‹dh (T',G') a = distribute_extension M1 (fst TG') (snd TG') cg_lookup cg_insert a w' completeInputTraces append_heuristic›
by (metis (no_types, opaque_lifting) TG' distribute_extension_subset in_mono)
obtain a' where "converge M1 a a'" and "converge M2 a a'"
and "a' @ w' ∈ set (fst (dh (T',G') a))"
and "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (dh (T',G') a))"
using distribute_extension_adds_sequence[OF assms(1,3) ‹a ∈ L M1› ‹a ∈ L M2› ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')› ‹convergence_graph_insert_invar M1 M2 cg_lookup cg_insert›, of "fst TG'" w' completeInputTraces append_heuristic, OF _ assms(13)]
‹L M1 ∩ set (fst (dh (T',G') a)) = L M2 ∩ set (fst (dh (T',G') a))›
unfolding ‹dh (T',G') a = distribute_extension M1 (fst TG') (snd TG') cg_lookup cg_insert a w' completeInputTraces append_heuristic›
by blast
have "u' ∈ L M1" and "a' ∈ L M1"
using ‹converge M1 u u'› ‹converge M1 a a'› by auto
have "?P2 (X@[a])"
using ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd (dh (T',G') a))›
using False ‹after_initial M1 u ≠ after_initial M1 a›
using ‹spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u (X@[a]) k completeInputTraces append_heuristic = dh (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic) a› ‹spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic= (T', G')›
by presburger
show ?thesis proof (cases "does_distinguish M1 (after_initial M1 u) (after_initial M1 a) (snd ew)")
case True
then have "distinguishes M1 (after_initial M1 u) (after_initial M1 a) w'"
using does_distinguish_correctness[OF assms(1) after_is_state[OF assms(1) ‹u ∈ L M1›] after_is_state[OF assms(1) ‹a ∈ L M1›]] w'
by metis
show ?thesis
using distinguish_converge_diverge[OF assms(1,2,3) ‹u' ∈ L M1› ‹a' ∈ L M1› ‹converge M1 u u'› ‹converge M1 a a'› ‹converge M2 u u'› ‹converge M2 a a'› ‹distinguishes M1 (after_initial M1 u) (after_initial M1 a) w'› ‹u' @ w' ∈ set (fst (dh (T',G') a))› ‹a' @ w' ∈ set (fst (dh (T',G') a))› ‹L M1 ∩ set (fst (dh (T',G') a)) = L M2 ∩ set (fst (dh (T',G') a))›]
‹?P2 (X@[a])›
by blast
next
case False
then have "¬ distinguishes M1 (after_initial M1 u) (after_initial M1 a) (snd ew)"
using does_distinguish_correctness[OF assms(1) after_is_state[OF assms(1) ‹u ∈ L M1›] after_is_state[OF assms(1) ‹a ∈ L M1›]]
by blast
then have "snd ew ∈ LS M1 (after_initial M1 u) = (snd ew ∈ LS M1 (after_initial M1 a))"
unfolding distinguishes_def
by blast
moreover have "snd ew ∈ LS M1 (after_initial M1 u) ∨ (snd ew ∈ LS M1 (after_initial M1 a))"
using ‹distinguishes M1 (after_initial M1 u) (after_initial M1 a) (snd ew @ γ)›
using language_prefix[of "snd ew" γ]
unfolding distinguishes_def
by fast
ultimately have "snd ew ∈ LS M1 (after_initial M1 u)" and "snd ew ∈ LS M1 (after_initial M1 a)"
by auto
have "after_initial M1 (u @ snd ew) ∈ states M1"
using ‹snd ew ∈ LS M1 (after_initial M1 u)› after_is_state[OF assms(1) ‹u ∈ L M1›]
by (meson after_is_state after_language_iff assms(1) assms(5))
moreover have "after_initial M1 (a @ snd ew) ∈ states M1"
using ‹snd ew ∈ LS M1 (after_initial M1 a)› after_is_state[OF assms(1) ‹a ∈ L M1›]
by (meson ‹a ∈ L M1› after_is_state after_language_iff assms(1))
moreover have "after_initial M1 (u @ snd ew) ≠ after_initial M1 (a @ snd ew)"
using ‹distinguishes M1 (after_initial M1 u) (after_initial M1 a) (snd ew @ γ)›
by (metis ‹a ∈ L M1› ‹snd ew ∈ LS M1 (after_initial M1 a)› ‹snd ew ∈ LS M1 (after_initial M1 u)› after_distinguishes_language after_language_iff append.assoc assms(1) assms(5))
ultimately have "distinguishes M1 (after_initial M1 (u @ snd ew)) (after_initial M1 (a @ snd ew)) w"
unfolding w using assms(7)
by blast
moreover have "w' = snd ew @ w"
using False w' by auto
ultimately have "distinguishes M1 (after_initial M1 u) (after_initial M1 a) w'"
using distinguish_prepend_initial[OF assms(1)]
by (meson ‹a ∈ L M1› ‹snd ew ∈ LS M1 (after_initial M1 a)› ‹snd ew ∈ LS M1 (after_initial M1 u)› after_language_iff assms(1) assms(5))
show ?thesis
using distinguish_converge_diverge[OF assms(1,2,3) ‹u' ∈ L M1› ‹a' ∈ L M1› ‹converge M1 u u'› ‹converge M1 a a'› ‹converge M2 u u'› ‹converge M2 a a'› ‹distinguishes M1 (after_initial M1 u) (after_initial M1 a) w'› ‹u' @ w' ∈ set (fst (dh (T',G') a))› ‹a' @ w' ∈ set (fst (dh (T',G') a))› ‹L M1 ∩ set (fst (dh (T',G') a)) = L M2 ∩ set (fst (dh (T',G') a))›]
‹?P2 (X@[a])›
by blast
qed
next
case False
then have "after_initial M1 u = after_initial M1 a"
by (meson ‹a ∈ L M1› assms(1) assms(3) assms(5) convergence_minimal)
then have "dh (T',G') a = (T',G')"
unfolding dh case_prod_conv
by auto
then have "?P2 (X@[a])"
using ‹?P2 X›
by (metis ‹spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u (X@[a]) k completeInputTraces append_heuristic = dh (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic) a› ‹spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic = (T', G')›)
then show ?thesis
using False
by blast
qed
qed
then show "¬ converge M1 u a ⟹ ¬ converge M2 u a"
and "?P2 (X@[a])"
by blast+
qed
have "?P1 (X@[a])"
proof -
have "⋀ v . v ∈ list.set X ⟹ ¬converge M1 u v ⟹ ¬converge M2 u v"
using ‹?P1 X›
unfolding preserves_divergence.simps
using Int_absorb2 ‹list.set X ⊆ L M1› assms(5) by blast
then show ?thesis
using ‹¬ converge M1 u a ⟹ ¬ converge M2 u a› by auto
qed
then show ?case
using ‹?P2 (X@[a])› by auto
qed
then show "?P1 X" and "?P2 X"
by auto
qed
lemma spyh_distinguish_preserves_divergence :
fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
assumes "observable M1"
and "observable M2"
and "minimal M1"
and "minimal M2"
and "u ∈ L M1" and "u ∈ L M2"
and "⋀ α β q1 q2 . q1 ∈ states M1 ⟹ q2 ∈ states M1 ⟹ q1 ≠ q2 ⟹ distinguishes M1 q1 q2 (get_distinguishing_trace q1 q2)"
and "convergence_graph_lookup_invar M1 M2 cg_lookup G"
and "convergence_graph_insert_invar M1 M2 cg_lookup cg_insert"
and "list.set X ⊆ L M1"
and "list.set X ⊆ L M2"
and "L M1 ∩ set (fst (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic)) = L M2 ∩ set (fst (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic))"
and "⋀ T w u' uBest lBest . fst (append_heuristic T w (uBest,lBest) u') ∈ {u',uBest}"
and "preserves_divergence M1 M2 (list.set X)"
shows "preserves_divergence M1 M2 (Set.insert u (list.set X))"
(is "?P1 X")
using spyh_distinguish_establishes_divergence(1)[OF assms(1-13)]
using assms(14)
unfolding preserves_divergence.simps
by (metis IntD2 Int_iff assms(10) converge.elims(2) converge.elims(3) inf.absorb_iff2 insert_iff)
subsection ‹HandleIOPair›
definition handle_io_pair :: "bool ⇒ bool ⇒ (('a::linorder,'b::linorder,'c::linorder) fsm ⇒
('a,'b,'c) state_cover_assignment ⇒
('b×'c) prefix_tree ⇒
'd ⇒
('d ⇒ ('b×'c) list ⇒ 'd) ⇒
('d ⇒ ('b×'c) list ⇒ ('b×'c) list list) ⇒
'a ⇒ 'b ⇒ 'c ⇒
(('b×'c) prefix_tree × 'd))" where
"handle_io_pair completeInputTraces useInputHeuristic M V T G cg_insert cg_lookup q x y =
distribute_extension M T G cg_lookup cg_insert (V q) [(x,y)] completeInputTraces (if useInputHeuristic then append_heuristic_input M else append_heuristic_io)"
lemma handle_io_pair_verifies_io_pair : "verifies_io_pair (handle_io_pair b c) M1 M2 cg_lookup cg_insert"
proof -
have *:"⋀ (M::('a::linorder,'b::linorder,'c::linorder) fsm) V T (G::'d) cg_insert cg_lookup q x y . set T ⊆ set (fst (handle_io_pair b c M V T G cg_insert cg_lookup q x y))"
using distribute_extension_subset unfolding handle_io_pair_def
by metis
have ***:"⋀ (M::('a::linorder,'b::linorder,'c::linorder) fsm) V T (G::'d) cg_insert cg_lookup q x y . finite_tree T ⟶ finite_tree (fst (handle_io_pair b c M V T G cg_insert cg_lookup q x y))"
using distribute_extension_finite unfolding handle_io_pair_def
by metis
have **:"⋀ (M1::('a::linorder,'b::linorder,'c::linorder) fsm) V T (G::'d) cg_insert cg_lookup q x y.
observable M1 ⟹
observable M2 ⟹
minimal M1 ⟹
minimal M2 ⟹
FSM.inputs M2 = FSM.inputs M1 ⟹
FSM.outputs M2 = FSM.outputs M1 ⟹
is_state_cover_assignment M1 V ⟹
L M1 ∩ V ` reachable_states M1 = L M2 ∩ V ` reachable_states M1 ⟹
q ∈ reachable_states M1 ⟹
x ∈ inputs M1 ⟹
y ∈ outputs M1 ⟹
convergence_graph_lookup_invar M1 M2 cg_lookup G ⟹
convergence_graph_insert_invar M1 M2 cg_lookup cg_insert ⟹
L M1 ∩ set (fst (handle_io_pair b c M1 V T G cg_insert cg_lookup q x y)) = L M2 ∩ set (fst (handle_io_pair b c M1 V T G cg_insert cg_lookup q x y)) ⟹
(∃ α .
converge M1 α (V q) ∧
converge M2 α (V q) ∧
α ∈ set (fst (handle_io_pair b c M1 V T G cg_insert cg_lookup q x y)) ∧
α@[(x,y)] ∈ set (fst (handle_io_pair b c M1 V T G cg_insert cg_lookup q x y)))
∧ convergence_graph_lookup_invar M1 M2 cg_lookup (snd (handle_io_pair b c M1 V T G cg_insert cg_lookup q x y))"
proof -
fix M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
fix G :: 'd
fix V T cg_insert cg_lookup q x y
assume a01: "observable M1"
assume a02: "observable M2"
assume a03: "minimal M1"
assume a04: "minimal M2"
assume a05: "FSM.inputs M2 = FSM.inputs M1"
assume a06: "FSM.outputs M2 = FSM.outputs M1"
assume a07: "is_state_cover_assignment M1 V"
assume a09: "L M1 ∩ V ` reachable_states M1 = L M2 ∩ V ` reachable_states M1"
assume a10: "q ∈ reachable_states M1"
assume a11: "x ∈ inputs M1"
assume a12: "y ∈ outputs M1"
assume a13: "convergence_graph_lookup_invar M1 M2 cg_lookup G"
assume a14: "convergence_graph_insert_invar M1 M2 cg_lookup cg_insert"
assume a15: "L M1 ∩ set (fst (handle_io_pair b c M1 V T G cg_insert cg_lookup q x y)) = L M2 ∩ set (fst (handle_io_pair b c M1 V T G cg_insert cg_lookup q x y))"
let ?heuristic = "(if c then append_heuristic_input M1 else append_heuristic_io)"
have d1: "V q ∈ L M1"
using is_state_cover_assignment_language[OF a07 a10] by auto
have d2: "V q ∈ L M2"
using is_state_cover_assignment_language[OF a07 a10]
using a09 a10 by auto
have d3: "L M1 ∩ Prefix_Tree.set (fst (distribute_extension M1 T G cg_lookup cg_insert (V q) [(x,y)] b ?heuristic)) = L M2 ∩ Prefix_Tree.set (fst (distribute_extension M1 T G cg_lookup cg_insert (V q) [(x,y)] b ?heuristic))"
using a15 unfolding handle_io_pair_def .
have d4: "(⋀T w u' uBest lBest. fst (?heuristic T w (uBest, lBest) u') ∈ {u', uBest})"
using append_heuristic_input_in[of M1] append_heuristic_io_in
by fastforce
show "(∃ α .
converge M1 α (V q) ∧
converge M2 α (V q) ∧
α ∈ set (fst (handle_io_pair b c M1 V T G cg_insert cg_lookup q x y)) ∧
α@[(x,y)] ∈ set (fst (handle_io_pair b c M1 V T G cg_insert cg_lookup q x y)))
∧ convergence_graph_lookup_invar M1 M2 cg_lookup (snd (handle_io_pair b c M1 V T G cg_insert cg_lookup q x y))"
using distribute_extension_adds_sequence[OF a01 a03 d1 d2 a13 a14 d3 d4]
unfolding handle_io_pair_def
by (metis converge_sym set_prefix)
qed
show ?thesis
unfolding verifies_io_pair_def
using * *** ** by presburger
qed
lemma handle_io_pair_handles_io_pair : "handles_io_pair (handle_io_pair b c) M1 M2 cg_lookup cg_insert"
using verifies_io_pair_handled[OF handle_io_pair_verifies_io_pair] .
subsection ‹HandleStateCover›
subsubsection ‹Dynamic›
fun handle_state_cover_dynamic :: "bool ⇒
bool ⇒
('a ⇒ 'a ⇒ ('b×'c) list) ⇒
('a::linorder,'b::linorder,'c::linorder) fsm ⇒
('a,'b,'c) state_cover_assignment ⇒
(('a,'b,'c) fsm ⇒ ('b×'c) prefix_tree ⇒ 'd) ⇒
('d ⇒ ('b×'c) list ⇒ 'd) ⇒
('d ⇒ ('b×'c) list ⇒ ('b×'c) list list) ⇒
(('b×'c) prefix_tree × 'd)"
where
"handle_state_cover_dynamic completeInputTraces useInputHeuristic get_distinguishing_trace M V cg_initial cg_insert cg_lookup =
(let
k = (2 * size M);
heuristic = (if useInputHeuristic then append_heuristic_input M else append_heuristic_io);
rstates = reachable_states_as_list M;
T0' = from_list (map V rstates);
T0 = (if completeInputTraces
then Prefix_Tree.combine T0' (from_list (concat (map (λ q . language_for_input M (initial M) (map fst (V q))) rstates)))
else T0');
G0 = cg_initial M T0;
separate_state = (λ (X,T,G) q . let u = V q;
TG' = spyh_distinguish M T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces heuristic;
X' = u#X
in (X',TG'))
in snd (foldl separate_state ([],T0,G0) rstates))"
lemma handle_state_cover_dynamic_separates_state_cover:
fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
fixes M2 :: "('e,'b,'c) fsm"
fixes cg_insert :: "('d ⇒ ('b×'c) list ⇒ 'd)"
assumes "⋀ α β q1 q2 . q1 ∈ states M1 ⟹ q2 ∈ states M1 ⟹ q1 ≠ q2 ⟹ distinguishes M1 q1 q2 (dist_fun q1 q2)"
shows "separates_state_cover (handle_state_cover_dynamic b c dist_fun) M1 M2 cg_initial cg_insert cg_lookup"
proof -
let ?f = "(handle_state_cover_dynamic b c dist_fun)"
have "⋀ (V :: ('a,'b,'c) state_cover_assignment) .
(V ` reachable_states M1 ⊆ set (fst (?f M1 V cg_initial cg_insert cg_lookup)))
∧ finite_tree (fst (?f M1 V cg_initial cg_insert cg_lookup))
∧ (observable M1 ⟶
observable M2 ⟶
minimal M1 ⟶
minimal M2 ⟶
inputs M2 = inputs M1 ⟶
outputs M2 = outputs M1 ⟶
is_state_cover_assignment M1 V ⟶
convergence_graph_insert_invar M1 M2 cg_lookup cg_insert ⟶
convergence_graph_initial_invar M1 M2 cg_lookup cg_initial ⟶
L M1 ∩ set (fst (?f M1 V cg_initial cg_insert cg_lookup)) = L M2 ∩ set (fst (?f M1 V cg_initial cg_insert cg_lookup)) ⟶
(preserves_divergence M1 M2 (V ` reachable_states M1)
∧ convergence_graph_lookup_invar M1 M2 cg_lookup (snd (?f M1 V cg_initial cg_insert cg_lookup))))" (is "⋀ V . ?P V")
proof -
fix V :: "('a,'b,'c) state_cover_assignment"
define k where "k = 2 * size M1"
define heuristic where "heuristic = (if c then append_heuristic_input M1 else append_heuristic_io)"
define separate_state where "separate_state = (λ (X,T,G::'d) q . let u = V q;
TG' = spyh_distinguish M1 T G cg_lookup cg_insert dist_fun u X k b heuristic;
X' = u#X
in (X',TG'))"
define rstates where "rstates = reachable_states_as_list M1"
define T0' where "T0' = from_list (map V rstates)"
define T0 where "T0 = (if b
then Prefix_Tree.combine T0' (from_list (concat (map (λ q . language_for_input M1 (initial M1) (map fst (V q))) rstates)))
else T0')"
define G0 where "G0 = cg_initial M1 T0"
have *:"(?f M1 V cg_initial cg_insert cg_lookup) = snd (foldl separate_state ([],T0,G0) rstates)"
unfolding k_def separate_state_def rstates_def heuristic_def T0'_def T0_def G0_def handle_state_cover_dynamic.simps Let_def
by simp
have separate_state_subset : "⋀ q X T G . set T ⊆ set (fst (snd (separate_state (X,T,G) q)))"
using spyh_distinguish_subset
unfolding separate_state_def case_prod_conv Let_def snd_conv
by metis
then have "set T0 ⊆ set (fst (?f M1 V cg_initial cg_insert cg_lookup))"
unfolding *
by (induction rstates rule: rev_induct; auto; metis (mono_tags, opaque_lifting) Collect_mono_iff prod.exhaust_sel)
moreover have "set T0' ⊆ set T0"
unfolding T0_def using combine_set by auto
moreover have "V ` reachable_states M1 ⊆ set T0'"
unfolding T0'_def rstates_def using from_list_subset
by (metis image_set reachable_states_as_list_set)
ultimately have p1: "V ` reachable_states M1 ⊆ set (fst (?f M1 V cg_initial cg_insert cg_lookup))"
by blast
have "finite_tree T0'"
unfolding T0'_def using from_list_finite_tree by auto
then have "finite_tree T0"
unfolding T0_def using combine_finite_tree[OF _ from_list_finite_tree]
by auto
have separate_state_finite : "⋀ q X T G . finite_tree T ⟹ finite_tree (fst (snd (separate_state (X,T,G) q)))"
using spyh_distinguish_finite
unfolding separate_state_def case_prod_conv Let_def snd_conv
by metis
have p2: "finite_tree (fst (?f M1 V cg_initial cg_insert cg_lookup))"
unfolding *
proof (induction rstates rule: rev_induct)
case Nil
show ?case using ‹finite_tree T0› by auto
next
case (snoc a rstates)
have *:"foldl separate_state ([], T0, G0) (rstates@[a]) = separate_state (foldl separate_state ([], T0, G0) rstates) a"
by auto
show ?case
using separate_state_finite[OF snoc.IH]
unfolding *
by (metis prod.collapse)
qed
have "⋀ q X T G . fst (separate_state (X,T,G) q) = V q # X"
unfolding separate_state_def case_prod_conv Let_def fst_conv by blast
have heuristic_prop: "(⋀T w u' uBest lBest. fst (heuristic T w (uBest, lBest) u') ∈ {u', uBest})"
unfolding heuristic_def
using append_heuristic_input_in[of M1] append_heuristic_io_in
by fastforce
have p3: "observable M1 ⟹
observable M2 ⟹
minimal M1 ⟹
minimal M2 ⟹
inputs M2 = inputs M1 ⟹
outputs M2 = outputs M1 ⟹
is_state_cover_assignment M1 V ⟹
convergence_graph_insert_invar M1 M2 cg_lookup cg_insert ⟹
convergence_graph_initial_invar M1 M2 cg_lookup cg_initial ⟹
L M1 ∩ set (fst (?f M1 V cg_initial cg_insert cg_lookup)) = L M2 ∩ set (fst (?f M1 V cg_initial cg_insert cg_lookup)) ⟹
(preserves_divergence M1 M2 (V ` reachable_states M1)
∧ convergence_graph_lookup_invar M1 M2 cg_lookup (snd (?f M1 V cg_initial cg_insert cg_lookup)))"
proof -
assume a0: "observable M1"
and a1: "observable M2"
and a2: "minimal M1"
and a3: "minimal M2"
and a4: "inputs M2 = inputs M1"
and a5: "outputs M2 = outputs M1"
and a6: "is_state_cover_assignment M1 V"
and a7: "convergence_graph_insert_invar M1 M2 cg_lookup cg_insert"
and a8: "convergence_graph_initial_invar M1 M2 cg_lookup cg_initial"
and a9: "L M1 ∩ set (fst (?f M1 V cg_initial cg_insert cg_lookup)) = L M2 ∩ set (fst (?f M1 V cg_initial cg_insert cg_lookup))"
have "⋀ rstates . (list.set (fst (foldl separate_state ([],T0,G0) rstates))) = V ` list.set rstates"
proof -
fix rstates show "(list.set (fst (foldl separate_state ([],T0,G0) rstates))) = V ` list.set rstates"
proof (induction rstates rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc a rstates)
have *:"(foldl separate_state ([], T0, G0) (rstates@[a])) = separate_state (foldl separate_state ([], T0, G0) rstates) a"
by auto
have **: "⋀ q XTG . fst (separate_state XTG q) = V q # fst XTG"
using ‹⋀ q X T G . fst (separate_state (X,T,G) q) = V q # X› by auto
show ?case
unfolding * **
using snoc by auto
qed
qed
then have "(list.set (fst (foldl separate_state ([],T0,G0) rstates))) = V ` reachable_states M1"
by (metis reachable_states_as_list_set rstates_def)
have "⋀ q . q ∈ reachable_states M1 ⟹ V q ∈ set T0"
using ‹Prefix_Tree.set T0' ⊆ Prefix_Tree.set T0› ‹V ` reachable_states M1 ⊆ Prefix_Tree.set T0'› by auto
have "list.set rstates ⊆ reachable_states M1"
unfolding rstates_def
using reachable_states_as_list_set by auto
moreover have "L M1 ∩ set (fst (snd (foldl separate_state ([],T0,G0) rstates))) = L M2 ∩ set (fst (snd (foldl separate_state ([],T0,G0) rstates)))"
using "*" a9 by presburger
ultimately have "preserves_divergence M1 M2 (list.set (fst (foldl separate_state ([],T0,G0) rstates)))
∧ convergence_graph_lookup_invar M1 M2 cg_lookup (snd (snd (foldl separate_state ([],T0,G0) rstates)))"
proof (induction rstates rule: rev_induct)
case Nil
have "L M1 ∩ set T0 = L M2 ∩ set T0"
using a9
using ‹set T0 ⊆ set (fst (handle_state_cover_dynamic b c dist_fun M1 V cg_initial cg_insert cg_lookup))› by blast
then have "convergence_graph_lookup_invar M1 M2 cg_lookup G0"
using a8 ‹finite_tree T0›
unfolding G0_def convergence_graph_initial_invar_def
by blast
then show ?case by auto
next
case (snoc q rstates)
obtain X' T' G' where "foldl separate_state ([],T0,G0) rstates = (X',T',G')"
using prod_cases3 by blast
then have "T' = fst (snd (foldl separate_state ([],T0,G0) rstates))"
and "X' = fst (foldl separate_state ([],T0,G0) rstates)"
by auto
define u where "u = V q"
define TG'' where "TG'' = spyh_distinguish M1 T' G' cg_lookup cg_insert dist_fun u X' k b heuristic"
define X'' where "X'' = u#X'"
have "foldl separate_state ([], T0, G0) (rstates@[q]) = separate_state (X',T',G') q"
using ‹foldl separate_state ([],T0,G0) rstates = (X',T',G')› by auto
also have "separate_state (X',T',G') q = (X'',TG'')"
unfolding separate_state_def u_def TG''_def X''_def case_prod_conv Let_def
by auto
finally have "foldl separate_state ([], T0, G0) (rstates@[q]) = (X'',TG'')" .
have "set T' ⊆ set (fst (snd (foldl separate_state ([],T0,G0) (rstates@[q]))))"
using separate_state_subset
unfolding ‹foldl separate_state ([], T0, G0) (rstates@[q]) = separate_state (X',T',G') q› by simp
then have "L M1 ∩ set T' = L M2 ∩ set T'"
using snoc.prems(2) by blast
then have "preserves_divergence M1 M2 (list.set X')"
and "convergence_graph_lookup_invar M1 M2 cg_lookup G'"
using snoc unfolding ‹foldl separate_state ([],T0,G0) rstates = (X',T',G')›
by auto
have "set T0 ⊆ set T'"
using separate_state_subset
unfolding ‹T' = fst (snd (foldl separate_state ([],T0,G0) rstates))›
by (induction rstates rule: rev_induct; auto; metis (mono_tags, opaque_lifting) Collect_mono_iff prod.collapse)
have "V q ∈ set T0"
using snoc.prems
using ‹⋀q. q ∈ reachable_states M1 ⟹ V q ∈ Prefix_Tree.set T0› by auto
then have "V q ∈ set T'"
using ‹set T0 ⊆ set T'› by auto
moreover have "V q ∈ L M1"
proof -
have "q ∈ reachable_states M1"
using snoc.prems(1) by auto
then show ?thesis
using is_state_cover_assignment_language[OF a6] by blast
qed
ultimately have "V q ∈ L M2"
using ‹L M1 ∩ set T' = L M2 ∩ set T'› by blast
have "list.set X' = V ` list.set rstates"
unfolding ‹X' = fst (foldl separate_state ([],T0,G0) rstates)›
using ‹⋀ rstates . (list.set (fst (foldl separate_state ([],T0,G0) rstates))) = V ` list.set rstates›
by blast
moreover have "list.set rstates ⊆ reachable_states M1"
using snoc.prems(1) by auto
ultimately have "list.set X' ⊆ set T'"
using ‹set T0 ⊆ set T'›
using ‹⋀q. q ∈ reachable_states M1 ⟹ V q ∈ Prefix_Tree.set T0› by auto
moreover have "list.set X' ⊆ L M1"
using ‹list.set X' = V ` list.set rstates› ‹list.set rstates ⊆ reachable_states M1› a6
by (metis dual_order.trans image_mono state_cover_assignment_language)
ultimately have "list.set X' ⊆ L M2"
using ‹L M1 ∩ set T' = L M2 ∩ set T'› by blast
have *: "L M1 ∩ set (fst (spyh_distinguish M1 T' G' cg_lookup cg_insert dist_fun (V q) X' k b heuristic)) =
L M2 ∩ set (fst (spyh_distinguish M1 T' G' cg_lookup cg_insert dist_fun (V q) X' k b heuristic))"
using snoc.prems(2) TG''_def ‹foldl separate_state ([], T0, G0) (rstates@[q]) = separate_state (X', T', G') q› ‹separate_state (X', T', G') q = (X'', TG'')› u_def by auto
have "preserves_divergence M1 M2 (Set.insert (V q) (list.set X'))"
using spyh_distinguish_preserves_divergence[OF a0 a1 a2 a3 ‹V q ∈ L M1› ‹V q ∈ L M2› assms(1) ‹convergence_graph_lookup_invar M1 M2 cg_lookup G'› a7 ‹list.set X' ⊆ L M1› ‹list.set X' ⊆ L M2› * heuristic_prop ‹preserves_divergence M1 M2 (list.set X')›]
by presburger
then have "preserves_divergence M1 M2 (list.set X'')"
by (metis X''_def list.simps(15) u_def)
moreover have "convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG'')"
using spyh_distinguish_establishes_divergence(2)[OF a0 a1 a2 a3 ‹V q ∈ L M1› ‹V q ∈ L M2› assms(1) ‹convergence_graph_lookup_invar M1 M2 cg_lookup G'› a7 ‹list.set X' ⊆ L M1› ‹list.set X' ⊆ L M2› * heuristic_prop ]
unfolding u_def[symmetric] TG''_def[symmetric]
by presburger
ultimately show ?case
unfolding ‹foldl separate_state ([], T0, G0) (rstates@[q]) = (X'',TG'')› snd_conv fst_conv
by blast
qed
then show ?thesis
unfolding ‹(list.set (fst (foldl separate_state ([],T0,G0) rstates))) = V ` reachable_states M1›
unfolding * .
qed
show "?P V"
using p1 p2 p3 by blast
qed
then show ?thesis
unfolding separates_state_cover_def by blast
qed
subsubsection ‹Static›
fun handle_state_cover_static :: "(nat ⇒ 'a ⇒ ('b×'c) prefix_tree) ⇒
('a::linorder,'b::linorder,'c::linorder) fsm ⇒
('a,'b,'c) state_cover_assignment ⇒
(('a,'b,'c) fsm ⇒ ('b×'c) prefix_tree ⇒ 'd) ⇒
('d ⇒ ('b×'c) list ⇒ 'd) ⇒
('d ⇒ ('b×'c) list ⇒ ('b×'c) list list) ⇒
(('b×'c) prefix_tree × 'd)"
where
"handle_state_cover_static dist_set M V cg_initial cg_insert cg_lookup =
(let
separate_state = (λ T q . combine_after T (V q) (dist_set 0 q));
T' = foldl separate_state empty (reachable_states_as_list M);
G' = cg_initial M T'
in (T',G'))"
lemma handle_state_cover_static_applies_dist_sets:
assumes "q ∈ reachable_states M1"
shows "set (dist_fun 0 q) ⊆ set (after (fst (handle_state_cover_static dist_fun M1 V cg_initial cg_insert cg_lookup)) (V q))"
(is "set (dist_fun 0 q) ⊆ set (after ?T (V q))")
proof -
define k where "k = 2 * size M1"
define separate_state where "separate_state = (λ T q . combine_after T (V q) (dist_fun 0 q))"
define rstates where "rstates = reachable_states_as_list M1"
define T where "T = foldl separate_state empty rstates"
define G where "G = cg_initial M1 T"
have *:"?T = T"
unfolding k_def separate_state_def rstates_def T_def G_def handle_state_cover_static.simps Let_def
by simp
have separate_state_subset : "⋀ q T . set T ⊆ set (separate_state T q)"
unfolding separate_state_def combine_after_set
by blast
have "⋀ q . q ∈ list.set rstates ⟹ set (dist_fun 0 q) ⊆ set (after T (V q))"
proof -
fix q assume "q ∈ list.set rstates"
then show "set (dist_fun 0 q) ⊆ set (after T (V q))"
unfolding T_def proof (induction rstates arbitrary: q rule: rev_induct )
case Nil
then show ?case by auto
next
case (snoc a rstates)
have *: "foldl separate_state empty (rstates@[a]) = separate_state (foldl separate_state empty rstates) a"
by auto
show ?case proof (cases "q = a")
case True
show ?thesis
unfolding True using separate_state_def combine_after_after_subset by force
next
case False
then have ‹q ∈ list.set rstates› using snoc.prems by auto
then have "set (dist_fun 0 q) ⊆ set (after (foldl separate_state empty rstates) (V q))"
using snoc.IH by auto
moreover have "set (after (foldl separate_state empty rstates) (V q)) ⊆ set (after (foldl separate_state empty (rstates@[a])) (V q))"
unfolding *
using subset_after_subset[OF separate_state_subset] by blast
ultimately show ?thesis by blast
qed
qed
qed
then show ?thesis
unfolding rstates_def ‹?T = T› using assms
using reachable_states_as_list_set by auto
qed
lemma handle_state_cover_static_separates_state_cover:
fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
fixes M2 :: "('e,'b,'c) fsm"
fixes cg_insert :: "('d ⇒ ('b×'c) list ⇒ 'd)"
assumes "observable M1 ⟹ minimal M1 ⟹ (⋀ q1 q2 . q1 ∈ states M1 ⟹ q2 ∈ states M1 ⟹ q1 ≠ q2 ⟹ ∃ io . ∀ k1 k2 . io ∈ set (dist_fun k1 q1) ∩ set (dist_fun k2 q2) ∧ distinguishes M1 q1 q2 io)"
and "⋀ k q . q ∈ states M1 ⟹ finite_tree (dist_fun k q)"
shows "separates_state_cover (handle_state_cover_static dist_fun) M1 M2 cg_initial cg_insert cg_lookup"
proof -
let ?f = "(handle_state_cover_static dist_fun)"
have "⋀ (V :: ('a,'b,'c) state_cover_assignment) .
(V ` reachable_states M1 ⊆ set (fst (?f M1 V cg_initial cg_insert cg_lookup)))
∧ finite_tree (fst (?f M1 V cg_initial cg_insert cg_lookup))
∧ (observable M1 ⟶
observable M2 ⟶
minimal M1 ⟶
minimal M2 ⟶
inputs M2 = inputs M1 ⟶
outputs M2 = outputs M1 ⟶
is_state_cover_assignment M1 V ⟶
convergence_graph_insert_invar M1 M2 cg_lookup cg_insert ⟶
convergence_graph_initial_invar M1 M2 cg_lookup cg_initial ⟶
L M1 ∩ set (fst (?f M1 V cg_initial cg_insert cg_lookup)) = L M2 ∩ set (fst (?f M1 V cg_initial cg_insert cg_lookup)) ⟶
(preserves_divergence M1 M2 (V ` reachable_states M1)
∧ convergence_graph_lookup_invar M1 M2 cg_lookup (snd (?f M1 V cg_initial cg_insert cg_lookup))))" (is "⋀ V . ?P V")
proof -
fix V :: "('a,'b,'c) state_cover_assignment"
define k where "k = 2 * size M1"
define separate_state where "separate_state = (λ T q . combine_after T (V q) (dist_fun 0 q))"
define rstates where "rstates = reachable_states_as_list M1"
define T where "T = foldl separate_state empty rstates"
define G where "G = cg_initial M1 T"
have *:"(?f M1 V cg_initial cg_insert cg_lookup) = (T,G)"
unfolding k_def separate_state_def rstates_def T_def G_def handle_state_cover_static.simps Let_def
by simp
have separate_state_subset : "⋀ q T . set T ⊆ set (separate_state T q)"
unfolding separate_state_def combine_after_set
by blast
have "V ` (list.set rstates) ⊆ set T"
unfolding T_def proof (induction rstates rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc a rstates)
have *: "foldl separate_state empty (rstates@[a]) = separate_state (foldl separate_state empty rstates) a"
by auto
have "V ` (list.set rstates) ⊆ set (foldl separate_state empty (rstates@[a]))"
using snoc separate_state_subset by auto
moreover have "V a ∈ set (separate_state (foldl separate_state empty rstates) a)"
unfolding separate_state_def combine_after_set
by simp
ultimately show ?case
unfolding * by auto
qed
then have p1: "(V ` reachable_states M1 ⊆ set (fst (?f M1 V cg_initial cg_insert cg_lookup)))"
unfolding rstates_def *
using reachable_states_as_list_set by auto
have separate_state_finite : "⋀ q X T G . q ∈ states M1 ⟹ finite_tree T ⟹ finite_tree (separate_state T q)"
unfolding separate_state_def using combine_after_finite_tree[OF _ assms(2)]
by metis
moreover have "⋀ q . q ∈ list.set rstates ⟹ q ∈ states M1"
unfolding rstates_def
by (metis reachable_state_is_state reachable_states_as_list_set)
ultimately have p2: "finite_tree (fst (?f M1 V cg_initial cg_insert cg_lookup))"
unfolding * fst_conv T_def using empty_finite_tree
by (induction rstates rule: rev_induct; auto)
have p3: "observable M1 ⟹
observable M2 ⟹
minimal M1 ⟹
minimal M2 ⟹
inputs M2 = inputs M1 ⟹
outputs M2 = outputs M1 ⟹
is_state_cover_assignment M1 V ⟹
convergence_graph_insert_invar M1 M2 cg_lookup cg_insert ⟹
convergence_graph_initial_invar M1 M2 cg_lookup cg_initial ⟹
L M1 ∩ set (fst (?f M1 V cg_initial cg_insert cg_lookup)) = L M2 ∩ set (fst (?f M1 V cg_initial cg_insert cg_lookup)) ⟹
(preserves_divergence M1 M2 (V ` reachable_states M1)
∧ convergence_graph_lookup_invar M1 M2 cg_lookup (snd (?f M1 V cg_initial cg_insert cg_lookup)))"
proof -
assume a0: "observable M1"
and a1: "observable M2"
and a2: "minimal M1"
and a3: "minimal M2"
and a4: "inputs M2 = inputs M1"
and a5: "outputs M2 = outputs M1"
and a6: "is_state_cover_assignment M1 V"
and a7: "convergence_graph_insert_invar M1 M2 cg_lookup cg_insert"
and a8: "convergence_graph_initial_invar M1 M2 cg_lookup cg_initial"
and a9: "L M1 ∩ set (fst (?f M1 V cg_initial cg_insert cg_lookup)) = L M2 ∩ set (fst (?f M1 V cg_initial cg_insert cg_lookup))"
have "L M1 ∩ set T = L M2 ∩ set T"
using a9 unfolding * by auto
then have "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (?f M1 V cg_initial cg_insert cg_lookup))"
using a8 p2
unfolding * fst_conv snd_conv G_def convergence_graph_initial_invar_def
by blast
moreover have "preserves_divergence M1 M2 (V ` reachable_states M1)"
proof -
have "⋀ u v . u∈L M1 ∩ V ` reachable_states M1 ⟹ v∈L M1 ∩ V ` reachable_states M1 ⟹ ¬ converge M1 u v ⟹ ¬ converge M2 u v"
proof -
fix u v assume "u∈L M1 ∩ V ` reachable_states M1" and "v∈L M1 ∩ V ` reachable_states M1" and "¬ converge M1 u v"
then obtain qv qu where "qu ∈ reachable_states M1" and "u = V qu"
"qv ∈ reachable_states M1" and "v = V qv"
by auto
then have "u ∈ L M1" and "v ∈ L M1"
using a6 by (meson is_state_cover_assignment_language)+
then have "qu ≠ qv"
using a6 ‹¬ converge M1 u v›
using ‹u = V qu› ‹v = V qv› a0 a2 convergence_minimal by blast
moreover have "qu ∈ states M1" and "qv ∈ states M1"
using ‹qu ∈ reachable_states M1› ‹qv ∈ reachable_states M1›
by (simp add: reachable_state_is_state)+
ultimately obtain w where "distinguishes M1 qu qv w" and "w ∈ set (dist_fun 0 qu)" and "w ∈ set (dist_fun 0 qv)"
using assms(1)[OF a0 a2]
by (metis Int_iff)
then have "w ≠ []"
by (meson ‹qu ∈ FSM.states M1› ‹qv ∈ FSM.states M1› distinguishes_not_Nil)
have "(u@w ∈ L M1) ≠ (v@w ∈ L M1)"
unfolding ‹u = V qu› ‹v = V qv›
using state_cover_assignment_after[OF a0 a6 ‹qu ∈ reachable_states M1›]
using state_cover_assignment_after[OF a0 a6 ‹qv ∈ reachable_states M1›]
by (metis ‹distinguishes M1 qu qv w› a0 after_distinguishes_language)
moreover have "u@w ∈ set T"
using handle_state_cover_static_applies_dist_sets[OF ‹qu ∈ reachable_states M1›, of dist_fun V cg_initial cg_insert cg_lookup] ‹w ∈ set (dist_fun 0 qu)› ‹w ≠ []›
unfolding * fst_conv after_set ‹u = V qu› by auto
moreover have "v@w ∈ set T"
using handle_state_cover_static_applies_dist_sets[OF ‹qv ∈ reachable_states M1›, of dist_fun V cg_initial cg_insert cg_lookup] ‹w ∈ set (dist_fun 0 qv)› ‹w ≠ []›
unfolding * fst_conv after_set ‹v = V qv› by auto
ultimately have "(u@w ∈ L M2) ≠ (v@w ∈ L M2)"
using ‹L M1 ∩ set T = L M2 ∩ set T›
by blast
then show "¬ converge M2 u v"
using a1 converge_append_language_iff by blast
qed
then show ?thesis
unfolding preserves_divergence.simps by blast
qed
ultimately show ?thesis
by blast
qed
show "?P V"
using p1 p2 p3 by blast
qed
then show ?thesis
unfolding separates_state_cover_def by blast
qed
subsection ‹Establishing Convergence of Traces›
subsubsection ‹Dynamic›
fun distinguish_from_set :: "('a::linorder,'b::linorder,'c::linorder) fsm ⇒ ('a,'b,'c) state_cover_assignment ⇒ ('b×'c) prefix_tree ⇒ 'd ⇒ ('d ⇒ ('b×'c) list ⇒ ('b×'c) list list) ⇒ ('d ⇒ ('b×'c) list ⇒ 'd) ⇒ ('a ⇒ 'a ⇒ ('b×'c) list) ⇒ ('b×'c) list ⇒ ('b×'c) list ⇒ ('b×'c) list list ⇒ nat ⇒ nat ⇒ bool ⇒ (('b×'c) prefix_tree ⇒ ('b×'c) list ⇒ (('b×'c) list × int) ⇒ ('b×'c) list ⇒ (('b×'c) list × int)) ⇒ bool ⇒ (('b×'c) prefix_tree × 'd)" where
"distinguish_from_set M V T G cg_lookup cg_insert get_distinguishing_trace u v X k depth completeInputTraces append_heuristic u_is_v=
(let TG' = spyh_distinguish M T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic;
vClass = Set.insert v (list.set (cg_lookup (snd TG') v));
notReferenced = (¬ u_is_v) ∧ (∀ q ∈ reachable_states M . V q ∉ vClass);
TG'' = (if notReferenced then spyh_distinguish M (fst TG') (snd TG') cg_lookup cg_insert get_distinguishing_trace v X k completeInputTraces append_heuristic
else TG')
in if depth > 0
then let X' = if notReferenced then (v#u#X) else (u#X);
XY = List.product (inputs_as_list M) (outputs_as_list M);
handleIO = (λ (T,G) (x,y) . (let TGu = distribute_extension M T G cg_lookup cg_insert u [(x,y)] completeInputTraces append_heuristic;
TGv = if u_is_v then TGu else distribute_extension M (fst TGu) (snd TGu) cg_lookup cg_insert v [(x,y)] completeInputTraces append_heuristic
in if is_in_language M (initial M) (u@[(x,y)])
then distinguish_from_set M V (fst TGv) (snd TGv) cg_lookup cg_insert get_distinguishing_trace (u@[(x,y)]) (v@[(x,y)]) X' k (depth - 1) completeInputTraces append_heuristic u_is_v
else TGv))
in foldl handleIO TG'' XY
else TG'')"
lemma distinguish_from_set_subset :
"set T ⊆ set (fst (distinguish_from_set M V T G cg_lookup cg_insert get_distinguishing_trace u v X k depth completeInputTraces append_heuristic u_is_v))"
proof (induction depth arbitrary: T G u v X)
case 0
define TG' where TG': "TG' = spyh_distinguish M T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic "
define vClass where vClass: "vClass = Set.insert v (list.set (cg_lookup (snd TG') v))"
define notReferenced where notReferenced: "notReferenced = ((¬ u_is_v) ∧ (∀ q ∈ reachable_states M . V q ∉ vClass))"
define TG'' where TG'': "TG'' = (if notReferenced then spyh_distinguish M (fst TG') (snd TG') cg_lookup cg_insert get_distinguishing_trace v X k completeInputTraces append_heuristic else TG')"
have "distinguish_from_set M V T G cg_lookup cg_insert get_distinguishing_trace u v X k 0 completeInputTraces append_heuristic u_is_v = TG''"
apply (subst distinguish_from_set.simps)
unfolding TG' vClass notReferenced TG'' Let_def
by force
moreover have "set T ⊆ set (fst (TG'))"
unfolding TG'
using spyh_distinguish_subset
by metis
moreover have "set (fst (TG')) ⊆ set (fst (TG''))"
unfolding TG''
using spyh_distinguish_subset
by (metis (mono_tags, lifting) equalityE)
ultimately show ?case
by blast
next
case (Suc depth)
have "(Suc depth - 1) = depth"
by auto
define TG' where TG': "TG' = spyh_distinguish M T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic"
define vClass where vClass: "vClass = Set.insert v (list.set (cg_lookup (snd TG') v))"
define notReferenced where notReferenced: "notReferenced = ((¬ u_is_v) ∧ (∀ q ∈ reachable_states M . V q ∉ vClass))"
define TG'' where TG'': "TG'' = (if notReferenced then spyh_distinguish M (fst TG') (snd TG') cg_lookup cg_insert get_distinguishing_trace v X k completeInputTraces append_heuristic else TG')"
define X' where X': "X' = (if notReferenced then (v#u#X) else (u#X))"
define XY where XY: "XY = List.product (inputs_as_list M) (outputs_as_list M)"
define handleIO where handleIO: "handleIO = (λ (T,G) (x,y) . (let TGu = distribute_extension M T G cg_lookup cg_insert u [(x,y)] completeInputTraces append_heuristic;
TGv = if u_is_v then TGu else distribute_extension M (fst TGu) (snd TGu) cg_lookup cg_insert v [(x,y)] completeInputTraces append_heuristic
in if is_in_language M (initial M) (u@[(x,y)])
then distinguish_from_set M V (fst TGv) (snd TGv) cg_lookup cg_insert get_distinguishing_trace (u@[(x,y)]) (v@[(x,y)]) X' k (depth) completeInputTraces append_heuristic u_is_v
else TGv))"
have "⋀ x y T G . set T ⊆ set (fst (handleIO (T,G) (x,y)))"
proof -
fix x y T G
define TGu where TGu: "TGu = distribute_extension M T G cg_lookup cg_insert u [(x,y)] completeInputTraces append_heuristic"
define TGv where TGv: "TGv = (if u_is_v then TGu else distribute_extension M (fst TGu) (snd TGu) cg_lookup cg_insert v [(x,y)] completeInputTraces append_heuristic)"
have *: "handleIO (T,G) (x,y) = (if is_in_language M (initial M) (u@[(x,y)])
then distinguish_from_set M V (fst TGv) (snd TGv) cg_lookup cg_insert get_distinguishing_trace (u@[(x,y)]) (v@[(x,y)]) X' k (depth) completeInputTraces append_heuristic u_is_v
else TGv)"
unfolding handleIO TGu TGv case_prod_conv Let_def
by auto
have "set T ⊆ set (fst TGu)"
unfolding TGu
using distribute_extension_subset
by metis
moreover have "set (fst TGu) ⊆ set (fst TGv)"
unfolding TGv
using distribute_extension_subset by force
ultimately have "set T ⊆ set (fst TGv)"
by blast
show "set T ⊆ set (fst (handleIO (T,G) (x,y)))"
unfolding *
using ‹set T ⊆ set (fst TGv)›
using Suc.IH[of "fst TGv" "snd TGv" "u@[(x,y)]" "v@[(x,y)]" X']
by (cases "is_in_language M (initial M) (u@[(x,y)])"; auto)
qed
have "set (fst TG'') ⊆ set (fst (foldl handleIO TG'' XY))"
proof (induction XY rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc a XY)
obtain x y where "a = (x,y)"
using prod.exhaust by metis
then have *: "(foldl handleIO TG'' (XY@[a])) = handleIO (fst (foldl handleIO TG'' XY),snd (foldl handleIO TG'' XY)) (x,y) "
by auto
show ?case
using snoc unfolding *
using ‹⋀ x y T G . set T ⊆ set (fst (handleIO (T,G) (x,y)))›
by blast
qed
moreover have "set T ⊆ set (fst TG'')"
proof -
have "set T ⊆ set (fst TG')"
unfolding TG'
using spyh_distinguish_subset
by metis
moreover have "set (fst TG') ⊆ set (fst TG'')"
unfolding TG''
using spyh_distinguish_subset
by (metis (mono_tags, lifting) order_refl)
ultimately show ?thesis
by blast
qed
moreover have "distinguish_from_set M V T G cg_lookup cg_insert get_distinguishing_trace u v X k (Suc depth) completeInputTraces append_heuristic u_is_v = foldl handleIO TG'' XY"
apply (subst distinguish_from_set.simps)
unfolding TG' vClass notReferenced TG'' Let_def X' XY handleIO
unfolding ‹(Suc depth - 1) = depth›
by force
ultimately show ?case
by (metis (no_types, lifting) order_trans)
qed
lemma distinguish_from_set_finite :
fixes T :: "('b::linorder×'c::linorder) prefix_tree "
assumes "finite_tree T"
shows "finite_tree (fst (distinguish_from_set M V T G cg_lookup cg_insert get_distinguishing_trace u v X k depth completeInputTraces append_heuristic u_is_v))"
using assms proof (induction depth arbitrary: T G u v X)
case 0
define TG' where TG': "TG' = spyh_distinguish M T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic"
define vClass where vClass: "vClass = Set.insert v (list.set (cg_lookup (snd TG') v))"
define notReferenced where notReferenced: "notReferenced = ((¬ u_is_v) ∧ (∀ q ∈ reachable_states M . V q ∉ vClass))"
define TG'' where TG'': "TG'' = (if notReferenced then spyh_distinguish M (fst TG') (snd TG') cg_lookup cg_insert get_distinguishing_trace v X k completeInputTraces append_heuristic else TG')"
have "finite_tree (fst (TG'))"
unfolding TG'
using spyh_distinguish_finite 0
by metis
then have "finite_tree (fst (TG''))"
unfolding TG''
using spyh_distinguish_finite[OF ‹finite_tree (fst (TG'))›, of M "snd TG'" ]
by auto
moreover have "distinguish_from_set M V T G cg_lookup cg_insert get_distinguishing_trace u v X k 0 completeInputTraces append_heuristic u_is_v= TG''"
apply (subst distinguish_from_set.simps)
unfolding TG' vClass notReferenced TG'' Let_def
by force
ultimately show ?case
by blast
next
case (Suc depth)
have "(Suc depth - 1) = depth"
by auto
define TG' where TG': "TG' = spyh_distinguish M T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic"
define vClass where vClass: "vClass = Set.insert v (list.set (cg_lookup (snd TG') v))"
define notReferenced where notReferenced: "notReferenced = ((¬ u_is_v) ∧ (∀ q ∈ reachable_states M . V q ∉ vClass))"
define TG'' where TG'': "TG'' = (if notReferenced then spyh_distinguish M (fst TG') (snd TG') cg_lookup cg_insert get_distinguishing_trace v X k completeInputTraces append_heuristic else TG')"
define X' where X': "X' = (if notReferenced then (v#u#X) else (u#X))"
define XY where XY: "XY = List.product (inputs_as_list M) (outputs_as_list M)"
define handleIO where handleIO: "handleIO = (λ (T,G) (x,y) . (let TGu = distribute_extension M T G cg_lookup cg_insert u [(x,y)] completeInputTraces append_heuristic;
TGv = if u_is_v then TGu else distribute_extension M (fst TGu) (snd TGu) cg_lookup cg_insert v [(x,y)] completeInputTraces append_heuristic
in if is_in_language M (initial M) (u@[(x,y)])
then distinguish_from_set M V (fst TGv) (snd TGv) cg_lookup cg_insert get_distinguishing_trace (u@[(x,y)]) (v@[(x,y)]) X' k (depth) completeInputTraces append_heuristic u_is_v
else TGv))"
have "⋀ x y T G . finite_tree T ⟹ finite_tree (fst (handleIO (T,G) (x,y)))"
proof -
fix T :: "('b::linorder×'c::linorder) prefix_tree "
fix x y G assume "finite_tree T"
define TGu where TGu: "TGu = distribute_extension M T G cg_lookup cg_insert u [(x,y)] completeInputTraces append_heuristic"
define TGv where TGv: "TGv = (if u_is_v then TGu else distribute_extension M (fst TGu) (snd TGu) cg_lookup cg_insert v [(x,y)] completeInputTraces append_heuristic)"
have *: "handleIO (T,G) (x,y) = (if is_in_language M (initial M) (u@[(x,y)])
then distinguish_from_set M V (fst TGv) (snd TGv) cg_lookup cg_insert get_distinguishing_trace (u@[(x,y)]) (v@[(x,y)]) X' k (depth) completeInputTraces append_heuristic u_is_v
else TGv)"
unfolding handleIO TGu TGv case_prod_conv Let_def
by auto
have "finite_tree (fst TGu)"
unfolding TGu
using distribute_extension_finite ‹finite_tree T›
by metis
then have "finite_tree (fst TGv)"
unfolding TGv
using distribute_extension_finite by force
then show "finite_tree (fst (handleIO (T,G) (x,y)))"
unfolding *
using Suc.IH[of "fst TGv" "snd TGv" "u@[(x,y)]" "v@[(x,y)]" X']
by (cases "is_in_language M (initial M) (u@[(x,y)])"; auto)
qed
have "finite_tree (fst TG')"
unfolding TG'
using spyh_distinguish_finite ‹finite_tree T›
by metis
then have "finite_tree (fst TG'')"
unfolding TG''
using spyh_distinguish_finite[OF ‹finite_tree (fst (TG'))›, of M "snd TG'" ]
by auto
have "finite_tree (fst (foldl handleIO TG'' XY))"
proof (induction XY rule: rev_induct)
case Nil
then show ?case using ‹finite_tree (fst TG'')› by auto
next
case (snoc a XY)
obtain x y where "a = (x,y)"
using prod.exhaust by metis
then have *: "(foldl handleIO TG'' (XY@[a])) = handleIO (fst (foldl handleIO TG'' XY),snd (foldl handleIO TG'' XY)) (x,y)"
by auto
show ?case
using snoc unfolding *
using ‹⋀ x y T G . finite_tree T ⟹ finite_tree (fst (handleIO (T,G) (x,y)))›
by blast
qed
moreover have "distinguish_from_set M V T G cg_lookup cg_insert get_distinguishing_trace u v X k (Suc depth) completeInputTraces append_heuristic u_is_v = foldl handleIO TG'' XY"
apply (subst distinguish_from_set.simps)
unfolding TG' vClass notReferenced TG'' Let_def X' XY handleIO
unfolding ‹(Suc depth - 1) = depth›
by force
ultimately show ?case
by (metis (no_types, lifting))
qed
lemma distinguish_from_set_properties :
assumes "observable M1"
and "observable M2"
and "minimal M1"
and "minimal M2"
and "inputs M2 = inputs M1"
and "outputs M2 = outputs M1"
and "is_state_cover_assignment M1 V"
and "V ` reachable_states M1 ⊆ list.set X"
and "preserves_divergence M1 M2 (list.set X)"
and "⋀ w . w ∈ list.set X ⟹ ∃ w' . converge M1 w w' ∧ converge M2 w w'"
and "converge M1 u v"
and "u ∈ L M2"
and "v ∈ L M2"
and "convergence_graph_lookup_invar M1 M2 cg_lookup G"
and "convergence_graph_insert_invar M1 M2 cg_lookup cg_insert"
and "⋀ α β q1 q2 . q1 ∈ states M1 ⟹ q2 ∈ states M1 ⟹ q1 ≠ q2 ⟹ distinguishes M1 q1 q2 (get_distinguishing_trace q1 q2)"
and "L M1 ∩ set (fst (distinguish_from_set M1 V T G cg_lookup cg_insert get_distinguishing_trace u v X k depth completeInputTraces append_heuristic (u = v))) = L M2 ∩ set (fst (distinguish_from_set M1 V T G cg_lookup cg_insert get_distinguishing_trace u v X k depth completeInputTraces append_heuristic (u = v)))"
and "⋀ T w u' uBest lBest . fst (append_heuristic T w (uBest,lBest) u') ∈ {u',uBest}"
shows "∀ γ x y . length (γ@[(x,y)]) ≤ depth ⟶
γ ∈ LS M1 (after_initial M1 u) ⟶
x ∈ inputs M1 ⟶ y ∈ outputs M1 ⟶
L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes (γ@[(x,y)]))}) = L M2 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes (γ@[(x,y)]))})
∧ preserves_divergence M1 M2 (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes (γ@[(x,y)]))})"
(is "?P1a X u v depth")
and "preserves_divergence M1 M2 (list.set X ∪ {u,v})"
(is "?P1b X u v")
and "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (distinguish_from_set M1 V T G cg_lookup cg_insert get_distinguishing_trace u v X k depth completeInputTraces append_heuristic (u = v)))"
(is "?P2 T G u v X depth")
proof -
have "?P1a X u v depth ∧ ?P1b X u v ∧ ?P2 T G u v X depth"
using assms(8-14) assms(17)
proof (induction depth arbitrary: T G u v X)
case 0
define TG' where TG': "TG' = spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic"
define vClass where vClass: "vClass = Set.insert v (list.set (cg_lookup (snd TG') v))"
define notReferenced where notReferenced: "notReferenced = ((¬ (u = v)) ∧ (∀ q ∈ reachable_states M1 . V q ∉ vClass))"
define TG'' where TG'': "TG'' = (if notReferenced then spyh_distinguish M1 (fst TG') (snd TG') cg_lookup cg_insert get_distinguishing_trace v X k completeInputTraces append_heuristic else TG')"
have "distinguish_from_set M1 V T G cg_lookup cg_insert get_distinguishing_trace u v X k 0 completeInputTraces append_heuristic (u = v) = TG''"
apply (subst distinguish_from_set.simps)
unfolding TG' vClass notReferenced TG'' Let_def
by force
have "set T ⊆ set (fst (distinguish_from_set M1 V T G cg_lookup cg_insert get_distinguishing_trace u v X k 0 completeInputTraces append_heuristic (u = v)))"
using distinguish_from_set_subset by metis
then have "L M1 ∩ set T = L M2 ∩ set T"
using "0.prems"(8)
by blast
have "list.set X ⊆ L M1" and "list.set X ⊆ L M2"
using "0.prems"(3)
by (meson converge.elims(2) subsetI)+
have "set (fst TG') ⊆ set (fst (distinguish_from_set M1 V T G cg_lookup cg_insert get_distinguishing_trace u v X k 0 completeInputTraces append_heuristic (u = v)))"
by (metis TG'' ‹distinguish_from_set M1 V T G cg_lookup cg_insert get_distinguishing_trace u v X k 0 completeInputTraces append_heuristic (u = v) = TG''› order_refl spyh_distinguish_subset)
then have *: "L M1 ∩ Prefix_Tree.set (fst (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic)) =
L M2 ∩ Prefix_Tree.set (fst (spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic))"
using "0.prems"(8) unfolding TG'
by blast
have "u ∈ L M1" and "v ∈ L M1"
using ‹converge M1 u v› by auto
have "preserves_divergence M1 M2 (Set.insert u (list.set X))"
using spyh_distinguish_preserves_divergence[OF assms(1-4) ‹u ∈ L M1› ‹u ∈ L M2› assms(16) "0.prems"(7) assms(15) ‹list.set X ⊆ L M1› ‹list.set X ⊆ L M2› * assms(18) "0.prems"(2)]
unfolding TG' by presburger
have "convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')"
unfolding TG'
using spyh_distinguish_establishes_divergence[OF assms(1-4) ‹u ∈ L M1› ‹u ∈ L M2› assms(16) "0.prems"(7) assms(15) ‹list.set X ⊆ L M1› ‹list.set X ⊆ L M2› * assms(18)]
by linarith
have "L M1 ∩ set (fst TG'') = L M2 ∩ set (fst TG'')"
using "0.prems"(8)
unfolding ‹distinguish_from_set M1 V T G cg_lookup cg_insert get_distinguishing_trace u v X k 0 completeInputTraces append_heuristic (u = v) = TG''›
by blast
have "preserves_divergence M1 M2 (Set.insert v (list.set X))"
and "convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG'')"
proof -
have "preserves_divergence M1 M2 (Set.insert v (list.set X)) ∧ convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG'')"
proof (cases "notReferenced")
case True
then have "TG'' = spyh_distinguish M1 (fst TG') (snd TG') cg_lookup cg_insert get_distinguishing_trace v X k completeInputTraces append_heuristic"
unfolding TG'' by auto
then have *: "L M1 ∩ Prefix_Tree.set (fst (spyh_distinguish M1 (fst TG') (snd TG') cg_lookup cg_insert get_distinguishing_trace v X k completeInputTraces append_heuristic)) =
L M2 ∩ Prefix_Tree.set (fst (spyh_distinguish M1 (fst TG') (snd TG') cg_lookup cg_insert get_distinguishing_trace v X k completeInputTraces append_heuristic))"
using ‹L M1 ∩ set (fst TG'') = L M2 ∩ set (fst TG'')›
by simp
show ?thesis
using spyh_distinguish_preserves_divergence[OF assms(1-4) ‹v ∈ L M1› ‹v ∈ L M2› assms(16) ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')› assms(15) ‹list.set X ⊆ L M1› ‹list.set X ⊆ L M2› * assms(18) "0.prems"(2)]
using spyh_distinguish_establishes_divergence(2)[OF assms(1-4) ‹v ∈ L M1› ‹v ∈ L M2› assms(16) ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')› assms(15) ‹list.set X ⊆ L M1› ‹list.set X ⊆ L M2› * assms(18)]
unfolding ‹TG'' = spyh_distinguish M1 (fst TG') (snd TG') cg_lookup cg_insert get_distinguishing_trace v X k completeInputTraces append_heuristic›
by presburger
next
case False
then consider "u = v" | "(u ≠ v) ∧ ¬(∀ q ∈ reachable_states M1 . V q ∉ vClass)"
unfolding notReferenced by blast
then show ?thesis proof cases
case 1
then show ?thesis
using False TG'' ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')› ‹preserves_divergence M1 M2 (Set.insert u (list.set X))› by presburger
next
case 2
then have "TG'' = TG'"
unfolding TG'' using False by auto
obtain q where "q ∈ reachable_states M1"
and "V q ∈ Set.insert v (list.set (cg_lookup (snd TG') v))"
using 2
unfolding notReferenced vClass
by blast
have "converge M1 (V q) v" and "converge M2 (V q) v"
proof -
have "converge M1 v (V q) ∧ converge M2 v (V q)"
proof (cases "V q = v")
case True
then show ?thesis
using ‹v ∈ L M1› ‹v ∈ L M2› by auto
next
case False
then have "V q ∈ list.set (cg_lookup (snd TG') v)"
using ‹V q ∈ Set.insert v (list.set (cg_lookup (snd TG') v))›
by blast
then show ?thesis
using ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')›
unfolding convergence_graph_lookup_invar_def
using "0.prems"(6) ‹v ∈ L M1› by blast
qed
then show "converge M1 (V q) v" and "converge M2 (V q) v"
by auto
qed
have "V q ∈ Set.insert u (list.set X)"
using ‹q ∈ reachable_states M1› "0.prems"(1) by blast
have "preserves_divergence M1 M2 (Set.insert v (list.set X))"
using preserves_divergence_converge_insert[OF assms(1-4) ‹converge M1 (V q) v› ‹converge M2 (V q) v› ‹preserves_divergence M1 M2 (Set.insert u (list.set X))› ‹V q ∈ Set.insert u (list.set X)›]
unfolding preserves_divergence.simps by blast
then show ?thesis
unfolding ‹TG'' = TG'›
using ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')›
by auto
qed
qed
then show "preserves_divergence M1 M2 (Set.insert v (list.set X))" and "convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG'')"
by auto
qed
have "converge M1 u u" and "converge M1 v v" and "converge M1 v u" and "converge M1 u v"
using ‹u ∈ L M1› ‹v ∈ L M1› ‹converge M1 u v› by auto
then have "preserves_divergence M1 M2 (Set.insert u (Set.insert v (list.set X)))"
using ‹preserves_divergence M1 M2 (Set.insert v (list.set X))›
‹preserves_divergence M1 M2 (Set.insert u (list.set X))›
unfolding preserves_divergence.simps
by blast
then have "?P1b X u v"
by (metis Un_insert_right sup_bot_right)
moreover have "?P2 T G u v X 0"
using ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG'')›
using ‹distinguish_from_set M1 V T G cg_lookup cg_insert get_distinguishing_trace u v X k 0 completeInputTraces append_heuristic (u = v) = TG''› by blast
moreover have P1: "?P1a X u v 0"
by auto
ultimately show ?case
by blast
next
case (Suc depth)
have "0 < Suc depth = True"
by auto
have "Suc depth - 1 = depth"
by auto
have "u ∈ L M1" and "v ∈ L M1"
using ‹converge M1 u v› by auto
define TG' where TG': "TG' = spyh_distinguish M1 T G cg_lookup cg_insert get_distinguishing_trace u X k completeInputTraces append_heuristic"
define vClass where vClass: "vClass = Set.insert v (list.set (cg_lookup (snd TG') v))"
define notReferenced where notReferenced: "notReferenced = (¬(u = v) ∧ (∀ q ∈ reachable_states M1 . V q ∉ vClass))"
define TG'' where TG'': "TG'' = (if notReferenced then spyh_distinguish M1 (fst TG') (snd TG') cg_lookup cg_insert get_distinguishing_trace v X k completeInputTraces append_heuristic else TG')"
define X' where X': "X' = (if notReferenced then (v#u#X) else (u#X))"
define XY where XY: "XY = List.product (inputs_as_list M1) (outputs_as_list M1)"
define handleIO where handleIO: "handleIO = (λ (T,G) (x,y). (let TGu = distribute_extension M1 T G cg_lookup cg_insert u [(x,y)] completeInputTraces append_heuristic;
TGv = if (u = v) then TGu else distribute_extension M1 (fst TGu) (snd TGu) cg_lookup cg_insert v [(x,y)] completeInputTraces append_heuristic
in if is_in_language M1 (initial M1) (u@[(x,y)])
then distinguish_from_set M1 V (fst TGv) (snd TGv) cg_lookup cg_insert get_distinguishing_trace (u@[(x,y)]) (v@[(x,y)]) X' k depth completeInputTraces append_heuristic (u = v)
else TGv))"
have result: "distinguish_from_set M1 V T G cg_lookup cg_insert get_distinguishing_trace u v X k (Suc depth) completeInputTraces append_heuristic (u = v) = foldl handleIO TG'' XY"
apply (subst distinguish_from_set.simps)
unfolding TG' vClass notReferenced TG'' X' XY handleIO ‹0 < Suc depth = True› case_prod_conv ‹Suc depth - 1 = depth› if_True Let_def
by force
then have pass_result: "L M1 ∩ set (fst (foldl handleIO TG'' XY)) = L M2 ∩ set (fst (foldl handleIO TG'' XY))"
using Suc.prems(8)
by metis
have handleIO_subset : "⋀ x y T G . set T ⊆ set (fst (handleIO (T,G) (x,y)))"
proof -
fix x y T G
define TGu where TGu: "TGu = distribute_extension M1 T G cg_lookup cg_insert u [(x,y)] completeInputTraces append_heuristic"
define TGv where TGv: "TGv = (if (u = v) then TGu else distribute_extension M1 (fst TGu) (snd TGu) cg_lookup cg_insert v [(x,y)] completeInputTraces append_heuristic)"
have handleIO: "handleIO (T,G) (x,y) = (if is_in_language M1 (initial M1) (u@[(x,y)])
then distinguish_from_set M1 V (fst TGv) (snd TGv) cg_lookup cg_insert get_distinguishing_trace (u@[(x,y)]) (v@[(x,y)]) X' k depth completeInputTraces append_heuristic (u = v)
else TGv)"
unfolding handleIO TGu TGv case_prod_conv Let_def
by force
have "set T ⊆ set (fst TGu)"
using distribute_extension_subset[of T]
unfolding TGu by metis
moreover have "set (fst TGu) ⊆ set (fst TGv)"
using distribute_extension_subset[of "fst TGu"]
unfolding TGv by force
moreover have "set (fst TGv) ⊆ set (fst (handleIO (T,G) (x,y)))"
unfolding handleIO
using distinguish_from_set_subset[of "fst TGv" M1 V "snd TGv" cg_lookup cg_insert get_distinguishing_trace "u@[(x,y)]" "v@[(x,y)]" X' k depth]
by auto
ultimately show "set T ⊆ set (fst (handleIO (T,G) (x,y)))"
by blast
qed
have result_subset: "set (fst TG'') ⊆ set (fst (foldl handleIO TG'' XY))"
proof (induction XY rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc x xs)
then show ?case
using handleIO_subset[of "fst (foldl handleIO TG'' xs)" "snd (foldl handleIO TG'' xs)" "fst x" "snd x"]
by force
qed
then have pass_TG'' : "L M1 ∩ set (fst TG'') = L M2 ∩ set (fst TG'')"
using pass_result by blast
have "set (fst TG') ⊆ set (fst TG'')"
unfolding TG'' using spyh_distinguish_subset
by (metis (mono_tags, lifting) equalityE)
then have pass_TG': "L M1 ∩ set (fst TG') = L M2 ∩ set (fst TG')"
using pass_TG'' by blast
have "set T ⊆ set (fst TG')"
unfolding TG' using spyh_distinguish_subset by metis
then have pass_T: "L M1 ∩ set T = L M2 ∩ set T"
using pass_TG' by blast
have "list.set X ⊆ L M1" and "list.set X ⊆ L M2"
using Suc.prems(3) by auto
have "preserves_divergence M1 M2 (Set.insert u (list.set X))"
and "convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')"
using spyh_distinguish_preserves_divergence[OF assms(1-4) ‹u ∈ L M1› ‹u ∈ L M2› assms(16) Suc.prems(7) assms(15) ‹list.set X ⊆ L M1› ‹list.set X ⊆ L M2› _ _Suc.prems(2), of T k completeInputTraces append_heuristic, OF _ _ _ _ assms(18)]
spyh_distinguish_establishes_divergence(2)[OF assms(1-4) ‹u ∈ L M1› ‹u ∈ L M2› assms(16) Suc.prems(7) assms(15) ‹list.set X ⊆ L M1› ‹list.set X ⊆ L M2›, of T k completeInputTraces append_heuristic, OF _ _ _ _ assms(18)]
pass_TG'
unfolding TG'[symmetric]
by linarith+
have "preserves_divergence M1 M2 (Set.insert v (list.set X))"
and "convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG'')"
proof -
have "preserves_divergence M1 M2 (Set.insert v (list.set X)) ∧ convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG'')"
proof (cases "notReferenced")
case True
then have "TG'' = spyh_distinguish M1 (fst TG') (snd TG') cg_lookup cg_insert get_distinguishing_trace v X k completeInputTraces append_heuristic"
unfolding TG'' by auto
then have *: "L M1 ∩ Prefix_Tree.set (fst (spyh_distinguish M1 (fst TG') (snd TG') cg_lookup cg_insert get_distinguishing_trace v X k completeInputTraces append_heuristic)) =
L M2 ∩ Prefix_Tree.set (fst (spyh_distinguish M1 (fst TG') (snd TG') cg_lookup cg_insert get_distinguishing_trace v X k completeInputTraces append_heuristic))"
using ‹L M1 ∩ set (fst TG'') = L M2 ∩ set (fst TG'')›
by simp
show ?thesis
using spyh_distinguish_preserves_divergence[OF assms(1-4) ‹v ∈ L M1› ‹v ∈ L M2› assms(16) ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')› assms(15) ‹list.set X ⊆ L M1› ‹list.set X ⊆ L M2› * assms(18) Suc.prems(2)]
spyh_distinguish_establishes_divergence(2)[OF assms(1-4) ‹v ∈ L M1› ‹v ∈ L M2› assms(16) ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')› assms(15) ‹list.set X ⊆ L M1› ‹list.set X ⊆ L M2› * assms(18)]
unfolding ‹TG'' = spyh_distinguish M1 (fst TG') (snd TG') cg_lookup cg_insert get_distinguishing_trace v X k completeInputTraces append_heuristic›
by presburger
next
case False
then consider "u = v" | "(u ≠ v) ∧ ¬(∀ q ∈ reachable_states M1 . V q ∉ vClass)"
unfolding notReferenced by blast
then show ?thesis proof cases
case 1
then show ?thesis
using False TG'' ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')› ‹preserves_divergence M1 M2 (Set.insert u (list.set X))› by presburger
next
case 2
then have "TG'' = TG'"
unfolding TG'' using False by auto
obtain q where "q ∈ reachable_states M1"
and "V q ∈ Set.insert v (list.set (cg_lookup (snd TG') v))"
using 2
unfolding notReferenced vClass
by blast
have "converge M1 (V q) v" and "converge M2 (V q) v"
proof -
have "converge M1 v (V q) ∧ converge M2 v (V q)"
proof (cases "V q = v")
case True
then show ?thesis
using ‹v ∈ L M1› ‹v ∈ L M2› by auto
next
case False
then have "V q ∈ list.set (cg_lookup (snd TG') v)"
using ‹V q ∈ Set.insert v (list.set (cg_lookup (snd TG') v))›
by blast
then show ?thesis
using ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')›
unfolding convergence_graph_lookup_invar_def
using Suc.prems(6) ‹v ∈ L M1› by blast
qed
then show "converge M1 (V q) v" and "converge M2 (V q) v"
by auto
qed
have "V q ∈ Set.insert u (list.set X)"
using ‹q ∈ reachable_states M1› Suc.prems(1) by blast
have "preserves_divergence M1 M2 (Set.insert v (list.set X))"
using preserves_divergence_converge_insert[OF assms(1-4) ‹converge M1 (V q) v› ‹converge M2 (V q) v› ‹preserves_divergence M1 M2 (Set.insert u (list.set X))› ‹V q ∈ Set.insert u (list.set X)›]
unfolding preserves_divergence.simps by blast
then show ?thesis
unfolding ‹TG'' = TG'›
using ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')›
by auto
qed
qed
then show "preserves_divergence M1 M2 (Set.insert v (list.set X))" and "convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG'')"
by auto
qed
have "converge M1 u u" and "converge M1 v v" and "converge M1 v u" and "converge M1 u v"
using ‹u ∈ L M1› ‹v ∈ L M1› ‹converge M1 u v› by auto
then have "preserves_divergence M1 M2 (Set.insert u (Set.insert v (list.set X)))"
using ‹preserves_divergence M1 M2 (Set.insert v (list.set X))›
‹preserves_divergence M1 M2 (Set.insert u (list.set X))›
unfolding preserves_divergence.simps
by blast
have IS1: "V ` reachable_states M1 ⊆ list.set X'"
using Suc.prems(1) unfolding X' by auto
have IS2: "preserves_divergence M1 M2 (list.set X')"
using ‹preserves_divergence M1 M2 (Set.insert u (Set.insert v (list.set X)))›
‹preserves_divergence M1 M2 (Set.insert u (list.set X))›
unfolding X'
by (simp add: insert_commute)
have handleIO_props : "⋀ x y T' G' . set T ⊆ set T' ⟹ convergence_graph_lookup_invar M1 M2 cg_lookup G' ⟹ L M1 ∩ set (fst (handleIO (T',G') (x,y))) = L M2 ∩ set (fst (handleIO (T',G') (x,y))) ⟹
x ∈ inputs M1 ⟹ y ∈ outputs M1 ⟹
convergence_graph_lookup_invar M1 M2 cg_lookup (snd (handleIO (T',G') (x,y)))
∧ L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])}) = L M2 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])})
∧ preserves_divergence M1 M2 (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])})
∧ (∀ γ x' y' . length ((x,y)#γ@[(x',y')]) ≤ Suc depth ⟶
((x,y)#γ) ∈ LS M1 (after_initial M1 u) ⟶
x' ∈ inputs M1 ⟶ y' ∈ outputs M1 ⟶
L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes ((x,y)#γ@[(x',y')]))}) = L M2 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes ((x,y)#γ@[(x',y')]))})
∧ preserves_divergence M1 M2 (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes ((x,y)#γ@[(x',y')]))}))"
proof -
fix x y T' G'
assume "convergence_graph_lookup_invar M1 M2 cg_lookup G'"
and "L M1 ∩ set (fst (handleIO (T',G') (x,y))) = L M2 ∩ set (fst (handleIO (T',G') (x,y)))"
and "x ∈ inputs M1"
and "y ∈ outputs M1"
and "set T ⊆ set T'"
define TGu where TGu: "TGu = distribute_extension M1 T' G' cg_lookup cg_insert u [(x,y)] completeInputTraces append_heuristic"
define TGv where TGv: "TGv = (if (u=v) then TGu else distribute_extension M1 (fst TGu) (snd TGu) cg_lookup cg_insert v [(x,y)] completeInputTraces append_heuristic)"
have handleIO: "handleIO (T',G') (x,y) = (if is_in_language M1 (initial M1) (u@[(x,y)])
then distinguish_from_set M1 V (fst TGv) (snd TGv) cg_lookup cg_insert get_distinguishing_trace (u@[(x,y)]) (v@[(x,y)]) X' k depth completeInputTraces append_heuristic (u=v)
else TGv)"
unfolding handleIO TGu TGv case_prod_conv Let_def
by force
have "set T' ⊆ set (fst TGu)"
using distribute_extension_subset[of T']
unfolding TGu by metis
have "set (fst TGu) ⊆ set (fst TGv)"
using distribute_extension_subset[of "fst TGu"]
unfolding TGv by force
have "set (fst TGv) ⊆ set (fst (handleIO (T',G') (x,y)))"
unfolding handleIO
using distinguish_from_set_subset[of "fst TGv" M1 V "snd TGv" cg_lookup cg_insert get_distinguishing_trace "u@[(x,y)]" "v@[(x,y)]" X' k depth]
by auto
then have pass_TGv: "L M1 ∩ set (fst TGv) = L M2 ∩ set (fst TGv)"
using ‹L M1 ∩ set (fst (handleIO (T',G') (x,y))) = L M2 ∩ set (fst (handleIO (T',G') (x,y)))› ‹set (fst TGv) ⊆ set (fst (handleIO (T',G') (x,y)))›
by blast
have *:"L M1 ∩ set (fst (distribute_extension M1 T' G' cg_lookup cg_insert u [(x,y)] completeInputTraces append_heuristic)) = L M2 ∩ set (fst (distribute_extension M1 T' G' cg_lookup cg_insert u [(x,y)] completeInputTraces append_heuristic))"
using ‹L M1 ∩ set (fst (handleIO (T',G') (x,y))) = L M2 ∩ set (fst (handleIO (T',G') (x,y)))› ‹set (fst TGv) ⊆ set (fst (handleIO (T',G') (x,y)))› ‹set (fst TGu) ⊆ set (fst TGv)›
unfolding TGu
by blast
obtain u' where "converge M1 u u'"
"u' @ [(x, y)] ∈ set (fst TGv)"
"converge M2 u u'"
"convergence_graph_lookup_invar M1 M2 cg_lookup (snd TGu)"
using distribute_extension_adds_sequence[OF assms(1,3) ‹u ∈ L M1› ‹u ∈ L M2› ‹convergence_graph_lookup_invar M1 M2 cg_lookup G'› assms(15) * assms(18)]
using ‹set (fst TGu) ⊆ set (fst TGv)›
unfolding TGu by blast
have "u' ∈ set (fst TGv)"
using ‹u' @ [(x, y)] ∈ set (fst TGv)› set_prefix by metis
have "u' ∈ L M1"
using ‹converge M1 u u'› by auto
have *:"¬(u=v) ⟹ L M1 ∩ set (fst (distribute_extension M1 (fst TGu) (snd TGu) cg_lookup cg_insert v [(x,y)] completeInputTraces append_heuristic)) = L M2 ∩ set (fst (distribute_extension M1 (fst TGu) (snd TGu) cg_lookup cg_insert v [(x,y)] completeInputTraces append_heuristic))"
using ‹L M1 ∩ set (fst (handleIO (T',G') (x,y))) = L M2 ∩ set (fst (handleIO (T',G') (x,y)))› ‹set (fst TGv) ⊆ set (fst (handleIO (T',G') (x,y)))›
using TGv pass_TGv by presburger
obtain v' where "converge M1 v v'"
"v' @ [(x, y)] ∈ set (fst TGv)"
"converge M2 v v'"
"convergence_graph_lookup_invar M1 M2 cg_lookup (snd TGv)"
"u=v ⟹ u' = v'"
proof (cases "u=v")
case True
then have "TGv = TGu" unfolding TGv by auto
show ?thesis
using that
using ‹converge M1 u u'› ‹u' @ [(x, y)] ∈ set (fst TGv)› ‹converge M2 u u'› ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TGu)›
unfolding True ‹TGv = TGu› by blast
next
case False
then show ?thesis
using that
using distribute_extension_adds_sequence[OF assms(1,3) ‹v ∈ L M1› ‹v ∈ L M2› ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TGu)› assms(15) *[OF False] assms(18)]
unfolding TGv by auto
qed
have "v' ∈ set (fst TGv)"
using ‹v' @ [(x, y)] ∈ set (fst TGv)› set_prefix by metis
have "v' ∈ L M1"
using ‹converge M1 v v'› by auto
have *: "{ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])} = {u,v,u@[(x,y)],v@[(x,y)]}"
by auto
have "u ∈ L M1 = (u ∈ L M2)"
using Suc.prems(5) ‹u ∈ L M1› by auto
moreover have "v ∈ L M1 = (v ∈ L M2)"
using Suc.prems(6) ‹v ∈ L M1› by auto
moreover have "u @ [(x, y)] ∈ L M1 = (u @ [(x, y)] ∈ L M2)"
proof -
have "u @ [(x, y)] ∈ L M1 = (u' @ [(x, y)] ∈ L M1)"
using ‹converge M1 u u'› assms(1) converge_append_language_iff by blast
also have "… = (u' @ [(x, y)] ∈ L M2)"
using pass_TGv ‹u' @ [(x, y)] ∈ set (fst TGv)› by blast
also have "… = (u @ [(x, y)] ∈ L M2)"
using ‹converge M2 u u'› assms(2) converge_append_language_iff by blast
finally show ?thesis .
qed
moreover have "v @ [(x, y)] ∈ L M1 = (v @ [(x, y)] ∈ L M2)"
proof -
have "v @ [(x, y)] ∈ L M1 = (v' @ [(x, y)] ∈ L M1)"
using ‹converge M1 v v'› assms(1) converge_append_language_iff by blast
also have "… = (v' @ [(x, y)] ∈ L M2)"
using pass_TGv ‹v' @ [(x, y)] ∈ set (fst TGv)› by blast
also have "… = (v @ [(x, y)] ∈ L M2)"
using ‹converge M2 v v'› assms(2) converge_append_language_iff by blast
finally show ?thesis .
qed
moreover have "L M1 ∩ list.set X = (L M2 ∩ list.set X)"
using Suc.prems(3)
by fastforce
ultimately have p2: "L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])}) = L M2 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])})"
unfolding * by blast
show "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (handleIO (T',G') (x,y)))
∧ L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])}) = L M2 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])})
∧ preserves_divergence M1 M2 (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])})
∧ (∀ γ x' y' . length ((x,y)#γ@[(x',y')]) ≤ Suc depth ⟶
((x,y)#γ) ∈ LS M1 (after_initial M1 u) ⟶
x' ∈ inputs M1 ⟶ y' ∈ outputs M1 ⟶
L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes ((x,y)#γ@[(x',y')]))}) = L M2 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes ((x,y)#γ@[(x',y')]))})
∧ preserves_divergence M1 M2 (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes ((x,y)#γ@[(x',y')]))}))"
proof (cases "is_in_language M1 (initial M1) (u@[(x,y)])")
case False
have "u@[(x,y)] ∉ L M1"
using False by (meson assms(1) fsm_initial is_in_language_iff)
moreover have "v@[(x,y)] ∉ L M1"
using calculation Suc.prems(4) assms(1) converge_append_language_iff by blast
moreover have "preserves_divergence M1 M2 (list.set X ∪ {u,v})"
by (metis (no_types) Un_insert_right ‹preserves_divergence M1 M2 (Set.insert u (Set.insert v (list.set X)))› sup_bot_right)
ultimately have p3: "preserves_divergence M1 M2 (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])})"
unfolding * preserves_divergence.simps
by blast
have handleIO: "(handleIO (T',G') (x,y)) = TGv"
using handleIO False by auto
have "⋀ x xs . x # xs = [x] @ xs" by auto
then have "⋀ γ . (x, y) # γ ∉ LS M1 (after_initial M1 u)"
by (metis ‹u @ [(x, y)] ∉ L M1› ‹u ∈ L M1› after_language_iff assms(1) language_prefix)
have "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (handleIO (T',G') (x,y)))"
unfolding handleIO
by (simp add: ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TGv)›)
moreover note p2 p3 ‹⋀ γ . (x, y) # γ ∉ LS M1 (after_initial M1 u)›
ultimately show ?thesis
by presburger
next
case True
then have handleIO: "(handleIO (T',G') (x,y)) = distinguish_from_set M1 V (fst TGv) (snd TGv) cg_lookup cg_insert get_distinguishing_trace (u @ [(x, y)]) (v @ [(x, y)]) X' k depth completeInputTraces append_heuristic (u@[(x,y)] = v@[(x,y)])"
using handleIO by auto
have "converge M1 (u@[(x,y)]) (v@[(x,y)])"
by (meson Suc.prems(4) True ‹v ∈ L M1› assms(1) converge_append fsm_initial is_in_language_iff)
then have "(u@[(x,y)]) ∈ L M1" and "(v@[(x,y)]) ∈ L M1"
by auto
have "(u@[(x,y)]) ∈ L M2"
by (meson True ‹(u @ [(x, y)] ∈ L M1) = (u @ [(x, y)] ∈ L M2)› assms(1) fsm_initial is_in_language_iff)
have "(v@[(x,y)]) ∈ L M2"
using Suc.prems(4) ‹(u @ [(x, y)] ∈ L M1) = (u @ [(x, y)] ∈ L M2)› ‹(v @ [(x, y)] ∈ L M1) = (v @ [(x, y)] ∈ L M2)› ‹u @ [(x, y)] ∈ L M2› assms(1) converge_append_language_iff by blast
have "preserves_divergence M1 M2 (list.set X ∪ {u,v})"
by (metis (no_types) Un_insert_right ‹preserves_divergence M1 M2 (Set.insert u (Set.insert v (list.set X)))› sup_bot_right)
have IS3: "⋀w. w ∈ list.set X' ⟹ ∃w'. converge M1 w w' ∧ converge M2 w w'"
unfolding X'
by (metis (full_types) Suc.prems(3) ‹converge M1 u u'› ‹converge M1 v v'› ‹converge M2 u u'› ‹converge M2 v v'› set_ConsD)
have "(u@[(x,y)] = v@[(x,y)]) = (u=v)"
by auto
have IS4: "L M1 ∩ Prefix_Tree.set (fst (distinguish_from_set M1 V (fst TGv) (snd TGv) cg_lookup cg_insert get_distinguishing_trace (u @ [(x, y)]) (v @ [(x, y)]) X' k depth completeInputTraces append_heuristic (u@[(x,y)] = v@[(x,y)]))) = L M2 ∩ Prefix_Tree.set (fst (distinguish_from_set M1 V (fst TGv) (snd TGv) cg_lookup cg_insert get_distinguishing_trace (u @ [(x, y)]) (v @ [(x, y)]) X' k depth completeInputTraces append_heuristic (u@[(x,y)] = v@[(x,y)])))"
using ‹L M1 ∩ set (fst (handleIO (T',G') (x,y))) = L M2 ∩ set (fst (handleIO (T',G') (x,y)))›
unfolding handleIO ‹(u@[(x,y)] = v@[(x,y)]) = (u=v)›
by blast
have IH1: "⋀ γ xa ya. length (γ @ [(xa, ya)]) ≤ depth ⟹
γ ∈ LS M1 (after_initial M1 (u @ [(x, y)])) ⟹
xa ∈ FSM.inputs M1 ⟹
ya ∈ FSM.outputs M1 ⟹
L M1 ∩ (list.set X' ∪ {ω @ ω' |ω ω'. ω ∈ {u @ [(x, y)], v @ [(x, y)]} ∧ ω' ∈ list.set (prefixes (γ @ [(xa, ya)]))}) = L M2 ∩ (list.set X' ∪ {ω @ ω' |ω ω'. ω ∈ {u @ [(x, y)], v @ [(x, y)]} ∧ ω' ∈ list.set (prefixes (γ @ [(xa, ya)]))}) ∧
preserves_divergence M1 M2 (list.set X' ∪ {ω @ ω' |ω ω'. ω ∈ {u @ [(x, y)], v @ [(x, y)]} ∧ ω' ∈ list.set (prefixes (γ @ [(xa, ya)]))})"
and IH2: "preserves_divergence M1 M2 (list.set X' ∪ {u @ [(x, y)], v @ [(x, y)]})"
and IH3: "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (handleIO (T', G') (x, y)))"
using Suc.IH[OF IS1 IS2 IS3 ‹converge M1 (u@[(x,y)]) (v@[(x,y)])› ‹u@[(x,y)] ∈ L M2› ‹v@[(x,y)] ∈ L M2› ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TGv)› IS4]
unfolding handleIO[symmetric]
by blast+
have p3: "preserves_divergence M1 M2 (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])})"
proof (cases notReferenced)
case True
then have "list.set X' = list.set X ∪ {u,v}"
unfolding X' by auto
show ?thesis
using IH2
unfolding * preserves_divergence.simps ‹list.set X' = list.set X ∪ {u,v}›
by blast
next
case False
then consider "u = v" | "(u ≠ v) ∧ ¬(∀ q ∈ reachable_states M1 . V q ∉ vClass)"
unfolding notReferenced by blast
then show ?thesis proof cases
case 1
then show ?thesis
by (metis (no_types, lifting) "*" False IH2 Un_insert_left Un_insert_right X' insertI1 insert_absorb list.simps(15))
next
case 2
then have **:"(list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])}) = (list.set X' ∪ {u @ [(x, y)], v @ [(x, y)]}) ∪ {v}"
unfolding * X'
by auto
obtain q where "q ∈ reachable_states M1" and "V q ∈ vClass"
using 2 notReferenced by blast
then have "V q ∈ list.set (cg_lookup (snd TG') v)"
unfolding vClass
using ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')› ‹v ∈ L M1› ‹v ∈ L M2›
unfolding convergence_graph_lookup_invar_def by blast
then have "converge M1 (V q) v" and "converge M2 (V q) v"
using convergence_graph_lookup_invar_simp[OF ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')› ‹v ∈ L M1› ‹v ∈ L M2›, of "V q"]
by auto
have "⋀ β . β ∈ L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])}) ⟹ ¬converge M1 v β ⟹ ¬converge M2 v β"
proof -
fix β assume "β ∈ L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])})" and "¬converge M1 v β"
then consider "β = v" | "β ∈ L M1 ∩ (list.set X' ∪ {u @ [(x, y)], v @ [(x, y)]})"
unfolding ** by blast
then show "¬converge M2 v β"
proof cases
case 1
then show ?thesis using ‹¬converge M1 v β› ‹v ∈ L M1› by auto
next
case 2
moreover have "¬converge M1 (V q) β"
using ‹converge M1 (V q) v› ‹¬converge M1 v β›
by auto
moreover have "V q ∈ list.set X'"
using Suc.prems(1) ‹q ∈ reachable_states M1›
unfolding X' by auto
moreover have "V q ∈ L M1"
using ‹converge M1 (V q) v› converge.simps by blast
ultimately have "¬converge M2 (V q) β"
using IH2
unfolding preserves_divergence.simps
by blast
then show ?thesis
using ‹converge M2 (V q) v› unfolding converge.simps by force
qed
qed
have "⋀ α β . α ∈ L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])}) ⟹ β ∈ L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])}) ⟹ ¬converge M1 α β ⟹ ¬converge M2 α β"
proof -
fix α β assume "α ∈ L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])})"
"β ∈ L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])})"
"¬converge M1 α β"
then consider "α = v ∧ β ∈ L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])})" |
"β = v ∧ α ∈ L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])})" |
"α ∈ L M1 ∩ (list.set X' ∪ {u @ [(x, y)], v @ [(x, y)]}) ∧ β ∈ L M1 ∩ (list.set X' ∪ {u @ [(x, y)], v @ [(x, y)]})"
unfolding ** by auto
then show "¬converge M2 α β" proof cases
case 1
then show ?thesis using ‹⋀ β . β ∈ L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])}) ⟹ ¬converge M1 v β ⟹ ¬converge M2 v β›
using ‹¬ converge M1 α β› by blast
next
case 2
then show ?thesis using ‹⋀ β . β ∈ L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])}) ⟹ ¬converge M1 v β ⟹ ¬converge M2 v β›[of α]
using ‹¬ converge M1 α β›
unfolding converge_sym[of _ α] by blast
next
case 3
then show ?thesis
using IH2 ‹¬ converge M1 α β›
unfolding preserves_divergence.simps by blast
qed
qed
then show ?thesis
unfolding preserves_divergence.simps
by blast
qed
qed
have p4: "(⋀ γ x' y'.
length ((x, y) # γ @ [(x', y')]) ≤ Suc depth ⟹
(x, y) # γ ∈ LS M1 (after_initial M1 u) ⟹
x' ∈ FSM.inputs M1 ⟹
y' ∈ FSM.outputs M1 ⟹
L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) =
L M2 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) ∧
preserves_divergence M1 M2 (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}))"
proof -
fix γ x' y'
assume "length ((x, y) # γ @ [(x', y')]) ≤ Suc depth"
"(x, y) # γ ∈ LS M1 (after_initial M1 u)"
"x' ∈ FSM.inputs M1"
"y' ∈ FSM.outputs M1"
have s1: "length (γ @ [(x', y')]) ≤ depth"
using ‹length ((x, y) # γ @ [(x', y')]) ≤ Suc depth› by auto
have s2: "γ ∈ LS M1 (after_initial M1 (u @ [(x, y)]))"
using ‹(x, y) # γ ∈ LS M1 (after_initial M1 u)›
by (metis ‹u @ [(x, y)] ∈ L M1› after_language_append_iff append_Cons assms(1) empty_append_eq_id)
have pass': "L M1 ∩ (list.set X' ∪ {ω @ ω' |ω ω'. ω ∈ {u @ [(x, y)], v @ [(x, y)]} ∧ ω' ∈ list.set (prefixes (γ @ [(x', y')]))}) = L M2 ∩ (list.set X' ∪ {ω @ ω' |ω ω'. ω ∈ {u @ [(x, y)], v @ [(x, y)]} ∧ ω' ∈ list.set (prefixes (γ @ [(x', y')]))})"
and preserve': "preserves_divergence M1 M2 (list.set X' ∪ {ω @ ω' |ω ω'. ω ∈ {u @ [(x, y)], v @ [(x, y)]} ∧ ω' ∈ list.set (prefixes (γ @ [(x', y')]))})"
using IH1[OF s1 s2 ‹x' ∈ FSM.inputs M1› ‹y' ∈ FSM.outputs M1›]
by blast+
have ***:"{ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}
= {ω @ ω' |ω ω'. ω ∈ {u @ [(x, y)], v @ [(x, y)]} ∧ ω' ∈ list.set (prefixes (γ @ [(x', y')]))} ∪ {u,v}"
(is "?A = ?B")
proof
show "?A ⊆ ?B"
proof
fix w assume "w ∈ ?A"
then obtain ω ω' where "w = ω @ ω'" and "ω ∈ {u, v}" and "ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))"
by blast
show "w ∈ ?B"
proof (cases ω')
case Nil
then show ?thesis unfolding ‹w = ω @ ω'› prefixes_set using ‹ω ∈ {u, v}› by auto
next
case (Cons a list)
then have "a = (x,y)" and "list ∈ list.set (prefixes (γ @ [(x', y')]))"
using ‹ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))›
by (meson prefixes_Cons)+
moreover have "ω@[(x,y)] ∈ {u @ [(x, y)], v @ [(x, y)]}"
using ‹ω ∈ {u, v}›
by auto
ultimately have "((ω@[(x,y)])@list) ∈ {ω @ ω' |ω ω'. ω ∈ {u @ [(x, y)], v @ [(x, y)]} ∧ ω' ∈ list.set (prefixes (γ @ [(x', y')]))}"
by blast
then show ?thesis
unfolding ‹w = ω @ ω'› Cons ‹a = (x,y)›
by auto
qed
qed
show "?B ⊆ ?A"
proof
fix w assume "w ∈ ?B"
then consider "w ∈ {u,v}" | "w ∈ {ω @ ω' |ω ω'. ω ∈ {u @ [(x, y)], v @ [(x, y)]} ∧ ω' ∈ list.set (prefixes (γ @ [(x', y')]))}"
by blast
then show "w ∈ ?A" proof cases
case 1
then show ?thesis using prefixes_set_Nil[of " ((x, y) # γ @ [(x', y')])"]
using append.right_neutral by blast
next
case 2
then obtain ω ω' where "w = ω @ ω'" and "ω ∈ {u @ [(x, y)], v @ [(x, y)]}" and "ω' ∈ list.set (prefixes (γ @ [(x', y')]))"
by blast
obtain ω'' where "ω = ω''@[(x,y)]"
using ‹ω ∈ {u @ [(x, y)], v @ [(x, y)]}› by auto
then have "ω'' ∈ {u,v}"
using ‹ω ∈ {u @ [(x, y)], v @ [(x, y)]}› by auto
moreover have "[(x,y)]@ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))"
using prefixes_prepend[OF ‹ω' ∈ list.set (prefixes (γ @ [(x', y')]))›]
by (metis append_Cons empty_append_eq_id)
ultimately show "w ∈ ?A"
unfolding ‹w = ω @ ω'› ‹ω = ω''@[(x,y)]›
using append_assoc by blast
qed
qed
qed
have "list.set X ⊆ list.set X'"
unfolding X' by auto
then have pass'': "L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) = L M2 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))})"
using pass' ‹u ∈ L M1› ‹v ∈ L M1› ‹u ∈ L M2› ‹v ∈ L M2›
unfolding ***
by blast
have preserve'': "preserves_divergence M1 M2 (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))})"
proof (cases notReferenced)
case True
then have "list.set X' = list.set X ∪ {u,v}"
unfolding X' by auto
show ?thesis
using preserve'
unfolding *** preserves_divergence.simps ‹list.set X' = list.set X ∪ {u,v}›
by blast
next
case False
then consider "u = v" | "(u ≠ v) ∧ ¬(∀ q ∈ reachable_states M1 . V q ∉ vClass)"
unfolding notReferenced by blast
then show ?thesis proof cases
case 1
then show ?thesis
using "***" X' preserve' by fastforce
next
case 2
then have **:"(list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) = (list.set X' ∪ {ω @ ω' |ω ω'. ω ∈ {u @ [(x, y)], v @ [(x, y)]} ∧ ω' ∈ list.set (prefixes (γ @ [(x', y')]))}) ∪ {v}"
unfolding *** X' by auto
obtain q where "q ∈ reachable_states M1" and "V q ∈ vClass"
using 2 notReferenced by blast
then have "V q ∈ list.set (cg_lookup (snd TG') v)"
unfolding vClass
using ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')› ‹v ∈ L M1› ‹v ∈ L M2›
unfolding convergence_graph_lookup_invar_def by blast
then have "converge M1 (V q) v" and "converge M2 (V q) v"
using convergence_graph_lookup_invar_simp[OF ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG')› ‹v ∈ L M1› ‹v ∈ L M2›, of "V q"]
by auto
have "⋀ β . β ∈ L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) ⟹ ¬converge M1 v β ⟹ ¬converge M2 v β"
proof -
fix β assume "β ∈ L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))})" and "¬converge M1 v β"
then consider "β = v" | "β ∈ L M1 ∩ (list.set X' ∪ {ω @ ω' |ω ω'. ω ∈ {u @ [(x, y)], v @ [(x, y)]} ∧ ω' ∈ list.set (prefixes (γ @ [(x', y')]))})"
unfolding ** by blast
then show "¬converge M2 v β"
proof cases
case 1
then show ?thesis using ‹¬converge M1 v β› ‹v ∈ L M1› by auto
next
case 2
moreover have "¬converge M1 (V q) β"
using ‹converge M1 (V q) v› ‹¬converge M1 v β›
by auto
moreover have "V q ∈ list.set X'"
using Suc.prems(1) ‹q ∈ reachable_states M1›
unfolding X' by auto
moreover have "V q ∈ L M1"
using ‹converge M1 (V q) v› converge.simps by blast
ultimately have "¬converge M2 (V q) β"
using preserve'
unfolding preserves_divergence.simps
by blast
then show ?thesis
using ‹converge M2 (V q) v› unfolding converge.simps by force
qed
qed
have "⋀ α β . α ∈ L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) ⟹ β ∈ L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) ⟹ ¬converge M1 α β ⟹ ¬converge M2 α β"
proof -
fix α β assume "α ∈ L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))})"
"β ∈ L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))})"
"¬converge M1 α β"
then consider "α = v ∧ β ∈ L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))})" |
"β = v ∧ α ∈ L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))})" |
"α ∈ L M1 ∩ (list.set X' ∪ {ω @ ω' |ω ω'. ω ∈ {u @ [(x, y)], v @ [(x, y)]} ∧ ω' ∈ list.set (prefixes (γ @ [(x', y')]))}) ∧ β ∈ L M1 ∩ (list.set X' ∪ {ω @ ω' |ω ω'. ω ∈ {u @ [(x, y)], v @ [(x, y)]} ∧ ω' ∈ list.set (prefixes (γ @ [(x', y')]))})"
unfolding ** by auto
then show "¬converge M2 α β" proof cases
case 1
then show ?thesis using ‹⋀ β . β ∈ L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) ⟹ ¬converge M1 v β ⟹ ¬converge M2 v β›
using ‹¬ converge M1 α β› by blast
next
case 2
then show ?thesis using ‹⋀ β . β ∈ L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) ⟹ ¬converge M1 v β ⟹ ¬converge M2 v β›[of α]
using ‹¬ converge M1 α β›
unfolding converge_sym[of _ α] by blast
next
case 3
then show ?thesis
using preserve' ‹¬ converge M1 α β›
unfolding preserves_divergence.simps by blast
qed
qed
then show ?thesis
unfolding preserves_divergence.simps
by blast
qed
qed
show "L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) =
L M2 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) ∧
preserves_divergence M1 M2 (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))})"
using pass'' preserve''
by presburger
qed
show ?thesis
using IH3 p2 p3 p4
by blast
qed
qed
have foldl_handleIO_subset: "⋀ XY T G . set T ⊆ set (fst (foldl handleIO (T,G) XY))"
proof -
fix XY T G
show "set T ⊆ set (fst (foldl handleIO (T,G) XY))"
proof (induction XY rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc x xs)
then show ?case
using handleIO_subset[of "fst (foldl handleIO (T, G) xs)" "snd (foldl handleIO (T, G) xs)" "fst x" "snd x"]
by force
qed
qed
have "list.set XY = inputs M1 × outputs M1"
unfolding XY
by (metis inputs_as_list_set outputs_as_list_set set_product)
then have "list.set XY ⊆ inputs M1 × outputs M1"
by auto
moreover have "L M1 ∩ set (fst (foldl handleIO (fst TG'', snd TG'') XY)) = L M2 ∩ set (fst (foldl handleIO (fst TG'', snd TG'') XY))"
using pass_result by auto
ultimately have foldl_handleIO_props: "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (foldl handleIO (fst TG'', snd TG'') XY))
∧ (∀ x y . (x,y) ∈ list.set XY ⟶
L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])}) = L M2 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])})
∧ preserves_divergence M1 M2 (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])})
∧ (∀ γ x' y' . length ((x,y)#γ@[(x',y')]) ≤ Suc depth ⟶
((x,y)#γ) ∈ LS M1 (after_initial M1 u) ⟶
x' ∈ inputs M1 ⟶ y' ∈ outputs M1 ⟶
L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes ((x,y)#γ@[(x',y')]))}) = L M2 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes ((x,y)#γ@[(x',y')]))})
∧ preserves_divergence M1 M2 (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes ((x,y)#γ@[(x',y')]))})))"
proof (induction XY rule: rev_induct)
case Nil
have *:"(foldl handleIO (fst TG'', snd TG'') []) = (fst TG'', snd TG'')"
by auto
show ?case
using ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd TG'')›
unfolding * snd_conv
by auto
next
case (snoc a XY)
obtain x' y' where "a = (x',y')"
using prod.exhaust by metis
then have "x' ∈ inputs M1" and "y' ∈ outputs M1"
using snoc.prems(1) by auto
have "set T ⊆ set (fst TG'')"
using ‹Prefix_Tree.set (fst TG') ⊆ Prefix_Tree.set (fst TG'')› ‹Prefix_Tree.set T ⊆ Prefix_Tree.set (fst TG')› by auto
have "(foldl handleIO (fst TG'', snd TG'') (XY@[a])) = handleIO (foldl handleIO (fst TG'', snd TG'') XY) (x',y')"
unfolding ‹a = (x',y')› by auto
then have "set (fst (foldl handleIO (fst TG'', snd TG'') XY)) ⊆ set (fst (foldl handleIO (fst TG'', snd TG'') (XY@[a])))"
using handleIO_subset
by (metis prod.collapse)
then have pass_XY: "L M1 ∩ set (fst (foldl handleIO (fst TG'', snd TG'') XY)) = L M2 ∩ set (fst (foldl handleIO (fst TG'', snd TG'') XY))"
using snoc.prems(2) by blast
have "set T ⊆ set (fst (foldl handleIO (fst TG'', snd TG'') XY))"
using foldl_handleIO_subset ‹set T ⊆ set (fst TG'')›
by blast
have "list.set XY ⊆ FSM.inputs M1 × FSM.outputs M1"
using snoc.prems(1) by auto
have "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (foldl handleIO (fst TG'', snd TG'') XY))"
using snoc.IH[OF ‹list.set XY ⊆ FSM.inputs M1 × FSM.outputs M1› pass_XY] by blast
have pass_aXY: "L M1 ∩ Prefix_Tree.set (fst (handleIO (fst (foldl handleIO (fst TG'', snd TG'') XY), snd (foldl handleIO (fst TG'', snd TG'') XY)) (x',y') )) = L M2 ∩ Prefix_Tree.set (fst (handleIO (fst (foldl handleIO (fst TG'', snd TG'') XY), snd (foldl handleIO (fst TG'', snd TG'') XY)) (x',y') ))"
using snoc.prems(2)
unfolding ‹(foldl handleIO (fst TG'', snd TG'') (XY@[a])) = handleIO (foldl handleIO (fst TG'', snd TG'') XY) (x',y')›
unfolding prod.collapse .
show ?case (is "?P1 ∧ ?P2")
proof
show "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (foldl handleIO (fst TG'', snd TG'') (XY@[a])))"
using handleIO_props[OF ‹set T ⊆ set (fst (foldl handleIO (fst TG'', snd TG'') XY))› ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd (foldl handleIO (fst TG'', snd TG'') XY))› pass_aXY ‹x' ∈ inputs M1› ‹y' ∈ outputs M1›]
unfolding ‹(foldl handleIO (fst TG'', snd TG'') (XY@[a])) = handleIO (foldl handleIO (fst TG'', snd TG'') XY) (x',y')›
unfolding prod.collapse
by blast
have "⋀ x y. (x, y) ∈ list.set (XY@[a]) ⟹
L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])}) = L M2 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])}) ∧
preserves_divergence M1 M2 (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes [(x, y)])}) ∧
(∀γ x' y'.
length ((x, y) # γ @ [(x', y')]) ≤ Suc depth ⟶
(x, y) # γ ∈ LS M1 (after_initial M1 u) ⟶
x' ∈ FSM.inputs M1 ⟶
y' ∈ FSM.outputs M1 ⟶
L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) =
L M2 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) ∧
preserves_divergence M1 M2 (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}))"
proof -
fix x y assume "(x, y) ∈ list.set (XY@[a])"
show "L M1 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])}) = L M2 ∩ (list.set X ∪ {ω@ω' | ω ω' . ω ∈ {u,v} ∧ ω' ∈ list.set (prefixes [(x,y)])}) ∧
preserves_divergence M1 M2 (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes [(x, y)])}) ∧
(∀γ x' y'.
length ((x, y) # γ @ [(x', y')]) ≤ Suc depth ⟶
(x, y) # γ ∈ LS M1 (after_initial M1 u) ⟶
x' ∈ FSM.inputs M1 ⟶
y' ∈ FSM.outputs M1 ⟶
L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) =
L M2 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) ∧
preserves_divergence M1 M2 (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}))"
proof (cases "a = (x,y)")
case True
then have *:"(x',y') = (x,y)"
using ‹a = (x',y')› by auto
show ?thesis
using handleIO_props[OF ‹set T ⊆ set (fst (foldl handleIO (fst TG'', snd TG'') XY))› ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd (foldl handleIO (fst TG'', snd TG'') XY))› pass_aXY ‹x' ∈ inputs M1› ‹y' ∈ outputs M1›]
unfolding ‹(foldl handleIO (fst TG'', snd TG'') (XY@[a])) = handleIO (foldl handleIO (fst TG'', snd TG'') XY) (x',y')›
unfolding prod.collapse *
by presburger
next
case False
then have "(x,y) ∈ list.set XY"
using ‹(x, y) ∈ list.set (XY@[a])› by auto
then show ?thesis
using snoc.IH[OF ‹list.set XY ⊆ FSM.inputs M1 × FSM.outputs M1› pass_XY]
by presburger
qed
qed
then show "?P2"
by blast
qed
qed
have "⋀ x y . (x,y) ∈ list.set XY = (x ∈ inputs M1 ∧ y ∈ outputs M1)"
unfolding ‹list.set XY = inputs M1 × outputs M1› by auto
have result_props_1: "⋀ x y γ x' y'. x ∈ inputs M1 ⟹ y ∈ outputs M1 ⟹
length ((x, y) # γ @ [(x', y')]) ≤ Suc depth ⟹
(x, y) # γ ∈ LS M1 (after_initial M1 u) ⟹
x' ∈ FSM.inputs M1 ⟹
y' ∈ FSM.outputs M1 ⟹
L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) =
L M2 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))}) ∧
preserves_divergence M1 M2 (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes ((x, y) # γ @ [(x', y')]))})"
using foldl_handleIO_props
unfolding ‹⋀ x y . (x,y) ∈ list.set XY = (x ∈ inputs M1 ∧ y ∈ outputs M1)›
by blast
have "?P1a X u v (Suc depth)"
proof -
have "⋀ γ x y.
length (γ @ [(x, y)]) ≤ Suc depth ⟹
γ ∈ LS M1 (after_initial M1 u) ⟹
x ∈ FSM.inputs M1 ⟹
y ∈ FSM.outputs M1 ⟹
L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) =
L M2 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) ∧
preserves_divergence M1 M2 (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))})"
proof -
fix γ x y
assume "length (γ @ [(x, y)]) ≤ Suc depth"
"γ ∈ LS M1 (after_initial M1 u)"
"x ∈ FSM.inputs M1"
"y ∈ FSM.outputs M1"
show "L M1 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) =
L M2 ∩ (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) ∧
preserves_divergence M1 M2 (list.set X ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))})"
proof (cases γ)
case Nil
then have *:"γ @ [(x,y)] = [(x,y)]"
by auto
have "(x,y) ∈ list.set XY"
unfolding ‹list.set XY = inputs M1 × outputs M1›
using ‹x ∈ FSM.inputs M1› ‹y ∈ FSM.outputs M1›
by auto
show ?thesis
unfolding *
using foldl_handleIO_props ‹(x,y) ∈ list.set XY›
by presburger
next
case (Cons a γ')
obtain x' y' where "a = (x',y')"
using prod.exhaust by metis
then have *: "γ = (x',y')#γ'"
unfolding Cons by auto
then have **: "γ @ [(x, y)] = (x',y')#γ'@ [(x, y)]"
by auto
have ‹x' ∈ inputs M1› ‹y' ∈ outputs M1›
using language_io[OF ‹γ ∈ LS M1 (after_initial M1 u)›, of x' y']
unfolding *
by auto
have "length ((x', y') # (γ' @ [(x, y)])) ≤ Suc depth"
using ‹length (γ @ [(x, y)]) ≤ Suc depth› unfolding * by auto
have "(x', y') # γ' ∈ LS M1 (after_initial M1 u)"
using ‹γ ∈ LS M1 (after_initial M1 u)› unfolding * .
show ?thesis
using result_props_1[OF ‹x' ∈ inputs M1› ‹y' ∈ outputs M1› ‹length ((x', y') # (γ' @ [(x, y)])) ≤ Suc depth› ‹(x', y') # γ' ∈ LS M1 (after_initial M1 u)› ‹x ∈ FSM.inputs M1› ‹y ∈ outputs M1›]
unfolding ** .
qed
qed
then show ?thesis by blast
qed
moreover have "?P1b X u v"
using ‹preserves_divergence M1 M2 (Set.insert u (Set.insert v (list.set X)))› by auto
moreover have "?P2 T G u v X (Suc depth)"
using foldl_handleIO_props
unfolding result prod.collapse
by blast
ultimately show ?case
by blast
qed
then show "?P1a X u v depth" and "?P1b X u v" and "?P2 T G u v X depth"
by presburger+
qed
lemma distinguish_from_set_establishes_convergence :
assumes "observable M1"
and "observable M2"
and "minimal M1"
and "minimal M2"
and "size_r M1 ≤ m"
and "size M2 ≤ m"
and "inputs M2 = inputs M1"
and "outputs M2 = outputs M1"
and "is_state_cover_assignment M1 V"
and "preserves_divergence M1 M2 (V ` reachable_states M1)"
and "L M1 ∩ (V ` reachable_states M1) = L M2 ∩ V ` reachable_states M1"
and "converge M1 u v"
and "u ∈ L M2"
and "v ∈ L M2"
and "convergence_graph_lookup_invar M1 M2 cg_lookup G"
and "convergence_graph_insert_invar M1 M2 cg_lookup cg_insert"
and "⋀ q1 q2 . q1 ∈ states M1 ⟹ q2 ∈ states M1 ⟹ q1 ≠ q2 ⟹ distinguishes M1 q1 q2 (get_distinguishing_trace q1 q2)"
and "L M1 ∩ set (fst (distinguish_from_set M1 V T G cg_lookup cg_insert get_distinguishing_trace u v (map V (reachable_states_as_list M1)) k (m - size_r M1) completeInputTraces append_heuristic (u=v))) = L M2 ∩ set (fst (distinguish_from_set M1 V T G cg_lookup cg_insert get_distinguishing_trace u v (map V (reachable_states_as_list M1)) k (m - size_r M1) completeInputTraces append_heuristic (u=v)))"
and "⋀ T w u' uBest lBest . fst (append_heuristic T w (uBest,lBest) u') ∈ {u',uBest}"
shows "converge M2 u v"
and "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (distinguish_from_set M1 V T G cg_lookup cg_insert get_distinguishing_trace u v (map V (reachable_states_as_list M1)) k (m - size_r M1) completeInputTraces append_heuristic (u=v)))"
proof -
have d1: "V ` reachable_states M1 ⊆ list.set (map V (reachable_states_as_list M1))"
using reachable_states_as_list_set by auto
have d2: "preserves_divergence M1 M2 (list.set (map V (reachable_states_as_list M1)))"
using assms(10) reachable_states_as_list_set
by (metis image_set)
have d3: "(⋀w. w ∈ list.set (map V (reachable_states_as_list M1)) ⟹ ∃w'. converge M1 w w' ∧ converge M2 w w')"
proof -
fix w assume "w ∈ list.set (map V (reachable_states_as_list M1))"
then have "w ∈ V ` reachable_states M1"
using reachable_states_as_list_set by auto
moreover have "w ∈ L M1"
by (metis assms(1) assms(9) calculation image_iff state_cover_assignment_after(1))
ultimately have "w ∈ L M2"
using assms(11) by blast
have "converge M1 w w"
using ‹w ∈ L M1› by auto
moreover have "converge M2 w w"
using ‹w ∈ L M2› by auto
ultimately show "∃w'. converge M1 w w' ∧ converge M2 w w'"
by blast
qed
have "list.set (map V (reachable_states_as_list M1)) = V ` reachable_states M1"
using reachable_states_as_list_set by auto
have prop1: "⋀γ x y.
length (γ @ [(x, y)]) ≤ (m - size_r M1) ⟹
γ ∈ LS M1 (after_initial M1 u) ⟹
x ∈ FSM.inputs M1 ⟹
y ∈ FSM.outputs M1 ⟹
L M1 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) =
L M2 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) ∧
preserves_divergence M1 M2
(V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))})"
and prop2: "preserves_divergence M1 M2 (V ` reachable_states M1 ∪ {u, v})"
and prop3: "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (distinguish_from_set M1 V T G cg_lookup cg_insert get_distinguishing_trace u v (map V (reachable_states_as_list M1)) k (m - size_r M1) completeInputTraces append_heuristic (u=v)))"
using distinguish_from_set_properties[OF assms(1-4,7,8,9) d1 d2 d3 assms(12-19)]
unfolding ‹list.set (map V (reachable_states_as_list M1)) = V ` reachable_states M1›
by presburger+
then show "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (distinguish_from_set M1 V T G cg_lookup cg_insert get_distinguishing_trace u v (map V (reachable_states_as_list M1)) k (m - size_r M1) completeInputTraces append_heuristic (u=v)))"
by presburger
show "converge M2 u v"
using establish_convergence_from_pass[OF assms(1-9,11-14) prop1 prop2]
by blast
qed
definition establish_convergence_dynamic :: "bool ⇒ bool ⇒ ('a ⇒ 'a ⇒ ('b × 'c) list) ⇒
('a::linorder,'b::linorder,'c::linorder) fsm ⇒
('a,'b,'c) state_cover_assignment ⇒
('b×'c) prefix_tree ⇒
'd ⇒
('d ⇒ ('b×'c) list ⇒ 'd) ⇒
('d ⇒ ('b×'c) list ⇒ ('b×'c) list list) ⇒
nat ⇒
('a,'b,'c) transition ⇒
(('b×'c) prefix_tree × 'd)" where
"establish_convergence_dynamic completeInputTraces useInputHeuristic dist_fun M1 V T G cg_insert cg_lookup m t =
distinguish_from_set M1 V T G cg_lookup cg_insert
dist_fun
((V (t_source t))@[(t_input t, t_output t)])
(V (t_target t))
(map V (reachable_states_as_list M1))
(2 * size M1)
(m - size_r M1)
completeInputTraces
(if useInputHeuristic then append_heuristic_input M1 else append_heuristic_io)
False"
lemma establish_convergence_dynamic_verifies_transition :
assumes "⋀ q1 q2 . q1 ∈ states M1 ⟹ q2 ∈ states M1 ⟹ q1 ≠ q2 ⟹ distinguishes M1 q1 q2 (dist_fun q1 q2)"
shows "verifies_transition (establish_convergence_dynamic b c dist_fun) M1 M2 V T0 cg_insert cg_lookup"
proof -
have *:"⋀ (M1::('a::linorder,'b::linorder,'c::linorder) fsm) V T (G::'d) cg_insert cg_lookup m t. Prefix_Tree.set T ⊆ Prefix_Tree.set (fst (establish_convergence_dynamic b c dist_fun M1 V T G cg_insert cg_lookup m t))"
using distinguish_from_set_subset unfolding establish_convergence_dynamic_def
by metis
have ***:"⋀ (M1::('a::linorder,'b::linorder,'c::linorder) fsm) V T (G::'d) cg_insert cg_lookup m t. finite_tree T ⟶ finite_tree (fst (establish_convergence_dynamic b c dist_fun M1 V T G cg_insert cg_lookup m t))"
using distinguish_from_set_finite unfolding establish_convergence_dynamic_def
by metis
have **:"⋀ V T (G::'d) cg_insert cg_lookup m t.
observable M1 ⟹
observable M2 ⟹
minimal M1 ⟹
minimal M2 ⟹
size_r M1 ≤ m ⟹
FSM.size M2 ≤ m ⟹
FSM.inputs M2 = FSM.inputs M1 ⟹
FSM.outputs M2 = FSM.outputs M1 ⟹
is_state_cover_assignment M1 V ⟹
preserves_divergence M1 M2 (V ` reachable_states M1) ⟹
V ` reachable_states M1 ⊆ set T ⟹
t ∈ FSM.transitions M1 ⟹
t_source t ∈ reachable_states M1 ⟹
((V (t_source t)) @ [(t_input t,t_output t)]) ≠ (V (t_target t)) ⟹
V (t_source t) @ [(t_input t, t_output t)] ∈ L M2 ⟹
convergence_graph_lookup_invar M1 M2 cg_lookup G ⟹
convergence_graph_insert_invar M1 M2 cg_lookup cg_insert ⟹
L M1 ∩ Prefix_Tree.set (fst (establish_convergence_dynamic b c dist_fun M1 V T G cg_insert cg_lookup m t)) =
L M2 ∩ Prefix_Tree.set (fst (establish_convergence_dynamic b c dist_fun M1 V T G cg_insert cg_lookup m t)) ⟹
converge M2 (V (t_source t) @ [(t_input t, t_output t)]) (V (t_target t)) ∧
convergence_graph_lookup_invar M1 M2 cg_lookup (snd (establish_convergence_dynamic b c dist_fun M1 V T G cg_insert cg_lookup m t))"
proof -
fix G :: 'd
fix V T cg_insert cg_lookup m t
assume a01: "observable M1"
assume a02: "observable M2"
assume a03: "minimal M1"
assume a04: "minimal M2"
assume a05: "size_r M1 ≤ m"
assume a06: "FSM.size M2 ≤ m"
assume a07: "FSM.inputs M2 = FSM.inputs M1"
assume a08: "FSM.outputs M2 = FSM.outputs M1"
assume a09: "is_state_cover_assignment M1 V"
assume a10: "preserves_divergence M1 M2 (V ` reachable_states M1)"
assume a11: "V ` reachable_states M1 ⊆ set T"
assume a12: "t ∈ FSM.transitions M1"
assume a13: "t_source t ∈ reachable_states M1"
assume a14: "V (t_source t) @ [(t_input t, t_output t)] ∈ L M2"
assume a15: "convergence_graph_lookup_invar M1 M2 cg_lookup G"
assume a16: "convergence_graph_insert_invar M1 M2 cg_lookup cg_insert"
assume a17: "L M1 ∩ Prefix_Tree.set (fst (establish_convergence_dynamic b c dist_fun M1 V T G cg_insert cg_lookup m t)) = L M2 ∩ Prefix_Tree.set (fst (establish_convergence_dynamic b c dist_fun M1 V T G cg_insert cg_lookup m t))"
assume a18: "((V (t_source t)) @ [(t_input t,t_output t)]) ≠ (V (t_target t))"
let ?heuristic = "(if c then append_heuristic_input M1 else append_heuristic_io)"
have d2: "converge M1 (V (t_source t) @ [(t_input t, t_output t)]) (V (t_target t))"
using state_cover_transition_converges[OF a01 a09 a12 a13] .
have d1: "L M1 ∩ V ` reachable_states M1 = L M2 ∩ V ` reachable_states M1"
using a11 a17 *[of T M1 V G cg_insert cg_lookup m t]
by blast
then have d3: "V (t_target t) ∈ L M2"
using a11 is_state_cover_assignment_language[OF a09, of "t_target t"] reachable_states_next[OF a13 a12] by auto
have d5: "L M1 ∩ Prefix_Tree.set (fst (distinguish_from_set M1 V T G cg_lookup cg_insert dist_fun (V (t_source t) @ [(t_input t, t_output t)]) (V (t_target t)) (map V (reachable_states_as_list M1)) (2 * size M1) (m - size_r M1) b ?heuristic (((V (t_source t)) @ [(t_input t,t_output t)]) = (V (t_target t))))) = L M2 ∩ Prefix_Tree.set (fst (distinguish_from_set M1 V T G cg_lookup cg_insert dist_fun (V (t_source t) @ [(t_input t, t_output t)]) (V (t_target t)) (map V (reachable_states_as_list M1)) (2 * size M1) (m - size_r M1) b ?heuristic (((V (t_source t)) @ [(t_input t,t_output t)]) = (V (t_target t)))))"
using a17 a18 unfolding establish_convergence_dynamic_def by force
have d6: "(⋀T w u' uBest lBest. fst (?heuristic T w (uBest, lBest) u') ∈ {u', uBest})"
using append_heuristic_input_in[of M1] append_heuristic_io_in
by fastforce
show "converge M2 (V (t_source t) @ [(t_input t, t_output t)]) (V (t_target t)) ∧
convergence_graph_lookup_invar M1 M2 cg_lookup (snd (establish_convergence_dynamic b c dist_fun M1 V T G cg_insert cg_lookup m t))"
using distinguish_from_set_establishes_convergence[OF a01 a02 a03 a04 a05 a06 a07 a08 a09 a10 d1 d2 a14 d3 a15 a16 assms d5 d6] a18
unfolding establish_convergence_dynamic_def by force
qed
show ?thesis
unfolding verifies_transition_def
using * *** ** by presburger
qed
definition handleUT_dynamic :: "bool ⇒
bool ⇒
('a ⇒ 'a ⇒ ('b × 'c) list) ⇒
(('a,'b,'c) fsm ⇒ ('a,'b,'c) state_cover_assignment ⇒ ('a,'b,'c) transition ⇒ ('a,'b,'c) transition list ⇒ nat ⇒ bool) ⇒
('a::linorder,'b::linorder,'c::linorder) fsm ⇒
('a,'b,'c) state_cover_assignment ⇒
('b×'c) prefix_tree ⇒
'd ⇒
('d ⇒ ('b×'c) list ⇒ 'd) ⇒
('d ⇒ ('b×'c) list ⇒ ('b×'c) list list) ⇒
('d ⇒ ('b×'c) list ⇒ ('b×'c) list ⇒ 'd) ⇒
nat ⇒
('a,'b,'c) transition ⇒
('a,'b,'c) transition list ⇒
(('a,'b,'c) transition list × ('b×'c) prefix_tree × 'd)"
where
"handleUT_dynamic complete_input_traces
use_input_heuristic
dist_fun
do_establish_convergence
M
V
T
G
cg_insert
cg_lookup
cg_merge
m
t
X
=
(let k = (2 * size M);
l = (m - size_r M);
heuristic = (if use_input_heuristic then append_heuristic_input M
else append_heuristic_io);
rstates = (map V (reachable_states_as_list M));
(T1,G1) = handle_io_pair complete_input_traces
use_input_heuristic
M
V
T
G
cg_insert
cg_lookup
(t_source t)
(t_input t)
(t_output t);
u = ((V (t_source t))@[(t_input t, t_output t)]);
v = (V (t_target t));
X' = butlast X
in if (do_establish_convergence M V t X' l)
then let (T2,G2) = distinguish_from_set M
V
T1
G1
cg_lookup
cg_insert
dist_fun
u
v
rstates
k
l
complete_input_traces
heuristic
False;
G3 = cg_merge G2 u v
in
(X',T2,G3)
else (X',distinguish_from_set M
V
T1
G1
cg_lookup
cg_insert
dist_fun
u
u
rstates
k
l
complete_input_traces
heuristic
True))"
lemma handleUT_dynamic_handles_transition :
fixes M1::"('a::linorder,'b::linorder,'c::linorder) fsm"
fixes M2::"('e,'b,'c) fsm"
assumes "⋀ q1 q2 . q1 ∈ states M1 ⟹ q2 ∈ states M1 ⟹ q1 ≠ q2 ⟹ distinguishes M1 q1 q2 (dist_fun q1 q2)"
shows "handles_transition (handleUT_dynamic b c dist_fun d) M1 M2 V T0 cg_insert cg_lookup cg_merge"
proof -
have "⋀ T G m t X .
Prefix_Tree.set T ⊆ Prefix_Tree.set (fst (snd (handleUT_dynamic b c dist_fun d M1 V T G cg_insert cg_lookup cg_merge m t X))) ∧
(finite_tree T ⟶ finite_tree (fst (snd (handleUT_dynamic b c dist_fun d M1 V T G cg_insert cg_lookup cg_merge m t X)))) ∧
(observable M1 ⟶
observable M2 ⟶
minimal M1 ⟶
minimal M2 ⟶
size_r M1 ≤ m ⟶
FSM.size M2 ≤ m ⟶
FSM.inputs M2 = FSM.inputs M1 ⟶
FSM.outputs M2 = FSM.outputs M1 ⟶
is_state_cover_assignment M1 V ⟶
preserves_divergence M1 M2 (V ` reachable_states M1) ⟶
V ` reachable_states M1 ⊆ Prefix_Tree.set T ⟶
t ∈ FSM.transitions M1 ⟶
t_source t ∈ reachable_states M1 ⟶
V (t_source t) @ [(t_input t, t_output t)] ≠ V (t_target t) ⟶
convergence_graph_lookup_invar M1 M2 cg_lookup G ⟶
convergence_graph_insert_invar M1 M2 cg_lookup cg_insert ⟶
convergence_graph_merge_invar M1 M2 cg_lookup cg_merge ⟶
L M1 ∩ Prefix_Tree.set (fst (snd (handleUT_dynamic b c dist_fun d M1 V T G cg_insert cg_lookup cg_merge m t X))) =
L M2 ∩ Prefix_Tree.set (fst (snd (handleUT_dynamic b c dist_fun d M1 V T G cg_insert cg_lookup cg_merge m t X))) ⟶
Prefix_Tree.set T0 ⊆ Prefix_Tree.set T ⟶
(∀γ. length γ ≤ m - size_r M1 ∧ list.set γ ⊆ FSM.inputs M1 × FSM.outputs M1 ∧ butlast γ ∈ LS M1 (t_target t) ⟶
L M1 ∩ (V ` reachable_states M1 ∪ {(V (t_source t) @ [(t_input t, t_output t)]) @ ω' |ω'. ω' ∈ list.set (prefixes γ)}) =
L M2 ∩ (V ` reachable_states M1 ∪ {(V (t_source t) @ [(t_input t, t_output t)]) @ ω' |ω'. ω' ∈ list.set (prefixes γ)}) ∧
preserves_divergence M1 M2 (V ` reachable_states M1 ∪ {(V (t_source t) @ [(t_input t, t_output t)]) @ ω' |ω'. ω' ∈ list.set (prefixes γ)})) ∧
convergence_graph_lookup_invar M1 M2 cg_lookup (snd (snd (handleUT_dynamic b c dist_fun d M1 V T G cg_insert cg_lookup cg_merge m t X))))"
(is "⋀ T G m t X . ?P T G m t X")
proof -
fix T :: "('b×'c) prefix_tree"
fix G :: 'd
fix m :: nat
fix t :: "('a,'b,'c) transition"
fix X :: "('a,'b,'c) transition list"
let ?TG = "snd (handleUT_dynamic b c dist_fun d M1 V T G cg_insert cg_lookup cg_merge m t X)"
define k where "k = (2 * size M1)"
define l where "l = (m - size_r M1)"
define X' where "X' = butlast X"
define heuristic where "heuristic = (if c then append_heuristic_input M1 else append_heuristic_io)"
define rstates where "rstates = (map V (reachable_states_as_list M1))"
obtain T1 G1 where "(T1,G1) = handle_io_pair b c M1 V T G cg_insert cg_lookup (t_source t) (t_input t) (t_output t)"
using prod.collapse by blast
then have T1_def: "T1 = fst (handle_io_pair b c M1 V T G cg_insert cg_lookup (t_source t) (t_input t) (t_output t))"
and G1_def: "G1 = snd (handle_io_pair b c M1 V T G cg_insert cg_lookup (t_source t) (t_input t) (t_output t))"
using fst_conv[of T1 G1] snd_conv[of T1 G1] by force+
define u where "u = ((V (t_source t))@[(t_input t, t_output t)])"
define v where "v = (V (t_target t))"
obtain T2 G2 where "(T2,G2) = distinguish_from_set M1 V T1 G1 cg_lookup cg_insert dist_fun u v rstates k l b heuristic False"
using prod.collapse by blast
then have T2_def: "T2 = fst (distinguish_from_set M1 V T1 G1 cg_lookup cg_insert dist_fun u v rstates k l b heuristic False)"
and G2_def: "G2 = snd (distinguish_from_set M1 V T1 G1 cg_lookup cg_insert dist_fun u v rstates k l b heuristic False)"
using fst_conv[of T2 G2] snd_conv[of T2 G2] by force+
define G3 where "G3 = cg_merge G2 u v"
obtain TH GH where "(TH,GH) = distinguish_from_set M1 V T1 G1 cg_lookup cg_insert dist_fun u u rstates k l b heuristic True"
using prod.collapse by blast
then have TH_def: "TH = fst (distinguish_from_set M1 V T1 G1 cg_lookup cg_insert dist_fun u u rstates k l b heuristic True)"
and GH_def: "GH = snd (distinguish_from_set M1 V T1 G1 cg_lookup cg_insert dist_fun u u rstates k l b heuristic True)"
using fst_conv[of TH GH] snd_conv[of TH GH] by force+
have TG_cases: "?TG = (if (d M1 V t X' l) then (T2,G3) else (TH,GH))"
unfolding handleUT_dynamic_def Let_def
unfolding u_def[symmetric] v_def[symmetric] rstates_def[symmetric] k_def[symmetric] l_def[symmetric] heuristic_def[symmetric]
unfolding ‹(T1,G1) = handle_io_pair b c M1 V T G cg_insert cg_lookup (t_source t) (t_input t) (t_output t)›[symmetric] case_prod_conv
unfolding ‹(T2,G2) = distinguish_from_set M1 V T1 G1 cg_lookup cg_insert dist_fun u v rstates k l b heuristic False›[symmetric] case_prod_conv
unfolding G3_def[symmetric]
unfolding ‹(TH,GH) = distinguish_from_set M1 V T1 G1 cg_lookup cg_insert dist_fun u u rstates k l b heuristic True›[symmetric]
unfolding X'_def[symmetric]
by auto
then have TG_cases_fst: "fst ?TG = (if (d M1 V t X' l) then T2 else TH)"
and TG_cases_snd: "snd ?TG = (if (d M1 V t X' l) then G3 else GH)"
by auto
have "set T ⊆ set T1"
unfolding T1_def handle_io_pair_def
by (metis distribute_extension_subset)
moreover have "set T1 ⊆ set T2"
unfolding T2_def
by (meson distinguish_from_set_subset)
moreover have "set T1 ⊆ set TH"
unfolding TH_def
by (meson distinguish_from_set_subset)
ultimately have *:"set T ⊆ set (fst ?TG)"
using TG_cases by auto
have "finite_tree T ⟹ finite_tree T1"
unfolding T1_def handle_io_pair_def
by (metis distribute_extension_finite)
moreover have "finite_tree T1 ⟹ finite_tree T2"
unfolding T2_def
by (meson distinguish_from_set_finite)
moreover have "finite_tree T1 ⟹ finite_tree TH"
unfolding TH_def
by (meson distinguish_from_set_finite)
ultimately have **:"finite_tree T ⟹ finite_tree (fst ?TG)"
using TG_cases by auto
have ***: "observable M1 ⟹
observable M2 ⟹
minimal M1 ⟹
minimal M2 ⟹
size_r M1 ≤ m ⟹
size M2 ≤ m ⟹
inputs M2 = inputs M1 ⟹
outputs M2 = outputs M1 ⟹
is_state_cover_assignment M1 V ⟹
preserves_divergence M1 M2 (V ` reachable_states M1) ⟹
V ` reachable_states M1 ⊆ set T ⟹
t ∈ transitions M1 ⟹
t_source t ∈ reachable_states M1 ⟹
V (t_source t) @ [(t_input t, t_output t)] ≠ V (t_target t) ⟹
convergence_graph_lookup_invar M1 M2 cg_lookup G ⟹
convergence_graph_insert_invar M1 M2 cg_lookup cg_insert ⟹
convergence_graph_merge_invar M1 M2 cg_lookup cg_merge ⟹
L M1 ∩ set (fst ?TG) = L M2 ∩ set (fst ?TG) ⟹
(set T0 ⊆ set T) ⟹
(∀ γ . (length γ ≤ (m-size_r M1) ∧ list.set γ ⊆ inputs M1 × outputs M1 ∧ butlast γ ∈ LS M1 (t_target t))
⟶ ((L M1 ∩ (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)})
= L M2 ∩ (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)}))
∧ preserves_divergence M1 M2 (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)})))
∧ convergence_graph_lookup_invar M1 M2 cg_lookup (snd ?TG)"
proof -
assume a01 : "observable M1"
assume a02 : "observable M2"
assume a03 : "minimal M1"
assume a04 : "minimal M2"
assume a05 : "size_r M1 ≤ m"
assume a06 : "size M2 ≤ m"
assume a07 : "inputs M2 = inputs M1"
assume a08 : "outputs M2 = outputs M1"
assume a09 : "is_state_cover_assignment M1 V"
assume a10 : "preserves_divergence M1 M2 (V ` reachable_states M1)"
assume a11 : "V ` reachable_states M1 ⊆ set T"
assume a12 : "t ∈ transitions M1"
assume a13 : "t_source t ∈ reachable_states M1"
assume a14 : "convergence_graph_lookup_invar M1 M2 cg_lookup G"
assume a15 : "convergence_graph_insert_invar M1 M2 cg_lookup cg_insert"
assume a16 : "convergence_graph_merge_invar M1 M2 cg_lookup cg_merge"
assume a17 : "L M1 ∩ set (fst ?TG) = L M2 ∩ set (fst ?TG)"
assume a18 : "(set T0 ⊆ set T)"
assume a19 : "V (t_source t) @ [(t_input t, t_output t)] ≠ V (t_target t)"
have pass_T1 : "L M1 ∩ set T1 = L M2 ∩ set T1"
using a17 ‹set T1 ⊆ set T2› ‹set T1 ⊆ set TH› unfolding TG_cases_fst
by (cases "d M1 V t X' l"; auto)
then have pass_T : "L M1 ∩ set T = L M2 ∩ set T"
using ‹set T ⊆ set T1› by blast
have "t_target t ∈ reachable_states M1"
using reachable_states_next[OF a13 a12] by auto
then have "(V (t_target t)) ∈ L M1"
using is_state_cover_assignment_language[OF a09] by blast
moreover have "(V (t_target t)) ∈ set T"
using a11 ‹t_target t ∈ reachable_states M1› by blast
ultimately have "(V (t_target t)) ∈ L M2"
using pass_T by blast
then have "v ∈ L M2"
unfolding v_def .
have "(V (t_source t)) ∈ L M1"
using is_state_cover_assignment_language[OF a09 a13] by blast
moreover have "(V (t_source t)) ∈ set T"
using a11 a13 by blast
ultimately have "(V (t_source t)) ∈ L M2"
using pass_T by blast
have "u ∈ L M1"
unfolding u_def
using a01 a09 a12 a13 converge.simps state_cover_transition_converges by blast
have heuristic_prop: "(⋀T w u' uBest lBest. fst (heuristic T w (uBest, lBest) u') ∈ {u', uBest})"
unfolding heuristic_def
using append_heuristic_input_in append_heuristic_io_in
by fastforce
have "convergence_graph_lookup_invar M1 M2 cg_lookup G1"
using distribute_extension_adds_sequence(2)[OF a01 a03 ‹(V (t_source t)) ∈ L M1› ‹(V (t_source t)) ∈ L M2› a14 a15, of T "[(t_input t, t_output t)]" b heuristic, OF _ heuristic_prop]
using pass_T1
unfolding T1_def G1_def handle_io_pair_def
unfolding heuristic_def[symmetric]
by blast
have "list.set rstates = V ` reachable_states M1"
unfolding rstates_def
using reachable_states_as_list_set by auto
then have "V ` reachable_states M1 ⊆ list.set rstates"
by auto
have "preserves_divergence M1 M2 (list.set rstates)"
unfolding rstates_def
using a10
by (metis image_set reachable_states_as_list_set)
then have "preserves_divergence M1 M2 (V ` reachable_states M1)"
unfolding ‹list.set rstates = V ` reachable_states M1› .
have "(⋀w. w ∈ list.set rstates ⟹ ∃w'. converge M1 w w' ∧ converge M2 w w')"
proof -
fix w assume "w ∈ list.set rstates"
then obtain q where "w = V q" and "q ∈ reachable_states M1"
unfolding rstates_def
using reachable_states_as_list_set by auto
then have "w ∈ L M1" and "w ∈ set T"
using is_state_cover_assignment_language[OF a09] a11 by blast+
then have "w ∈ L M2"
using pass_T by blast
then have "converge M1 w w" and "converge M2 w w"
using ‹w ∈ L M1› by auto
then show "∃w'. converge M1 w w' ∧ converge M2 w w'"
by blast
qed
have "L M1 ∩ V ` reachable_states M1 = L M2 ∩ V ` reachable_states M1"
by (meson a11 inter_eq_subsetI pass_T)
have "converge M1 u v"
unfolding u_def v_def
using a01 a09 a12 a13 state_cover_transition_converges by blast
have "u ∈ L M2"
using distribute_extension_adds_sequence(1)[OF a01 a03 ‹(V (t_source t)) ∈ L M1› ‹(V (t_source t)) ∈ L M2› a14 a15, of T "[(t_input t, t_output t)]" b heuristic, OF _ heuristic_prop]
using pass_T1
unfolding T1_def G1_def handle_io_pair_def
unfolding heuristic_def[symmetric]
by (metis (no_types, lifting) Int_iff ‹V (t_target t) ∈ L M1› ‹converge M1 u v› a01 a02 append_Nil2 converge_append_language_iff u_def v_def)
have "(u = v) = False"
unfolding u_def v_def using a19 by simp
have "after_initial M1 u = t_target t"
using a09 unfolding u_def
by (metis ‹converge M1 u v› ‹t_target t ∈ reachable_states M1› a01 a03 converge.elims(2) convergence_minimal is_state_cover_assignment_observable_after u_def v_def)
have "⋀ γ x y . {u @ ω' | ω'. ω' ∈ list.set (prefixes (γ @ [(x, y)]))} ⊆ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}"
by blast
show "(∀ γ . (length γ ≤ (m-size_r M1) ∧ list.set γ ⊆ inputs M1 × outputs M1 ∧ butlast γ ∈ LS M1 (t_target t))
⟶ ((L M1 ∩ (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)})
= L M2 ∩ (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)}))
∧ preserves_divergence M1 M2 (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)})))
∧ convergence_graph_lookup_invar M1 M2 cg_lookup (snd ?TG)"
proof (cases "d M1 V t X' l")
case True
then have "?TG = (T2,G3)"
unfolding TG_cases by auto
have pass_T2: "L M1 ∩ set T2 = L M2 ∩ set T2"
using a17 unfolding ‹?TG = (T2,G3)› by auto
have "convergence_graph_lookup_invar M1 M2 cg_lookup G2"
and "converge M2 u v"
using pass_T2
using distinguish_from_set_establishes_convergence[OF a01 a02 a03 a04 a05 a06 a07 a08 a09 ‹preserves_divergence M1 M2 (V ` reachable_states M1)› ‹L M1 ∩ V ` reachable_states M1 = L M2 ∩ V ` reachable_states M1› ‹converge M1 u v› ‹u ∈ L M2› ‹v ∈ L M2› ‹convergence_graph_lookup_invar M1 M2 cg_lookup G1› a15 assms, of T1 k b heuristic, OF _ _ _ _ heuristic_prop]
unfolding G2_def T2_def ‹(u = v) = False› rstates_def[symmetric] l_def[symmetric]
by blast+
then have "convergence_graph_lookup_invar M1 M2 cg_lookup (snd ?TG)"
unfolding ‹?TG = (T2,G3)› G3_def snd_conv using a16
by (meson ‹converge M1 u v› convergence_graph_merge_invar_def)
have cons_prop: "⋀γ x y.
length (γ @ [(x, y)]) ≤ l ⟹
γ ∈ LS M1 (after_initial M1 u) ⟹
x ∈ FSM.inputs M1 ⟹
y ∈ FSM.outputs M1 ⟹
L M1 ∩ (list.set rstates ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) =
L M2 ∩ (list.set rstates ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) ∧
preserves_divergence M1 M2 (list.set rstates ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))})"
and nil_prop: "preserves_divergence M1 M2 (list.set rstates ∪ {u, v})"
using pass_T2
using distinguish_from_set_properties(1,2)[OF a01 a02 a03 a04 a07 a08 a09 ‹V ` reachable_states M1 ⊆ list.set rstates› ‹preserves_divergence M1 M2 (list.set rstates)› ‹(⋀w. w ∈ list.set rstates ⟹ ∃w'. converge M1 w w' ∧ converge M2 w w')› ‹converge M1 u v› ‹u ∈ L M2› ‹v ∈ L M2› ‹convergence_graph_lookup_invar M1 M2 cg_lookup G1› a15 assms, of T1 k l b heuristic, OF _ _ _ _ _ heuristic_prop ]
unfolding G2_def T2_def ‹(u = v) = False›
by presburger+
have "⋀ γ . (length γ ≤ (m-size_r M1) ∧ list.set γ ⊆ inputs M1 × outputs M1 ∧ butlast γ ∈ LS M1 (t_target t))
⟹ ((L M1 ∩ (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)})
= L M2 ∩ (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)}))
∧ preserves_divergence M1 M2 (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)}))"
(is "⋀ γ . (length γ ≤ (m-size_r M1) ∧ list.set γ ⊆ inputs M1 × outputs M1 ∧ butlast γ ∈ LS M1 (t_target t)) ⟹ ?P1 γ ∧ ?P2 γ")
proof -
fix γ assume assm:"(length γ ≤ (m-size_r M1) ∧ list.set γ ⊆ inputs M1 × outputs M1 ∧ butlast γ ∈ LS M1 (t_target t))"
show "?P1 γ ∧ ?P2 γ"
proof (cases γ rule: rev_cases)
case Nil
have *: "(V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)})
= (V ` reachable_states M1 ∪ {u})"
unfolding u_def[symmetric] ‹list.set rstates = V ` reachable_states M1› Nil by auto
have "?P1 γ"
using ‹L M1 ∩ V ` reachable_states M1 = L M2 ∩ V ` reachable_states M1›
‹u ∈ L M1› ‹u ∈ L M2›
unfolding * by blast
moreover have "?P2 γ"
using preserves_divergence_subset[OF nil_prop]
unfolding * ‹list.set rstates = V ` reachable_states M1›
by (metis Un_empty_right Un_insert_right Un_upper1 insertI1 insert_subsetI)
ultimately show ?thesis
by simp
next
case (snoc γ' xy)
moreover obtain x y where "xy = (x,y)"
using prod.exhaust by metis
ultimately have "γ = γ'@[(x,y)]"
by auto
have *: "(V ` reachable_states M1 ∪ {u @ ω' |ω'. ω' ∈ list.set (prefixes γ)}) ⊆ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes γ)})"
by blast
have "length (γ' @ [(x, y)]) ≤ l"
using assm unfolding l_def ‹γ = γ'@[(x,y)]› by auto
moreover have "γ' ∈ LS M1 (after_initial M1 u)"
using assm unfolding l_def ‹γ = γ'@[(x,y)]›
by (simp add: ‹after_initial M1 u = t_target t›)
moreover have "x ∈ FSM.inputs M1" and "y ∈ FSM.outputs M1"
using assm unfolding ‹γ = γ'@[(x,y)]› by auto
ultimately show ?thesis
using cons_prop[of γ' x y] preserves_divergence_subset[of M1 M2 "(V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes γ)})", OF _ *]
unfolding ‹γ = γ'@[(x,y)]›[symmetric] u_def[symmetric] ‹list.set rstates = V ` reachable_states M1›
by blast
qed
qed
then show ?thesis
using ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd ?TG)›
by presburger
next
case False
then have "?TG = (TH,GH)"
unfolding TG_cases by auto
have pass_TH: "L M1 ∩ set TH = L M2 ∩ set TH"
using a17 unfolding ‹?TG = (TH,GH)› by auto
have "converge M1 u u"
using ‹u ∈ L M1› by auto
have cons_prop: "⋀γ x y.
length (γ @ [(x, y)]) ≤ l ⟹
γ ∈ LS M1 (t_target t) ⟹
x ∈ FSM.inputs M1 ⟹
y ∈ FSM.outputs M1 ⟹
L M1 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {u, u} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) =
L M2 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {u, u} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) ∧
preserves_divergence M1 M2 (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {u, u} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))})"
and nil_prop: "preserves_divergence M1 M2 (V ` reachable_states M1 ∪ {u,u})"
and "convergence_graph_lookup_invar M1 M2 cg_lookup (snd ?TG)"
using pass_TH
using distinguish_from_set_properties[OF a01 a02 a03 a04 a07 a08 a09 ‹V ` reachable_states M1 ⊆ list.set rstates› ‹preserves_divergence M1 M2 (list.set rstates)› ‹(⋀w. w ∈ list.set rstates ⟹ ∃w'. converge M1 w w' ∧ converge M2 w w')› ‹converge M1 u u› ‹u ∈ L M2› ‹u ∈ L M2› ‹convergence_graph_lookup_invar M1 M2 cg_lookup G1› a15 assms, of T1 k l b heuristic, OF _ _ _ _ _ heuristic_prop ]
unfolding ‹?TG = (TH,GH)› snd_conv
unfolding GH_def TH_def ‹list.set rstates = V ` reachable_states M1› ‹after_initial M1 u = t_target t›
by presburger+
have "⋀ γ . (length γ ≤ (m-size_r M1) ∧ list.set γ ⊆ inputs M1 × outputs M1 ∧ butlast γ ∈ LS M1 (t_target t))
⟹ ((L M1 ∩ (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)})
= L M2 ∩ (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)}))
∧ preserves_divergence M1 M2 (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)}))"
(is "⋀ γ . (length γ ≤ (m-size_r M1) ∧ list.set γ ⊆ inputs M1 × outputs M1 ∧ butlast γ ∈ LS M1 (t_target t)) ⟹ ?P1 γ ∧ ?P2 γ")
proof -
fix γ assume assm:"(length γ ≤ (m-size_r M1) ∧ list.set γ ⊆ inputs M1 × outputs M1 ∧ butlast γ ∈ LS M1 (t_target t))"
show "?P1 γ ∧ ?P2 γ"
proof (cases γ rule: rev_cases)
case Nil
have *: "(V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)})
= (V ` reachable_states M1 ∪ {u})"
unfolding u_def[symmetric] ‹list.set rstates = V ` reachable_states M1› Nil by auto
have "?P1 γ"
using ‹L M1 ∩ V ` reachable_states M1 = L M2 ∩ V ` reachable_states M1›
‹u ∈ L M1› ‹u ∈ L M2›
unfolding * by blast
moreover have "?P2 γ"
using nil_prop
unfolding * by auto
ultimately show ?thesis
by simp
next
case (snoc γ' xy)
moreover obtain x y where "xy = (x,y)"
using prod.exhaust by metis
ultimately have "γ = γ'@[(x,y)]"
by auto
have *: "{ω @ ω' |ω ω'. ω ∈ {u, u} ∧ ω' ∈ list.set (prefixes γ)} = {u @ ω' |ω'. ω' ∈ list.set (prefixes γ)}"
by blast
have "length (γ' @ [(x, y)]) ≤ l"
using assm unfolding l_def ‹γ = γ'@[(x,y)]› by auto
moreover have "γ' ∈ LS M1 (t_target t)"
using assm unfolding l_def ‹γ = γ'@[(x,y)]›
by simp
moreover have "x ∈ FSM.inputs M1" and "y ∈ FSM.outputs M1"
using assm unfolding ‹γ = γ'@[(x,y)]› by auto
ultimately show ?thesis
using cons_prop[of γ' x y]
unfolding ‹γ = γ'@[(x,y)]›[symmetric] u_def[symmetric] ‹list.set rstates = V ` reachable_states M1› *
by blast
qed
qed
then show ?thesis
using ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd ?TG)›
by presburger
qed
qed
show "?P T G m t X"
using * ** *** by blast
qed
then show ?thesis
unfolding handles_transition_def
by blast
qed
subsubsection ‹Static›
fun traces_to_check :: "('a,'b::linorder,'c::linorder) fsm ⇒ 'a ⇒ nat ⇒ ('b×'c) list list" where
"traces_to_check M q 0 = []" |
"traces_to_check M q (Suc k) = (let
ios = List.product (inputs_as_list M) (outputs_as_list M)
in concat (map (λ(x,y) . case h_obs M q x y of None ⇒ [[(x,y)]] | Some q' ⇒ [(x,y)] # (map ((#) (x,y)) (traces_to_check M q' k))) ios))"
lemma traces_to_check_set :
fixes M :: "('a,'b::linorder,'c::linorder) fsm"
assumes "observable M"
and "q ∈ states M"
shows "list.set (traces_to_check M q k) = {(γ @ [(x, y)]) | γ x y . length (γ @ [(x, y)]) ≤ k ∧ γ ∈ LS M q ∧ x ∈ inputs M ∧ y ∈ outputs M}"
using assms(2) proof (induction k arbitrary: q)
case 0
then show ?case by auto
next
case (Suc k)
define ios where ios: "ios = List.product (inputs_as_list M) (outputs_as_list M)"
define f where f: "f = (λ(x,y) . case h_obs M q x y of None ⇒ [[(x,y)]] | Some q' ⇒ [(x,y)] # (map ((#) (x,y)) (traces_to_check M q' k)))"
have "list.set ios = inputs M × outputs M"
using inputs_as_list_set outputs_as_list_set unfolding ios by auto
moreover have "traces_to_check M q (Suc k) = concat (map f ios)"
unfolding f ios by auto
ultimately have in_ex : "⋀ io . io ∈ list.set (traces_to_check M q (Suc k)) ⟷ (∃ x y . x ∈ inputs M ∧ y ∈ outputs M ∧ io ∈ list.set (f (x,y)))"
by auto
show ?case
proof
show "list.set (traces_to_check M q (Suc k)) ⊆ {(γ @ [(x, y)]) | γ x y . length (γ @ [(x, y)]) ≤ (Suc k) ∧ γ ∈ LS M q ∧ x ∈ inputs M ∧ y ∈ outputs M}"
proof
fix io assume "io ∈ list.set (traces_to_check M q (Suc k))"
then obtain x y where "x ∈ inputs M" and "y ∈ outputs M"
and "io ∈ list.set (f (x,y))"
using in_ex by blast
have "[(x,y)] ∈ {(γ @ [(x, y)]) | γ x y . length (γ @ [(x, y)]) ≤ (Suc k) ∧ γ ∈ LS M q ∧ x ∈ inputs M ∧ y ∈ outputs M}"
proof -
have "length ([] @ [(x, y)]) ≤ Suc k"
by auto
moreover have "[] ∈ LS M q"
using Suc.prems by auto
ultimately show ?thesis
using ‹x ∈ inputs M› ‹y ∈ outputs M› by blast
qed
show "io ∈ {(γ @ [(x, y)]) | γ x y . length (γ @ [(x, y)]) ≤ (Suc k) ∧ γ ∈ LS M q ∧ x ∈ inputs M ∧ y ∈ outputs M}"
proof (cases "h_obs M q x y")
case None
then have "io = [(x,y)]"
using ‹io ∈ list.set (f (x,y))› unfolding f by auto
then show ?thesis
using ‹[(x,y)] ∈ {(γ @ [(x, y)]) | γ x y . length (γ @ [(x, y)]) ≤ (Suc k) ∧ γ ∈ LS M q ∧ x ∈ inputs M ∧ y ∈ outputs M}›
by blast
next
case (Some q')
then consider "io = [(x,y)]" | "io ∈ list.set (map ((#) (x,y)) (traces_to_check M q' k))"
using ‹io ∈ list.set (f (x,y))› unfolding f by auto
then show ?thesis proof cases
case 1
then show ?thesis
using ‹[(x,y)] ∈ {(γ @ [(x, y)]) | γ x y . length (γ @ [(x, y)]) ≤ (Suc k) ∧ γ ∈ LS M q ∧ x ∈ inputs M ∧ y ∈ outputs M}›
by blast
next
case 2
then obtain io' where "io = (x,y)#io'" and "io' ∈ list.set (traces_to_check M q' k)"
by auto
then have "io' ∈ {(γ @ [(x, y)]) | γ x y . length (γ @ [(x, y)]) ≤ k ∧ γ ∈ LS M q' ∧ x ∈ inputs M ∧ y ∈ outputs M}"
using Suc.IH[OF h_obs_state[OF Some]] by blast
then obtain γ x' y' where "io' = (γ @ [(x', y')])" and "length (γ @ [(x', y')]) ≤ k" and "γ ∈ LS M q'" and "x' ∈ inputs M" and "y' ∈ outputs M"
by auto
have "length (((x,y)#γ) @ [(x', y')]) ≤ Suc k"
using ‹length (γ @ [(x', y')]) ≤ k› by auto
moreover have "((x,y)#γ) ∈ LS M q"
using ‹γ ∈ LS M q'› Some assms(1)
by (meson h_obs_language_iff)
ultimately show ?thesis
using ‹x' ∈ inputs M› ‹y' ∈ outputs M› unfolding ‹io = (x,y)#io'› ‹io' = (γ @ [(x', y')])›
by auto
qed
qed
qed
show "{γ @ [(x, y)] |γ x y. length (γ @ [(x, y)]) ≤ Suc k ∧ γ ∈ LS M q ∧ x ∈ FSM.inputs M ∧ y ∈ FSM.outputs M} ⊆ list.set (traces_to_check M q (Suc k))"
proof
fix io assume "io ∈ {γ @ [(x, y)] |γ x y. length (γ @ [(x, y)]) ≤ Suc k ∧ γ ∈ LS M q ∧ x ∈ FSM.inputs M ∧ y ∈ FSM.outputs M}"
then obtain γ x' y' where "io = (γ @ [(x', y')])" and "length (γ @ [(x', y')]) ≤ Suc k" and "γ ∈ LS M q" and "x' ∈ inputs M" and "y' ∈ outputs M"
by auto
show "io ∈ list.set (traces_to_check M q (Suc k))"
proof (cases γ)
case Nil
then have "io = [(x',y')]"
using ‹io = (γ @ [(x', y')])› by auto
have "io ∈ list.set (f (x',y'))"
unfolding f case_prod_conv ‹io = [(x',y')]›
by (cases "FSM.h_obs M q x' y'"; auto)
then show ?thesis
using in_ex[of io] ‹x' ∈ inputs M› ‹y' ∈ outputs M› by blast
next
case (Cons xy γ')
obtain x y where "xy = (x,y)"
using prod.exhaust by metis
obtain q' where "h_obs M q x y = Some q'" and "x ∈ inputs M" and "y ∈ outputs M" and "γ' ∈ LS M q'"
using ‹γ ∈ LS M q› unfolding Cons ‹xy = (x,y)›
by (meson assms(1) h_obs_language_iff language_io(1) language_io(2) list.set_intros(1))
then have "γ'@[(x',y')] ∈ {γ @ [(x, y)] |γ x y. length (γ @ [(x, y)]) ≤ k ∧ γ ∈ LS M q' ∧ x ∈ FSM.inputs M ∧ y ∈ FSM.outputs M}"
using ‹length (γ @ [(x', y')]) ≤ Suc k› ‹x' ∈ inputs M› ‹y' ∈ outputs M› unfolding Cons by auto
then have "γ'@[(x',y')] ∈ list.set (traces_to_check M q' k)"
using Suc.IH[OF h_obs_state[OF ‹h_obs M q x y = Some q'›]] by blast
then have "io ∈ list.set (f (x,y))"
unfolding f case_prod_conv ‹h_obs M q x y = Some q'› unfolding ‹io = (γ @ [(x', y')])› Cons ‹xy = (x,y)›
by auto
then show ?thesis
using in_ex[of io] ‹x ∈ inputs M› ‹y ∈ outputs M› by blast
qed
qed
qed
qed
fun establish_convergence_static :: "(nat ⇒ 'a ⇒ ('b×'c) prefix_tree) ⇒
('a::linorder,'b::linorder,'c::linorder) fsm ⇒
('a,'b,'c) state_cover_assignment ⇒
('b×'c) prefix_tree ⇒
'd ⇒
('d ⇒ ('b×'c) list ⇒ 'd) ⇒
('d ⇒ ('b×'c) list ⇒ ('b×'c) list list) ⇒
nat ⇒
('a,'b,'c) transition ⇒
(('b×'c) prefix_tree × 'd)"
where
"establish_convergence_static dist_fun M V T G cg_insert cg_lookup m t =
(let
α = V (t_source t);
xy = (t_input t, t_output t);
β = V (t_target t);
qSource = (after_initial M (V (t_source t)));
qTarget = (after_initial M (V (t_target t)));
k = m - size_r M;
ttc = [] # traces_to_check M qTarget k;
handleTrace = (λ (T,G) u .
if is_in_language M qTarget u
then let
qu = FSM.after M qTarget u;
ws = sorted_list_of_maximal_sequences_in_tree (dist_fun (Suc (length u)) qu);
appendDistTrace = (λ (T,G) w . let
(T',G') = distribute_extension M T G cg_lookup cg_insert α (xy#u@w) False (append_heuristic_input M)
in distribute_extension M T' G' cg_lookup cg_insert β (u@w) False (append_heuristic_input M))
in foldl appendDistTrace (T,G) ws
else let
(T',G') = distribute_extension M T G cg_lookup cg_insert α (xy#u) False (append_heuristic_input M)
in distribute_extension M T' G' cg_lookup cg_insert β u False (append_heuristic_input M))
in
foldl handleTrace (T,G) ttc)"
lemma appendDistTrace_subset_helper :
assumes "appendDistTrace = (λ (T,G) w . let
(T',G') = distribute_extension M T G cg_lookup cg_insert α (xy#u@w) False (append_heuristic_input M)
in distribute_extension M T' G' cg_lookup cg_insert β (u@w) False (append_heuristic_input M))"
shows "set T ⊆ set (fst (appendDistTrace (T,G) w))"
proof -
obtain T' G' where ***: "distribute_extension M T G cg_lookup cg_insert α (xy#u@w) False (append_heuristic_input M) = (T',G')"
using prod.exhaust by metis
show "set T ⊆ set (fst (appendDistTrace (T,G) w))"
using distribute_extension_subset[of T M G cg_lookup cg_insert α "xy#u@w" False "(append_heuristic_input M)"]
using distribute_extension_subset[of T' M G' cg_lookup cg_insert β "u@w" False "(append_heuristic_input M)"]
unfolding assms case_prod_conv *** Let_def fst_conv
by blast
qed
lemma handleTrace_subset_helper :
assumes "handleTrace = (λ (T,G) u .
if is_in_language M qTarget u
then let
qu = FSM.after M qTarget u;
ws = sorted_list_of_maximal_sequences_in_tree (dist_fun (Suc (length u)) qu);
appendDistTrace = (λ (T,G) w . let
(T',G') = distribute_extension M T G cg_lookup cg_insert α (xy#u@w) False (append_heuristic_input M)
in distribute_extension M T' G' cg_lookup cg_insert β (u@w) False (append_heuristic_input M))
in foldl appendDistTrace (T,G) ws
else let
(T',G') = distribute_extension M T G cg_lookup cg_insert α (xy#u) False (append_heuristic_input M)
in distribute_extension M T' G' cg_lookup cg_insert β u False (append_heuristic_input M))"
shows "set T ⊆ set (fst (handleTrace (T,G) u))"
proof (cases "is_in_language M qTarget u")
case True
define qu where qu: "qu = FSM.after M qTarget u"
define ws where ws: "ws = sorted_list_of_maximal_sequences_in_tree (dist_fun (Suc (length u)) qu)"
define appendDistTrace where appendDistTrace: "appendDistTrace = (λ (T,G) w . let
(T',G') = distribute_extension M T G cg_lookup cg_insert α (xy#u@w) False (append_heuristic_input M)
in distribute_extension M T' G' cg_lookup cg_insert β (u@w) False (append_heuristic_input M))"
have **: "handleTrace (T,G) u = foldl appendDistTrace (T,G) ws"
unfolding qu ws appendDistTrace Let_def case_prod_conv assms using True by force
show ?thesis
using appendDistTrace_subset_helper[OF appendDistTrace]
unfolding **
apply (induction ws rule: rev_induct; simp)
by (metis (no_types, opaque_lifting) Collect_mono_iff fst_conv old.prod.exhaust)
next
case False
obtain T' G' where ***: "distribute_extension M T G cg_lookup cg_insert α (xy#u) False (append_heuristic_input M) = (T',G')"
using prod.exhaust by metis
show "set T ⊆ set (fst (handleTrace (T, G) u))"
using distribute_extension_subset[of T M G cg_lookup cg_insert α "xy#u" False "(append_heuristic_input M)"]
using distribute_extension_subset[of T' M G' cg_lookup cg_insert β "u" False "(append_heuristic_input M)"]
using False
unfolding case_prod_conv *** Let_def fst_conv assms
by force
qed
lemma establish_convergence_static_subset :
"set T ⊆ set (fst (establish_convergence_static dist_fun M V T G cg_insert cg_lookup m t))"
proof -
define α where α: "α = V (t_source t)"
define xy where xy: "xy = (t_input t, t_output t)"
define β where β: "β = V (t_target t)"
define qSource where qSource: "qSource = (after_initial M (V (t_source t)))"
define qTarget where qTarget: "qTarget = (after_initial M (V (t_target t)))"
define k where k: "k = m - size_r M"
define ttc where ttc : "ttc = [] # traces_to_check M qTarget k"
define handleTrace where handleTrace: "handleTrace = (λ (T,G) u .
if is_in_language M qTarget u
then let
qu = FSM.after M qTarget u;
ws = sorted_list_of_maximal_sequences_in_tree (dist_fun (Suc (length u)) qu);
appendDistTrace = (λ (T,G) w . let
(T',G') = distribute_extension M T G cg_lookup cg_insert α (xy#u@w) False (append_heuristic_input M)
in distribute_extension M T' G' cg_lookup cg_insert β (u@w) False (append_heuristic_input M))
in foldl appendDistTrace (T,G) ws
else let
(T',G') = distribute_extension M T G cg_lookup cg_insert α (xy#u) False (append_heuristic_input M)
in distribute_extension M T' G' cg_lookup cg_insert β u False (append_heuristic_input M))"
have *:"establish_convergence_static dist_fun M V T G cg_insert cg_lookup m t = foldl handleTrace (T,G) ttc"
unfolding establish_convergence_static.simps α xy β qSource qTarget k ttc handleTrace Let_def by force
show ?thesis
unfolding * proof (induction ttc rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc io ttc)
have *:"foldl handleTrace (T, G) (ttc@[io]) = handleTrace (foldl handleTrace (T,G) ttc) io"
by auto
have "⋀ u T G . set T ⊆ set (fst (handleTrace (T,G) u))"
using handleTrace_subset_helper[of handleTrace] handleTrace
unfolding α xy β qSource qTarget k ttc by blast
then show ?case
unfolding *
by (metis (no_types, opaque_lifting) snoc.IH dual_order.trans fst_conv old.prod.exhaust)
qed
qed
lemma establish_convergence_static_finite :
fixes M :: "('a::linorder,'b::linorder,'c::linorder) fsm"
assumes "finite_tree T"
shows "finite_tree (fst (establish_convergence_static dist_fun M V T G cg_insert cg_lookup m t))"
proof -
define α where α: "α = V (t_source t)"
define xy where xy: "xy = (t_input t, t_output t)"
define β where β: "β = V (t_target t)"
define qSource where qSource: "qSource = (after_initial M (V (t_source t)))"
define qTarget where qTarget: "qTarget = (after_initial M (V (t_target t)))"
define k where k: "k = m - size_r M"
define ttc where ttc : "ttc = [] # traces_to_check M qTarget k"
define handleTrace where handleTrace: "handleTrace = (λ (T,G) u .
if is_in_language M qTarget u
then let
qu = FSM.after M qTarget u;
ws = sorted_list_of_maximal_sequences_in_tree (dist_fun (Suc (length u)) qu);
appendDistTrace = (λ (T,G) w . let
(T',G') = distribute_extension M T G cg_lookup cg_insert α (xy#u@w) False (append_heuristic_input M)
in distribute_extension M T' G' cg_lookup cg_insert β (u@w) False (append_heuristic_input M))
in foldl appendDistTrace (T,G) ws
else let
(T',G') = distribute_extension M T G cg_lookup cg_insert α (xy#u) False (append_heuristic_input M)
in distribute_extension M T' G' cg_lookup cg_insert β u False (append_heuristic_input M))"
have *:"establish_convergence_static dist_fun M V T G cg_insert cg_lookup m t = foldl handleTrace (T,G) ttc"
unfolding establish_convergence_static.simps α xy β qSource qTarget k ttc handleTrace Let_def by force
show ?thesis
unfolding * proof (induction ttc rule: rev_induct)
case Nil
then show ?case using assms by auto
next
case (snoc io ttc)
have *:"foldl handleTrace (T, G) (ttc@[io]) = handleTrace (foldl handleTrace (T,G) ttc) io"
by auto
have "⋀ u T G . finite_tree T ⟹ finite_tree (fst (handleTrace (T,G) u))"
proof -
fix T :: "('b×'c) prefix_tree"
fix u G assume "finite_tree T"
show "finite_tree (fst (handleTrace (T,G) u))" proof (cases "is_in_language M qTarget u")
case True
define qu where qu: "qu = FSM.after M qTarget u"
define ws where ws: "ws = sorted_list_of_maximal_sequences_in_tree (dist_fun (Suc (length u)) qu)"
define appendDistTrace where appendDistTrace: "appendDistTrace = (λ (T,G) w . let
(T',G') = distribute_extension M T G cg_lookup cg_insert α (xy#u@w) False (append_heuristic_input M)
in distribute_extension M T' G' cg_lookup cg_insert β (u@w) False (append_heuristic_input M))"
have **: "handleTrace (T,G) u = foldl appendDistTrace (T,G) ws"
unfolding handleTrace qu ws appendDistTrace Let_def case_prod_conv using True by force
have "⋀ w T G . finite_tree T ⟹ finite_tree (fst (appendDistTrace (T,G) w))"
proof -
fix T :: "('b×'c) prefix_tree"
fix w G assume "finite_tree T"
obtain T' G' where ***: "distribute_extension M T G cg_lookup cg_insert α (xy#u@w) False (append_heuristic_input M) = (T',G')"
using prod.exhaust by metis
show "finite_tree (fst (appendDistTrace (T,G) w))"
using distribute_extension_finite[of T M G cg_lookup cg_insert α "xy#u@w" False "(append_heuristic_input M)", OF ‹finite_tree T›]
using distribute_extension_finite[of T' M G' cg_lookup cg_insert β "u@w" False "(append_heuristic_input M)"]
unfolding appendDistTrace case_prod_conv *** Let_def fst_conv
by blast
qed
then show ?thesis
unfolding ** using ‹finite_tree T›
apply (induction ws rule: rev_induct; simp)
by (metis (no_types, opaque_lifting) fst_conv old.prod.exhaust)
next
case False
obtain T' G' where ***: "distribute_extension M T G cg_lookup cg_insert α (xy#u) False (append_heuristic_input M) = (T',G')"
using prod.exhaust by metis
show "finite_tree (fst (handleTrace (T, G) u))"
using distribute_extension_finite[of T M G cg_lookup cg_insert α "xy#u" False "(append_heuristic_input M)", OF ‹finite_tree T›]
using distribute_extension_finite[of T' M G' cg_lookup cg_insert β "u" False "(append_heuristic_input M)"]
using False
unfolding case_prod_conv *** Let_def fst_conv handleTrace
by force
qed
qed
then show ?case
unfolding *
by (metis (no_types, opaque_lifting) snoc.IH fst_conv old.prod.exhaust)
qed
qed
lemma establish_convergence_static_properties :
assumes "observable M1"
and "observable M2"
and "minimal M1"
and "minimal M2"
and "inputs M2 = inputs M1"
and "outputs M2 = outputs M1"
and "t ∈ transitions M1"
and "t_source t ∈ reachable_states M1"
and "is_state_cover_assignment M1 V"
and "V (t_source t) @ [(t_input t, t_output t)] ∈ L M2"
and "V ` reachable_states M1 ⊆ set T"
and "preserves_divergence M1 M2 (V ` reachable_states M1)"
and "convergence_graph_lookup_invar M1 M2 cg_lookup G"
and "convergence_graph_insert_invar M1 M2 cg_lookup cg_insert"
and "⋀ q1 q2 . q1 ∈ states M1 ⟹ q2 ∈ states M1 ⟹ q1 ≠ q2 ⟹ ∃ io . ∀ k1 k2 . io ∈ set (dist_fun k1 q1) ∩ set (dist_fun k2 q2) ∧ distinguishes M1 q1 q2 io"
and "⋀ q . q ∈ reachable_states M1 ⟹ set (dist_fun 0 q) ⊆ set (after T (V q))"
and "⋀ q k . q ∈ states M1 ⟹ finite_tree (dist_fun k q)"
and "L M1 ∩ set (fst (establish_convergence_static dist_fun M1 V T G cg_insert cg_lookup m t)) = L M2 ∩ set (fst (establish_convergence_static dist_fun M1 V T G cg_insert cg_lookup m t))"
shows "∀ γ x y . length (γ@[(x,y)]) ≤ m - size_r M1 ⟶
γ ∈ LS M1 (after_initial M1 (V (t_source t) @ [(t_input t, t_output t)])) ⟶
x ∈ inputs M1 ⟶ y ∈ outputs M1 ⟶
L M1 ∩ ((V ` reachable_states M1) ∪ {ω@ω' | ω ω' . ω ∈ {((V (t_source t)) @ [(t_input t,t_output t)]), (V (t_target t))} ∧ ω' ∈ list.set (prefixes (γ@[(x,y)]))}) = L M2 ∩ ((V ` reachable_states M1) ∪ {ω@ω' | ω ω' . ω ∈ {((V (t_source t)) @ [(t_input t,t_output t)]), (V (t_target t))} ∧ ω' ∈ list.set (prefixes (γ@[(x,y)]))})
∧ preserves_divergence M1 M2 ((V ` reachable_states M1) ∪ {ω@ω' | ω ω' . ω ∈ {((V (t_source t)) @ [(t_input t,t_output t)]), (V (t_target t))} ∧ ω' ∈ list.set (prefixes (γ@[(x,y)]))})"
(is "?P1a")
and "preserves_divergence M1 M2 ((V ` reachable_states M1) ∪ {((V (t_source t)) @ [(t_input t,t_output t)]), (V (t_target t))})"
(is "?P1b")
and "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (establish_convergence_static dist_fun M1 V T G cg_insert cg_lookup m t))"
(is "?P2")
proof -
define α where α: "α = V (t_source t)"
define xy where xy: "xy = (t_input t, t_output t)"
define β where β: "β = V (t_target t)"
define qSource where qSource: "qSource = (after_initial M1 (V (t_source t)))"
define qTarget where qTarget: "qTarget = (after_initial M1 (V (t_target t)))"
define k where k: "k = m - size_r M1"
define ttc where ttc : "ttc = [] # traces_to_check M1 qTarget k"
define handleTrace where handleTrace: "handleTrace = (λ (T,G) u .
if is_in_language M1 qTarget u
then let
qu = FSM.after M1 qTarget u;
ws = sorted_list_of_maximal_sequences_in_tree (dist_fun (Suc (length u)) qu);
appendDistTrace = (λ (T,G) w . let
(T',G') = distribute_extension M1 T G cg_lookup cg_insert α (xy#u@w) False (append_heuristic_input M1)
in distribute_extension M1 T' G' cg_lookup cg_insert β (u@w) False (append_heuristic_input M1))
in foldl appendDistTrace (T,G) ws
else let
(T',G') = distribute_extension M1 T G cg_lookup cg_insert α (xy#u) False (append_heuristic_input M1)
in distribute_extension M1 T' G' cg_lookup cg_insert β u False (append_heuristic_input M1))"
have result: "establish_convergence_static dist_fun M1 V T G cg_insert cg_lookup m t = foldl handleTrace (T,G) ttc"
unfolding establish_convergence_static.simps α xy β qSource qTarget k ttc handleTrace Let_def by force
then have result_pass: "L M1 ∩ set (fst (foldl handleTrace (T,G) ttc)) = L M2 ∩ set (fst (foldl handleTrace (T,G) ttc))"
using assms(18) by auto
have "V (t_source t) ∈ L M1" and "t_source t = qSource"
using state_cover_assignment_after[OF assms(1,9,8)] unfolding qSource by auto
then have "qSource ∈ states M1"
unfolding qSource
by (simp add: assms(8) reachable_state_is_state)
have "α ∈ L M1"
using ‹V (t_source t) ∈ L M1› unfolding α by auto
have "α ∈ L M2"
by (metis α assms(10) language_prefix)
have "qTarget ∈ reachable_states M1"
using reachable_states_next[OF assms(8,7)] unfolding qTarget
by (metis assms(1) assms(9) is_state_cover_assignment_observable_after)
then have "qTarget ∈ states M1"
using reachable_state_is_state by metis
have "V (t_target t) ∈ L M1"
by (meson assms(7) assms(8) assms(9) is_state_cover_assignment_language reachable_states_next)
then have "β ∈ L M1"
unfolding β by auto
have "t_target t = qTarget"
by (metis assms(1) assms(7) assms(8) assms(9) is_state_cover_assignment_observable_after qTarget reachable_states_next)
have "converge M1 (α@[xy]) β"
using state_cover_transition_converges[OF assms(1,9,7,8)]
unfolding α xy β .
then have "α@[xy] ∈ L M1"
by auto
have "L M1 ∩ set T = L M2 ∩ set T"
using assms(18) establish_convergence_static_subset[of T dist_fun M1 V G cg_insert cg_lookup m t]
by blast
then have "β ∈ L M2"
using reachable_states_next[OF assms(8,7)] assms(11) ‹β ∈ L M1›
unfolding β qTarget by blast
have "(∀ u w . u ∈ list.set ttc ⟶ u ∈ LS M1 qTarget ⟶ w ∈ set (dist_fun (Suc (length u)) (FSM.after M1 qTarget u)) ⟶ L M1 ∩ {α @ [xy] @ u @ w, β @ u @ w} = L M2 ∩ {α @ [xy] @ u @ w, β @ u @ w})
∧ (∀ u w . u ∈ list.set ttc ⟶ u ∉ LS M1 qTarget ⟶ L M1 ∩ {α@[xy]@u,β@u} = L M2 ∩ {α@[xy]@u,β@u})
∧ (convergence_graph_lookup_invar M1 M2 cg_lookup (snd (foldl handleTrace (T,G) ttc)))"
using result_pass
proof (induction ttc rule: rev_induct)
case Nil
then show ?case using assms(13) by auto
next
case (snoc a ttc)
have *:"foldl handleTrace (T, G) (ttc@[a]) = handleTrace (foldl handleTrace (T,G) ttc) a"
by auto
have "L M1 ∩ Prefix_Tree.set (fst (foldl handleTrace (T, G) ttc)) = L M2 ∩ Prefix_Tree.set (fst (foldl handleTrace (T, G) ttc))"
using snoc.prems handleTrace_subset_helper[of handleTrace M1 qTarget dist_fun cg_lookup cg_insert, OF handleTrace]
unfolding *
by (metis (no_types, opaque_lifting) fst_conv inter_eq_subsetI old.prod.exhaust)
then have IH1: "⋀ u w. u ∈ list.set ttc ⟹ u ∈ LS M1 qTarget ⟹ w ∈ Prefix_Tree.set (dist_fun (Suc (length u)) (FSM.after M1 qTarget u)) ⟹ L M1 ∩ {α @ [xy] @ u @ w, β @ u @ w} = L M2 ∩ {α @ [xy] @ u @ w, β @ u @ w}"
and IH2: "⋀u w. u ∈ list.set ttc ⟹ u ∉ LS M1 qTarget ⟹ L M1 ∩ {α @ [xy] @ u, β @ u} = L M2 ∩ {α @ [xy] @ u, β @ u}"
and IH3: "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (foldl handleTrace (T, G) ttc))"
using snoc.IH
by presburger+
show ?case proof (cases "is_in_language M1 qTarget a")
case True
define qa where qa: "qa = FSM.after M1 qTarget a"
define ws where ws: "ws = sorted_list_of_maximal_sequences_in_tree (dist_fun (Suc (length a)) qa)"
define appendDistTrace where appendDistTrace: "appendDistTrace = (λ (T,G) w . let
(T',G') = distribute_extension M1 T G cg_lookup cg_insert α (xy#a@w) False (append_heuristic_input M1)
in distribute_extension M1 T' G' cg_lookup cg_insert β (a@w) False (append_heuristic_input M1))"
have **: "⋀ TG . handleTrace TG a = foldl appendDistTrace TG ws"
using ‹is_in_language M1 qTarget a›
unfolding qa ws appendDistTrace Let_def case_prod_conv assms True handleTrace by force
have "foldl handleTrace (T, G) (ttc@[a]) = foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws"
unfolding *
unfolding True
unfolding ** by auto
then have "L M1 ∩ set (fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws)) = L M2 ∩ set (fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws))"
using snoc.prems by metis
then have handleTrace_props: "(∀ w . w ∈ list.set ws ⟶ ((∃ α' . converge M1 α α' ∧ (α'@[xy]@a@w) ∈ set (fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws)) ∧ converge M2 α α')
∧ (∃ β' . converge M1 β β' ∧ (β'@a@w) ∈ set (fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws)) ∧ converge M2 β β')))
∧ convergence_graph_lookup_invar M1 M2 cg_lookup (snd (foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws))"
proof (induction ws rule: rev_induct)
case Nil
then show ?case using IH3 by auto
next
case (snoc v ws)
have *:"foldl appendDistTrace (foldl handleTrace (T, G) ttc) (ws@[v]) = appendDistTrace (foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws) v"
by auto
define Tws where Tws: "Tws = fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws)"
define Gws where Gws: "Gws = snd (foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws)"
have "(foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws) = (Tws,Gws)"
unfolding Tws Gws by auto
obtain T' G' where "distribute_extension M1 Tws Gws cg_lookup cg_insert α (xy#a@v) False (append_heuristic_input M1) = (T',G')"
using prod.exhaust by metis
have **: "appendDistTrace (foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws) v
= distribute_extension M1 T' G' cg_lookup cg_insert β (a@v) False (append_heuristic_input M1)"
using ‹distribute_extension M1 Tws Gws cg_lookup cg_insert α (xy # a @ v) False (append_heuristic_input M1) = (T', G')› ‹foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws = (Tws, Gws)› appendDistTrace by auto
have pass_outer : "L M1 ∩ set (fst (distribute_extension M1 T' G' cg_lookup cg_insert β (a@v) False (append_heuristic_input M1)))
= L M2 ∩ set (fst (distribute_extension M1 T' G' cg_lookup cg_insert β (a@v) False (append_heuristic_input M1)))"
using snoc.prems unfolding * ** .
moreover have "set (fst (distribute_extension M1 Tws Gws cg_lookup cg_insert α (xy#a@v) False (append_heuristic_input M1))) ⊆ set (fst (distribute_extension M1 T' G' cg_lookup cg_insert β (a@v) False (append_heuristic_input M1)))"
using distribute_extension_subset[of T' M1 G' cg_lookup cg_insert β "(a@v)" False "(append_heuristic_input M1)"]
using ‹distribute_extension M1 Tws Gws cg_lookup cg_insert α (xy#a@v) False (append_heuristic_input M1) = (T',G')›
by (metis fst_conv)
ultimately have pass_inner: "L M1 ∩ set (fst (distribute_extension M1 Tws Gws cg_lookup cg_insert α (xy#a@v) False (append_heuristic_input M1)))
= L M2 ∩ set (fst (distribute_extension M1 Tws Gws cg_lookup cg_insert α (xy#a@v) False (append_heuristic_input M1)))"
by blast
then have pass_ws: "L M1 ∩ Prefix_Tree.set (fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws)) =
L M2 ∩ Prefix_Tree.set (fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws))"
using distribute_extension_subset[of Tws M1 Gws cg_lookup cg_insert]
unfolding Tws Gws
by blast
have "set (fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws)) ⊆ set (fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) (ws@[v])))"
using appendDistTrace_subset_helper[OF appendDistTrace]
by (metis "*" Tws ‹foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws = (Tws, Gws)›)
have "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws))"
using snoc.IH[OF pass_ws ] by auto
then have "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (distribute_extension M1 Tws Gws cg_lookup cg_insert α (xy#a@v) False (append_heuristic_input M1)))"
using distribute_extension_adds_sequence(2)[OF assms(1,3) ‹α ∈ L M1› ‹α ∈ L M2› _ assms(14) pass_inner append_heuristic_input_in]
unfolding Gws by blast
then have "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (appendDistTrace (foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws) v))"
unfolding ** ‹distribute_extension M1 Tws Gws cg_lookup cg_insert α (xy#a@v) False (append_heuristic_input M1) = (T',G')› snd_conv
using distribute_extension_adds_sequence(2)[OF assms(1,3) ‹β ∈ L M1› ‹β ∈ L M2› _ assms(14) pass_outer append_heuristic_input_in]
by blast
moreover have "⋀ w . w ∈ list.set (ws@[v]) ⟹ ((∃ α' . converge M1 α α' ∧ (α'@[xy]@a@w) ∈ set (fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) (ws@[v]))) ∧ converge M2 α α')
∧ (∃ β' . converge M1 β β' ∧ (β'@a@w) ∈ set (fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) (ws@[v]))) ∧ converge M2 β β'))"
proof -
fix w assume "w ∈ list.set (ws@[v])"
then consider "w ∈ list.set ws" | "v = w"
by auto
then show "((∃ α' . converge M1 α α' ∧ (α'@[xy]@a@w) ∈ set (fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) (ws@[v]))) ∧ converge M2 α α')
∧ (∃ β' . converge M1 β β' ∧ (β'@a@w) ∈ set (fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) (ws@[v]))) ∧ converge M2 β β'))"
proof cases
case 1
then show ?thesis using snoc.IH[OF pass_ws]
using ‹set (fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws)) ⊆ set (fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) (ws@[v])))›
by blast
next
case 2
have "∃u'. converge M1 α u' ∧ u' @ xy # a @ w ∈ set T' ∧ converge M2 α u'"
using distribute_extension_adds_sequence(1)[OF assms(1,3) ‹α ∈ L M1› ‹α ∈ L M2› _ assms(14) pass_inner append_heuristic_input_in]
‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd (foldl appendDistTrace (foldl handleTrace (T, G) ttc) ws))›
unfolding Gws[symmetric]
unfolding ‹distribute_extension M1 Tws Gws cg_lookup cg_insert α (xy#a@v) False (append_heuristic_input M1) = (T',G')›
unfolding 2 fst_conv
by blast
then have "(∃ α' . converge M1 α α' ∧ (α'@[xy]@a@w) ∈ set (fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) (ws@[v]))) ∧ converge M2 α α')"
using "**" ‹Prefix_Tree.set (fst (distribute_extension M1 Tws Gws cg_lookup cg_insert α (xy # a @ v) False (append_heuristic_input M1))) ⊆ Prefix_Tree.set (fst (distribute_extension M1 T' G' cg_lookup cg_insert β (a @ v) False (append_heuristic_input M1)))› ‹distribute_extension M1 Tws Gws cg_lookup cg_insert α (xy # a @ v) False (append_heuristic_input M1) = (T', G')› by auto
moreover have "(∃ β' . converge M1 β β' ∧ (β'@a@w) ∈ set (fst (foldl appendDistTrace (foldl handleTrace (T, G) ttc) (ws@[v]))) ∧ converge M2 β β')"
using distribute_extension_adds_sequence(1)[OF assms(1,3) ‹β ∈ L M1› ‹β ∈ L M2› _ assms(14) pass_outer append_heuristic_input_in]
using ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd (distribute_extension M1 Tws Gws cg_lookup cg_insert α (xy#a@v) False (append_heuristic_input M1)))›
unfolding ‹distribute_extension M1 Tws Gws cg_lookup cg_insert α (xy#a@v) False (append_heuristic_input M1) = (T',G')› snd_conv
unfolding * **
unfolding 2
by blast
ultimately show ?thesis by blast
qed
qed
ultimately show ?case
by fastforce
qed
have "⋀ u w. u ∈ list.set (ttc@[a]) ⟹ u ∈ LS M1 qTarget ⟹ w ∈ Prefix_Tree.set (dist_fun (Suc (length u)) (FSM.after M1 qTarget u)) ⟹ L M1 ∩ {α @ [xy] @ u @ w, β @ u @ w} = L M2 ∩ {α @ [xy] @ u @ w, β @ u @ w}"
proof -
fix u w assume "u ∈ list.set (ttc@[a])" and a1:"u ∈ LS M1 qTarget" and a2:"w ∈ Prefix_Tree.set (dist_fun (Suc (length u)) (FSM.after M1 qTarget u))"
then consider "u ∈ list.set ttc" | "a = u"
by auto
then show "L M1 ∩ {α @ [xy] @ u @ w, β @ u @ w} = L M2 ∩ {α @ [xy] @ u @ w, β @ u @ w}"
proof cases
case 1
then show ?thesis
using IH1[OF _ a1 a2] by blast
next
case 2
obtain w' where "w@w' ∈ list.set ws"
proof -
have "qa ∈ reachable_states M1"
using ‹qTarget ∈ reachable_states M1› ‹u ∈ LS M1 qTarget›
by (metis "2" after_reachable assms(1) qa)
then have "finite_tree (dist_fun (Suc (length u)) qa)"
using ‹⋀ q k . q ∈ states M1 ⟹ finite_tree (dist_fun k q)› reachable_state_is_state[of qa M1]
by blast
moreover have "w ∈ set (dist_fun (Suc (length u)) qa)"
using ‹w ∈ set (dist_fun (Suc (length u)) (FSM.after M1 qTarget u))›
unfolding qa 2 .
ultimately show ?thesis
using sorted_list_of_maximal_sequences_in_tree_ob[of "dist_fun (Suc (length u)) qa" w]
using that unfolding ws 2 by blast
qed
then obtain α' β' where "converge M1 α α'" and "α' @ [xy] @ a @ w@w' ∈ Prefix_Tree.set (fst (foldl handleTrace (T, G) (ttc@[a])))" and "converge M2 α α'"
and "converge M1 β β'" and "β' @ a @ w@w' ∈ Prefix_Tree.set (fst (foldl handleTrace (T, G) (ttc@[a])))" and "converge M2 β β'"
using handleTrace_props
unfolding **[symmetric] *[symmetric]
by blast
then have "α' @ [xy] @ a @ w ∈ Prefix_Tree.set (fst (foldl handleTrace (T, G) (ttc@[u])))"
and "β' @ a @ w ∈ Prefix_Tree.set (fst (foldl handleTrace (T, G) (ttc@[u])))"
using set_prefix[of "α' @ [xy] @ a @ w" w']
using set_prefix[of "β' @ a @ w" w']
unfolding 2
by auto
have "α @ [xy] @ u @ w ∈ L M1 = (α' @ [xy] @ u @ w ∈ L M1)"
using ‹converge M1 α α'›
using assms(1) converge_append_language_iff by blast
also have "… = (α' @ [xy] @ u @ w ∈ L M2)"
using ‹α' @ [xy] @ a @ w ∈ Prefix_Tree.set (fst (foldl handleTrace (T, G) (ttc@[u])))›
using snoc.prems unfolding 2
by blast
also have "… = (α @ [xy] @ u @ w ∈ L M2)"
using ‹converge M2 α α'›
using assms(2) converge_append_language_iff by blast
finally have "α @ [xy] @ u @ w ∈ L M1 = (α @ [xy] @ u @ w ∈ L M2)" .
have "β @ u @ w ∈ L M1 = (β' @ u @ w ∈ L M1)"
using ‹converge M1 β β'›
using assms(1) converge_append_language_iff by blast
also have "… = (β' @ u @ w ∈ L M2)"
using ‹β' @ a @ w ∈ Prefix_Tree.set (fst (foldl handleTrace (T, G) (ttc@[u])))›
using snoc.prems unfolding 2
by blast
also have "… = (β @ u @ w ∈ L M2)"
using ‹converge M2 β β'›
using assms(2) converge_append_language_iff by blast
finally have "β @ u @ w ∈ L M1 = (β @ u @ w ∈ L M2)" .
then show ?thesis
using ‹α @ [xy] @ u @ w ∈ L M1 = (α @ [xy] @ u @ w ∈ L M2)›
by blast
qed
qed
moreover have "⋀ u w . u ∈ list.set (ttc@[a]) ⟹ u ∉ LS M1 qTarget ⟹ L M1 ∩ {α @ [xy] @ u, β @ u} = L M2 ∩ {α @ [xy] @ u, β @ u}"
proof -
fix u w assume "u ∈ list.set (ttc@[a])" and "u ∉ LS M1 qTarget"
then have "u ≠ a"
using True
unfolding is_in_language_iff[OF assms(1) ‹qTarget ∈ states M1›]
by auto
then have "u ∈ list.set ttc"
using ‹u ∈ list.set (ttc@[a])› by auto
then show "L M1 ∩ {α @ [xy] @ u, β @ u} = L M2 ∩ {α @ [xy] @ u, β @ u}"
using IH2[OF _ ‹u ∉ LS M1 qTarget›] by blast
qed
moreover have "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (foldl handleTrace (T, G) (ttc@[a])))"
using handleTrace_props unfolding * ** by blast
ultimately show ?thesis
by blast
next
case False
define Tc where Tc: "Tc = fst (foldl handleTrace (T, G) ttc)"
define Gc where Gc: "Gc = snd (foldl handleTrace (T, G) ttc)"
have "(foldl handleTrace (T, G) ttc) = (Tc,Gc)"
unfolding Tc Gc by auto
define T' where T': "T' = fst (distribute_extension M1 Tc Gc cg_lookup cg_insert α (xy#a) False (append_heuristic_input M1))"
define G' where G': "G' = snd (distribute_extension M1 Tc Gc cg_lookup cg_insert α (xy#a) False (append_heuristic_input M1))"
have **: "handleTrace (foldl handleTrace (T,G) ttc) a = distribute_extension M1 T' G' cg_lookup cg_insert β a False (append_heuristic_input M1)"
using False
unfolding ‹(foldl handleTrace (T, G) ttc) = (Tc,Gc)›
unfolding handleTrace
unfolding case_prod_conv Let_def
unfolding T' G' Tc Gc
by (meson case_prod_beta')
have pass_outer : "L M1 ∩ set (fst (distribute_extension M1 T' G' cg_lookup cg_insert β a False (append_heuristic_input M1)))
= L M2 ∩ set (fst (distribute_extension M1 T' G' cg_lookup cg_insert β a False (append_heuristic_input M1)))"
using snoc.prems unfolding * ** .
moreover have "set (fst (distribute_extension M1 Tc Gc cg_lookup cg_insert α (xy#a) False (append_heuristic_input M1))) ⊆ set (fst (distribute_extension M1 T' G' cg_lookup cg_insert β (a) False (append_heuristic_input M1)))"
using distribute_extension_subset[of T' M1 G' cg_lookup cg_insert β "a" False "(append_heuristic_input M1)"]
using ‹(foldl handleTrace (T, G) ttc) = (Tc,Gc)›
using T' by blast
ultimately have pass_inner: "L M1 ∩ set (fst (distribute_extension M1 Tc Gc cg_lookup cg_insert α (xy#a) False (append_heuristic_input M1)))
= L M2 ∩ set (fst (distribute_extension M1 Tc Gc cg_lookup cg_insert α (xy#a) False (append_heuristic_input M1)))"
by blast
have "convergence_graph_lookup_invar M1 M2 cg_lookup Gc"
using snoc.IH[OF ‹L M1 ∩ Prefix_Tree.set (fst (foldl handleTrace (T, G) ttc)) = L M2 ∩ Prefix_Tree.set (fst (foldl handleTrace (T, G) ttc))›]
unfolding Gc by blast
then have "convergence_graph_lookup_invar M1 M2 cg_lookup G'"
using distribute_extension_adds_sequence(2)[OF assms(1,3) ‹α ∈ L M1› ‹α ∈ L M2› _ assms(14) pass_inner append_heuristic_input_in]
unfolding G' by blast
then have "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (foldl handleTrace (T, G) (ttc@[a])))"
unfolding * **
using distribute_extension_adds_sequence(2)[OF assms(1,3) ‹β ∈ L M1› ‹β ∈ L M2› _ assms(14) pass_outer append_heuristic_input_in]
by blast
moreover have "⋀ u w. u ∈ list.set (ttc@[a]) ⟹ u ∈ LS M1 qTarget ⟹ w ∈ Prefix_Tree.set (dist_fun (Suc (length u)) (FSM.after M1 qTarget u)) ⟹ L M1 ∩ {α @ [xy] @ u @ w, β @ u @ w} = L M2 ∩ {α @ [xy] @ u @ w, β @ u @ w}"
proof -
fix u w assume "u ∈ list.set (ttc@[a])" and a1:"u ∈ LS M1 qTarget" and a2:"w ∈ Prefix_Tree.set (dist_fun (Suc (length u)) (FSM.after M1 qTarget u))"
then have "u ≠ a"
using False
unfolding is_in_language_iff[OF assms(1) ‹qTarget ∈ states M1›]
by auto
then have "u ∈ list.set ttc"
using ‹u ∈ list.set (ttc@[a])› by auto
then show "L M1 ∩ {α @ [xy] @ u @ w, β @ u @ w} = L M2 ∩ {α @ [xy] @ u @ w, β @ u @ w}"
using IH1[OF _ a1 a2]
by blast
qed
moreover have "⋀ u w . u ∈ list.set (ttc@[a]) ⟹ u ∉ LS M1 qTarget ⟹ L M1 ∩ {α @ [xy] @ u, β @ u} = L M2 ∩ {α @ [xy] @ u, β @ u}"
proof -
fix u w assume "u ∈ list.set (ttc@[a])" and "u ∉ LS M1 qTarget"
then consider "u ∈ list.set ttc" | "a = u"
by auto
then show "L M1 ∩ {α @ [xy] @ u, β @ u} = L M2 ∩ {α @ [xy] @ u, β @ u}" proof cases
case 1
then show ?thesis
using IH2[OF _ ‹u ∉ LS M1 qTarget›] by blast
next
case 2
obtain α' where "converge M1 α α'" and "α' @ xy # a ∈ set (fst (foldl handleTrace (T, G) (ttc@[a])))" and "converge M2 α α'"
using distribute_extension_adds_sequence(1)[OF assms(1,3) ‹α ∈ L M1› ‹α ∈ L M2› _ assms(14) pass_inner append_heuristic_input_in] ‹convergence_graph_lookup_invar M1 M2 cg_lookup Gc›
unfolding T'[symmetric]
using distribute_extension_subset[of T' M1 G' cg_lookup cg_insert β "a" False "(append_heuristic_input M1)"]
unfolding * ** by blast
have "⋀ α' . α' @ xy # u = α' @ [xy] @ u"
by auto
obtain β' where "converge M1 β β'" and "β' @ a ∈ set (fst (foldl handleTrace (T, G) (ttc@[a])))" and "converge M2 β β'"
using distribute_extension_adds_sequence(1)[OF assms(1,3) ‹β ∈ L M1› ‹β ∈ L M2› _ assms(14) pass_outer append_heuristic_input_in] ‹convergence_graph_lookup_invar M1 M2 cg_lookup G'›
unfolding * ** by blast
have "α @ [xy] @ u ∈ L M1 = (α' @ [xy] @ u ∈ L M1)"
using ‹converge M1 α α'›
using assms(1) converge_append_language_iff by blast
also have "… = (α' @ [xy] @ u ∈ L M2)"
using ‹α' @ xy # a ∈ Prefix_Tree.set (fst (foldl handleTrace (T, G) (ttc@[a])))›
using snoc.prems unfolding 2 ‹⋀ α' . α' @ xy # u = α' @ [xy] @ u›
by blast
also have "… = (α @ [xy] @ u ∈ L M2)"
using ‹converge M2 α α'›
using assms(2) converge_append_language_iff by blast
finally have "α @ [xy] @ u ∈ L M1 = (α @ [xy] @ u ∈ L M2)" .
have "β @ u ∈ L M1 = (β' @ u ∈ L M1)"
using ‹converge M1 β β'›
using assms(1) converge_append_language_iff by blast
also have "… = (β' @ u ∈ L M2)"
using ‹β' @ a ∈ Prefix_Tree.set (fst (foldl handleTrace (T, G) (ttc@[a])))›
using snoc.prems unfolding 2
by blast
also have "… = (β @ u ∈ L M2)"
using ‹converge M2 β β'›
using assms(2) converge_append_language_iff by blast
finally have "β @ u ∈ L M1 = (β @ u ∈ L M2)" .
then show ?thesis
using ‹α @ [xy] @ u ∈ L M1 = (α @ [xy] @ u ∈ L M2)›
by blast
qed
qed
ultimately show ?thesis
by blast
qed
qed
then have handleTrace_foldl_props_1: "⋀ u w. u ∈ list.set ttc ⟹
u ∈ LS M1 qTarget ⟹
w ∈ Prefix_Tree.set (dist_fun (Suc (length u)) (FSM.after M1 qTarget u)) ⟹
L M1 ∩ {α @ [xy] @ u @ w, β @ u @ w} = L M2 ∩ {α @ [xy] @ u @ w, β @ u @ w}"
and handleTrace_foldl_props_2: "⋀u w. u ∈ list.set ttc ⟹ u ∉ LS M1 qTarget ⟹ L M1 ∩ {α @ [xy] @ u, β @ u} = L M2 ∩ {α @ [xy] @ u, β @ u}"
and "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (foldl handleTrace (T, G) ttc))"
by presburger+
then show "?P2"
unfolding result by blast
show "preserves_divergence M1 M2 ((V ` reachable_states M1) ∪ {((V (t_source t)) @ [(t_input t,t_output t)]), (V (t_target t))})"
proof -
let ?w = "((V (t_source t)) @ [(t_input t,t_output t)])"
have "V (t_target t) ∈ (V ` reachable_states M1)"
by (simp add: ‹qTarget ∈ reachable_states M1› ‹t_target t = qTarget›)
then have "((V ` reachable_states M1) ∪ {((V (t_source t)) @ [(t_input t,t_output t)]), (V (t_target t))}) = Set.insert ((V (t_source t)) @ [(t_input t,t_output t)]) (V ` reachable_states M1)"
by blast
moreover have "Set.insert ?w (V ` reachable_states M1) ⊆ L M1"
using state_cover_assignment_language[OF assms(9)]
using α ‹converge M1 (α @ [xy]) β› xy by auto
ultimately have *:"L M1 ∩ (V ` reachable_states M1 ∪ {V (t_source t) @ [(t_input t, t_output t)], V (t_target t)}) = Set.insert ?w (V ` reachable_states M1)"
and **:"L M1 ∩ (V ` reachable_states M1) = (V ` reachable_states M1)"
by blast+
have "⋀ u . u ∈ Set.insert ?w (V ` reachable_states M1) ⟹ ¬converge M1 u ?w ⟹ ¬converge M2 u ?w"
proof -
fix u assume "u ∈ Set.insert ?w (V ` reachable_states M1)" and "¬converge M1 u ?w"
moreover have "converge M1 ?w ?w"
using ‹α@[xy] ∈ L M1› unfolding α xy by auto
ultimately have "u ∈ (V ` reachable_states M1)"
by auto
have "¬converge M1 u β"
using ‹¬converge M1 u ?w› ‹converge M1 (α@[xy]) β› unfolding α xy β
by auto
have "β = V qTarget"
by (simp add: β ‹t_target t = qTarget›)
obtain qU where "qU ∈ reachable_states M1" and "u = V qU"
using ‹u ∈ (V ` reachable_states M1)› by blast
then have "qU = after_initial M1 u"
using state_cover_assignment_after[OF assms(1,9)] by metis
then have "qU ≠ qTarget"
using ‹¬converge M1 u β›
using β ‹β ∈ L M1› ‹t_target t = qTarget› ‹u = V qU› by fastforce
then obtain w where "∀ k1 k2 . w ∈ set (dist_fun k1 qU) ∩ set (dist_fun k2 qTarget)" and "distinguishes M1 qU qTarget w"
using assms(15)[OF reachable_state_is_state[OF ‹qU ∈ reachable_states M1›] ‹qTarget ∈ states M1›]
by blast
then have "w ∈ set (after T (V qU))" and "w ∈ set (after T (V qTarget))"
using assms(16)[OF ‹qU ∈ reachable_states M1›]
using assms(16)[OF ‹qTarget ∈ reachable_states M1›]
by blast+
have "[] ∈ list.set ttc"
unfolding ttc by auto
moreover have "[] ∈ LS M1 qTarget"
using ‹qTarget ∈ states M1› by auto
moreover have "w ∈ set (dist_fun (Suc (length [])) (FSM.after M1 qTarget []))"
using ‹∀ k1 k2 . w ∈ set (dist_fun k1 qU) ∩ set (dist_fun k2 qTarget)› by auto
ultimately have "L M1 ∩ {?w @ w, β @ w} = L M2 ∩ {?w @ w, β @ w}"
using handleTrace_foldl_props_1[of "[]" w]
unfolding α xy
by auto
moreover have "(?w @ w ∈ L M1) = (β@w ∈ L M1)"
using converge_extend[OF assms(1) ‹converge M1 (α@[xy]) β› _ ‹β ∈ L M1›, of w]
using converge_extend[OF assms(1) _ _ ‹α@[xy] ∈ L M1›, of β w]
using ‹converge M1 (α@[xy]) β› unfolding converge_sym[where u=β]
unfolding α[symmetric] xy[symmetric]
by blast
ultimately have "(?w @ w ∈ L M2) = (β@w ∈ L M2)"
by blast
have "(w ∈ LS M1 qU) ≠ (w ∈ LS M1 qTarget)"
using ‹distinguishes M1 qU qTarget w›
unfolding distinguishes_def
by blast
moreover have "(w ∈ LS M1 qU) = (u@w ∈ L M1)"
by (metis "**" IntD1 ‹qU = after_initial M1 u› ‹u ∈ V ` reachable_states M1› after_language_iff assms(1))
moreover have "(w ∈ LS M1 qTarget) = (β@w ∈ L M1)"
by (metis ‹β = V qTarget› ‹β ∈ L M1› ‹qTarget ∈ reachable_states M1› after_language_iff assms(1) assms(9) is_state_cover_assignment_observable_after)
ultimately have "(u@w ∈ L M1) ≠ (β@w ∈ L M1)"
by blast
moreover have "u@w ∈ set T"
using ‹w ∈ set (after T (V qU))›
unfolding after_set ‹u = V qU›[symmetric]
using ‹u ∈ V ` reachable_states M1› assms(11) by auto
moreover have "β@w ∈ set T"
using ‹w ∈ set (after T (V qTarget))›
unfolding after_set ‹β = V qTarget›
using ‹qTarget ∈ reachable_states M1› assms(11) by auto
ultimately have "(u@w ∈ L M2) ≠ (β@w ∈ L M2)"
using ‹L M1 ∩ set T = L M2 ∩ set T› by blast
then have "(u@w ∈ L M2) ≠ (?w@w ∈ L M2)"
unfolding ‹(?w @ w ∈ L M2) = (β@w ∈ L M2)› .
moreover have "(u@w ∈ L M2) = (w ∈ LS M2 (after_initial M2 u))"
by (metis (no_types, lifting) "**" Int_iff ‹L M1 ∩ Prefix_Tree.set T = L M2 ∩ Prefix_Tree.set T› ‹u ∈ V ` reachable_states M1› after_language_iff assms(11) assms(2) inter_eq_subsetI)
moreover have "(?w@w ∈ L M2) = (w ∈ LS M2 (after_initial M2 ?w))"
using assms(10) unfolding α[symmetric] xy[symmetric]
by (metis assms(2) observable_after_language_append observable_after_language_none)
ultimately show "¬converge M2 u ?w"
using converge.elims(2) by blast
qed
moreover have "⋀ v . v ∈ (V ` reachable_states M1) ⟹ ¬converge M1 ?w v ⟹ ¬converge M2 ?w v"
using calculation unfolding converge_sym[where v="?w"]
by blast
ultimately show ?thesis
using assms(12)
unfolding preserves_divergence.simps
unfolding * **
by blast
qed
have "⋀ γ x y . length (γ@[(x,y)]) ≤ m - size_r M1 ⟹
γ ∈ LS M1 (after_initial M1 (V (t_source t) @ [(t_input t, t_output t)])) ⟹
x ∈ inputs M1 ⟹ y ∈ outputs M1 ⟹
L M1 ∩ ((V ` reachable_states M1) ∪ {ω@ω' | ω ω' . ω ∈ {((V (t_source t)) @ [(t_input t,t_output t)]), (V (t_target t))} ∧ ω' ∈ list.set (prefixes (γ@[(x,y)]))}) = L M2 ∩ ((V ` reachable_states M1) ∪ {ω@ω' | ω ω' . ω ∈ {((V (t_source t)) @ [(t_input t,t_output t)]), (V (t_target t))} ∧ ω' ∈ list.set (prefixes (γ@[(x,y)]))})
∧ preserves_divergence M1 M2 ((V ` reachable_states M1) ∪ {ω@ω' | ω ω' . ω ∈ {((V (t_source t)) @ [(t_input t,t_output t)]), (V (t_target t))} ∧ ω' ∈ list.set (prefixes (γ@[(x,y)]))})"
proof
fix γ x y
assume "length (γ@[(x,y)]) ≤ m - size_r M1"
and "γ ∈ LS M1 (after_initial M1 (V (t_source t) @ [(t_input t, t_output t)]))"
and "x ∈ inputs M1"
and "y ∈ outputs M1"
have "(after_initial M1 (V (t_source t) @ [(t_input t, t_output t)])) = qTarget"
using ‹converge M1 (α@[xy]) β›
unfolding α[symmetric] xy[symmetric] qTarget β[symmetric]
using ‹α @ [xy] ∈ L M1› ‹β ∈ L M1› assms(1) assms(3) convergence_minimal by blast
then have "γ ∈ LS M1 qTarget"
using ‹γ ∈ LS M1 (after_initial M1 (V (t_source t) @ [(t_input t, t_output t)]))›
by auto
then have "γ@[(x,y)] ∈ list.set (traces_to_check M1 qTarget k)"
unfolding traces_to_check_set[OF assms(1) ‹qTarget ∈ states M1›] k
using ‹length (γ@[(x,y)]) ≤ m - size_r M1› ‹x ∈ inputs M1› ‹y ∈ outputs M1›
by blast
then have "(γ@[(x,y)]) ∈ list.set ttc"
unfolding ttc by auto
have "⋀ γ' . γ' ∈ list.set (prefixes γ) ⟹ γ' ∈ list.set ttc ∧ γ' ∈ LS M1 qTarget"
proof
fix γ' assume "γ' ∈ list.set (prefixes γ)"
then obtain γ'' where "γ = γ'@γ''"
using prefixes_set_ob by blast
then show "γ' ∈ LS M1 qTarget"
using ‹γ ∈ LS M1 qTarget› language_prefix by metis
show "γ' ∈ list.set ttc" proof (cases γ' rule: rev_cases)
case Nil
then show ?thesis unfolding ttc by auto
next
case (snoc ioI ioL)
then obtain xL yL where "γ' = ioI@[(xL,yL)]"
using prod.exhaust by metis
then have "xL ∈ inputs M1" and "yL ∈ outputs M1"
using language_io[OF ‹γ' ∈ LS M1 qTarget›, of xL yL]
by auto
moreover have "length γ' ≤ m - size_r M1"
using ‹length (γ@[(x,y)]) ≤ m - size_r M1› ‹γ = γ'@γ''› by auto
moreover have "ioI ∈ LS M1 qTarget"
using ‹γ' ∈ LS M1 qTarget› ‹γ' = ioI@[(xL,yL)]› language_prefix by metis
ultimately have "γ' ∈ list.set (traces_to_check M1 qTarget k)"
unfolding traces_to_check_set[OF assms(1) ‹qTarget ∈ states M1›] k ‹γ' = ioI@[(xL,yL)]›
by blast
then show ?thesis
unfolding ttc by auto
qed
qed
show "L M1 ∩ ((V ` reachable_states M1) ∪ {ω@ω' | ω ω' . ω ∈ {((V (t_source t)) @ [(t_input t,t_output t)]), (V (t_target t))} ∧ ω' ∈ list.set (prefixes (γ@[(x,y)]))}) = L M2 ∩ ((V ` reachable_states M1) ∪ {ω@ω' | ω ω' . ω ∈ {((V (t_source t)) @ [(t_input t,t_output t)]), (V (t_target t))} ∧ ω' ∈ list.set (prefixes (γ@[(x,y)]))})"
proof -
have "L M1 ∩ (V ` reachable_states M1) = L M2 ∩ (V ` reachable_states M1)"
using assms(11) ‹L M1 ∩ set T = L M2 ∩ set T›
by blast
moreover have "L M1 ∩ {ω@ω' | ω ω' . ω ∈ {((V (t_source t)) @ [(t_input t,t_output t)]), (V (t_target t))} ∧ ω' ∈ list.set (prefixes (γ@[(x,y)]))} = L M2 ∩ {ω@ω' | ω ω' . ω ∈ {((V (t_source t)) @ [(t_input t,t_output t)]), (V (t_target t))} ∧ ω' ∈ list.set (prefixes (γ@[(x,y)]))}"
proof -
have *:"{ω@ω' | ω ω' . ω ∈ {α@[xy],β} ∧ ω' ∈ list.set (prefixes (γ@[(x,y)]))}
= {ω@ω' | ω ω' . ω ∈ {α@[xy],β} ∧ ω' ∈ list.set (prefixes γ)} ∪ {(α@[xy])@(γ@[(x,y)]),β@(γ@[(x,y)])}"
unfolding prefixes_set_Cons_insert by blast
have "L M1 ∩ {ω@ω' | ω ω' . ω ∈ {α@[xy],β} ∧ ω' ∈ list.set (prefixes γ)} = L M2 ∩ {ω@ω' | ω ω' . ω ∈ {α@[xy],β} ∧ ω' ∈ list.set (prefixes γ)}"
proof -
have "⋀ io . io ∈ {ω@ω' | ω ω' . ω ∈ {α@[xy],β} ∧ ω' ∈ list.set (prefixes γ)} ⟹ (io ∈ L M1) = (io ∈ L M2)"
proof -
fix io assume "io ∈ {ω@ω' | ω ω' . ω ∈ {α@[xy],β} ∧ ω' ∈ list.set (prefixes γ)}"
then obtain γ' where "io ∈ {α@[xy]@γ',β@γ'}" and "γ' ∈ list.set (prefixes γ)"
by force
then have "γ' ∈ list.set ttc" and "γ' ∈ LS M1 qTarget"
using ‹⋀ γ' . γ' ∈ list.set (prefixes γ) ⟹ γ' ∈ list.set ttc ∧ γ' ∈ LS M1 qTarget›
by blast+
moreover have "[] ∈ Prefix_Tree.set (dist_fun (length γ') (FSM.after M1 qTarget γ'))"
by simp
ultimately have "L M1 ∩ {α@[xy]@γ',β@γ'} = L M2 ∩ {α@[xy]@γ',β@γ'}"
using handleTrace_foldl_props_1[of γ' "[]"]
by auto
then show "(io ∈ L M1) = (io ∈ L M2)"
using ‹io ∈ {α@[xy]@γ',β@γ'}› by blast
qed
then show ?thesis by blast
qed
moreover have "L M1 ∩ {(α@[xy])@(γ@[(x,y)]),β@(γ@[(x,y)])} = L M2 ∩ {(α@[xy])@(γ@[(x,y)]),β@(γ@[(x,y)])}"
proof (cases "(γ@[(x,y)]) ∈ LS M1 qTarget")
case True
show ?thesis
using handleTrace_foldl_props_1[OF ‹(γ@[(x,y)]) ∈ list.set ttc› True, of "[]"]
by auto
next
case False
show ?thesis
using handleTrace_foldl_props_2[OF ‹(γ@[(x,y)]) ∈ list.set ttc› False]
by auto
qed
ultimately show ?thesis
unfolding α[symmetric] xy[symmetric] β[symmetric] *
by (metis (no_types, lifting) Int_Un_distrib)
qed
ultimately show ?thesis
by (metis (no_types, lifting) Int_Un_distrib)
qed
show "preserves_divergence M1 M2 ((V ` reachable_states M1) ∪ {ω@ω' | ω ω' . ω ∈ {((V (t_source t)) @ [(t_input t,t_output t)]), (V (t_target t))} ∧ ω' ∈ list.set (prefixes (γ@[(x,y)]))})"
proof -
have "⋀ u v . u ∈ L M1 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {α @ [xy], β} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) ⟹
v ∈ L M1 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {α @ [xy], β} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) ⟹
¬ converge M1 u v ⟹
¬ converge M2 u v"
proof -
fix u v assume "u ∈ L M1 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {α @ [xy], β} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))})"
and "v ∈ L M1 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {α @ [xy], β} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))})"
and "¬ converge M1 u v"
then have "u ∈ L M1" and "v ∈ L M1" and "after_initial M1 u ≠ after_initial M1 v"
by auto
then have "after_initial M1 u ∈ states M1"
and "after_initial M1 v ∈ states M1"
using after_is_state[OF assms(1)] by auto
have pass_dist: "⋀ u . u ∈ L M1 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {α @ [xy], β} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) ⟹
(∃ k . ∀ w ∈ Prefix_Tree.set (dist_fun k (after_initial M1 u)) . (u@w ∈ L M1) = (u@w ∈ L M2))"
proof -
fix u assume "u ∈ L M1 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {α @ [xy], β} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))})"
then consider "u ∈ V ` reachable_states M1" | "u ∈ {ω @ ω' |ω ω'. ω ∈ {α @ [xy], β} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}"
by blast
then show "(∃ k . ∀ w ∈ Prefix_Tree.set (dist_fun k (after_initial M1 u)) . (u@w ∈ L M1) = (u@w ∈ L M2))"
proof cases
case 1
then obtain qU where "qU ∈ reachable_states M1" and "V qU = u"
by blast
have "after_initial M1 u = qU"
by (metis ‹V qU = u› ‹qU ∈ reachable_states M1› assms(1) assms(9) is_state_cover_assignment_observable_after)
have "⋀w . w ∈ Prefix_Tree.set (dist_fun 0 (after_initial M1 u)) ⟹ (u@w ∈ L M1) = (u@w ∈ L M2)"
proof -
fix w assume "w ∈ Prefix_Tree.set (dist_fun 0 (after_initial M1 u))"
then have "w ∈ Prefix_Tree.set (Prefix_Tree.after T u)"
using assms(16)[OF ‹qU ∈ reachable_states M1›]
unfolding ‹V qU = u› ‹after_initial M1 u = qU›
by blast
moreover have "u ∈ set T"
using "1" assms(11) by auto
ultimately have "u@w ∈ set T"
unfolding after_set
by auto
then show "(u@w ∈ L M1) = (u@w ∈ L M2)"
using ‹L M1 ∩ set T = L M2 ∩ set T› by blast
qed
then show ?thesis
by blast
next
case 2
then obtain γ' where "u ∈ {(α @ [xy]) @ γ', β @ γ'}" and "γ' ∈ list.set (prefixes (γ @ [(x, y)]))"
by blast
then have "γ' ∈ list.set ttc"
using ‹(γ @ [(x, y)]) ∈ list.set ttc› ‹⋀ γ' . γ' ∈ list.set (prefixes γ) ⟹ γ' ∈ list.set ttc ∧ γ' ∈ LS M1 qTarget›
unfolding prefixes_set_Cons_insert by blast
have "γ' ∈ LS M1 qTarget"
proof -
have "u ∈ L M1"
using ‹u ∈ L M1 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {α @ [xy], β} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))})› by blast
then show ?thesis
using ‹u ∈ {(α @ [xy]) @ γ', β @ γ'}› ‹converge M1 (α @ [xy]) β›
unfolding qTarget β[symmetric]
by (metis ‹β ∈ L M1› assms(1) converge_append_language_iff insert_iff observable_after_language_none singleton_iff)
qed
then have "(FSM.after M1 qTarget γ') = (after_initial M1 u)"
using ‹u ∈ {(α @ [xy]) @ γ', β @ γ'}› ‹converge M1 (α @ [xy]) β›
unfolding qTarget β[symmetric]
by (metis ‹α @ [xy] ∈ L M1› ‹β ∈ L M1› after_split assms(1) assms(3) convergence_minimal insert_iff observable_after_language_append singleton_iff)
have "⋀ w . {α @ [xy] @ γ' @ w, β @ γ' @ w} = {((α @ [xy]) @ γ') @ w, (β @ γ') @ w}"
by auto
have "⋀ w . w ∈ set (dist_fun (Suc (length γ')) (after_initial M1 u)) ⟹ (u @ w ∈ L M1) = (u @ w ∈ L M2)"
using handleTrace_foldl_props_1[OF ‹γ' ∈ list.set ttc› ‹γ' ∈ LS M1 qTarget›]
unfolding ‹(FSM.after M1 qTarget γ') = (after_initial M1 u)›
using ‹u ∈ {(α @ [xy]) @ γ', β @ γ'}›
unfolding ‹⋀ w . {α @ [xy] @ γ' @ w, β @ γ' @ w} = {((α @ [xy]) @ γ') @ w, (β @ γ') @ w}› by blast
then show ?thesis
by blast
qed
qed
obtain ku where "⋀ w . w ∈ set (dist_fun ku (after_initial M1 u)) ⟹ (u@w ∈ L M1) = (u@w ∈ L M2)"
using pass_dist[OF ‹u ∈ L M1 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {α @ [xy], β} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))})›]
by blast
obtain kv where "⋀ w . w ∈ set (dist_fun kv (after_initial M1 v)) ⟹ (v@w ∈ L M1) = (v@w ∈ L M2)"
using pass_dist[OF ‹v ∈ L M1 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {α @ [xy], β} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))})›]
by blast
obtain w where "w ∈ set (dist_fun ku (after_initial M1 u))"
and "w ∈ set (dist_fun kv (after_initial M1 v))"
and "distinguishes M1 (after_initial M1 u) (after_initial M1 v) w"
using assms(15)[OF ‹after_initial M1 u ∈ states M1› ‹after_initial M1 v ∈ states M1› ‹after_initial M1 u ≠ after_initial M1 v›]
by blast
then have "(w ∈ LS M1 (after_initial M1 u)) ≠ (w ∈ LS M1 (after_initial M1 v))"
unfolding distinguishes_def by blast
moreover have "w ∈ LS M1 (after_initial M1 u) = (w ∈ LS M2 (after_initial M2 u))"
by (metis ‹⋀w. w ∈ Prefix_Tree.set (dist_fun ku (after_initial M1 u)) ⟹ (u @ w ∈ L M1) = (u @ w ∈ L M2)› ‹u ∈ L M1› ‹w ∈ Prefix_Tree.set (dist_fun ku (after_initial M1 u))› append_Nil2 assms(1) assms(2) observable_after_language_append observable_after_language_none set_Nil)
moreover have "w ∈ LS M1 (after_initial M1 v) = (w ∈ LS M2 (after_initial M2 v))"
by (metis ‹⋀w. w ∈ Prefix_Tree.set (dist_fun kv (after_initial M1 v)) ⟹ (v @ w ∈ L M1) = (v @ w ∈ L M2)› ‹v ∈ L M1› ‹w ∈ Prefix_Tree.set (dist_fun kv (after_initial M1 v))› append_Nil2 assms(1) assms(2) observable_after_language_append observable_after_language_none set_Nil)
ultimately have "(w ∈ LS M2 (after_initial M2 u)) ≠ (w ∈ LS M2 (after_initial M2 v))"
by blast
then have "after_initial M2 u ≠ after_initial M2 v"
by auto
then show "¬ converge M2 u v"
using assms(2) assms(4) converge.simps convergence_minimal by blast
qed
then show ?thesis
unfolding preserves_divergence.simps α[symmetric] xy[symmetric] β[symmetric]
by blast
qed
qed
then show "?P1a"
by blast
qed
lemma establish_convergence_static_establishes_convergence :
assumes "observable M1"
and "observable M2"
and "minimal M1"
and "minimal M2"
and "size_r M1 ≤ m"
and "size M2 ≤ m"
and "inputs M2 = inputs M1"
and "outputs M2 = outputs M1"
and "t ∈ transitions M1"
and "t_source t ∈ reachable_states M1"
and "is_state_cover_assignment M1 V"
and "V (t_source t) @ [(t_input t, t_output t)] ∈ L M2"
and "V ` reachable_states M1 ⊆ set T"
and "preserves_divergence M1 M2 (V ` reachable_states M1)"
and "convergence_graph_lookup_invar M1 M2 cg_lookup G"
and "convergence_graph_insert_invar M1 M2 cg_lookup cg_insert"
and "⋀ q1 q2 . q1 ∈ states M1 ⟹ q2 ∈ states M1 ⟹ q1 ≠ q2 ⟹ ∃ io . ∀ k1 k2 . io ∈ set (dist_fun k1 q1) ∩ set (dist_fun k2 q2) ∧ distinguishes M1 q1 q2 io"
and "⋀ q . q ∈ reachable_states M1 ⟹ set (dist_fun 0 q) ⊆ set (after T (V q))"
and "⋀ q k . q ∈ states M1 ⟹ finite_tree (dist_fun k q)"
and "L M1 ∩ set (fst (establish_convergence_static dist_fun M1 V T G cg_insert cg_lookup m t)) = L M2 ∩ set (fst (establish_convergence_static dist_fun M1 V T G cg_insert cg_lookup m t))"
shows "converge M2 (V (t_source t) @ [(t_input t, t_output t)]) (V (t_target t))"
(is "converge M2 ?u ?v")
proof -
have prop1: "⋀γ x y.
length (γ @ [(x, y)]) ≤ (m - size_r M1) ⟹
γ ∈ LS M1 (after_initial M1 ?u) ⟹
x ∈ FSM.inputs M1 ⟹
y ∈ FSM.outputs M1 ⟹
L M1 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {?u, ?v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) =
L M2 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {?u, ?v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) ∧
preserves_divergence M1 M2
(V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {?u, ?v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))})"
and prop2: "preserves_divergence M1 M2 (V ` reachable_states M1 ∪ {?u, ?v})"
using establish_convergence_static_properties(1,2)[OF assms(1-4,7-20)]
by presburger+
have "L M1 ∩ V ` reachable_states M1 = L M2 ∩ V ` reachable_states M1"
using assms(13,20)
using establish_convergence_static_subset[of T dist_fun M1 V G cg_insert cg_lookup m t ]
by blast
then have "V (t_target t) ∈ L M2"
by (metis Int_iff assms(10) assms(11) assms(9) imageI is_state_cover_assignment_language reachable_states_next)
have "converge M1 ?u ?v"
using state_cover_transition_converges[OF assms(1,11,9,10)] .
show ?thesis
using establish_convergence_from_pass[OF assms(1-8,11) ‹L M1 ∩ V ` reachable_states M1 = L M2 ∩ V ` reachable_states M1› ‹converge M1 ?u ?v› ‹V (t_source t) @ [(t_input t, t_output t)] ∈ L M2› ‹V (t_target t) ∈ L M2› prop1 prop2]
by blast
qed
lemma establish_convergence_static_verifies_transition :
assumes "⋀ q1 q2 . q1 ∈ states M1 ⟹ q2 ∈ states M1 ⟹ q1 ≠ q2 ⟹ ∃ io . ∀ k1 k2 . io ∈ set (dist_fun k1 q1) ∩ set (dist_fun k2 q2) ∧ distinguishes M1 q1 q2 io"
and "⋀ q k . q ∈ states M1 ⟹ finite_tree (dist_fun k q)"
shows "verifies_transition (establish_convergence_static dist_fun) M1 M2 V (fst (handle_state_cover_static dist_fun M1 V cg_initial cg_insert cg_lookup)) cg_insert cg_lookup"
proof -
have *:"⋀ V T (G::'d) m t. set T ⊆ set (fst ((establish_convergence_static dist_fun) M1 V T G cg_insert cg_lookup m t))"
using establish_convergence_static_subset
by metis
have ***:"⋀ V T (G::'d) m t. finite_tree T ⟶ finite_tree (fst ((establish_convergence_static dist_fun) M1 V T G cg_insert cg_lookup m t))"
using establish_convergence_static_finite
by metis
let ?distinguish_traces = "(λ α t' q' β t'' g'' . dist_fun 0 q')"
have **:"⋀ T (G::'d) m t.
observable M1 ⟹
observable M2 ⟹
minimal M1 ⟹
minimal M2 ⟹
size_r M1 ≤ m ⟹
FSM.size M2 ≤ m ⟹
FSM.inputs M2 = FSM.inputs M1 ⟹
FSM.outputs M2 = FSM.outputs M1 ⟹
is_state_cover_assignment M1 V ⟹
preserves_divergence M1 M2 (V ` reachable_states M1) ⟹
V ` reachable_states M1 ⊆ set T ⟹
t ∈ FSM.transitions M1 ⟹
t_source t ∈ reachable_states M1 ⟹
V (t_source t) @ [(t_input t, t_output t)] ∈ L M2 ⟹
convergence_graph_lookup_invar M1 M2 cg_lookup G ⟹
convergence_graph_insert_invar M1 M2 cg_lookup cg_insert ⟹
set (fst (handle_state_cover_static dist_fun M1 V cg_initial cg_insert cg_lookup)) ⊆ set T ⟹
L M1 ∩ Prefix_Tree.set (fst ((establish_convergence_static dist_fun) M1 V T G cg_insert cg_lookup m t)) =
L M2 ∩ Prefix_Tree.set (fst ((establish_convergence_static dist_fun) M1 V T G cg_insert cg_lookup m t)) ⟹
converge M2 (V (t_source t) @ [(t_input t, t_output t)]) (V (t_target t)) ∧
convergence_graph_lookup_invar M1 M2 cg_lookup (snd ((establish_convergence_static dist_fun) M1 V T G cg_insert cg_lookup m t))"
proof
fix G :: 'd
fix T m t
assume a01: "observable M1"
assume a02: "observable M2"
assume a03: "minimal M1"
assume a04: "minimal M2"
assume a05: "size_r M1 ≤ m"
assume a06: "FSM.size M2 ≤ m"
assume a07: "FSM.inputs M2 = FSM.inputs M1"
assume a08: "FSM.outputs M2 = FSM.outputs M1"
assume a09: "is_state_cover_assignment M1 V"
assume a10: "preserves_divergence M1 M2 (V ` reachable_states M1)"
assume a11: "V ` reachable_states M1 ⊆ set T"
assume a12: "t ∈ FSM.transitions M1"
assume a13: "t_source t ∈ reachable_states M1"
assume a14: "V (t_source t) @ [(t_input t, t_output t)] ∈ L M2"
assume a15: "convergence_graph_lookup_invar M1 M2 cg_lookup G"
assume a16: "convergence_graph_insert_invar M1 M2 cg_lookup cg_insert"
assume a17: "L M1 ∩ Prefix_Tree.set (fst ((establish_convergence_static dist_fun) M1 V T G cg_insert cg_lookup m t)) = L M2 ∩ Prefix_Tree.set (fst ((establish_convergence_static dist_fun) M1 V T G cg_insert cg_lookup m t))"
assume a18: "set (fst (handle_state_cover_static dist_fun M1 V cg_initial cg_insert cg_lookup)) ⊆ set T"
have "L M1 ∩ V ` reachable_states M1 = L M2 ∩ V ` reachable_states M1"
using a11 a17 *
by blast
then have d2: "V (t_target t) ∈ L M2"
using a11 is_state_cover_assignment_language[OF a09, of "t_target t"] reachable_states_next[OF a13 a12]
by blast
have d1: "⋀ q . q ∈ reachable_states M1 ⟹ set (dist_fun 0 q) ⊆ set (after T (V q))"
using handle_state_cover_static_applies_dist_sets[of _ M1 dist_fun V cg_initial cg_insert cg_lookup] a18
by (meson in_mono subsetI subset_after_subset)
show "converge M2 (V (t_source t) @ [(t_input t, t_output t)]) (V (t_target t))"
using establish_convergence_static_establishes_convergence[where dist_fun=dist_fun, OF a01 a02 a03 a04 a05 a06 a07 a08 a12 a13 a09 a14 a11 a10 a15 a16 assms(1) d1 assms(2) a17]
by force
show "convergence_graph_lookup_invar M1 M2 cg_lookup (snd (establish_convergence_static dist_fun M1 V T G cg_insert cg_lookup m t))"
using establish_convergence_static_properties(3)[where dist_fun=dist_fun, OF a01 a02 a03 a04 a07 a08 a12 a13 a09 a14 a11 a10 a15 a16 assms(1) d1 assms(2) a17]
by blast
qed
show ?thesis
unfolding verifies_transition_def
using * *** **
by presburger
qed
definition handleUT_static :: "(nat ⇒ 'a ⇒ ('b×'c) prefix_tree) ⇒
(('a::linorder,'b::linorder,'c::linorder) fsm ⇒
('a,'b,'c) state_cover_assignment ⇒
('b×'c) prefix_tree ⇒
'd ⇒
('d ⇒ ('b×'c) list ⇒ 'd) ⇒
('d ⇒ ('b×'c) list ⇒ ('b×'c) list list) ⇒
('d ⇒ ('b×'c) list ⇒ ('b×'c) list ⇒ 'd) ⇒
nat ⇒
('a,'b,'c) transition ⇒
('a,'b,'c) transition list ⇒
(('a,'b,'c) transition list × ('b×'c) prefix_tree × 'd))"
where
"handleUT_static dist_fun M V T G cg_insert cg_lookup cg_merge l t X = (let
(T1,G1) = handle_io_pair False False M V T G cg_insert cg_lookup (t_source t) (t_input t) (t_output t);
(T2,G2) = establish_convergence_static dist_fun M V T1 G1 cg_insert cg_lookup l t;
G3 = cg_merge G2 ((V (t_source t))@[(t_input t, t_output t)]) (V (t_target t))
in (X,T2,G3))"
lemma handleUT_static_handles_transition :
fixes M1::"('a::linorder,'b::linorder,'c::linorder) fsm"
fixes M2::"('e,'b,'c) fsm"
assumes "⋀ q1 q2 . q1 ∈ states M1 ⟹ q2 ∈ states M1 ⟹ q1 ≠ q2 ⟹ ∃ io . ∀ k1 k2 . io ∈ set (dist_fun k1 q1) ∩ set (dist_fun k2 q2) ∧ distinguishes M1 q1 q2 io"
and "⋀ q k . q ∈ states M1 ⟹ finite_tree (dist_fun k q)"
shows "handles_transition (handleUT_static dist_fun) M1 M2 V (fst (handle_state_cover_static dist_fun M1 V cg_initial cg_insert cg_lookup)) cg_insert cg_lookup cg_merge"
proof -
let ?T0 = "(fst (handle_state_cover_static dist_fun M1 V cg_initial cg_insert cg_lookup))"
have "⋀ T G m t X .
Prefix_Tree.set T ⊆ Prefix_Tree.set (fst (snd (handleUT_static dist_fun M1 V T G cg_insert cg_lookup cg_merge m t X))) ∧
(finite_tree T ⟶ finite_tree (fst (snd (handleUT_static dist_fun M1 V T G cg_insert cg_lookup cg_merge m t X)))) ∧
(observable M1 ⟶
observable M2 ⟶
minimal M1 ⟶
minimal M2 ⟶
size_r M1 ≤ m ⟶
FSM.size M2 ≤ m ⟶
FSM.inputs M2 = FSM.inputs M1 ⟶
FSM.outputs M2 = FSM.outputs M1 ⟶
is_state_cover_assignment M1 V ⟶
preserves_divergence M1 M2 (V ` reachable_states M1) ⟶
V ` reachable_states M1 ⊆ Prefix_Tree.set T ⟶
t ∈ FSM.transitions M1 ⟶
t_source t ∈ reachable_states M1 ⟶
V (t_source t) @ [(t_input t, t_output t)] ≠ V (t_target t) ⟶
convergence_graph_lookup_invar M1 M2 cg_lookup G ⟶
convergence_graph_insert_invar M1 M2 cg_lookup cg_insert ⟶
convergence_graph_merge_invar M1 M2 cg_lookup cg_merge ⟶
L M1 ∩ Prefix_Tree.set (fst (snd (handleUT_static dist_fun M1 V T G cg_insert cg_lookup cg_merge m t X))) =
L M2 ∩ Prefix_Tree.set (fst (snd (handleUT_static dist_fun M1 V T G cg_insert cg_lookup cg_merge m t X))) ⟶
Prefix_Tree.set ?T0 ⊆ Prefix_Tree.set T ⟶
(∀γ. length γ ≤ m - size_r M1 ∧ list.set γ ⊆ FSM.inputs M1 × FSM.outputs M1 ∧ butlast γ ∈ LS M1 (t_target t) ⟶
L M1 ∩ (V ` reachable_states M1 ∪ {(V (t_source t) @ [(t_input t, t_output t)]) @ ω' |ω'. ω' ∈ list.set (prefixes γ)}) =
L M2 ∩ (V ` reachable_states M1 ∪ {(V (t_source t) @ [(t_input t, t_output t)]) @ ω' |ω'. ω' ∈ list.set (prefixes γ)}) ∧
preserves_divergence M1 M2 (V ` reachable_states M1 ∪ {(V (t_source t) @ [(t_input t, t_output t)]) @ ω' |ω'. ω' ∈ list.set (prefixes γ)})) ∧
convergence_graph_lookup_invar M1 M2 cg_lookup (snd (snd (handleUT_static dist_fun M1 V T G cg_insert cg_lookup cg_merge m t X))))"
(is "⋀ T G m t X . ?P T G m t X")
proof -
fix T :: "('b×'c) prefix_tree"
fix G :: 'd
fix m :: nat
fix t :: "('a,'b,'c) transition"
fix X :: "('a,'b,'c) transition list"
let ?TG = "snd (handleUT_static dist_fun M1 V T G cg_insert cg_lookup cg_merge m t X)"
obtain T1 G1 where "(T1,G1) = handle_io_pair False False M1 V T G cg_insert cg_lookup (t_source t) (t_input t) (t_output t)"
using prod.collapse by blast
then have T1_def: "T1 = fst (handle_io_pair False False M1 V T G cg_insert cg_lookup (t_source t) (t_input t) (t_output t))"
and G1_def: "G1 = snd (handle_io_pair False False M1 V T G cg_insert cg_lookup (t_source t) (t_input t) (t_output t))"
using fst_conv[of T1 G1] snd_conv[of T1 G1] by force+
obtain T2 G2 where "(T2,G2) = establish_convergence_static dist_fun M1 V T1 G1 cg_insert cg_lookup m t"
using prod.collapse by blast
have T2_def: "T2 = fst (establish_convergence_static dist_fun M1 V T1 G1 cg_insert cg_lookup m t)"
and G2_def: "G2 = snd (establish_convergence_static dist_fun M1 V T1 G1 cg_insert cg_lookup m t)"
unfolding ‹(T2,G2) = establish_convergence_static dist_fun M1 V T1 G1 cg_insert cg_lookup m t›[symmetric] by auto
define u where "u = ((V (t_source t))@[(t_input t, t_output t)])"
define v where "v = (V (t_target t))"
define G3 where "G3 = cg_merge G2 u v"
have TG_cases: "?TG = (T2,G3)"
unfolding handleUT_static_def Let_def
unfolding ‹(T1,G1) = handle_io_pair False False M1 V T G cg_insert cg_lookup (t_source t) (t_input t) (t_output t)›[symmetric] case_prod_conv
unfolding ‹(T2,G2) = establish_convergence_static dist_fun M1 V T1 G1 cg_insert cg_lookup m t›[symmetric] case_prod_conv
unfolding G3_def u_def v_def
by simp
have "set T1 ⊆ set T2"
and "finite_tree T1 ⟹ finite_tree T2"
using establish_convergence_static_verifies_transition[OF assms, of M2 V cg_initial cg_insert cg_lookup]
unfolding T2_def verifies_transition_def by blast+
moreover have "set T ⊆ set T1"
and "finite_tree T ⟹ finite_tree T1"
using handle_io_pair_verifies_io_pair[of False False M1 M2 cg_insert cg_lookup]
unfolding T1_def verifies_io_pair_def
by blast+
ultimately have *:"set T ⊆ set (fst ?TG)"
and **:"finite_tree T ⟹ finite_tree (fst ?TG)"
using TG_cases by auto
have ***: "observable M1 ⟹
observable M2 ⟹
minimal M1 ⟹
minimal M2 ⟹
size_r M1 ≤ m ⟹
size M2 ≤ m ⟹
inputs M2 = inputs M1 ⟹
outputs M2 = outputs M1 ⟹
is_state_cover_assignment M1 V ⟹
preserves_divergence M1 M2 (V ` reachable_states M1) ⟹
V ` reachable_states M1 ⊆ set T ⟹
t ∈ transitions M1 ⟹
t_source t ∈ reachable_states M1 ⟹
V (t_source t) @ [(t_input t, t_output t)] ≠ V (t_target t) ⟹
convergence_graph_lookup_invar M1 M2 cg_lookup G ⟹
convergence_graph_insert_invar M1 M2 cg_lookup cg_insert ⟹
convergence_graph_merge_invar M1 M2 cg_lookup cg_merge ⟹
L M1 ∩ set (fst ?TG) = L M2 ∩ set (fst ?TG) ⟹
(set ?T0 ⊆ set T) ⟹
(∀ γ . (length γ ≤ (m-size_r M1) ∧ list.set γ ⊆ inputs M1 × outputs M1 ∧ butlast γ ∈ LS M1 (t_target t))
⟶ ((L M1 ∩ (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)})
= L M2 ∩ (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)}))
∧ preserves_divergence M1 M2 (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)})))
∧ convergence_graph_lookup_invar M1 M2 cg_lookup (snd ?TG)"
proof -
assume a01 : "observable M1"
assume a02 : "observable M2"
assume a03 : "minimal M1"
assume a04 : "minimal M2"
assume a05 : "size_r M1 ≤ m"
assume a06 : "size M2 ≤ m"
assume a07 : "inputs M2 = inputs M1"
assume a08 : "outputs M2 = outputs M1"
assume a09 : "is_state_cover_assignment M1 V"
assume a10 : "preserves_divergence M1 M2 (V ` reachable_states M1)"
assume a11 : "V ` reachable_states M1 ⊆ set T"
assume a12 : "t ∈ transitions M1"
assume a13 : "t_source t ∈ reachable_states M1"
assume a14 : "convergence_graph_lookup_invar M1 M2 cg_lookup G"
assume a15 : "convergence_graph_insert_invar M1 M2 cg_lookup cg_insert"
assume a16 : "convergence_graph_merge_invar M1 M2 cg_lookup cg_merge"
assume a17 : "L M1 ∩ set (fst ?TG) = L M2 ∩ set (fst ?TG)"
assume a18 : "(set ?T0 ⊆ set T)"
assume a19 : "V (t_source t) @ [(t_input t, t_output t)] ≠ V (t_target t)"
have pass_T1 : "L M1 ∩ set T1 = L M2 ∩ set T1"
using a17 ‹set T1 ⊆ set T2› unfolding TG_cases by auto
then have pass_T : "L M1 ∩ set T = L M2 ∩ set T"
using ‹set T ⊆ set T1› by blast
have "t_target t ∈ reachable_states M1"
using reachable_states_next[OF a13 a12] by auto
then have "(V (t_target t)) ∈ L M1"
using is_state_cover_assignment_language[OF a09] by blast
moreover have "(V (t_target t)) ∈ set T"
using a11 ‹t_target t ∈ reachable_states M1› by blast
ultimately have "(V (t_target t)) ∈ L M2"
using pass_T by blast
then have "v ∈ L M2"
unfolding v_def .
have "(V (t_source t)) ∈ L M1"
using is_state_cover_assignment_language[OF a09 a13] by blast
moreover have "(V (t_source t)) ∈ set T"
using a11 a13 by blast
ultimately have "(V (t_source t)) ∈ L M2"
using pass_T by blast
have "u ∈ L M1"
unfolding u_def
using a01 a09 a12 a13 converge.simps state_cover_transition_converges by blast
have "after_initial M1 u = t_target t"
using a09 unfolding u_def
by (metis ‹u ∈ L M1› a01 a12 a13 after_split after_transition_exhaust is_state_cover_assignment_observable_after u_def)
have "u ∈ L M2"
using distribute_extension_adds_sequence(1)[OF a01 a03 ‹(V (t_source t)) ∈ L M1› ‹(V (t_source t)) ∈ L M2› a14 a15, of T "[(t_input t, t_output t)]", of False "(if False then append_heuristic_input M1 else append_heuristic_io)"]
using pass_T1 append_heuristic_io_in
unfolding T1_def G1_def handle_io_pair_def u_def
by (metis (no_types, lifting) Int_iff ‹u ∈ L M1› a01 a02 converge_append_language_iff u_def)
then have "V (t_source t) @ [(t_input t, t_output t)] ∈ L M2"
unfolding u_def .
have "L M1 ∩ V ` reachable_states M1 = L M2 ∩ V ` reachable_states M1"
using a11 a17 *
by blast
have "V ` reachable_states M1 ⊆ set T1"
using a11 ‹set T ⊆ set T1› by blast
have "⋀ q . q ∈ reachable_states M1 ⟹ set (dist_fun 0 q) ⊆ set (after T (V q))"
using handle_state_cover_static_applies_dist_sets[of _ M1 dist_fun V cg_initial cg_insert cg_lookup] a18
by (meson in_mono subsetI subset_after_subset)
then have "⋀ q . q ∈ reachable_states M1 ⟹ set (dist_fun 0 q) ⊆ set (after T1 (V q))"
using ‹set T ⊆ set T1›
by (meson dual_order.trans subset_after_subset)
have pass_T2: "L M1 ∩ Prefix_Tree.set (fst (establish_convergence_static dist_fun M1 V T1 G1 cg_insert cg_lookup m t)) = L M2 ∩ Prefix_Tree.set (fst (establish_convergence_static dist_fun M1 V T1 G1 cg_insert cg_lookup m t))"
using a17 unfolding TG_cases T2_def fst_conv .
have "convergence_graph_lookup_invar M1 M2 cg_lookup G1"
using handle_io_pair_verifies_io_pair[of False False M1 M2 cg_insert cg_lookup]
using a01 a02 a03 a04 a07 a08 a09 ‹L M1 ∩ V ` reachable_states M1 = L M2 ∩ V ` reachable_states M1› pass_T1 a13 fsm_transition_input[OF a12] fsm_transition_output[OF a12] a14 a15
unfolding T1_def G1_def verifies_io_pair_def
by blast
have cons_prop: "⋀γ x y.
length (γ @ [(x, y)]) ≤ m-size_r M1 ⟹
γ ∈ LS M1 (after_initial M1 u) ⟹
x ∈ FSM.inputs M1 ⟹
y ∈ FSM.outputs M1 ⟹
L M1 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) =
L M2 ∩ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))}) ∧
preserves_divergence M1 M2 (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes (γ @ [(x, y)]))})"
and nil_prop: "preserves_divergence M1 M2 (V ` reachable_states M1 ∪ {u, v})"
and conv_G2: "convergence_graph_lookup_invar M1 M2 cg_lookup G2"
using establish_convergence_static_properties[OF a01 a02 a03 a04 a07 a08 a12 a13 a09 ‹V (t_source t) @ [(t_input t, t_output t)] ∈ L M2› ‹V ` reachable_states M1 ⊆ set T1› a10 ‹convergence_graph_lookup_invar M1 M2 cg_lookup G1› a15 assms(1) ‹⋀ q . q ∈ reachable_states M1 ⟹ set (dist_fun 0 q) ⊆ set (after T1(V q))› assms(2) pass_T2]
unfolding G2_def[symmetric] u_def[symmetric] v_def[symmetric]
by blast+
have "converge M2 u v"
using establish_convergence_static_establishes_convergence[OF a01 a02 a03 a04 a05 a06 a07 a08 a12 a13 a09 ‹V (t_source t) @ [(t_input t, t_output t)] ∈ L M2› ‹V ` reachable_states M1 ⊆ set T1› a10 ‹convergence_graph_lookup_invar M1 M2 cg_lookup G1› a15 assms(1) ‹⋀ q . q ∈ reachable_states M1 ⟹ set (dist_fun 0 q) ⊆ set (after T1(V q))› assms(2) pass_T2]
unfolding u_def v_def by blast
moreover have "converge M1 u v"
unfolding u_def v_def using a09 a12 a13
using a01 state_cover_transition_converges by blast
ultimately have "convergence_graph_lookup_invar M1 M2 cg_lookup G3"
using ‹convergence_graph_lookup_invar M1 M2 cg_lookup G2› a16
unfolding G3_def
by (meson convergence_graph_merge_invar_def)
then have "convergence_graph_lookup_invar M1 M2 cg_lookup (snd ?TG)"
unfolding TG_cases by auto
moreover have "⋀ γ . (length γ ≤ (m-size_r M1) ∧ list.set γ ⊆ inputs M1 × outputs M1 ∧ butlast γ ∈ LS M1 (t_target t))
⟹ ((L M1 ∩ (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)})
= L M2 ∩ (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)}))
∧ preserves_divergence M1 M2 (V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)}))"
(is "⋀ γ . (length γ ≤ (m-size_r M1) ∧ list.set γ ⊆ inputs M1 × outputs M1 ∧ butlast γ ∈ LS M1 (t_target t)) ⟹ ?P1 γ ∧ ?P2 γ")
proof -
fix γ assume assm:"(length γ ≤ (m-size_r M1) ∧ list.set γ ⊆ inputs M1 × outputs M1 ∧ butlast γ ∈ LS M1 (t_target t))"
show "?P1 γ ∧ ?P2 γ"
proof (cases γ rule: rev_cases)
case Nil
have *: "(V ` reachable_states M1 ∪ {((V (t_source t))@[(t_input t,t_output t)]) @ ω' | ω'. ω' ∈ list.set (prefixes γ)})
= (V ` reachable_states M1 ∪ {u})"
unfolding u_def[symmetric] Nil by auto
have "?P1 γ"
using ‹L M1 ∩ V ` reachable_states M1 = L M2 ∩ V ` reachable_states M1›
‹u ∈ L M1› ‹u ∈ L M2›
unfolding * by blast
moreover have "?P2 γ"
using preserves_divergence_subset[OF nil_prop]
unfolding *
by (metis Un_empty_right Un_insert_right Un_upper1 insertI1 insert_subsetI)
ultimately show ?thesis
by simp
next
case (snoc γ' xy)
moreover obtain x y where "xy = (x,y)"
using prod.exhaust by metis
ultimately have "γ = γ'@[(x,y)]"
by auto
have *: "(V ` reachable_states M1 ∪ {u @ ω' |ω'. ω' ∈ list.set (prefixes γ)}) ⊆ (V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes γ)})"
by blast
have "length (γ' @ [(x, y)]) ≤ m - size_r M1"
using assm unfolding ‹γ = γ'@[(x,y)]› by auto
moreover have "γ' ∈ LS M1 (after_initial M1 u)"
using assm unfolding ‹γ = γ'@[(x,y)]›
by (simp add: ‹after_initial M1 u = t_target t›)
moreover have "x ∈ FSM.inputs M1" and "y ∈ FSM.outputs M1"
using assm unfolding ‹γ = γ'@[(x,y)]› by auto
ultimately show ?thesis
using cons_prop[of γ' x y] preserves_divergence_subset[of M1 M2 "(V ` reachable_states M1 ∪ {ω @ ω' |ω ω'. ω ∈ {u, v} ∧ ω' ∈ list.set (prefixes γ)})", OF _ *]
unfolding ‹γ = γ'@[(x,y)]›[symmetric] u_def[symmetric]
by blast
qed
qed
then show ?thesis
using ‹convergence_graph_lookup_invar M1 M2 cg_lookup (snd ?TG)›
by presburger
qed
show "?P T G m t X"
using * ** *** by blast
qed
then show ?thesis
unfolding handles_transition_def
by blast
qed
subsection ‹Distinguishing Traces›
subsubsection ‹Symmetry›
text ‹The following lemmata serve to show that the function to choose distinguishing sequences
returns the same sequence for reversed pairs, thus ensuring that the HSIs do not contain two
sequences for the same pair of states.›
lemma select_diverging_ofsm_table_io_sym :
assumes "observable M"
and "q1 ∈ states M"
and "q2 ∈ states M"
and "ofsm_table M (λq . states M) (Suc k) q1 ≠ ofsm_table M (λq . states M) (Suc k) q2"
assumes "(select_diverging_ofsm_table_io M q1 q2 (Suc k)) = (io,(a,b))"
shows "(select_diverging_ofsm_table_io M q2 q1 (Suc k)) = (io,(b,a))"
proof -
define xs where xs: "xs = (List.product (inputs_as_list M) (outputs_as_list M))"
define f1' where f1': "f1' = (λ(x, y) ⇒ (case (h_obs M q1 x y, h_obs M q2 x y) of
(None, None) ⇒ None |
(None, Some q2') ⇒ Some ((x, y), None, Some q2') |
(Some q1', None) ⇒ Some ((x, y), Some q1', None) |
(Some q1', Some q2') ⇒ (if ofsm_table M (λq . states M) ((Suc k) - 1) q1' ≠ ofsm_table M (λq . states M) ((Suc k) - 1) q2' then Some ((x, y), Some q1', Some q2') else None)))"
define f1 where f1: "f1 = (λxs . (hd (List.map_filter f1' xs)))"
define f2' where f2': "f2' = (λ(x, y) ⇒ (case (h_obs M q2 x y, h_obs M q1 x y) of
(None, None) ⇒ None |
(None, Some q2') ⇒ Some ((x, y), None, Some q2') |
(Some q1', None) ⇒ Some ((x, y), Some q1', None) |
(Some q1', Some q2') ⇒ (if ofsm_table M (λq . states M) ((Suc k) - 1) q1' ≠ ofsm_table M (λq . states M) ((Suc k) - 1) q2' then Some ((x, y), Some q1', Some q2') else None)))"
define f2 where f2: "f2 = (λxs . (hd (List.map_filter f2' xs)))"
obtain x y where "select_diverging_ofsm_table_io M q1 q2 (Suc k) = ((x,y),(h_obs M q1 x y, h_obs M q2 x y))"
using select_diverging_ofsm_table_io_Some(1)[OF assms(1-4)]
by meson
have "⋀ xy io a b . f1' xy = Some (io,(a,b)) ⟹ f2' xy = Some (io,(b,a))"
proof -
fix xy io a b assume *: "f1' xy = Some (io,(a,b))"
obtain x y where "xy = (x,y)"
using prod.exhaust by metis
show "f2' xy = Some (io,(b,a))"
proof (cases "h_obs M q1 x y")
case None
show ?thesis proof (cases "h_obs M q2 x y")
case None
then show ?thesis using ‹h_obs M q1 x y = None› * unfolding f1' f2' ‹xy = (x,y)› by auto
next
case (Some q2')
show ?thesis using * unfolding f1' f2'
unfolding case_prod_conv None Some ‹xy = (x,y)› by auto
qed
next
case (Some q1')
show ?thesis proof (cases "h_obs M q2 x y")
case None
show ?thesis using * unfolding f1' f2'
unfolding case_prod_conv None Some ‹xy = (x,y)› by auto
next
case (Some q2')
have "ofsm_table M (λq . states M) ((Suc k) - 1) q2' ≠ ofsm_table M (λq . states M) ((Suc k) - 1) q1'"
using * unfolding f1' case_prod_conv ‹h_obs M q1 x y = Some q1'› Some ‹xy = (x,y)› by auto
then have "f1' (x,y) = Some ((x,y),(h_obs M q1 x y,h_obs M q2 x y))"
unfolding f1' case_prod_conv ‹h_obs M q1 x y = Some q1'› Some by auto
then have "io = (x,y)" and "b = h_obs M q2 x y" and "a = h_obs M q1 x y"
using * ‹xy = (x,y)› by auto
show ?thesis unfolding f2'
unfolding case_prod_conv ‹h_obs M q1 x y = Some q1'› Some ‹io = (x,y)› ‹b = h_obs M q2 x y› ‹a = h_obs M q1 x y› ‹xy = (x,y)›
using ‹ofsm_table M (λq . states M) ((Suc k) - 1) q2' ≠ ofsm_table M (λq . states M) ((Suc k) - 1) q1'› by simp
qed
qed
qed
moreover have "⋀ xy io a b . f2' xy = Some (io,(a,b)) ⟹ f1' xy = Some (io,(b,a))"
proof -
fix xy io a b assume *: "f2' xy = Some (io,(a,b))"
obtain x y where "xy = (x,y)"
using prod.exhaust by metis
show "f1' xy = Some (io,(b,a))"
proof (cases "h_obs M q1 x y")
case None
show ?thesis proof (cases "h_obs M q2 x y")
case None
then show ?thesis using ‹h_obs M q1 x y = None› * unfolding f1' f2' ‹xy = (x,y)› by auto
next
case (Some q2')
show ?thesis using * unfolding f1' f2'
unfolding case_prod_conv None Some ‹xy = (x,y)› by auto
qed
next
case (Some q1')
show ?thesis proof (cases "h_obs M q2 x y")
case None
show ?thesis using * unfolding f1' f2'
unfolding case_prod_conv None Some ‹xy = (x,y)› by auto
next
case (Some q2')
have "ofsm_table M (λq . states M) ((Suc k) - 1) q2' ≠ ofsm_table M (λq . states M) ((Suc k) - 1) q1'"
using * unfolding f2' case_prod_conv ‹h_obs M q1 x y = Some q1'› Some ‹xy = (x,y)› by auto
then have "f2' (x,y) = Some ((x,y),(h_obs M q2 x y,h_obs M q1 x y))"
unfolding f2' case_prod_conv ‹h_obs M q1 x y = Some q1'› Some by auto
then have "io = (x,y)" and "b = h_obs M q1 x y" and "a = h_obs M q2 x y"
using * ‹xy = (x,y)› by auto
show ?thesis unfolding f1'
unfolding case_prod_conv ‹h_obs M q1 x y = Some q1'› Some ‹io = (x,y)› ‹b = h_obs M q1 x y› ‹a = h_obs M q2 x y› ‹xy = (x,y)›
using ‹ofsm_table M (λq . states M) ((Suc k) - 1) q2' ≠ ofsm_table M (λq . states M) ((Suc k) - 1) q1'› by simp
qed
qed
qed
ultimately have "⋀ xy io a b . f2' xy = Some (io,(a,b)) ⟷ f1' xy = Some (io,(b,a))"
by blast
moreover have "⋀ xs . (⋀ xy io a b . f1' xy = Some (io,(a,b)) ⟷ f2' xy = Some (io,(b,a))) ⟹ ∃ xy ∈ list.set xs . f1' xy ≠ None ⟹ f1 xs = (io,(a,b)) ⟹ f2 xs = (io,(b,a))"
proof -
fix xs assume "(⋀ xy io a b . f1' xy = Some (io,(a,b)) ⟷ f2' xy = Some (io,(b,a)))"
"∃ xy ∈ list.set xs . f1' xy ≠ None"
"f1 xs = (io,(a,b))"
then show "f2 xs = (io,(b,a))"
proof (induction xs)
case Nil
then show ?case by auto
next
case (Cons xy xs)
show ?case proof (cases "f1' xy")
case None
then have "∄ io a b . f1' xy = Some (io,(a,b))"
by auto
then have "f2' xy = None"
using Cons.prems(1)
by (metis option.exhaust prod_cases3)
then have "f2 (xy#xs) = f2 xs"
unfolding f2 map_filter_simps by auto
moreover have "f1 (xy#xs) = f1 xs"
using None unfolding f1 map_filter_simps by auto
ultimately show ?thesis
using Cons.IH Cons.prems(1) Cons.prems(2) Cons.prems(3) None by fastforce
next
case (Some ioab)
then have "f1 (xy#xs) = ioab"
unfolding f1 map_filter_simps
by simp
then have "ioab = (io,(a,b))"
using Cons.prems(3) by auto
then have "f2' xy = Some (io,(b,a))"
using Cons.prems(1) Some by auto
then show "f2 (xy#xs) = (io,(b,a))"
unfolding f2 map_filter_simps by auto
qed
qed
qed
moreover have "f1 xs = (io,(a,b))"
using ‹(select_diverging_ofsm_table_io M q1 q2 (Suc k)) = (io,(a,b))›
unfolding select_diverging_ofsm_table_io.simps f1 f1' xs Let_def by auto
moreover have "∃ xy ∈ list.set xs . f1' xy ≠ None"
proof -
let ?P = "∀ x y . x ∈ inputs M ⟶ y ∈ outputs M ⟶ (h_obs M q1 x y = None ⟷ h_obs M q2 x y = None)"
show ?thesis proof (cases ?P)
case False
then obtain x y where "x ∈ inputs M" and "y ∈ outputs M" and "¬ (h_obs M q1 x y = None ⟷ h_obs M q2 x y = None)"
by blast
then consider "h_obs M q1 x y = None ∧ (∃ q2' . h_obs M q2 x y = Some q2')" |
"h_obs M q2 x y = None ∧ (∃ q1' . h_obs M q1 x y = Some q1')"
by fastforce
then show ?thesis proof cases
case 1
then obtain q2' where "h_obs M q1 x y = None" and "h_obs M q2 x y = Some q2'" by blast
then have "f1' (x,y) = Some ((x,y),(None, Some q2'))"
unfolding f1' by force
moreover have "(x,y) ∈ list.set xs"
unfolding xs
using ‹y ∈ outputs M› outputs_as_list_set[of M]
using ‹x ∈ inputs M› inputs_as_list_set[of M]
using image_iff by fastforce
ultimately show ?thesis
by blast
next
case 2
then obtain q1' where "h_obs M q2 x y = None" and "h_obs M q1 x y = Some q1'" by blast
then have "f1' (x,y) = Some ((x,y),(Some q1', None))"
unfolding f1' by force
moreover have "(x,y) ∈ list.set xs"
unfolding xs
using ‹y ∈ outputs M› outputs_as_list_set[of M]
using ‹x ∈ inputs M› inputs_as_list_set[of M]
using image_iff by fastforce
ultimately show ?thesis
by blast
qed
next
case True
obtain io where "length io ≤ Suc k" and "io ∈ LS M q1 ∪ LS M q2" and "io ∉ LS M q1 ∩ LS M q2"
using ‹ofsm_table M (λq . states M) (Suc k) q1 ≠ ofsm_table M (λq . states M) (Suc k) q2›
unfolding ofsm_table_set_observable[OF assms(1,2) minimise_initial_partition] ofsm_table_set_observable[OF assms(1,3) minimise_initial_partition] by blast
then have "io ≠ []"
using assms(2) assms(3) by auto
then have "io = [hd io] @ tl io"
by (metis append.left_neutral append_Cons list.exhaust_sel)
then obtain x y where "hd io = (x,y)"
by (meson prod.exhaust_sel)
have "[(x,y)] ∈ LS M q1 ∩ LS M q2"
proof -
have "[(x,y)] ∈ LS M q1 ∪ LS M q2"
using ‹io ∈ LS M q1 ∪ LS M q2› language_prefix ‹hd io = (x,y)› ‹io = [hd io] @ tl io›
by (metis Un_iff)
then have "x ∈ inputs M" and "y ∈ outputs M"
by auto
consider "[(x,y)] ∈ LS M q1" | "[(x,y)] ∈ LS M q2"
using ‹[(x,y)] ∈ LS M q1 ∪ LS M q2› by blast
then show ?thesis
proof cases
case 1
then have "h_obs M q1 x y ≠ None"
using h_obs_None[OF ‹observable M›] unfolding LS_single_transition by auto
then have "h_obs M q2 x y ≠ None"
using True ‹x ∈ inputs M› ‹y ∈ outputs M› by meson
then show ?thesis
using 1 h_obs_None[OF ‹observable M›]
by (metis IntI LS_single_transition fst_conv snd_conv)
next
case 2
then have "h_obs M q2 x y ≠ None"
using h_obs_None[OF ‹observable M›] unfolding LS_single_transition by auto
then have "h_obs M q1 x y ≠ None"
using True ‹x ∈ inputs M› ‹y ∈ outputs M› by meson
then show ?thesis
using 2 h_obs_None[OF ‹observable M›]
by (metis IntI LS_single_transition fst_conv snd_conv)
qed
qed
then obtain q1' q2' where "(q1,x,y,q1') ∈ transitions M"
and "(q2,x,y,q2') ∈ transitions M"
using LS_single_transition by force
then have "q1' ∈ states M" and "q2' ∈ states M" using fsm_transition_target by auto
have "tl io ∈ LS M q1' ∪ LS M q2'"
using observable_language_transition_target[OF ‹observable M› ‹(q1,x,y,q1') ∈ transitions M›]
observable_language_transition_target[OF ‹observable M› ‹(q2,x,y,q2') ∈ transitions M›]
‹io ∈ LS M q1 ∪ LS M q2›
unfolding fst_conv snd_conv
by (metis Un_iff ‹hd io = (x, y)› ‹io = [hd io] @ tl io› append_Cons append_Nil)
moreover have "tl io ∉ LS M q1' ∩ LS M q2'"
using observable_language_transition_target[OF ‹observable M› ‹(q1,x,y,q1') ∈ transitions M›]
observable_language_transition_target[OF ‹observable M› ‹(q2,x,y,q2') ∈ transitions M›]
‹io ∈ LS M q1 ∪ LS M q2›
unfolding fst_conv snd_conv
by (metis Int_iff LS_prepend_transition ‹(q1, x, y, q1') ∈ FSM.transitions M› ‹(q2, x, y, q2') ∈ FSM.transitions M› ‹hd io = (x, y)› ‹io ≠ []› ‹io ∉ LS M q1 ∩ LS M q2› fst_conv list.collapse snd_conv)
ultimately have "((tl io) ∈ LS M q1') ≠ (tl io ∈ LS M q2')"
by blast
moreover have "length (tl io) ≤ k"
using ‹length io ≤ Suc k› by auto
ultimately have "q2' ∉ ofsm_table M (λq . states M) k q1'"
unfolding ofsm_table_set_observable[OF assms(1) ‹q1' ∈ states M› minimise_initial_partition]
by blast
then have "ofsm_table M (λq . states M) k q1' ≠ ofsm_table M (λq . states M) k q2'"
by (metis ‹q2' ∈ FSM.states M› ofsm_table_containment)
moreover have "h_obs M q1 x y = Some q1'"
using ‹(q1,x,y,q1') ∈ transitions M› ‹observable M› unfolding h_obs_Some[OF ‹observable M›] observable_alt_def by auto
moreover have "h_obs M q2 x y = Some q2'"
using ‹(q2,x,y,q2') ∈ transitions M› ‹observable M› unfolding h_obs_Some[OF ‹observable M›] observable_alt_def by auto
ultimately have "f1' (x,y) = Some ((x,y),(Some q1', Some q2'))"
unfolding f1' by force
moreover have "(x,y) ∈ list.set xs"
unfolding xs
using fsm_transition_output[OF ‹(q1,x,y,q1') ∈ transitions M›] outputs_as_list_set[of M]
using fsm_transition_input[OF ‹(q1,x,y,q1') ∈ transitions M›] inputs_as_list_set[of M]
using image_iff by fastforce
ultimately show ?thesis
by blast
qed
qed
ultimately have "f2 xs = (io,(b,a))"
by blast
then show ?thesis
unfolding select_diverging_ofsm_table_io.simps f2 f2' xs Let_def by auto
qed
lemma assemble_distinguishing_sequence_from_ofsm_table_sym :
assumes "observable M"
and "q1 ∈ states M"
and "q2 ∈ states M"
and "ofsm_table M (λq . states M) k q1 ≠ ofsm_table M (λq . states M) k q2"
shows "assemble_distinguishing_sequence_from_ofsm_table M q1 q2 k = assemble_distinguishing_sequence_from_ofsm_table M q2 q1 k"
using assms(2,3,4) proof (induction k arbitrary: q1 q2)
case 0
then show ?case by auto
next
case (Suc k)
obtain xy a b where "select_diverging_ofsm_table_io M q1 q2 (Suc k) = (xy,(a,b))"
using prod_cases3 by blast
then have "select_diverging_ofsm_table_io M q2 q1 (Suc k) = (xy,(b, a))"
using select_diverging_ofsm_table_io_sym[OF assms(1) Suc.prems] by auto
consider "∃ q1' q2' . a = Some q1' ∧ b = Some q2'" | "a = None ∨ b = None"
using option.exhaust_sel by auto
then show ?case proof cases
case 1
then obtain q1' q2' where "select_diverging_ofsm_table_io M q1 q2 (Suc k) = (xy,(Some q1', Some q2'))"
using ‹select_diverging_ofsm_table_io M q1 q2 (Suc k) = (xy,(a,b))› by auto
then have "select_diverging_ofsm_table_io M q2 q1 (Suc k) = (xy,(Some q2', Some q1'))"
using select_diverging_ofsm_table_io_sym[OF assms(1) Suc.prems] by auto
obtain x y where "select_diverging_ofsm_table_io M q1 q2 (Suc k) = ((x,y),(h_obs M q1 x y, h_obs M q2 x y))"
and "⋀ q1' q2' . h_obs M q1 x y = Some q1' ⟹ h_obs M q2 x y = Some q2' ⟹ ofsm_table M (λq . states M) k q1' ≠ ofsm_table M (λq . states M) k q2'"
and "h_obs M q1 x y ≠ None ∨ h_obs M q2 x y ≠ None"
using select_diverging_ofsm_table_io_Some(1)[OF assms(1) Suc.prems]
by blast
then have "xy = (x,y)" and "h_obs M q1 x y = Some q1'" and "h_obs M q2 x y = Some q2'"
using ‹select_diverging_ofsm_table_io M q1 q2 (Suc k) = (xy,(Some q1', Some q2'))› by auto
then have "q1' ∈ states M" and "q2' ∈ states M"
unfolding h_obs_Some[OF assms(1)] using fsm_transition_target by fastforce+
moreover have "ofsm_table M (λq . states M) k q1' ≠ ofsm_table M (λq . states M) k q2'"
using ‹h_obs M q1 x y = Some q1'› ‹h_obs M q2 x y = Some q2'› ‹⋀ q1' q2' . h_obs M q1 x y = Some q1' ⟹ h_obs M q2 x y = Some q2' ⟹ ofsm_table M (λq . states M) k q1' ≠ ofsm_table M (λq . states M) k q2'›
by blast
ultimately have "assemble_distinguishing_sequence_from_ofsm_table M q1' q2' k = assemble_distinguishing_sequence_from_ofsm_table M q2' q1' k"
using Suc.IH by auto
then show ?thesis
using ‹select_diverging_ofsm_table_io M q1 q2 (Suc k) = (xy,(Some q1', Some q2'))›
‹select_diverging_ofsm_table_io M q2 q1 (Suc k) = (xy,(Some q2', Some q1'))›
by auto
next
case 2
obtain x y where "xy = (x,y)"
using prod.exhaust by metis
have helper: "⋀ f f1 f2 .(case ((x,y),(a,b)) of ((x,y),(Some a',Some b')) ⇒ f1 x y a' b' | ((x,y),_) ⇒ f2 x y) = f2 x y"
using 2 by (metis case_prod_conv option.case_eq_if)
have helper2: "⋀ f f1 f2 .(case ((x,y),(b,a)) of ((x,y),(Some a',Some b')) ⇒ f1 x y a' b' | ((x,y),_) ⇒ f2 x y) = f2 x y"
using 2 by (metis case_prod_conv option.case_eq_if)
have "assemble_distinguishing_sequence_from_ofsm_table M q1 q2 (Suc k) = [xy]"
unfolding assemble_distinguishing_sequence_from_ofsm_table.simps
‹select_diverging_ofsm_table_io M q1 q2 (Suc k) = (xy,(a, b))› ‹xy = (x,y)› helper
by simp
moreover have "assemble_distinguishing_sequence_from_ofsm_table M q2 q1 (Suc k) = [xy]"
unfolding assemble_distinguishing_sequence_from_ofsm_table.simps
‹select_diverging_ofsm_table_io M q2 q1 (Suc k) = (xy,(b, a))› ‹xy = (x,y)› helper2
by simp
ultimately show ?thesis
by simp
qed
qed
lemma find_first_distinct_ofsm_table_sym :
assumes "q1 ∈ FSM.states M"
and "q2 ∈ FSM.states M"
and "ofsm_table_fix M (λq . states M) 0 q1 ≠ ofsm_table_fix M (λq . states M) 0 q2"
shows "find_first_distinct_ofsm_table M q1 q2 = find_first_distinct_ofsm_table M q2 q1"
proof -
have "⋀ q1 q2 . q1 ∈ FSM.states M ⟹ q2 ∈ FSM.states M ⟹ ofsm_table_fix M (λq . states M) 0 q1 ≠ ofsm_table_fix M (λq . states M) 0 q2 ⟹ find_first_distinct_ofsm_table M q2 q1 < find_first_distinct_ofsm_table M q1 q2 ⟹ False"
proof -
fix q1 q2 assume "q1 ∈ FSM.states M" and "q2 ∈ FSM.states M"
and "ofsm_table_fix M (λq . states M) 0 q1 ≠ ofsm_table_fix M (λq . states M) 0 q2"
and "find_first_distinct_ofsm_table M q2 q1 < find_first_distinct_ofsm_table M q1 q2"
show False
using find_first_distinct_ofsm_table_is_first(1)[OF ‹q1 ∈ FSM.states M› ‹q2 ∈ FSM.states M› ‹ofsm_table_fix M (λq . states M) 0 q1 ≠ ofsm_table_fix M (λq . states M) 0 q2›]
find_first_distinct_ofsm_table_is_first(2)[OF ‹q1 ∈ FSM.states M› ‹q2 ∈ FSM.states M› ‹ofsm_table_fix M (λq . states M) 0 q1 ≠ ofsm_table_fix M (λq . states M) 0 q2› ‹find_first_distinct_ofsm_table M q2 q1 < find_first_distinct_ofsm_table M q1 q2›]
‹find_first_distinct_ofsm_table M q2 q1 < find_first_distinct_ofsm_table M q1 q2›
by (metis ‹ofsm_table_fix M (λq . states M) 0 q1 ≠ ofsm_table_fix M (λq . states M) 0 q2› ‹q1 ∈ FSM.states M› ‹q2 ∈ FSM.states M› find_first_distinct_ofsm_table_gt_is_first_gt(1))
qed
then show ?thesis
using assms
by (metis linorder_neqE_nat)
qed
lemma get_distinguishing_sequence_from_ofsm_tables_sym :
assumes "observable M"
and "minimal M"
and "q1 ∈ states M"
and "q2 ∈ states M"
and "q1 ≠ q2"
shows "get_distinguishing_sequence_from_ofsm_tables M q1 q2 = get_distinguishing_sequence_from_ofsm_tables M q2 q1"
proof -
have "ofsm_table_fix M (λq . states M) 0 q1 ≠ ofsm_table_fix M (λq . states M) 0 q2"
using ‹minimal M› unfolding minimal_observable_code[OF assms(1)]
using assms(3,4,5) by blast
let ?k = "find_first_distinct_ofsm_table_gt M q1 q2 0"
have "ofsm_table M (λq . states M) ?k q1 ≠ ofsm_table M (λq . states M) ?k q2"
using find_first_distinct_ofsm_table_is_first(1)[OF assms(3,4) ‹ofsm_table_fix M (λq . states M) 0 q1 ≠ ofsm_table_fix M (λq . states M) 0 q2›] .
show ?thesis
using assemble_distinguishing_sequence_from_ofsm_table_sym[OF assms(1,3,4) ‹ofsm_table M (λq . states M) ?k q1 ≠ ofsm_table M (λq . states M) ?k q2›]
unfolding get_distinguishing_sequence_from_ofsm_tables.simps Let_def
find_first_distinct_ofsm_table_sym[OF assms(3,4) ‹ofsm_table_fix M (λq . states M) 0 q1 ≠ ofsm_table_fix M (λq . states M) 0 q2›] .
qed
subsubsection ‹Harmonised State Identifiers›
fun add_distinguishing_sequence :: "('a,'b::linorder,'c::linorder) fsm ⇒ (('b×'c) list × 'a) × (('b×'c) list × 'a) ⇒ ('b×'c) prefix_tree ⇒ ('b×'c) prefix_tree" where
"add_distinguishing_sequence M ((α,q1), (β,q2)) t = insert empty (get_distinguishing_sequence_from_ofsm_tables M q1 q2)"
lemma add_distinguishing_sequence_distinguishes :
assumes "observable M"
and "minimal M"
and "α ∈ L M"
and "β ∈ L M"
and "after_initial M α ≠ after_initial M β"
shows "∃ io ∈ set (add_distinguishing_sequence M ((α,after_initial M α),(β,after_initial M β)) t) ∪ (set (after t α) ∩ set (after t β)) . distinguishes M (after_initial M α) (after_initial M β) io"
proof -
have "set (add_distinguishing_sequence M ((α,after_initial M α),(β,after_initial M β)) t) = set (insert empty (get_distinguishing_sequence_from_ofsm_tables M (after_initial M α) (after_initial M β)))"
by auto
then have "get_distinguishing_sequence_from_ofsm_tables M (after_initial M α) (after_initial M β) ∈ set (add_distinguishing_sequence M ((α,after_initial M α),(β,after_initial M β)) t) ∪ (set (after t α) ∩ set (after t β))"
unfolding insert_set by auto
then show ?thesis
using get_distinguishing_sequence_from_ofsm_tables_is_distinguishing_trace(1,2)[OF assms(1,2) after_is_state[OF assms(1,3)] after_is_state[OF assms(1,4)] assms(5)]
by (meson distinguishes_def)
qed
lemma add_distinguishing_sequence_finite :
"finite_tree (add_distinguishing_sequence M ((α,after_initial M α),(β,after_initial M β)) t)"
unfolding add_distinguishing_sequence.simps
using insert_finite_tree[OF empty_finite_tree] by metis
fun get_HSI :: "('a::linorder,'b::linorder,'c::linorder) fsm ⇒ 'a ⇒ ('b×'c) prefix_tree" where
"get_HSI M q = from_list (map (λq' . get_distinguishing_sequence_from_ofsm_tables M q q') (filter ((≠) q) (states_as_list M)))"
lemma get_HSI_elem :
assumes "q2 ∈ states M"
and "q2 ≠ q1"
shows "get_distinguishing_sequence_from_ofsm_tables M q1 q2 ∈ set (get_HSI M q1)"
proof -
have "q2 ∈ list.set (filter ((≠) q1) (states_as_list M))"
using assms unfolding states_as_list_set[of M,symmetric] by auto
then have *:"get_distinguishing_sequence_from_ofsm_tables M q1 q2 ∈ list.set (map (λq' . get_distinguishing_sequence_from_ofsm_tables M q1 q') (filter ((≠) q1) (states_as_list M)))"
by auto
show ?thesis
using from_list_set_elem[OF *]
unfolding get_HSI.simps .
qed
lemma get_HSI_distinguishes :
assumes "observable M"
and "minimal M"
and "q1 ∈ states M" and "q2 ∈ states M" and "q1 ≠ q2"
shows "∃ io ∈ set (get_HSI M q1) ∩ set (get_HSI M q2) . distinguishes M q1 q2 io"
proof -
have "get_distinguishing_sequence_from_ofsm_tables M q2 q1 ∈ set (get_HSI M q1)"
using get_HSI_elem[OF assms(4), of q1] assms(5)
unfolding get_distinguishing_sequence_from_ofsm_tables_sym[OF assms]
by metis
moreover have "get_distinguishing_sequence_from_ofsm_tables M q2 q1 ∈ set (get_HSI M q2)"
using get_HSI_elem[OF assms(3)] assms(5) by metis
moreover have "distinguishes M q1 q2 (get_distinguishing_sequence_from_ofsm_tables M q2 q1)"
using get_distinguishing_sequence_from_ofsm_tables_is_distinguishing_trace(1,2)[OF assms]
unfolding get_distinguishing_sequence_from_ofsm_tables_sym[OF assms]
unfolding distinguishes_def
by blast
ultimately show ?thesis
by blast
qed
lemma get_HSI_finite :
"finite_tree (get_HSI M q)"
unfolding get_HSI.simps using from_list_finite_tree by metis
subsubsection ‹Distinguishing Sets›
fun distinguishing_set :: "('a :: linorder, 'b :: linorder, 'c :: linorder) fsm ⇒ ('b × 'c) prefix_tree" where
"distinguishing_set M = (let
pairs = filter (λ (x,y) . x ≠ y) (list_ordered_pairs (states_as_list M))
in from_list (map (case_prod (get_distinguishing_sequence_from_ofsm_tables M)) pairs))"
lemma distinguishing_set_distinguishes :
assumes "observable M"
and "minimal M"
and "q1 ∈ states M"
and "q2 ∈ states M"
and "q1 ≠ q2"
shows "∃ io ∈ set (distinguishing_set M) . distinguishes M q1 q2 io"
proof -
define pairs where pairs: "pairs = filter (λ (x,y) . x ≠ y) (list_ordered_pairs (states_as_list M))"
then have *: "distinguishing_set M = from_list (map (case_prod (get_distinguishing_sequence_from_ofsm_tables M)) pairs)"
by auto
have "q1 ∈ list.set (states_as_list M)" and "q2 ∈ list.set (states_as_list M)"
unfolding states_as_list_set using assms(3,4) by blast+
then have "(q1,q2) ∈ list.set pairs ∨ (q2,q1) ∈ list.set pairs"
using list_ordered_pairs_set_containment[OF _ _ assms(5)] assms(5) unfolding pairs by auto
then have "get_distinguishing_sequence_from_ofsm_tables M q1 q2 ∈ list.set (map (case_prod (get_distinguishing_sequence_from_ofsm_tables M)) pairs)
| get_distinguishing_sequence_from_ofsm_tables M q2 q1 ∈ list.set (map (case_prod (get_distinguishing_sequence_from_ofsm_tables M)) pairs)"
by (metis image_iff old.prod.case set_map)
then have "get_distinguishing_sequence_from_ofsm_tables M q1 q2 ∈ set (distinguishing_set M)
∨ get_distinguishing_sequence_from_ofsm_tables M q2 q1 ∈ set (distinguishing_set M)"
unfolding * from_list_set by blast
then show ?thesis
using get_distinguishing_sequence_from_ofsm_tables_is_distinguishing_trace(1,2)[OF assms]
get_distinguishing_sequence_from_ofsm_tables_is_distinguishing_trace(1,2)[OF assms(1,2,4,3)] assms(5)
unfolding distinguishes_def by blast
qed
lemma distinguishing_set_finite :
"finite_tree (distinguishing_set M)"
unfolding distinguishing_set.simps Let_def
using from_list_finite_tree by metis
function (domintros) intersection_is_distinguishing :: "('a,'b,'c) fsm ⇒ ('b × 'c) prefix_tree ⇒ 'a ⇒ ('b × 'c) prefix_tree ⇒ 'a ⇒ bool" where
"intersection_is_distinguishing M (PT t1) q1 (PT t2) q2 =
(∃ (x,y) ∈ dom t1 ∩ dom t2 .
case h_obs M q1 x y of
None ⇒ h_obs M q2 x y ≠ None |
Some q1' ⇒ (case h_obs M q2 x y of
None ⇒ True |
Some q2' ⇒ intersection_is_distinguishing M (the (t1 (x,y))) q1' (the (t2 (x,y))) q2'))"
by pat_completeness auto
termination
proof -
{
fix M :: "('a,'b,'c) fsm"
fix t1
fix q1
fix t2
fix q2
have "intersection_is_distinguishing_dom (M, t1,q1, t2,q2)"
proof (induction t1 arbitrary: t2 q1 q2)
case (PT m1)
obtain m2 where "t2 = PT m2"
by (metis prefix_tree.exhaust)
have "(⋀xy t1' t2' q1' q2' . m1 xy = Some t1' ⟹ intersection_is_distinguishing_dom (M, t1', q1', t2', q2'))"
proof -
fix xy t1' t2' q1' q2' assume "m1 xy = Some t1'"
then have "Some t1' ∈ range m1"
by (metis range_eqI)
show "intersection_is_distinguishing_dom (M, t1', q1', t2', q2')"
using PT(1)[OF ‹Some t1' ∈ range m1›]
by simp
qed
then show ?case
using intersection_is_distinguishing.domintros[of q1 M q2 m1 m2] unfolding ‹t2 = PT m2› by blast
qed
}
then show ?thesis by auto
qed
lemma intersection_is_distinguishing_code[code] :
"intersection_is_distinguishing M (MPT t1) q1 (MPT t2) q2 =
(∃ (x,y) ∈ Mapping.keys t1 ∩ Mapping.keys t2 .
case h_obs M q1 x y of
None ⇒ h_obs M q2 x y ≠ None |
Some q1' ⇒ (case h_obs M q2 x y of
None ⇒ True |
Some q2' ⇒ intersection_is_distinguishing M (the (Mapping.lookup t1 (x,y))) q1' (the (Mapping.lookup t2 (x,y))) q2'))"
unfolding intersection_is_distinguishing.simps MPT_def
by (simp add: keys_dom_lookup)
lemma intersection_is_distinguishing_correctness :
assumes "observable M"
and "q1 ∈ states M"
and "q2 ∈ states M"
shows "intersection_is_distinguishing M t1 q1 t2 q2 = (∃ io . isin t1 io ∧ isin t2 io ∧ distinguishes M q1 q2 io)"
(is "?P1 = ?P2")
proof
show "?P1 ⟹ ?P2"
proof (induction t1 arbitrary: t2 q1 q2)
case (PT m1)
obtain m2 where "t2 = PT m2"
using prefix_tree.exhaust by blast
then obtain x y where "(x,y) ∈ dom m1" and "(x,y) ∈ dom m2"
and *: "case h_obs M q1 x y of
None ⇒ h_obs M q2 x y ≠ None |
Some q1' ⇒ (case h_obs M q2 x y of
None ⇒ True |
Some q2' ⇒ intersection_is_distinguishing M (the (m1 (x,y))) q1' (the (m2 (x,y))) q2')"
using PT.prems(1) intersection_is_distinguishing.simps by force
obtain t1' where "m1 (x,y) = Some t1'"
using ‹(x,y) ∈ dom m1› by auto
then have "isin (PT m1) [(x,y)]"
by auto
obtain t2' where "m2 (x,y) = Some t2'"
using ‹(x,y) ∈ dom m2› by auto
then have "isin t2 [(x,y)]"
unfolding ‹t2 = PT m2› by auto
show ?case proof (cases "h_obs M q1 x y")
case None
then have "h_obs M q2 x y ≠ None"
using * by auto
then have "[(x,y)] ∈ LS M q2"
unfolding LS_single_transition h_obs_None[OF ‹observable M›]
by fastforce
moreover have "[(x,y)] ∉ LS M q1"
using None unfolding LS_single_transition h_obs_None[OF ‹observable M›]
by auto
ultimately have "distinguishes M q1 q2 [(x,y)]"
unfolding distinguishes_def by blast
then show ?thesis
using ‹isin (PT m1) [(x,y)]› ‹isin t2 [(x,y)]› by blast
next
case (Some q1')
then have "[(x,y)] ∈ LS M q1"
unfolding LS_single_transition h_obs_Some[OF ‹observable M›]
using insert_compr by fastforce
show ?thesis proof (cases "h_obs M q2 x y")
case None
then have "[(x,y)] ∉ LS M q2"
unfolding LS_single_transition h_obs_None[OF ‹observable M›]
by auto
then have "distinguishes M q1 q2 [(x,y)]"
using ‹[(x,y)] ∈ LS M q1› unfolding distinguishes_def by blast
then show ?thesis
using ‹isin (PT m1) [(x,y)]› ‹isin t2 [(x,y)]› by blast
next
case (Some q2')
then have "intersection_is_distinguishing M (the (m1 (x,y))) q1' (the (m2 (x,y))) q2'"
using ‹h_obs M q1 x y = Some q1'› * by auto
moreover have "(the (m1 (x,y))) = t1'"
using ‹m1 (x,y) = Some t1'› by auto
moreover have "(the (m2 (x,y))) = t2'"
using ‹m2 (x,y) = Some t2'› by auto
ultimately have "intersection_is_distinguishing M t1' q1' t2' q2'"
by simp
then have "∃io. isin t1' io ∧ isin t2' io ∧ distinguishes M q1' q2' io"
using PT.IH[of "Some t1'" t1' q1' t2' q2']
by (metis ‹m1 (x, y) = Some t1'› option.set_intros rangeI)
then obtain io where "isin t1' io"
and "isin t2' io"
and "distinguishes M q1' q2' io"
by blast
have "isin (PT m1) ((x,y)#io)"
using ‹m1 (x, y) = Some t1'› ‹isin t1' io› by auto
moreover have "isin t2 ((x,y)#io)"
using ‹t2 = PT m2› ‹m2 (x, y) = Some t2'› ‹isin t2' io› by auto
moreover have "distinguishes M q1 q2 ((x,y)#io)"
using h_obs_language_iff[OF ‹observable M›, of x y io q1] unfolding ‹h_obs M q1 x y = Some q1'›
using h_obs_language_iff[OF ‹observable M›, of x y io q2] unfolding Some
using ‹distinguishes M q1' q2' io›
unfolding distinguishes_def
by auto
ultimately show ?thesis
by blast
qed
qed
qed
show "?P2 ⟹ ?P1"
proof -
assume ?P2
then obtain io where "isin t1 io"
and "isin t2 io"
and "distinguishes M q1 q2 io"
by blast
then show ?P1
using assms(2,3) proof (induction io arbitrary: t1 t2 q1 q2)
case Nil
then have "[] ∈ LS M q1 ∩ LS M q2"
by auto
then have "¬ distinguishes M q1 q2 []"
unfolding distinguishes_def by blast
then show ?case
using ‹distinguishes M q1 q2 []› by simp
next
case (Cons a io)
obtain x y where "a = (x,y)"
by fastforce
obtain m1 where "t1 = PT m1"
using prefix_tree.exhaust by blast
obtain t1' where "m1 (x,y) = Some t1'"
and "isin t1' io"
using ‹isin t1 (a # io)› unfolding ‹a = (x,y)› ‹t1 = PT m1› isin.simps
using case_optionE by blast
obtain m2 where "t2 = PT m2"
using prefix_tree.exhaust by blast
obtain t2' where "m2 (x,y) = Some t2'"
and "isin t2' io"
using ‹isin t2 (a # io)› unfolding ‹a = (x,y)› ‹t2 = PT m2› isin.simps
using case_optionE by blast
then have "(x,y) ∈ dom m1 ∩ dom m2"
using ‹m1 (x,y) = Some t1'› by auto
show ?case proof (cases "h_obs M q1 x y")
case None
then have "[(x,y)] ∉ LS M q1"
unfolding LS_single_transition h_obs_None[OF ‹observable M›]
by auto
then have "a#io ∉ LS M q1"
unfolding ‹a = (x,y)›
by (metis None assms(1) h_obs_language_iff option.distinct(1))
then have "a#io ∈ LS M q2"
using ‹distinguishes M q1 q2 (a#io)› unfolding distinguishes_def by blast
then have "[(x,y)] ∈ LS M q2"
unfolding ‹a = (x,y)›
using language_prefix
by (metis append_Cons append_Nil)
then have "h_obs M q2 x y ≠ None"
unfolding h_obs_None[OF ‹observable M›] LS_single_transition by force
then show ?thesis
using None ‹(x,y) ∈ dom m1 ∩ dom m2› unfolding ‹t1 = PT m1› ‹t2 = PT m2›
by force
next
case (Some q1')
then have "[(x,y)] ∈ LS M q1"
unfolding LS_single_transition h_obs_Some[OF ‹observable M›]
by (metis Some assms(1) fst_conv h_obs_None option.distinct(1) snd_conv)
show ?thesis proof (cases "h_obs M q2 x y")
case None
then show ?thesis
using Some ‹(x,y) ∈ dom m1 ∩ dom m2› unfolding ‹t1 = PT m1› ‹t2 = PT m2›
unfolding intersection_is_distinguishing.simps
by (metis (no_types, lifting) case_prodI option.case_eq_if option.distinct(1))
next
case (Some q2')
have "distinguishes M q1' q2' io"
using h_obs_language_iff[OF ‹observable M›, of x y io q1] unfolding ‹h_obs M q1 x y = Some q1'›
using h_obs_language_iff[OF ‹observable M›, of x y io q2] unfolding Some
using ‹distinguishes M q1 q2 (a#io)› unfolding ‹a = (x,y)› distinguishes_def
by blast
moreover have "q1' ∈ states M" and "q2' ∈ states M"
using Some ‹h_obs M q1 x y = Some q1'› unfolding h_obs_Some[OF ‹observable M›]
using fsm_transition_target[where M=M]
by fastforce+
ultimately have "intersection_is_distinguishing M t1' q1' t2' q2'"
using Cons.IH[OF ‹isin t1' io› ‹isin t2' io›]
by auto
then show ?thesis
using ‹(x,y) ∈ dom m1 ∩ dom m2› Some ‹h_obs M q1 x y = Some q1'›
unfolding ‹t1 = PT m1› ‹t2 = PT m2›
unfolding intersection_is_distinguishing.simps
by (metis (no_types, lifting) ‹m1 (x, y) = Some t1'› ‹m2 (x, y) = Some t2'› case_prodI option.case_eq_if option.distinct(1) option.sel)
qed
qed
qed
qed
qed
fun contains_distinguishing_trace :: "('a,'b,'c) fsm ⇒ ('b × 'c) prefix_tree ⇒ 'a ⇒ 'a ⇒ bool" where
"contains_distinguishing_trace M T q1 q2 = intersection_is_distinguishing M T q1 T q2"
lemma contains_distinguishing_trace_code[code] :
"contains_distinguishing_trace M (MPT t1) q1 q2 =
(∃ (x,y) ∈ Mapping.keys t1.
case h_obs M q1 x y of
None ⇒ h_obs M q2 x y ≠ None |
Some q1' ⇒ (case h_obs M q2 x y of
None ⇒ True |
Some q2' ⇒ contains_distinguishing_trace M (the (Mapping.lookup t1 (x,y))) q1' q2'))"
unfolding intersection_is_distinguishing.simps MPT_def
by (simp add: keys_dom_lookup)
lemma contains_distinguishing_trace_correctness :
assumes "observable M"
and "q1 ∈ states M"
and "q2 ∈ states M"
shows "contains_distinguishing_trace M t q1 q2 = (∃ io . isin t io ∧ distinguishes M q1 q2 io)"
using intersection_is_distinguishing_correctness[OF assms]
by simp
fun distinguishing_set_reduced :: "('a :: linorder, 'b :: linorder, 'c :: linorder) fsm ⇒ ('b × 'c) prefix_tree" where
"distinguishing_set_reduced M = (let
pairs = filter (λ (q,q') . q ≠ q') (list_ordered_pairs (states_as_list M));
handlePair = (λ W (q,q') . if contains_distinguishing_trace M W q q'
then W
else insert W (get_distinguishing_sequence_from_ofsm_tables M q q'))
in foldl handlePair empty pairs)"
lemma distinguishing_set_reduced_distinguishes :
assumes "observable M"
and "minimal M"
and "q1 ∈ states M"
and "q2 ∈ states M"
and "q1 ≠ q2"
shows "∃ io ∈ set (distinguishing_set_reduced M) . distinguishes M q1 q2 io"
proof -
define pairs where pairs: "pairs = filter (λ (x,y) . x ≠ y) (list_ordered_pairs (states_as_list M))"
define handlePair where "handlePair = (λ W (q,q') . if contains_distinguishing_trace M W q q'
then W
else insert W (get_distinguishing_sequence_from_ofsm_tables M q q'))"
have "distinguishing_set_reduced M = foldl handlePair empty pairs"
unfolding distinguishing_set_reduced.simps handlePair_def pairs Let_def by metis
have handlePair_subset: "⋀ W q q' . set W ⊆ set (handlePair W (q,q'))"
unfolding handlePair_def
using insert_set unfolding case_prod_conv
by (metis (mono_tags) Un_upper1 order_refl)
have "q1 ∈ list.set (states_as_list M)" and "q2 ∈ list.set (states_as_list M)"
unfolding states_as_list_set using assms(3,4) by blast+
then have "(q1,q2) ∈ list.set pairs ∨ (q2,q1) ∈ list.set pairs"
using list_ordered_pairs_set_containment[OF _ _ assms(5)] assms(5) unfolding pairs by auto
moreover have "⋀ pairs' . list.set pairs' ⊆ list.set pairs ⟹ (q1,q2) ∈ list.set pairs' ∨ (q2,q1) ∈ list.set pairs' ⟹ (∃ io ∈ set (foldl handlePair empty pairs') . distinguishes M q1 q2 io)"
proof -
fix pairs' assume "list.set pairs' ⊆ list.set pairs" and "(q1,q2) ∈ list.set pairs' ∨ (q2,q1) ∈ list.set pairs'"
then show "(∃ io ∈ set (foldl handlePair empty pairs') . distinguishes M q1 q2 io)"
proof (induction pairs' rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc qq qqs)
define W where "W = foldl handlePair empty qqs"
have "foldl handlePair empty (qqs@[qq]) = handlePair W qq"
unfolding W_def by auto
then have W_subset: "set W ⊆ set (foldl handlePair empty (qqs@[qq]))"
by (metis handlePair_subset prod.collapse)
have handlePair_sym : "handlePair W (q1,q2) = handlePair W (q2,q1)"
unfolding handlePair_def case_prod_conv
unfolding contains_distinguishing_trace_correctness[OF assms(1,3,4)] contains_distinguishing_trace_correctness[OF assms(1,4,3)]
unfolding get_distinguishing_sequence_from_ofsm_tables_sym[OF assms]
using distinguishes_sym
by metis
show ?case proof (cases "qq = (q1,q2) ∨ qq = (q2,q1)")
case True
then have "foldl handlePair empty (qqs@[qq]) = handlePair W (q1,q2)"
unfolding ‹foldl handlePair empty (qqs@[qq]) = handlePair W qq›
using handlePair_sym
by auto
show ?thesis proof (cases "contains_distinguishing_trace M W q1 q2")
case True
then show ?thesis
unfolding contains_distinguishing_trace_correctness[OF assms(1,3,4)]
using W_subset
by auto
next
case False
then have "foldl handlePair empty (qqs@[qq]) = insert W (get_distinguishing_sequence_from_ofsm_tables M q1 q2)"
unfolding ‹foldl handlePair empty (qqs@[qq]) = handlePair W (q1,q2)›
unfolding handlePair_def case_prod_conv
by auto
then have "get_distinguishing_sequence_from_ofsm_tables M q1 q2 ∈ set (foldl handlePair empty (qqs@[qq]))"
using insert_isin
by metis
then show ?thesis
using get_distinguishing_sequence_from_ofsm_tables_distinguishes[OF assms]
by blast
qed
next
case False
then have "(q1, q2) ∈ list.set qqs ∨ (q2, q1) ∈ list.set qqs"
using snoc.prems by auto
then show ?thesis using snoc W_subset unfolding W_def
by (meson dual_order.trans list_prefix_subset subsetD)
qed
qed
qed
ultimately show ?thesis
unfolding ‹distinguishing_set_reduced M = foldl handlePair empty pairs›
by blast
qed
lemma distinguishing_set_reduced_finite :
"finite_tree (distinguishing_set_reduced M)"
proof -
define pairs where pairs: "pairs = filter (λ (x,y) . x ≠ y) (list_ordered_pairs (states_as_list M))"
define handlePair where "handlePair = (λ W (q,q') . if contains_distinguishing_trace M W q q'
then W
else insert W (get_distinguishing_sequence_from_ofsm_tables M q q'))"
have "distinguishing_set_reduced M = foldl handlePair empty pairs"
unfolding distinguishing_set_reduced.simps handlePair_def pairs Let_def by metis
show ?thesis
unfolding ‹distinguishing_set_reduced M = foldl handlePair empty pairs›
proof (induction pairs rule: rev_induct)
case Nil
then show ?case using empty_finite_tree by auto
next
case (snoc qq qqs)
define W where "W = foldl handlePair empty qqs"
have "foldl handlePair empty (qqs@[qq]) = handlePair W qq"
unfolding W_def by auto
have "finite_tree W"
using snoc W_def by auto
then show ?case
unfolding ‹foldl handlePair empty (qqs@[qq]) = handlePair W qq›
unfolding handlePair_def
using insert_finite_tree[of W]
by (simp add: case_prod_unfold)
qed
qed
fun add_distinguishing_set :: "('a :: linorder, 'b :: linorder, 'c :: linorder) fsm ⇒ (('b×'c) list × 'a) × (('b×'c) list × 'a) ⇒ ('b×'c) prefix_tree ⇒ ('b×'c) prefix_tree" where
"add_distinguishing_set M _ t = distinguishing_set M"
lemma add_distinguishing_set_distinguishes :
assumes "observable M"
and "minimal M"
and "α ∈ L M"
and "β ∈ L M"
and "after_initial M α ≠ after_initial M β"
shows "∃ io ∈ set (add_distinguishing_set M ((α,after_initial M α),(β,after_initial M β)) t) ∪ (set (after t α) ∩ set (after t β)) . distinguishes M (after_initial M α) (after_initial M β) io"
using distinguishing_set_distinguishes[OF assms(1,2) after_is_state[OF assms(1,3)] after_is_state[OF assms(1,4)] assms(5)]
by force
lemma add_distinguishing_set_finite :
"finite_tree ((add_distinguishing_set M) x t)"
unfolding add_distinguishing_set.simps distinguishing_set.simps Let_def
using from_list_finite_tree
by simp
subsection ‹Transition Sorting›
definition sort_unverified_transitions_by_state_cover_length :: "('a :: linorder,'b :: linorder,'c :: linorder) fsm ⇒ ('a,'b,'c) state_cover_assignment ⇒ ('a,'b,'c) transition list ⇒ ('a,'b,'c) transition list" where
"sort_unverified_transitions_by_state_cover_length M V ts = (let
default_weight = 2 * size M;
weights = mapping_of (map (λt . (t, length (V (t_source t)) + length (V (t_target t)))) ts);
weight = (λq . case Mapping.lookup weights q of Some w ⇒ w | None ⇒ default_weight)
in mergesort_by_rel (λ t1 t2 . weight t1 ≤ weight t2) ts)"
lemma sort_unverified_transitions_by_state_cover_length_retains_set :
"List.set xs = List.set (sort_unverified_transitions_by_state_cover_length M1 (get_state_cover M1) xs)"
unfolding sort_unverified_transitions_by_state_cover_length_def Let_def
unfolding set_mergesort_by_rel
by simp
end