section \<open>The abstract semantics is computable\<close>

theory AbsCFComp
imports AbsCF Computability FixTransform CPSUtils MapSets
begin

default_sort type

text \<open>
The point of the abstract semantics is that it is computable. To show this, we exploit the special structure of \<open>\<aF>\<close> and \<open>\<aC>\<close>: Each call adds some elements to the result set and joins this with the results from a number of recursive calls. So we separate these two actions into separate functions. These take as arguments the direct sum of \<open>\<afstate>\<close> and \<open>\<acstate>\<close>, i.e.\ we treat the two mutually recursive functions now as one.

\<open>abs_g\<close> gives the local result for the given argument.
\<close>

fixrec abs_g :: "('c::contour \<afstate> + 'c \<acstate>) discr \<rightarrow> 'c \<aans>"
  where "abs_g\<cdot>x = (case undiscr x of
              (Inl (PC (Lambda lab vs c, \<beta>), as, ve, b)) \<Rightarrow> {}
            | (Inl (PP (Plus c),[_,_,cnts],ve,b)) \<Rightarrow>
                     let b' = \<anb> b c;
                         \<beta>  = [c \<mapsto> b]
                     in {((c, \<beta>), cont) | cont . cont \<in> cnts}
            | (Inl (PP (prim.If ct cf),[_, cntts, cntfs],ve,b)) \<Rightarrow>
                  ((   let b' = \<anb> b ct;
                            \<beta> = [ct \<mapsto> b]
                        in {((ct, \<beta>), cnt) | cnt . cnt \<in> cntts}
                   )\<union>(
                       let b' = \<anb> b cf;
                            \<beta> = [cf \<mapsto> b]
                        in {((cf, \<beta>), cnt) | cnt . cnt \<in> cntfs}
                   ))
            | (Inl (AStop,[_],_,_)) \<Rightarrow> {}
            | (Inl _) \<Rightarrow> \<bottom>
            | (Inr (App lab f vs,\<beta>,ve,b)) \<Rightarrow>
                 let fs = \<aA> f \<beta> ve;
                     as = map (\<lambda>v. \<aA> v \<beta> ve) vs;
                     b' = \<anb> b lab
                  in {((lab, \<beta>),f') | f' . f'\<in> fs}
            | (Inr (Let lab ls c',\<beta>,ve,b)) \<Rightarrow> {}
        )"

text \<open>
\<open>abs_R\<close> gives the set of arguments passed to the recursive calls.
\<close>

fixrec abs_R :: "('c::contour \<afstate> + 'c \<acstate>) discr \<rightarrow> ('c::contour \<afstate> + 'c \<acstate>) discr set"
  where "abs_R\<cdot>x = (case undiscr x of
              (Inl (PC (Lambda lab vs c, \<beta>), as, ve, b)) \<Rightarrow>
               (if length vs = length as
                then let \<beta>' = \<beta> (lab \<mapsto> b);
                         ve' = ve \<union>. (\<Union>. (map (\<lambda>(v,a). {(v,b) := a}.) (zip vs as)))
                     in {Discr (Inr (c,\<beta>',ve',b))}
                else \<bottom>)
            | (Inl (PP (Plus c),[_,_,cnts],ve,b)) \<Rightarrow>
                     let b' = \<anb> b c;
                         \<beta>  = [c \<mapsto> b]
                     in (\<Union>cnt\<in>cnts. {Discr (Inl (cnt,[{}],ve,b'))})
            | (Inl (PP (prim.If ct cf),[_, cntts, cntfs],ve,b)) \<Rightarrow>
                  ((   let b' = \<anb> b ct;
                            \<beta> = [ct \<mapsto> b]
                        in (\<Union>cnt\<in>cntts . {Discr (Inl (cnt,[],ve,b'))})
                   )\<union>(
                       let b' = \<anb> b cf;
                            \<beta> = [cf \<mapsto> b]
                        in (\<Union>cnt\<in>cntfs . {Discr (Inl (cnt,[],ve,b'))})
                   ))
            | (Inl (AStop,[_],_,_)) \<Rightarrow> {}
            | (Inl _) \<Rightarrow> \<bottom>
            | (Inr (App lab f vs,\<beta>,ve,b)) \<Rightarrow>
                 let fs = \<aA> f \<beta> ve;
                     as = map (\<lambda>v. \<aA> v \<beta> ve) vs;
                     b' = \<anb> b lab
                  in (\<Union>f' \<in> fs. {Discr (Inl (f',as,ve,b'))})
            | (Inr (Let lab ls c',\<beta>,ve,b)) \<Rightarrow>
                 let b' = \<anb> b lab;
                     \<beta>' = \<beta> (lab \<mapsto> b');
                     ve' = ve \<union>. (\<Union>. (map (\<lambda>(v,l). {(v,b') := (\<aA> (L l) \<beta>' ve)}.) ls))
                 in {Discr (Inr (c',\<beta>',ve',b'))}
        )"

text \<open>
The initial argument vector, as created by \<open>\<aPR>\<close>.
\<close>

definition initial_r :: "prog \<Rightarrow> ('c::contour \<afstate> + 'c \<acstate>) discr"
  where "initial_r prog = Discr (Inl
     (the_elem (\<aA> (L prog) Map.empty {}.), [{AStop}], {}., \<abinit>))"

subsection \<open>Towards finiteness\<close>

text \<open>
We need to show that the set of possible arguments for a given program \<open>p\<close> is finite. Therefore, we define the set of possible procedures, of possible arguments to \<open>\<aF>\<close>, or possible arguments to \<open>\<aC>\<close> and of possible arguments.
\<close>

definition proc_poss :: "prog \<Rightarrow> 'c::contour proc set"
  where "proc_poss p = PC ` (lambdas p \<times> maps_over (labels p) UNIV) \<union> PP ` prims p \<union> {AStop}"

definition fstate_poss :: "prog \<Rightarrow> 'c::contour a_fstate set"
  where "fstate_poss p = (proc_poss p \<times> NList (Pow (proc_poss p)) (call_list_lengths p) \<times> smaps_over (vars p \<times> UNIV) (proc_poss p) \<times> UNIV)"

definition cstate_poss :: "prog \<Rightarrow> 'c::contour a_cstate set"
  where "cstate_poss p = (calls p \<times> maps_over (labels p) UNIV \<times> smaps_over (vars p \<times> UNIV) (proc_poss p) \<times> UNIV)"

definition arg_poss :: "prog \<Rightarrow> ('c::contour a_fstate + 'c a_cstate) discr set"
  where "arg_poss p = Discr ` (fstate_poss p <+> cstate_poss p)"

text \<open>
Using the auxiliary results from @{theory "Shivers-CFA.CPSUtils"}, we see that the argument space as defined here is finite.
\<close>

lemma finite_arg_space: "finite (arg_poss p)"
  unfolding arg_poss_def and cstate_poss_def and fstate_poss_def and proc_poss_def
  by (auto intro!: finite_cartesian_product finite_imageI maps_over_finite smaps_over_finite finite_UNIV finite_Nlist)

text \<open>
But is it closed? I.e.\ if we pass a member of \<open>arg_poss\<close> to \<open>abs_R\<close>, are the generated recursive call arguments also in \<open>arg_poss\<close>? This is shown in \<open>arg_space_complete\<close>, after proving an auxiliary result about the possible outcome of a call to \<open>\<aA>\<close> and an admissibility lemma.
\<close>

lemma evalV_possible:
  assumes f: "f \<in> \<aA> d \<beta> ve"
  and d: "d \<in> vals p"
  and ve: "ve \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)"
  and \<beta>: "\<beta> \<in> maps_over (labels p) UNIV"
shows "f \<in> proc_poss p"
proof (cases "(d,\<beta>,ve)" rule: evalV_a.cases)
case (1 cl \<beta>' ve')
  thus ?thesis using f by auto next
case (2 prim \<beta>' ve')
  thus ?thesis using d f
    by (auto dest: vals1 simp add:proc_poss_def)
next
case (3 l var \<beta>' ve')
  thus ?thesis using f d smaps_over_im[OF _ ve]
  by (auto split:option.split_asm dest: vals2)
next
case (4 l \<beta> ve)
  thus ?thesis using f d \<beta>
  by (auto dest!: vals3 simp add:proc_poss_def)
qed

lemma adm_subset: "cont (\<lambda>x. f x) \<Longrightarrow>  adm (\<lambda>x. f x \<subseteq> S)"
by (subst sqsubset_is_subset[THEN sym], intro adm_lemmas cont2cont)

lemma arg_space_complete:
  "state \<in> arg_poss p \<Longrightarrow> abs_R\<cdot>state \<subseteq> arg_poss p"
proof(induct rule: abs_R.induct[case_names Admissibility Bot Step])
case Admissibility show ?case
   by (intro adm_lemmas adm_subset cont2cont)
next
case Bot show ?case by simp next
case (Step abs_R)
  note state = Step(2)
  show ?case
  proof (cases state)
  case (Discr state') show ?thesis
   proof (cases state')
     case (Inl fstate) show ?thesis
     using Inl Discr state
     proof (cases fstate rule: a_fstate_case, auto)
     txt \<open>Case Lambda\<close>
     fix l vs c \<beta> as ve b
     assume "Discr (Inl (PC (Lambda l vs c, \<beta>), as, ve, b)) \<in> arg_poss p"
       hence lam: "Lambda l vs c \<in> lambdas p"
       and  beta: "\<beta> \<in> maps_over (labels p) UNIV "
       and  ve: "ve \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)"
       and  as: "as \<in> NList (Pow (proc_poss p)) (call_list_lengths p)"
       unfolding arg_poss_def fstate_poss_def proc_poss_def by auto

     from lam have "c \<in> calls p"
       by (rule lambdas1)

     moreover
     from lam have "l \<in> labels p"
       by (rule lambdas2)
     with beta have "\<beta>(l \<mapsto> b) \<in> maps_over (labels p) UNIV"
       by (rule maps_over_upd, auto)

     moreover
     from lam have vs: "set vs \<subseteq> vars p" by (rule lambdas3)
     from as have "\<forall> x \<in> set as. x \<in> Pow (proc_poss p)"
        unfolding NList_def nList_def by auto
     with vs have "ve \<union>. \<Union>.map (\<lambda>(v, y). { (v, b) := y}.) (zip vs as)
       \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)" (is "?ve' \<in> _")
       by (auto intro!: smaps_over_un[OF ve] smaps_over_Union smaps_over_singleton)
          (auto simp add:set_zip)

     ultimately
     have "(c, \<beta>(l \<mapsto> b), ?ve', b) \<in> cstate_poss p" (is "?cstate \<in> _")
       unfolding cstate_poss_def by simp
     thus "Discr (Inr ?cstate) \<in> arg_poss p"
       unfolding arg_poss_def by auto
     next

     txt \<open>Case Plus\<close>
     fix ve b l v1 v2 cnts cnt
     assume "Discr (Inl (PP (prim.Plus l), [v1, v2, cnts], ve, b)) \<in> arg_poss p"
         and "cnt \<in> cnts"
     hence "cnt \<in> proc_poss p"
         and "ve \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)"
       unfolding arg_poss_def fstate_poss_def NList_def nList_def
       by auto
     moreover
     have "[{}] \<in> NList (Pow (proc_poss p)) (call_list_lengths p)"
       unfolding call_list_lengths_def NList_def nList_def by auto
     ultimately
     have "(cnt, [{}], ve, \<anb> b l) \<in> fstate_poss p"
       unfolding fstate_poss_def by auto
     thus "Discr (Inl (cnt, [{}], ve, \<anb> b l)) \<in> arg_poss p"
       unfolding arg_poss_def by auto
     next

     txt \<open>Case If (true case)\<close>
     fix ve b l1 l2 v cntst cntsf cnt
     assume "Discr (Inl (PP (prim.If l1 l2), [v, cntst, cntsf], ve, b)) \<in> arg_poss p"
         and "cnt \<in> cntst"
     hence "cnt \<in> proc_poss p"
         and "ve \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)"
       unfolding arg_poss_def fstate_poss_def NList_def nList_def
       by auto
     moreover
     have "[] \<in> NList (Pow (proc_poss p)) (call_list_lengths p)"
       unfolding call_list_lengths_def NList_def nList_def by auto
     ultimately
     have "(cnt, [], ve, \<anb> b l1) \<in> fstate_poss p"
       unfolding fstate_poss_def by auto
     thus "Discr (Inl (cnt, [], ve, \<anb> b l1)) \<in> arg_poss p"
       unfolding arg_poss_def by auto
     next

     txt \<open>Case If (false case)\<close>
     fix ve b l1 l2 v cntst cntsf cnt
     assume "Discr (Inl (PP (prim.If l1 l2), [v, cntst, cntsf], ve, b)) \<in> arg_poss p"
         and "cnt \<in> cntsf"
     hence "cnt \<in> proc_poss p"
         and "ve \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)"
       unfolding arg_poss_def fstate_poss_def NList_def nList_def
       by auto
     moreover
     have "[] \<in> NList (Pow (proc_poss p)) (call_list_lengths p)"
       unfolding call_list_lengths_def NList_def nList_def by auto
     ultimately
     have "(cnt, [], ve, \<anb> b l2) \<in> fstate_poss p"
       unfolding fstate_poss_def by auto
     thus "Discr (Inl (cnt, [], ve, \<anb> b l2)) \<in> arg_poss p"
       unfolding arg_poss_def by auto
    qed
  next
  case (Inr cstate)
  show ?thesis proof(cases cstate rule: prod_cases4)
   case (fields c \<beta> ve b)
   show ?thesis using Discr Inr fields state proof(cases c, auto simp add:HOL.Let_def simp del:evalV_a.simps)

     txt \<open>Case App\<close>
     fix l d ds f
     assume arg: "Discr (Inr (App l d ds, \<beta>, ve, b)) \<in> arg_poss p"
       and f: "f \<in> \<aA> d \<beta> ve"
     hence c: "App l d ds \<in> calls p"
       and d: "d \<in> vals p"
       and ds: "set ds \<subseteq> vals p"
       and beta: "\<beta> \<in> maps_over (labels p) UNIV"
       and ve: "ve \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)"
     by (auto simp add: arg_poss_def cstate_poss_def call_list_lengths_def dest: app1 app2)

     have len: "length ds \<in> call_list_lengths p"
       by (auto intro: rev_image_eqI[OF c] simp add: call_list_lengths_def)

     have "f \<in> proc_poss p"
       using f d ve beta by (rule evalV_possible)
     moreover
     have "map (\<lambda>v. \<aA> v \<beta> ve) ds \<in> NList (Pow (proc_poss p)) (call_list_lengths p)"
       using ds len
       unfolding NList_def by (auto simp add:nList_def intro!: evalV_possible[OF _ _ ve beta])
     ultimately
     have "(f, map (\<lambda>v. \<aA> v \<beta> ve) ds, ve, \<anb> b l) \<in> fstate_poss p" (is "?fstate \<in> _")
       using ve
       unfolding fstate_poss_def by simp
     thus "Discr (Inl ?fstate) \<in> arg_poss p"
       unfolding arg_poss_def by auto

   next
     txt \<open>Case Let\<close>
     fix l binds c'
     assume arg: "Discr (Inr (Let l binds c', \<beta>, ve, b)) \<in> arg_poss p"
     hence l: "l \<in> labels p"
       and c': "c' \<in> calls p"
       and vars: "fst ` set binds \<subseteq> vars p"
       and ls: "snd ` set binds \<subseteq> lambdas p"
       and beta: "\<beta> \<in> maps_over (labels p) UNIV"
       and ve: "ve \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)"
     by (auto simp add: arg_poss_def cstate_poss_def call_list_lengths_def
              dest:let1 let2 let3 let4)

     have beta': "\<beta>(l \<mapsto> \<anb> b l) \<in> maps_over (labels p) UNIV" (is "?\<beta>' \<in> _")
       by (auto intro: maps_over_upd[OF beta l])

     moreover
     have "ve \<union>. \<Union>.map (\<lambda>(v, lam). { (v, \<anb> b l) := \<aA> (L lam) (\<beta>(l \<mapsto> \<anb> b l)) ve }.)
                binds
       \<in> smaps_over (vars p \<times> UNIV) (proc_poss p)" (is "?ve' \<in> _")
       using vars ls beta'
       by (auto intro!: smaps_over_un[OF ve] smaps_over_Union)
          (auto intro!:smaps_over_singleton simp add: proc_poss_def)

     ultimately
     have "(c', ?\<beta>', ?ve', \<anb> b l) \<in> cstate_poss p" (is "?cstate \<in> _")
     using c' unfolding cstate_poss_def by simp
     thus "Discr (Inr ?cstate) \<in> arg_poss p"
       unfolding arg_poss_def by auto
   qed
 qed
qed
qed
qed

text \<open>
This result is now lifted to the powerset of \<open>abs_R\<close>.
\<close>

lemma arg_space_complete_ps: "states \<subseteq> arg_poss p \<Longrightarrow> (\<^ps>abs_R)\<cdot>states \<subseteq> arg_poss p"
using arg_space_complete unfolding powerset_lift_def by auto

text \<open>
We are not so much interested in the finiteness of the set of possible arguments but rather of the the set of occurring arguments, when we start with the initial argument. But as this is of course a subset of the set of possible arguments, this is not hard to show.
\<close>

lemma UN_iterate_less:
  assumes start: "x \<in> S"
  and step: "\<And>y. y\<subseteq>S \<Longrightarrow> (f\<cdot>y) \<subseteq> S"
  shows "(\<Union>i. iterate i\<cdot>f\<cdot>{x}) \<subseteq> S"
proof- {
  fix i
  have "iterate i\<cdot>f\<cdot>{x} \<subseteq> S"
  proof(induct i)
    case 0 show ?case using \<open>x \<in> S\<close> by simp next
    case (Suc i) thus ?case using step[of "iterate i\<cdot>f\<cdot>{x}"] by simp
  qed
  } thus ?thesis by auto
qed

lemma args_finite: "finite (\<Union>i. iterate i\<cdot>(\<^ps>abs_R)\<cdot>{initial_r p})" (is "finite ?S")
proof (rule finite_subset[OF _finite_arg_space])
  have [simp]:"p \<in> lambdas p" by (cases p, simp)
  show "?S \<subseteq> arg_poss p"
  unfolding initial_r_def
  by  (rule UN_iterate_less[OF _ arg_space_complete_ps])
      (auto simp add:arg_poss_def fstate_poss_def proc_poss_def call_list_lengths_def NList_def nList_def
         intro!: imageI)
qed

subsection \<open>A decomposition\<close>

text \<open>
The functions \<open>abs_g\<close> and \<open>abs_R\<close> are derived from \<open>\<aF>\<close> and \<open>\<aC>\<close>. This connection has yet to expressed explicitly.
\<close>

lemma Un_commute_helper:"(a \<union> b) \<union> (c \<union> d) = (a \<union> c) \<union> (b \<union> d)"
by auto

lemma a_evalF_decomp:
  "\<aF> = fst (sum_to_tup\<cdot>(fix\<cdot>(\<Lambda> f x. (\<Union>y\<in>abs_R\<cdot>x. f\<cdot>y) \<union> abs_g\<cdot>x)))"
apply (subst a_evalF_def)
apply (subst fix_transform_pair_sum)
apply (rule arg_cong [of _ _ "\<lambda>x. fst (sum_to_tup\<cdot>(fix\<cdot>x))"])
apply (simp)
apply (simp only: discr_app undiscr_Discr)
apply (rule cfun_eqI, rule cfun_eqI, simp)
apply (case_tac xa, rename_tac a, case_tac a, simp)
apply (case_tac aa rule:a_fstate_case, simp_all add: Un_commute_helper)
apply (case_tac b rule:prod_cases4)
apply (case_tac aa)
apply (simp_all add:HOL.Let_def)
done

subsection \<open>The iterative equation\<close>

text \<open>
Because of the special form of \<open>\<aF>\<close> (and thus \<open>\<aPR>\<close>) derived in the previous lemma, we can apply our generic results from @{theory "Shivers-CFA.Computability"} and express the abstract semantics as the image of a finite set under a computable function.
\<close>

lemma a_evalF_iterative:
  "\<aF>\<cdot>(Discr x) = \<^ps>abs_g\<cdot>(\<Union>i. iterate i\<cdot>(\<^ps>abs_R)\<cdot>{Discr (Inl x)})"
by (simp del:abs_R.simps abs_g.simps add: theorem12 Un_commute a_evalF_decomp)

lemma a_evalCPS_interative:
"\<aPR> prog = \<^ps>abs_g\<cdot>(\<Union>i. iterate i\<cdot>(\<^ps>abs_R)\<cdot>{initial_r prog})"
unfolding evalCPS_a_def and initial_r_def
by(subst a_evalF_iterative, simp del:abs_R.simps abs_g.simps evalV_a.simps)

end


section{*Properties for Proving the Abstract Translation Algorithm*}

theory HBDTranslationProperties imports ExtendedHBDAlgebra Diagrams
begin
context BaseOperationVars
begin

lemma io_diagram_fb_perm_eq: "io_diagram A \<Longrightarrow> fb_perm_eq A"
proof (simp add: fb_perm_eq_def, safe)
  fix x
  assume [simp]: "perm x (VarFB A)"
  assume [simp]: "io_diagram A"

  have [simp]: "perm (VarFB A) x"
    by (simp add: perm_sym)

  have [simp]: "set (VarFB A) \<inter> set (InFB A) = {}"
    by (simp add: VarFB_def Var_def InFB_def)

  have [simp]: "set (VarFB A) \<inter> set (OutFB A) = {}"
    by (simp add: VarFB_def Var_def OutFB_def)

  have [simp]: "perm (Out A) (VarFB A @ OutFB A)"
    by (metis OutFB_def VarFB_def Var_def \<open>io_diagram A\<close> diff_inter_left perm_switch_aux_c perm_sym io_diagram_def)

  have [simp]: "set x \<subseteq> set (VarFB A) \<union> set (OutFB A)"
    using \<open>perm x (VarFB A)\<close> perm_set_eq by blast

  have [simp]: "distinct x"
    using \<open>perm x (VarFB A)\<close>
    by (metis VarFB_def Var_def \<open>perm (VarFB A) x\<close> \<open>io_diagram A\<close> dist_perm distinct_inter io_diagram_def)
  have "set x \<inter> set (InFB A) = {}"
    using \<open>perm x (VarFB A)\<close>
    by (metis Diff_disjoint InFB_def perm_diff_eq set_diff)

  have [simp]: "set (In A) \<subseteq> set (VarFB A) \<union> set (InFB A)"
    by (simp add: InFB_def set_diff)

  have [simp]: "set x \<inter> set (InFB A) = {}"
    by (simp add: \<open>set x \<inter> set (InFB A) = {}\<close>)

  have [simp]: "TI (Trs A) = TVs (In A)"
    using \<open>io_diagram A\<close> io_diagram_distinct(3) by blast
  have [simp]: "TO (Trs A) = TVs (Out A)"
    using \<open>io_diagram A\<close> io_diagram_distinct(4) by blast
  have [simp]: "distinct (Out A)"
    using \<open>io_diagram A\<close> io_diagram_distinct(2) by blast

  have "(fb ^^ length (VarFB A)) ([VarFB A @ InFB A \<leadsto> In A] oo Trs A oo [Out A \<leadsto> VarFB A @ OutFB A])
    = (fb ^^ length (VarFB A)) ([x @ InFB A \<leadsto> VarFB A @ InFB A]
      oo ([VarFB A @ InFB A \<leadsto> In A] oo Trs A oo [Out A \<leadsto> VarFB A @ OutFB A])
      oo [VarFB A @ OutFB A \<leadsto> x @ OutFB A])"

    by (subst fb_perm, simp_all add: fbtype_def)
  also have "... = (fb ^^ length (VarFB A)) ( ([x @ InFB A \<leadsto> VarFB A @ InFB A]
      oo [VarFB A @ InFB A \<leadsto> In A]) oo Trs A oo ([Out A \<leadsto> VarFB A @ OutFB A]
      oo [VarFB A @ OutFB A \<leadsto> x @ OutFB A]))"
    by (simp add: comp_assoc)
  also have "... = (fb ^^ length (VarFB A)) ( ([x @ InFB A \<leadsto> In A]) oo Trs A oo ([Out A \<leadsto> x @ OutFB A]))"
    apply (subgoal_tac "[x @ InFB A \<leadsto> VarFB A @ InFB A] oo [VarFB A @ InFB A \<leadsto> In A] = [x @ InFB A \<leadsto> In A]")
     apply simp
     apply (subgoal_tac "[Out A \<leadsto> VarFB A @ OutFB A] oo [VarFB A @ OutFB A \<leadsto> x @ OutFB A] = [Out A \<leadsto> x @ OutFB A]")
      apply simp
     by (simp_all add:  switch_comp)

  finally show "(fb ^^ length (VarFB A)) ([VarFB A @ InFB A \<leadsto> In A] oo Trs A oo [Out A \<leadsto> VarFB A @ OutFB A]) =
         (fb ^^ length (VarFB A)) ([x @ InFB A \<leadsto> In A] oo Trs A oo [Out A \<leadsto> x @ OutFB A])"
    by simp
qed

theorem FeedbackSerial: "io_diagram A \<Longrightarrow> io_diagram B \<Longrightarrow> set (In A) \<inter> set (In B) = {} (*required*)
  \<Longrightarrow> set (Out A) \<inter> set (Out B) = {} \<Longrightarrow> FB (A ||| B) = FB (FB (A) ;; FB (B))"

  apply (rule FeedbackSerial_Feedbackless, simp_all)
  apply (rule io_diagram_fb_perm_eq)
  by (simp add: io_diagram_Parallel)

lemmas fb_perm_sym = fb_perm [THEN sym]

declare length_TVs [simp del]

declare [[simp_trace_depth_limit=40]]

lemma in_out_equiv_FB: "io_diagram B \<Longrightarrow> in_out_equiv A B \<Longrightarrow> in_out_equiv (FB A) (FB B)"
  apply (rule in_out_equiv_FB_less, simp_all)
  apply (rule io_diagram_fb_perm_eq)
  using in_out_equiv_io_diagram by blast

end

end


theory MorphismImage
  imports ParticularStructureMorphisms
begin

context inherence_base
begin

lemma \<^marker>\<open>tag (proof) aponly\<close> moments_eq_particulars_minus_subst: \<open>\<M> = \<P> - \<S>\<close> by blast

lemma \<^marker>\<open>tag (proof) aponly\<close> substantials_eq_particulars_minus_moments: \<open>\<S> = \<P> - \<M>\<close> by blast

end

context particular_struct_morphism
begin

abbreviation \<^marker>\<open>tag aponly\<close> \<open>\<W>\<^sub>\<phi> \<equiv> ps_worlds (MorphImg \<phi> \<Gamma>\<^sub>1)\<close>
abbreviation \<^marker>\<open>tag aponly\<close>img_inheres_in (infix \<open>\<triangleleft>\<^sub>\<phi>\<close> 75)
  where \<open>(\<triangleleft>\<^sub>\<phi>) \<equiv> ps_inheres_in (MorphImg \<phi> \<Gamma>\<^sub>1)\<close>
abbreviation \<^marker>\<open>tag aponly\<close>img_assoc_quale (infix \<open>\<leadsto>\<^sub>\<phi>\<close> 75)
  where \<open>(\<leadsto>\<^sub>\<phi>) \<equiv> ps_assoc_quale (MorphImg \<phi> \<Gamma>\<^sub>1)\<close>
abbreviation \<^marker>\<open>tag aponly\<close>img_towards (infix \<open>\<longlongrightarrow>\<^sub>\<phi>\<close> 75)
  where \<open>(\<longlongrightarrow>\<^sub>\<phi>) \<equiv> ps_towards (MorphImg \<phi> \<Gamma>\<^sub>1)\<close>

interpretation \<^marker>\<open>tag aponly\<close> img: ufo_particular_theory_sig \<open>\<W>\<^sub>\<phi>\<close> \<open>(\<triangleleft>\<^sub>\<phi>)\<close> src.\<Q>\<S> \<open>(\<leadsto>\<^sub>\<phi>)\<close> \<open>(\<longlongrightarrow>\<^sub>\<phi>)\<close> .

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_particulars(*[simp]*): \<open>img.\<P> = \<phi> ` src.\<P>\<close>
  by (auto simp: possible_worlds_sig.\<P>_def)

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_worlds_tgt(*[simp]*):
  \<open>\<W>\<^sub>\<phi> = { w \<inter> \<phi> ` src.\<P> | w . w \<in> tgt.\<W>}\<close>
(* slow *)
proof (auto)
  fix w\<^sub>s
  assume A[simp]: \<open>w\<^sub>s \<in> src.\<W>\<close>
  then obtain w\<^sub>t where B: \<open>w\<^sub>s \<Leftrightarrow> w\<^sub>t\<close> using morph_worlds_correspond_src_tgt by metis
  obtain C[simp]: \<open>w\<^sub>t \<in> tgt.\<W>\<close> \<open>\<And>x. x \<in> src.\<P> \<Longrightarrow> x \<in> w\<^sub>s \<longleftrightarrow> \<phi> x \<in> w\<^sub>t\<close>
    using world_corresp_E[OF B] by metis
  have \<open>\<phi> ` w\<^sub>s = w\<^sub>t \<inter> \<phi> ` src.endurants\<close>
    apply auto
    using A C(2) by blast+
  then show \<open>\<exists>w\<^sub>t. \<phi> ` w\<^sub>s = w\<^sub>t \<inter> \<phi> ` src.endurants \<and> w\<^sub>t \<in> tgt.\<W>\<close>
    using C(1) by blast
next
  fix w\<^sub>t
  assume A[simp]: \<open>w\<^sub>t \<in> tgt.\<W>\<close>
  then obtain w\<^sub>s where B: \<open>w\<^sub>s \<Leftrightarrow> w\<^sub>t\<close> using morph_worlds_correspond_tgt_src by metis
  obtain C[simp]: \<open>w\<^sub>s \<in> src.\<W>\<close> \<open>\<And>x. x \<in> src.\<P> \<Longrightarrow> x \<in> w\<^sub>s \<longleftrightarrow> \<phi> x \<in> w\<^sub>t\<close>
    using world_corresp_E[OF B] by metis
  have \<open>w\<^sub>t \<inter> \<phi> ` src.endurants = \<phi> ` w\<^sub>s \<and> w\<^sub>s \<in> src.\<W>\<close>
    apply auto
    using A C by blast+
  then show \<open>\<exists>w\<^sub>s. w\<^sub>t \<inter> \<phi> ` src.endurants = \<phi> ` w\<^sub>s \<and> w\<^sub>s \<in> src.\<W>\<close> by blast
qed

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_worlds_src:\<open>\<W>\<^sub>\<phi> = ((`) \<phi>) ` src.\<W>\<close>
  by auto

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_ed_tgt(*[simp]*):  \<open>img.ed x y \<longleftrightarrow> x \<in> \<phi> ` src.\<P> \<and> y \<in> \<phi> ` src.\<P> \<and> tgt.ed x y\<close>
proof (intro iffI conjI ; (elim conjE)?)
  assume A: \<open>possible_worlds_sig.ed (ps_worlds (MorphImg \<phi> \<Gamma>\<^sub>1)) x y\<close>
  obtain B[simp]: \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> and C: \<open>\<And>w. w \<in> ps_worlds (MorphImg \<phi> \<Gamma>\<^sub>1) \<Longrightarrow> x \<in> w \<Longrightarrow> y \<in> w\<close>
    using possible_worlds_sig.edE[OF A,simplified morph_image_particulars ] by blast
  show D: \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> by simp_all
  have E: \<open>y \<in> w\<^sub>1\<close> if \<open>w\<^sub>1 = w\<^sub>2 \<inter> \<phi> ` src.\<P>\<close> \<open>w\<^sub>2 \<in> tgt.\<W>\<close> \<open>x \<in> w\<^sub>1\<close> for w\<^sub>1 w\<^sub>2
    using C[simplified morph_image_worlds_tgt, OF CollectI] that by metis
  obtain F[simp]: \<open>x \<in> tgt.\<P>\<close> \<open>y \<in> tgt.\<P>\<close> using D by blast
  show \<open>tgt.ed x y\<close>
  proof (intro tgt.edI F)
    fix w\<^sub>t
    assume AA[simp]: \<open>w\<^sub>t \<in> tgt.\<W>\<close> \<open>x \<in> w\<^sub>t\<close>
    show \<open>y \<in> w\<^sub>t\<close>
      using E[of \<open>w\<^sub>t \<inter> \<phi> ` src.\<P>\<close> w\<^sub>t,THEN IntD1,simplified] by simp
  qed
next
  assume A: \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> \<open>tgt.ed x y\<close>
  then obtain x\<^sub>s y\<^sub>s where B[simp]: \<open>x = \<phi> x\<^sub>s\<close> \<open>y = \<phi> y\<^sub>s\<close> \<open>x\<^sub>s \<in> src.\<P>\<close> \<open>y\<^sub>s \<in> src.\<P>\<close> by blast
  obtain C[simp]: \<open>\<phi> x\<^sub>s \<in> tgt.\<P>\<close> \<open>\<phi> y\<^sub>s \<in> tgt.\<P>\<close> using A B by blast
  have D: \<open>\<phi> y\<^sub>s \<in> w\<close> if \<open>w \<in> tgt.\<W>\<close> \<open>\<phi> x\<^sub>s \<in> w\<close> for w
    using tgt.edE[OF A(3),simplified] that by blast
  obtain E: \<open>\<phi> x\<^sub>s \<in> particulars (MorphImg \<phi> \<Gamma>\<^sub>1)\<close> \<open>\<phi> y\<^sub>s \<in> particulars (MorphImg \<phi> \<Gamma>\<^sub>1)\<close>
    by (simp only: morph_image_particulars A B(1,2)[symmetric])

  show \<open>possible_worlds_sig.ed (ps_worlds (MorphImg \<phi> \<Gamma>\<^sub>1)) x y\<close>
  proof (simp only: B ; intro possible_worlds_sig.edI E ; simp ; elim exE conjE ; simp)
    fix w :: "'p\<^sub>2 set" and wa :: "'p\<^sub>1 set"
    assume a1: "\<phi> x\<^sub>s \<in> \<phi> ` wa"
    assume a2: "w = \<phi> ` wa"
    assume "wa \<in> src.\<W>"
    then obtain PP :: "'p\<^sub>1 set \<Rightarrow> 'p\<^sub>2 set" where
      f3: "wa \<Leftrightarrow> PP wa"
      by (meson morph_worlds_correspond_src_tgt)
    have "x \<in> w"
      using a2 a1 by fastforce
    then show "\<phi> y\<^sub>s \<in> \<phi> ` wa"
      using f3 a2 A(3) B(2) B(4) by blast
  qed
qed

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_edI:
  assumes \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> \<open>tgt.ed x y\<close>
  shows \<open>img.ed x y\<close>
  using assms by (simp only: morph_image_ed_tgt)

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_edD:
  assumes \<open>img.ed x y\<close>
  shows \<open>tgt.ed x y\<close>
  using assms by (simp only: morph_image_ed_tgt)

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_edE:
  assumes \<open>img.ed x y\<close>
  obtains \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> \<open>tgt.ed x y\<close>
  using assms by (simp only: morph_image_ed_tgt)

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_indep_iff: \<open>img.indep x y \<longleftrightarrow> x \<in> \<phi> ` src.\<P> \<and> y \<in> \<phi> ` src.\<P> \<and> tgt.indep x y\<close>
proof (intro iffI conjI ; (elim conjE)?)
  assume A: \<open>img.indep x y\<close>
  obtain B: \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> \<open>\<not> img.ed x y\<close> \<open>\<not> img.ed y x\<close>
    using img.indepE[OF A,simplified morph_image_particulars] by metis
  then show \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> by simp+
  obtain C: \<open>x \<in> tgt.\<P>\<close> \<open>y \<in> tgt.\<P>\<close> using B(1,2) by blast
  have D: \<open>\<not> tgt.ed x y\<close>  \<open>\<not> tgt.ed y x\<close>
    using B(3,4)[THEN notE,OF morph_image_edI] B(2,1) by metis+
  then show \<open>tgt.indep x y\<close>
    by (intro tgt.indepI C D)
next
  assume A: \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> and B: \<open>tgt.indep x y\<close>
  show \<open>img.indep x y\<close>
    apply (intro img.indepI notI ; (elim notE morph_image_edE)?
          ; (simp only: morph_image_particulars A) ; simp)
    using B tgt.indepE by blast+
qed

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_indepI:
  assumes \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> \<open>tgt.indep x y\<close>
  shows \<open>img.indep x y\<close>
  using assms by (simp only: morph_image_indep_iff)

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_indepE:
  assumes \<open>img.indep x y\<close>
  obtains \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> \<open>tgt.indep x y\<close>
  using assms by (simp only: morph_image_indep_iff)

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_indepD:
  assumes \<open>img.indep x y\<close>
  shows \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> \<open>tgt.indep x y\<close>
  using assms by (simp only: morph_image_indep_iff)+

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_inheres_in: \<open>x \<triangleleft>\<^sub>\<phi> y \<longleftrightarrow> x \<in> \<phi> ` src.\<P> \<and> y \<in> \<phi> ` src.\<P> \<and> x \<triangleleft>\<^sub>t y\<close>
  apply (auto)
  by blast

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_inheres_in_I:
  assumes \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> \<open>x \<triangleleft>\<^sub>t y\<close>
  shows \<open>x \<triangleleft>\<^sub>\<phi> y\<close>
  using assms by (simp only: morph_image_inheres_in)

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_inheres_in_E:
  assumes \<open>x \<triangleleft>\<^sub>\<phi> y\<close>
  obtains \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> \<open>x \<triangleleft>\<^sub>t y\<close>
  using assms by (simp only: morph_image_inheres_in)

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_inheres_in_D:
  assumes \<open>x \<triangleleft>\<^sub>\<phi> y\<close>
  shows \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> \<open>x \<triangleleft>\<^sub>t y\<close>
  using assms by (simp only: morph_image_inheres_in)+

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_trans_inheres_in:  \<open>(\<triangleleft>\<^sub>\<phi>)\<^sup>+\<^sup>+ x y \<longleftrightarrow> x \<in> \<phi> ` src.\<P> \<and> y \<in> \<phi> ` src.\<P> \<and> (\<triangleleft>\<^sub>t)\<^sup>+\<^sup>+ x y\<close>
proof (intro iffI conjI ; (elim conjE)?)
  assume A: \<open>(\<triangleleft>\<^sub>\<phi>)\<^sup>+\<^sup>+ x y\<close>
  show G1: \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close>
  proof -
    obtain x\<^sub>1 where \<open>x \<triangleleft>\<^sub>\<phi> x\<^sub>1\<close>
      using A tranclp_induct by metis
    obtain y\<^sub>1 where \<open>y\<^sub>1 \<triangleleft>\<^sub>\<phi> y\<close>
      using A by (metis tranclp.cases)
    then show \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close>
      using \<open>x \<triangleleft>\<^sub>\<phi> x\<^sub>1\<close> morph_image_inheres_in_D(1,2) by metis+
  qed
  from A
  show \<open>(\<triangleleft>\<^sub>t)\<^sup>+\<^sup>+ x y\<close>
  proof (induct)
    fix y
    assume AA: \<open>x \<triangleleft>\<^sub>\<phi> y\<close>
    show \<open>(\<triangleleft>\<^sub>t)\<^sup>+\<^sup>+ x y\<close>
      using AA morph_image_inheres_in_D(3) tranclp.intros(1) by metis
  next
    fix y z
    assume AA:  \<open>y \<triangleleft>\<^sub>\<phi> z\<close> \<open>(\<triangleleft>\<^sub>t)\<^sup>+\<^sup>+ x y\<close>
    then show \<open>(\<triangleleft>\<^sub>t)\<^sup>+\<^sup>+ x z\<close>
      using AA morph_image_inheres_in_D(3) tranclp.intros(2) by metis
  qed
next
  assume A: \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> and B: \<open>(\<triangleleft>\<^sub>t)\<^sup>+\<^sup>+ x y\<close>
  from B
  show \<open>(\<triangleleft>\<^sub>\<phi>)\<^sup>+\<^sup>+ x y\<close>
  proof (induct)
    fix y
    assume AA: \<open>x \<triangleleft>\<^sub>t y\<close>
    then show \<open>(\<triangleleft>\<^sub>\<phi>)\<^sup>+\<^sup>+ x y\<close>
      using A morph_image_inheres_in_I tranclp.intros(1)
      by (metis image_iff morph_does_not_add_bearers)
  next
    fix y z
    assume AA: \<open>(\<triangleleft>\<^sub>t)\<^sup>+\<^sup>+ x y\<close> \<open>y \<triangleleft>\<^sub>t z\<close> \<open>(\<triangleleft>\<^sub>\<phi>)\<^sup>+\<^sup>+ x y\<close>
    have BB: \<open>y \<in> \<phi> ` src.\<P>\<close>
      by (metis AA(3) converse_tranclp_induct morph_image_inheres_in)
    then have CC: \<open>z \<in> \<phi> ` src.\<P>\<close> using morph_does_not_add_bearers AA(2) by blast
    then have BB: \<open>y \<triangleleft>\<^sub>\<phi> z\<close>
      using morph_image_inheres_in_I BB AA(2) by blast
    then show \<open>(\<triangleleft>\<^sub>\<phi>)\<^sup>+\<^sup>+ x z\<close>
      using AA(3) tranclp.intros(2) by metis
  qed
qed

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_moments(*[simp]*): \<open>img.\<M> = \<phi> ` src.\<M>\<close>
  by (auto  simp: inherence_sig.\<M>_def)

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_assoc_quale: \<open>x \<leadsto>\<^sub>\<phi> q \<longleftrightarrow> x \<in> \<phi> ` src.\<P> \<and> x \<leadsto>\<^sub>t q\<close>
  apply (auto)
  subgoal by (meson imageI src.assoc_quale_scopeD(1))
  subgoal using morph_reflects_quale_assoc src.assoc_quale_scopeD(1) by blast
  using morph_reflects_quale_assoc by blast

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_assoc_quale_I:
  assumes \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>x \<leadsto>\<^sub>t q\<close>
  shows \<open>x \<leadsto>\<^sub>\<phi> q\<close>
  using assms by (simp only: morph_image_assoc_quale)

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_assoc_quale_E:
  assumes\<open>x \<leadsto>\<^sub>\<phi> q\<close>
  obtains \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>x \<leadsto>\<^sub>t q\<close>
  using assms by (simp only: morph_image_assoc_quale)

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_assoc_quale_D:
  assumes\<open>x \<leadsto>\<^sub>\<phi> q\<close>
  shows \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>x \<leadsto>\<^sub>t q\<close>
  using assms by (simp only: morph_image_assoc_quale)+

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_towards(*[simp]*): \<open>x \<longlongrightarrow>\<^sub>\<phi> y \<longleftrightarrow> x \<in> \<phi> ` src.\<P> \<and> y \<in> \<phi> ` src.\<P> \<and> x \<longlongrightarrow>\<^sub>t y\<close>
  apply (auto)
  subgoal G1 using morph_reflects_towardness by blast
  subgoal G2 by blast
  done

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_towards_I:
  assumes \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> \<open>x \<longlongrightarrow>\<^sub>t y\<close>
  shows \<open>x \<longlongrightarrow>\<^sub>\<phi> y\<close>
  using assms by (simp only: morph_image_towards)

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_towards_E:
  assumes \<open>x \<longlongrightarrow>\<^sub>\<phi> y\<close>
  obtains \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> \<open>x \<longlongrightarrow>\<^sub>t y\<close>
  using assms by (simp only: morph_image_towards)

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_towards_D:
  assumes \<open>x \<longlongrightarrow>\<^sub>\<phi> y\<close>
  shows \<open>x \<in> \<phi> ` src.\<P>\<close> \<open>y \<in> \<phi> ` src.\<P>\<close> \<open>x \<longlongrightarrow>\<^sub>t y\<close>
  using assms by (simp only: morph_image_towards)+

interpretation img: possible_worlds \<open>\<W>\<^sub>\<phi>\<close>
  apply (unfold_locales)
  subgoal G1 by (simp add: tgt.injection_to_ZF_exist)
  subgoal G2 by (simp add: src.at_least_one_possible_world)
proof(simp only: morph_image_particulars ; simp only: morph_image_worlds_src
        ; auto)
  fix xa :: 'p\<^sub>1
  assume a1: "xa \<in> src.endurants"
  then obtain PP :: "'p\<^sub>1 \<Rightarrow> 'p\<^sub>1 set" where
    f2: "PP xa \<in> src.\<W> \<and> xa \<notin> PP xa"
    by (meson src.particulars_do_not_exist_in_some_world)
  then obtain PPa :: "'p\<^sub>1 set \<Rightarrow> 'p\<^sub>2 set" where
    "PP xa \<Leftrightarrow> PPa (PP xa)"
    by (meson morph_worlds_correspond_src_tgt)
  then have f3: "PP xa \<in> src.\<W> \<and> PPa (PP xa) \<in> tgt.\<W> \<and> (\<forall>p. p \<notin> src.endurants \<or> (p \<in> PP xa) = (\<phi> p \<in> PPa (PP xa)))"
    by blast
  have "\<forall>p f P. (p::'p\<^sub>2) \<notin> f ` P \<or> (\<exists>pa. p = f (pa::'p\<^sub>1) \<and> pa \<in> P)"
    by blast
  then show "\<exists>P\<in>src.\<W>. \<phi> xa \<notin> \<phi> ` P"
    using f3 f2 a1 by (metis possible_worlds_sig.\<P>_I)
qed

interpretation img: inherence_base \<open>\<W>\<^sub>\<phi>\<close> \<open>(\<triangleleft>\<^sub>\<phi>)\<close>
  apply (unfold_locales ; (simp only: morph_image_ed_tgt morph_image_particulars)?
        ; elim morph_image_inheres_in_E
        ; (intro conjI)? ; simp?)
  subgoal by (simp add: tgt.inherence_imp_ed)
  using tgt.moment_non_migration by blast

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_substantials(*[simp]*): \<open>img.\<S> = \<phi> ` src.\<S>\<close>
  apply (simp only: inherence_sig.\<S>_def morph_image_particulars morph_image_moments)
  apply auto
  by (metis morph_preserves_moments_simp morph_preserves_moments)

interpretation img: noetherian_inherence \<open>\<W>\<^sub>\<phi>\<close> \<open>(\<triangleleft>\<^sub>\<phi>)\<close>
  apply (unfold_locales ; simp)
  apply (rule wf_subset[to_pred,OF tgt.inherence_is_noetherian] ; simp ; rule)
  apply (elim exE conjE )
  using morph_preserves_inherence_1 by metis

interpretation img: inherence \<open>\<W>\<^sub>\<phi>\<close> \<open>(\<triangleleft>\<^sub>\<phi>)\<close>
  apply (unfold_locales ; simp)
  apply (rule wf_subset[to_pred,OF tgt.inherence_is_wf] ; rule )
  apply (elim exE conjE )
  using morph_preserves_inherence_1 by metis

interpretation img: quality_space \<open>ps_quality_spaces (MorphImg \<phi> \<Gamma>\<^sub>1)\<close>
  by (simp ; unfold_locales)

interpretation img:  qualified_particulars \<open>\<W>\<^sub>\<phi>\<close> \<open>(\<triangleleft>\<^sub>\<phi>)\<close>  \<open>src.\<Q>\<S>\<close> \<open>(\<leadsto>\<^sub>\<phi>)\<close>
  supply   ParticularStructure.particular_struct.simps[simp del]
  apply (unfold_locales ; (simp only: morph_image_moments morph_image_assoc_quale ; simp )?
          ; (elim conjE)?)
  subgoal G1 by (metis image_eqI  morph_image_def morph_image_iff  morph_reflects_quale_assoc src.assoc_quale_scope)
  subgoal G1 by (simp add: tgt.assoc_quale_unique)
  subgoal G3 premises P for w x\<^sub>1 x\<^sub>2 y q\<^sub>1 q\<^sub>2 Q
    using P
    by (smt image_iff pre_particular_struct_morphism.morph_preserves_inherence_1
        pre_particular_struct_morphism.morph_reflects_inherence
        pre_particular_struct_morphism.morph_reflects_quale_assoc
        pre_particular_struct_morphism_axioms src.\<P>_I src.endurantI2
        src.quality_moment_unique_by_quality_space)
  subgoal G4
    by (meson morph_reflects_quale_assoc src.assoc_quale_scopeD(1) src.every_quality_space_is_used)
  subgoal G5
    using src.quale_determines_moment
    by (metis morph_preserves_inherence_1 tgt.quale_determines_moment)
  done

lemma \<^marker>\<open>tag (proof) aponly\<close> rtranclp_iff_tranclp: \<open>R\<^sup>*\<^sup>* x y \<longleftrightarrow> x = y \<or> (R\<^sup>+\<^sup>+ x y)\<close> for R x y
  apply auto
  by (meson rtranclpD)

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_ultimate_bearer:
  assumes \<open>x \<in> \<phi> ` src.\<P>\<close>
  shows \<open>img.ultimateBearer x = tgt.ultimateBearer x\<close>
  using assms
proof (induct x rule: wfP_induct[OF tgt.inherence_is_noetherian])
  fix x
  assume A: \<open>x \<in> \<phi> ` src.\<P>\<close>
     and B: \<open>\<forall>y. (\<triangleleft>\<^sub>t)\<inverse>\<inverse> y x \<longrightarrow> y \<in> \<phi> ` src.endurants \<longrightarrow> img.ultimateBearer y = tgt.ultimateBearer y\<close>
  have C: \<open>img.ultimateBearer y = tgt.ultimateBearer y\<close>
    if \<open>y \<in> \<phi> ` src.\<P>\<close> \<open>x \<triangleleft>\<^sub>t y\<close> for y using B that by blast
  have D: \<open>x \<in> tgt.\<P>\<close> using A by blast

  have \<open>\<phi> ` src.\<M> \<subseteq> tgt.\<M>\<close> by blast
  then have E[simp]: \<open>tgt.ultimateBearer x \<notin> \<phi> ` src.\<M>\<close>
    using tgt.ultimate_bearer_is_not_a_moment
    using D by blast

  have c_moment: \<open>img.ultimateBearer x = tgt.ultimateBearer x\<close> if as: \<open>x \<in> tgt.\<M>\<close>
  proof -
    obtain y where \<open>x \<triangleleft>\<^sub>t y\<close> using as by blast
    then have \<open>y \<in> \<phi> ` src.\<P>\<close> using A morph_does_not_add_bearers by blast
    then have AA: \<open>img.ultimateBearer y = tgt.ultimateBearer y\<close> using C \<open>x \<triangleleft>\<^sub>t y\<close> by blast
    then obtain BB: \<open>tgt.ultimateBearer y \<notin> img.\<M>\<close> \<open>(\<triangleleft>\<^sub>\<phi>)\<^sup>*\<^sup>* y (tgt.ultimateBearer y)\<close>
      using AA[simplified img.ultimate_bearer_eq_simp]
      by (metis \<open>y \<in> \<phi> ` src.endurants\<close> img.noetherian_inherence_axioms
              img.ultimate_bearer_is_not_a_moment
              morph_image_particulars noetherian_inherence.ultimate_bearer_eq_simp)
    have \<open>x \<triangleleft>\<^sub>\<phi> y\<close> using A \<open>y \<in> \<phi> ` src.\<P>\<close> \<open>x \<triangleleft>\<^sub>t y\<close> morph_image_inheres_in_I by blast
    then have CC: \<open>(\<triangleleft>\<^sub>\<phi>)\<^sup>*\<^sup>* x (tgt.ultimateBearer y)\<close>
      using BB(2) converse_rtranclp_into_rtranclp by metis
    have \<open>x \<noteq> y\<close> using \<open>x \<triangleleft>\<^sub>\<phi> y\<close> using img.inherence_irrefl by blast
    then have DD: \<open>(\<triangleleft>\<^sub>\<phi>)\<^sup>+\<^sup>+ x (tgt.ultimateBearer y)\<close> using CC
      by (metis \<open>x \<triangleleft>\<^sub>t y\<close> rtranclp_iff_tranclp tgt.inherence_scopeE tgt.ultimate_bearer_is_not_a_moment)
    then have EE: \<open>x \<noteq> tgt.ultimateBearer y\<close> using img.inherence_is_acyclic by blast
    have FF: \<open>img.ultimateBearer x = tgt.ultimateBearer y\<close>
      by (metis A AA CC \<open>y \<in> \<phi> ` src.endurants\<close> img.ultimate_bearer_eq_simp morph_image_particulars)
    obtain GG: \<open>tgt.ultimateBearer y \<notin> tgt.\<M>\<close> \<open>(\<triangleleft>\<^sub>t)\<^sup>*\<^sup>* y (tgt.ultimateBearer y)\<close>
      by (meson \<open>x \<triangleleft>\<^sub>t y\<close> tgt.endurantI2 tgt.ultimate_bearer_eq_simp tgt.ultimate_bearer_is_not_a_moment)
    have HH: \<open>(\<triangleleft>\<^sub>t)\<^sup>*\<^sup>* x (tgt.ultimateBearer y)\<close>
      using \<open>x \<triangleleft>\<^sub>t y\<close> converse_rtranclp_into_rtranclp GG(2) by metis
    then have II: \<open>tgt.ultimateBearer x = tgt.ultimateBearer y\<close>
      using D \<open>x \<triangleleft>\<^sub>t y\<close> tgt.ultimate_bearer_eq_simp by auto
    show ?thesis
      by (simp only: FF II)
  qed

  have c_substantial: \<open>img.ultimateBearer x = tgt.ultimateBearer x\<close> if as: \<open>x \<in> tgt.\<S>\<close>
  proof -
    have AA: \<open>x \<in> img.\<S>\<close> using as morph_image_substantials A
      by auto
    then obtain BB: \<open>x \<notin> img.\<M>\<close> \<open>x \<notin> tgt.\<M>\<close> using as by blast
    obtain CC: \<open>(\<triangleleft>\<^sub>\<phi>)\<^sup>*\<^sup>* x x\<close> \<open>(\<triangleleft>\<^sub>t)\<^sup>*\<^sup>* x x\<close> by blast
    have DD1: \<open>img.ultimateBearer x = x\<close>
        using AA img.ultimate_bearer_eq_simp by blast
      have DD2: \<open>tgt.ultimateBearer x = x\<close>
        by (simp add: D tgt.ultimate_bearer_eq_simp that)
    show ?thesis
      using DD1 DD2 by simp
  qed

  show \<open>img.ultimateBearer x = tgt.ultimateBearer x\<close>
    using D apply (cases x rule: tgt.endurant_cases)
    subgoal using c_substantial .
    using c_moment .
qed

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_directed_moments(*[simp]*): \<open>img.directed_moments = \<phi> ` src.directed_moments\<close>
  apply (simp only: towardness_sig.directed_moments_def morph_image_towards )
  apply auto
  subgoal G1 by blast
  by (meson inherence_base.endurantI1 morph_reflects_towardness src.inherence_base_axioms src.towardness_scopeE)

interpretation img: towardness \<open>\<W>\<^sub>\<phi>\<close> \<open>(\<triangleleft>\<^sub>\<phi>)\<close> \<open>(\<longlongrightarrow>\<^sub>\<phi>)\<close>
  apply (unfold_locales ; (simp only: morph_image_moments morph_image_towards
      morph_image_directed_moments)?)

  subgoal G1 for x y
    apply (intro conjI ; elim conjE )
    subgoal G1_1 by auto
    using morph_image_substantials by auto
  subgoal G2 for x y
    apply (auto simp: possible_worlds_sig.ed_def possible_worlds_sig.\<P>_def)
    using src.\<P>_I by auto
  subgoal G2 for x y using morph_image_ultimate_bearer by auto
  subgoal G3 for x y\<^sub>1 y\<^sub>2 using tgt.towardness_single by blast
  done

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_qualified_particulars(*[simp]*): \<open>img.qualifiedParticulars = \<phi> ` src.qualifiedParticulars\<close>
  apply (simp only: qualified_particulars_sig.qualifiedParticulars_def morph_image_assoc_quale)
  apply auto
  subgoal G1 by (metis imageI mem_Collect_eq morph_reflects_quale_assoc)
  subgoal G2 by (meson imageI src.assoc_quale_scopeD(1))
  using morph_reflects_quale_assoc src.assoc_quale_scopeD(1) by blast

interpretation img: ufo_particular_theory \<open>\<W>\<^sub>\<phi>\<close> \<open>(\<triangleleft>\<^sub>\<phi>)\<close> \<open>src.\<Q>\<S>\<close> \<open>(\<leadsto>\<^sub>\<phi>)\<close> \<open>(\<longlongrightarrow>\<^sub>\<phi>)\<close>
  apply (intro_locales)
  apply (unfold_locales ; simp only: morph_image_qualified_particulars morph_image_inheres_in
        ; intro notI ; elim conjE)
  using src.qualified_particulars_are_not_bearers
        tgt.qualified_particulars_are_not_bearers
  by (metis img.qOf_assoc_quale_I morph_image_assoc_quale morph_image_qualified_particulars tgt.qualifiedParticulars_iff)

interpretation img1: particular_struct \<open>MorphImg \<phi> \<Gamma>\<^sub>1\<close>
  supply A = img.ufo_particular_theory_axioms[simplified ufo_particular_theory_def]
  supply B = A[THEN conjunct1] A[THEN conjunct2,THEN conjunct2]
  apply (intro_locales ; (simp only: particular_struct_morphism_image_simps(1))?)
  subgoal using B(1)[simplified qualified_particulars_def] by metis
  using B(2)[simplified qualified_particulars_def] by metis

interpretation src_to_img1_morph: pre_particular_struct_morphism \<Gamma>\<^sub>1 \<open>MorphImg \<phi> \<Gamma>\<^sub>1\<close>
  by (unfold_locales
      ; (simp only: morph_image_particulars morph_image_inheres_in morph_image_towards morph_image_assoc_quale)?
      ; simp ; blast)

lemma \<^marker>\<open>tag (proof) aponly\<close> src_to_img1_world_corresp: \<open>src_to_img1_morph.world_corresp w\<^sub>s w\<^sub>t \<longleftrightarrow> w\<^sub>s \<in> src.\<W> \<and> w\<^sub>t = \<phi> ` w\<^sub>s\<close>
proof -
  (* generated by slegehammer *)
  have A: \<open>w\<^sub>s \<in> src.\<W> \<Longrightarrow> w\<^sub>t = \<phi> ` w\<^sub>s \<Longrightarrow> \<exists>w. \<phi> ` w\<^sub>s = w \<inter> \<phi> ` src.endurants \<and> w \<in> tgt.\<W>\<close>
  proof -
    assume a1: "w\<^sub>s \<in> src.\<W>"
    assume a2: "w\<^sub>t = \<phi> ` w\<^sub>s"
    then have "w\<^sub>t \<in> {P \<inter> \<phi> ` src.endurants |P. P \<in> tgt.\<W>}"
      using a1 by (metis (no_types) image_iff morph_image_worlds_src morph_image_worlds_tgt)
    then show ?thesis
      using a2 by fastforce
  qed

  (* generated by sledgehammer *)
  have B: \<open>\<And>x. w\<^sub>s \<in> src.\<W> \<Longrightarrow> w\<^sub>t = \<phi> ` w\<^sub>s \<Longrightarrow> x \<in> src.endurants \<Longrightarrow> \<phi> x \<in> \<phi> ` w\<^sub>s \<Longrightarrow> x \<in> w\<^sub>s\<close>
  proof -
    fix x :: 'p\<^sub>1
    assume a1: "x \<in> src.endurants"
    assume a2: "w\<^sub>s \<in> src.\<W>"
    assume a3: "\<phi> x \<in> \<phi> ` w\<^sub>s"
    obtain PP :: "'p\<^sub>1 set \<Rightarrow> 'p\<^sub>2 set" where
      "w\<^sub>s \<Leftrightarrow> PP w\<^sub>s"
      using a2 by (meson morph_worlds_correspond_src_tgt)
    then have "w\<^sub>s \<in> src.\<W> \<and> PP w\<^sub>s \<in> tgt.\<W> \<and> (\<forall>p. p \<notin> src.endurants \<or> (p \<in> w\<^sub>s) = (\<phi> p \<in> PP w\<^sub>s))"
      by blast
    then show "x \<in> w\<^sub>s"
      using a3 a1 by (metis imageE possible_worlds_sig.\<P>_I)
  qed

  show ?thesis
    apply (simp only: src_to_img1_morph.world_corresp_def morph_image_worlds_tgt ; simp)
    apply (intro iffI ; (elim conjE)? ; intro conjI ballI iffI ; (elim exE conjE)? ;
            (intro set_eqI iffI conjI)? ; simp?)
    subgoal G1    by blast
    subgoal G2    by blast
    subgoal G3 using A .
    using B .
qed

interpretation src_to_img1_morph: particular_struct_morphism \<Gamma>\<^sub>1 \<open>MorphImg \<phi> \<Gamma>\<^sub>1\<close> \<phi>
proof -
  (* generated by sledgehammer *)
  have A: \<open>\<exists>w. w\<^sub>t = w \<inter> \<phi> ` src.endurants \<and> w \<in> tgt.\<W> \<Longrightarrow> \<exists>w\<^sub>s. w\<^sub>s \<in> src.\<W> \<and> w\<^sub>t = \<phi> ` w\<^sub>s\<close> for w\<^sub>t
  proof -
    assume "\<exists>w. w\<^sub>t = w \<inter> \<phi> ` src.endurants \<and> w \<in> tgt.\<W>"
    then obtain PP :: "'p\<^sub>2 set" where
      f1: "w\<^sub>t = PP \<inter> \<phi> ` src.endurants \<and> PP \<in> tgt.\<W>"
      by blast
    have "PP \<inter> \<phi> ` src.endurants \<in> {P \<inter> \<phi> ` src.endurants |P. P \<in> tgt.\<W>} \<longrightarrow> (\<exists>P. PP \<inter> \<phi> ` src.endurants = \<phi> ` P \<and> P \<in> src.\<W>)"
      using morph_image_worlds_tgt by auto
    then show ?thesis
      using f1 by blast
  qed
  show \<open>particular_struct_morphism \<Gamma>\<^sub>1 (MorphImg \<phi> \<Gamma>\<^sub>1) \<phi>\<close>
    apply (unfold_locales
           ; (simp only: morph_image_worlds_tgt
                         morph_image_inheres_in
                         morph_image_assoc_quale
                         morph_image_qualified_particulars
                         src_to_img1_world_corresp)?
           ; simp?)
    using A .
qed

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_surjective[intro!,simp]: \<open>particular_struct_surjection \<Gamma>\<^sub>1 (MorphImg \<phi> \<Gamma>\<^sub>1) \<phi>\<close>
  by (unfold_locales ; simp only: morph_image_particulars)

lemma \<^marker>\<open>tag (proof) aponly\<close> morph_image_tgt_struct(*[simp]*): \<open>src_to_img1_morph.tgt.\<Gamma> = MorphImg \<phi> \<Gamma>\<^sub>1\<close>
  by (intro particular_struct_eqI
      ; simp add: ufo_particular_theory_sig.\<Gamma>_def)

lemmas morph_image_simps =
    morph_image_particulars
    morph_image_worlds_tgt
    morph_image_worlds_src
    morph_image_ed_tgt
    morph_image_indep_iff
    morph_image_inheres_in
    morph_image_trans_inheres_in
    morph_image_moments
    morph_image_assoc_quale
    morph_image_towards
    morph_image_substantials
    morph_image_ultimate_bearer
    morph_image_directed_moments
    morph_image_qualified_particulars
    src_to_img1_world_corresp
    morph_image_tgt_struct

lemmas morph_image_intros =
    morph_image_edI
    morph_image_indepI
    morph_image_inheres_in_I
    morph_image_assoc_quale_I
    morph_image_towards_I

lemmas morph_image_elims =
    morph_image_edE
    morph_image_indepE
    morph_image_inheres_in_E
    morph_image_assoc_quale_E
    morph_image_towards_E

lemmas morph_image_dests =
    morph_image_edD
    morph_image_indepD
    morph_image_inheres_in_D
    morph_image_assoc_quale_D
    morph_image_towards_D

end

end


theory Z_Machine
  imports Z_Operations "ITree_Simulation.ITree_Simulation" "Z_Toolkit.Z_Toolkit"
    "HOL-Library.Code_Target_Numeral" "Explorer.Explorer"
  keywords "zmachine" "zoperation" :: "thy_decl_block"
    and "over" "init" "invariant" "operations" "params" "pre" "update" "\<in>"
begin

named_theorems z_machine_defs

hide_const Map.dom
hide_const Map.ran

text \<open> An operation is constructed from a precondition, update, and postcondition, all of which
  are parameterised. \<close>

definition mk_zop :: "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 's subst) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('e, 's) htree)" where
"mk_zop P \<sigma> Q = (\<lambda> v. assume (P v) ;; assert (Q v) ;; \<langle>\<sigma> v\<rangle>\<^sub>a)"

text \<open> An operation requires that precondition holds, and that following the update the postcondition(s)
  also hold. \<close>

lemma wp_zop [wp, code_unfold]: "wp (mk_zop P \<sigma> Q v) b = [\<lambda> \<s>. P v \<s> \<and> Q v \<s> \<and> (\<sigma> v \<dagger> [\<lambda> \<s>. b \<s>]\<^sub>e) \<s>]\<^sub>e"
  by (simp add: mk_zop_def wp)

lemma wlp_zop [wp, code_unfold]: "wlp (mk_zop P \<sigma> Q v) b = [\<lambda> \<s>. P v \<s> \<longrightarrow> Q v \<s> \<longrightarrow> (\<sigma> v \<dagger> [\<lambda> \<s>. b \<s>]\<^sub>e) \<s>]\<^sub>e"
  by (simp add: mk_zop_def wp)

lemma itree_pre_zop [dpre]: "itree_pre (mk_zop P \<sigma> Q v) = [\<lambda> \<s>. P v \<s>]\<^sub>e"
  by (simp add: mk_zop_def dpre wp)

lemma itree_rel_zop [itree_rel]: "itree_rel (mk_zop P \<sigma> Q v) = {(x, z). P v x \<and> Q v x \<and> z = \<sigma> v x}"
  by (simp add: mk_zop_def itree_rel relcomp_unfold)

lemma mk_zop_state_sat: "\<lbrakk> P v s; Q v s \<rbrakk> \<Longrightarrow> mk_zop P \<sigma> Q v s = Ret (\<sigma> v s)"
  by (simp add: mk_zop_def seq_itree_def kleisli_comp_def assume_def test_def assigns_def)

text \<open> An operation can have its parameters supplied by an event, using the construct below. \<close>

abbreviation input_in_where_choice
  :: "('a \<Longrightarrow>\<^sub>\<triangle> 'e) \<Rightarrow> ('s \<Rightarrow> 'a set) \<Rightarrow> ('a \<Rightarrow> ('s \<Rightarrow> bool) \<times> ('e, 's) htree) \<Rightarrow> 's \<Rightarrow> 'e \<Zpfun> ('e, 's) itree" where
  "input_in_where_choice c A P \<equiv> (\<lambda> s. (\<lambda> e \<in> build\<^bsub>c\<^esub> ` A s | fst (P (the (match\<^bsub>c\<^esub> e))) s \<bullet> snd (P (the (match\<^bsub>c\<^esub> e))) s))"

(*
definition zop_event :: "('a \<Longrightarrow>\<^sub>\<triangle> 'e) \<Rightarrow> ('s \<Rightarrow> 'a set) \<Rightarrow> ('a \<Rightarrow> ('e, 's) htree) \<Rightarrow> 's \<Rightarrow> 'e \<Zpfun> ('e, 's) itree" where
[code_unfold]: "zop_event c A zop = input_in_where_choice c A (\<lambda> v. (pre (zop v), zop v))"
*)

definition zop_event :: "('a \<Longrightarrow>\<^sub>\<triangle> 'e) \<Rightarrow> ('s \<Rightarrow> 'a set) \<Rightarrow> ('a \<Rightarrow> ('e, 's) htree) \<Rightarrow> ('e, 's) htree" where
[code_unfold]: "zop_event c A zop = (\<lambda> s. Vis (prism_fun c (A s) (\<lambda> v. (pre (zop v) s, zop v s))))"

lemma hl_zop_event [hoare_safe]: "\<lbrakk> \<And> p. \<^bold>{P\<^bold>} zop p \<^bold>{Q\<^bold>} \<rbrakk> \<Longrightarrow> \<^bold>{P\<^bold>} zop_event c A zop \<^bold>{Q\<^bold>}"
  by (auto elim!: trace_to_VisE simp add: zop_event_def hoare_alt_def)
     (metis (no_types, lifting) IntE mem_Collect_eq pabs_apply pdom_pabs prism_fun_def snd_conv)

lemma zop_event_is_event_block:
  "\<lbrakk> wb_prism c \<rbrakk> \<Longrightarrow> zop_event c A (mk_zop P \<sigma> Q) = event_block c A (\<lambda> p. ([\<lambda> s. P p s \<and> Q p s]\<^sub>e, \<sigma> p))"
  by (auto intro: prism_fun_cong2 simp add: zop_event_def event_block_def wp usubst fun_eq_iff mk_zop_state_sat)

(*
lemma pdom_zop_event: "wb_prism c \<Longrightarrow> pdom (zop_event c A zop s) = {e. e \<in> build\<^bsub>c\<^esub> ` A s \<and> pre (zop (the (match\<^bsub>c\<^esub> e))) s}"
  by (simp add: zop_event_def dom_prism_fun, auto)
*)

text \<open> A machine has an initialisation and a list of operations. \<close>

lemma wp_Vis: "wp (\<lambda> s. Vis (F s)) P = (\<exists> e\<in>dom F. wp (\<lambda> s. F s e) P)\<^sub>e"
  apply (auto simp add: wp_itree_def itree_rel_defs fun_eq_iff)
  apply (metis imageE pran_pdom)
  apply (meson pfun_app_in_ran)
  done

lemma wlp_Vis: "wlp (\<lambda> s. Vis (F s)) P = (\<forall> e\<in>dom F. wlp (\<lambda> s. F s e) P)\<^sub>e"
  apply (auto simp add: wlp_itree_def itree_rel_defs fun_eq_iff)
  apply (meson pfun_app_in_ran)
  apply (metis imageE pran_pdom)
  done

definition z_machine_main :: "(('e, 's) htree) list \<Rightarrow> ('e, 's) htree" where
"z_machine_main Ops = foldr (\<box>) Ops Stop"

definition z_machine :: "('s::default) subst \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> (('e, 's) htree) list \<Rightarrow> 'e process" where
[code_unfold]: "z_machine Init Inv Ops = process Init (loop (z_machine_main Ops))"

(*
definition z_machine :: "('s::default) subst \<Rightarrow> ('e, 's) htree list \<Rightarrow> 'e process" where
[code_unfold]: "z_machine Init Ops = process Init (loop (foldr (\<box>) Ops Stop))"
*)

lemma deadlock_free_z_machine:
  fixes Inv :: "'s::default \<Rightarrow> bool"
  assumes
    "Init establishes Inv"
    "\<And> E. E\<in>set Events \<Longrightarrow> E preserves Inv"
    "`Inv \<longrightarrow> dfp (foldr (\<box>) Events Stop)`"
  shows "deadlock_free (z_machine Init Inv Events)"
proof (simp add: z_machine_def z_machine_main_def, rule deadlock_free_processI, rule deadlock_free_init_loop[where P="Inv"], rule assms(1), simp_all)
  from assms(2) show "\<^bold>{Inv\<^bold>} foldr (\<box>) Events Stop \<^bold>{Inv\<^bold>}"
  proof (induct Events)
    case Nil
    then show ?case by (simp, metis SEXP_def hl_Stop)
  next
    case (Cons Ev Events)
    then show ?case
      by (metis foldr.simps(2) hl_choice list.set_intros(1) list.set_intros(2) o_apply)
  qed
  show "`Inv \<longrightarrow> dfp (foldr (\<box>) Events Stop)`"
    using assms(3) by auto
qed

method deadlock_free_invs uses invs =
  ((simp add: z_machine_defs)?
  ,rule deadlock_free_z_machine
  ,(zpog_full; auto)[1]
  ,(auto intro!: hl_zop_event hoare_lemmas invs)[1])

method deadlock_free uses invs =
  (deadlock_free_invs invs: invs,
   (simp add: zop_event_is_event_block extchoice_event_block z_defs z_locale_defs wp Bex_Sum_iff;
    expr_simp add: split_sum_all split_sum_ex;
    ((rule conjI allI impI | erule conjE disjE exE)+; rename_alpha_vars?)?))

ML_file \<open>Z_Machine.ML\<close>

ML \<open>
Outer_Syntax.command @{command_keyword zmachine} "define a Z machine"
    (Z_Machine.parse_zmachine >> (Toplevel.local_theory NONE NONE o Z_Machine.zmachine_sem));

Outer_Syntax.command @{command_keyword zoperation} "define a Z operation"
    (Z_Machine.parse_operation >> (Toplevel.local_theory NONE NONE o Z_Machine.mk_zop));
\<close>

code_datatype pfun_of_alist pfun_of_map pfun_of_pinj pfun_entries

setup \<open> Explorer_Lib.switch_to_quotes \<close>

lit_vars

text \<open> Change the default target of string syntax to be literals. Literals are much better for
  code generation, and also provide more control since they are a distinct type to lists.
  We also replace the @{typ string} type name with @{typ "String.literal"}.
 \<close>

bundle literal_syntax
begin

no_syntax
  "_String" :: "str_position \<Rightarrow> string"    ("_")

syntax
  "_Literal" :: "str_position \<Rightarrow> String.literal"   ("_")

end

hide_type (open) string

type_synonym string = "String.literal"

unbundle literal_syntax

text \<open> The next line allows us to create lists of characters from literals by coercion. \<close>

declare [[coercion String.explode]]

unbundle Expression_Syntax

end


theory Proofs_3
  imports Requirements ExtraInv VCTheoryLemmas
begin

definition pred3 where "pred3 s1 s2 s s5 \<equiv>
substate s1 s2 \<and>
    substate s2 s \<and>
    toEnvP s1 \<and>
    toEnvP s2 \<and>
    toEnvNum s1 s2 = 1 \<and> DELAY'TIMEOUT = toEnvNum s2 s \<and> getVarBool s1 rotation = True \<and> \<not> getVarBool s2 user \<and>
(\<forall> s4. toEnvP s4 \<and> substate s2 s4 \<and> substate s4 s5 \<and> s4 \<noteq> s5 \<longrightarrow> getVarBool s4 rotation = True \<and> \<not> getVarBool s4 user)
 \<longrightarrow>
    (\<exists>s4. toEnvP s4 \<and>
          substate s5 s4 \<and>
          substate s4 s \<and>
          toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
          (getVarBool s4 rotation = False \<or> getVarBool s4 user) \<and>
          (\<forall>s3. toEnvP s3 \<and> substate s5 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow> getVarBool s3 rotation = True \<and> \<not> getVarBool s3 user))"

thm extraInv_def
lemma rotating_not_vc3: "toEnvP s1 \<and> substate s1 s \<and> getPstate s1 Controller = Controller'rotating \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 ERROR = Controller'rotating \<longrightarrow>
      (\<exists>s2 s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = ERROR \<and>
          toEnvNum s2 s1 = ltime s1 ERROR \<and>
          ((getPstate s2 ERROR = Controller'motionless \<or> getPstate s2 ERROR = Controller'rotating) \<and>
           getVarBool s3 user \<or>
           getPstate s2 ERROR = Controller'suspended) \<and>
          \<not> getVarBool s3 pressure)) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 ERROR = Controller'motionless \<longrightarrow>
      getVarBool s1 rotation = False \<and> getVarBool s1 brake = False) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 ERROR = Controller'rotating \<longrightarrow>
      getVarBool s1 rotation = True \<and> getVarBool s1 brake = False) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s \<and> getPstate s1 ERROR = Controller'suspended \<longrightarrow>
      getVarBool s1 rotation = False \<and> getVarBool s1 brake = True) \<Longrightarrow>
(\<exists> s2 s3. toEnvP s2 \<and> toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s1 \<and> toEnvNum s2 s1 \<le> ltime s1 Controller \<and> toEnvNum s2 s3 = 1 \<and>
 (getVarBool s2 rotation = False \<or> getVarBool s3 user))
"
  by (metis eq_imp_le substate_trans)

definition inv3 where "inv3 s \<equiv> R3 s \<and> extraInv s"

theorem proof_3_1: "VC1 inv3 s0"
  apply(simp only: VC1_def inv3_def R3_def extraInv_def)
  by  auto

theorem proof_3_5: "VC5 inv3 env  s0 user_value pressure_value"
  apply(simp only: VC5_def inv3_def R3_def extraInv_def)
  by  auto

theorem proof_3_7: "VC7 inv3 env  s0 user_value pressure_value"
  apply(simp only: VC7_def inv3_def R3_def extraInv_def)
  by  auto

theorem proof_3_11: "VC11 inv3 env  s0 user_value pressure_value"
  apply(simp only: VC11_def inv3_def R3_def extraInv_def)
  by  auto
end


theory "EWD-urn"
  imports "./TLA-Utils"
begin

locale Urn =
  fixes initialBlackBallCount initialWhiteBallCount :: nat
  assumes nonempty: "0 < initialBlackBallCount + initialWhiteBallCount"
  fixes blackBallCount whiteBallCount :: "nat stfun"
  assumes bv: "basevars (blackBallCount, whiteBallCount)"
  fixes Initial :: stpred
  defines "Initial \<equiv> PRED blackBallCount = #initialBlackBallCount \<and> whiteBallCount = #initialWhiteBallCount"
  fixes DrawTwoBlack :: action
  defines "DrawTwoBlack \<equiv> ACT #2 \<le> $blackBallCount \<and> blackBallCount$ = $blackBallCount - #1 \<and> unchanged whiteBallCount"
  fixes DrawTwoWhite :: action
  defines "DrawTwoWhite \<equiv> ACT #2 \<le> $whiteBallCount \<and> whiteBallCount$ = $whiteBallCount - #2 \<and> blackBallCount$ = $blackBallCount + #1"
  fixes DrawOneOfEach :: action
  defines "DrawOneOfEach \<equiv> ACT #1 \<le> $whiteBallCount \<and> #1 \<le> $blackBallCount \<and> blackBallCount$ = $blackBallCount - #1 \<and> unchanged whiteBallCount"
  fixes Next :: action
  defines "Next \<equiv> ACT (DrawTwoBlack \<or> DrawTwoWhite \<or> DrawOneOfEach)"
  fixes Fair :: temporal
  defines "Fair \<equiv> TEMP WF(Next)_(blackBallCount, whiteBallCount)"
  fixes Spec :: temporal
  defines "Spec \<equiv> TEMP (Init Initial \<and> \<box>[Next]_(blackBallCount, whiteBallCount) \<and> Fair)"
  fixes Invariant :: stpred
  defines "Invariant \<equiv> PRED (even<whiteBallCount> = #(even initialWhiteBallCount) \<and> #1 \<le> whiteBallCount + blackBallCount)"

context Urn
begin

lemma invariant: "\<turnstile> Spec \<longrightarrow> \<box>Invariant"
proof invariant
  fix sigma
  assume "sigma \<Turnstile> Spec"
  hence initial: "sigma \<Turnstile> Init Initial" and step: "sigma \<Turnstile> \<box>[Next]_(blackBallCount, whiteBallCount)"
    unfolding Spec_def by auto

  from initial nonempty show "sigma \<Turnstile> Init Invariant"
    by (auto simp add: Init_def Initial_def Invariant_def)

  from step
  show "sigma \<Turnstile> stable Invariant"
    by (intro Stable, auto simp add: Invariant_def square_def Next_def DrawTwoBlack_def DrawTwoWhite_def DrawOneOfEach_def)
qed

lemma terminates: "\<turnstile> Spec \<longrightarrow> \<diamond>\<box>(blackBallCount + whiteBallCount = #1)"
proof (intro stable_dmd_stuck)

  have "\<turnstile> Spec \<longrightarrow> \<box>[Next]_(blackBallCount, whiteBallCount)"
    by (auto simp add: Spec_def)
  also have "\<turnstile> \<box>[Next]_(blackBallCount, whiteBallCount) \<longrightarrow> stable (blackBallCount + whiteBallCount = #1)"
    by (intro StableT, auto simp add: Next_def square_def DrawTwoBlack_def DrawTwoWhite_def DrawOneOfEach_def)
  finally show "\<turnstile> Spec \<longrightarrow> stable (blackBallCount + whiteBallCount = #1)".

  from nonempty
  have "\<turnstile> Spec \<longrightarrow> \<diamond>(\<exists> n. blackBallCount + whiteBallCount = #n \<and> #1 \<le> #n)"
    by (intro imp_eventually_init, auto simp add: Spec_def Init_def Initial_def)

  also have "\<turnstile> Spec \<longrightarrow> ((\<exists> n. blackBallCount + whiteBallCount = #n \<and> #1 \<le> #n) \<leadsto> blackBallCount + whiteBallCount = #1)"
  proof (intro wf_imp_ex_leadsto [OF wf_less])
    fix n
    show "\<turnstile> Spec \<longrightarrow> (blackBallCount + whiteBallCount = #n \<and> #1 \<le> #n
                    \<leadsto> blackBallCount + whiteBallCount = #1
                        \<or> (\<exists>n'. #((n', n) \<in> {(n', n). n' < n}) \<and> blackBallCount + whiteBallCount = #n' \<and> #1 \<le> #n'))"
    proof (cases "n \<le> 1")
      case True
      thus ?thesis by (intro imp_imp_leadsto, auto)
    next
      case False
      then obtain n' where n_Suc: "n = Suc n'" "1 \<le> n'" by (cases n, auto)

      have next_angle_eq[simp]: "(ACT <Next>_(blackBallCount, whiteBallCount)) = (ACT Next)"
        by (intro ext, auto simp add: angle_def Next_def DrawTwoBlack_def DrawTwoWhite_def DrawOneOfEach_def)

      from basevars [OF bv]
      have enabled_simp[simp]: "(PRED (Enabled Next)) = (PRED (#2 \<le> blackBallCount + whiteBallCount))"
        apply (intro ext, auto simp add: enabled_def angle_def Next_def DrawTwoBlack_def DrawTwoWhite_def DrawOneOfEach_def)
        by (metis add.left_neutral add.right_neutral diff_is_0_eq le_add_diff_inverse not_less_eq_eq zero_le)

      have "\<turnstile> Spec \<longrightarrow> \<box>[Next]_(blackBallCount, whiteBallCount) \<and> WF(Next)_(blackBallCount, whiteBallCount)"
        by (auto simp add: Spec_def Fair_def)
      also from n_Suc
      have "\<turnstile> \<box>[Next]_(blackBallCount, whiteBallCount) \<and> WF(Next)_(blackBallCount, whiteBallCount)
                  \<longrightarrow> (blackBallCount + whiteBallCount = #(Suc n') \<and> #1 \<le> #n \<leadsto> blackBallCount + whiteBallCount = #n')"
        by (intro WF1, auto, auto simp add: Next_def square_def DrawTwoBlack_def DrawTwoWhite_def DrawOneOfEach_def angle_def)
      finally have "\<turnstile> Spec \<longrightarrow> (blackBallCount + whiteBallCount = #n \<and> #1 \<le> #n \<leadsto> blackBallCount + whiteBallCount = #n')"
        by (simp add: n_Suc)
      also from n_Suc
      have "\<turnstile> Spec \<longrightarrow> (blackBallCount + whiteBallCount = #n'
        \<leadsto> blackBallCount + whiteBallCount = #1 \<or> (\<exists>n'. #((n', n) \<in> {(n', n). n' < n}) \<and> blackBallCount + whiteBallCount = #n' \<and> #1 \<le> #n'))"
        by (intro imp_imp_leadsto, auto)
      finally show "\<turnstile> Spec \<longrightarrow> (blackBallCount + whiteBallCount = #n \<and>
              #1 \<le> #n \<leadsto> blackBallCount + whiteBallCount = #1 \<or> (\<exists>n'. #((n', n) \<in> {(n', n). n' < n}) \<and> blackBallCount + whiteBallCount = #n' \<and> #1 \<le> #n'))" .
    qed
  qed

  finally show "\<turnstile> Spec \<longrightarrow> \<diamond>(blackBallCount + whiteBallCount = #1)".
qed

lemma
  shows "\<turnstile> Spec \<longrightarrow> \<diamond>\<box>((blackBallCount, whiteBallCount) = #(if even initialWhiteBallCount then (1,0) else (0,1)))"
proof (intro stable_dmd_stuck)
  have "\<turnstile> Spec \<longrightarrow> \<box>[Next]_(blackBallCount, whiteBallCount)"
    by (auto simp add: Spec_def)
  also have "\<turnstile> \<box>[Next]_(blackBallCount, whiteBallCount) \<longrightarrow> stable ((blackBallCount, whiteBallCount) = #(if even initialWhiteBallCount then (1,0) else (0,1)))"
    by (intro StableT, auto simp add: Next_def square_def DrawTwoBlack_def DrawTwoWhite_def DrawOneOfEach_def)
  finally show "\<turnstile> Spec \<longrightarrow> stable ((blackBallCount, whiteBallCount) = #(if even initialWhiteBallCount then (1,0) else (0,1)))".

  have "\<turnstile> Spec \<longrightarrow> \<diamond>(even<whiteBallCount> = #(even initialWhiteBallCount) \<and> blackBallCount + whiteBallCount = #1)"
  proof (intro imp_dmd_conj_invariant terminates imp_eventually_forever_implies_infinitely_often imp_infinitely_often_implies_eventually)
    from invariant
    show "\<turnstile> Spec \<longrightarrow> \<box>(even<whiteBallCount> = #(even initialWhiteBallCount))" by (auto simp add: Invariant_def)
  qed
  also have "\<turnstile> \<diamond>(even<whiteBallCount> = #(even initialWhiteBallCount) \<and> blackBallCount + whiteBallCount = #1)
            \<longrightarrow> \<diamond>((blackBallCount, whiteBallCount) = #(if even initialWhiteBallCount then (1,0) else (0,1)))"
    by (intro DmdImpl, auto, presburger+)
  finally show "\<turnstile> Spec \<longrightarrow> \<diamond>(blackBallCount, whiteBallCount) = #(if even initialWhiteBallCount then (1, 0) else (0, 1))".
qed

end

end


theory Gensyn_Facts imports Gensyn Gensyn_Descend
begin

(* Lemmas about gensyn syntax
 * TODO there is probably some overlap between this and Gensyn_Descend_Facts *)

lemma gensyn_get_list_child :
  assumes H : "gensyn_get_list l [n] = Some t"
  shows "l ! n = t" using H
proof(induction l arbitrary: n t)
  case Nil
  then show ?case by auto
next
  case (Cons lh lt)
  then show ?case
  proof(cases n)
    case 0
    then show ?thesis using Cons by auto
  next
    case (Suc n')
    then show ?thesis using Cons by(auto)
  qed
qed

lemma gensyn_get_list_child_length :
  assumes H : "gensyn_get_list l [n] = Some t"
  shows "n < length l" using H
proof(induction l arbitrary: n)
  case Nil
  then show ?case by auto
next
  case (Cons lh lt)
  then show ?case
  proof(cases n)
    case 0
    then show ?thesis using Cons by auto
  next
    case (Suc n')
    then show ?thesis using Cons by(auto)
  qed
qed

lemma gensyn_get_list_child' :
  assumes H : "l ! n = t"
  assumes Hl : "n < length l"
  shows "gensyn_get_list l [n] = Some t" using H Hl
proof(induction l arbitrary: n t)
  case Nil
  then show ?case by(auto)
next
  case (Cons lh lt)
  then show ?case
  proof(cases n)
    case 0
    then show ?thesis using Cons by auto
  next
    case (Suc n')
    then show ?thesis using Cons by(auto)
  qed
qed

lemma gensyn_get_list_child_None :
  assumes H : "gensyn_get_list l [n] = None"
  shows "length l \<le> n" using H
proof(induction l arbitrary: n)
  case Nil
  then show ?case by auto
next
  case (Cons lh lt)
  then show ?case
  proof(cases n)
    case 0
    then show ?thesis using Cons by auto
  next
    case (Suc n')
    then show ?thesis using Cons by(auto)
  qed
qed

lemma gensyn_get_list_child_None' :
  assumes Hl : "length l \<le> n"
  shows "gensyn_get_list l [n] = None" using Hl
proof(induction l arbitrary: n)
  case Nil
  then show ?case by(auto)
next
  case (Cons lh lt)
  then show ?case
  proof(cases n)
    case 0
    then show ?thesis using Cons by auto
  next
    case (Suc n')
    then show ?thesis using Cons by(auto)
  qed
qed

lemma gensyn_get_list_comp :
  assumes H1 : "gensyn_get_list l1 cp1 = Some (G x1 l2)"
  assumes H2 : "gensyn_get_list l2 cp2 = Some t3"
  shows "gensyn_get_list l1 (cp1@cp2) = Some t3" using assms
proof(induction l1 arbitrary: cp1 x1 l2 cp2 t3 rule: gensyn_induct')
  case (1 x l)
  then show ?case
  proof(cases cp1)
    case Nil
    then show ?thesis using 1 by auto
  next
    case (Cons cp1h cp1t)
    then show ?thesis using 1
    proof(cases cp1h)
      case 0
      show ?thesis
      proof(cases cp1t)
        case Nil' : Nil
        then show ?thesis using 1 Cons 0
        proof(cases cp2)
          case Nil'' : Nil
          then show ?thesis using 1 Cons 0 Nil'
            by(cases l2; auto)
        next
          case Cons'' : (Cons cp2h cp3t)
          then show ?thesis using 1 Cons 0 Nil'
            by(auto)
        qed
      next
        case Cons' : (Cons cp1th cp1tt)
        then show ?thesis using "1.prems" "1.IH"[of cp1t] Cons 0
          by(auto)
      qed
    next
      case (Suc nat)
      then show ?thesis using 1 Cons
        by(auto)
    qed
  qed
next
  case 2
  then show ?case by auto
next
  case (3 t l)
  then show ?case
  proof(cases cp1)
    case Nil
    then show ?thesis using 3 by auto
  next
    case (Cons cp1h cp1t)
    then show ?thesis
    proof(cases cp1h)
      case 0
      show ?thesis
      proof(cases cp1t)
        case Nil' : Nil
        then show ?thesis using 3 Cons 0
        proof(cases cp2)
          case Nil'' : Nil
          then show ?thesis using 3 Cons 0 Nil'
            by(cases l2; auto)
        next
          case Cons'' : (Cons cp2h cp3t)
          then show ?thesis using 3 Cons 0 Nil'
            by(auto)
        qed
      next
        case Cons' : (Cons cp1th cp1tt)

        obtain tx tl where T : "t = G tx tl" by(cases t; auto)

        then show ?thesis using "3.prems" "3.IH"(1)[of "cp1"] Cons 0 Cons'
          by(auto)
      qed
    next
      case (Suc cp1h')
      then show ?thesis using "3.prems" "3.IH"(2)[of "cp1h'#cp1t"] Cons
        by(auto)
    qed
  qed
qed

lemma gensyn_get_comp :
  assumes H1 : "gensyn_get t1 cp1 = Some t2"
  assumes H2 : "gensyn_get t2 cp2 = Some t3"
  shows "gensyn_get t1 (cp1@cp2) = Some t3" using assms
proof(cases cp1)
  case Nil
  then show ?thesis using H1 H2 by auto
next
  case (Cons cp1h cp1t)

  show ?thesis
  proof(cases cp2)
    case Nil' : Nil

    then show ?thesis using H1 H2 by auto
  next
    case Cons' : (Cons cp2h cp2t)

    obtain x1 l1 where T1 : "t1 = G x1 l1"
      by(cases t1; auto)

    obtain x2 l2 where T2 : "t2 = G x2 l2"
      by(cases t2; auto)

    have H1' : "gensyn_get_list l1 cp1 = Some (G x2 l2)"
      using T1 T2 H1 Cons
      by(auto)

    have H2' : "gensyn_get_list l2 cp2 = Some t3"
      using T2 H2 Cons'
      by(auto)

    show ?thesis using gensyn_get_list_comp[OF H1' H2'] Cons T1
      by(auto)
  qed
qed

lemma gensyn_get_list_comp_None :
  assumes H1 : "gensyn_get_list l1 cp1 = Some (G x1 l2)"
  assumes H2 : "gensyn_get_list l2 (cph2#cpt2) = None"
  shows "gensyn_get_list l1 (cp1@cph2#cpt2) = None" using assms
proof(induction l1 arbitrary: cp1 x1 l2 cph2 cpt2 rule: gensyn_induct')
  case (1 x l)
  then show ?case
  proof(cases cp1)
    case Nil
    then show ?thesis using 1 by auto
  next
    case (Cons cp1h cp1t)
    then show ?thesis using 1
    proof(cases cp1h)
      case 0
      show ?thesis
      proof(cases cp1t)
        case Nil' : Nil
        then show ?thesis using 1 Cons 0 by(auto)
      next
        case Cons' : (Cons cp1th cp1tt)
        then show ?thesis using "1.prems" "1.IH"[of cp1t] Cons 0
          by(auto)
      qed
    next
      case (Suc nat)
      then show ?thesis using 1 Cons
        by(auto)
    qed
  qed
next
  case 2
  then show ?case by auto
next
  case (3 t l)
  then show ?case
  proof(cases cp1)
    case Nil
    then show ?thesis using 3 by auto
  next
    case (Cons cp1h cp1t)
    then show ?thesis
    proof(cases cp1h)
      case 0
      show ?thesis
      proof(cases cp1t)
        case Nil' : Nil
        then show ?thesis using 3 Cons 0 by auto
      next
        case Cons' : (Cons cp1th cp1tt)

        obtain tx tl where T : "t = G tx tl" by(cases t; auto)

        then show ?thesis using "3.prems" "3.IH"(1)[of "cp1"] Cons 0 Cons'
          by(auto)
      qed
    next
      case (Suc cp1h')
      then show ?thesis using "3.prems" "3.IH"(2)[of "cp1h'#cp1t"] Cons
        by(auto)
    qed
  qed
qed

lemma gensyn_get_comp_None :
  assumes H1 : "gensyn_get t1 cp1 = Some t2"
  assumes H2 : "gensyn_get t2 cp2 = None"
  shows "gensyn_get t1 (cp1@cp2) = None" using assms
proof(cases cp1)
  case Nil
  then show ?thesis using H1 H2 by auto
next
  case (Cons cp1h cp1t)

  obtain x1 l1 where T1 : "t1 = G x1 l1"
    by(cases t1; auto)

  obtain x2 l2 where T2 : "t2 = G x2 l2"
    by(cases t2; auto)

  have H1' : "gensyn_get_list l1 cp1 = Some (G x2 l2)"
    using T1 T2 H1 Cons
    by(auto)

  show ?thesis
  proof(cases cp2)
    case Nil' : Nil
    then show ?thesis using Cons H2 by auto
  next
    case Cons' : (Cons cph2 cpt2)

    have H2' : "gensyn_get_list l2 (cph2#cpt2) = None"
      using T2 H2 Cons'
      by(auto)

    show ?thesis using gensyn_get_list_comp_None[OF H1' H2'] Cons T1 Cons'
      by(auto)
  qed
qed

lemma gensyn_get_list_nonnil :
  assumes H : "gensyn_get_list l cp = Some t"
  shows "cp \<noteq> []" using H
  by(cases cp; cases l; auto)

lemma gensyn_get_list_split :
  assumes H1 : "gensyn_get_list l1 (cph1#cpt1@cph2#cpt2) = Some t3"
  shows "\<exists> x2 l2 . gensyn_get_list l1 (cph1#cpt1) = Some (G x2 l2) \<and>
                gensyn_get_list l2 (cph2#cpt2) = Some t3" using assms
proof(induction l1 arbitrary: cph1 cpt1 cph2 cpt2 t3 rule: gensyn_induct')
  case (1 x l)
  then show ?case
  proof(cases cph1)
    case 0
    show ?thesis
    proof(cases cpt1)
      case Nil
      then show ?thesis using 1 Cons 0 by(auto)
    next
      case (Cons cp1th cp1tt)
      then show ?thesis using "1.prems" "1.IH" 0
        by(auto)
    qed
  next
    case (Suc nat)
    then show ?thesis using 1 Cons
      by(auto)
  qed
next
  case 2
  then show ?case by auto
next
  case (3 t l)
  then show ?case
  proof(cases cph1)
    case 0

    obtain tx tl where T : "t = G tx tl" by(cases t; auto)

    show ?thesis
    proof(cases cpt1)
      case Nil : Nil
      then show ?thesis using 3 0 T by(auto)
    next
      case Cons : (Cons cp1th cp1tt)

      then show ?thesis using "3.prems" "3.IH"(1)[of cph1 "cp1th#cp1tt"] Cons 0 T
        by(auto)
    qed
  next
    case (Suc cp1h')
    then show ?thesis using "3.prems" "3.IH"(2)[of "cp1h'" cpt1 cph2 cpt2] Cons
      by(auto)
  qed
qed

lemma gensyn_get_split :
  assumes H1 : "gensyn_get t1 (cp1@cp2) = Some t3"
  shows "\<exists> t2 . gensyn_get t1 (cp1) = Some t2 \<and>
                gensyn_get t2 (cp2) = Some t3" using assms
proof(cases cp1)
  case Nil

  have Desc1 : "gensyn_get t1 cp1 = Some t1" using Nil by auto

  have Desc2 : "gensyn_get t1 cp2 = Some t3" using Nil H1
    by auto

  then show ?thesis using Desc1 Desc2 by blast
next
  case (Cons cph1 cpt1)
  then show ?thesis

  proof(cases cp2)
    case Nil' : Nil

    have Desc1 : "gensyn_get t1 cp1 = Some t3" using Nil' H1 by auto

    have Desc2 : "gensyn_get t3 cp2 = Some t3" using Nil'
      by auto

    then show ?thesis using Desc1 Desc2 by blast
  next
    case Cons' : (Cons cph2 cpt2)

    obtain xt lt where T1 : "t1 = G xt lt" by(cases t1; auto)

    then show ?thesis using gensyn_get_list_split[of lt cph1 cpt1 cph2 cpt2 t3]
      H1 Cons Cons' T1
      by(auto)
  qed
qed

lemma gensyn_get_list_split_None :
  assumes H1 : "gensyn_get_list l1 (cp1 @ (cph2#cpt2)) = None"
  assumes H2 : "gensyn_get_list l1 cp1 = Some (G x2 l2)"
  shows "gensyn_get_list l2 (cph2#cpt2) = None"  using H1 H2
proof(induction l1 arbitrary:  cp1 cph2 cpt2 x2 l2 rule: gensyn_induct')
  case (1 x l)
  then show ?case
  proof(cases cp1)
    case Nil
    then show ?thesis using 1 by auto
  next
    case (Cons cph1 cpt1)

    then show ?thesis
    proof(cases cph1)

      case 0
      show ?thesis

      proof(cases cpt1)
        case Nil' : Nil
        then show ?thesis using 1 Cons 0 by(auto)
      next
        case Cons' : (Cons cpt1h cpt1t)
        then show ?thesis using "1.prems" "1.IH"[of "cpt1h # cpt1t"] Cons 0
          by(auto)
      qed
    next
      case (Suc nat)
      then show ?thesis using 1 Cons
        by(auto)
    qed
  qed
next
  case 2
  then show ?case by auto
next
  case (3 t l)
  then show ?case

  proof(cases cp1)
    case Nil
    then show ?thesis using 3 by auto
  next
    case (Cons cph1 cpt1)
    then show ?thesis

    proof(cases cph1)
      case 0

      obtain tx tl where T : "t = G tx tl" by(cases t; auto)

      show ?thesis
      proof(cases cpt1)
        case Nil : Nil
        then show ?thesis using 3 0 Cons T by(auto)
      next
        case Cons' : (Cons cpt1h cpt1t)

        then show ?thesis using "3.prems" "3.IH"(1)[of "0#cpt1h#cpt1t" cph2 cpt2] Cons 0 T
          by(auto)
      qed
    next
      case (Suc cp1h')
      then show ?thesis using "3.prems" "3.IH"(2)[of "cp1h'#cpt1" cph2 cpt2] Cons
        by(auto)
    qed
  qed
qed

lemma gensyn_get_split_None :
  assumes H1 : "gensyn_get t1 (cp1 @ cp2) = None"
  assumes H2 : "gensyn_get t1 cp1 = Some t2"
  shows "gensyn_get t2 cp2 = None"  using H1 H2
proof(cases cp2)
  case Nil
  then show ?thesis using H1 H2 by auto
next
  case (Cons cph2 cpt2)

  obtain tx1 tl1 where T1 : "t1 = G tx1 tl1" by(cases t1; auto)
  obtain tx2 tl2 where T2 : "t2 = G tx2 tl2" by(cases t2; auto)

  then show ?thesis
    using gensyn_get_list_split_None[of tl1 cp1 cph2 cpt2] H1 H2 Cons T1 T2
    by(cases cp1; auto)
qed

lemma gensyn_descend_correct1 :
  assumes H : "gensyn_descend t t' cp"
  shows "gensyn_get t cp = Some t'" using H
proof(induction rule: gensyn_descend.induct)
  case (1 c ls t x)
  show ?case
  proof(cases ls)
    case Nil
    then show ?thesis using 1 by auto
  next
    case (Cons lh lt)
    then show ?thesis using 1 gensyn_get_list_child'[of "ls" c]
      by(auto)
  qed
next
  case (2 t t' l t'' l')

  obtain t'x t'l where T' : "t' = G t'x t'l" by(cases t'; auto)

  then show ?case using 2 gensyn_get_comp[of t l t' l' t'']
    by(auto)
qed

lemma gensyn_descend_nonnil :
  assumes H : "gensyn_descend t t' cp"
  shows "cp \<noteq> []" using H
proof(induction rule: gensyn_descend.induct)
  case (1 c ls t x)
  then show ?case by auto
next
  case (2 t t' l t'' l')
  then show ?case by auto
qed

lemma gensyn_descend_nonempty :
  assumes H : "gensyn_descend t t' cp"
  assumes H' : "t = G xt lt"
  shows "lt \<noteq> []" using assms
proof(induction arbitrary: t' cp xt lt rule: gensyn_descend.induct)
  case (1 c ls t x)
  then show ?case by(cases lt; auto)
next
  case (2 tc tc' lc tc'' lc')
  show ?case using "2.IH"[of xt lt] "2.prems"
    by auto
qed

lemma gensyn_descend_child_zero :
  assumes H : "gensyn_descend t t' cp"
  assumes Hcp : "cp = 0#cp'"
  assumes Ht : "t = (G xr l1)"
  assumes Hl1 : "l1 = [z]"
  shows "gensyn_descend (G xr' (z#l)) t' cp" using assms
proof(induction arbitrary: xr xr' z cp' l1  l rule: gensyn_descend.induct)
  case (1 cc lsc tc xc)
  then show ?case
    by(auto intro: gensyn_descend.intros)
next
  case (2 tc tc' lc tc'' lc')

  obtain lch lct where Lc : "lc = lch#lct"
    using 2 gensyn_descend_nonnil[of tc tc' lc]
    by(cases lc; auto)

  have Lch : "lch = 0" using 2 Lc by auto

  have Desc1 : "gensyn_descend (G xr' (z # l)) tc' lc"
    using "2.IH"(1)[of lct xr l1 z] "2.prems" Lc Lch
    by(auto)

  show ?case using gensyn_descend.intros(2)[OF Desc1 "2.hyps"(2)] by auto
qed

lemma gensyn_descend_child_suc :
  assumes H : "gensyn_descend t t' cp"
  assumes Hcp : "cp = n#cp'"
  assumes Ht : "t = (G xr l1)"
  shows "gensyn_descend (G xr' (z#l1)) t' (Suc n # cp')" using assms
proof(induction arbitrary: xr xr' n z cp' l1 rule: gensyn_descend.induct)
  case (1 cc lsc tc xc)
  then show ?case
    by(auto intro: gensyn_descend.intros)
next
  case (2 tc tc' lc tc'' lc')

  obtain lch lct where Lc : "lc = lch#lct"
    using 2 gensyn_descend_nonnil[of tc tc' lc]
    by(cases lc; auto)

  have Lch : "lch = n" using 2 Lc by auto

  have Desc1 : "gensyn_descend (G xr' (z # l1)) tc' (Suc lch # lct)"
    using "2.IH"(1)[of n lct xr l1 xr' z] "2.prems" Lc Lch
    by(auto)

  show ?case using gensyn_descend.intros(2)[OF Desc1 "2.hyps"(2)] Lch Lc "2.prems"
    by(auto)
qed

lemma gensyn_descend_correct2' :
  assumes H : "gensyn_get_list l cp = Some t'"
  shows "gensyn_descend (G xr l) t' cp" using assms
proof(induction l arbitrary: cp t' xr rule: gensyn_induct')
  case (1 x l)
  then show ?case
  proof(cases cp)
    case Nil
    then show ?thesis using 1 by auto
  next
    case (Cons cph cpt)
    then show ?thesis
    proof(cases cph)
      case 0
      then show ?thesis
      proof(cases cpt)
        case Nil' : Nil
        then show ?thesis using 1 Cons 0
          by(auto intro: gensyn_descend.intros)
      next
        case Cons' : (Cons cph2 cpt2)
        have Desc1 : "gensyn_descend (G xr [G x l]) (G x l) [0]"
          by(auto intro: gensyn_descend.intros)

        have Desc2 : "gensyn_descend (G x l) t' cpt"
          using Cons' "1.prems" "1.IH"[of cpt t' x] Cons 0
          by auto

        show ?thesis using gensyn_descend.intros(2)[OF Desc1 Desc2]
          Cons' 0 Cons by auto
      qed
    next
      case (Suc cph')
      then show ?thesis using 1 Cons
        by(auto)
    qed
  qed
next
  case 2
  then show ?case by auto
next
  case (3 t l)
  show ?case
  proof(cases cp)
    case Nil
    then show ?thesis using 3 by(auto)
  next
    case (Cons cph cpt)

    show ?thesis
    proof(cases cph)
      case 0

      show ?thesis
      proof(cases cpt)
        case Nil' : Nil
        then show ?thesis using "3.prems" "3.IH"(1) Cons 0
          by(auto intro: gensyn_descend.intros)
      next
        case Cons' : (Cons cph2 cpt2)

        obtain xt lt where T : "t = G xt lt" by(cases t; auto)

        have Desc2' : "gensyn_descend (G xr [t]) t' cp"
          using Cons' "3.prems" "3.IH"(1)[of cp] Cons 0 T
          by(auto)

        show ?thesis
          using gensyn_descend_child_zero[OF Desc2'] 0 Cons
          by(auto)
      qed
    next
      case (Suc cph')

      obtain xt lt where T : "t = G xt lt" by(cases t; auto)

      have Desc2' : "gensyn_descend (G xr l) t' (cph'#cpt)"
        using "3.IH"(2)[of "cph'#cpt"] "3.prems" Cons Suc T
        by(auto)

      show ?thesis using gensyn_descend_child_suc[OF Desc2'] Suc Cons
        by auto
    qed
  qed
qed

(* relating skeletons to the structure of the original tree.
   NB: we could prove this for gensyn map in general
*)

lemma gs_implies_skel_Some' :
  assumes "gensyn_get_list ts cp = Some t'"
  shows "gensyn_get_list (map gs_sk ts) cp = Some (gs_sk t')" using assms
proof(induction ts arbitrary: cp t' rule: gensyn_induct')
case (1 x l)
  then show ?case
  proof(cases cp)
    case Nil
    then show ?thesis using 1 by auto
  next
    case (Cons cph cpt)
    then show ?thesis
    proof(cases cph)
      case 0
      then show ?thesis
      proof(cases cpt)
        case Nil' : Nil
        then show ?thesis using 1 Cons 0
          by(auto)
      next
        case Cons' : (Cons cph2 cpt2)
        then show ?thesis using 1 Cons 0
          by(auto simp add: gs_sk_def)
      qed
    next
      case (Suc cph')
      then show ?thesis using 1 Cons
        by(auto)
    qed
  qed

next
  case 2
  then show ?case
    by(auto)
next
  case (3 t l)
  then show ?case
  proof(cases cp)
    case Nil
    then show ?thesis using 3 by(auto)
  next
    case (Cons cph cpt)

    show ?thesis
    proof(cases cph)
      case 0

      show ?thesis
      proof(cases cpt)
        case Nil' : Nil
        then show ?thesis using "3.prems" "3.IH"(1) Cons 0 by auto
      next
        case Cons' : (Cons cph2 cpt2)
        then show ?thesis using "3.prems" "3.IH"(1)[of cp] Cons 0
          by(cases t; auto simp add: gs_sk_def)
      qed
    next
      case (Suc cph')
      then show ?thesis using "3.prems" "3.IH"(2) Cons
        by(auto)
    qed
  qed
qed

lemma gs_implies_skel_Some :
  assumes H: "gensyn_get t cp = Some t'"
  shows "gensyn_get (gs_sk t) cp = Some (gs_sk t')"
proof(cases cp)
  case Nil
  then show ?thesis using H
    by(auto)
next
  case (Cons cph cpt)

  obtain x l where T : "t = G x l"
    by(cases t; auto)

  have H' : "gensyn_get_list l cp = Some t'"
    using T H Cons
    by(auto)

  show "gensyn_get (gs_sk t) cp = Some (gs_sk t')"
    using gs_implies_skel_Some'[OF H'] H Cons T
    unfolding gs_sk_def
    by(auto)
qed

lemma gs_implies_skel_None' :
  assumes "gensyn_get_list ts cp = None"
  shows "gensyn_get_list (map gs_sk ts) cp = None" using assms
proof(induction ts arbitrary: cp  rule: gensyn_induct')
  case (1 x l)
  then show ?case
  proof(cases cp)
    case Nil
    then show ?thesis using 1 by auto
  next
    case (Cons cph cpt)
    then show ?thesis
    proof(cases cph)
      case 0
      then show ?thesis
      proof(cases cpt)
        case Nil' : Nil
        then show ?thesis using 1 Cons 0
          by(auto)
      next
        case Cons' : (Cons cph2 cpt2)
        then show ?thesis using 1 Cons 0
          by(auto simp add: gs_sk_def)
      qed
    next
      case (Suc cph')
      then show ?thesis using 1 Cons
        by(auto)
    qed
  qed
next
  case 2
  then show ?case by auto
next
  case (3 t l)
  then show ?case
  proof(cases cp)
    case Nil
    then show ?thesis using 3 by(auto)
  next
    case (Cons cph cpt)

    show ?thesis
    proof(cases cph)
      case 0

      show ?thesis
      proof(cases cpt)
        case Nil' : Nil
        then show ?thesis using "3.prems" "3.IH"(1) Cons 0 by auto
      next
        case Cons' : (Cons cph2 cpt2)
        then show ?thesis using "3.prems" "3.IH"(1)[of cp] Cons 0
          by(cases t; auto simp add: gs_sk_def)
      qed
    next
      case (Suc cph')
      then show ?thesis using "3.prems" "3.IH"(2) Cons
        by(auto)
    qed
  qed
qed

lemma gs_implies_skel_None :
  assumes H: "gensyn_get t cp = None"
  shows "gensyn_get (gs_sk t) cp = None" using assms
proof(cases cp)
  case Nil
  then show ?thesis using H
    by(auto)
next
  case (Cons cph cpt)

  obtain x l where T : "t = G x l"
    by(cases t; auto)

  have H' : "gensyn_get_list l cp = None"
    using T H Cons
    by(auto)

  show "gensyn_get (gs_sk t) cp = None"
    using gs_implies_skel_None'[OF H'] H Cons T
    unfolding gs_sk_def
    by(auto)
qed

(* converses of the above *)
lemma gs_skel_implies_Some' :
  assumes "gensyn_get_list (map gs_sk ts) cp = Some t'sk "
  shows "\<exists> t' . gensyn_get_list ts cp = Some t' \<and> gs_sk t' = t'sk" using assms
proof(induction ts arbitrary: cp t'sk rule: gensyn_induct')
  case (1 x l)
  then show ?case
  proof(cases cp)
    case Nil
    then show ?thesis using 1 by auto
  next
    case (Cons cph cpt)
    then show ?thesis
    proof(cases cph)
      case 0
      then show ?thesis
      proof(cases cpt)
        case Nil' : Nil
        then show ?thesis using 1 Cons 0
          by(auto)
      next
        case Cons' : (Cons cph2 cpt2)
        then show ?thesis using 1 Cons 0
          by(auto simp add: gs_sk_def)
      qed
    next
      case (Suc cph')
      then show ?thesis using 1 Cons
        by(auto)
    qed
  qed
next
  case 2
  then show ?case by auto
next
  case (3 t l)
  then show ?case
  proof(cases cp)
    case Nil
    then show ?thesis using 3 by(auto)
  next
    case (Cons cph cpt)

    show ?thesis
    proof(cases cph)
      case 0

      show ?thesis
      proof(cases cpt)
        case Nil' : Nil
        then show ?thesis using "3.prems" "3.IH"(1) Cons 0 by auto
      next
        case Cons' : (Cons cph2 cpt2)
        then show ?thesis using "3.prems" "3.IH"(1)[of cp] Cons 0
          by(cases t; auto simp add: gs_sk_def)
      qed
    next
      case (Suc cph')
      then show ?thesis using "3.prems" "3.IH"(2) Cons
        by(auto)
    qed
  qed
qed

lemma gs_skel_implies_Some :
  assumes H: "gensyn_get (gs_sk t) cp = Some t'sk "
  shows "\<exists> t' . gensyn_get t cp = Some t' \<and> gs_sk t' = t'sk" using assms
proof(cases cp)
  case Nil
  then show ?thesis using H
    by(auto)
next
  case (Cons cph cpt)

  obtain x l where T : "t = G x l"
    by(cases t; auto)

  have H' : "gensyn_get_list (map gs_sk l) cp = Some t'sk"
    using T H Cons unfolding gs_sk_def
    by(auto)

  show "\<exists>t'. gensyn_get t cp = Some t' \<and> gs_sk t' = t'sk"
    using gs_skel_implies_Some'[OF H'] H Cons T
    unfolding gs_sk_def
    by(auto)
qed

lemma gs_skel_implies_None' :
  assumes "gensyn_get_list (map gs_sk ts) cp = None "
  shows "gensyn_get_list ts cp = None" using assms
proof(induction ts arbitrary: cp rule: gensyn_induct')
  case (1 x l)
  then show ?case
  proof(cases cp)
    case Nil
    then show ?thesis using 1 by auto
  next
    case (Cons cph cpt)
    then show ?thesis
    proof(cases cph)
      case 0
      then show ?thesis
      proof(cases cpt)
        case Nil' : Nil
        then show ?thesis using 1 Cons 0
          by(auto)
      next
        case Cons' : (Cons cph2 cpt2)
        then show ?thesis using 1 Cons 0
          by(auto simp add: gs_sk_def)
      qed
    next
      case (Suc cph')
      then show ?thesis using 1 Cons
        by(auto)
    qed
  qed
next
  case 2
  then show ?case by auto
next
  case (3 t l)
  then show ?case
  proof(cases cp)
    case Nil
    then show ?thesis using 3 by(auto)
  next
    case (Cons cph cpt)

    show ?thesis
    proof(cases cph)
      case 0

      show ?thesis
      proof(cases cpt)
        case Nil' : Nil
        then show ?thesis using "3.prems" "3.IH"(1) Cons 0 by auto
      next
        case Cons' : (Cons cph2 cpt2)
        then show ?thesis using "3.prems" "3.IH"(1)[of cp] Cons 0
          by(cases t; auto simp add: gs_sk_def)
      qed
    next
      case (Suc cph')
      then show ?thesis using "3.prems" "3.IH"(2) Cons
        by(auto)
    qed
  qed
qed

lemma gs_skel_implies_None :
  assumes H: "gensyn_get (gs_sk t) cp = None"
  shows "gensyn_get t cp = None" using assms
proof(cases cp)
  case Nil
  then show ?thesis using H
    by(auto)
next
  case (Cons cph cpt)

  obtain x l where T : "t = G x l"
    by(cases t; auto)

  have H' : "gensyn_get_list (map gs_sk l) cp = None"
    using T H Cons unfolding gs_sk_def
    by(auto)

  show "gensyn_get t cp = None"
    using gs_skel_implies_None'[OF H'] H Cons T
    unfolding gs_sk_def
    by(auto)
qed

(* specification for get_suffix *)
lemma get_suffix_spec :
  assumes H : "get_suffix l1 l2 = Some l3"
  shows "l1 @ l3 = l2" using H
proof(induction l1 arbitrary: l2 l3)
case Nil
  then show ?case
    by(cases l2; auto)
next
  case (Cons l1h l1t)
  then show ?case
  proof(cases l2)
    case Nil' : Nil
    then show ?thesis using Cons by auto
  next
    case Cons' : (Cons l2h l2t)
    then show ?thesis
    proof(cases "l1h = l2h")
      case True
      then show ?thesis using Cons Cons' by auto
    next
      case False
      then show ?thesis using Cons Cons'
        by(auto)
    qed
  qed
qed

lemma get_suffix_spec_conv :
  assumes H: "l1 @ (l2h#l2t) = l3"
  shows "get_suffix l1 l3 = Some (l2h#l2t)" using H
proof(induction l1 arbitrary: l2h l2t l3)
  case Nil
  then show ?case
    by(auto)
next
  case (Cons l1h l1t)
  then show ?case
    by(auto)
qed

(* specification for parent *)

lemma gensyn_cp_parent_spec :
  assumes H : "cp_parent cp = Some cp'"
  shows "\<exists> loc . cp = cp' @ [loc]" using H
proof(induction cp arbitrary: cp')
case Nil
  then show ?case by auto
next
  case (Cons cph cpt)
  then show ?case
    by(cases cpt; auto)
qed

lemma gensyn_cp_parent_spec_conv :
  shows "cp_parent (cp' @ [loc]) = Some cp'"
proof(induction cp' arbitrary: loc)
case Nil
  then show ?case by auto
next
  case (Cons cph cpt)
  then show ?case by auto
qed

lemma get_suffix_nonnil :
  "get_suffix l1 l2 \<noteq> Some []"
proof(induction l1 arbitrary: l2)
  case Nil
  then show ?case by(cases l2; auto)
next
  case (Cons l1h l1t)
  then show ?case
    by(cases l2; auto)
qed

end