theory Incredible_Trees
imports
  "~~/src/HOL/Library/Sublist"
  "~~/src/HOL/Library/Countable"
  Entailment
  Inits
  Rose_Tree
  Abstract_Rules_To_Incredible
begin

text \<open>This theory defines incredible trees, which carry roughly the same information
as a (tree-shaped) incredible graph, but where the structure is still given by the data type,
and not by a set of edges etc.\<close>

text {*
Tree-shape, but incredible-graph-like content (port names, explicit annotation and substitution)
*}

datatype ('form,'rule,'subst,'var) itnode =
    I (iNodeOf': "('form, 'rule) graph_node")
      (iOutPort': "'form reg_out_port")
      (iAnnot': "nat")
      (iSubst': "'subst")
  | H (iAnnot': "nat")
      (iSubst': "'subst")

abbreviation "INode n p i s ants \<equiv> RNode (I n p i s) ants"
abbreviation "HNode i s ants \<equiv> RNode (H i s) ants"

type_synonym ('form,'rule,'subst,'var) itree = "('form,'rule,'subst,'var) itnode rose_tree"

fun iNodeOf where
   "iNodeOf (INode n p i s ants) = n"
 | "iNodeOf (HNode i s ants) = Helper"

context Abstract_Formulas begin
fun iOutPort where
   "iOutPort (INode n p i s ants) = p"
 | "iOutPort (HNode i s ants) = anyP"
end

fun iAnnot where "iAnnot it = iAnnot' (root it)"
fun iSubst where "iSubst it = iSubst' (root it)"
fun iAnts where "iAnts it = children it"

type_synonym ('form, 'rule, 'subst) fresh_check = "('form, 'rule) graph_node \<Rightarrow> nat \<Rightarrow> 'subst \<Rightarrow> 'form entailment \<Rightarrow> bool"

context  Abstract_Task
begin

  text \<open>The well-formedness of the tree. The first argument can be varied, depending on whether we
  are interested in the local freshness side-conditions or not.\<close>

  inductive iwf :: "('form, 'rule, 'subst) fresh_check \<Rightarrow> ('form,'rule,'subst,'var) itree \<Rightarrow> 'form entailment \<Rightarrow> bool"
    for fc
    where
    iwf: "\<lbrakk>
       n \<in> sset nodes;
       Reg p |\<in>| outPorts n;
       list_all2 (\<lambda> ip t. iwf fc t ((\<lambda> h . subst s (freshen i (labelsOut n h))) |`| hyps_for n ip |\<union>| \<Gamma> \<turnstile> subst s (freshen i (labelsIn n ip))))
                (inPorts' n) ants;
       fc n i s (\<Gamma> \<turnstile> c);
       c = subst s (freshen i p)
      \<rbrakk> \<Longrightarrow> iwf fc (INode n p i s ants) (\<Gamma> \<turnstile> c)"
  | iwfH: "\<lbrakk>
       c |\<notin>| ass_forms;
       c |\<in>| \<Gamma>;
       c = subst s (freshen i anyP)
      \<rbrakk> \<Longrightarrow> iwf fc (HNode i s []) (\<Gamma> \<turnstile> c)"

lemma iwf_subst_freshen_outPort:
  "iwf lc ts ent \<Longrightarrow>
  snd ent = subst (iSubst ts) (freshen (iAnnot ts) (iOutPort ts))"
  by (auto elim: iwf.cases)

definition all_local_vars :: "('form, 'rule) graph_node \<Rightarrow> 'var set" where
  "all_local_vars n = \<Union>(local_vars n ` fset (inPorts n))"

lemma all_local_vars_Helper[simp]:
  "all_local_vars Helper = {}"
  unfolding all_local_vars_def by simp

lemma all_local_vars_Assumption[simp]:
  "all_local_vars (Assumption c) = {}"
  unfolding all_local_vars_def by simp

text \<open>Local freshness side-conditions, corresponding what we have in the
theory @{text Natural_Deduction}.\<close>

inductive local_fresh_check :: "('form, 'rule, 'subst) fresh_check" where
  "\<lbrakk>\<And> f. f |\<in>| \<Gamma> \<Longrightarrow> freshenLC i ` (all_local_vars n) \<inter> lconsts f = {};
    freshenLC i ` (all_local_vars n) \<inter> subst_lconsts s = {}
   \<rbrakk> \<Longrightarrow> local_fresh_check n i s (\<Gamma> \<turnstile> c)"

abbreviation "local_iwf \<equiv> iwf local_fresh_check"

text \<open>No freshness side-conditions. Used with the tree that comes out of
@{text globalize}, where we establish the (global) freshness conditions
separately.\<close>

inductive no_fresh_check :: "('form, 'rule, 'subst) fresh_check" where
  "no_fresh_check n i s (\<Gamma> \<turnstile> c)"

abbreviation "plain_iwf \<equiv> iwf no_fresh_check"

fun isHNode where
  "isHNode (HNode _ _ _ ) = True"
 |"isHNode _ = False"

lemma iwf_edge_match:
  assumes "iwf fc t ent"
  assumes "is@[i] \<in> it_paths t"
  shows "subst (iSubst (tree_at t (is@[i]))) (freshen (iAnnot (tree_at t (is@[i]))) (iOutPort (tree_at t (is@[i]))))
     = subst (iSubst (tree_at t is)) (freshen (iAnnot (tree_at t is)) (a_conc (inPorts' (iNodeOf (tree_at t is)) ! i)))"
  using assms
  apply (induction arbitrary: "is" i)
   apply (auto elim!: it_paths_SnocE)[1]
   apply (rename_tac "is" i)
   apply (case_tac "is")
    apply (auto dest!: list_all2_nthD2)[1]
    using iwf_subst_freshen_outPort
    apply (solves \<open>(auto)[1]\<close>)
   apply (auto elim!: it_paths_ConsE dest!: list_all2_nthD2)[1]
   using it_path_SnocI
   apply (solves blast)
  apply (solves auto)
  done

lemma iwf_length_inPorts:
  assumes "iwf fc t ent"
  assumes "is \<in> it_paths t"
  shows "length (iAnts (tree_at t is)) \<le> length (inPorts' (iNodeOf (tree_at t is)))"
  using assms
  by (induction arbitrary: "is" rule: iwf.induct)
     (auto elim!: it_paths_RNodeE dest: list_all2_lengthD list_all2_nthD2)

lemma iwf_local_not_in_subst:
  assumes "local_iwf t ent"
  assumes "is \<in> it_paths t"
  assumes "var \<in> all_local_vars (iNodeOf (tree_at t is))"
  shows "freshenLC (iAnnot (tree_at t is)) var \<notin> subst_lconsts (iSubst (tree_at t is))"
  using assms
  by (induction arbitrary: "is" rule: iwf.induct)
     (auto 4 4 elim!: it_paths_RNodeE local_fresh_check.cases dest: list_all2_lengthD list_all2_nthD2)

lemma iwf_length_inPorts_not_HNode:
  assumes "iwf fc t ent"
  assumes "is \<in> it_paths t"
  assumes "\<not> (isHNode (tree_at t is))"
  shows "length (iAnts (tree_at t is)) = length (inPorts' (iNodeOf (tree_at t is)))"
  using assms
  by (induction arbitrary: "is" rule: iwf.induct)
     (auto 4 4 elim!: it_paths_RNodeE  dest: list_all2_lengthD list_all2_nthD2)

lemma iNodeOf_outPorts:
  "iwf fc t ent \<Longrightarrow> is \<in> it_paths t \<Longrightarrow> outPorts (iNodeOf (tree_at t is)) = {||} \<Longrightarrow> False"
  by (induction arbitrary: "is" rule: iwf.induct)
     (auto 4 4 elim!: it_paths_RNodeE  dest: list_all2_lengthD list_all2_nthD2)

lemma iwf_outPort:
  assumes "iwf fc t ent"
  assumes "is \<in> it_paths t"
  shows "Reg (iOutPort (tree_at t is)) |\<in>| outPorts (iNodeOf (tree_at t is))"
  using assms
  by (induction arbitrary: "is" rule: iwf.induct)
     (auto 4 4 elim!: it_paths_RNodeE  dest: list_all2_lengthD list_all2_nthD2)

inductive_set hyps_along for t "is" where
 "prefixeq (is'@[i]) is \<Longrightarrow>
  i < length (inPorts' (iNodeOf (tree_at t is'))) \<Longrightarrow>
  hyps (iNodeOf (tree_at t is')) h = Some (inPorts' (iNodeOf (tree_at t is')) ! i) \<Longrightarrow>
  subst (iSubst (tree_at t is')) (freshen (iAnnot (tree_at t is')) (labelsOut (iNodeOf (tree_at t is')) h)) \<in> hyps_along t is"

lemma hyps_along_Nil[simp]: "hyps_along t [] = {}"
  by (auto simp add: hyps_along.simps)

lemma hyps_along_Cons:
  assumes "iwf fc t ent"
  assumes "i#is \<in> it_paths t"
  shows "hyps_along t (i#is) =
    (\<lambda>h. subst (iSubst t) (freshen (iAnnot t) (labelsOut (iNodeOf t) h))) ` fset (hyps_for (iNodeOf t) (inPorts' (iNodeOf t) ! i))
    \<union> hyps_along (iAnts t ! i) is" (is "?S1 = ?S2 \<union> ?S3")
proof-
  from assms
  have "i < length (iAnts t)" and "is \<in> it_paths (iAnts t ! i)"
    by (auto elim: it_paths_ConsE)
  let "?t'" = "iAnts t ! i"

  show ?thesis
  proof (rule; rule)
    fix x
    assume "x \<in> hyps_along t (i # is)"
    then obtain is' i' h where
      "prefixeq (is'@[i']) (i#is)"
      and "i' < length (inPorts' (iNodeOf (tree_at t is')))"
      and "hyps (iNodeOf (tree_at t is')) h = Some (inPorts' (iNodeOf (tree_at t is')) ! i')"
      and [simp]: "x = subst (iSubst (tree_at t is')) (freshen (iAnnot (tree_at t is')) (labelsOut (iNodeOf (tree_at t is')) h))"
    by (auto elim!: hyps_along.cases)
    from this(1)
    show "x \<in> ?S2 \<union> ?S3"
    proof(cases rule: prefixeq_app_Cons_elim)
      assume "is' = []" and "i' = i"
      with `hyps (iNodeOf (tree_at t is')) h = Some _`
      have "x \<in> ?S2" by auto
      thus ?thesis..
    next
      fix is''
      assume [simp]: "is' = i # is''" and "prefixeq (is'' @ [i']) is"
      have "tree_at t is' = tree_at ?t' is''" by simp

      note `prefixeq (is'' @ [i']) is`
           `i' < length (inPorts' (iNodeOf (tree_at t is')))`
           `hyps (iNodeOf (tree_at t is')) h = Some (inPorts' (iNodeOf (tree_at t is')) ! i')`
      from this[unfolded `tree_at t is' = tree_at ?t' is''`]
      have "subst (iSubst (tree_at (iAnts t ! i) is'')) (freshen (iAnnot (tree_at (iAnts t ! i) is'')) (labelsOut (iNodeOf (tree_at (iAnts t ! i) is'')) h))
          \<in> hyps_along (iAnts t ! i) is" by (rule hyps_along.intros)
      hence "x \<in> ?S3" by simp
      thus ?thesis..
    qed
  next
    fix x
    assume "x \<in> ?S2 \<union> ?S3"
    thus "x \<in> ?S1"
    proof
      have "prefixeq ([]@[i]) (i#is)" by simp
      moreover
      from `iwf _ t _`
      have "length (iAnts t) \<le> length (inPorts' (iNodeOf (tree_at t []))) "
        by cases (auto dest: list_all2_lengthD)
      with `i < _`
      have "i < length (inPorts' (iNodeOf (tree_at t [])))" by simp
      moreover
      assume "x \<in> ?S2"
      then obtain h where "h |\<in>| hyps_for (iNodeOf t) (inPorts' (iNodeOf t) ! i)"
        and [simp]: "x = subst (iSubst t) (freshen (iAnnot t) (labelsOut (iNodeOf t) h))" by auto
      from this(1)
      have "hyps (iNodeOf (tree_at t [])) h = Some (inPorts' (iNodeOf (tree_at t [])) ! i)" by simp
      ultimately
      have "subst (iSubst (tree_at t [])) (freshen (iAnnot (tree_at t [])) (labelsOut (iNodeOf (tree_at t [])) h)) \<in> hyps_along t (i # is)"
        by (rule hyps_along.intros)
      thus "x \<in> hyps_along t (i # is)" by simp
    next
      assume "x \<in> ?S3"
      thus "x \<in> ?S1"
        apply (auto simp add: hyps_along.simps)
        apply (rule_tac x = "i#is'" in exI)
        apply auto
        done
    qed
  qed
qed

lemma iwf_hyps_exist:
  assumes "iwf lc it ent"
  assumes "is \<in> it_paths it"
  assumes "tree_at it is = (HNode i s ants')"
  assumes "fst ent |\<subseteq>| ass_forms"
  shows "subst s (freshen i anyP) \<in> hyps_along it is"
proof-
  from assms(1,2,3)
  have "subst s (freshen i anyP) \<in> hyps_along it is
     \<or> subst s (freshen i anyP) |\<in>| fst ent
       \<and> subst s (freshen i anyP) |\<notin>| ass_forms"
  proof(induction arbitrary: "is" rule: iwf.induct)
    case (iwf n p  s' a' \<Gamma> ants c "is")

    have "iwf lc (INode n p a' s' ants) (\<Gamma> \<turnstile> c)"
      using iwf(1,2,3,4,5)
      by (auto intro!: iwf.intros elim!: list_all2_mono)

    show ?case
    proof(cases "is")
      case Nil
      with `tree_at (INode n p a' s' ants) is = HNode i s ants'`
      show ?thesis by auto
    next
      case (Cons i' "is'")
      with `is \<in> it_paths (INode n p a' s' ants)`
      have "i' < length ants" and "is' \<in> it_paths (ants ! i')"
        by (auto elim: it_paths_ConsE)

      let ?\<Gamma>' = "(\<lambda>h. subst s' (freshen a' (labelsOut n h))) |`| hyps_for n (inPorts' n ! i')"

      from `tree_at (INode n p a' s' ants) is = HNode i s ants'`
      have "tree_at (ants ! i') is' = HNode i s ants'" using Cons by simp

      from  iwf.IH `i' < length ants`  `is' \<in> it_paths (ants ! i')` this
      have  "subst s (freshen i anyP) \<in> hyps_along (ants ! i') is'
        \<or> subst s (freshen i anyP) |\<in>| ?\<Gamma>' |\<union>| \<Gamma> \<and> subst s (freshen i anyP) |\<notin>| ass_forms"
        by (auto dest: list_all2_nthD2)
      moreover
      from  `is \<in> it_paths (INode n p a' s' ants)`
      have "hyps_along (INode n p a' s' ants) is = fset ?\<Gamma>' \<union> hyps_along (ants ! i') is'"
        using `is = _`
        by (simp add: hyps_along_Cons[OF `iwf lc (INode n p a' s' ants) (\<Gamma> \<turnstile> c)`])
      ultimately
      show ?thesis by auto
    qed
  next
    case (iwfH c  \<Gamma> s' i' "is")
    hence [simp]: "is = []" "i' = i" "s' = s" by simp_all
    from `c = subst s' (freshen i' anyP)` `c |\<in>| \<Gamma>` `c |\<notin>| ass_forms`
    show ?case by simp
  qed
  with assms(4)
  show ?thesis by blast
qed

definition hyp_port_for' :: "('form, 'rule, 'subst, 'var) itree \<Rightarrow> nat list \<Rightarrow> 'form \<Rightarrow> nat list \<times> nat \<times> ('form, 'var) out_port" where
  "hyp_port_for' t is f = (SOME x.
   (case x of (is', i, h) \<Rightarrow>
      prefixeq (is' @ [i]) is \<and>
      i < length (inPorts' (iNodeOf (tree_at t is'))) \<and>
      hyps (iNodeOf (tree_at t is')) h =  Some (inPorts' (iNodeOf (tree_at t is')) ! i) \<and>
      f = subst (iSubst  (tree_at t is')) (freshen (iAnnot (tree_at t is')) (labelsOut (iNodeOf (tree_at t is')) h))
   ))"

lemma hyp_port_for_spec':
  assumes "f \<in> hyps_along t is"
  shows "(case hyp_port_for' t is f of (is', i, h) \<Rightarrow>
      prefixeq (is' @ [i]) is \<and>
      i < length (inPorts' (iNodeOf (tree_at t is'))) \<and>
      hyps (iNodeOf (tree_at t is')) h =  Some (inPorts' (iNodeOf (tree_at t is')) ! i) \<and>
      f = subst (iSubst  (tree_at t is')) (freshen (iAnnot (tree_at t is')) (labelsOut (iNodeOf (tree_at t is')) h)))"
using assms unfolding hyps_along.simps hyp_port_for'_def by -(rule someI_ex, blast)

definition hyp_port_path_for :: "('form, 'rule, 'subst, 'var) itree \<Rightarrow> nat list \<Rightarrow> 'form \<Rightarrow> nat list"
  where "hyp_port_path_for t is f = fst (hyp_port_for' t is f)"
definition hyp_port_i_for ::  "('form, 'rule, 'subst, 'var) itree \<Rightarrow> nat list \<Rightarrow> 'form \<Rightarrow> nat"
  where "hyp_port_i_for t is f = fst (snd (hyp_port_for' t is f))"
definition hyp_port_h_for :: "('form, 'rule, 'subst, 'var) itree \<Rightarrow> nat list \<Rightarrow> 'form \<Rightarrow> ('form, 'var) out_port"
  where "hyp_port_h_for t is f = snd (snd (hyp_port_for' t is f))"

lemma hyp_port_prefixeq:
  assumes "f \<in> hyps_along t is"
  shows "prefixeq (hyp_port_path_for t is f@[hyp_port_i_for t is f]) is"
using hyp_port_for_spec'[OF assms] unfolding hyp_port_path_for_def hyp_port_i_for_def by auto

lemma hyp_port_prefix:
  assumes "f \<in> hyps_along t is"
  shows "prefix (hyp_port_path_for t is f) is"
using hyp_port_prefixeq[OF assms] by (simp add: prefixI' prefix_order.dual_order.strict_trans1)

lemma hyp_port_it_paths:
  assumes "is \<in> it_paths t"
  assumes "f \<in> hyps_along t is"
  shows "hyp_port_path_for t is f \<in> it_paths t"
using assms by (rule it_paths_prefix[OF _ hyp_port_prefix] )

lemma hyp_port_hyps:
  assumes "f \<in> hyps_along t is"
  shows "hyps (iNodeOf (tree_at t (hyp_port_path_for t is f))) (hyp_port_h_for t is f) = Some (inPorts' (iNodeOf (tree_at t (hyp_port_path_for t is f))) ! hyp_port_i_for t is f)"
using hyp_port_for_spec'[OF assms] unfolding hyp_port_path_for_def hyp_port_i_for_def hyp_port_h_for_def by auto

lemma hyp_port_outPort:
  assumes "f \<in> hyps_along t is"
  shows "(hyp_port_h_for t is f) |\<in>| outPorts (iNodeOf (tree_at t (hyp_port_path_for t is f)))"
using hyps_correct[OF hyp_port_hyps[OF assms]]..

lemma hyp_port_eq:
  assumes "f \<in> hyps_along t is"
  shows "f = subst (iSubst (tree_at t (hyp_port_path_for t is f))) (freshen (iAnnot (tree_at t (hyp_port_path_for t is f))) (labelsOut (iNodeOf (tree_at t (hyp_port_path_for t is f))) (hyp_port_h_for t is f)))"
using hyp_port_for_spec'[OF assms] unfolding hyp_port_path_for_def hyp_port_i_for_def hyp_port_h_for_def by auto

definition isidx :: "nat list \<Rightarrow> nat" where "isidx xs = to_nat (Some xs)"
definition v_away :: "nat" where "v_away = to_nat (None :: nat list option)"
lemma isidx_inj[simp]: "isidx xs = isidx ys \<longleftrightarrow> xs = ys"
  unfolding isidx_def by simp
lemma isidx_v_away[simp]: "isidx xs \<noteq> v_away"
  unfolding isidx_def v_away_def by simp

definition mapWithIndex where "mapWithIndex f xs = map (\<lambda> (i,t) . f i t) (List.enumerate 0 xs)"
lemma mapWithIndex_cong [fundef_cong]:
  "xs = ys \<Longrightarrow> (\<And>x i. x \<in> set ys \<Longrightarrow> f i x = g i x) \<Longrightarrow> mapWithIndex f xs = mapWithIndex g ys"
unfolding mapWithIndex_def by (auto simp add: in_set_enumerate_eq)

lemma mapWithIndex_Nil[simp]: "mapWithIndex f [] = []"
  unfolding mapWithIndex_def by simp

lemma length_mapWithIndex[simp]: "length (mapWithIndex f xs) = length xs"
  unfolding mapWithIndex_def by simp

lemma nth_mapWithIndex[simp]: "i < length xs \<Longrightarrow> mapWithIndex f xs ! i = f i (xs ! i)"
  unfolding mapWithIndex_def by (auto simp add: nth_enumerate_eq)

lemma list_all2_mapWithIndex2E:
  assumes "list_all2 P as bs"
  assumes "\<And> i a b . i < length bs \<Longrightarrow> P a b \<Longrightarrow> Q a (f i b)"
  shows "list_all2 Q as (mapWithIndex f bs)"
using assms(1)
by (auto simp add: list_all2_conv_all_nth mapWithIndex_def nth_enumerate_eq intro: assms(2) split: prod.split)

text \<open>The globalize function, which renames all local constants so that they cannot clash with
local constants occurring anywhere else in the tree.\<close>

fun globalize_node :: "nat list \<Rightarrow> ('var \<Rightarrow> 'var) \<Rightarrow> ('form,'rule,'subst,'var) itnode \<Rightarrow>  ('form,'rule,'subst,'var) itnode"  where
  "globalize_node is f (I n p i s) =  I n p (isidx is) (subst_renameLCs f s)"
  | "globalize_node is f (H i s) = H (isidx is) (subst_renameLCs f s)"

fun globalize :: "nat list \<Rightarrow> ('var \<Rightarrow> 'var) \<Rightarrow> ('form,'rule,'subst,'var) itree \<Rightarrow> ('form,'rule,'subst,'var) itree" where
  "globalize is f (RNode r ants) = RNode
    (globalize_node is f r)
    (mapWithIndex (\<lambda> i' t.
      globalize (is@[i'])
                (rerename (a_fresh (inPorts' (iNodeOf (RNode r ants)) ! i'))
                          (iAnnot (RNode r ants)) (isidx is) f)
                t
      ) ants)"

lemma iAnnot'_globalize_node[simp]: "iAnnot' (globalize_node is f n) = isidx is"
  by (cases n) auto

lemma iAnnot_globalize:
  assumes "is' \<in> it_paths (globalize is f t)"
  shows  "iAnnot (tree_at (globalize is f t) is') = isidx (is@is')"
  using assms
  by (induction t arbitrary: f "is" is') (auto elim!: it_paths_RNodeE)

lemma all_local_consts_listed':
  assumes "n \<in> sset nodes"
  assumes "p |\<in>| inPorts n"
  shows "lconsts (a_conc p) \<union> (\<Union>(lconsts ` fset (a_hyps p))) \<subseteq> a_fresh p "
  using assms
  by (auto simp add: nodes_def stream.set_map lconsts_anyP closed_no_lconsts conclusions_closed fmember.rep_eq f_antecedent_def dest!: all_local_consts_listed)

lemma no_local_consts_in_consequences':
  "n \<in> sset nodes \<Longrightarrow> Reg p |\<in>| outPorts n \<Longrightarrow>  lconsts p = {}"
  using no_local_consts_in_consequences
  by (auto simp add: nodes_def lconsts_anyP closed_no_lconsts assumptions_closed stream.set_map f_consequent_def)

lemma iwf_globalize:
  assumes "local_iwf t (\<Gamma> \<turnstile> c)"
  shows "plain_iwf (globalize is f t) (renameLCs f |`| \<Gamma> \<turnstile> renameLCs f c)"
using assms
proof (induction t "\<Gamma> \<turnstile> c" arbitrary: "is" f \<Gamma> c rule: iwf.induct)
  case (iwf n p s i \<Gamma> ants c "is" f)

  note `n \<in> sset nodes`
  moreover
  note `Reg p |\<in>| outPorts n`
  moreover
  { fix i'
    let ?V = "a_fresh (inPorts' n ! i')"
    let ?f' = "rerename ?V i (isidx is) f"
    let ?t = "globalize (is @ [i']) ?f' (ants ! i')"
    let ?ip = "inPorts' n ! i'"
    let ?\<Gamma>' = "(\<lambda>h. subst (subst_renameLCs f s) (freshen (isidx is) (labelsOut n h))) |`| hyps_for n ?ip"
    let ?c' = "subst (subst_renameLCs f s) (freshen (isidx is) (labelsIn n ?ip))"

    assume "i' < length (inPorts' n)"
    hence "(inPorts' n ! i') |\<in>| inPorts n" by (simp add: inPorts_fset_of)

    from `i' < length (inPorts' n)`
    have subset_V: "?V \<subseteq> all_local_vars n"
      unfolding all_local_vars_def
      by (auto simp add: inPorts_fset_of set_conv_nth)

    from `local_fresh_check n i s (\<Gamma> \<turnstile> c)`
    have "freshenLC i ` all_local_vars n \<inter> subst_lconsts s = {}"
      by (rule local_fresh_check.cases) simp
    hence "freshenLC i ` ?V \<inter> subst_lconsts s = {}"
      using subset_V  by auto
    hence rerename_subst: "subst_renameLCs ?f' s = subst_renameLCs f s"
      by (rule rerename_subst_noop)

    from all_local_consts_listed'[OF ` n \<in> sset nodes` `(inPorts' n ! i') |\<in>| inPorts n`]
    have subset_conc: "lconsts (a_conc (inPorts' n ! i')) \<subseteq> ?V"
      and subset_hyp': "\<And> hyp . hyp |\<in>| a_hyps (inPorts' n ! i') \<Longrightarrow> lconsts hyp \<subseteq> ?V"
      by (auto simp add: fmember.rep_eq)

    from List.list_all2_nthD[OF `list_all2 _ _ _` `i' < length (inPorts' n)`,simplified]
    have "plain_iwf ?t
           (renameLCs ?f' |`| ((\<lambda>h. subst s (freshen i (labelsOut n h))) |`| hyps_for n ?ip |\<union>|  \<Gamma>) \<turnstile>
            renameLCs ?f' (subst s (freshen i (a_conc ?ip))))"
         by simp
    also have "renameLCs ?f' |`| ((\<lambda>h. subst s (freshen i (labelsOut n h))) |`| hyps_for n ?ip |\<union>|  \<Gamma>)
      = (\<lambda>x. subst (subst_renameLCs ?f' s) (renameLCs ?f' (freshen i (labelsOut n x)))) |`|  hyps_for n ?ip |\<union>| renameLCs ?f' |`| \<Gamma>"
     by (simp add: fimage_fimage fimage_funion comp_def rename_subst)
    also have "renameLCs ?f' |`| \<Gamma> =  renameLCs f |`| \<Gamma>"
    proof(rule fimage_cong[OF refl])
      fix x
      assume "x |\<in>| \<Gamma>"
      with `local_fresh_check n i s (\<Gamma> \<turnstile> c)`
      have "freshenLC i ` all_local_vars n \<inter> lconsts x = {}"
        by (elim local_fresh_check.cases) simp
      hence "freshenLC i ` ?V \<inter> lconsts x = {}"
        using subset_V  by auto
      thus "renameLCs ?f' x = renameLCs f x"
        by (rule rerename_rename_noop)
    qed
    also have "(\<lambda>x. subst (subst_renameLCs ?f' s) (renameLCs ?f' (freshen i (labelsOut n x)))) |`|  hyps_for n ?ip = ?\<Gamma>'"
    proof(rule fimage_cong[OF refl])
      fix hyp
      assume "hyp |\<in>| hyps_for n (inPorts' n ! i')"
      hence "labelsOut n hyp |\<in>| a_hyps (inPorts' n ! i')"
        apply (cases hyp)
        apply (solves simp)
        apply (cases n)
        apply (auto split: if_splits)
        done
      from subset_hyp'[OF this]
      have subset_hyp: "lconsts (labelsOut n hyp) \<subseteq> ?V".

      show "subst (subst_renameLCs ?f' s) (renameLCs ?f' (freshen i (labelsOut n hyp))) =
            subst (subst_renameLCs f s)  (freshen (isidx is) (labelsOut n hyp))"
        apply (simp add: freshen_def rename_rename  rerename_subst)
        apply (rule arg_cong[OF renameLCs_cong])
        apply (auto dest: subsetD[OF subset_hyp])
        done
    qed
    also have "renameLCs ?f' (subst s (freshen i (a_conc ?ip))) = subst (subst_renameLCs ?f' s) (renameLCs ?f' (freshen i (a_conc ?ip)))" by (simp add: rename_subst)
    also have "... = ?c'"
        apply (simp add: freshen_def rename_rename  rerename_subst)
        apply (rule arg_cong[OF renameLCs_cong])
        apply (auto dest: subsetD[OF subset_conc])
        done
    finally
    have "plain_iwf ?t (?\<Gamma>' |\<union>| renameLCs f |`| \<Gamma> \<turnstile> ?c')".
  }
  with list_all2_lengthD[OF `list_all2 _ _ _`]
  have "list_all2
     (\<lambda>ip t. plain_iwf t ((\<lambda>h. subst (subst_renameLCs f s)
       (freshen (isidx is) (labelsOut n h))) |`| hyps_for n ip |\<union>|  renameLCs f |`| \<Gamma> \<turnstile> subst (subst_renameLCs f s) (freshen (isidx is) (labelsIn n ip))))
     (inPorts' n)
     (mapWithIndex (\<lambda> i' t. globalize (is@[i']) (rerename (a_fresh (inPorts' n ! i')) i (isidx is) f) t) ants)"
   by (auto simp add: list_all2_conv_all_nth)
  moreover
  have "no_fresh_check n (isidx is) (subst_renameLCs f s) (renameLCs f |`| \<Gamma> \<turnstile> renameLCs f c)"..
  moreover
  from `n \<in> sset nodes` `Reg p |\<in>| outPorts n`
  have "lconsts p = {}" by (rule no_local_consts_in_consequences')
  with `c = subst s (freshen i p)`
  have "renameLCs f c = subst (subst_renameLCs f s) (freshen (isidx is) p)"
    by (simp add: rename_subst rename_closed freshen_closed)
  ultimately
  show ?case
    unfolding globalize.simps globalize_node.simps iNodeOf.simps iAnnot.simps itnode.sel rose_tree.sel  Let_def
    by (rule iwf.intros(1))
next
  case (iwfH c \<Gamma> s i "is" f)
  from `c |\<notin>| ass_forms`
  have "renameLCs f c |\<notin>| ass_forms"
    using assumptions_closed closed_no_lconsts lconsts_renameLCs rename_closed by fastforce
  moreover
  from `c |\<in>| \<Gamma>`
  have "renameLCs f c |\<in>| renameLCs f |`| \<Gamma>"  by auto
  moreover
  from `c = subst s (freshen i anyP)`
  have "renameLCs f c = subst (subst_renameLCs f s)  (freshen (isidx is) anyP)"
    by (metis freshen_closed lconsts_anyP rename_closed rename_subst)
  ultimately
  show "plain_iwf (globalize is f (HNode i s [])) (renameLCs f |`| \<Gamma> \<turnstile> renameLCs f c)"
    unfolding globalize.simps globalize_node.simps  mapWithIndex_Nil  Let_def
    by (rule iwf.intros(2))
qed

definition fresh_at where
  "fresh_at t xs =
   (case rev xs of [] \<Rightarrow> {}
                 | (i#is') \<Rightarrow> freshenLC (iAnnot (tree_at t (rev is'))) ` (a_fresh (inPorts' (iNodeOf (tree_at t (rev is'))) ! i)))"

lemma fresh_at_Nil[simp]:
  "fresh_at t [] = {}"
  unfolding fresh_at_def by simp

lemma fresh_at_snoc[simp]:
  "fresh_at t (is@[i]) = freshenLC (iAnnot (tree_at t is)) ` (a_fresh (inPorts' (iNodeOf (tree_at t is)) ! i))"
  unfolding fresh_at_def by simp

lemma fresh_at_def':
  "fresh_at t is =
   (if is = [] then {}
    else freshenLC (iAnnot (tree_at t (butlast is))) ` (a_fresh (inPorts' (iNodeOf (tree_at t (butlast is))) ! last is)))"
  unfolding fresh_at_def by (auto split: list.split)

lemma fresh_at_Cons[simp]:
  "fresh_at t (i#is) = (if is = [] then freshenLC (iAnnot t) ` (a_fresh (inPorts' (iNodeOf t) ! i)) else (let t' = iAnts t ! i in fresh_at t' is))"
  unfolding fresh_at_def'
  by (auto simp add: Let_def)

definition fresh_at_path where
  "fresh_at_path t is = \<Union>(fresh_at t ` set (inits is))"

lemma fresh_at_path_Nil[simp]:
  "fresh_at_path t [] = {}"
  unfolding fresh_at_path_def by simp

lemma fresh_at_path_Cons[simp]:
  "fresh_at_path t (i#is) = fresh_at t [i] \<union> fresh_at_path (iAnts t ! i) is"
  unfolding fresh_at_path_def
  apply (auto split: if_splits)
  apply (metis empty_iff fresh_at_Nil in_set_inits)
  done

lemma globalize_local_consts:
  assumes "is' \<in> it_paths (globalize is f t)"
  shows "subst_lconsts (iSubst (tree_at (globalize is f t) is')) \<subseteq>
    fresh_at_path (globalize is f t) is' \<union> range f"
  using assms
  apply (induction "is" f t  arbitrary: is' rule:globalize.induct)
  apply (rename_tac "is" f r ants is')
  apply (case_tac r)
   apply (auto simp add: subst_lconsts_subst_renameLCs  elim!: it_paths_RNodeE)
   apply (solves \<open>force dest!: subsetD[OF range_rerename]\<close>)
  apply (solves \<open>force dest!: subsetD[OF range_rerename]\<close>)
  done

lemma iwf_globalize':
  assumes "local_iwf t ent"
  assumes "\<And> x. x |\<in>| fst ent \<Longrightarrow> closed x"
  assumes "closed (snd ent)"
  shows "plain_iwf (globalize is (freshenLC v_away) t) ent"
using assms
proof(induction ent rule: prod.induct)
  case (Pair \<Gamma> c)
  have "plain_iwf (globalize is (freshenLC v_away) t) (renameLCs (freshenLC v_away) |`| \<Gamma> \<turnstile> renameLCs (freshenLC v_away) c)"
    by (rule iwf_globalize[OF Pair(1)])
  also
  from Pair(3) have "closed c" by simp
  hence "renameLCs (freshenLC v_away) c = c" by (simp add: closed_no_lconsts rename_closed)
  also
  from Pair(2)
  have "renameLCs (freshenLC v_away) |`| \<Gamma> = \<Gamma>"
    by (auto simp add: closed_no_lconsts rename_closed fmember.rep_eq image_iff)
  finally show ?case.
qed
end

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_nat_boring_max_min_abs
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

theorem property0 :
  "((let z :: Nat = (if le x y then x else y)
     in (if le x z then z else x)) =
      x)"
  oops

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2005         |
            |               January 2006                |
            |                 March 2007  (modified)    |
            |                 August 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory FNF_F_sf_ext
imports FNF_F_sf_induct
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*  The following simplification rules are deleted in this theory file *)
(*       P (if Q then x else y) = ((Q --> P x) & (~ Q --> P y))        *)
(* Isabelle 2017: split_if --> if_split *)

declare if_split  [split del]

(*****************************************************************

         1. full sequentialization for Ext_choice
         2. full sequentialization for Timeout
         2.
         3.

 *****************************************************************)

(*============================================================*
 |                                                            |
 |                        Ext_choice                          |
 |                                                            |
 *============================================================*)

definition
  Pfun_Ext_choice :: "('p,'a) proc => ('p,'a) proc => ('p,'a) proc"
  where
  Pfun_Ext_choice_def :
    "Pfun_Ext_choice == (%P1 P2. P1 [+] P2)"

definition
  SP_step_Ext_choice ::
   "('a set => ('a => ('p,'a) proc) => ('p,'a) proc =>
     'a set => ('a => ('p,'a) proc) => ('p,'a) proc =>
    ('a => ('p,'a) proc) => ('a => ('p,'a) proc) => ('a => ('p,'a) proc)
        => ('p,'a) proc)"
  where
  SP_step_Ext_choice_def :
    "SP_step_Ext_choice == (%A1 Pf1 Q1 A2 Pf2 Q2 SPf SPf1 SPf2.

           (? a:(A1 Un A2)
               -> (if (a : A1 & a : A2)
                   then (Pf1 a) |~|seq (Pf2 a)
                   else if (a : A1)
                        then (Pf1 a) else (Pf2 a)))
           [+] (if (Q1 = STOP) then Q2
                else if (Q2 = STOP) then Q1
                else (if (Q1 = SKIP | Q2 = SKIP) then SKIP else DIV)))"

definition
  fsfF_Ext_choice  :: "('p,'a) proc => ('p,'a) proc => ('p,'a) proc"
                                    ("(1_ /[+]seq _)" [72,73] 72)
  where
  fsfF_Ext_choice_def :
    "P1 [+]seq P2 ==
       (fsfF_induct2 Pfun_Ext_choice SP_step_Ext_choice P1 P2)"

(*------------------------------------------------------------*
 |                        in fsfF_proc                        |
 *------------------------------------------------------------*)

lemma fsfF_Ext_choice_in:
    "[| P1 : fsfF_proc ; P2 : fsfF_proc |]
     ==> P1 [+]seq P2 : fsfF_proc"
apply (simp add: fsfF_Ext_choice_def)
apply (rule fsfF_induct2_in)
apply (simp_all)

apply (simp_all add: SP_step_Ext_choice_def)
apply (rule fsfF_proc_ext)
apply (intro ballI)
apply (simp split: if_split)
apply (intro impI conjI)
apply (rule fsfF_Int_choice_in)
apply (simp_all)
apply (simp split: if_split)
apply (auto)
done

(*------------------------------------------------------------*
 |             syntactical transformation to fsfF             |
 *------------------------------------------------------------*)

lemma cspF_fsfF_Ext_choice_eqF:
    "P1 [+] P2 =F P1 [+]seq P2"
apply (simp add: fsfF_Ext_choice_def)
apply (rule cspF_rw_right)
apply (rule cspF_fsfF_induct2_eqF[THEN cspF_sym])
apply (simp_all add: Pfun_Ext_choice_def)
apply (rule cspF_Dist_nonempty, simp)
apply (rule cspF_Dist_nonempty, simp)
apply (simp add: SP_step_Ext_choice_def)

(* commut and assoc *)
apply (rule cspF_rw_left)
apply (subgoal_tac
  "? :A1 -> Pf1 [+] Q1 [+] (? :A2 -> Pf2 [+] Q2)
  =F (? :A1 -> Pf1 [+] ? :A2 -> Pf2) [+] (Q1 [+] Q2)")  (* sub1 *)
apply (simp)

 (* sub1 *)
 apply (rule cspF_rw_left)
 apply (rule cspF_assoc)
 apply (rule cspF_rw_left)
 apply (rule cspF_decompo)
 apply (rule cspF_assoc_sym)
 apply (rule cspF_reflex)
 apply (rule cspF_rw_left)
 apply (rule cspF_decompo)
 apply (rule cspF_decompo)
 apply (rule cspF_reflex)
 apply (rule cspF_commut)
 apply (rule cspF_reflex)
 apply (rule cspF_rw_left)
 apply (rule cspF_decompo)
 apply (rule cspF_assoc)
 apply (rule cspF_reflex)
 apply (rule cspF_rw_left)
 apply (rule cspF_assoc_sym)
 apply (rule cspF_reflex)

apply (rule cspF_decompo)

(* expand *)
apply (rule cspF_rw_left)
apply (rule cspF_step)
apply (rule cspF_decompo)
apply (simp)

(* if *)
apply (rule cspF_rw_right)
apply (rule cspF_IF_split[THEN cspF_sym])
apply (rule cspF_decompo)
apply (simp)
apply (simp add: cspF_fsfF_Int_choice_eqF)
apply (rule cspF_rw_right)
apply (rule cspF_IF_split[THEN cspF_sym])
apply (rule cspF_decompo)
apply (simp_all)

(* SKIP [+] DIV *)
apply (simp split: if_split)
apply (intro conjI impI)
apply (simp_all)
apply (rule cspF_rw_left)
apply (rule cspF_SKIP_or_DIV)
apply (simp_all)
apply (rule cspF_rw_left)
apply (rule cspF_SKIP_or_DIV)
apply (simp_all)

(* congruence *)
apply (simp add: SP_step_Ext_choice_def)
done

(*--------------------------------------------------*
 |                                                  |
 |  The equality "cspF_fsfF_Ext_choice_eqF" can be  |
 |  proven by using tactics as follows:             |
 |                                                  |
 *--------------------------------------------------*)

(*
lemma "P1 [+] P2 =F P1 [+]seq P2"
apply (simp add: fsfF_Ext_choice_def)
apply (rule cspF_rw_right)
apply (rule cspF_fsfF_induct2_eqF[THEN cspF_sym])
apply (simp_all add: Pfun_Ext_choice_def)
apply (tactic {* cspF_dist_tac 1 *})
apply (tactic {* cspF_dist_tac 1 *})
apply (simp add: SP_step_Ext_choice_def)
apply (elim disjE)
apply (simp_all)

apply ((tactic {* cspF_hsf_tac 1 *})+,
       (rule cspF_decompo), (rule), (simp),
       (simp split: if_split),
       (intro conjI allI impI),
       (tactic {* cspF_simp_tac 1 *})+,
       (rule cspF_fsfF_Int_choice_eqF),
       (tactic {* cspF_simp_tac 1 *}),
       (tactic {* cspF_simp_tac 1 *}))+

apply (simp add: SP_step_Ext_choice_def)
done
*)

(*============================================================*
 |                                                            |
 |                         Timeout                            |
 |                                                            |
 *============================================================*)

definition
  fsfF_Timeout ::
  "('p,'a) proc => ('p,'a) proc => ('p,'a) proc"  ("(1_ /[>seq _)" [73,74] 73)
  where
  fsfF_Timeout_def :
    "P1 [>seq P2 == (P1 |~|seq SSTOP) [+]seq P2"

(*------------------------------------*
 |                 in                 |
 *------------------------------------*)

lemma fsfF_Timeout_in:
  "[| P1 : fsfF_proc ; P2 : fsfF_proc |] ==> P1 [>seq P2 : fsfF_proc"
apply (simp add: fsfF_Timeout_def)
apply (rule fsfF_Ext_choice_in)
apply (rule fsfF_Int_choice_in)
apply (simp_all)
done

(*------------------------------------*
 |                 eqF                |
 *------------------------------------*)

lemma cspF_fsfF_Timeout_eqF:
  "(P1 [> P2) =F (P1 [>seq P2)"
apply (simp add: fsfF_Timeout_def)
apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Ext_choice_eqF[THEN cspF_sym])
apply (rule cspF_decompo)

apply (rule cspF_rw_right)
apply (rule cspF_fsfF_Int_choice_eqF[THEN cspF_sym])
apply (rule cspF_decompo)
apply (rule cspF_reflex)
apply (rule cspF_SSTOP_eqF)
apply (rule cspF_reflex)
done

(****************** to add them again ******************)

declare if_split    [split]
declare disj_not1   [simp]

end


theory Scratch
  imports Main
begin
lemma a:
  assumes "A"
  assumes "B"
  shows "A \<and> B \<Longrightarrow> True"
  using [[simp_trace]]
  apply auto
  done
end


theory Failures_TickTock_Interrupt

imports
  Failures_TickTock
begin

lemma Tock_not_in_set_empty_filter_tocks:
  assumes "[Tock]\<^sub>E \<notin> set xs"
  shows "filter_tocks xs = []"
  using assms by (induct xs rule:filter_tocks.induct, auto)

lemma subset_Ref_trace_TT1_prefix:
  assumes "xs @ [[R]\<^sub>R] \<in> P" "TT1 P" "S \<subseteq> R"
  shows "xs @ [[S]\<^sub>R] \<in> P"
  using assms
  by (meson TT1_def empty_subsetI tt_prefix_subset.simps(1) tt_prefix_subset.simps(2) tt_prefix_subset_same_front)

lemma Tock_not_image_iff_ttevt2F_Set:
  assumes "Tock \<notin> R"
  shows "ttevt2F`{x. ttevt2F x \<in> R} = R"
  using assms unfolding image_def
    apply auto
  by (metis ttevent.exhaust ttevt2F.simps(1) ttevt2F.simps(2))

lemma ttevt2F_eq_Sets_diff_Tock:
  assumes "{x. ttevt2F x \<in> R} = {x. ttevt2F x \<in> Z}"
  shows "R-{Tock} = Z-{Tock}"
proof -
    have "tt2F [[Z]\<^sub>R] = tt2F [[R]\<^sub>R]"
    using assms by force
  then show ?thesis
    by (metis (no_types) DiffE list.inject singletonI tt2F_refusal_eq tt2F_refusal_without_Tock ttobs.inject(2))
qed

lemma Some_tt2F_tt2T:
  assumes "Some (t, b) = tt2F ya"  "t \<noteq> []" "tick \<notin> set (tt2T y)" "\<not>(\<exists>R. [R]\<^sub>R \<in> set y)" "ttWF y"
  shows "Some (tt2T y @ t, b) = tt2F (y @ ya)"
  using assms apply (induct y arbitrary: ya b, auto)
  apply (case_tac a, auto)
  apply (case_tac x1, auto)
  apply (metis (mono_tags, lifting) fst_conv option.simps(5) snd_conv)
  by (metis list.exhaust_sel list.set_intros(1) tt2T.simps(1) ttWF.simps(8))

lemma ttWF_no_Ref_no_Tock:
  assumes "\<not>(\<exists>R. [R]\<^sub>R \<in> set ys)" "ttWF ys"
  shows "[Tock]\<^sub>E \<notin> set ys"
  using assms by (induct ys rule:ttWF.induct, auto)

lemma exists_Refusal_tt2T_concat_Ref_end:
  assumes "\<exists>R. [R]\<^sub>R \<in> set y" "tick \<notin> set (tt2T y)" "ttWF y"
  shows "\<exists>ys R. tt2T y = tt2T (ys@[[R]\<^sub>R]) \<and> \<not>(\<exists>R. [R]\<^sub>R \<in> set ys) \<and> [Tick]\<^sub>E \<notin> set ys \<and> ttWF (ys@[[R]\<^sub>R]) \<and> [Tock]\<^sub>E \<notin> set ys \<and> ys@[[R]\<^sub>R] \<lesssim>\<^sub>C y"
  using assms apply (induct y rule:rev_induct, auto)
  by (smt ttWF_no_Ref_no_Tock Ref_in_concat_lhs Tick_set_ends_in_Tick Un_iff append1_eq_conv set_append ttWF_prefix_is_ttWF tt_prefix_concat tt_prefix_subset_refl tt_prefix_subset_tt_prefix_trans)+

lemma tt2T_Tick_concat_lhs:
  assumes "[Tick]\<^sub>E \<notin> set ys"
  shows "tt2T (ys @ [[Y]\<^sub>R]) = tt2T ys"
  using Ref_in_concat_lhs Tock_in_concat_lhs assms tt2T_concat_dist by fastforce

lemma ttproc2F_InterruptF_failures_subseteq_TimeSyncInterruptTT:
  assumes ttWF_P: "TTwf P" and TT0_P: "TT0 P" and TT1_P: "TT1 P"
      and ttWF_Q: "TTwf Q" and TT0_Q: "TT0 Q" and TT1_Q: "TT1 Q"
  shows "fst ((ttproc2F P) \<triangle>\<^sub>F (ttproc2F Q)) \<subseteq> fst (ttproc2F (P \<triangle>\<^sub>T Q))"
  using assms unfolding ttproc2F_def TimeSyncInterruptTT_def InterruptF_def
proof (auto)
  fix a b y ya
  assume "Some (a, b) = tt2F y"
       "y \<in> P"
       "Some ([], b) = tt2F ya"
       "ya \<in> Q"
  then obtain xs R where xs_X:"y = xs@[[R]\<^sub>R] \<and> tt2T xs = a \<and> b = {x. ttevt2F x \<in> R} \<and> [Tock]\<^sub>E \<notin> set xs \<and> ttWF(xs@[[R]\<^sub>R])"
    using Some_tt2F_concat_refusal by blast
  then obtain Z where "ya = [[Z]\<^sub>R] \<and> Z -{Tock} = R -{Tock}"
    using \<open>Some ([], b) = tt2F ya\<close> tt2F_some_exists ttevt2F_eq_Sets_diff_Tock
    by (smt Some_tt2F_concat_refusal \<open>\<And>thesis. (\<And>xs R. y = xs @ [[R]\<^sub>R] \<and> tt2T xs = a \<and> b = {x. ttevt2F x \<in> R} \<and> [Tock]\<^sub>E \<notin> set xs \<and> ttWF (xs @ [[R]\<^sub>R]) \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> append1_eq_conv tt2F.simps(1) ttobs.inject(2))

  from xs_X show"
       \<exists>ya. tt2F y = tt2F ya \<and>
            ((\<exists>p. p @ [[Tick]\<^sub>E] \<in> P \<and> filter_tocks p \<in> Q \<and> ya = p @ [[Tick]\<^sub>E]) \<or>
             (\<exists>p X. p @ [[X]\<^sub>R] \<in> P \<and>
                    (\<exists>Y. filter_tocks p @ [[Y]\<^sub>R] \<in> Q \<and>
                         (\<exists>Z\<subseteq>X \<union> Y. {e \<in> X. e \<noteq> Tock} = {e \<in> Y. e \<noteq> Tock} \<and> ya = p @ [[Z]\<^sub>R]))) \<or>
             (\<exists>p. p \<in> P \<and>
                  (\<forall>p'. p \<noteq> p' @ [[Tick]\<^sub>E]) \<and>
                  (\<forall>p' Y. p \<noteq> p' @ [[Y]\<^sub>R]) \<and> (\<exists>q2. filter_tocks p @ q2 \<in> Q \<and> (\<forall>q' Y. q2 \<noteq> [Y]\<^sub>R # q') \<and> ya = p @ q2)))"
    apply (rule_tac x="xs@[[R]\<^sub>R]" in exI, auto)
    apply (rule_tac x="xs" in exI, auto)
    apply (rule_tac x="R" in exI, auto)
    using \<open>y \<in> P\<close> TT1_P subset_Ref_trace_TT1_prefix
    apply blast
    apply (rule_tac x="Z" in exI, auto)
    using Tock_not_in_set_empty_filter_tocks
    using \<open>ya = [[Z]\<^sub>R] \<and> Z - {Tock} = R - {Tock}\<close> \<open>ya \<in> Q\<close> by force+
next
  fix b t y ya
  assume assm1:"t \<noteq> []"
  and    assm2:"y \<in> P"
  and    assm3:"Some (t, b) = tt2F ya"
  and    assm4:"ya \<in> Q"
  and    assm5:"tick \<notin> set (tt2T y)"
  then obtain xs R where xs_X:"ya = xs@[[R]\<^sub>R] \<and> tt2T xs = t \<and> b = {x. ttevt2F x \<in> R} \<and> [Tock]\<^sub>E \<notin> set xs \<and> ttWF(xs@[[R]\<^sub>R])"
    using Some_tt2F_concat_refusal by blast

  have tt2T_ya:"tt2T ya = t"
    using assm3 Some_tt2F_imp_tt2T' by blast

  show "\<exists>ya. Some (tt2T y @ t, b) = tt2F ya \<and>
            ((\<exists>p. p @ [[Tick]\<^sub>E] \<in> P \<and> filter_tocks p \<in> Q \<and> ya = p @ [[Tick]\<^sub>E]) \<or>
             (\<exists>p X. p @ [[X]\<^sub>R] \<in> P \<and>
                    (\<exists>Y. filter_tocks p @ [[Y]\<^sub>R] \<in> Q \<and>
                         (\<exists>Z\<subseteq>X \<union> Y. {e \<in> X. e \<noteq> Tock} = {e \<in> Y. e \<noteq> Tock} \<and> ya = p @ [[Z]\<^sub>R]))) \<or>
             (\<exists>p. p \<in> P \<and>
                  (\<forall>p'. p \<noteq> p' @ [[Tick]\<^sub>E]) \<and>
                  (\<forall>p' Y. p \<noteq> p' @ [[Y]\<^sub>R]) \<and> (\<exists>q2. filter_tocks p @ q2 \<in> Q \<and> (\<forall>q' Y. q2 \<noteq> [Y]\<^sub>R # q') \<and> ya = p @ q2)))"
  proof (cases "\<exists>R. [R]\<^sub>R \<in> set y")
    case True (* Can obtain the first refusal somewhere in the trace *)
    then obtain ys Y where ys_Y:"tt2T y = tt2T (ys@[[Y]\<^sub>R]) \<and> \<not>(\<exists>R. [R]\<^sub>R \<in> set ys) \<and> [Tick]\<^sub>E \<notin> set ys \<and> ttWF (ys@[[Y]\<^sub>R]) \<and> [Tock]\<^sub>E \<notin> set ys \<and> ys@[[Y]\<^sub>R] \<lesssim>\<^sub>C y"
      using exists_Refusal_tt2T_concat_Ref_end
      by (metis TTwf_def assm2 assm5 ttWF_P)
    then have "tt2T (ys) @ tt2T ya = tt2T (ys @ ya)"
      by (simp add: tt2T_concat_dist)
    then show ?thesis
      using ys_Y tt2T_ya  apply (rule_tac x="ys@ya" in exI, auto)
      using ys_Y tt2T_Tick_concat_lhs apply (metis Some_concat_extend assm3)
      apply (rule_tac x="ys" in exI, auto)
      apply (rule_tac x="Y" in exI, auto)
      using TT1_P TT1_def assm2 apply blast
      by (smt TT1_P TT1_def Tock_not_in_set_empty_filter_tocks append.left_neutral assm1 assm2 assm4 in_set_conv_decomp tt2T.simps(5) tt_prefix_subset_front)
  next
    case False (* y is only events, no Tocks, Refusals or Ticks *)
    then show ?thesis
      apply (rule_tac x="y@ya" in exI, auto)
      using assm1 assm2 assm5 Some_tt2F_tt2T TTwf_def assm3 ttWF_P apply blast
      using xs_X apply auto
      apply (rule_tac x="y" in exI, auto)
      by (smt Some_tt2F_imp_tt2T' Some_tt2F_no_Tick Some_tt2F_no_Tock Some_tt2F_tt2T TTwf_def Tock_not_in_set_empty_filter_tocks Un_iff append.left_neutral assm1 assm2 assm3 assm4 assm5 list.set_intros(1) set_append tt2T.simps(5) ttWF_P)
  qed
qed

lemma no_Tock_end_Ref_no_Tock_before:
  assumes "p = xs@[[R]\<^sub>R]" "[Tock]\<^sub>E \<notin> set xs"
  shows "[Tock]\<^sub>E \<notin> set p"
  using assms by (induct p arbitrary:, auto)

lemma tt2F_refusal_minus_Tock:
  shows "tt2F (p @ [[Z]\<^sub>R]) = tt2F (p @ [[Z - {Tock}]\<^sub>R])"
  apply (induct p rule:tt2F.induct, auto)
  by (metis evt.exhaust ttevent.distinct(1) ttevent.distinct(5) ttevt2F.simps(1) ttevt2F.simps(2))

lemma ttproc2F_TimeSyncInterruptTT_failures_subseteq_InterruptF:
  assumes TTWF_P: "TTwf P" and TT0_P: "TT0 P" and TT1_P: "TT1 P"
      and TTWF_Q: "TTwf Q" and TT0_Q: "TT0 Q" and TT1_Q: "TT1 Q"
  shows "fst (ttproc2F (P \<triangle>\<^sub>T Q)) \<subseteq> fst ((ttproc2F P) \<triangle>\<^sub>F (ttproc2F Q))"
  using assms unfolding ttproc2F_def TimeSyncInterruptTT_def InterruptF_def
proof (simp_all, safe, blast)
  fix a b y p
  assume "\<nexists>s t. a = s @ t \<and> (\<exists>y. s = tt2T y \<and> y \<in> P) \<and> (\<exists>y. Some (t, b) = tt2F y \<and> y \<in> Q) \<and> t \<noteq> [] \<and> tick \<notin> set s"
         "Some (a, b) = tt2F (p @ [[Tick]\<^sub>E])"
         "p @ [[Tick]\<^sub>E] \<in> P"
         "filter_tocks p \<in> Q"
  then show "\<exists>y. Some ([], b) = tt2F y \<and> y \<in> Q"
    by (meson Some_tt2F_no_Tick Tick_no_eq)
next
  fix a b y p X Y Z
  assume assm1:"\<nexists>s t. a = s @ t \<and> (\<exists>y. s = tt2T y \<and> y \<in> P) \<and> (\<exists>y. Some (t, b) = tt2F y \<and> y \<in> Q) \<and> t \<noteq> [] \<and> tick \<notin> set s"
  and    assm2:"Some (a, b) = tt2F (p @ [[Z]\<^sub>R])"
  and    assm3:"p @ [[X]\<^sub>R] \<in> P"
  and    assm4:"filter_tocks p @ [[Y]\<^sub>R] \<in> Q"
  and    assm5:"Z \<subseteq> X \<union> Y"
  and    assm6:"{e \<in> X. e \<noteq> Tock} = {e \<in> Y. e \<noteq> Tock}"
  then have "Z-{Tock} \<subseteq> X"
    by blast
  then have "p @ [[Z-{Tock}]\<^sub>R] \<in> P"
    using TT1_P \<open>p @ [[X]\<^sub>R] \<in> P\<close> subset_Ref_trace_TT1_prefix by blast
  then show "\<exists>y. Some (a, b) = tt2F y \<and> y \<in> P"
    using assm2 assm3 apply (rule_tac x="p @ [[Z-{Tock}]\<^sub>R]" in exI, simp)
    using tt2F_refusal_minus_Tock by blast
next
  fix a b y p X Y Z
  assume assm1:"\<nexists>s t. a = s @ t \<and> (\<exists>y. s = tt2T y \<and> y \<in> P) \<and> (\<exists>y. Some (t, b) = tt2F y \<and> y \<in> Q) \<and> t \<noteq> [] \<and> tick \<notin> set s"
  and    assm2:"Some (a, b) = tt2F (p @ [[Z]\<^sub>R])"
  and    assm3:"p @ [[X]\<^sub>R] \<in> P"
  and    assm4:"filter_tocks p @ [[Y]\<^sub>R] \<in> Q"
  and    assm5:"Z \<subseteq> X \<union> Y"
  and    assm6:"{e \<in> X. e \<noteq> Tock} = {e \<in> Y. e \<noteq> Tock}"
  then have "[Tock]\<^sub>E \<notin> set p"
    using Some_tt2F_concat_refusal by force
  then have ft_p_Nil:"filter_tocks p = []"
    using Tock_not_in_set_empty_filter_tocks by blast

  have "Z-{Tock} \<subseteq> Y"
    using assm5 assm6 by auto
  then have "[[Z-{Tock}]\<^sub>R] \<in> Q"
    by (metis TT1_Q assm4 eq_Nil_appendI ft_p_Nil subset_Ref_trace_TT1_prefix)
  then show "\<exists>y. Some ([], b) = tt2F y \<and> y \<in> Q"
    using assm2 apply (rule_tac x="[[Z-{Tock}]\<^sub>R]" in exI, simp, safe)
    using Some_tt2F_concat_refusal apply force
     apply (metis evt.exhaust ttevent.distinct(1) ttevent.distinct(5) ttevt2F.simps(1) ttevt2F.simps(2))
    using Some_tt2F_concat_refusal by force
next
  fix a b y p q2
  assume assm1:"\<nexists>s t. a = s @ t \<and> (\<exists>y. s = tt2T y \<and> y \<in> P) \<and> (\<exists>y. Some (t, b) = tt2F y \<and> y \<in> Q) \<and> t \<noteq> [] \<and> tick \<notin> set s"
  and    assm2:"Some (a, b) = tt2F (p @ q2)"
  and    assm3:"p \<in> P"
  and    assm4:"\<forall>p'. p \<noteq> p' @ [[Tick]\<^sub>E]"
  and    assm5:"\<forall>p' Y. p \<noteq> p' @ [[Y]\<^sub>R]"
  and    assm6:"filter_tocks p @ q2 \<in> Q"
  and    assm7:"\<forall>q' Y. q2 \<noteq> [Y]\<^sub>R # q'"
  then have assm8:"\<forall>s t. a = s @ t \<longrightarrow> (\<forall>y. s = tt2T y \<longrightarrow> y \<notin> P) \<or> (\<forall>y. Some (t, b) = tt2F y \<longrightarrow> y \<notin> Q) \<or> t = [] \<or> tick \<in> set s"
    by auto
  then obtain xs R where xs_X:"(p @ q2) = xs@[[R]\<^sub>R] \<and> tt2T xs = a \<and> b = {x. ttevt2F x \<in> R} \<and> [Tock]\<^sub>E \<notin> set xs \<and> ttWF(xs@[[R]\<^sub>R])"
    using assm2 Some_tt2F_concat_refusal by metis
  then have no_Tick_Tock:
              "[Tock]\<^sub>E \<notin> set p"
              "[Tick]\<^sub>E \<notin> set p"
     apply (metis UnCI no_Tock_end_Ref_no_Tock_before set_append)
    using TTWF_P TTwf_def Tick_set_ends_in_Tick assm3 assm4 by auto
  then have "filter_tocks p = []"
    using Tock_not_in_set_empty_filter_tocks by blast
  then have q2_in_Q:"q2 \<in> Q"
    using assm6 by auto

  then have no_Tick:"tick \<notin> set (tt2T p)"
    using Tick_set_tt2T_in no_Tick_Tock by blast
  then have a_p_q2:"a = (tt2T p) @ (tt2T q2)"
    using no_Tick_Tock by (metis Some_tt2F_imp_tt2T' Some_tt2F_no_prev_refusals TTWF_P TTwf_def assm2 assm3 assm4 assm5 nontick_event_end_append_wf tt2T_concat_dist ttWF.simps(2) ttWF_tt2F_last_refusal_concat)
  then have "(tt2T p) \<noteq> []"
            "(tt2T q2) \<noteq> []"
     apply (metis TTWF_P TTwf_def Tick_set_tt2T_in Tock_not_in_set_empty_filter_tocks \<open>[Tick]\<^sub>E \<notin> set p\<close> \<open>[Tock]\<^sub>E \<notin> set p\<close> append_self_conv2 assm1 assm2 assm3 assm4 assm5 assm6 assm7 nontick_event_end_append_wf tt2F_Some_concat_Nil ttWF.simps(2) ttWF_tt2F_last_refusal_concat xs_X)
  proof -
    obtain tts :: "'a ttobs list \<Rightarrow> 'a ttobs list" and TT :: "'a ttobs list \<Rightarrow> 'a ttevent set" where
      f1: "\<forall>x1. (\<exists>v2 v3. x1 = v2 @ [[v3]\<^sub>R]) = (x1 = tts x1 @ [[TT x1]\<^sub>R])"
      by moura
    obtain ttsa :: "'a ttobs list \<Rightarrow> 'a ttobs list" where
      "\<forall>x1. (\<exists>v2. x1 = v2 @ [[Tick]\<^sub>E]) = (x1 = ttsa x1 @ [[Tick]\<^sub>E])"
      by moura
    then have f2: "\<forall>ts tsa. (\<not> ttWF ts \<or> \<not> ttWF tsa \<or> ts = ttsa ts @ [[Tick]\<^sub>E] \<or> ts = tts ts @ [[TT ts]\<^sub>R]) \<or> ttWF (ts @ tsa)"
      using f1 by (meson nontick_event_end_append_wf)
    have "q2 \<noteq> ttsa q2 @ [[Tick]\<^sub>E]"
      by (metis Some_tt2F_no_Tick UnCI \<open>\<And>thesis. (\<And>xs R. p @ q2 = xs @ [[R]\<^sub>R] \<and> tt2T xs = a \<and> b = {x. ttevt2F x \<in> R} \<and> [Tock]\<^sub>E \<notin> set xs \<and> ttWF (xs @ [[R]\<^sub>R]) \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> in_set_conv_decomp set_append ttWF_tt2F_last_refusal_concat)
    then show "tt2T q2 \<noteq> []"
      using f2 by (metis Some_tt2F_imp_tt2T' TTWF_Q TTwf_def Tock_not_in_set_empty_filter_tocks UnCI \<open>\<And>thesis. (\<And>xs R. p @ q2 = xs @ [[R]\<^sub>R] \<and> tt2T xs = a \<and> b = {x. ttevt2F x \<in> R} \<and> [Tock]\<^sub>E \<notin> set xs \<and> ttWF (xs @ [[R]\<^sub>R]) \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> append_Nil2 append_self_conv2 assm5 assm6 assm7 no_Tock_end_Ref_no_Tock_before set_append tt2F_Some_concat_Nil ttWF.simps(2) ttWF_tt2F_last_refusal_concat)
  qed
  then have "(\<forall>y. (tt2T p) = tt2T y \<longrightarrow> y \<notin> P) \<or> (\<forall>y. Some ((tt2T q2), b) = tt2F y \<longrightarrow> y \<notin> Q) "
    using assm8 a_p_q2 no_Tick by auto
  then have "p \<notin> P \<or> q2 \<notin> Q"
  proof -
    have "Some ((tt2T q2), b) = tt2F q2"
      using xs_X assm2 assm4 assm5 assm7 apply (induct q2 rule:rev_induct, simp, safe)
      using \<open>tt2T q2 \<noteq> []\<close> tt2T.simps(3)
      by (smt Ref_in_concat_lhs TTWF_Q TTwf_def Tock_not_in_set_empty_filter_tocks Un_iff \<open>\<And>thesis. (\<And>xs R. p @ q2 = xs @ [[R]\<^sub>R] \<and> tt2T xs = a \<and> b = {x. ttevt2F x \<in> R} \<and> [Tock]\<^sub>E \<notin> set xs \<and> ttWF (xs @ [[R]\<^sub>R]) \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> a_p_q2 append_self_conv2 assm6 butlast_append butlast_snoc last_appendR last_snoc no_Tick_Tock(2) same_append_eq self_append_conv set_append tt2T_concat_dist ttWF_tt2F_last_refusal_concat)
    then show ?thesis
      using \<open>tt2T q2 \<noteq> []\<close> a_p_q2 assm8 no_Tick by blast
  qed
  then have "False"
    using assm3 q2_in_Q by auto
   then show "\<exists>y. Some (a, b) = tt2F y \<and> y \<in> P"
     by auto
next
  fix a b y p q2
  assume assm1:"\<nexists>s t. a = s @ t \<and> (\<exists>y. s = tt2T y \<and> y \<in> P) \<and> (\<exists>y. Some (t, b) = tt2F y \<and> y \<in> Q) \<and> t \<noteq> [] \<and> tick \<notin> set s"
  and    assm2:"Some (a, b) = tt2F (p @ q2)"
  and    assm3:"p \<in> P"
  and    assm4:"\<forall>p'. p \<noteq> p' @ [[Tick]\<^sub>E]"
  and    assm5:"\<forall>p' Y. p \<noteq> p' @ [[Y]\<^sub>R]"
  and    assm6:"filter_tocks p @ q2 \<in> Q"
  and    assm7:"\<forall>q' Y. q2 \<noteq> [Y]\<^sub>R # q'"
  then have assm8:"\<forall>s t. a = s @ t \<longrightarrow> (\<forall>y. s = tt2T y \<longrightarrow> y \<notin> P) \<or> (\<forall>y. Some (t, b) = tt2F y \<longrightarrow> y \<notin> Q) \<or> t = [] \<or> tick \<in> set s"
    by auto
  then obtain xs R where xs_X:"(p @ q2) = xs@[[R]\<^sub>R] \<and> tt2T xs = a \<and> b = {x. ttevt2F x \<in> R} \<and> [Tock]\<^sub>E \<notin> set xs \<and> ttWF(xs@[[R]\<^sub>R])"
    using assm2 Some_tt2F_concat_refusal by metis
  then have no_Tick_Tock:
              "[Tock]\<^sub>E \<notin> set p"
              "[Tick]\<^sub>E \<notin> set p"
     apply (metis UnCI no_Tock_end_Ref_no_Tock_before set_append)
    using TTWF_P TTwf_def Tick_set_ends_in_Tick assm3 assm4 by auto
  then have "filter_tocks p = []"
    using Tock_not_in_set_empty_filter_tocks by blast
  then have q2_in_Q:"q2 \<in> Q"
    using assm6 by auto

  then have no_Tick:"tick \<notin> set (tt2T p)"
    using Tick_set_tt2T_in no_Tick_Tock by blast
  then have a_p_q2:"a = (tt2T p) @ (tt2T q2)"
    using no_Tick_Tock by (metis Some_tt2F_imp_tt2T' Some_tt2F_no_prev_refusals TTWF_P TTwf_def assm2 assm3 assm4 assm5 nontick_event_end_append_wf tt2T_concat_dist ttWF.simps(2) ttWF_tt2F_last_refusal_concat)
  then have "(tt2T p) \<noteq> []"
            "(tt2T q2) \<noteq> []"
     apply (metis TTWF_P TTwf_def Tick_set_tt2T_in Tock_not_in_set_empty_filter_tocks \<open>[Tick]\<^sub>E \<notin> set p\<close> \<open>[Tock]\<^sub>E \<notin> set p\<close> append_self_conv2 assm1 assm2 assm3 assm4 assm5 assm6 assm7 nontick_event_end_append_wf tt2F_Some_concat_Nil ttWF.simps(2) ttWF_tt2F_last_refusal_concat xs_X)
  proof -
    obtain tts :: "'a ttobs list \<Rightarrow> 'a ttobs list" and TT :: "'a ttobs list \<Rightarrow> 'a ttevent set" where
      f1: "\<forall>x1. (\<exists>v2 v3. x1 = v2 @ [[v3]\<^sub>R]) = (x1 = tts x1 @ [[TT x1]\<^sub>R])"
      by moura
    obtain ttsa :: "'a ttobs list \<Rightarrow> 'a ttobs list" where
      "\<forall>x1. (\<exists>v2. x1 = v2 @ [[Tick]\<^sub>E]) = (x1 = ttsa x1 @ [[Tick]\<^sub>E])"
      by moura
    then have f2: "\<forall>ts tsa. (\<not> ttWF ts \<or> \<not> ttWF tsa \<or> ts = ttsa ts @ [[Tick]\<^sub>E] \<or> ts = tts ts @ [[TT ts]\<^sub>R]) \<or> ttWF (ts @ tsa)"
      using f1 by (meson nontick_event_end_append_wf)
    have "q2 \<noteq> ttsa q2 @ [[Tick]\<^sub>E]"
      by (metis Some_tt2F_no_Tick UnCI \<open>\<And>thesis. (\<And>xs R. p @ q2 = xs @ [[R]\<^sub>R] \<and> tt2T xs = a \<and> b = {x. ttevt2F x \<in> R} \<and> [Tock]\<^sub>E \<notin> set xs \<and> ttWF (xs @ [[R]\<^sub>R]) \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> in_set_conv_decomp set_append ttWF_tt2F_last_refusal_concat)
    then show "tt2T q2 \<noteq> []"
      using f2 by (metis Some_tt2F_imp_tt2T' TTWF_Q TTwf_def Tock_not_in_set_empty_filter_tocks UnCI \<open>\<And>thesis. (\<And>xs R. p @ q2 = xs @ [[R]\<^sub>R] \<and> tt2T xs = a \<and> b = {x. ttevt2F x \<in> R} \<and> [Tock]\<^sub>E \<notin> set xs \<and> ttWF (xs @ [[R]\<^sub>R]) \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> append_Nil2 append_self_conv2 assm5 assm6 assm7 no_Tock_end_Ref_no_Tock_before set_append tt2F_Some_concat_Nil ttWF.simps(2) ttWF_tt2F_last_refusal_concat)
  qed
  then have "(\<forall>y. (tt2T p) = tt2T y \<longrightarrow> y \<notin> P) \<or> (\<forall>y. Some ((tt2T q2), b) = tt2F y \<longrightarrow> y \<notin> Q) "
    using assm8 a_p_q2 no_Tick by auto
  then have "p \<notin> P \<or> q2 \<notin> Q"
  proof -
    have "Some ((tt2T q2), b) = tt2F q2"
      using xs_X assm2 assm4 assm5 assm7 apply (induct q2 rule:rev_induct, simp, safe)
      using \<open>tt2T q2 \<noteq> []\<close> tt2T.simps(3)
      by (smt Ref_in_concat_lhs TTWF_Q TTwf_def Tock_not_in_set_empty_filter_tocks Un_iff \<open>\<And>thesis. (\<And>xs R. p @ q2 = xs @ [[R]\<^sub>R] \<and> tt2T xs = a \<and> b = {x. ttevt2F x \<in> R} \<and> [Tock]\<^sub>E \<notin> set xs \<and> ttWF (xs @ [[R]\<^sub>R]) \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> a_p_q2 append_self_conv2 assm6 butlast_append butlast_snoc last_appendR last_snoc no_Tick_Tock(2) same_append_eq self_append_conv set_append tt2T_concat_dist ttWF_tt2F_last_refusal_concat)
    then show ?thesis
      using \<open>tt2T q2 \<noteq> []\<close> a_p_q2 assm8 no_Tick by blast
  qed
  then have "False"
    using assm3 q2_in_Q by auto
   then show "\<exists>y. Some ([], b) = tt2F y \<and> y \<in> Q"
     by auto
  qed

lemma ttproc2F_TimeSyncInterruptTT_traces_subseteq_InterruptF:
  assumes TTWF_P: "TTwf P" and TT0_P: "TT0 P" and TT1_P: "TT1 P"
      and TTWF_Q: "TTwf Q" and TT0_Q: "TT0 Q" and TT1_Q: "TT1 Q"
  shows "snd (ttproc2F (P \<triangle>\<^sub>T Q)) \<subseteq> snd ((ttproc2F P) \<triangle>\<^sub>F (ttproc2F Q))"
  using assms unfolding ttproc2F_def TimeSyncInterruptTT_def InterruptF_def
proof (simp_all, safe, blast)
  fix x y p X Y Z
  assume assm1:"\<nexists>s t. tt2T (p @ [[Z]\<^sub>R]) = s @ t \<and> tick \<notin> set s \<and> (\<exists>y. s = tt2T y \<and> y \<in> P) \<and> (\<exists>y. t = tt2T y \<and> y \<in> Q)"
  and    assm2:"p @ [[X]\<^sub>R] \<in> P"
  and    assm3:"filter_tocks p @ [[Y]\<^sub>R] \<in> Q"
  and    assm4:"Z \<subseteq> X \<union> Y"
  and    assm5:"{e \<in> X. e \<noteq> Tock} = {e \<in> Y. e \<noteq> Tock}"
  then show "\<exists>y. tt2T (p @ [[Z]\<^sub>R]) = tt2T y \<and> y \<in> P"
    by (metis TTWF_P TTwf_concat_prefix_of_ref_set_no_Tick tt2T_Tick_concat_lhs)
next
  fix x y p q2
  assume assm1:"\<nexists>s t. tt2T (p @ q2) = s @ t \<and> tick \<notin> set s \<and> (\<exists>y. s = tt2T y \<and> y \<in> P) \<and> (\<exists>y. t = tt2T y \<and> y \<in> Q)"
  and    assm2:"p \<in> P"
  and    assm3:"\<forall>p'. p \<noteq> p' @ [[Tick]\<^sub>E]"
  and    assm4:"\<forall>p' Y. p \<noteq> p' @ [[Y]\<^sub>R]"
  and    assm5:"filter_tocks p @ q2 \<in> Q"
  and    assm6:"\<forall>q' Y. q2 \<noteq> [Y]\<^sub>R # q'"
  then show "\<exists>y. tt2T (p @ q2) = tt2T y \<and> y \<in> P"
    by (metis Ref_in_concat_lhs TTWF_P TTwf_def Tick_set_ends_in_Tick Tick_set_tt2T_in Tock_in_concat_lhs Tock_not_in_set_empty_filter_tocks append_self_conv2 tt2T_concat_dist)
qed

lemma Refusal_in_lhs_concat_tt2T:
  assumes "[R]\<^sub>R \<in> set xs"
  shows "tt2T (xs @ [[Event ev]\<^sub>E]) = tt2T xs"
  using assms by (induct xs rule:tt2T.induct, auto)

lemma last_event_prefix_in_set:
  assumes "p @ [[e]\<^sub>E] \<lesssim>\<^sub>C xs"
  shows "[e]\<^sub>E \<in> set xs"
  using assms apply (induct p xs rule:tt_prefix_subset.induct, auto)
  using tt_prefix_subset.elims(2) by fastforce

lemma last_Ref_prefix_in_set:
  assumes "p @ [[R]\<^sub>R] \<lesssim>\<^sub>C xs"
  shows "\<exists>R. [R]\<^sub>R \<in> set xs"
  using assms apply (induct p xs rule:tt_prefix_subset.induct, auto)
  by (metis list.exhaust list.set_intros(1) tt_prefix_subset.simps(1) tt_prefix_subset.simps(5) tt_prefix_subset_antisym ttobs.exhaust)

lemma ttproc2F_InterruptF_traces_subseteq_TimeSyncInterruptTT:
  assumes ttWF_P: "TTwf P" and TT0_P: "TT0 P" and TT1_P: "TT1 P"
      and ttWF_Q: "TTwf Q" and TT0_Q: "TT0 Q" and TT1_Q: "TT1 Q"
  shows "snd ((ttproc2F P) \<triangle>\<^sub>F (ttproc2F Q)) \<subseteq> snd (ttproc2F (P \<triangle>\<^sub>T Q))"
  using assms unfolding ttproc2F_def TimeSyncInterruptTT_def InterruptF_def
proof (auto)
  fix y
  assume y_in_P:"y \<in> P"

  text \<open> Here the issue is splitting cases on y:

         When y ends on tick; ends with a Refusal; is events only;
         For each of these get the actual trace before such an element,
         and then prove. \<close>

  have ttWF_y:"ttWF y"
    using TTwf_def \<open>y \<in> P\<close> ttWF_P by blast

  have "\<exists>ya. tt2T y = tt2T ya \<and>
            ((\<exists>p. p @ [[Tick]\<^sub>E] \<lesssim>\<^sub>C y \<and> filter_tocks p \<in> Q \<and> ya = p @ [[Tick]\<^sub>E]) \<or>
             (\<exists>p X. p @ [[X]\<^sub>R] \<lesssim>\<^sub>C y \<and>
                    (\<exists>Y. filter_tocks p @ [[Y]\<^sub>R] \<in> Q \<and>
                         (\<exists>Z\<subseteq>X \<union> Y. {e \<in> X. e \<noteq> Tock} = {e \<in> Y. e \<noteq> Tock} \<and> ya = p @ [[Z]\<^sub>R]))) \<or>
             (\<exists>p. p \<lesssim>\<^sub>C y \<and>
                  (\<forall>p'. p \<noteq> p' @ [[Tick]\<^sub>E]) \<and>
                  (\<forall>p' Y. p \<noteq> p' @ [[Y]\<^sub>R]) \<and> (\<exists>q2. filter_tocks p @ q2 \<in> Q \<and> (\<forall>q' Y. q2 \<noteq> [Y]\<^sub>R # q') \<and> ya = p @ q2)))"
    using ttWF_y
  proof (cases "\<exists>R. [R]\<^sub>R \<in> set y")
    case True (* Can obtain the first refusal somewhere in the trace *)
    then obtain ys Y where ys_Y:"tt2T y = tt2T (ys@[[Y]\<^sub>R]) \<and> \<not>(\<exists>R. [R]\<^sub>R \<in> set ys) \<and> [Tick]\<^sub>E \<notin> set ys \<and> ttWF (ys@[[Y]\<^sub>R]) \<and> [Tock]\<^sub>E \<notin> set ys \<and> ys@[[Y]\<^sub>R] \<lesssim>\<^sub>C y"
      by (smt Tick_set_ends_in_Tick Tick_set_tt2T_in Tock_in_trace_Refusal_no_Tick UnE empty_set exists_Refusal_tt2T_concat_Ref_end list.simps(15) set_append singletonD ttWF_y ttobs.distinct(1))
    then have "\<exists>ya. tt2T y = tt2T ya \<and> (\<exists>p. p \<lesssim>\<^sub>C y \<and>
                  (\<forall>p'. p \<noteq> p' @ [[Tick]\<^sub>E]) \<and>
                  (\<forall>p' Y. p \<noteq> p' @ [[Y]\<^sub>R]) \<and> (\<exists>q2. filter_tocks p @ q2 \<in> Q \<and> (\<forall>q' Y. q2 \<noteq> [Y]\<^sub>R # q') \<and> ya = p @ q2))"
      apply auto
      by (metis TT0_Q TT0_TT1_empty TT1_Q Tock_not_in_set_empty_filter_tocks append_Nil2 in_set_conv_decomp tt2T_Tick_concat_lhs tt_prefix_subset_front)
    then show ?thesis
      by blast
  next
    case no_Ref:False
    then show ?thesis
    proof (cases "[Tick]\<^sub>E \<in> set y")
      case True
      then show ?thesis
        by (metis (no_types, hide_lams) no_Ref TT0_Q TT0_TT1_empty TT1_Q Tick_set_ends_in_Tick Tock_not_in_set_empty_filter_tocks filter_tocks_end_tick ttWF_no_Ref_no_Tock ttWF_y tt_prefix_subset_refl)
    next
      case False
      then have "\<exists>ya. (\<exists>p. p \<lesssim>\<^sub>C y \<and>
                  (\<forall>p'. p \<noteq> p' @ [[Tick]\<^sub>E]) \<and>
                  (\<forall>p' Y. p \<noteq> p' @ [[Y]\<^sub>R]) \<and> (\<exists>q2. filter_tocks p @ q2 \<in> Q \<and> (\<forall>q' Y. q2 \<noteq> [Y]\<^sub>R # q') \<and> ya = p @ q2))"
        apply (rule_tac x="y" in exI, auto)
        apply (rule_tac x="y" in exI, auto)
        using tt_prefix_subset_refl apply blast
        using no_Ref apply auto
        by (simp add: TT0_Q TT0_TT1_empty TT1_Q Tock_not_in_set_empty_filter_tocks ttWF_no_Ref_no_Tock ttWF_y)
      then show ?thesis
        by (metis (no_types, hide_lams) False TT0_Q TT0_TT1_empty TT1_Q Tock_not_in_set_empty_filter_tocks append_Nil2 in_set_conv_decomp no_Ref ttWF_no_Ref_no_Tock ttWF_y tt_prefix_subset_refl)
    qed
  qed

  then show "\<exists>ya. tt2T y = tt2T ya \<and>
              ((\<exists>p. p @ [[Tick]\<^sub>E] \<in> P \<and> filter_tocks p \<in> Q \<and> ya = p @ [[Tick]\<^sub>E]) \<or>
               (\<exists>p X. p @ [[X]\<^sub>R] \<in> P \<and>
                      (\<exists>Y. filter_tocks p @ [[Y]\<^sub>R] \<in> Q \<and>
                           (\<exists>Z\<subseteq>X \<union> Y. {e \<in> X. e \<noteq> Tock} = {e \<in> Y. e \<noteq> Tock} \<and> ya = p @ [[Z]\<^sub>R]))) \<or>
               (\<exists>p. p \<in> P \<and>
                    (\<forall>p'. p \<noteq> p' @ [[Tick]\<^sub>E]) \<and>
                    (\<forall>p' Y. p \<noteq> p' @ [[Y]\<^sub>R]) \<and> (\<exists>q2. filter_tocks p @ q2 \<in> Q \<and> (\<forall>q' Y. q2 \<noteq> [Y]\<^sub>R # q') \<and> ya = p @ q2)))"
    using TT1_P y_in_P apply safe
    apply (simp_all)
    using TT1_def by smt+
next
  fix y ya
  assume assm1:"y \<in> P"
  and    assm2:"ya \<in> Q"
  and    assm3:"tick \<notin> set (tt2T y)"

  have ttWF_y:"ttWF y"
    using TTwf_def \<open>y \<in> P\<close> ttWF_P by blast

  have "\<exists>yb. tt2T y @ tt2T ya = tt2T yb \<and>
            ((\<exists>p. p @ [[Tick]\<^sub>E] \<lesssim>\<^sub>C y \<and> filter_tocks p \<in> Q \<and> yb = p @ [[Tick]\<^sub>E]) \<or>
             (\<exists>p X. p @ [[X]\<^sub>R] \<lesssim>\<^sub>C y \<and>
                    (\<exists>Y. filter_tocks p @ [[Y]\<^sub>R] \<in> Q \<and>
                         (\<exists>Z\<subseteq>X \<union> Y. {e \<in> X. e \<noteq> Tock} = {e \<in> Y. e \<noteq> Tock} \<and> yb = p @ [[Z]\<^sub>R]))) \<or>
             (\<exists>p. p \<lesssim>\<^sub>C y \<and>
                  (\<forall>p'. p \<noteq> p' @ [[Tick]\<^sub>E]) \<and>
                  (\<forall>p' Y. p \<noteq> p' @ [[Y]\<^sub>R]) \<and> (\<exists>q2. filter_tocks p @ q2 \<in> Q \<and> (\<forall>q' Y. q2 \<noteq> [Y]\<^sub>R # q') \<and> yb = p @ q2)))"
  proof (cases "\<exists>R. [R]\<^sub>R \<in> set y")
    case True (* Can obtain the first refusal somewhere in the trace *)
    then obtain ys Y where ys_Y:"tt2T y = tt2T (ys@[[Y]\<^sub>R]) \<and> \<not>(\<exists>R. [R]\<^sub>R \<in> set ys) \<and> [Tick]\<^sub>E \<notin> set ys \<and> ttWF (ys@[[Y]\<^sub>R]) \<and> [Tock]\<^sub>E \<notin> set ys \<and> ys@[[Y]\<^sub>R] \<lesssim>\<^sub>C y"
      using exists_Refusal_tt2T_concat_Ref_end
      using assm3 ttWF_y by blast
    then have "tt2T y = tt2T ys"
              "tt2T (ys) @ tt2T ya = tt2T (ys @ ya)"
       apply (simp add: tt2T_Tick_concat_lhs)
       using ys_Y by (simp add: tt2T_concat_dist)
    then have "\<exists>yb. tt2T y @ tt2T ya = tt2T yb \<and> (\<exists>p. p \<lesssim>\<^sub>C y \<and>
               (\<forall>p'. p \<noteq> p' @ [[Tick]\<^sub>E]) \<and>
               (\<forall>p' Y. p \<noteq> p' @ [[Y]\<^sub>R]) \<and> (\<exists>q2. filter_tocks p @ q2 \<in> Q \<and> (\<forall>q' Y. q2 \<noteq> [Y]\<^sub>R # q') \<and> yb = p @ q2))"
      by (metis (no_types, hide_lams) TT0_Q TT0_TT1_empty TT1_Q Tock_not_in_set_empty_filter_tocks append_Nil append_Nil2 assm2 in_set_conv_decomp tt2T.simps(5) tt_prefix_subset_front ys_Y)
    then show ?thesis
      by blast
  next
    case no_Ref:False
    then show ?thesis
    proof (cases "[Tick]\<^sub>E \<in> set y")
      case True
      then show ?thesis using assm3
        by (smt TTwf_concat_prefix_set_no_Tick TTwf_def Tick_set_ends_in_Tick Un_iff assm1 in_set_conv_decomp no_Ref set_append tt2T.simps(1) tt2T_concat_dist ttWF_P ttWF_no_Ref_no_Tock)
    next
      case False
      then have "\<exists>yb. tt2T y @ tt2T ya = tt2T yb \<and> (\<exists>p. p \<lesssim>\<^sub>C y \<and>
                  (\<forall>p'. p \<noteq> p' @ [[Tick]\<^sub>E]) \<and>
                  (\<forall>p' Y. p \<noteq> p' @ [[Y]\<^sub>R]) \<and> (\<exists>q2. filter_tocks p @ q2 \<in> Q \<and> (\<forall>q' Y. q2 \<noteq> [Y]\<^sub>R # q') \<and> yb = p @ q2))"
        by (metis TT0_Q TT0_TT1_empty TT1_Q Tock_not_in_set_empty_filter_tocks append.left_neutral assm2 last_in_set list.distinct(1) no_Ref snoc_eq_iff_butlast tt2T.simps(3) tt2T.simps(5) tt2T_concat_dist ttWF_no_Ref_no_Tock ttWF_y tt_prefix_subset_refl)
      then show ?thesis
        by blast
    qed
  qed

  then show "\<exists>yb. tt2T y @ tt2T ya = tt2T yb \<and>
            ((\<exists>p. p @ [[Tick]\<^sub>E] \<in> P \<and> filter_tocks p \<in> Q \<and> yb = p @ [[Tick]\<^sub>E]) \<or>
             (\<exists>p X. p @ [[X]\<^sub>R] \<in> P \<and>
                    (\<exists>Y. filter_tocks p @ [[Y]\<^sub>R] \<in> Q \<and>
                         (\<exists>Z\<subseteq>X \<union> Y. {e \<in> X. e \<noteq> Tock} = {e \<in> Y. e \<noteq> Tock} \<and> yb = p @ [[Z]\<^sub>R]))) \<or>
             (\<exists>p. p \<in> P \<and>
                  (\<forall>p'. p \<noteq> p' @ [[Tick]\<^sub>E]) \<and>
                  (\<forall>p' Y. p \<noteq> p' @ [[Y]\<^sub>R]) \<and> (\<exists>q2. filter_tocks p @ q2 \<in> Q \<and> (\<forall>q' Y. q2 \<noteq> [Y]\<^sub>R # q') \<and> yb = p @ q2)))"
    using TT1_P assm1 apply safe
    apply (simp_all)
    using TT1_def by smt+
qed

lemma ttproc2F_InterruptF_eq_TimeSyncInterruptTT:
  assumes ttWF_P: "TTwf P" and TT0_P: "TT0 P" and TT1_P: "TT1 P"
      and ttWF_Q: "TTwf Q" and TT0_Q: "TT0 Q" and TT1_Q: "TT1 Q"
  shows "((ttproc2F P) \<triangle>\<^sub>F (ttproc2F Q)) = (ttproc2F (P \<triangle>\<^sub>T Q))"
  using assms
  by (metis dual_order.antisym prod.collapse ttproc2F_InterruptF_failures_subseteq_TimeSyncInterruptTT ttproc2F_InterruptF_traces_subseteq_TimeSyncInterruptTT ttproc2F_TimeSyncInterruptTT_failures_subseteq_InterruptF ttproc2F_TimeSyncInterruptTT_traces_subseteq_InterruptF)

end


theory IO
  imports
    Main
    "HOL-Library.Monad_Syntax"
begin

section\<open>IO Monad\<close>
text \<open>
  Inspired by Haskell.
  Definitions from \<^url>\<open>https://wiki.haskell.org/IO_inside\<close>
\<close>

subsection\<open>Real World\<close>
text \<open>
  We model the real world with a fake type.

  WARNING:
    Using low-level commands such as \<^theory_text>\<open>typedecl\<close> instead of high-level \<^theory_text>\<open>datatype\<close> is dangerous.
    We explicitly use a \<^theory_text>\<open>typedecl\<close> instead of a \<^theory_text>\<open>datatype\<close> because we never want to instantiate
    the world. We don't need a constructor, we just need the type.

  The following models an arbitrary type we cannot reason about.
  Don't reason about the complete world! Only write down some assumptions about parts of the world.
\<close>
typedecl real_world (\<open>\<^url>\<close>)

text\<open>
  For examples, see \<^file>\<open>HelloWorld_Proof.thy\<close>.
  In said theory, we model \<^verbatim>\<open>STDIN\<close> and \<^verbatim>\<open>STDOUT\<close> as parts of the world and describe how this part
  of the wold can be affected. We don't model the rest of the world. This allows us to reason about
  \<^verbatim>\<open>STDIN\<close> and \<^verbatim>\<open>STDOUT\<close> as part of the world, but nothing more.
\<close>

subsection\<open>IO Monad\<close>
text \<open>
  The set of all functions which take a \<^typ>\<open>\<^url>\<close> and return an \<^typ>\<open>'\<alpha>\<close> and a \<^typ>\<open>\<^url>\<close>.

  The rough idea of all IO functions is the following: You are given the world in its current state.
  You can do whatever you like to the world. You can produce some value of type \<^typ>\<open>'\<alpha>\<close> and you
  have to return the modified world.

  For example, the \<^verbatim>\<open>main\<close> function is Haskell does not produce a value, therefore, \<^verbatim>\<open>main\<close> in
  Haskell is of type \<^verbatim>\<open>IO ()\<close>. Another example in Haskell is \<^verbatim>\<open>getLine\<close>, which returns \<^verbatim>\<open>String\<close>.
  It's type in Haskell is \<^verbatim>\<open>IO String\<close>. All those functions may also modify the state of the world.
\<close>

typedef '\<alpha> io = "UNIV :: (\<^url> \<Rightarrow> '\<alpha> \<times> \<^url>) set"
proof -
  show "\<exists>x. x \<in> UNIV" by simp
qed

text \<open>
  Related Work:
  \<^emph>\<open>Programming TLS in Isabelle/HOL\<close> by Andreas Lochbihler and Marc Züst uses a partial function
  (\<open>\<rightharpoonup>\<close>).
  \<^theory_text>\<open>
    typedecl real_world
    typedef '\<alpha> io = "UNIV :: (\<^url> \<rightharpoonup> '\<alpha> \<times> \<^url>) set" by simp
  \<close>
  We use a total function. This implies the dangerous assumption that all IO functions are total
  (i.e., terminate).
\<close>

text \<open>
  The \<^theory_text>\<open>typedef\<close> above gives us some convenient definitions.
  Since the model of \<^typ>\<open>'\<alpha> io\<close> is just a mode, those definitions should not end up in generated
  code.
\<close>
term Abs_io \<comment> \<open>Takes a \<^typ>\<open>(\<^url> \<Rightarrow> '\<alpha> \<times> \<^url>)\<close> and abstracts it to an \<^typ>\<open>'\<alpha> io\<close>.\<close>
term Rep_io \<comment> \<open>Unpacks an \<^typ>\<open>'\<alpha> io\<close> to a \<^typ>\<open>(\<^url> \<Rightarrow> '\<alpha> \<times> \<^url>)\<close>\<close>

subsection\<open>Monad Operations\<close>
text\<open>
  Within an \<^typ>\<open>'\<alpha> io\<close> context, execute \<^term>\<open>action\<^sub>1\<close> and \<^term>\<open>action\<^sub>2\<close> sequentially.
  The world is passed through and potentially modified by each action.
\<close>
definition bind :: "'\<alpha> io \<Rightarrow> ('\<alpha> \<Rightarrow> '\<beta> io) \<Rightarrow> '\<beta> io" where [code del]:
  "bind action\<^sub>1 action\<^sub>2 = Abs_io (\<lambda>world\<^sub>0.
                                  let (a, world\<^sub>1) = (Rep_io action\<^sub>1) world\<^sub>0;
                                      (b, world\<^sub>2) = (Rep_io (action\<^sub>2 a)) world\<^sub>1
                                  in (b, world\<^sub>2))"

text \<open>
  In Haskell, the definition for \<^verbatim>\<open>bind\<close> (\<^verbatim>\<open>>>=\<close>) is:
  \<^verbatim>\<open>
    (>>=) :: IO a -> (a -> IO b) -> IO b
    (action1 >>= action2) world0 =
       let (a, world1) = action1 world0
           (b, world2) = action2 a world1
       in (b, world2)
  \<close>
\<close>

hide_const (open) bind
adhoc_overloading bind IO.bind

text \<open>Thanks to \<^theory_text>\<open>adhoc_overloading\<close>, we can use monad syntax.\<close>
lemma "bind (foo :: '\<alpha> io) (\<lambda>a. bar a) = foo \<bind> (\<lambda>a. bar a)"
  by simp

definition return :: "'\<alpha> \<Rightarrow> '\<alpha> io" where [code del]:
  "return a \<equiv> Abs_io (\<lambda>world. (a, world))"

hide_const (open) return

text \<open>
  In Haskell, the definition for \<^verbatim>\<open>return\<close> is::
  \<^verbatim>\<open>
    return :: a -> IO a
    return a world0  =  (a, world0)
  \<close>
\<close>

subsection\<open>Monad Laws\<close>
lemma left_id:
  fixes f :: "'\<alpha> \<Rightarrow> '\<beta> io" \<comment> \<open>Make sure we use our \<^const>\<open>IO.bind\<close>.\<close>
  shows "(IO.return a \<bind> f) = f a"
  by(simp add: return_def IO.bind_def Abs_io_inverse Rep_io_inverse)

lemma right_id:
  fixes m :: "'\<alpha> io" \<comment> \<open>Make sure we use our \<^const>\<open>IO.bind\<close>.\<close>
  shows "(m \<bind> IO.return) = m"
  by(simp add: return_def IO.bind_def Abs_io_inverse Rep_io_inverse)

lemma bind_assoc:
  fixes m :: "'\<alpha> io" \<comment> \<open>Make sure we use our \<^const>\<open>IO.bind\<close>.\<close>
  shows "((m \<bind> f) \<bind> g) = (m \<bind> (\<lambda>x. f x \<bind> g))"
  by(simp add: IO.bind_def Abs_io_inverse Abs_io_inject fun_eq_iff split: prod.splits)

subsection\<open>Code Generator Setup\<close>
text \<open>
  We don't expose our \<^const>\<open>IO.bind\<close> definition to code.
  We use the built-in definitions of the target language (e.g., Haskell, SML).
\<close>
code_printing constant IO.bind \<rightharpoonup> (Haskell) "_ >>= _"
                                  and (SML) "bind"
            | constant IO.return \<rightharpoonup> (Haskell) "return"
                                    and (SML) "(() => _)"

text\<open>SML does not come with a bind function. We just define it (hopefully correct).\<close>
code_printing code_module Bind \<rightharpoonup> (SML) \<open>
fun bind x f () = f (x ()) ();
\<close>
code_reserved SML bind return

text\<open>
  Make sure the code generator does not try to define \<^typ>\<open>'\<alpha> io\<close> by itself, but always uses
  the one of the target language.
  For Haskell, this is the fully qualified Prelude.IO.
  For SML, we wrap it in a nullary function.
\<close>
code_printing type_constructor io \<rightharpoonup> (Haskell) "Prelude.IO _"
                                     and (SML) "unit -> _"

text\<open>
In Isabelle, a \<^typ>\<open>string\<close> is just a type synonym for \<^typ>\<open>char list\<close>.
When translating a \<^typ>\<open>string\<close> to Haskell, Isabelle does not use Haskell's \<^verbatim>\<open>String\<close> or
\<^verbatim>\<open>[Prelude.Char]\<close>. Instead, Isabelle serializes its own
  \<^verbatim>\<open>data Char = Char Bool Bool Bool Bool Bool Bool Bool Bool\<close>.
The resulting code will look just ugly.

To use the native strings of Haskell, we use the Isabelle type \<^typ>\<open>String.literal\<close>.
This gets translated to a Haskell \<^verbatim>\<open>String\<close>.

A string literal in Isabelle is created with \<^term>\<open>STR ''foo'' :: String.literal\<close>.
\<close>

text\<open>
  We define IO functions in Isabelle without implementation.
  For a proof in Isabelle, we will only describe their externally observable properties.
  For code generation, we map those functions to the corresponding function of the target language.

  Our assumption is that our description in Isabelle corresponds to the real behavior of those
  functions in the respective target language.

  We use \<^theory_text>\<open>axiomatization\<close> instead of \<^theory_text>\<open>consts\<close> to axiomatically define that those functions exist,
  but there is no implementation of them. This makes sure that we have to explicitly write down all
  our assumptions about their behavior. Currently, no assumptions (apart from their type) can be
  made about those functions.
\<close>
axiomatization
  println :: "String.literal \<Rightarrow> unit io" and
  getLine :: "String.literal io"

text \<open>A Haskell module named \<^verbatim>\<open>StdIO\<close> which just implements \<^verbatim>\<open>println\<close> and \<^verbatim>\<open>getLine\<close>.\<close>
code_printing code_module StdIO \<rightharpoonup> (Haskell) \<open>
module StdIO (println, getLine) where
import qualified Prelude (putStrLn, getLine)
println = Prelude.putStrLn
getLine = Prelude.getLine
\<close>                              and (SML) \<open>
(* Newline behavior in SML is odd.*)
fun println s () = TextIO.print (s ^ "\n");
fun getLine () = case (TextIO.inputLine TextIO.stdIn) of
                  SOME s => String.substring (s, 0, String.size s - 1)
                | NONE => raise Fail "getLine";
\<close>

code_reserved Haskell StdIO println getLine
code_reserved SML println print getLine TextIO

text\<open>
  When the code generator sees the functions \<^const>\<open>println\<close> or \<^const>\<open>getLine\<close>, we tell it to use
  our language-specific implementation.
  \<close>
code_printing constant println \<rightharpoonup> (Haskell) "StdIO.println"
                              and (SML) "println"
            | constant getLine \<rightharpoonup> (Haskell) "StdIO.getLine"
                              and (SML) "getLine"

text\<open>Monad syntax and \<^const>\<open>println\<close> examples.\<close>
lemma "bind (println (STR ''foo''))
            (\<lambda>_.  println (STR ''bar'')) =
       println (STR ''foo'') \<bind> (\<lambda>_. println (STR ''bar''))"
  by simp
lemma "do { _ \<leftarrow> println (STR ''foo'');
            println (STR ''bar'')} =
      println (STR ''foo'') \<then> (println (STR ''bar''))"
  by simp

subsection\<open>Modelling Running an \<^typ>\<open>'\<alpha> io\<close> Function\<close>
text\<open>
  Apply some function \<^term>\<open>iofun :: '\<alpha> io\<close> to a specific world and return the new world
  (discarding the result of \<^term>\<open>iofun\<close>).
\<close>
definition exec :: "'\<alpha> io \<Rightarrow> \<^url> \<Rightarrow> \<^url>" where
  "exec iofun world = snd (Rep_io iofun world)"

text\<open>Similar, but only get the result.\<close>
definition eval :: "'\<alpha> io \<Rightarrow> \<^url> \<Rightarrow> '\<alpha>" where
  "eval iofun world = fst (Rep_io iofun world)"

text\<open>
  Essentially, \<^const>\<open>exec\<close> and \<^const>\<open>eval\<close> extract the payload \<^typ>\<open>'\<alpha>\<close> and \<^typ>\<open>\<^url>\<close>
  when executing an \<^typ>\<open>'\<alpha> io\<close>.
\<close>
lemma "Abs_io (\<lambda>world. (eval iofun world, exec iofun world)) = iofun"
  by(simp add: exec_def eval_def Rep_io_inverse)

lemma exec_Abs_io: "exec (Abs_io f) world = snd (f world)"
  by(simp add: exec_def Abs_io_inverse)

lemma exec_then:
    "exec (io\<^sub>1 \<then> io\<^sub>2) world = exec io\<^sub>2 (exec io\<^sub>1 world)"
  and eval_then:
    "eval (io\<^sub>1 \<then> io\<^sub>2) world = eval io\<^sub>2 (exec io\<^sub>1 world)"
  by (simp_all add: exec_def eval_def bind_def Abs_io_inverse split_beta)

lemma exec_bind:
    "exec (io\<^sub>1 \<bind> io\<^sub>2) world = exec (io\<^sub>2 (eval io\<^sub>1 world)) (exec io\<^sub>1 world)"
  and eval_bind:
    "eval (io\<^sub>1 \<bind> io\<^sub>2) world = eval (io\<^sub>2 (eval io\<^sub>1 world)) (exec io\<^sub>1 world)"
  by(simp_all add: exec_def eval_def bind_def Abs_io_inverse split_beta)

lemma exec_return:
    "exec (IO.return a) world = world"
  and
    "eval (IO.return a) world = a"
  by (simp_all add: exec_def eval_def Abs_io_inverse return_def)

end


theory Deletion
  imports Morphism Pushout Gluing
begin

locale deletion =
  g: injective_morphism L G g +
  l: injective_morphism K L b'
  for K G L g b' +
  assumes
    dang_src: \<open>e \<in> E\<^bsub>G\<^esub> - \<^bsub>g\<^esub>\<^sub>E ` (E\<^bsub>L\<^esub> - \<^bsub>b'\<^esub>\<^sub>E ` E\<^bsub>K\<^esub>) \<Longrightarrow> s\<^bsub>G\<^esub> e \<notin> \<^bsub>g\<^esub>\<^sub>V ` (V\<^bsub>L\<^esub> - \<^bsub>b'\<^esub>\<^sub>V ` V\<^bsub>K\<^esub>)\<close> and
    dang_trg: \<open>e \<in> E\<^bsub>G\<^esub> - \<^bsub>g\<^esub>\<^sub>E ` (E\<^bsub>L\<^esub> - \<^bsub>b'\<^esub>\<^sub>E ` E\<^bsub>K\<^esub>) \<Longrightarrow> t\<^bsub>G\<^esub> e \<notin> \<^bsub>g\<^esub>\<^sub>V ` (V\<^bsub>L\<^esub> - \<^bsub>b'\<^esub>\<^sub>V ` V\<^bsub>K\<^esub>)\<close>
begin

abbreviation V where \<open>V \<equiv> V\<^bsub>G\<^esub> - \<^bsub>g\<^esub>\<^sub>V ` (V\<^bsub>L\<^esub> - \<^bsub>b'\<^esub>\<^sub>V ` V\<^bsub>K\<^esub>)\<close>
abbreviation E where \<open>E \<equiv> E\<^bsub>G\<^esub> - \<^bsub>g\<^esub>\<^sub>E ` (E\<^bsub>L\<^esub> - \<^bsub>b'\<^esub>\<^sub>E ` E\<^bsub>K\<^esub>)\<close>

abbreviation D where \<open>D \<equiv> G\<lparr>nodes:=V,edges:=E\<rparr>\<close>

sublocale d: graph D
proof
  show \<open>finite V\<^bsub>D\<^esub>\<close>
    by (simp add:g.H.finite_nodes)
next
  show \<open>finite E\<^bsub>D\<^esub>\<close>
    by (simp add:g.H.finite_edges)
next
  show \<open>s\<^bsub>D\<^esub> e \<in> V\<^bsub>D\<^esub>\<close> if \<open>e \<in> E\<^bsub>D\<^esub>\<close> for e
    using that
    by (simp add: g.H.source_integrity dang_src[of e])
next
  show \<open>t\<^bsub>D\<^esub> e \<in> V\<^bsub>D\<^esub>\<close> if \<open>e \<in> E\<^bsub>D\<^esub>\<close> for e
    using that
    by (simp add: g.H.target_integrity dang_trg[of e])
qed

abbreviation d :: "('g, 'e, 'h, 'f) pre_morph" where
\<open>d \<equiv> g \<circ>\<^sub>\<rightarrow> b'\<close>

lemma k_inj_in_d_edge:
  assumes \<open>e \<in> E\<^bsub>K\<^esub>\<close>
  shows \<open>\<^bsub>d\<^esub>\<^sub>E e \<in> E\<^bsub>D\<^esub>\<close>
  using  g.morph_edge_range l.morph_edge_range  g.inj_edges
  by (fastforce simp add: morph_comp_def assms dest: inj_onD)

lemma k_inj_in_d_node:
  assumes \<open>v \<in> V\<^bsub>K\<^esub>\<close>
  shows \<open>\<^bsub>d\<^esub>\<^sub>V v \<in> V\<^bsub>D\<^esub>\<close>
  using  g.morph_node_range l.morph_node_range  g.inj_nodes
  by (fastforce simp add: morph_comp_def assms dest: inj_onD)

interpretation inj_d: injective_morphism K D d
proof
  show \<open>\<^bsub>d\<^esub>\<^sub>E e \<in> E\<^bsub>D\<^esub>\<close> if \<open>e \<in> E\<^bsub>K\<^esub>\<close> for e
    using that k_inj_in_d_edge by blast
next
  show \<open>\<^bsub>d\<^esub>\<^sub>V v \<in> V\<^bsub>D\<^esub>\<close> if \<open>v \<in> V\<^bsub>K\<^esub>\<close> for v
    using that k_inj_in_d_node by blast
next
  show \<open>\<^bsub>d\<^esub>\<^sub>V (s\<^bsub>K\<^esub> e) = s\<^bsub>D\<^esub> (\<^bsub>d\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>K\<^esub>\<close> for e
    using that wf_morph_comp[of K L b' G g]
    by (simp add: g.morphism_axioms l.morphism_axioms morphism.source_preserve)
next
  show \<open>\<^bsub>d\<^esub>\<^sub>V (t\<^bsub>K\<^esub> e) = t\<^bsub>D\<^esub> (\<^bsub>d\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>K\<^esub>\<close> for e
    using that wf_morph_comp[of K L b' G g]
    by (simp add: g.morphism_axioms l.morphism_axioms morphism.target_preserve)
next
  show \<open>l\<^bsub>K\<^esub> v = l\<^bsub>D\<^esub> (\<^bsub>d\<^esub>\<^sub>V v)\<close> if \<open>v \<in> V\<^bsub>K\<^esub>\<close> for v
    using that wf_morph_comp[of K L b' G g]
    by (simp add: g.morphism_axioms l.morphism_axioms morphism.label_preserve)
next
  show \<open>m\<^bsub>K\<^esub> e = m\<^bsub>D\<^esub> (\<^bsub>d\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>K\<^esub>\<close> for e
    using that wf_morph_comp[of K L b' G g]
    by (simp add: g.morphism_axioms l.morphism_axioms morphism.mark_preserve)
next
  show \<open>inj_on \<^bsub>d\<^esub>\<^sub>V V\<^bsub>K\<^esub>\<close>
    using inj_comp_inj g.injective_morphism_axioms injective_morphism.inj_nodes l.injective_morphism_axioms morph_comp_def
    by blast
next
  show \<open>inj_on \<^bsub>d\<^esub>\<^sub>E E\<^bsub>K\<^esub>\<close>
    using inj_comp_inj g.injective_morphism_axioms injective_morphism.inj_edges l.injective_morphism_axioms morph_comp_def
    by blast
qed

abbreviation c' :: "('e, 'e, 'f, 'f) pre_morph" where \<open>c' \<equiv> idM\<close>
interpretation inj_d: injective_morphism D G c'
proof
  show \<open>\<^bsub>c'\<^esub>\<^sub>E e \<in> E\<^bsub>G\<^esub>\<close> if \<open>e \<in> E\<^bsub>D\<^esub>\<close> for e
    using that by simp
next
  show \<open>\<^bsub>c'\<^esub>\<^sub>V v \<in> V\<^bsub>G\<^esub>\<close> if \<open>v \<in> V\<^bsub>D\<^esub>\<close> for v
    using that by simp
next
  show \<open>\<^bsub>c'\<^esub>\<^sub>V (s\<^bsub>D\<^esub> e) = s\<^bsub>G\<^esub> (\<^bsub>c'\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>D\<^esub>\<close> for e
    using that by simp
next
  show \<open>\<^bsub>c'\<^esub>\<^sub>V (t\<^bsub>D\<^esub> e) = t\<^bsub>G\<^esub> (\<^bsub>c'\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>D\<^esub>\<close> for e
    using that by simp
next
  show \<open>l\<^bsub>D\<^esub> v = l\<^bsub>G\<^esub> (\<^bsub>c'\<^esub>\<^sub>V v)\<close> if \<open>v \<in> V\<^bsub>D\<^esub>\<close> for v
    using that by simp
next
  show \<open>m\<^bsub>D\<^esub> e = m\<^bsub>G\<^esub> (\<^bsub>c'\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>D\<^esub>\<close> for e
    using that by simp
next
  show \<open>inj_on \<^bsub>c'\<^esub>\<^sub>V V\<^bsub>D\<^esub>\<close>
    by simp
next
  show \<open>inj_on \<^bsub>c'\<^esub>\<^sub>E E\<^bsub>D\<^esub>\<close>
    by simp
qed

lemma xxx[simp]:
  assumes \<open>e \<in> X\<close>
  shows \<open>inv_into X id e = id e\<close>
  by (metis assms id_apply inj_on_id inv_into_f_f)

lemma xxx2[simp]:
  assumes \<open>e \<in> E\<^bsub>X\<^esub>\<close>
  shows \<open>inv_into E\<^bsub>X\<^esub> id e = id e\<close>
  by (metis assms id_apply inj_on_id inv_into_f_f)

lemma xx11:
  shows \<open>E\<^bsub>D\<^esub> \<subseteq> E\<^bsub>G\<^esub>\<close> and \<open>V\<^bsub>D\<^esub> \<subseteq> V\<^bsub>G\<^esub>\<close>
  by simp_all

lemma xx3:\<open>E \<subseteq> E\<^bsub>G\<^esub>\<close>
  by blast

lemma xx5:
  assumes \<open>\<^bsub>g\<^esub>\<^sub>V v \<in> V\<^bsub>G\<^esub>\<close> and \<open>v \<in> V\<^bsub>L\<^esub>\<close>
  shows \<open>\<^bsub>g\<^esub>\<^sub>V v \<notin> \<^bsub>g\<^esub>\<^sub>V ` (V\<^bsub>L\<^esub> - \<^bsub>l\<^esub>\<^sub>V ` V\<^bsub>K\<^esub>) \<longleftrightarrow> v \<in>  \<^bsub>l\<^esub>\<^sub>V ` V\<^bsub>K\<^esub>\<close>
  using assms(2) g.inj_nodes inj_onD by fastforce

lemma xxx8:
  assumes \<open>x \<in> V\<^bsub>L\<^esub>\<close>
  shows \<open>inv_into V\<^bsub>L\<^esub> \<^bsub>g\<^esub>\<^sub>V (\<^bsub>g\<^esub>\<^sub>V x) = x\<close>
  by (simp add: assms g.inj_nodes)

lemma xxx8':
  assumes \<open>x \<in> E\<^bsub>L\<^esub>\<close>
  shows \<open>inv_into E\<^bsub>L\<^esub> \<^bsub>g\<^esub>\<^sub>E (\<^bsub>g\<^esub>\<^sub>E x) = x\<close>
  by (simp add: assms g.inj_edges)

lemma case_sum_id_into_disj_union[simp]:
  shows \<open>case_sum id f  ` (Inl ` Y \<union> Inr ` R) = Y \<union> f ` (R)\<close>
  by force

sublocale po: pushout_diagram K L D G b' d g c'
proof -

  interpret gl: gluing K D L d b'
    ..

  define u where
    \<open>u \<equiv> \<lparr> node_map = case_sum id \<^bsub>g\<^esub>\<^sub>V
         , edge_map = case_sum id \<^bsub>g\<^esub>\<^sub>E\<rparr>\<close>

  interpret u: bijective_morphism gl.H G u
  proof
    show \<open>\<^bsub>u\<^esub>\<^sub>E e \<in> E\<^bsub>G\<^esub>\<close> if \<open>e \<in> E\<^bsub>gl.H\<^esub>\<close> for e
      using that g.morph_edge_range
      by (auto simp add: u_def gl.H_def)
  next
    show \<open>\<^bsub>u\<^esub>\<^sub>V v \<in> V\<^bsub>G\<^esub>\<close> if \<open>v \<in> V\<^bsub>gl.H\<^esub>\<close> for v
      using that g.morph_node_range
      by (auto simp add: u_def gl.H_def)
  next
    show \<open>\<^bsub>u\<^esub>\<^sub>V (s\<^bsub>gl.H\<^esub> e) = s\<^bsub>G\<^esub> (\<^bsub>u\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>gl.H\<^esub>\<close> for e
    proof (cases e)
      case (Inl a)
      then show ?thesis
        by (simp add: u_def gl.H_def)
    next
      case (Inr b)
      then show ?thesis
        using that  l.inj_nodes g.source_preserve
        by (auto simp add: u_def gl.H_def) (metis comp_apply morph_comp_def pre_morph.select_convs(1))
    qed
  next
    show \<open>\<^bsub>u\<^esub>\<^sub>V (t\<^bsub>gl.H\<^esub> e) = t\<^bsub>G\<^esub> (\<^bsub>u\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>gl.H\<^esub>\<close> for e
    proof (cases e)
      case (Inl a)
      then show ?thesis
        by (simp add: u_def gl.H_def)
    next
      case (Inr b)
      then show ?thesis
        using that  l.inj_nodes g.target_preserve
        by (auto simp add: u_def gl.H_def) (metis comp_apply morph_comp_def pre_morph.select_convs(1))
    qed
  next
    show \<open>l\<^bsub>gl.H\<^esub> v = l\<^bsub>G\<^esub> (\<^bsub>u\<^esub>\<^sub>V v)\<close> if \<open>v \<in> V\<^bsub>gl.H\<^esub>\<close> for v
      using that g.label_preserve
      by (auto simp add: u_def gl.H_def)
  next
    show \<open>m\<^bsub>gl.H\<^esub> e = m\<^bsub>G\<^esub> (\<^bsub>u\<^esub>\<^sub>E e)\<close> if \<open>e \<in> E\<^bsub>gl.H\<^esub>\<close> for e
      using that g.mark_preserve
      by (auto simp add: u_def gl.H_def)

  next
    show \<open>bij_betw \<^bsub>u\<^esub>\<^sub>V V\<^bsub>gl.H\<^esub> V\<^bsub>G\<^esub>\<close>
    proof -
      have \<open>V\<^bsub>D\<^esub> \<inter> \<^bsub>g\<^esub>\<^sub>V ` (V\<^bsub>L\<^esub> - \<^bsub>b'\<^esub>\<^sub>V ` V\<^bsub>K\<^esub>) = {}\<close>
        using g.inj_nodes
        by fastforce

      moreover
      have \<open>V\<^bsub>D\<^esub> \<union> \<^bsub>g\<^esub>\<^sub>V ` (V\<^bsub>L\<^esub> - \<^bsub>b'\<^esub>\<^sub>V ` V\<^bsub>K\<^esub>) = V\<^bsub>G\<^esub>\<close>
        using g.inj_nodes g.morph_node_range
        by fastforce

      ultimately show ?thesis
        using  g.inj_nodes
        by (force simp add: u_def inj_on_def bij_betw_def gl.H_def)
    qed
  next
    show \<open>bij_betw \<^bsub>u\<^esub>\<^sub>E E\<^bsub>gl.H\<^esub> E\<^bsub>G\<^esub>\<close>
    proof -
      have \<open>E\<^bsub>D\<^esub> \<inter> \<^bsub>g\<^esub>\<^sub>E ` (E\<^bsub>L\<^esub> - \<^bsub>b'\<^esub>\<^sub>E ` E\<^bsub>K\<^esub>) = {}\<close>
        using g.inj_edges
        by fastforce

      moreover
      have \<open>E\<^bsub>D\<^esub> \<union> \<^bsub>g\<^esub>\<^sub>E ` (E\<^bsub>L\<^esub> - \<^bsub>b'\<^esub>\<^sub>E ` E\<^bsub>K\<^esub>) = E\<^bsub>G\<^esub>\<close>
        using g.inj_edges g.morph_edge_range
        by fastforce

      ultimately show ?thesis
        using  g.inj_edges
        by (force simp add: u_def inj_on_def bij_betw_def gl.H_def)
    qed
  qed

  have \<open>\<forall>v\<in>V\<^bsub>L\<^esub>. \<^bsub>u \<circ>\<^sub>\<rightarrow> gl.h\<^esub>\<^sub>V v = \<^bsub>g\<^esub>\<^sub>V v\<close>  \<open>\<forall>e\<in>E\<^bsub>L\<^esub>. \<^bsub>u \<circ>\<^sub>\<rightarrow> gl.h\<^esub>\<^sub>E e = \<^bsub>g\<^esub>\<^sub>E e\<close>
    and \<open>\<forall>v\<in>V\<^bsub>D\<^esub>. \<^bsub>u \<circ>\<^sub>\<rightarrow> gl.c\<^esub>\<^sub>V v = \<^bsub>c'\<^esub>\<^sub>V v\<close>  \<open>\<forall>e\<in>E\<^bsub>D\<^esub>. \<^bsub>u \<circ>\<^sub>\<rightarrow> gl.c\<^esub>\<^sub>E e = \<^bsub>c'\<^esub>\<^sub>E e\<close>
  proof -
    show \<open>\<forall>v\<in>V\<^bsub>L\<^esub>. \<^bsub>u \<circ>\<^sub>\<rightarrow> gl.h\<^esub>\<^sub>V v = \<^bsub>g\<^esub>\<^sub>V v\<close>
      using l.inj_nodes gl.h_def
      by (auto simp add: morph_comp_def u_def l.inj_nodes)

  next
    show \<open>\<forall>e\<in>E\<^bsub>L\<^esub>. \<^bsub>u \<circ>\<^sub>\<rightarrow> gl.h\<^esub>\<^sub>E e = \<^bsub>g\<^esub>\<^sub>E e\<close>
      using gl.h_def
      by (auto simp add: morph_comp_def u_def l.inj_edges)
  next
    show \<open>\<forall>v\<in>V\<^bsub>D\<^esub>. \<^bsub>u \<circ>\<^sub>\<rightarrow> gl.c\<^esub>\<^sub>V v = \<^bsub>c'\<^esub>\<^sub>V v\<close>
      by (simp add: u_def gl.c_def morph_comp_def)
  next
    show \<open>\<forall>e\<in>E\<^bsub>D\<^esub>. \<^bsub>u \<circ>\<^sub>\<rightarrow> gl.c\<^esub>\<^sub>E e = \<^bsub>c'\<^esub>\<^sub>E e\<close>
      by (simp add: u_def gl.c_def morph_comp_def)
  qed

  show \<open>pushout_diagram K L D G b' d g c'\<close>
    using
      u.bijective_morphism_axioms
      gl.po.uniqueness_po[OF g.H.graph_axioms  g.morphism_axioms inj_d.morphism_axioms]
      \<open>\<forall>e\<in>E\<^bsub>D\<^esub>. \<^bsub>u \<circ>\<^sub>\<rightarrow> gl.c\<^esub>\<^sub>E e = \<^bsub>c'\<^esub>\<^sub>E e\<close> \<open>\<forall>e\<in>E\<^bsub>L\<^esub>. \<^bsub>u \<circ>\<^sub>\<rightarrow> gl.h\<^esub>\<^sub>E e = \<^bsub>g\<^esub>\<^sub>E e\<close>
      \<open>\<forall>v\<in>V\<^bsub>D\<^esub>. \<^bsub>u \<circ>\<^sub>\<rightarrow> gl.c\<^esub>\<^sub>V v = \<^bsub>c'\<^esub>\<^sub>V v\<close> \<open>\<forall>v\<in>V\<^bsub>L\<^esub>. \<^bsub>u \<circ>\<^sub>\<rightarrow> gl.h\<^esub>\<^sub>V v = \<^bsub>g\<^esub>\<^sub>V v\<close>
    by blast
qed

end

end