theory Chapter4
  imports Chapter1 Chapter2 Complex_Main

begin
declare [[smt_timeout = 200]]
text \<open>
\spike
Soon to be filled in with some Hartshorne text.

Key idea for this on 3/10:

If you have a projective plane, defined by meets: points -> lines,
then you can define a NEW set of points:

type_equivalence ppoints = lines

and a new set of lines:

type_equivalence llines = points

in which you swap the role of "point" and "line". We already saw something like this in our
work on the real projective plane, where I suggested that we could use the type "point" (3-coordinate
homogeneous vector) to represent a line (the "line" defined by "points in the plane orthogonal to the
given "normal" vector).

With these two "new" types we can define a new "meets" function:

  fun dmeets :: "ppoint \<Rightarrow> lline \<Rightarrow> bool" where
    "dmeets P k = meets k P"

i.e., the "newpoint P" (which is really a line p) meets the "newline l" (which is really a point L)
exactly if L lies on p in our original projective plane. This new function, dmeets, (together with its
domain and codomain) constitutes a projective plane, called the "dual" of the original plane.

To prove this, we have to (as usual) show the three axioms are true.

\done\<close>

  locale projective_plane_plus =
    projective_plane meets
  for meets :: "'point \<Rightarrow> 'line \<Rightarrow> bool"
begin
    definition dmeets
      where "dmeets P l  \<longleftrightarrow> ( meets l P)"
(* Goal: to prove the theorem that "dmeets is a projective plane" *)

lemma dmeets_p1aa_1:
  assumes "P\<noteq>Q"
  shows "\<exists>l. dmeets P l \<and> dmeets Q l"
  unfolding dmeets_def
  using assms p2 by blast

lemma dmeets_p1aa: "P \<noteq> Q \<longrightarrow> (\<exists>l. dmeets P l \<and> dmeets Q l)"

  using dmeets_p1aa_1 by auto

(* first exercise:
1. what happens if you remove the "forall Q : at the start of that lemma?
2. rewrite that lemma as p1a, in fix-assume-show format
3. PROVE the lemma (you may need to delete the lemma I've written above, or it'll
be used as the "proof" of the rewritten lemma.
*)

lemma dunique_lines:
  fixes B
  fixes l
  fixes m
  assumes diff:"P \<noteq> B"
  assumes "dmeets P l"
  assumes "dmeets B l"
  assumes "dmeets P m"
  assumes "dmeets B m"

  shows "l = m"
  using assms dmeets_def p2 by blast

lemma "dmeets_p1b": "P \<noteq> Q \<longrightarrow> (\<exists>!l. dmeets P l \<and> dmeets Q l)"
  using dmeets_p1aa dunique_lines by blast

lemma "dmeets_p2": "\<forall>l m. l \<noteq> m \<longrightarrow> (\<exists>!P. dmeets P l \<and> dmeets P m)"

  by (simp add: dmeets_def p1)

lemma "dmeets_p3": "\<exists>P Q R. P \<noteq> Q \<and> P \<noteq> R \<and> Q \<noteq> R \<and> \<not> projective_plane_data.collinear dmeets P Q R"
proof -
  obtain l m n where lmn: "l \<noteq> m \<and> l \<noteq> n \<and> m \<noteq> n \<and> \<not> projective_plane_data.collinear meets l m n"
    using p3 by blast
  obtain P where P: "dmeets P l \<and> dmeets P m" using dmeets_p2 lmn by blast
  obtain Q where Q: "dmeets Q m \<and> dmeets Q n" using dmeets_p2 lmn by blast
  obtain R where R: "dmeets R n \<and> dmeets R l" using dmeets_p2 lmn by blast
  have PQ: "P \<noteq> Q" using P Q collinear_def dmeets_def lmn by blast
  have PR: "P \<noteq> R" using P R collinear_def dmeets_def lmn by blast
  have RQ: "R \<noteq> Q" using R Q collinear_def dmeets_def lmn by blast
  thus ?thesis by (smt P Q R dunique_lines lmn projective_plane_data.collinear_def) qed

lemma "pmeets_p4": "\<exists>P Q R. P \<noteq> Q \<and> P \<noteq> R \<and> Q \<noteq> R \<and> dmeets P l \<and> dmeets Q l \<and> dmeets R l"
proof -
  obtain A where A:"\<not> meets l A" using dmeets_def dmeets_p3
    by (smt projective_plane_data.collinear_def)
  obtain m n k where mnk:"meets m A \<and> meets n A \<and> meets k A \<and> m \<noteq> n \<and> n \<noteq> k \<and> m \<noteq>k"
    using p4 by blast
  obtain P where P: "meets l P \<and> meets m P"
    by (metis mnk p1)
 obtain Q where Q: "meets l Q \<and> meets n Q"
   by (metis mnk p1)
 obtain R where R: "meets l R \<and> meets k R"
   by (metis mnk p1)
 have "P \<noteq> Q \<and> P \<noteq> R \<and> Q \<noteq> R \<and> meets l P \<and> meets l Q \<and> meets l R"
   by (metis A P Q R mnk p2)
  thus ?thesis unfolding dmeets_def by auto
qed

lemma "extra_line":
  fixes P
  shows "\<exists> k . \<not> meets P k"
  using dmeets_def dmeets_p3 projective_plane_data.collinear_def by force

text\<open>\daniel This allows us an easy way to prove the duals of theorems
in a projective plane\<close>

interpretation dual:projective_plane dmeets
  unfolding projective_plane_def
  using dmeets_p1b dmeets_p2 dmeets_p3 local.pmeets_p4 by blast

lemma linesOffPoints: (* dual of pointOffLines *)
  fixes P::"'point" and Q::"'point"
  assumes "P \<noteq> Q"
  shows "\<exists>l::'line. (\<not> meets P l) \<and> (\<not> meets Q l)"
  using dual.pointOffLines assms dmeets_def by blast

text\<open>\done\<close>
end

end
text\<open>\seiji \caleb\<close>
locale desarguian_projective_plane_plus =
    projective_plane_plus meets +
    desarguian_proj_plane meets
    for meets :: "'point \<Rightarrow> 'line \<Rightarrow> bool"
begin
lemma perspective_implies_concurrent:
  fixes a and b and c and a' and b' and c' and p
  assumes "desarguian_plane_data.perspective_from_point local.dmeets p a b c a' b' c'"
  shows "(projective_plane_data.concurrent meets a a' p)"
proof -
  obtain P where P: "local.dmeets p P \<and> local.dmeets a P"
    by (metis (full_types) dmeets_def dmeets_p1aa p4)
  obtain A where A: "local.dmeets a A \<and> local.dmeets a' A"
    by (metis (full_types) dmeets_def dmeets_p1aa p4)
  obtain P' where P': "local.dmeets p P' \<and> local.dmeets a' P'"
    by (metis (full_types) dmeets_def dmeets_p1aa p4)

qed
lemma dual_desargues:
  fixes a and b and c and a' and b' and c' and p
  assumes "desarguian_plane_data.perspective_from_point local.dmeets p a b c a' b' c'"
  shows "desarguian_plane_data.perspective_from_line local.dmeets a b c a' b' c'"
proof -
  have conc1: "(projective_plane_data.concurrent meets a a' p)" try
    by (smt assms concurrent_def desarguian_plane_data.intro desarguian_plane_data.perspective_from_point_def dmeets_def dmeets_p1b dmeets_p2 dmeets_p3 local.pmeets_p4 projective_plane.intro projective_plane_data.collinear_def)

qed
end

text\<open>\done \done\<close>


chapter \<open>Löb  Formulas\<close>

(*<*)
theory Loeb_Formula imports Diagonalization Derivability_Conditions
begin
(*>*)

text \<open>The Löb formula, parameterized by a sentence @{term \<phi>}, is defined by diagonalizing @{term "imp P \<phi>"}.\<close>

locale Loeb_Form =
Deduct2
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
+
Repr_SelfSubst
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
  enc
  S
+
HBL1
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
  enc
  P
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var num FvarsT substT Fvars subst
and eql cnj imp all exi
and prv bprv
and enc ("\<langle>_\<rangle>")
and S
and P
begin

text \<open>The Löb formula associated to a formula @{term \<phi>}:\<close>
definition \<phi>L :: "'fmla \<Rightarrow> 'fmla" where "\<phi>L \<phi> \<equiv> diag (imp P \<phi>)"

lemma \<phi>L[simp,intro]: "\<And>\<phi>. \<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> \<phi>L \<phi> \<in> fmla"
and
Fvars_\<phi>L[simp]: "\<phi> \<in> fmla \<Longrightarrow> Fvars \<phi> = {} \<Longrightarrow> Fvars (\<phi>L \<phi>) = {}"
  unfolding \<phi>L_def PP_def by auto

lemma bprv_\<phi>L_eqv:
"\<phi> \<in> fmla \<Longrightarrow> Fvars \<phi>  = {} \<Longrightarrow> bprv (eqv (\<phi>L \<phi>) (imp (PP \<langle>\<phi>L \<phi>\<rangle>) \<phi>))"
  unfolding \<phi>L_def PP_def using bprv_diag_eqv[of "imp P \<phi>"] by auto

lemma prv_\<phi>L_eqv:
"\<phi> \<in> fmla \<Longrightarrow> Fvars \<phi>  = {} \<Longrightarrow> prv (eqv (\<phi>L \<phi>) (imp (PP \<langle>\<phi>L \<phi>\<rangle>) \<phi>))"
  using bprv_prv[OF _ _ bprv_\<phi>L_eqv, simplified] by auto

end \<comment> \<open>context @{locale Loeb_Form}\<close>

(*<*)
end
(*>*)


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Galois Property\<close>
theory Transport_Compositions_Agree_Galois_Property
  imports
    Transport_Compositions_Agree_Base
begin

context transport_comp_agree
begin

lemma galois_propI:
  assumes galois1: "((\<le>\<^bsub>L1\<^esub>) \<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and galois2: "((\<le>\<^bsub>L2\<^esub>) \<unlhd> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and mono_l1: "([in_dom (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m in_dom (\<le>\<^bsub>L2\<^esub>)) l1"
  and mono_r2: "([in_codom (\<le>\<^bsub>R2\<^esub>)] \<Rrightarrow>\<^sub>m in_codom (\<le>\<^bsub>R1\<^esub>)) r2"
  and agree: "([in_dom (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow> [in_codom (\<le>\<^bsub>R2\<^esub>)] \<Rrightarrow> (\<longleftrightarrow>))
    (rel_bimap l1 r2 (\<le>\<^bsub>R1\<^esub>)) (rel_bimap l1 r2 (\<le>\<^bsub>L2\<^esub>))"
  shows "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
proof (rule galois_prop.galois_propI')
  fix x y assume "in_dom (\<le>\<^bsub>L\<^esub>) x" "in_codom (\<le>\<^bsub>R\<^esub>) y"
  with mono_r2 mono_l1 have "in_dom (\<le>\<^bsub>L2\<^esub>) (l1 x)" "in_codom (\<le>\<^bsub>R1\<^esub>) (r2 y)" by auto
  have "x \<le>\<^bsub>L\<^esub> r y \<longleftrightarrow> x \<le>\<^bsub>L1\<^esub> r1 (r2 y)" by simp
  also from galois1 \<open>in_dom (\<le>\<^bsub>L1\<^esub>) x\<close> \<open>in_codom (\<le>\<^bsub>R1\<^esub>) (r2 y)\<close>
    have "... \<longleftrightarrow> l1 x \<le>\<^bsub>R1\<^esub> r2 y"
    by (rule g1.galois_prop_left_rel_right_iff_left_right_rel)
  also from agree \<open>in_dom (\<le>\<^bsub>L1\<^esub>) x\<close> \<open>in_codom (\<le>\<^bsub>R2\<^esub>) y\<close>
    have "... \<longleftrightarrow> l1 x \<le>\<^bsub>L2\<^esub> r2 y" by fastforce
  also from galois2 \<open>in_dom (\<le>\<^bsub>L2\<^esub>) (l1 x)\<close> \<open>in_codom (\<le>\<^bsub>R2\<^esub>) y\<close>
    have "... \<longleftrightarrow> l x \<le>\<^bsub>R2\<^esub> y"
    unfolding l_def
    by (simp add: g2.galois_prop_left_rel_right_iff_left_right_rel)
  finally show "x \<le>\<^bsub>L\<^esub> r y \<longleftrightarrow> l x \<le>\<^bsub>R\<^esub> y" .
qed

end

context transport_comp_same
begin

corollary galois_propI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>R1\<^esub>) \<unlhd> (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "([in_dom (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m in_dom (\<le>\<^bsub>R1\<^esub>)) l1"
  and "([in_codom (\<le>\<^bsub>R2\<^esub>)] \<Rrightarrow>\<^sub>m in_codom (\<le>\<^bsub>R1\<^esub>)) r2"
  shows "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (rule galois_propI) auto

end

end


section \<open>Intermediate Frameworks\<close>

text \<open>This theory provides partial applications of the H, SPY, and Pair-Frameworks.\<close>

theory Intermediate_Frameworks
imports Intermediate_Implementations Test_Suite_Representations "../OFSM_Tables_Refined" Simple_Convergence_Graph Empty_Convergence_Graph
begin

subsection \<open>Partial Applications of the SPY-Framework\<close>

definition spy_framework_static_with_simple_graph :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow>
                              (nat \<Rightarrow> 'a \<Rightarrow> ('b\<times>'c) prefix_tree) \<Rightarrow>
                              nat \<Rightarrow>
                              ('b\<times>'c) prefix_tree"
  where
  "spy_framework_static_with_simple_graph M1
                         dist_fun
                         m
    = spy_framework M1
                  get_state_cover_assignment
                  (handle_state_cover_static dist_fun)
                  (\<lambda> M V ts . ts)
                  (establish_convergence_static dist_fun)
                  (handle_io_pair False True)
                  simple_cg_initial
                  simple_cg_insert
                  simple_cg_lookup_with_conv
                  simple_cg_merge
                  m"

lemma spy_framework_static_with_simple_graph_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
  and     "\<And> q1 q2 . q1 \<in> states M1 \<Longrightarrow> q2 \<in> states M1 \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> \<exists> io . \<forall> k1 k2 . io \<in> set (dist_fun k1 q1) \<inter> set (dist_fun k2 q2) \<and> distinguishes M1 q1 q2 io"
  and     "\<And> q k . q \<in> states M1 \<Longrightarrow> finite_tree (dist_fun k q)"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (spy_framework_static_with_simple_graph M1 dist_fun m)) = (L M2 \<inter> set (spy_framework_static_with_simple_graph M1 dist_fun m)))"
and "finite_tree (spy_framework_static_with_simple_graph M1 dist_fun m)"
  using spy_framework_completeness_and_finiteness[OF assms(1-8),
                                                   of get_state_cover_assignment, OF get_state_cover_assignment_is_state_cover_assignment,
                                                   of "(\<lambda> M V ts . ts)",
                                                   OF _ simple_cg_initial_invar_with_conv[OF assms(1,2)],
                                                   OF _ simple_cg_insert_invar_with_conv[OF assms(1,2)],
                                                   OF _ simple_cg_merge_invar_with_conv[OF assms(1,2)],
                                                   of "handle_state_cover_static dist_fun"
                                                      "establish_convergence_static dist_fun"
                                                      "handle_io_pair False True"
                                                   ]
  using handle_state_cover_static_separates_state_cover[OF assms(9,10)]
  using establish_convergence_static_verifies_transition[of M1 dist_fun M2 "get_state_cover_assignment M1" simple_cg_initial simple_cg_insert simple_cg_lookup_with_conv, OF assms(9,10)]
  using handle_io_pair_verifies_io_pair[of False True M1 M2 simple_cg_insert simple_cg_lookup_with_conv]
  unfolding spy_framework_static_with_simple_graph_def
  by blast+

definition spy_framework_static_with_empty_graph :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow>
                              (nat \<Rightarrow> 'a \<Rightarrow> ('b\<times>'c) prefix_tree) \<Rightarrow>
                              nat \<Rightarrow>
                              ('b\<times>'c) prefix_tree"
  where
  "spy_framework_static_with_empty_graph M1
                 dist_fun
                 m
    = spy_framework M1
                     get_state_cover_assignment
                     (handle_state_cover_static dist_fun)
                     (\<lambda> M V ts . ts)
                     (establish_convergence_static dist_fun)
                     (handle_io_pair False True)
                     empty_cg_initial
                     empty_cg_insert
                     empty_cg_lookup
                     empty_cg_merge
                     m"

lemma spy_framework_static_with_empty_graph_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
  and     "\<And> q1 q2 . q1 \<in> states M1 \<Longrightarrow> q2 \<in> states M1 \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> \<exists> io . \<forall> k1 k2 . io \<in> set (dist_fun k1 q1) \<inter> set (dist_fun k2 q2) \<and> distinguishes M1 q1 q2 io"
  and     "\<And> q k . q \<in> states M1 \<Longrightarrow> finite_tree (dist_fun k q)"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (spy_framework_static_with_empty_graph M1 dist_fun m)) = (L M2 \<inter> set (spy_framework_static_with_empty_graph M1 dist_fun m)))"
and "finite_tree (spy_framework_static_with_empty_graph M1 dist_fun m)"
  using spy_framework_completeness_and_finiteness[OF assms(1-8),
                                                   of get_state_cover_assignment, OF get_state_cover_assignment_is_state_cover_assignment,
                                                   of "(\<lambda> M V ts . ts)",
                                                   OF _ empty_graph_initial_invar,
                                                   OF _ empty_graph_insert_invar,
                                                   OF _ empty_graph_merge_invar,
                                                   of "handle_state_cover_static dist_fun"
                                                      "establish_convergence_static dist_fun"
                                                      "handle_io_pair False True"
                                                   ]
  using handle_state_cover_static_separates_state_cover[OF assms(9,10)]
  using establish_convergence_static_verifies_transition[of M1 dist_fun M2 "get_state_cover_assignment M1" empty_cg_initial empty_cg_insert empty_cg_lookup, OF assms(9,10)]
  using handle_io_pair_verifies_io_pair[of False True M1 M2 empty_cg_insert empty_cg_lookup]
  unfolding spy_framework_static_with_empty_graph_def
  by blast+

subsection \<open>Partial Applications of the H-Framework\<close>

definition h_framework_static_with_simple_graph :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow>
                                        (nat \<Rightarrow> 'a \<Rightarrow> ('b\<times>'c) prefix_tree) \<Rightarrow>
                                        nat \<Rightarrow>
                                        ('b\<times>'c) prefix_tree"
  where
  "h_framework_static_with_simple_graph M1 dist_fun m =
    h_framework M1
                   get_state_cover_assignment
                   (handle_state_cover_static dist_fun)
                   (\<lambda> M V ts . ts)
                   (handleUT_static dist_fun)
                   (handle_io_pair False False)
                   simple_cg_initial
                   simple_cg_insert
                   simple_cg_lookup_with_conv
                   simple_cg_merge
                   m"

lemma h_framework_static_with_simple_graph_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('e,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
  and     "\<And> q1 q2 . q1 \<in> states M1 \<Longrightarrow> q2 \<in> states M1 \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> \<exists> io . \<forall> k1 k2 . io \<in> set (dist_fun k1 q1) \<inter> set (dist_fun k2 q2) \<and> distinguishes M1 q1 q2 io"
  and     "\<And> q k . q \<in> states M1 \<Longrightarrow> finite_tree (dist_fun k q)"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (h_framework_static_with_simple_graph  M1 dist_fun m)) = (L M2 \<inter> set (h_framework_static_with_simple_graph  M1 dist_fun m)))"
and "finite_tree (h_framework_static_with_simple_graph  M1 dist_fun m)"
  using h_framework_completeness_and_finiteness[OF assms(1-8),
                                             of get_state_cover_assignment
                                                "(\<lambda> M V ts . ts)" ,
                                             OF get_state_cover_assignment_is_state_cover_assignment
                                                _
                                                simple_cg_initial_invar_with_conv[OF assms(1,2)]
                                                simple_cg_insert_invar_with_conv[OF assms(1,2)]
                                                simple_cg_merge_invar_with_conv[OF assms(1,2)]
                                                handle_state_cover_static_separates_state_cover[OF assms(9,10)]
                                                handleUT_static_handles_transition[OF assms(9,10)]
                                                verifies_io_pair_handled[OF handle_io_pair_verifies_io_pair[of False False M1 M2 simple_cg_insert simple_cg_lookup_with_conv]]
                                             ]
  unfolding h_framework_static_with_simple_graph_def[symmetric]
  by presburger+

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

lemma h_framework_static_with_simple_graph_lists_completeness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
  and     "\<And> q1 q2 . q1 \<in> states M1 \<Longrightarrow> q2 \<in> states M1 \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> \<exists> io . \<forall> k1 k2 . io \<in> set (dist_fun k1 q1) \<inter> set (dist_fun k2 q2) \<and> distinguishes M1 q1 q2 io"
  and     "\<And> q k . q \<in> states M1 \<Longrightarrow> finite_tree (dist_fun k q)"
shows "(L M1 = L M2) \<longleftrightarrow> list_all (passes_test_case M2 (initial M2)) (h_framework_static_with_simple_graph_lists M1 dist_fun m)"
  unfolding h_framework_static_with_simple_graph_lists_def
  using h_framework_static_with_simple_graph_completeness_and_finiteness(1)[OF assms(1,2,3,4,5,6,7,8,9,10)]
  using passes_test_cases_from_io_tree[OF assms(1,2) fsm_initial fsm_initial h_framework_static_with_simple_graph_completeness_and_finiteness(2)[OF assms]]
  by blast

definition h_framework_static_with_empty_graph :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow>
                                        (nat \<Rightarrow> 'a \<Rightarrow> ('b\<times>'c) prefix_tree) \<Rightarrow>
                                        nat \<Rightarrow>
                                        ('b\<times>'c) prefix_tree"
  where
  "h_framework_static_with_empty_graph M1 dist_fun m =
    h_framework M1
                   get_state_cover_assignment
                   (handle_state_cover_static dist_fun)
                   (\<lambda> M V ts . ts)
                   (handleUT_static dist_fun)
                   (handle_io_pair False False)
                   empty_cg_initial
                   empty_cg_insert
                   empty_cg_lookup
                   empty_cg_merge
                   m"

lemma h_framework_static_with_empty_graph_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('e,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
  and     "\<And> q1 q2 . q1 \<in> states M1 \<Longrightarrow> q2 \<in> states M1 \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> \<exists> io . \<forall> k1 k2 . io \<in> set (dist_fun k1 q1) \<inter> set (dist_fun k2 q2) \<and> distinguishes M1 q1 q2 io"
  and     "\<And> q k . q \<in> states M1 \<Longrightarrow> finite_tree (dist_fun k q)"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (h_framework_static_with_empty_graph  M1 dist_fun m)) = (L M2 \<inter> set (h_framework_static_with_empty_graph  M1 dist_fun m)))"
and "finite_tree (h_framework_static_with_empty_graph  M1 dist_fun m)"
  using h_framework_completeness_and_finiteness[OF assms(1-8),
                                             of get_state_cover_assignment
                                                "(\<lambda> M V ts . ts)" ,
                                             OF get_state_cover_assignment_is_state_cover_assignment
                                                _
                                                empty_graph_initial_invar
                                                empty_graph_insert_invar
                                                empty_graph_merge_invar
                                                handle_state_cover_static_separates_state_cover[OF assms(9,10)]
                                                handleUT_static_handles_transition[OF assms(9,10)]
                                                verifies_io_pair_handled[OF handle_io_pair_verifies_io_pair[of False False M1 M2 empty_cg_insert empty_cg_lookup]]
                                             ]
  unfolding h_framework_static_with_empty_graph_def[symmetric]
  by presburger+

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

lemma h_framework_static_with_empty_graph_lists_completeness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
  and     "\<And> q1 q2 . q1 \<in> states M1 \<Longrightarrow> q2 \<in> states M1 \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> \<exists> io . \<forall> k1 k2 . io \<in> set (dist_fun k1 q1) \<inter> set (dist_fun k2 q2) \<and> distinguishes M1 q1 q2 io"
  and     "\<And> q k . q \<in> states M1 \<Longrightarrow> finite_tree (dist_fun k q)"
shows "(L M1 = L M2) \<longleftrightarrow> list_all (passes_test_case M2 (initial M2)) (h_framework_static_with_empty_graph_lists M1 dist_fun m)"
  unfolding h_framework_static_with_empty_graph_lists_def
  using h_framework_static_with_empty_graph_completeness_and_finiteness(1)[OF assms(1,2,3,4,5,6,7,8,9,10)]
  using passes_test_cases_from_io_tree[OF assms(1,2) fsm_initial fsm_initial h_framework_static_with_empty_graph_completeness_and_finiteness(2)[OF assms]]
  by blast

definition h_framework_dynamic :: "
              (('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) state_cover_assignment \<Rightarrow> ('a,'b,'c) transition \<Rightarrow> ('a,'b,'c) transition list \<Rightarrow> nat \<Rightarrow> bool) \<Rightarrow>
              ('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow>
              nat \<Rightarrow>
              bool \<Rightarrow>
              bool \<Rightarrow>
              ('b\<times>'c) prefix_tree"
  where
  "h_framework_dynamic convergence_decisision M1 m completeInputTraces useInputHeuristic =
    h_framework M1
                   get_state_cover_assignment
                   (handle_state_cover_dynamic completeInputTraces useInputHeuristic (get_distinguishing_sequence_from_ofsm_tables M1))
                   sort_unverified_transitions_by_state_cover_length
                   (handleUT_dynamic completeInputTraces useInputHeuristic (get_distinguishing_sequence_from_ofsm_tables M1) convergence_decisision)
                   (handle_io_pair completeInputTraces useInputHeuristic)
                   simple_cg_initial
                   simple_cg_insert
                   simple_cg_lookup_with_conv
                   simple_cg_merge
                   m"

lemma h_framework_dynamic_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('e,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (h_framework_dynamic convergenceDecision M1 m completeInputTraces useInputHeuristic)) = (L M2 \<inter> set (h_framework_dynamic convergenceDecision M1 m completeInputTraces useInputHeuristic)))"
and "finite_tree (h_framework_dynamic convergenceDecision M1 m completeInputTraces useInputHeuristic)"
  using h_framework_completeness_and_finiteness[OF assms,
                                             of get_state_cover_assignment
                                                sort_unverified_transitions_by_state_cover_length ,
                                             OF get_state_cover_assignment_is_state_cover_assignment
                                                sort_unverified_transitions_by_state_cover_length_retains_set[of _ M1 get_state_cover_assignment]
                                                simple_cg_initial_invar_with_conv[OF assms(1,2)]
                                                simple_cg_insert_invar_with_conv[OF assms(1,2)]
                                                simple_cg_merge_invar_with_conv[OF assms(1,2)]
                                                handle_state_cover_dynamic_separates_state_cover[OF get_distinguishing_sequence_from_ofsm_tables_distinguishes[OF assms(1,3)], of completeInputTraces useInputHeuristic M2 simple_cg_initial simple_cg_insert simple_cg_lookup_with_conv]
                                                handleUT_dynamic_handles_transition[of M1 "(get_distinguishing_sequence_from_ofsm_tables M1)" completeInputTraces useInputHeuristic convergenceDecision M2 _ _ simple_cg_insert simple_cg_lookup_with_conv simple_cg_merge, OF get_distinguishing_sequence_from_ofsm_tables_distinguishes[OF assms(1,3)]]
                                                verifies_io_pair_handled[OF handle_io_pair_verifies_io_pair[of completeInputTraces useInputHeuristic M1 M2 simple_cg_insert simple_cg_lookup_with_conv]]
                                             ]
  unfolding h_framework_dynamic_def[symmetric]
  by presburger+

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

lemma h_framework_dynamic_lists_completeness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> list_all (passes_test_case M2 (initial M2)) (h_framework_dynamic_lists convergenceDecision M1 m completeInputTraces useInputHeuristic)"
  unfolding h_framework_dynamic_lists_def
            h_framework_dynamic_completeness_and_finiteness(1)[OF assms, of convergenceDecision completeInputTraces useInputHeuristic]
            passes_test_cases_from_io_tree[OF assms(1,2) fsm_initial fsm_initial h_framework_dynamic_completeness_and_finiteness(2)[OF assms]]
  by blast

subsection \<open>Partial Applications of the Pair-Framework\<close>

definition pair_framework_h_components :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow>
                                           (('a,'b,'c) fsm \<Rightarrow> (('b \<times> 'c) list \<times> 'a) \<times> ('b \<times> 'c) list \<times> 'a \<Rightarrow> ('b \<times> 'c) prefix_tree \<Rightarrow> ('b \<times> 'c) prefix_tree) \<Rightarrow>
                                           ('b\<times>'c) prefix_tree"
where
  "pair_framework_h_components M m get_separating_traces = (let
    V = get_state_cover_assignment M
  in pair_framework M m (get_initial_test_suite_H V) (get_pairs_H V) get_separating_traces)"

lemma pair_framework_h_components_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('e,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
  and     "\<And> \<alpha> \<beta> t . \<alpha> \<in> L M1 \<Longrightarrow> \<beta> \<in> L M1 \<Longrightarrow> after_initial M1 \<alpha> \<noteq> after_initial M1 \<beta> \<Longrightarrow> \<exists> io \<in> set (get_separating_traces M1 ((\<alpha>,after_initial M1 \<alpha>),(\<beta>,after_initial M1 \<beta>)) t) \<union> (set (after t \<alpha>) \<inter> set (after t \<beta>)) . distinguishes M1 (after_initial M1 \<alpha>) (after_initial M1 \<beta>) io"
  and     "\<And> \<alpha> \<beta> t . \<alpha> \<in> L M1 \<Longrightarrow> \<beta> \<in> L M1 \<Longrightarrow> after_initial M1 \<alpha> \<noteq> after_initial M1 \<beta> \<Longrightarrow> finite_tree (get_separating_traces M1 ((\<alpha>,after_initial M1 \<alpha>),(\<beta>,after_initial M1 \<beta>)) t)"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (pair_framework_h_components M1 m get_separating_traces)) = (L M2 \<inter> set (pair_framework_h_components M1 m get_separating_traces)))"
and "finite_tree (pair_framework_h_components M1 m get_separating_traces)"
proof -
  show "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (pair_framework_h_components M1 m get_separating_traces)) = (L M2 \<inter> set (pair_framework_h_components M1 m get_separating_traces)))"
    using pair_framework_completeness[ OF assms(1,2,3,5,4,6,7) get_state_cover_assignment_is_state_cover_assignment
                                     , of "get_initial_test_suite_H (get_state_cover_assignment M1)" "get_pairs_H (get_state_cover_assignment M1)" get_separating_traces
                                     , OF get_initial_test_suite_H_set_and_finite(1)[of "get_state_cover_assignment M1" M1 m]
                                     , OF get_pairs_H_set(1)[OF assms(1) get_state_cover_assignment_is_state_cover_assignment, where m=m] assms(8)
                                     ]
    unfolding pair_framework_h_components_def Let_def
    using get_pairs_H_set(1)[OF assms(1) get_state_cover_assignment_is_state_cover_assignment, where m=m]
    using assms(8)
    unfolding pair_framework_h_components_def Let_def
    by presburger

  show "finite_tree (pair_framework_h_components M1 m get_separating_traces)"
    using pair_framework_finiteness[of M1 get_separating_traces "get_initial_test_suite_H (get_state_cover_assignment M1)" m "get_pairs_H (get_state_cover_assignment M1)",
                                    OF assms(9) get_initial_test_suite_H_set_and_finite(2)[of "get_state_cover_assignment M1" M1 m] get_pairs_H_set(2)[OF assms(1) get_state_cover_assignment_is_state_cover_assignment] ]
    unfolding pair_framework_h_components_def Let_def
    by auto
qed

definition pair_framework_h_components_2 :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow>
                                           (('a,'b,'c) fsm \<Rightarrow> (('b \<times> 'c) list \<times> 'a) \<times> ('b \<times> 'c) list \<times> 'a \<Rightarrow> ('b \<times> 'c) prefix_tree \<Rightarrow> ('b \<times> 'c) prefix_tree) \<Rightarrow>
                                            bool \<Rightarrow>
                                           ('b\<times>'c) prefix_tree"
where
  "pair_framework_h_components_2 M m get_separating_traces c = (let
    V = get_state_cover_assignment M
  in pair_framework M m (get_initial_test_suite_H_2 c V) (get_pairs_H V) get_separating_traces)"

lemma pair_framework_h_components_2_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('e,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
  and     "\<And> \<alpha> \<beta> t . \<alpha> \<in> L M1 \<Longrightarrow> \<beta> \<in> L M1 \<Longrightarrow> after_initial M1 \<alpha> \<noteq> after_initial M1 \<beta> \<Longrightarrow> \<exists> io \<in> set (get_separating_traces M1 ((\<alpha>,after_initial M1 \<alpha>),(\<beta>,after_initial M1 \<beta>)) t) \<union> (set (after t \<alpha>) \<inter> set (after t \<beta>)) . distinguishes M1 (after_initial M1 \<alpha>) (after_initial M1 \<beta>) io"
  and     "\<And> \<alpha> \<beta> t . \<alpha> \<in> L M1 \<Longrightarrow> \<beta> \<in> L M1 \<Longrightarrow> after_initial M1 \<alpha> \<noteq> after_initial M1 \<beta> \<Longrightarrow> finite_tree (get_separating_traces M1 ((\<alpha>,after_initial M1 \<alpha>),(\<beta>,after_initial M1 \<beta>)) t)"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (pair_framework_h_components_2 M1 m get_separating_traces c)) = (L M2 \<inter> set (pair_framework_h_components_2 M1 m get_separating_traces c)))"
and "finite_tree (pair_framework_h_components_2 M1 m get_separating_traces c)"
proof -
  show "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (pair_framework_h_components_2 M1 m get_separating_traces c)) = (L M2 \<inter> set (pair_framework_h_components_2 M1 m get_separating_traces c)))"
    using pair_framework_completeness[ OF assms(1,2,3,5,4,6,7) get_state_cover_assignment_is_state_cover_assignment
                                     , of "get_initial_test_suite_H_2 c (get_state_cover_assignment M1)" "get_pairs_H (get_state_cover_assignment M1)" get_separating_traces
                                     , OF get_initial_test_suite_H_2_set_and_finite(1)[of "get_state_cover_assignment M1" M1 m]
                                     , OF get_pairs_H_set(1)[OF assms(1) get_state_cover_assignment_is_state_cover_assignment, where m=m] assms(8)
                                     ]
    unfolding pair_framework_h_components_2_def Let_def
    using get_pairs_H_set(1)[OF assms(1) get_state_cover_assignment_is_state_cover_assignment, where m=m]
    using assms(8)
    unfolding pair_framework_h_components_def Let_def
    by presburger

  show "finite_tree (pair_framework_h_components_2 M1 m get_separating_traces c)"
    using pair_framework_finiteness[of M1 get_separating_traces "get_initial_test_suite_H_2 c (get_state_cover_assignment M1)" m "get_pairs_H (get_state_cover_assignment M1)",
                                    OF assms(9) get_initial_test_suite_H_2_set_and_finite(2)[of c "get_state_cover_assignment M1" M1 m] get_pairs_H_set(2)[OF assms(1) get_state_cover_assignment_is_state_cover_assignment] ]
    unfolding pair_framework_h_components_2_def Let_def
    by auto
qed

subsection \<open>Code Generation\<close>

(* one-time pre-computation of OFSM tables *)
lemma h_framework_dynamic_code[code] :
  "h_framework_dynamic convergence_decisision M1 m completeInputTraces useInputHeuristic = (let
      tables = (compute_ofsm_tables M1 (size M1 - 1));
      distMap = mapping_of (map (\<lambda> (q1,q2) . ((q1,q2), get_distinguishing_sequence_from_ofsm_tables_with_provided_tables tables M1 q1 q2))
                        (filter (\<lambda> qq . fst qq \<noteq> snd qq) (List.product (states_as_list M1) (states_as_list M1))));
      distHelper = (\<lambda> q1 q2 . if q1 \<in> states M1 \<and> q2 \<in> states M1 \<and> q1 \<noteq> q2 then the (Mapping.lookup distMap (q1,q2)) else get_distinguishing_sequence_from_ofsm_tables M1 q1 q2)
    in
      h_framework  M1
                   get_state_cover_assignment
                   (handle_state_cover_dynamic completeInputTraces useInputHeuristic distHelper)
                   sort_unverified_transitions_by_state_cover_length
                   (handleUT_dynamic completeInputTraces useInputHeuristic distHelper convergence_decisision)
                   (handle_io_pair completeInputTraces useInputHeuristic)
                   simple_cg_initial
                   simple_cg_insert
                   simple_cg_lookup_with_conv
                   simple_cg_merge
                   m)"
  unfolding h_framework_dynamic_def
  apply (subst (1 2) get_distinguishing_sequence_from_ofsm_tables_precomputed[of M1])
  unfolding Let_def
  by presburger

end


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

theory IND_CPA_PK imports
  CryptHOL.Computational_Model
  CryptHOL.Negligible
begin

subsection \<open>The IND-CPA game for public-key encryption with oracle access\<close>

locale ind_cpa_pk =
  fixes key_gen :: "('pubkey \<times> 'privkey, 'call, 'ret) gpv" \<comment> \<open>probabilistic\<close>
  and aencrypt :: "'pubkey \<Rightarrow> 'plain \<Rightarrow> ('cipher, 'call, 'ret) gpv"  \<comment> \<open>probabilistic w/ access to an oracle\<close>
  and adecrypt :: "'privkey \<Rightarrow> 'cipher \<Rightarrow> ('plain, 'call, 'ret) gpv" \<comment> \<open>not used\<close>
  and valid_plains :: "'plain \<Rightarrow> 'plain \<Rightarrow> bool" \<comment> \<open>checks whether a pair of plaintexts is valid, i.e., they have the right format\<close>
begin

text \<open>
  We cannot incorporate the predicate @{term valid_plain} in the type @{typ "'plain"} of plaintexts,
  because the single @{typ "'plain"} must contain plaintexts for all values of the security parameter,
  as HOL does not have dependent types.  Consequently, the game has to ensure that the received
  plaintexts are valid.
\<close>

type_synonym ('pubkey', 'plain', 'cipher', 'call', 'ret', 'state) adversary =
  "('pubkey' \<Rightarrow> (('plain' \<times> 'plain') \<times> 'state, 'call', 'ret') gpv)
   \<times> ('cipher' \<Rightarrow> 'state \<Rightarrow> (bool, 'call', 'ret') gpv)"

fun ind_cpa :: "('pubkey, 'plain, 'cipher, 'call, 'ret, 'state) adversary \<Rightarrow> (bool, 'call, 'ret) gpv"
where
  "ind_cpa (\1, \2) = TRY do {
     (pk, sk) \<leftarrow> key_gen;
     b \<leftarrow> lift_spmf coin_spmf;
     ((m0, m1), \<sigma>) \<leftarrow> (\1 pk);
     assert_gpv (valid_plains m0 m1);
     cipher \<leftarrow> aencrypt pk (if b then m0 else m1);
     guess \<leftarrow> \2 cipher \<sigma>;
     Done (guess = b)
   } ELSE lift_spmf coin_spmf"

definition advantage :: "('\<sigma> \<Rightarrow> 'call \<Rightarrow> ('ret \<times> '\<sigma>) spmf) \<Rightarrow> '\<sigma> \<Rightarrow> ('pubkey, 'plain, 'cipher, 'call, 'ret, 'state) adversary \<Rightarrow> real"
where "advantage oracle \<sigma> \ = \<bar>spmf (run_gpv oracle (ind_cpa \) \<sigma>) True - 1/2\<bar>"

lemma advantage_nonneg: "advantage oracle \<sigma> \ \<ge> 0" by(simp add: advantage_def)

definition ibounded_by :: "('call \<Rightarrow> bool) \<Rightarrow> ('pubkey, 'plain, 'cipher, 'call, 'ret, 'state) adversary \<Rightarrow> enat \<Rightarrow> bool"
where
  "ibounded_by consider = (\<lambda>(\1, \2) q.
  (\<exists>q1 q2. (\<forall>pk. interaction_bounded_by consider (\1 pk) q1) \<and> (\<forall>cipher \<sigma>. interaction_bounded_by consider (\2 cipher \<sigma>) q2) \<and> q1 + q2 \<le> q))"

lemma ibounded_by'E [consumes 1, case_names ibounded_by', elim?]:
  assumes "ibounded_by consider (\1, \2) q"
  obtains q1 q2
  where "q1 + q2 \<le> q"
  and "\<And>pk. interaction_bounded_by consider (\1 pk) q1"
  and "\<And>cipher \<sigma>. interaction_bounded_by consider (\2 cipher \<sigma>) q2"
using assms by(auto simp add: ibounded_by_def)

lemma ibounded_byI [intro?]:
  "\<lbrakk> \<And>pk. interaction_bounded_by consider (\1 pk) q1; \<And>cipher \<sigma>. interaction_bounded_by consider (\2 cipher \<sigma>) q2; q1 + q2 \<le> q \<rbrakk>
  \<Longrightarrow> ibounded_by consider (\1, \2) q"
by(auto simp add: ibounded_by_def)

definition lossless :: "('pubkey, 'plain, 'cipher, 'call, 'ret, 'state) adversary \<Rightarrow> bool"
where "lossless = (\<lambda>(\1, \2). (\<forall>pk. lossless_gpv \_full (\1 pk)) \<and> (\<forall>cipher \<sigma>. lossless_gpv \_full (\2 cipher \<sigma>)))"

end

end


theory weird_nat_add3_assoc3
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3 :: "Nat => Nat => Nat => Nat" where
"add3 (Z) (Z) z = z"
| "add3 (Z) (S y2) z = S (add3 Z y2 z)"
| "add3 (S x2) y z = S (add3 x2 y z)"

(*hipster add3 *)

theorem x0 :
  "!! (x1 :: Nat) (x2 :: Nat) (x3 :: Nat) (x4 :: Nat) (x5 :: Nat) .
     (add3 x1 (add3 x2 x3 x4) x5) = (add3 x1 x2 (add3 x3 x4 x5))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory ModifyStringToCharTuples
  imports Main
begin

definition isAlpha :: "char \<Rightarrow> bool" where
"isAlpha chr = (let val = nat_of_char chr  in  (65  \<le>  val \<and> val \<le> 90 ) \<or> (97 \<le> val \<and> val \<le> 122))"

declare isAlpha_def [simp]

lemma isAlphaTest1 : "isAlpha CHR ''a''" by simp

lemma isAlphaTest2 : "isAlpha CHR ''A''" by simp

lemma isAlphaTest3 : "isAlpha CHR ''z''" by simp

lemma isAlphaTest4 : "isAlpha CHR ''Z''" by simp

(*simple snaity proof*)
theorem "(\<exists>x . isAlpha x = False) \<and> (\<exists>x. isAlpha x = True)"
proof -
  have "isAlpha CHR ''}''= False" by simp
  hence tmp:"\<exists>x . isAlpha x = False" by (rule exI)

  have "isAlpha CHR ''a''= True" by simp
  hence "\<exists>x . isAlpha x = True" by (rule exI)

  with  tmp show ?thesis by (rule conjI)
qed

definition "allLetterNats = set ([ nat_of_char CHR ''a'' ..< nat_of_char CHR ''z'' + 1] @ [nat_of_char CHR ''A'' ..< nat_of_char CHR ''Z'' + 1])"

definition "allNotLetterNats = set (map (nat_of_char) (Enum.enum :: char list)) - allLetterNats"

declare allLetterNats_def [simp]

declare allNotLetterNats_def [simp]

lemma helper1:"x \<in> set [n ..< m] \<Longrightarrow> n \<le>  x  \<and>  x < m " by simp

lemma helper2:"x \<in> set ([n ..<m] @ [a ..<b]) \<Longrightarrow> (n \<le> x \<and> x < m) \<or> (a \<le> x \<and> x < b)" by simp

theorem "nat_of_char x \<in> allLetterNats \<Longrightarrow> isAlpha x" by auto

lemma "nat_of_char (x :: char) < 256" by simp

lemma helper3:"x \<in> allNotLetterNats \<Longrightarrow> x < 65 \<or> (90 < x \<and> x < 97) \<or> 122 < x"  (*takes some time to compute*) by (auto ; arith)

lemma helper3'':"x \<in> allNotLetterNats \<Longrightarrow> x < 256" by auto

lemma helper3':" noc \<in>  allNotLetterNats \<Longrightarrow> (noc < 65 \<or> (90 < noc \<and> noc < 97) \<or> 122 < noc) \<and> noc < 256" using helper3 helper3'' by simp

lemma helper4:"noc = nat_of_char x \<Longrightarrow> \<not>isAlpha x = (noc < 65 \<or> (90 < noc \<and> noc < 97) \<or> 122 < noc) " by (auto simp add : Let_def )

theorem "nat_of_char x \<in> allNotLetterNats \<Longrightarrow> isAlpha x = False"
proof -
  let ?noc="nat_of_char x"
  assume hyp:"nat_of_char x \<in> allNotLetterNats"
  hence "(?noc < 65 \<or> (90 < ?noc \<and> ?noc < 97) \<or> 122 < ?noc) " by (rule helper3)
  thus ?thesis using helper4 by simp
qed

primrec transform :: "string \<Rightarrow> string" where
"transform [] = []"|
"transform (x#xs) = ''bla''"


theory Digraph_Map_Impl
imports
  Graph_Genus
  Executable_Permutations
  "Transitive-Closure.Transitive_Closure_Impl"
begin

section \<open>Enumerating Maps\<close>

definition grouped_by_fst :: "('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list list" where
  "grouped_by_fst xs = map (\<lambda>u. filter (\<lambda>x. fst x = u) xs) (remdups (map fst xs))"

fun grouped_out_arcs :: "'a list \<times> ('a \<times> 'a) list \<Rightarrow> ('a \<times> 'a) list list" where
  "grouped_out_arcs (vs,as) = grouped_by_fst as"

definition all_maps_list :: "('a list \<times> ('a \<times> 'a) list) \<Rightarrow> ('a \<times> 'a) list list list" where
  "all_maps_list G_list = (cyc_permutationss o grouped_out_arcs) G_list"

definition "list_digraph_ext ext G_list  \<equiv> \<lparr> pverts = set (fst G_list), parcs = set (snd G_list), \<dots> = ext \<rparr>"
abbreviation "list_digraph \<equiv> list_digraph_ext ()"

code_datatype list_digraph_ext

lemma list_digraph_simps:
  "pverts (list_digraph G_list) = set (fst G_list)"
  "parcs (list_digraph G_list) = set (snd G_list)"
  by (auto simp: list_digraph_ext_def)

lemma union_grouped_by_fst:
  "(\<Union>xs \<in> set (grouped_by_fst ys). set xs) = set ys"
  by (auto simp: grouped_by_fst_def)

lemma union_grouped_out_arcs:
  "(\<Union>xs \<in> set (grouped_out_arcs G_list). set xs) = set (snd G_list)"
  by (cases G_list) (simp add: union_grouped_by_fst)

lemma nil_not_in_grouped_out_arcs: "[] \<notin> set (grouped_out_arcs G_list)"
  apply (cases G_list) apply (auto simp: grouped_by_fst_def )
  by (metis (mono_tags) filter_empty_conv fst_conv)

lemma set_grouped_out_arcs:
  assumes "pair_wf_digraph (list_digraph G_list)"
  shows "set ` set (grouped_out_arcs G_list) = {out_arcs (list_digraph G_list) v | v. v \<in> pverts (list_digraph G_list) \<and> out_arcs (list_digraph G_list) v \<noteq> {} }"
    (is "?L = ?R")
proof -
  interpret pair_wf_digraph "list_digraph G_list" by fact
  define vs where "vs = remdups (map fst (snd G_list))"
  have "set vs = {v. out_arcs (list_digraph G_list) v \<noteq> {}}"
    by (auto simp: out_arcs_def list_digraph_ext_def vs_def intro: rev_image_eqI )
  then have vs: "set vs = {v \<in> pverts (list_digraph G_list). out_arcs (list_digraph G_list) v \<noteq> {}}"
    by (auto dest: in_arcsD1)
  have goa: "grouped_out_arcs G_list = map (\<lambda>u. filter (\<lambda>x. fst x = u) (snd G_list)) vs"
    by (cases G_list) (auto simp: grouped_by_fst_def vs_def)
  have filter: "set \<circ> (\<lambda>u. filter (\<lambda>x. fst x = u) (snd G_list)) = out_arcs (list_digraph G_list)"
    by (rule ext) (auto simp: list_digraph_ext_def)

  have "set (map set (grouped_out_arcs G_list)) = ?R" by (auto simp add: goa filter vs)
  then show ?thesis by simp
qed

lemma distincts_grouped_by_fst:
  assumes "distinct xs" shows "distincts (grouped_by_fst xs)"
proof -
  have list_eq_setD: "\<And>xs ys. xs = ys \<Longrightarrow> set xs = set ys" by auto
  have inj: "inj_on (\<lambda>u. filter (\<lambda>x. fst x = u) xs) (fst ` set xs)"
    by (rule inj_onI) (drule list_eq_setD, auto)
  with assms show ?thesis
    by (auto simp: grouped_by_fst_def distincts_def distinct_map filter_empty_conv)
qed

lemma distincts_grouped_arcs:
  assumes "distinct (snd G_list)" shows "distincts (grouped_out_arcs G_list)"
  using assms by (cases G_list) (simp add: distincts_grouped_by_fst)

lemma distincts_in_all_maps_list:
  "distinct (snd X) \<Longrightarrow> xss \<in> set (all_maps_list X) \<Longrightarrow> distincts xss"
  by (simp add: all_maps_list_def distincts_grouped_arcs in_set_cyc_permutationss)

definition to_map :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a \<Rightarrow> 'a \<times> 'a) \<Rightarrow> ('a \<times> 'a) pre_map" where
  "to_map A f = \<lparr> edge_rev = swap_in A, edge_succ = f \<rparr>"

abbreviation "to_map' as xss \<equiv> to_map (set as) (lists_succ xss)"

definition all_maps :: "'a pair_pre_digraph \<Rightarrow> ('a \<times> 'a) pre_map set" where
  "all_maps G \<equiv> to_map (arcs G) ` {f. f permutes arcs G \<and> (\<forall>v \<in> verts G. out_arcs G v \<noteq> {} \<longrightarrow> cyclic_on f (out_arcs G v))}"

definition maps_all_maps_list :: "('a list \<times> ('a \<times> 'a) list) \<Rightarrow> ('a \<times> 'a) pre_map list" where
  "maps_all_maps_list G_list = map (to_map (set (snd G_list)) o lists_succ) (all_maps_list G_list)"

lemma (in pair_graph) all_maps_correct:
  shows "all_maps G = {M. digraph_map G M}"
proof (intro set_eqI iffI)
  fix M assume A:"M \<in> all_maps G"
  then have [simp]: "edge_rev M = swap_in (arcs G)" "edge_succ M permutes parcs G"
    by (auto simp: all_maps_def to_map_def)

  have "digraph_map G M"
  proof (rule digraph_mapI)
    fix a assume "a \<notin> parcs G" then show "edge_rev M a = a" by (auto simp: swap_in_def)
  next
    fix a assume "a \<in> parcs G"
    then show "edge_rev M (edge_rev M a) = a" "fst (edge_rev M a) = snd a" "edge_rev M a \<noteq> a"
      by (case_tac [!] "a") (auto intro: arcs_symmetric simp: swap_in_def dest: no_loops)
  next
    show "edge_succ M permutes parcs G" by simp
  next
    fix v assume "v \<in> pverts G" "out_arcs (with_proj G) v \<noteq> {}"
    then show "cyclic_on (edge_succ M) (out_arcs (with_proj G) v)"
      using A unfolding all_maps_def by (auto simp: to_map_def)
  qed
  then show "M \<in> {M. digraph_map G M}" by simp
next
  fix M assume A: "M \<in> {M. digraph_map G M}"
  then interpret M: digraph_map G M by simp
  from A have "\<And>x. fst (edge_rev M x) = fst (swap_in (arcs G) x)"
      "\<And>x. snd (edge_rev M x) = snd (swap_in (arcs G) x)"
    using M.tail_arev M.head_arev by (auto simp: fun_eq_iff swap_in_def M.arev_eq)
  then have "edge_rev M = swap_in (arcs G)"
    by (metis prod.collapse fun_eq_iff)
  then show "M \<in> all_maps G"
    using M.edge_succ_permutes M.edge_succ_cyclic
    unfolding all_maps_def
    by (auto simp: to_map_def intro!: image_eqI[where x="edge_succ M"])
qed

lemma set_maps_all_maps_list:
  assumes "pair_wf_digraph (list_digraph G_list)" "distinct (snd G_list)"
  shows "all_maps (list_digraph G_list) = set (maps_all_maps_list G_list)"
proof -
  let ?G = "list_digraph G_list"

  { fix f
    have "(\<forall>x\<in>set (grouped_out_arcs G_list). cyclic_on f (set x))
        \<longleftrightarrow> (\<forall>x\<in>set ` set (grouped_out_arcs G_list). cyclic_on f x)" (is "?all1 = _")
      by simp
    also have "\<dots> \<longleftrightarrow> (\<forall>v\<in>pverts ?G. out_arcs ?G v \<noteq> {} \<longrightarrow> cyclic_on f (out_arcs ?G v))" (is "_ = ?all2")
      using assms by (auto simp: set_grouped_out_arcs)
    finally have "?all1 = ?all2" .
  } note all_eq = this

  have "lists_succ ` set (all_maps_list G_list)
      = {f. f permutes arcs ?G \<and> (\<forall>v \<in> pverts ?G. out_arcs ?G v \<noteq> {} \<longrightarrow> cyclic_on f (out_arcs ?G v))}"
    unfolding all_maps_list_def using assms all_eq
    by (simp add: lists_succ_set_cyc_permutationss distincts_grouped_arcs union_grouped_out_arcs list_digraph_simps)
  then have *: "lists_succ ` set (all_maps_list G_list) = {f. f permutes set (snd G_list) \<and> (\<forall>v\<in>set (fst G_list). out_arcs (with_proj \<lparr>pverts = set (fst G_list), parcs = set (snd G_list)\<rparr>) v \<noteq> {} \<longrightarrow> cyclic_on f (out_arcs (with_proj \<lparr>pverts = set (fst G_list), parcs = set (snd G_list)\<rparr>) v))}"
    by (auto simp add: maps_all_maps_list_def all_maps_def list_digraph_simps list_digraph_ext_def)
  then have **: "\<And>f. \<not> (f permutes set (snd G_list) \<and> (\<forall>a. a \<in> set (fst G_list) \<longrightarrow> out_arcs (with_proj \<lparr>pverts = set (fst G_list), parcs = set (snd G_list)\<rparr>) a \<noteq> {} \<longrightarrow> cyclic_on f (out_arcs (with_proj \<lparr>pverts = set (fst G_list), parcs = set (snd G_list)\<rparr>) a))) \<or> f \<in> lists_succ ` set (all_maps_list G_list)"
    by force
  from * show ?thesis
    by (auto simp add: maps_all_maps_list_def all_maps_def list_digraph_simps list_digraph_ext_def) (use ** in blast)
qed

section \<open>Compute Face Cycles\<close>

definition lists_fc_succ :: "('a \<times> 'a) list list \<Rightarrow> ('a \<times> 'a) \<Rightarrow> ('a \<times> 'a)" where
  "lists_fc_succ xss = (let sxss = \<Union>(sset xss) in (\<lambda>x. lists_succ xss (swap_in sxss x)))"

locale lists_digraph_map =
  fixes G_list :: "'b list \<times> ('b \<times> 'b) list"
    and xss :: "('b \<times> 'b) list list"
  assumes digraph_map: "digraph_map (list_digraph G_list) (to_map' (snd G_list) xss)"
  assumes no_loops: "\<And>a. a \<in> parcs (list_digraph G_list) \<Longrightarrow> fst a \<noteq> snd a"
  assumes distincts_xss: "distincts xss"
  assumes parcs_xss: "parcs (list_digraph G_list) = \<Union>(sset xss)"
begin

abbreviation (input) "G \<equiv> list_digraph G_list"
abbreviation (input) "M \<equiv> to_map' (snd G_list) xss"

lemma edge_rev_simps:
  assumes "(u,v) \<in> parcs G" shows "edge_rev M (u,v) = (v,u)"
  using assms
  unfolding to_map_def list_digraph_ext_def by (auto simp: swap_in_def to_map_def)

end

sublocale lists_digraph_map \<subseteq> digraph_map G M by (rule local.digraph_map)

sublocale lists_digraph_map \<subseteq> pair_graph G
proof
  fix e assume "e \<in> parcs G"
  then have "e \<in> arcs G" by simp
  then have "head G e \<in> verts G" "tail G e \<in> verts G" by (blast dest: wellformed)+
  then show "fst e \<in> pverts G" "snd e \<in> pverts G" by auto
next
  fix e assume "e \<in> parcs G" then show "fst e \<noteq> snd e" using no_loops by simp
next
  show "finite (pverts G)" "finite (parcs G)"
    unfolding list_digraph_ext_def by simp_all
next
  { fix u v assume "(u,v) \<in> parcs G"
    then have "edge_rev M (u,v) \<in> parcs G"
      using edge_rev_in_arcs by simp
    then have "(v,u) \<in> parcs G" using \<open>(u,v) \<in> _ \<close> by (simp add: edge_rev_simps) }
  then show "symmetric G"
    unfolding symmetric_def by (auto intro: symI)
qed

context lists_digraph_map begin

definition "lists_fcs \<equiv> orbits_list (lists_fc_succ xss)"

lemma M_simps:
  "edge_succ M = lists_succ xss"
  unfolding to_map_def by (cases G_list) auto

lemma lists_fc_succ_permutes: "lists_fc_succ xss permutes (\<Union>(sset xss))"
proof -
  have "\<forall>(u,v) \<in> \<Union>(sset xss). (v,u) \<in> \<Union>(sset xss)"
    using sym_arcs unfolding parcs_xss[symmetric] symmetric_def by (auto elim: symE)
  then have "swap_in (\<Union>(sset xss)) permutes \<Union>(sset xss)"
    using distincts_xss
    apply (auto simp: permutes_def split: if_splits)
    unfolding swap_in_def
    apply (simp_all split: if_splits prod.splits)
    apply metis+
    done
  moreover
  have "lists_succ xss permutes (\<Union>(sset xss))"
    using lists_succ_permutes[OF distincts_xss] by simp
  moreover
  have "lists_fc_succ xss = lists_succ xss o swap_in (\<Union>(sset xss))"
    by (simp add: fun_eq_iff lists_fc_succ_def)
  ultimately
  show ?thesis by (metis permutes_compose)
qed

lemma permutation_lists_fc_succ[intro, simp]: "permutation (lists_fc_succ xss)"
  using lists_fc_succ_permutes by (auto simp: permutation_permutes)

lemma face_cycle_succ_conv: "face_cycle_succ = lists_fc_succ xss"
  using parcs_xss unfolding face_cycle_succ_def
  by (simp add: fun_eq_iff to_map_def lists_fc_succ_def swap_in_def list_digraph_ext_def)

lemma sset_lists_fcs:
  "sset (lists_fcs as) = {face_cycle_set a | a. a \<in> set as}"
  by (auto simp: lists_fcs_def sset_orbits_list face_cycle_set_def face_cycle_succ_conv)

lemma distincts_lists_fcs: "distinct as \<Longrightarrow>distincts (lists_fcs as)"
  by (simp add: lists_fcs_def distincts_orbits_list)

lemma face_cycle_set_ss: "a \<in> parcs G \<Longrightarrow> face_cycle_set a \<subseteq> parcs G"
  using in_face_cycle_setD with_proj_simps(2) by blast

lemma face_cycle_succ_neq:
  assumes "a \<in> parcs G" shows "face_cycle_succ a \<noteq> a"
  using assms no_loops by (intro face_cycle_succ_neq) auto

lemma card_face_cycle_sets_conv:
  shows "card (pre_digraph_map.face_cycle_sets G M) = length (lists_fcs (remdups (snd G_list)))"
proof -
  interpret digraph_map G M by (rule digraph_map)

  have "face_cycle_sets = {face_cycle_set a | a. a \<in> parcs G}"
    by (auto simp: face_cycle_sets_def)
  also have "\<dots> = sset (lists_fcs (remdups (snd G_list)))"
    unfolding sset_lists_fcs by (simp add: list_digraph_simps)
  also have "card \<dots> = length (lists_fcs (remdups (snd G_list)))"
    by (simp add: card_image distincts_inj_on_set distinct_card distincts_distinct distincts_lists_fcs)
  finally show ?thesis .
qed

end

definition "gen_succ \<equiv> \<lambda>as xs. [b. (a,b) <- as, a \<in> set xs]"
interpretation RTLI: set_access_gen set "\<lambda>x xs. x \<in> set xs" "[]" "\<lambda>xs ys. remdups (xs @ ys)" "gen_succ"
  by standard (auto simp: gen_succ_def)
hide_const (open) gen_succ

text \<open>
  It would suffice to check that @{term "set (RTLI.rtrancl_i A [u]) = set V"}. We don't do
  this here, since it makes the proof more complicated (and is not necessary for the graphs
  we care about
\<close>
definition sccs_verts_impl :: "'a list \<times> ('a \<times> 'a) list \<Rightarrow> 'a set set" where
  "sccs_verts_impl G \<equiv> set ` (\<lambda>x. RTLI.rtrancl_i (snd G) [x]) ` set (fst G)"

definition isolated_verts_impl :: "'a list \<times> ('a \<times> 'a) list \<Rightarrow> 'a list" where
  "isolated_verts_impl G = [v \<leftarrow> (fst G). \<not>(\<exists>e \<in> set (snd G). fst e = v)]"

definition pair_graph_impl :: "'a list \<times> ('a \<times> 'a) list \<Rightarrow> bool" where
  "pair_graph_impl G \<equiv> case G of (V,A) \<Rightarrow> (\<forall>(u,v) \<in> set A. u \<noteq> v \<and> u \<in> set V \<and> v \<in> set V \<and> (v,u) \<in> set A)"

definition genus_impl :: "'a list \<times> ('a \<times> 'a) list \<Rightarrow> ('a \<times> 'a) list list \<Rightarrow> int" where
  "genus_impl G M \<equiv> case G of (V,A) \<Rightarrow>
    (int (2*card (sccs_verts_impl G)) - int (length (isolated_verts_impl G))
      - (int (length V) - int (length A) div 2
      + int (length (orbits_list_impl (lists_fc_succ M) A)))) div 2"

definition comb_planar_impl :: "'a list \<times> ('a \<times> 'a) list \<Rightarrow> bool" where
  "comb_planar_impl G \<equiv> case G of (V,A) \<Rightarrow>
    let i = int (2*card (sccs_verts_impl G)) - int (length (isolated_verts_impl G))
      - int (length V) + int (length A) div 2
    in (\<exists>M\<in>set (all_maps_list G). (i - int (length (orbits_list_impl (lists_fc_succ M) A))) div 2 = 0)"

(*
definition comb_planar_impl :: "'a list \<times> ('a \<times> 'a) list \<Rightarrow> bool" where
  "comb_planar_impl G \<equiv> \<exists>M\<in>set (all_maps_list G). genus_impl G M = 0"
*)

lemma sccs_verts_impl_correct:
  assumes "pair_pseudo_graph (list_digraph G)"
  shows "pre_digraph.sccs_verts (list_digraph G) = sccs_verts_impl G"
proof -
  interpret pair_pseudo_graph "list_digraph G" by fact
  { fix u assume "u \<in> set (fst G)"
    then have "\<And>x. (u, x) \<in> (set (snd G))\<^sup>* \<Longrightarrow> x \<in> set (fst G)"
      by (metis in_arcsD2 list_digraph_simps rtrancl.cases)
    then have "set (RTLI.rtrancl_i (snd G) [u]) = {v. u \<rightarrow>\<^sup>*\<^bsub>list_digraph G\<^esub> v }"
      unfolding RTLI.rtrancl_impl reachable_conv by (auto simp: list_digraph_simps \<open>u \<in> _\<close>)
    also have "\<dots> = scc_of u"
      unfolding scc_of_def by (auto intro: symmetric_reachable')
    finally have "scc_of u = set (RTLI.rtrancl_i (snd G) [u])" by simp
  }
  then have "pre_digraph.sccs_verts (list_digraph G) = set ` (\<lambda>x. RTLI.rtrancl_i (snd G) [x]) ` set (fst G)"
    unfolding sccs_verts_conv_scc_of list_digraph_simps
    by (force intro: rev_image_eqI)
  then show ?thesis unfolding sccs_verts_impl_def by simp
qed

lemma isolated_verts_impl_correct:
  "pre_digraph.isolated_verts (list_digraph G) = set (isolated_verts_impl G)"
  by (auto simp: pre_digraph.isolated_verts_def isolated_verts_impl_def list_digraph_simps out_arcs_def)

lemma pair_graph_impl_correct[code]:
  "pair_graph (list_digraph G) = pair_graph_impl G" (is "?L = ?R")
  unfolding pair_graph_def pair_digraph_def pair_fin_digraph_def pair_wf_digraph_def
    pair_fin_digraph_axioms_def pair_loopfree_digraph_def pair_loopfree_digraph_axioms_def
    pair_sym_digraph_def pair_sym_digraph_axioms_def pair_pseudo_graph_def
    pair_graph_impl_def
  by (auto simp: pair_graph_impl_def list_digraph_simps symmetric_def intro: symI dest: symD split: prod.splits)

lemma genus_impl_correct:
  assumes dist_V: "distinct (fst G)" and dist_A: "distinct (snd G)"
  assumes "lists_digraph_map G M"
  shows "pre_digraph_map.euler_genus (list_digraph G) (to_map' (snd G) M) = genus_impl G M"
proof -
  interpret lists_digraph_map G M by fact
  obtain V A where G_eq: "G = (V,A)" by (cases G)
  moreover
  have "distinct (isolated_verts_impl G)"
    using dist_V by (auto simp: isolated_verts_impl_def )
  moreover
  have faces: "card face_cycle_sets = length (orbits_list_impl (lists_fc_succ M) (snd G))"
    using dist_A
    by (simp add: card_face_cycle_sets_conv lists_fcs_def orbits_list_conv_impl distinct_remdups_id)
  ultimately show ?thesis
    using pair_pseudo_graph dist_V dist_A
    unfolding euler_genus_def euler_char_def genus_impl_def card_sccs_verts[symmetric]
    by (simp add: sccs_verts_impl_correct isolated_verts_impl_correct
      distinct_card list_digraph_simps zdiv_int)
qed

lemma elems_all_maps_list:
  assumes "M \<in> set (all_maps_list G)" "distinct (snd G)"
  shows "\<Union>(sset M) = set (snd G)"
    using assms
    by (simp add: all_maps_list_def in_set_cyc_permutationss distincts_grouped_arcs union_grouped_out_arcs[symmetric])
       (metis set_map)

lemma comb_planar_impl_altdef: "comb_planar_impl G = (\<exists>M\<in>set (all_maps_list G). genus_impl G M = 0)"
  unfolding comb_planar_impl_def Let_def genus_impl_def by (cases G) (simp add: algebra_simps)

lemma comb_planar_impl_correct:
  assumes "pair_graph (list_digraph G)"
  assumes dist_V: "distinct (fst G)" and dist_A: "distinct (snd G)"
  shows "comb_planar (list_digraph G) = comb_planar_impl G" (is "?L = ?R")
proof -
  interpret G: pair_graph "list_digraph G" by fact
  let ?G = "list_digraph G"
  have *: "all_maps (list_digraph G) = set (maps_all_maps_list G)"
    by (rule set_maps_all_maps_list) (unfold_locales, simp add: dist_A)

  obtain V A where "G = (V,A)" by (cases G)

  { fix M assume "M \<in> set (all_maps_list G)"
    have "digraph_map (list_digraph G) (to_map' (snd G) M)"
      using \<open>M \<in> _\<close> G.all_maps_correct by (auto simp: * maps_all_maps_list_def)
    then interpret G: digraph_map "list_digraph G" "to_map' (snd G) M" .

    have "distincts M" using \<open>M \<in> _\<close>
      using dist_A distincts_in_all_maps_list by blast

    have "lists_digraph_map G M"
      using elems_all_maps_list[OF \<open>M \<in> _\<close> \<open>distinct (snd G)\<close>]
      apply unfold_locales
      by (auto intro: \<open>distincts M\<close> dest: G.adj_not_same) (auto simp: list_digraph_simps)
  } note ldm = this

  have "comb_planar ?G = (\<exists>M \<in> {M. digraph_map ?G M}. pre_digraph_map.euler_genus ?G M = 0)"
    unfolding comb_planar_def by simp
  also have "\<dots> = (\<exists>M\<in>set (all_maps_list G). pre_digraph_map.euler_genus (list_digraph G)
      (to_map (set (snd G)) (lists_succ M)) = 0)"
    unfolding comb_planar_def comb_planar_impl_def Let_def G.all_maps_correct[symmetric]
      set_maps_all_maps_list[OF G.pair_wf_digraph dist_A] maps_all_maps_list_def by simp
  also have "\<dots> = (\<exists>M\<in>set (all_maps_list G). genus_impl G M = 0)"
    using ldm assms by (simp add: genus_impl_correct)
  also have "\<dots> = comb_planar_impl G"
    unfolding comb_planar_impl_def genus_impl_def Let_def by (simp add: \<open>G = (V,A)\<close> algebra_simps)
  finally show ?thesis .
qed

end


(*  Title:      HOL/HOLCF/IOA/meta_theory/Abstraction.thy
    Author:     Olaf Müller
*)

section {* Abstraction Theory -- tailored for I/O automata *}

theory Abstraction
imports LiveIOA
begin

default_sort type

definition
  cex_abs :: "('s1 => 's2) => ('a,'s1)execution => ('a,'s2)execution" where
  "cex_abs f ex = (f (fst ex), Map (%(a,t). (a,f t))$(snd ex))"
definition
  -- {* equals cex_abs on Sequences -- after ex2seq application *}
  cex_absSeq :: "('s1 => 's2) => ('a option,'s1)transition Seq => ('a option,'s2)transition Seq" where
  "cex_absSeq f = (%s. Map (%(s,a,t). (f s,a,f t))$s)"

definition
  is_abstraction ::"[('s1=>'s2),('a,'s1)ioa,('a,'s2)ioa] => bool" where
  "is_abstraction f C A =
   ((!s:starts_of(C). f(s):starts_of(A)) &
   (!s t a. reachable C s & s -a--C-> t
            --> (f s) -a--A-> (f t)))"

definition
  weakeningIOA :: "('a,'s2)ioa => ('a,'s1)ioa => ('s1 => 's2) => bool" where
  "weakeningIOA A C h = (!ex. ex : executions C --> cex_abs h ex : executions A)"
definition
  temp_strengthening :: "('a,'s2)ioa_temp => ('a,'s1)ioa_temp => ('s1 => 's2) => bool" where
  "temp_strengthening Q P h = (!ex. (cex_abs h ex |== Q) --> (ex |== P))"
definition
  temp_weakening :: "('a,'s2)ioa_temp => ('a,'s1)ioa_temp => ('s1 => 's2) => bool" where
  "temp_weakening Q P h = temp_strengthening (.~ Q) (.~ P) h"

definition
  state_strengthening :: "('a,'s2)step_pred => ('a,'s1)step_pred => ('s1 => 's2) => bool" where
  "state_strengthening Q P h = (!s t a.  Q (h(s),a,h(t)) --> P (s,a,t))"
definition
  state_weakening :: "('a,'s2)step_pred => ('a,'s1)step_pred => ('s1 => 's2) => bool" where
  "state_weakening Q P h = state_strengthening (.~Q) (.~P) h"

definition
  is_live_abstraction :: "('s1 => 's2) => ('a,'s1)live_ioa => ('a,'s2)live_ioa => bool" where
  "is_live_abstraction h CL AM =
     (is_abstraction h (fst CL) (fst AM) &
      temp_weakening (snd AM) (snd CL) h)"

axiomatization where
(* thm about ex2seq which is not provable by induction as ex2seq is not continous *)
ex2seq_abs_cex:
  "ex2seq (cex_abs h ex) = cex_absSeq h (ex2seq ex)"

axiomatization where
(* analog to the proved thm strength_Box - proof skipped as trivial *)
weak_Box:
"temp_weakening P Q h
 ==> temp_weakening ([] P) ([] Q) h"

axiomatization where
(* analog to the proved thm strength_Next - proof skipped as trivial *)
weak_Next:
"temp_weakening P Q h
 ==> temp_weakening (Next P) (Next Q) h"

subsection "cex_abs"

lemma cex_abs_UU: "cex_abs f (s,UU) = (f s, UU)"
  by (simp add: cex_abs_def)

lemma cex_abs_nil: "cex_abs f (s,nil) = (f s, nil)"
  by (simp add: cex_abs_def)

lemma cex_abs_cons: "cex_abs f (s,(a,t)>>ex) = (f s, (a,f t) >> (snd (cex_abs f (t,ex))))"
  by (simp add: cex_abs_def)

declare cex_abs_UU [simp] cex_abs_nil [simp] cex_abs_cons [simp]

subsection "lemmas"

lemma temp_weakening_def2: "temp_weakening Q P h = (! ex. (ex |== P) --> (cex_abs h ex |== Q))"
  apply (simp add: temp_weakening_def temp_strengthening_def NOT_def temp_sat_def satisfies_def)
  apply auto
  done

lemma state_weakening_def2: "state_weakening Q P h = (! s t a. P (s,a,t) --> Q (h(s),a,h(t)))"
  apply (simp add: state_weakening_def state_strengthening_def NOT_def)
  apply auto
  done

subsection "Abstraction Rules for Properties"

lemma exec_frag_abstraction [rule_format]:
 "[| is_abstraction h C A |] ==>
  !s. reachable C s & is_exec_frag C (s,xs)
  --> is_exec_frag A (cex_abs h (s,xs))"
apply (unfold cex_abs_def)
apply simp
apply (tactic {* pair_induct_tac @{context} "xs" [@{thm is_exec_frag_def}] 1 *})
txt {* main case *}
apply (auto dest: reachable.reachable_n simp add: is_abstraction_def)
done

lemma abs_is_weakening: "is_abstraction h C A ==> weakeningIOA A C h"
apply (simp add: weakeningIOA_def)
apply auto
apply (simp add: executions_def)
txt {* start state *}
apply (rule conjI)
apply (simp add: is_abstraction_def cex_abs_def)
txt {* is-execution-fragment *}
apply (erule exec_frag_abstraction)
apply (simp add: reachable.reachable_0)
done

lemma AbsRuleT1: "[|is_abstraction h C A; validIOA A Q; temp_strengthening Q P h |]
          ==> validIOA C P"
apply (drule abs_is_weakening)
apply (simp add: weakeningIOA_def validIOA_def temp_strengthening_def)
apply (auto simp add: split_paired_all)
done

(* FIX: Nach TLS.ML *)

lemma IMPLIES_temp_sat: "(ex |== P .--> Q) = ((ex |== P) --> (ex |== Q))"
  by (simp add: IMPLIES_def temp_sat_def satisfies_def)

lemma AND_temp_sat: "(ex |== P .& Q) = ((ex |== P) & (ex |== Q))"
  by (simp add: AND_def temp_sat_def satisfies_def)

lemma OR_temp_sat: "(ex |== P .| Q) = ((ex |== P) | (ex |== Q))"
  by (simp add: OR_def temp_sat_def satisfies_def)

lemma NOT_temp_sat: "(ex |== .~ P) = (~ (ex |== P))"
  by (simp add: NOT_def temp_sat_def satisfies_def)

declare IMPLIES_temp_sat [simp] AND_temp_sat [simp] OR_temp_sat [simp] NOT_temp_sat [simp]

lemma AbsRuleT2:
   "[|is_live_abstraction h (C,L) (A,M);
          validLIOA (A,M) Q;  temp_strengthening Q P h |]
          ==> validLIOA (C,L) P"
apply (unfold is_live_abstraction_def)
apply auto
apply (drule abs_is_weakening)
apply (simp add: weakeningIOA_def temp_weakening_def2 validLIOA_def validIOA_def temp_strengthening_def)
apply (auto simp add: split_paired_all)
done

lemma AbsRuleTImprove:
   "[|is_live_abstraction h (C,L) (A,M);
          validLIOA (A,M) (H1 .--> Q);  temp_strengthening Q P h;
          temp_weakening H1 H2 h; validLIOA (C,L) H2 |]
          ==> validLIOA (C,L) P"
apply (unfold is_live_abstraction_def)
apply auto
apply (drule abs_is_weakening)
apply (simp add: weakeningIOA_def temp_weakening_def2 validLIOA_def validIOA_def temp_strengthening_def)
apply (auto simp add: split_paired_all)
done

subsection "Correctness of safe abstraction"

lemma abstraction_is_ref_map:
"is_abstraction h C A ==> is_ref_map h C A"
apply (unfold is_abstraction_def is_ref_map_def)
apply auto
apply (rule_tac x = "(a,h t) >>nil" in exI)
apply (simp add: move_def)
done

lemma abs_safety: "[| inp(C)=inp(A); out(C)=out(A);
                   is_abstraction h C A |]
                ==> C =<| A"
apply (simp add: ioa_implements_def)
apply (rule trace_inclusion)
apply (simp (no_asm) add: externals_def)
apply (auto)[1]
apply (erule abstraction_is_ref_map)
done

subsection "Correctness of life abstraction"

(* Reduces to Filter (Map fst x) = Filter (Map fst (Map (%(a,t). (a,x)) x),
   that is to special Map Lemma *)
lemma traces_coincide_abs:
  "ext C = ext A
         ==> mk_trace C$xs = mk_trace A$(snd (cex_abs f (s,xs)))"
apply (unfold cex_abs_def mk_trace_def filter_act_def)
apply simp
apply (tactic {* pair_induct_tac @{context} "xs" [] 1 *})
done

(* Does not work with abstraction_is_ref_map as proof of abs_safety, because
   is_live_abstraction includes temp_strengthening which is necessarily based
   on cex_abs and not on corresp_ex. Thus, the proof is redoone in a more specific
   way for cex_abs *)
lemma abs_liveness: "[| inp(C)=inp(A); out(C)=out(A);
                   is_live_abstraction h (C,M) (A,L) |]
                ==> live_implements (C,M) (A,L)"
apply (simp add: is_live_abstraction_def live_implements_def livetraces_def liveexecutions_def)
apply auto
apply (rule_tac x = "cex_abs h ex" in exI)
apply auto
  (* Traces coincide *)
  apply (tactic {* pair_tac @{context} "ex" 1 *})
  apply (rule traces_coincide_abs)
  apply (simp (no_asm) add: externals_def)
  apply (auto)[1]

  (* cex_abs is execution *)
  apply (tactic {* pair_tac @{context} "ex" 1 *})
  apply (simp add: executions_def)
  (* start state *)
  apply (rule conjI)
  apply (simp add: is_abstraction_def cex_abs_def)
  (* is-execution-fragment *)
  apply (erule exec_frag_abstraction)
  apply (simp add: reachable.reachable_0)

 (* Liveness *)
apply (simp add: temp_weakening_def2)
 apply (tactic {* pair_tac @{context} "ex" 1 *})
done

(* FIX: NAch Traces.ML bringen *)

lemma implements_trans:
"[| A =<| B; B =<| C|] ==> A =<| C"
by (auto simp add: ioa_implements_def)

subsection "Abstraction Rules for Automata"

lemma AbsRuleA1: "[| inp(C)=inp(A); out(C)=out(A);
                   inp(Q)=inp(P); out(Q)=out(P);
                   is_abstraction h1 C A;
                   A =<| Q ;
                   is_abstraction h2 Q P |]
                ==> C =<| P"
apply (drule abs_safety)
apply assumption+
apply (drule abs_safety)
apply assumption+
apply (erule implements_trans)
apply (erule implements_trans)
apply assumption
done

lemma AbsRuleA2: "!!LC. [| inp(C)=inp(A); out(C)=out(A);
                   inp(Q)=inp(P); out(Q)=out(P);
                   is_live_abstraction h1 (C,LC) (A,LA);
                   live_implements (A,LA) (Q,LQ) ;
                   is_live_abstraction h2 (Q,LQ) (P,LP) |]
                ==> live_implements (C,LC) (P,LP)"
apply (drule abs_liveness)
apply assumption+
apply (drule abs_liveness)
apply assumption+
apply (erule live_implements_trans)
apply (erule live_implements_trans)
apply assumption
done

declare split_paired_All [simp del]

subsection "Localizing Temporal Strengthenings and Weakenings"

lemma strength_AND:
"[| temp_strengthening P1 Q1 h;
          temp_strengthening P2 Q2 h |]
       ==> temp_strengthening (P1 .& P2) (Q1 .& Q2) h"
apply (unfold temp_strengthening_def)
apply auto
done

lemma strength_OR:
"[| temp_strengthening P1 Q1 h;
          temp_strengthening P2 Q2 h |]
       ==> temp_strengthening (P1 .| P2) (Q1 .| Q2) h"
apply (unfold temp_strengthening_def)
apply auto
done

lemma strength_NOT:
"[| temp_weakening P Q h |]
       ==> temp_strengthening (.~ P) (.~ Q) h"
apply (unfold temp_strengthening_def)
apply (simp add: temp_weakening_def2)
apply auto
done

lemma strength_IMPLIES:
"[| temp_weakening P1 Q1 h;
          temp_strengthening P2 Q2 h |]
       ==> temp_strengthening (P1 .--> P2) (Q1 .--> Q2) h"
apply (unfold temp_strengthening_def)
apply (simp add: temp_weakening_def2)
done

lemma weak_AND:
"[| temp_weakening P1 Q1 h;
          temp_weakening P2 Q2 h |]
       ==> temp_weakening (P1 .& P2) (Q1 .& Q2) h"
apply (simp add: temp_weakening_def2)
done

lemma weak_OR:
"[| temp_weakening P1 Q1 h;
          temp_weakening P2 Q2 h |]
       ==> temp_weakening (P1 .| P2) (Q1 .| Q2) h"
apply (simp add: temp_weakening_def2)
done

lemma weak_NOT:
"[| temp_strengthening P Q h |]
       ==> temp_weakening (.~ P) (.~ Q) h"
apply (unfold temp_strengthening_def)
apply (simp add: temp_weakening_def2)
apply auto
done

lemma weak_IMPLIES:
"[| temp_strengthening P1 Q1 h;
          temp_weakening P2 Q2 h |]
       ==> temp_weakening (P1 .--> P2) (Q1 .--> Q2) h"
apply (unfold temp_strengthening_def)
apply (simp add: temp_weakening_def2)
done

subsubsection {* Box *}

(* FIX: should be same as nil_is_Conc2 when all nils are turned to right side !! *)
lemma UU_is_Conc: "(UU = x @@ y) = (((x::'a Seq)= UU) | (x=nil & y=UU))"
apply (tactic {* Seq_case_simp_tac @{context} "x" 1 *})
done

lemma ex2seqConc [rule_format]:
"Finite s1 -->
  (! ex. (s~=nil & s~=UU & ex2seq ex = s1 @@ s) --> (? ex'. s = ex2seq ex'))"
apply (rule impI)
apply (tactic {* Seq_Finite_induct_tac @{context} 1 *})
apply blast
(* main case *)
apply clarify
apply (tactic {* pair_tac @{context} "ex" 1 *})
apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
(* UU case *)
apply (simp add: nil_is_Conc)
(* nil case *)
apply (simp add: nil_is_Conc)
(* cons case *)
apply (tactic {* pair_tac @{context} "aa" 1 *})
apply auto
done

(* important property of ex2seq: can be shiftet, as defined "pointwise" *)

lemma ex2seq_tsuffix:
"tsuffix s (ex2seq ex) ==> ? ex'. s = (ex2seq ex')"
apply (unfold tsuffix_def suffix_def)
apply auto
apply (drule ex2seqConc)
apply auto
done

(* FIX: NAch Sequence.ML bringen *)

lemma Mapnil: "(Map f$s = nil) = (s=nil)"
apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
done

lemma MapUU: "(Map f$s = UU) = (s=UU)"
apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
done

(* important property of cex_absSeq: As it is a 1to1 correspondence,
  properties carry over *)

lemma cex_absSeq_tsuffix:
"tsuffix s t ==> tsuffix (cex_absSeq h s) (cex_absSeq h t)"
apply (unfold tsuffix_def suffix_def cex_absSeq_def)
apply auto
apply (simp add: Mapnil)
apply (simp add: MapUU)
apply (rule_tac x = "Map (% (s,a,t) . (h s,a, h t))$s1" in exI)
apply (simp add: Map2Finite MapConc)
done

lemma strength_Box:
"[| temp_strengthening P Q h |]
       ==> temp_strengthening ([] P) ([] Q) h"
apply (unfold temp_strengthening_def state_strengthening_def temp_sat_def satisfies_def Box_def)
apply clarify
apply (frule ex2seq_tsuffix)
apply clarify
apply (drule_tac h = "h" in cex_absSeq_tsuffix)
apply (simp add: ex2seq_abs_cex)
done

subsubsection {* Init *}

lemma strength_Init:
"[| state_strengthening P Q h |]
       ==> temp_strengthening (Init P) (Init Q) h"
apply (unfold temp_strengthening_def state_strengthening_def
  temp_sat_def satisfies_def Init_def unlift_def)
apply auto
apply (tactic {* pair_tac @{context} "ex" 1 *})
apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
apply (tactic {* pair_tac @{context} "a" 1 *})
done

subsubsection {* Next *}

lemma TL_ex2seq_UU:
"(TL$(ex2seq (cex_abs h ex))=UU) = (TL$(ex2seq ex)=UU)"
apply (tactic {* pair_tac @{context} "ex" 1 *})
apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
apply (tactic {* pair_tac @{context} "a" 1 *})
apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
apply (tactic {* pair_tac @{context} "a" 1 *})
done

lemma TL_ex2seq_nil:
"(TL$(ex2seq (cex_abs h ex))=nil) = (TL$(ex2seq ex)=nil)"
apply (tactic {* pair_tac @{context} "ex" 1 *})
apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
apply (tactic {* pair_tac @{context} "a" 1 *})
apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
apply (tactic {* pair_tac @{context} "a" 1 *})
done

(* FIX: put to Sequence Lemmas *)
lemma MapTL: "Map f$(TL$s) = TL$(Map f$s)"
apply (tactic {* Seq_induct_tac @{context} "s" [] 1 *})
done

(* important property of cex_absSeq: As it is a 1to1 correspondence,
  properties carry over *)

lemma cex_absSeq_TL:
"cex_absSeq h (TL$s) = (TL$(cex_absSeq h s))"
apply (unfold cex_absSeq_def)
apply (simp add: MapTL)
done

(* important property of ex2seq: can be shiftet, as defined "pointwise" *)

lemma TLex2seq: "[| (snd ex)~=UU ; (snd ex)~=nil |] ==> (? ex'. TL$(ex2seq ex) = ex2seq ex')"
apply (tactic {* pair_tac @{context} "ex" 1 *})
apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
apply (tactic {* pair_tac @{context} "a" 1 *})
apply auto
done

lemma ex2seqnilTL: "(TL$(ex2seq ex)~=nil) = ((snd ex)~=nil & (snd ex)~=UU)"
apply (tactic {* pair_tac @{context} "ex" 1 *})
apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
apply (tactic {* pair_tac @{context} "a" 1 *})
apply (tactic {* Seq_case_simp_tac @{context} "s" 1 *})
apply (tactic {* pair_tac @{context} "a" 1 *})
done

lemma strength_Next:
"[| temp_strengthening P Q h |]
       ==> temp_strengthening (Next P) (Next Q) h"
apply (unfold temp_strengthening_def state_strengthening_def temp_sat_def satisfies_def Next_def)
apply simp
apply auto
apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
apply (simp add: TL_ex2seq_nil TL_ex2seq_UU)
(* cons case *)
apply (simp add: TL_ex2seq_nil TL_ex2seq_UU ex2seq_abs_cex cex_absSeq_TL [symmetric] ex2seqnilTL)
apply (erule conjE)
apply (drule TLex2seq)
apply assumption
apply auto
done

text {* Localizing Temporal Weakenings     - 2 *}

lemma weak_Init:
"[| state_weakening P Q h |]
       ==> temp_weakening (Init P) (Init Q) h"
apply (simp add: temp_weakening_def2 state_weakening_def2
  temp_sat_def satisfies_def Init_def unlift_def)
apply auto
apply (tactic {* pair_tac @{context} "ex" 1 *})
apply (tactic {* Seq_case_simp_tac @{context} "y" 1 *})
apply (tactic {* pair_tac @{context} "a" 1 *})
done

text {* Localizing Temproal Strengthenings - 3 *}

lemma strength_Diamond:
"[| temp_strengthening P Q h |]
       ==> temp_strengthening (<> P) (<> Q) h"
apply (unfold Diamond_def)
apply (rule strength_NOT)
apply (rule weak_Box)
apply (erule weak_NOT)
done

lemma strength_Leadsto:
"[| temp_weakening P1 P2 h;
          temp_strengthening Q1 Q2 h |]
       ==> temp_strengthening (P1 ~> Q1) (P2 ~> Q2) h"
apply (unfold Leadsto_def)
apply (rule strength_Box)
apply (erule strength_IMPLIES)
apply (erule strength_Diamond)
done

text {* Localizing Temporal Weakenings - 3 *}

lemma weak_Diamond:
"[| temp_weakening P Q h |]
       ==> temp_weakening (<> P) (<> Q) h"
apply (unfold Diamond_def)
apply (rule weak_NOT)
apply (rule strength_Box)
apply (erule strength_NOT)
done

lemma weak_Leadsto:
"[| temp_strengthening P1 P2 h;
          temp_weakening Q1 Q2 h |]
       ==> temp_weakening (P1 ~> Q1) (P2 ~> Q2) h"
apply (unfold Leadsto_def)
apply (rule weak_Box)
apply (erule weak_IMPLIES)
apply (erule weak_Diamond)
done

lemma weak_WF:
  " !!A. [| !! s. Enabled A acts (h s) ==> Enabled C acts s|]
    ==> temp_weakening (WF A acts) (WF C acts) h"
apply (unfold WF_def)
apply (rule weak_IMPLIES)
apply (rule strength_Diamond)
apply (rule strength_Box)
apply (rule strength_Init)
apply (rule_tac [2] weak_Box)
apply (rule_tac [2] weak_Diamond)
apply (rule_tac [2] weak_Init)
apply (auto simp add: state_weakening_def state_strengthening_def
  xt2_def plift_def option_lift_def NOT_def)
done

lemma weak_SF:
  " !!A. [| !! s. Enabled A acts (h s) ==> Enabled C acts s|]
    ==> temp_weakening (SF A acts) (SF C acts) h"
apply (unfold SF_def)
apply (rule weak_IMPLIES)
apply (rule strength_Box)
apply (rule strength_Diamond)
apply (rule strength_Init)
apply (rule_tac [2] weak_Box)
apply (rule_tac [2] weak_Diamond)
apply (rule_tac [2] weak_Init)
apply (auto simp add: state_weakening_def state_strengthening_def
  xt2_def plift_def option_lift_def NOT_def)
done

lemmas weak_strength_lemmas =
  weak_OR weak_AND weak_NOT weak_IMPLIES weak_Box weak_Next weak_Init
  weak_Diamond weak_Leadsto strength_OR strength_AND strength_NOT
  strength_IMPLIES strength_Box strength_Next strength_Init
  strength_Diamond strength_Leadsto weak_WF weak_SF

ML {*
fun abstraction_tac ctxt =
  SELECT_GOAL (auto_tac
    (ctxt addSIs @{thms weak_strength_lemmas}
      addsimps [@{thm state_strengthening_def}, @{thm state_weakening_def}]))
*}

method_setup abstraction = {* Scan.succeed (SIMPLE_METHOD' o abstraction_tac) *}

end