theory Incredible_Correctness
imports
  Abstract_Rules_To_Incredible
  Natural_Deduction
begin

text \<open>
In this theory, we prove that if we have a graph that proves a given abstract task (which is
represented as the context @{term Tasked_Proof_Graph}), then we can prove @{term solved}.
\<close>

context Tasked_Proof_Graph
begin

definition adjacentTo :: "'vertex \<Rightarrow> ('form, 'var) in_port \<Rightarrow> ('vertex \<times> ('form, 'var) out_port)" where
 "adjacentTo v p = (SOME ps. (ps, (v,p)) \<in> edges)"

fun isReg where
  "isReg v p = (case p of Hyp h c \<Rightarrow> False | Reg  c \<Rightarrow>
      (case nodeOf v of
        Conclusion a \<Rightarrow> False
      | Assumption a \<Rightarrow> False
      | Rule r \<Rightarrow> True
      | Helper \<Rightarrow> True
      ))"

fun toNatRule  where
  "toNatRule v p = (case p of Hyp h c \<Rightarrow> Axiom | Reg  c \<Rightarrow>
      (case nodeOf v of
        Conclusion a \<Rightarrow> Axiom \<comment> \<open>a lie\<close>
      | Assumption a \<Rightarrow> Axiom
      | Rule r \<Rightarrow> NatRule (r,c)
      | Helper \<Rightarrow> Cut
      ))"

inductive_set global_assms' :: "'var itself \<Rightarrow> 'form set" for i  where
  "v |\<in>| vertices \<Longrightarrow> nodeOf v = Assumption p \<Longrightarrow> labelAtOut v (Reg p) \<in> global_assms' i"

lemma finite_global_assms': "finite (global_assms' i)"
proof-
  have "finite (fset vertices)" by (rule finite_fset)
  moreover
  have "global_assms' i \<subseteq> (\<lambda> v. case nodeOf v of Assumption p \<Rightarrow>  labelAtOut v (Reg p)) ` fset vertices"
    by (force simp add: global_assms'.simps fmember_iff_member_fset image_iff )
  ultimately
  show ?thesis by (rule finite_surj)
qed

context includes fset.lifting
begin
  lift_definition global_assms :: "'var itself \<Rightarrow> 'form fset" is global_assms' by (rule finite_global_assms')
  lemmas global_assmsI = global_assms'.intros[Transfer.transferred]
  lemmas global_assms_simps = global_assms'.simps[Transfer.transferred]
end

fun extra_assms :: "('vertex \<times> ('form, 'var) in_port) \<Rightarrow> 'form fset" where
  "extra_assms (v, p) = (\<lambda> p. labelAtOut v p) |`| hyps_for (nodeOf v) p"

fun hyps_along :: "('vertex, 'form, 'var) edge' list \<Rightarrow> 'form fset" where
  "hyps_along pth = ffUnion (extra_assms |`| snd |`| fset_from_list pth) |\<union>| global_assms TYPE('var)"

lemma hyps_alongE[consumes 1, case_names Hyp Assumption]:
  assumes "f |\<in>| hyps_along pth"
  obtains v p h where "(v,p) \<in> snd ` set pth" and "f = labelAtOut v h " and "h |\<in>| hyps_for (nodeOf v) p"
  | v pf  where "v |\<in>| vertices" and "nodeOf v = Assumption pf" "f = labelAtOut v (Reg pf)"
  using assms
  apply (auto simp add: fmember_iff_member_fset ffUnion.rep_eq  global_assms_simps[unfolded fmember_iff_member_fset])
  apply (metis image_iff snd_conv)
  done

text \<open>Here we build the natural deduction tree, by walking the graph.\<close>

primcorec tree :: "'vertex \<Rightarrow> ('form, 'var) in_port \<Rightarrow> ('vertex, 'form, 'var) edge' list \<Rightarrow>  (('form entailment), ('rule \<times> 'form) NatRule) dtree" where
 "root (tree v p pth) =
    ((hyps_along ((adjacentTo v p,(v,p))#pth) \<turnstile> labelAtIn v p),
    (case adjacentTo v p of (v', p') \<Rightarrow> toNatRule v' p'
    ))"
 | "cont (tree v p pth) =
    (case adjacentTo v p of (v', p') \<Rightarrow>
    (if isReg v' p' then ((\<lambda> p''. tree v' p'' ((adjacentTo v p,(v,p))#pth)) |`| inPorts (nodeOf v')) else {||}
    ))"

lemma fst_root_tree[simp]: "fst (root (tree v p pth)) = (hyps_along ((adjacentTo v p,(v,p))#pth) \<turnstile> labelAtIn v p)" by simp

lemma out_port_cases[consumes 1, case_names Assumption Hyp Rule Helper]:
  assumes "p |\<in>| outPorts n"
  obtains
    a where "n = Assumption a" and "p = Reg a"
    | r h c where "n = Rule r" and "p = Hyp h c"
    | r f where "n = Rule r" and "p = Reg f"
    | "n = Helper" and "p = Reg anyP"
  using assms by (atomize_elim, cases p; cases n) auto

lemma hyps_for_fimage: "hyps_for (Rule r) x = (if x |\<in>| f_antecedent r then (\<lambda> f. Hyp f x) |`| (a_hyps x) else {||})"
  apply (rule fset_eqI)
  apply (rename_tac p')
  apply (case_tac p')
  apply (auto simp add:  split: if_splits out_port.splits)
  done

text \<open>Now we prove that the thus produced tree is well-formed.\<close>

theorem wf_tree:
  assumes "valid_in_port (v,p)"
  assumes "terminal_path v t pth"
  shows "wf (tree v p pth)"
using assms
proof (coinduction arbitrary: v p pth)
case (wf v p pth)
  let ?t = "tree v p pth"
  from saturated[OF wf(1)]
  obtain v' p'
  where e:"((v',p'),(v,p)) \<in> edges" and [simp]: "adjacentTo v p = (v',p')"
    by (auto simp add: adjacentTo_def, metis (no_types, lifting) eq_fst_iff tfl_some)

  let ?e = "((v',p'),(v,p))"
  let ?pth' = "?e#pth"
  let ?\<Gamma> = "hyps_along ?pth'"
  let ?l = "labelAtIn v p"

  from e valid_edges have "v' |\<in>| vertices" and "p' |\<in>| outPorts (nodeOf v')" by auto
  hence "nodeOf v' \<in> sset nodes" using valid_nodes by (meson image_eqI notin_fset subsetD)

  from \<open>?e \<in> edges\<close>
  have s: "labelAtOut v' p' = labelAtIn v p"  by (rule solved)

  from \<open>p' |\<in>| outPorts (nodeOf v')\<close>
  show ?case
  proof (cases rule: out_port_cases)
    case (Hyp r h c)

    from Hyp \<open>p' |\<in>| outPorts (nodeOf v')\<close>
    have "h |\<in>| a_hyps c" and "c |\<in>| f_antecedent r" by auto
    hence "hyps (nodeOf v') (Hyp h c) = Some c" using Hyp by simp

    from well_scoped[OF \<open> _ \<in> edges\<close>[unfolded Hyp] this]
    have "(v, p) = (v', c) \<or> v \<in> scope (v', c)".
    hence "(v', c) \<in> insert (v, p) (snd ` set pth)"
    proof
      assume "(v, p) = (v', c)"
      thus ?thesis by simp
    next
      assume "v \<in> scope (v', c)"
      from this terminal_path_end_is_terminal[OF wf(2)] terminal_path_is_path[OF wf(2)]
      have "(v', c) \<in> snd ` set pth" by (rule scope_find)
      thus ?thesis by simp
    qed
    moreover

    from \<open>hyps (nodeOf v') (Hyp h c) = Some c\<close>
    have "Hyp h c |\<in>| hyps_for (nodeOf v') c" by simp
    hence "labelAtOut v' (Hyp h c) |\<in>| extra_assms (v',c)" by auto
    ultimately

    have "labelAtOut v' (Hyp h c) |\<in>| ?\<Gamma>"
      by (fastforce simp add: fmember_iff_member_fset ffUnion.rep_eq)

    hence "labelAtIn v p |\<in>| ?\<Gamma>" by (simp add: s[symmetric] Hyp fmember_iff_member_fset)
    thus ?thesis
      using Hyp
      apply (auto intro: exI[where x = ?t] simp add: eff.simps simp del: hyps_along.simps)
      done
  next
    case (Assumption f)

    from \<open>v' |\<in>| vertices\<close> \<open>nodeOf v' = Assumption f\<close>
    have "labelAtOut v' (Reg f) |\<in>| global_assms TYPE('var)"
      by (rule global_assmsI)
    hence "labelAtOut v' (Reg f) |\<in>| ?\<Gamma>" by auto
    hence "labelAtIn v p |\<in>| ?\<Gamma>" by (simp add: s[symmetric] Assumption fmember_iff_member_fset)
    thus ?thesis using Assumption
      by (auto intro: exI[where x = ?t] simp add: eff.simps)
  next
    case (Rule r f)
    with \<open>nodeOf v' \<in> sset nodes\<close>
    have "r \<in> sset rules"
      by (auto simp add: nodes_def stream.set_map)

    from Rule
    have "hyps (nodeOf v') p' = None" by simp
    with e \<open>terminal_path v t pth\<close>
    have "terminal_path v' t ?pth'"..

    from Rule  \<open>p' |\<in>| outPorts (nodeOf v')\<close>
    have "f |\<in>| f_consequent r" by simp
    hence "f \<in> set (consequent r)" by (simp add: f_consequent_def)
    with \<open>r \<in> sset rules\<close>
    have "NatRule (r, f) \<in> sset (smap NatRule n_rules)"
      by (auto simp add: stream.set_map n_rules_def no_empty_conclusions)
    moreover

    {
    from \<open>f |\<in>| f_consequent r\<close>
    have "f \<in> set (consequent r)" by (simp add: f_consequent_def)
    hence "natEff_Inst (r, f) f (f_antecedent r)"
      by (rule natEff_Inst.intros)
    hence "eff (NatRule (r, f)) (?\<Gamma> \<turnstile> subst (inst v') (freshen (vidx v') f))
           ((\<lambda>ant. ((\<lambda>p. subst (inst v') (freshen (vidx v') p)) |`| a_hyps ant |\<union>| ?\<Gamma> \<turnstile> subst (inst v') (freshen (vidx v') (a_conc ant)))) |`| f_antecedent r)"
           (is "eff _ _ ?ants")
    proof (rule eff.intros)
      fix ant f
      assume "ant |\<in>| f_antecedent r"
      from  \<open>v' |\<in>| vertices\<close> \<open>ant |\<in>| f_antecedent r\<close>
      have "valid_in_port (v',ant)" by (simp add: Rule)

      assume "f |\<in>| ?\<Gamma>"
      thus "freshenLC (vidx v') ` a_fresh ant \<inter> lconsts f = {}"
      proof(induct rule: hyps_alongE)
        case (Hyp v'' p'' h'')

        from Hyp(1) snd_set_path_verties[OF terminal_path_is_path[OF \<open>terminal_path v' t ?pth'\<close>]]
        have "v'' |\<in>| vertices" by (force simp add: fmember_iff_member_fset)

        from \<open>terminal_path v' t ?pth'\<close> Hyp(1)
        have "v'' \<notin> scope (v', ant)" by (rule hyps_free_path_not_in_scope)
        with \<open>valid_in_port (v',ant)\<close> \<open>v'' |\<in>| vertices\<close>
        have "freshenLC (vidx v') ` local_vars (nodeOf v') ant \<inter> subst_lconsts (inst v'') = {}"
         by (rule out_of_scope)
        moreover
        from hyps_free_vertices_distinct'[OF \<open>terminal_path v' t ?pth'\<close>] Hyp.hyps(1)
        have "v'' \<noteq> v'" by (metis distinct.simps(2) fst_conv image_eqI list.set_map)
        hence "vidx v'' \<noteq> vidx v'" using \<open>v' |\<in>| vertices\<close> \<open>v'' |\<in>| vertices\<close> by (meson vidx_inj inj_onD notin_fset)
        hence "freshenLC (vidx v') ` a_fresh ant \<inter> freshenLC (vidx v'') ` lconsts (labelsOut (nodeOf v'') h'') = {}"by auto
        moreover
        have "lconsts f \<subseteq> lconsts (freshen (vidx v'') (labelsOut (nodeOf v'') h'')) \<union> subst_lconsts (inst v'') " using \<open>f = _\<close>
          by (simp add: labelAtOut_def fv_subst)
        ultimately
        show ?thesis
          by (fastforce simp add:  lconsts_freshen)
      next
        case (Assumption v pf)
        hence "f = subst (inst v) (freshen (vidx v) pf)" by (simp add: labelAtOut_def)
        moreover
        from Assumption have "Assumption pf \<in> sset nodes" using valid_nodes by (auto simp add: fmember_iff_member_fset)
        hence "pf \<in> set assumptions" unfolding nodes_def by (auto simp add: stream.set_map)
        hence "closed pf" by (rule assumptions_closed)
        ultimately
        have "lconsts f = {}" by (simp add: closed_no_lconsts lconsts_freshen subst_closed freshen_closed)
        thus ?thesis by simp
      qed
    next
      fix ant
      assume "ant |\<in>| f_antecedent r"
      from  \<open>v' |\<in>| vertices\<close> \<open>ant |\<in>| f_antecedent r\<close>
      have "valid_in_port (v',ant)" by (simp add: Rule)
      moreover
      note \<open>v' |\<in>| vertices\<close>
      moreover
      hence "v' \<notin> scope (v', ant)" by (rule scopes_not_refl)
      ultimately
      have "freshenLC (vidx v') ` local_vars (nodeOf v') ant \<inter> subst_lconsts (inst v') = {}"
        by (rule out_of_scope)
      thus "freshenLC (vidx v') ` a_fresh ant \<inter> subst_lconsts (inst v') = {}" by simp
    qed
    also
    have "subst (inst v') (freshen (vidx v') f) = labelAtOut v' p'" using Rule by (simp add: labelAtOut_def)
    also
    note \<open>labelAtOut v' p' = labelAtIn v p\<close>
    also
    have "?ants = ((\<lambda>x. (extra_assms (v',x) |\<union>| hyps_along ?pth' \<turnstile> labelAtIn  v' x)) |`| f_antecedent r)"
      by (rule fimage_cong[OF refl])
        (auto simp add: labelAtIn_def labelAtOut_def Rule hyps_for_fimage fmember_iff_member_fset ffUnion.rep_eq)
    finally
    have "eff (NatRule (r, f))
        (?\<Gamma>, labelAtIn v p)
        ((\<lambda>x. extra_assms (v',x) |\<union>| ?\<Gamma> \<turnstile> labelAtIn v' x) |`| f_antecedent r)".
    }
    moreover

    { fix x
      assume "x |\<in>| cont ?t"
      then obtain a where "x = tree v' a ?pth'" and "a |\<in>| f_antecedent r"
        by (auto simp add: Rule)
      note this(1)
      moreover

      from  \<open>v' |\<in>| vertices\<close> \<open>a |\<in>| f_antecedent r\<close>
      have "valid_in_port (v',a)" by (simp add: Rule)
      moreover

      note \<open>terminal_path v' t ?pth'\<close>
      ultimately

      have "\<exists>v p pth. x = tree v p pth \<and> valid_in_port (v,p) \<and>  terminal_path v t pth"
        by blast
    }
    ultimately

    show ?thesis using Rule
      by (auto intro!: exI[where x = ?t]  simp add: comp_def funion_assoc)
  next
    case Helper
    from Helper
    have "hyps (nodeOf v') p' = None" by simp
    with e \<open>terminal_path v t pth\<close>
    have "terminal_path v' t ?pth'"..

    have "labelAtIn v' (plain_ant anyP) = labelAtIn v p"
      unfolding s[symmetric]
      using Helper by (simp add: labelAtIn_def labelAtOut_def)
    moreover
    { fix x
      assume "x |\<in>| cont ?t"

      hence "x = tree v' (plain_ant anyP) ?pth'"
        by (auto simp add: Helper)
      note this(1)
      moreover

      from  \<open>v' |\<in>| vertices\<close>
      have "valid_in_port (v',plain_ant anyP)" by (simp add: Helper)
      moreover

      note \<open>terminal_path v' t ?pth'\<close>
      ultimately

      have "\<exists>v p pth. x = tree v p pth \<and> valid_in_port (v,p) \<and>  terminal_path v t pth"
        by blast
    }
    ultimately

    show ?thesis using Helper
      by (auto intro!: exI[where x = ?t]  simp add: comp_def funion_assoc )
  qed
qed

lemma global_in_ass: "global_assms TYPE('var) |\<subseteq>| ass_forms"
proof
  fix x
  assume "x |\<in>| global_assms TYPE('var)"
  then obtain v pf where "v |\<in>| vertices" and "nodeOf v = Assumption pf" and "x = labelAtOut v (Reg pf)"
    by (auto simp add: global_assms_simps)
  from this (1,2) valid_nodes
  have "Assumption pf \<in> sset nodes" by (auto simp add: fmember_iff_member_fset)
  hence "pf \<in> set assumptions" by (auto simp add: nodes_def stream.set_map)
  hence "closed pf" by (rule  assumptions_closed)
  with \<open>x = labelAtOut v (Reg pf)\<close>
  have "x = pf" by (auto simp add: labelAtOut_def lconsts_freshen closed_no_lconsts freshen_closed subst_closed)
  thus "x |\<in>| ass_forms" using \<open>pf \<in> set assumptions\<close> by (auto simp add: ass_forms_def)
qed

primcorec edge_tree :: "'vertex \<Rightarrow> ('form, 'var) in_port \<Rightarrow> ('vertex, 'form, 'var) edge' tree" where
 "root (edge_tree v p) = (adjacentTo v p, (v,p))"
 | "cont (edge_tree v p) =
    (case adjacentTo v p of (v', p') \<Rightarrow>
    (if isReg v' p' then ((\<lambda> p. edge_tree  v' p) |`| inPorts (nodeOf v')) else {||}
    ))"

lemma tfinite_map_tree: "tfinite (map_tree f t) \<longleftrightarrow> tfinite t"
proof
  assume "tfinite (map_tree f t)"
  thus "tfinite t"
    by (induction "map_tree f t" arbitrary: t rule: tfinite.induct)
       (fastforce intro:  tfinite.intros simp add:  tree.map_sel)
next
  assume "tfinite t"
  thus "tfinite (map_tree f t)"
    by (induction t rule: tfinite.induct)
       (fastforce intro:  tfinite.intros simp add:  tree.map_sel)
qed

lemma finite_tree_edge_tree:
  "tfinite (tree v p pth) \<longleftrightarrow> tfinite (edge_tree v p)"
proof-
  have "map_tree (\<lambda> _. ())  (tree v p pth) = map_tree (\<lambda> _. ()) (edge_tree v p)"
   by(coinduction arbitrary: v p pth)
     (fastforce simp add: tree.map_sel rel_fset_def rel_set_def split: prod.split out_port.split graph_node.split option.split)
  thus ?thesis by (metis tfinite_map_tree)
qed

coinductive forbidden_path :: "'vertex \<Rightarrow> ('vertex, 'form, 'var) edge' stream \<Rightarrow> bool"   where
    forbidden_path: "((v\<^sub>1,p\<^sub>1),(v\<^sub>2,p\<^sub>2)) \<in> edges \<Longrightarrow> hyps (nodeOf v\<^sub>1) p\<^sub>1 = None \<Longrightarrow> forbidden_path v\<^sub>1 pth \<Longrightarrow> forbidden_path v\<^sub>2 (((v\<^sub>1,p\<^sub>1),(v\<^sub>2,p\<^sub>2))##pth)"

lemma path_is_forbidden:
  assumes "valid_in_port (v,p)"
  assumes "ipath (edge_tree v p) es"
  shows "forbidden_path v es"
using assms
proof(coinduction arbitrary: v p es)
  case forbidden_path

  let ?es' = "stl es"

  from forbidden_path(2)
  obtain t' where "root (edge_tree v p) = shd es" and "t' |\<in>| cont (edge_tree v p)" and "ipath t' ?es'"
    by rule blast

  from \<open>root (edge_tree v p) = shd es\<close>
  have [simp]: "shd es = (adjacentTo v p, (v,p))" by simp

  from saturated[OF \<open>valid_in_port (v,p)\<close>]
  obtain v' p'
  where e:"((v',p'),(v,p)) \<in> edges" and [simp]: "adjacentTo v p = (v',p')"
    by (auto simp add: adjacentTo_def, metis (no_types, lifting) eq_fst_iff tfl_some)
  let ?e = "((v',p'),(v,p))"

  from e have "p' |\<in>| outPorts (nodeOf v')" using valid_edges by auto
  thus ?case
  proof(cases rule: out_port_cases)
    case Hyp
    with  \<open>t' |\<in>| cont (edge_tree v p)\<close>
    have False by auto
    thus ?thesis..
  next
    case Assumption
    with  \<open>t' |\<in>| cont (edge_tree v p)\<close>
    have False by auto
    thus ?thesis..
  next
    case (Rule r f)
    from \<open>t' |\<in>| cont (edge_tree v p)\<close> Rule
    obtain a where [simp]: "t' = edge_tree v' a" and "a |\<in>| f_antecedent r"  by auto

    have "es = ?e ## ?es'" by (cases es rule: stream.exhaust_sel) simp
    moreover

    have "?e \<in> edges" using e by simp
    moreover

    from \<open>p' = Reg f\<close> \<open>nodeOf v' = Rule r\<close>
    have "hyps (nodeOf v') p' = None" by simp
    moreover

    from e valid_edges have "v' |\<in>| vertices"  by auto
    with \<open>nodeOf v' = Rule r\<close> \<open>a |\<in>| f_antecedent r\<close>
    have "valid_in_port (v', a)" by simp
    moreover

    have "ipath (edge_tree v' a) ?es'" using \<open>ipath t' _\<close> by simp
    ultimately

    show ?thesis by metis
  next
    case Helper
    from \<open>t' |\<in>| cont (edge_tree v p)\<close> Helper
    have [simp]: "t' = edge_tree v' (plain_ant anyP)" by simp

    have "es = ?e ## ?es'" by (cases es rule: stream.exhaust_sel) simp
    moreover

    have "?e \<in> edges" using e by simp
    moreover

    from \<open>p' = Reg anyP\<close> \<open>nodeOf v' = Helper\<close>
    have "hyps (nodeOf v') p' = None" by simp
    moreover

    from e valid_edges have "v' |\<in>| vertices"  by auto
    with \<open>nodeOf v' = Helper\<close>
    have "valid_in_port (v', plain_ant anyP)" by simp
    moreover

    have "ipath (edge_tree v' (plain_ant anyP)) ?es'" using \<open>ipath t' _\<close> by simp
    ultimately

    show ?thesis by metis
  qed
qed

lemma forbidden_path_prefix_is_path:
  assumes "forbidden_path v es"
  obtains v' where  "path v' v (rev (stake n es))"
  using assms
  apply (atomize_elim)
  apply (induction n arbitrary: v es)
  apply simp
  apply (simp add: path_snoc)
  apply (subst (asm) (2) forbidden_path.simps)
  apply auto
  done

lemma forbidden_path_prefix_is_hyp_free:
  assumes "forbidden_path v es"
  shows "hyps_free (rev (stake n es))"
  using assms
  apply (induction n arbitrary: v es)
  apply (simp add: hyps_free_def)
  apply (subst (asm) (2) forbidden_path.simps)
  apply (force simp add: hyps_free_def)
  done

text \<open>And now we prove that the tree is finite, which requires the above notion of a
@{term forbidden_path}, i.e.\@ an infinite path.\<close>

theorem finite_tree:
  assumes "valid_in_port (v,p)"
  assumes "terminal_vertex v"
  shows "tfinite (tree v p pth)"
proof(rule ccontr)
  let ?n = "Suc (fcard vertices)"
  assume "\<not> tfinite (tree v p pth)"
  hence "\<not> tfinite (edge_tree v p)" unfolding finite_tree_edge_tree.
  then obtain es  :: "('vertex, 'form, 'var) edge' stream"
    where "ipath (edge_tree v p) es" using Konig by blast
  with \<open>valid_in_port (v,p)\<close>
  have "forbidden_path v es" by (rule path_is_forbidden)
  from forbidden_path_prefix_is_path[OF this] forbidden_path_prefix_is_hyp_free[OF this]
  obtain v' where "path v' v (rev (stake ?n es))" and "hyps_free (rev (stake ?n es))"
    by blast
  from this \<open>terminal_vertex v\<close>
  have "terminal_path  v' v (rev (stake ?n es))" by (rule terminal_pathI)
  hence "length (rev (stake ?n es)) \<le> fcard vertices"
    by (rule hyps_free_limited)
  thus False by simp
qed

text \<open>The main result of this theory.\<close>

theorem solved
unfolding solved_def
proof(intro ballI allI conjI impI)
  fix c
  assume "c |\<in>| conc_forms"
  hence "c \<in> set conclusions"  by (auto simp add: conc_forms_def)
  from this(1) conclusions_present
  obtain v where "v |\<in>| vertices" and "nodeOf v = Conclusion c"
    by (auto, metis (no_types, lifting) image_iff image_subset_iff notin_fset)

  have "valid_in_port (v, (plain_ant c))"
    using \<open>v |\<in>| vertices\<close> \<open>nodeOf _ = _ \<close>  by simp

  have "terminal_vertex v" using \<open>v |\<in>| vertices\<close> \<open>nodeOf v = Conclusion c\<close> by auto

  let ?t = "tree v (plain_ant c) []"

  have "fst (root ?t) = (global_assms TYPE('var), c)"
    using \<open>c \<in> set conclusions\<close> \<open>nodeOf _ = _\<close>
    by (auto simp add: labelAtIn_def conclusions_closed closed_no_lconsts  freshen_def rename_closed subst_closed)
  moreover

  have "global_assms TYPE('var) |\<subseteq>| ass_forms" by (rule global_in_ass)
  moreover

  from  \<open>terminal_vertex v\<close>
  have "terminal_path v v []" by (rule terminal_path_empty)
  with \<open>valid_in_port (v, (plain_ant c))\<close>
  have "wf ?t" by (rule wf_tree)
  moreover

  from \<open>valid_in_port (v, plain_ant c)\<close> \<open>terminal_vertex v\<close>
  have "tfinite ?t" by (rule finite_tree)
  ultimately

  show "\<exists>\<Gamma> t. fst (root t) = (\<Gamma> \<turnstile> c) \<and> \<Gamma> |\<subseteq>| ass_forms \<and> wf t \<and> tfinite t" by blast
qed

end

end


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

theory ShortExecutions
imports Traces
begin

text \<open>
  Some properties about \<open>Cut ex\<close>, defined as follows:

  For every execution ex there is another shorter execution \<open>Cut ex\<close>
  that has the same trace as ex, but its schedule ends with an external action.
\<close>

definition oraclebuild :: "('a \<Rightarrow> bool) \<Rightarrow> 'a Seq \<rightarrow> 'a Seq \<rightarrow> 'a Seq"
  where "oraclebuild P =
    (fix \<cdot>
      (LAM h s t.
        case t of
          nil \<Rightarrow> nil
        | x ## xs \<Rightarrow>
            (case x of
              UU \<Rightarrow> UU
            | Def y \<Rightarrow>
                (Takewhile (\<lambda>x. \<not> P x) \<cdot> s) @@
                (y \<leadsto> (h \<cdot> (TL \<cdot> (Dropwhile (\<lambda>x. \<not> P x) \<cdot> s)) \<cdot> xs)))))"

definition Cut :: "('a \<Rightarrow> bool) \<Rightarrow> 'a Seq \<Rightarrow> 'a Seq"
  where "Cut P s = oraclebuild P \<cdot> s \<cdot> (Filter P \<cdot> s)"

definition LastActExtsch :: "('a,'s) ioa \<Rightarrow> 'a Seq \<Rightarrow> bool"
  where "LastActExtsch A sch \<longleftrightarrow> Cut (\<lambda>x. x \<in> ext A) sch = sch"

axiomatization where
  Cut_prefixcl_Finite: "Finite s \<Longrightarrow> \<exists>y. s = Cut P s @@ y"

axiomatization where
  LastActExtsmall1: "LastActExtsch A sch \<Longrightarrow> LastActExtsch A (TL \<cdot> (Dropwhile P \<cdot> sch))"

axiomatization where
  LastActExtsmall2: "Finite sch1 \<Longrightarrow> LastActExtsch A (sch1 @@ sch2) \<Longrightarrow> LastActExtsch A sch2"

ML \<open>
fun thin_tac' ctxt j =
  rotate_tac (j - 1) THEN'
  eresolve_tac ctxt [thin_rl] THEN'
  rotate_tac (~ (j - 1))
\<close>

subsection \<open>\<open>oraclebuild\<close> rewrite rules\<close>

lemma oraclebuild_unfold:
  "oraclebuild P =
    (LAM s t.
      case t of
        nil \<Rightarrow> nil
      | x ## xs \<Rightarrow>
          (case x of
            UU \<Rightarrow> UU
          | Def y \<Rightarrow>
            (Takewhile (\<lambda>a. \<not> P a) \<cdot> s) @@
            (y \<leadsto> (oraclebuild P \<cdot> (TL \<cdot> (Dropwhile (\<lambda>a. \<not> P a) \<cdot> s)) \<cdot> xs))))"
  apply (rule trans)
  apply (rule fix_eq2)
  apply (simp only: oraclebuild_def)
  apply (rule beta_cfun)
  apply simp
  done

lemma oraclebuild_UU: "oraclebuild P \<cdot> sch \<cdot> UU = UU"
  apply (subst oraclebuild_unfold)
  apply simp
  done

lemma oraclebuild_nil: "oraclebuild P \<cdot> sch \<cdot> nil = nil"
  apply (subst oraclebuild_unfold)
  apply simp
  done

lemma oraclebuild_cons:
  "oraclebuild P \<cdot> s \<cdot> (x \<leadsto> t) =
    (Takewhile (\<lambda>a. \<not> P a) \<cdot> s) @@
    (x \<leadsto> (oraclebuild P \<cdot> (TL \<cdot> (Dropwhile (\<lambda>a. \<not> P a) \<cdot> s)) \<cdot> t))"
  apply (rule trans)
  apply (subst oraclebuild_unfold)
  apply (simp add: Consq_def)
  apply (simp add: Consq_def)
  done

subsection \<open>Cut rewrite rules\<close>

lemma Cut_nil: "Forall (\<lambda>a. \<not> P a) s \<Longrightarrow> Finite s \<Longrightarrow> Cut P s = nil"
  apply (unfold Cut_def)
  apply (subgoal_tac "Filter P \<cdot> s = nil")
  apply (simp add: oraclebuild_nil)
  apply (rule ForallQFilterPnil)
  apply assumption+
  done

lemma Cut_UU: "Forall (\<lambda>a. \<not> P a) s \<Longrightarrow> \<not> Finite s \<Longrightarrow> Cut P s = UU"
  apply (unfold Cut_def)
  apply (subgoal_tac "Filter P \<cdot> s = UU")
  apply (simp add: oraclebuild_UU)
  apply (rule ForallQFilterPUU)
  apply assumption+
  done

lemma Cut_Cons:
  "P t \<Longrightarrow> Forall (\<lambda>x. \<not> P x) ss \<Longrightarrow> Finite ss \<Longrightarrow>
    Cut P (ss @@ (t \<leadsto> rs)) = ss @@ (t \<leadsto> Cut P rs)"
  apply (unfold Cut_def)
  apply (simp add: ForallQFilterPnil oraclebuild_cons TakewhileConc DropwhileConc)
  done

subsection \<open>Cut lemmas for main theorem\<close>

lemma FilterCut: "Filter P \<cdot> s = Filter P \<cdot> (Cut P s)"
  apply (rule_tac A1 = "\<lambda>x. True" and Q1 = "\<lambda>x. \<not> P x" and x1 = "s" in take_lemma_induct [THEN mp])
  prefer 3
  apply fast
  apply (case_tac "Finite s")
  apply (simp add: Cut_nil ForallQFilterPnil)
  apply (simp add: Cut_UU ForallQFilterPUU)
  text \<open>main case\<close>
  apply (simp add: Cut_Cons ForallQFilterPnil)
  done

lemma Cut_idemp: "Cut P (Cut P s) = (Cut P s)"
  apply (rule_tac A1 = "\<lambda>x. True" and Q1 = "\<lambda>x. \<not> P x" and x1 = "s" in
    take_lemma_less_induct [THEN mp])
  prefer 3
  apply fast
  apply (case_tac "Finite s")
  apply (simp add: Cut_nil ForallQFilterPnil)
  apply (simp add: Cut_UU ForallQFilterPUU)
  text \<open>main case\<close>
  apply (simp add: Cut_Cons ForallQFilterPnil)
  apply (rule take_reduction)
  apply auto
  done

lemma MapCut: "Map f\<cdot>(Cut (P \<circ> f) s) = Cut P (Map f\<cdot>s)"
  apply (rule_tac A1 = "\<lambda>x. True" and Q1 = "\<lambda>x. \<not> P (f x) " and x1 = "s" in
    take_lemma_less_induct [THEN mp])
  prefer 3
  apply fast
  apply (case_tac "Finite s")
  apply (simp add: Cut_nil)
  apply (rule Cut_nil [symmetric])
  apply (simp add: ForallMap o_def)
  apply (simp add: Map2Finite)
  text \<open>case \<open>\<not> Finite s\<close>\<close>
  apply (simp add: Cut_UU)
  apply (rule Cut_UU)
  apply (simp add: ForallMap o_def)
  apply (simp add: Map2Finite)
  text \<open>main case\<close>
  apply (simp add: Cut_Cons MapConc ForallMap FiniteMap1 o_def)
  apply (rule take_reduction)
  apply auto
  done

lemma Cut_prefixcl_nFinite [rule_format]: "\<not> Finite s \<longrightarrow> Cut P s \<sqsubseteq> s"
  apply (intro strip)
  apply (rule take_lemma_less [THEN iffD1])
  apply (intro strip)
  apply (rule mp)
  prefer 2
  apply assumption
  apply (tactic "thin_tac' \<^context> 1 1")
  apply (rule_tac x = "s" in spec)
  apply (rule nat_less_induct)
  apply (intro strip)
  apply (rename_tac na n s)
  apply (case_tac "Forall (\<lambda>x. \<not> P x) s")
  apply (rule take_lemma_less [THEN iffD2, THEN spec])
  apply (simp add: Cut_UU)
  text \<open>main case\<close>
  apply (drule divide_Seq3)
  apply (erule exE)+
  apply (erule conjE)+
  apply hypsubst
  apply (simp add: Cut_Cons)
  apply (rule take_reduction_less)
  text \<open>auto makes also reasoning about Finiteness of parts of \<open>s\<close>!\<close>
  apply auto
  done

lemma execThruCut: "is_exec_frag A (s, ex) \<Longrightarrow> is_exec_frag A (s, Cut P ex)"
  apply (case_tac "Finite ex")
  apply (cut_tac s = "ex" and P = "P" in Cut_prefixcl_Finite)
  apply assumption
  apply (erule exE)
  apply (rule exec_prefix2closed)
  apply (erule_tac s = "ex" and t = "Cut P ex @@ y" in subst)
  apply assumption
  apply (erule exec_prefixclosed)
  apply (erule Cut_prefixcl_nFinite)
  done

subsection \<open>Main Cut Theorem\<close>

lemma exists_LastActExtsch:
  "sch \<in> schedules A \<Longrightarrow> tr = Filter (\<lambda>a. a \<in> ext A) \<cdot> sch \<Longrightarrow>
    \<exists>sch. sch \<in> schedules A \<and> tr = Filter (\<lambda>a. a \<in> ext A) \<cdot> sch \<and> LastActExtsch A sch"
  apply (unfold schedules_def has_schedule_def [abs_def])
  apply auto
  apply (rule_tac x = "filter_act \<cdot> (Cut (\<lambda>a. fst a \<in> ext A) (snd ex))" in exI)
  apply (simp add: executions_def)
  apply (pair ex)
  apply auto
  apply (rule_tac x = "(x1, Cut (\<lambda>a. fst a \<in> ext A) x2)" in exI)
  apply simp

  text \<open>Subgoal 1: Lemma:  propagation of execution through \<open>Cut\<close>\<close>
  apply (simp add: execThruCut)

  text \<open>Subgoal 2:  Lemma:  \<open>Filter P s = Filter P (Cut P s)\<close>\<close>
  apply (simp add: filter_act_def)
  apply (subgoal_tac "Map fst \<cdot> (Cut (\<lambda>a. fst a \<in> ext A) x2) = Cut (\<lambda>a. a \<in> ext A) (Map fst \<cdot> x2)")
  apply (rule_tac [2] MapCut [unfolded o_def])
  apply (simp add: FilterCut [symmetric])

  text \<open>Subgoal 3: Lemma: \<open>Cut\<close> idempotent\<close>
  apply (simp add: LastActExtsch_def filter_act_def)
  apply (subgoal_tac "Map fst \<cdot> (Cut (\<lambda>a. fst a \<in> ext A) x2) = Cut (\<lambda>a. a \<in> ext A) (Map fst \<cdot> x2)")
  apply (rule_tac [2] MapCut [unfolded o_def])
  apply (simp add: Cut_idemp)
  done

subsection \<open>Further Cut lemmas\<close>

lemma LastActExtimplnil: "LastActExtsch A sch \<Longrightarrow> Filter (\<lambda>x. x \<in> ext A) \<cdot> sch = nil \<Longrightarrow> sch = nil"
  apply (unfold LastActExtsch_def)
  apply (drule FilternPnilForallP)
  apply (erule conjE)
  apply (drule Cut_nil)
  apply assumption
  apply simp
  done

lemma LastActExtimplUU: "LastActExtsch A sch \<Longrightarrow> Filter (\<lambda>x. x \<in> ext A) \<cdot> sch = UU \<Longrightarrow> sch = UU"
  apply (unfold LastActExtsch_def)
  apply (drule FilternPUUForallP)
  apply (erule conjE)
  apply (drule Cut_UU)
  apply assumption
  apply simp
  done

end


theory OperatorAmbiguity
  imports "LocalLexing2.Derivations" Containers.Containers

begin
locale OperatorAmbiguity = CFG +
  fixes Priority :: "(('a, 'b) rule \<times> ('a, 'b) rule) set"
  fixes Left :: "(('a, 'b) rule \<times> ('a, 'b) rule) set"
  fixes Right:: "(('a, 'b) rule \<times> ('a, 'b) rule) set"
  assumes Priority_between_alternates: "\<forall>((N1, r1), (N2, r2)) \<in> Priority. (N1 = N2)"
  assumes Priority_valid: "\<forall>((N1, r1), (N2, r2)) \<in> Priority.  ((N1 = hd r1 \<and>hd r1 = last r2) \<or> ((N1 = hd r1 \<and> last r1 = hd r2)))"
  assumes Priority_is_strictpart: "antisym Priority \<and> trans Priority \<and> irrefl Priority"
  assumes Left_between_alternates: "\<forall>((N1, r1), (N2, r2)) \<in> Left. (N1 = N2)"
  assumes Left_valid: "\<forall>((N1, r1), (N2, r2)) \<in> Left.  (N1 = hd r1\<and>hd r2 = hd r1 \<and>hd r1 = last r1  \<and>hd r2 = last r2)"
  assumes Right_between_alternates: "\<forall>((N1, r1), (N2, r2)) \<in> Right. (N1 = N2)"
  assumes Right_valid: "\<forall>((N1, r1), (N2, r2)) \<in> Right.  (N1 = hd r1\<and>hd r2 = hd r1 \<and>hd r1 = last r1  \<and>hd r2 = last r2)"
  assumes Relation_safety: "(Left \<inter> Right = {}) \<and> (Priority \<inter> Right = {}) \<and> (Left \<inter> Priority = {})"
begin

(*how to best define those kind of derivations? \<longrightarrow> need derivation sequence*)
(*how do I define a precedence left derivation?

! !precedencederivations have to be defined on their subtrees specifically*)
(*actual way it works is all subtrees are precedenceleft derivations and root does not have any of the other*)
(*along right/left spine?*)

fun "derive"::"('a, 'b) sentence \<Rightarrow> nat \<Rightarrow> ('a, 'b) rule \<Rightarrow> ('a, 'b)sentence" where
"derive a n (N, r) = (take (n-1) a)@r@(drop n a) "

fun valid::" ('a, 'b) sentence \<Rightarrow> ('a, 'b) rule \<Rightarrow> bool" where
"valid s (N, r) =  ((last r = N) \<and>(\<exists>w . is_word w \<and> s = w@[N]@r))"

(*one level for associativity, all others along, right/left spine*)

(*this happens until \<Longrightarrow> remember position of any other nonterminal and iterate all get applied to it*)
(*splits derivation such that all children in leftmost expansion of leading rule are in left*)
fun left_children::"('a, 'b) rule \<Rightarrow> ('a, 'b) derivation \<Rightarrow> ('a, 'b) derivation \<times> ('a, 'b) derivation" where
"left_children (_, r) D = (if \<not> is_nonterminal (hd r) then ([],  D)
                      else
                        snd (foldr
    (\<lambda>(n, S, R) (N, left, right). if (n \<le> N) then (n+ length R,left@[(n,S, R)], right) else  (n ,left, right@[(n,S, R)])) D (0, [], [])))"

(*drop all until one derivation gets applied to the rightmost terminal*)
(*potential bug length r*)
(*splits derivatioin such that all children in rightmost expansion of leading rule are in right*)
fun right_children::"('a, 'b) rule \<Rightarrow> ('a, 'b) derivation \<Rightarrow> ('a, 'b) derivation \<times> ('a, 'b) derivation" where
"right_children (_, r) D = (if \<not> is_nonterminal (last r) then ([],  D)
                      else
                        snd (foldr
    (\<lambda>(n, S, R) (N, left, right). if (n < N) then (n+ length R,left@[(n,S, R)], right) else  (n ,left, right@[(n,S, R)])) D (length r, [], [])))"

lemma left_children_safe: "fst (left_children r D)@(snd (left_children r D)) = D"
  apply(induct D)
   apply(auto)
  sorry

lemma right_children_safe: "fst (right_children r D)@(snd (right_children r D)) = D"
  apply(induct D)
   apply(auto)
  sorry

fun rightspine::"('a, 'b) rule \<Rightarrow> ('a, 'b) derivation \<Rightarrow> ('a, 'b) rule set" where
"rightspine (S, r) D = set (map snd (filter (\<lambda>(_, N, _). N = S)(takeWhile (\<lambda>(n, N, r). is_nonterminal (hd r)) (snd (right_children (S, r) D)))))"

(*
fun leftspine::"sentence \<Rightarrow> rule \<Rightarrow> derivation \<Rightarrow> rule set" where
"leftspine s (S, r) D = set (snd (foldr (\<lambda>(n, rule) (a, d). let s = derive a n rule in (s, if valid s (S, r) then rule#d else d))  D (s@[S]@r ,[]))) "
*)

fun rightexpansion::"('a, 'b) derivation \<Rightarrow> ('a, 'b) derivation" where
"rightexpansion [] = []" |
"rightexpansion ((n, H, r)#D) = (if \<not> is_nonterminal (last r) then [] else
      snd (foldr (\<lambda>(n1, H1, r1) (N, s). if n1 = N then
          (if  is_nonterminal (last r1) then ((N + length r1), (n1, H1, r1)#s) else (N -1, (n1, H1, r1)#s))
          else (N, s)) D (n + length r, [])))"

fun leftspine::"('a, 'b) rule \<Rightarrow> ('a, 'b) derivation \<Rightarrow> ('a, 'b) rule set" where
"leftspine (S, r) D = (if \<not> is_nonterminal (hd r) then {}  else set  (map snd (rightexpansion D)))"

fun PrecedenceLeftDerivation :: "('a, 'b) sentence \<Rightarrow> ('a, 'b) derivation \<Rightarrow> ('a, 'b) sentence \<Rightarrow> bool"
where
  "PrecedenceLeftDerivation a [] b = (a = b)"
| "PrecedenceLeftDerivation a (d#D) b = (\<exists> x. LeftDerives1 a (fst d) (snd d) x \<and> PrecedenceLeftDerivation x D b \<and>
   (leftspine (snd d) D  \<inter> ((Priority) `` {snd d}) = {}) \<and>  (rightspine (snd d) D  \<inter> ((Priority) `` {snd d}) = {}))"
(*rotations are not as easy \<Longrightarrow> have to show that no new conflicts arise*)
(*or can we prove safety in another way?*)
(*E\<alpha> > \<beta>E*)
fun ambiguous1::"('a, 'b) symbol \<Rightarrow> ('a, 'b) rule \<Rightarrow>('a, 'b)  rule \<Rightarrow> bool" where
"ambiguous1 s (N1, r1) (N2, r2)  = ((s = N1) \<and>(N1 = N2) \<and> (N1 = hd r1 \<and>hd r1 = last r2))"
(*\<beta>E > E\<alpha>*)
fun ambiguous2::"('a, 'b) symbol \<Rightarrow> ('a, 'b) rule \<Rightarrow> ('a, 'b) rule \<Rightarrow> bool" where
"ambiguous2 s (N1, r1) (N2, r2)  = ( (s = N1) \<and>(N1 = N2) \<and> (N1 = hd r2 \<and>hd r2 = last r1))"

(*need additional lemma for derivation shift*)
(*have to prove that left most holds*)
(*direction of application should not *)
(*keep a look at derivation_swap in derivation
*)
(*prove this by induction on D*)
(*is_Word append*)
lemma nth_append':"(a@l) ! (n + length a) = l ! n  "
  apply(induct a, auto)
  done

lemma Derives1_append:"is_sentence u \<Longrightarrow> Derives1 a n r b \<Longrightarrow> Derives1 (u@a) (n + length u) r (u@b)"
  apply(auto simp add: Derives1_def)
  apply(rule_tac x="u@x" in exI)
  apply(rule_tac x="y" in exI)
  apply(auto simp add: is_sentence_concat)
  done
lemma LeftDerives1_append_word:"LeftDerives1 a i r b \<Longrightarrow> is_word u \<Longrightarrow> LeftDerives1 (u@a) (i + (length u)) r (u@b)"
  apply(auto simp add: Derives1_append  LeftDerives1_def nth_append leftmost_def)
done
(*possible take rules used: first subgoal is on shifting on operator*)
lemma LeftDerivation_append_word:"is_word u \<Longrightarrow> LeftDerivation a D b \<Longrightarrow> LeftDerivation (u@a) (derivation_shift D 0 (length u)) (u@b)"
  apply(auto simp add: derivation_shift_def Derivation_take)
  apply(induct D arbitrary:u a b)
  apply(auto )
  apply(rule_tac x="u@x" in exI)
  apply(simp add:  LeftDerives1_append_word)
  done

lemma nth_take:"n < n1 \<Longrightarrow>  (take n1 l) ! n =  l ! n  "
  apply(induct l, auto)
  done

lemma nth_concat:"n < length l \<Longrightarrow>   (take (length l) (l@a)) ! n = (l@a) ! n"
  by(rule nth_take)

lemma Derives1_concat:"is_sentence d \<Longrightarrow> Derives1 a i r b \<Longrightarrow> Derives1 (a@d) i r (b@d)"
  apply(auto simp add: Derives1_def)
  apply(rule_tac x="x" in exI)
  apply(rule_tac x="y@d" in exI)
  apply(auto simp add: is_sentence_concat)
  done

lemma LeftDerives1_concat:"is_sentence d \<Longrightarrow> LeftDerives1 a i r b \<Longrightarrow> LeftDerives1 (a@d) i r (b@d)"
  apply(auto simp add: LeftDerives1_def leftmost_def Derives1_concat nth_append)
done

lemma LeftDerivation_concat: "is_sentence d \<Longrightarrow> LeftDerivation a D b \<Longrightarrow> LeftDerivation (a@d) D (b@d)"
  apply(induct D arbitrary: a b d)
   apply(auto )
  apply(rule_tac x="x@d" in exI)
  apply(simp add: LeftDerives1_concat)
 done

theorem type1_derivation:
  assumes E:"is_nonterminal E" and "(E, \<alpha>@[E]) \<in> \<RR>" and "(E, E#\<beta>)  \<in> \<RR>"
    and v:"is_word v" and
mu:"is_word \<mu>" and root:"LeftDerivation [E]  D1 (\<mu>@[E])" and first_word:"LeftDerivation \<alpha> D2 v" and tail:"LeftDerivation [E] D3 (E#\<gamma>)"
  and gamma:"is_sentence \<gamma>"
  shows "LeftDerivation [E]  (D1@[((length \<mu>), (E, \<alpha>@[E]))]@(derivation_shift D2 0 (length \<mu>))@(derivation_shift D3 0 (length (\<mu>@v)))@[((length (\<mu>@v)), (E, E#\<beta>))]) (\<mu>@v@E#\<beta>@\<gamma>)"
proof -
  from assms have alphaE:"LeftDerives1 [E] (0) (E, \<alpha>@[E]) (\<alpha>@[E])" by (simp add: LeftDerives1_def leftmost_def Derives1_def)
  from assms have Ebeta:"LeftDerives1 [E] (0) (E, E#\<beta>) (E#\<beta>)" by (simp add: LeftDerives1_def leftmost_def Derives1_def)
  from mu and v have muv:"is_word (\<mu>@v)" by simp
  from alphaE and mu have "LeftDerives1 (\<mu>@[E]) (length \<mu>) (E, \<alpha>@[E])  (\<mu>@\<alpha>@[E])" using LeftDerives1_append_word by fastforce
  from this and root have seq1: "LeftDerivation [E] (D1@[((length \<mu>), (E, \<alpha>@[E]))])  (\<mu>@\<alpha>@[E])" by (auto simp add: LeftDerivation_LeftDerives1 )
  from first_word and mu have "LeftDerivation  (\<mu>@\<alpha>) (derivation_shift D2 0 (length \<mu>)) (\<mu>@v)" by (auto simp add: LeftDerivation_append_word)
  from this and E have "LeftDerivation  (\<mu>@\<alpha>@[E]) (derivation_shift D2 0 (length \<mu>)) (\<mu>@v@[E])" using  LeftDerivation_concat apply(force simp: is_sentence_def is_symbol_def) done
  from seq1 and this have seq2:"LeftDerivation [E] (D1@[((length \<mu>), (E, \<alpha>@[E]))]@(derivation_shift D2 0 (length \<mu>)))  (\<mu>@v@[E])" using LeftDerivation_implies_append apply(force) done
  from tail and muv have "LeftDerivation (\<mu>@v@[E]) (derivation_shift D3 0 (length (\<mu>@v))) (\<mu>@v@(E#\<gamma>))" using LeftDerivation_append_word by fastforce
  from this and seq2 have seq3:"LeftDerivation [E]  (D1@[((length \<mu>), (E, \<alpha>@[E]))]@(derivation_shift D2 0 (length \<mu>))@(derivation_shift D3 0 (length (\<mu>@v))))(\<mu>@v@(E#\<gamma>))" using LeftDerivation_append  by fastforce
  from Ebeta and gamma have "LeftDerives1 (E#\<gamma>) 0 (E, E#\<beta>)  (E#\<beta>@\<gamma>)" using LeftDerives1_concat by fastforce
  from this and muv have  "LeftDerives1 (\<mu>@v@E#\<gamma>) (length (\<mu>@v)) (E, E#\<beta>)  (\<mu>@v@E#\<beta>@\<gamma>)" using LeftDerives1_append_word by fastforce
  from this and seq3 have "LeftDerivation [E]  (D1@[((length \<mu>), (E, \<alpha>@[E]))]@(derivation_shift D2 0 (length \<mu>))@(derivation_shift D3 0 (length (\<mu>@v)))@[((length (\<mu>@v)), (E, E#\<beta>))]) (\<mu>@v@E#\<beta>@\<gamma>)" using LeftDerivation_append by auto
  from this show ?thesis by auto
qed

theorem type2_derivation:
  assumes E:"is_nonterminal E" and "(E, \<alpha>@[E]) \<in> \<RR>" and beta:"(E, E#\<beta>)  \<in> \<RR>"
    and v:"is_word v" and
mu:"is_word \<mu>" and root:"LeftDerivation [E]  D1 (\<mu>@[E])" and first_word:"LeftDerivation \<alpha> D2 v" and tail:"LeftDerivation [E] D3 (E#\<gamma>)"
  and gamma:"is_sentence \<gamma>"
shows  "LeftDerivation [E] (D3@[(0, (E, E#\<beta>))]@D1@[( (length \<mu>),(E, \<alpha>@[E]))]@(derivation_shift D2 0 (length \<mu>)))  (\<mu>@v@[E]@\<beta>@\<gamma>)"
proof -
  from assms have alphaE:"LeftDerives1 [E] (0) (E, \<alpha>@[E]) (\<alpha>@[E])" by (simp add: LeftDerives1_def leftmost_def Derives1_def)
  from assms have Ebeta:"LeftDerives1 [E] (0) (E, E#\<beta>) (E#\<beta>)" by (simp add: LeftDerives1_def leftmost_def Derives1_def)
  from mu and v have muv:"is_word (\<mu>@v)" by simp
  from beta have "is_sentence (E#\<beta>)" by (simp)
  from this have "is_sentence \<beta>" by (simp add: is_sentence_def)
  from this and gamma have betagamma:"is_sentence (\<beta>@\<gamma>)" by (simp add: is_sentence_concat)
  from betagamma and E have Ebetagamma:"is_sentence ([E]@\<beta>@\<gamma>)" by (simp add: is_sentence_def)
  from Ebeta and gamma have "LeftDerives1 (E#\<gamma>) 0 (E, E#\<beta>)  (E#\<beta>@\<gamma>)" using LeftDerives1_concat by fastforce
  from this and tail have  seq1:"LeftDerivation [E] (D3@[(0, (E, E#\<beta>))]) (E#\<beta>@\<gamma>)" by (auto simp add: LeftDerivation_LeftDerives1)
  from betagamma and root have "LeftDerivation (E#\<beta>@\<gamma>) D1 (\<mu>@E#\<beta>@\<gamma>)" using LeftDerivation_concat by fastforce
  from this and seq1 have seq2:"LeftDerivation  [E] (D3@[(0, (E, E#\<beta>))]@D1)  (\<mu>@E#\<beta>@\<gamma>)" using LeftDerivation_implies_append by fastforce
  from mu and alphaE have "LeftDerives1 (\<mu>@[E]) (length \<mu>) (E, \<alpha>@[E]) (\<mu>@\<alpha>@[E])" using LeftDerives1_append_word by fastforce
  from betagamma and this  have "LeftDerives1 (\<mu>@[E]@\<beta>@\<gamma>) (length \<mu>) (E, \<alpha>@[E]) (\<mu>@\<alpha>@[E]@\<beta>@\<gamma>)" using LeftDerives1_concat by fastforce
  from this and seq2 have seq3:"LeftDerivation  [E] (D3@[(0, (E, E#\<beta>))]@D1@[( (length \<mu>),(E, \<alpha>@[E]))])  (\<mu>@\<alpha>@[E]@\<beta>@\<gamma>)" using LeftDerivation_LeftDerives1 by fastforce
  from first_word and mu have "LeftDerivation (\<mu>@\<alpha>) (derivation_shift D2 0 (length \<mu>)) (\<mu>@v)" using LeftDerivation_append_word by fastforce
  from this and Ebetagamma have "LeftDerivation (\<mu>@\<alpha>@[E]@\<beta>@\<gamma>) (derivation_shift D2 0 (length \<mu>))  (\<mu>@v@[E]@\<beta>@\<gamma>)" using LeftDerivation_concat by fastforce
  from this and seq3 have "LeftDerivation [E] (D3@[(0, (E, E#\<beta>))]@D1@[( (length \<mu>),(E, \<alpha>@[E]))]@(derivation_shift D2 0 (length \<mu>)))  (\<mu>@v@[E]@\<beta>@\<gamma>)" using LeftDerivation_implies_append by fastforce
  from this show ?thesis by auto
qed

definition leftrecursive::"('a, 'b) symbol \<Rightarrow> ('a, 'b) rule \<Rightarrow> bool" where
"leftrecursive s R =  (snd R \<noteq> [] \<and> is_nonterminal s \<and> ((fst R) = s) \<and> (last (snd R) = s))"

(*separation of sequence using LeftDerivation_append?*)
(*imply existence of other rotation*)
(*might have to fix E as start symbol \<Longrightarrow> any other way to enable rotation(?)*)
(*maybe not additional condition for splitting?*)
fun split_derivation::"('a, 'b) derivation \<Rightarrow> (nat \<times> ('a, 'b) rule) \<Rightarrow> (('a, 'b)derivation \<times>  ('a, 'b)derivation)" where
"split_derivation D d = (takeWhile (\<lambda> s. s \<noteq> d) D , dropWhile (\<lambda> s. s \<noteq> d) D)"

lemma is_sentence_drop:
  assumes "is_sentence s"
  shows "is_sentence (drop i s)"
proof -
  have l:"set (drop i s) \<subseteq> set s" using set_drop_subset by fast
  from assms have "\<forall> x \<in> set s . is_symbol x" using list_all_def is_sentence_def by metis
  with l have "\<forall> x \<in> set (drop i s) . is_symbol x" by blast
  then  show ?thesis using list_all_def is_sentence_def by metis
qed

lemma takedrop1: " take (i-j) (drop j n) = drop j (take i n)"
  apply(auto simp add: set_def drop_take )
  done

lemma list_all_tl:"list_all a p \<Longrightarrow> list_all a (tl p)"
  apply(induct p)
   apply(auto simp: tl_def)
  done
lemma is_word_drop:"is_word u \<Longrightarrow>  is_word ( drop j u)"
  apply(auto simp add: is_word_def)
  apply(induct j arbitrary: u)
   apply(auto simp add: drop_0)
  apply(auto simp add: drop_Suc )
  apply(simp add: list_all_tl)
  done
lemma take_invar: "take i u = take (i+j-j) u"
  apply(induct i)
   apply(auto simp add:  take_Cons )
  done
lemma is_word_drop1: "j \<le> i \<Longrightarrow>is_word (take i  u) \<Longrightarrow>  is_word (take (i - j) (drop j u))"
  apply(auto simp: take_drop )
  using is_word_drop by simp

lemma wordsmallerleftmost:
  assumes  word:"is_word (take i u)"  and left:" leftmost j u"  and valid:"i \<le> length u"
  shows "i \<le> j"
proof (rule ccontr)
  assume "\<not> i \<le> j"
  from this have greater:"j < i" by auto
  from left have nonterm:"is_word (take j u) \<and> is_nonterminal (u ! j) \<and> (j < length u)"apply(auto simp: leftmost_def) done
  from this and greater have "(take i u) ! j = u ! j" by auto
  from this and nonterm have non_terminal:"is_nonterminal ((take i u) ! j)" by auto
  from greater and valid have "(length (take i u)) > j" by auto
  from this and word and greater have terminal:"is_terminal ((take i u) ! j)" by (auto simp add: is_word_def list_all_length)
  from this and non_terminal show "False"  using is_terminal_nonterminal by fastforce
qed
lemma LeftDerives1_take:
  assumes "LeftDerives1 u n r v \<and> is_word (take j u) \<and> j \<le> length u "
  shows "LeftDerives1 (drop j  u) (n-j) r (drop j v)"
proof -
  from assms have leftmost:"leftmost n u" by (simp add: LeftDerives1_def)
  from this and assms have less:"j \<le> n" using wordsmallerleftmost by fastforce
  from assms obtain x y N \<alpha> where
         deriv1:"u = x @ [N] @ y \<and> v = x @ \<alpha> @ y \<and> is_sentence x \<and> is_sentence y \<and>(N, \<alpha>) \<in> \<RR> \<and> r = (N, \<alpha>) \<and> n = length x" apply(simp add:  LeftDerives1_def Derives1_def) by blast
  from this and less have "j \<le> length x" by auto
  from  this and deriv1 have lem:"Derives1 (drop j u) (n -j) r (drop j v)" apply (simp add:Derives1_def leftmost_def) apply(rule_tac x="drop j x" in exI)
    apply(rule_tac x="y" in exI) apply(auto) apply(simp add: is_sentence_drop) done
  from leftmost have smallerlength:"n < length u" by (simp add: leftmost_def)
  from deriv1 have c:"length x <= length v" by auto
  from leftmost and less have "leftmost (n -j) (drop j u)" apply (auto simp add: leftmost_def is_word_drop)  using is_word_drop1 by fastforce
  from lem  and this  have head:"LeftDerives1 (drop j u) (n -j) r (drop j v)" by (auto simp add: LeftDerives1_def)
  from this show ?thesis by auto
  qed
lemma LeftDerivation_take:
  shows "LeftDerivation u D  v \<Longrightarrow> is_word(take j u) \<and> j \<le> length u\<Longrightarrow> LeftDerivation (drop j  u) (derivation_shift D j 0) (drop j v)"
proof (induction D arbitrary: u v)
  case Nil

  with Nil have " u = v" by auto
  with this show ?case by (auto simp add: derivation_shift_def)
next
  case (Cons d D)
  from Cons have "(\<exists> x. LeftDerives1 u (fst d) (snd d) x \<and> LeftDerivation x D v)" by auto
  from this obtain c where first:"LeftDerives1 u (fst d) (snd d) c" and tail:"LeftDerivation c D v" by blast
  from this have fst:"leftmost (fst d) u" by (simp add: LeftDerives1_def)
  from fst and Cons have less:"j \<le> fst d" using wordsmallerleftmost by fastforce
  from first obtain x y N \<alpha> where
         deriv1:"u = x @ [N] @ y \<and> c = x @ \<alpha> @ y \<and> is_sentence x \<and> is_sentence y \<and>(N, \<alpha>) \<in> \<RR> \<and> (snd d) = (N, \<alpha>) \<and> (fst d) = length x" apply(simp add:  LeftDerives1_def Derives1_def) by blast
  from this and less have smaller_word:"j \<le> length x" by auto
  from  this and deriv1 have lem:"Derives1 (drop j u) ((fst d) -j) (snd d) (drop j c)" apply (simp add:Derives1_def leftmost_def) apply(rule_tac x="drop j x" in exI)
    apply(rule_tac x="y" in exI) apply(auto) apply(simp add: is_sentence_drop) done
  from fst have smallerlength:"(fst d) < length u" by (simp add: leftmost_def)
  from deriv1 have c:"length x <= length c" by auto
  from fst and less have "leftmost ((fst d) -j) (drop j u)" apply (auto simp add: leftmost_def is_word_drop)  using is_word_drop1 by fastforce
  from lem  and this  have head:"LeftDerives1 (drop j u) ((fst d) -j) (snd d) (drop j c)" by (auto simp add: LeftDerives1_def)
  from first and deriv1 have "is_word x" by (auto simp: LeftDerives1_def)
  from smaller_word and deriv1 have " take j  c = take j u" by auto
  from this  and smaller_word and Cons and c have "is_word (take j c) \<and> j \<le> length c" by auto
  from this and tail and Cons have INH:"LeftDerivation  (drop j c) (derivation_shift D j 0) (drop j v)" by fastforce
  from this and head show ?case by fastforce
qed

lemma split_preserves:"(fst(split_derivation D d))@(snd(split_derivation D d)) = D"
  apply(auto)
  done

(*s look to be leftrecursive anyways*)

lemma rotatetype1_type2_0:
  assumes valid:"is_leftderivation s" and s_deriv:"s=\<mu>@[E] \<and> is_word \<mu>" and
    leftrecursive:"leftrecursive E (snd d)" and deriv:"LeftDerivation s (d#D) s1" and
    conflict:"\<exists>r1. r1 \<in> rightspine (snd d) D "
  shows head:"\<exists> D1 .LeftDerivation [E]  D1 (\<mu>@[E])" and "LeftDerivation \<mu> D2 v \<and> is_word v" and tail:"LeftDerivation [E] D3 (E#\<gamma>)"
proof -
  from valid have "\<exists> D0 . LeftDerivation [\<SS>] D0 s" apply (simp add: is_leftderivation_def) using  leftderives_implies_LeftDerivation by fastforce
  from this obtain D0 where "LeftDerivation [\<SS>] D0 s" by blast
  from deriv have " \<exists> x.(LeftDerives1 s (fst d) (snd d) x \<and> LeftDerivation x D s1)" by auto
  obtain \<alpha> where "\<alpha> = (snd (snd d))" by blast
  from s_deriv have l1:"drop (length \<mu>) s = [E]" by auto
  from s_deriv have l2:"is_word (take (length \<mu>) s) \<and> length \<mu> < length s" by auto
  from l1 and l2 and deriv have lderiv:"LeftDerivation (drop (length \<mu>) s) (derivation_shift (d#D) (length \<mu>) 0) (drop (length \<mu>) s1)" using LeftDerivation_take by fastforce
  (*prove that we have a follow up derivation with \<alpha>@[E]*)
  from this have "LeftDerivation (drop (length \<mu>) s) ((fst d - (length \<mu>), snd d)#(derivation_shift D (length \<mu>) 0)) (drop (length \<mu>) s1)" by simp
  from this have " \<exists> x.(LeftDerives1  (drop (length \<mu>) s) (fst d - (length \<mu>)) (snd d) x \<and> LeftDerivation x  (derivation_shift (D) (length \<mu>) 0) (drop (length \<mu>)s1))" by auto
  then obtain x1 where x1':"LeftDerives1 (drop (length \<mu>) s) (fst d - (length \<mu>)) (snd d) x1" and x2':"LeftDerivation x1  (derivation_shift (D) (length \<mu>) 0) (drop (length \<mu>) s1)" by blast
  from l1 and l2 and x1' have l3': "LeftDerives1 [E] (fst d - (length \<mu>)) (snd d) x1" using LeftDerives1_take by fastforce
  from x1' have "snd d \<in> \<RR>" by (auto simp: LeftDerives1_def)
  from this and  leftrecursive have l4:"LeftDerives1 [E] 0 (snd d) (snd (snd d))" apply(auto simp add: LeftDerives1_def Derives1_def leftmost_def leftrecursive_def) apply(rule_tac x="[]" in exI) apply(rule_tac x="[]" in exI) apply(rule_tac x="fst (snd d)" in exI)
    apply(auto)    done
  from l3' and l4 have "0 = fst d- (length \<mu>)" apply (auto simp add: LeftDerives1_def) using leftmost_unique by fastforce
  from this and l4 and l3' have eq:"x1 = (snd (snd d))" apply(auto simp: LeftDerives1_def) using Derives1_unique_dest by fastforce
  obtain \<alpha>E where aE:"\<alpha>E = (snd (snd d))" by blast
  from this and leftrecursive have last:"last (\<alpha>E)= E" by (auto simp add: leftrecursive_def)
  from aE and  leftrecursive have nonempty:"\<alpha>E \<noteq> []" by (auto simp add: leftrecursive_def last_def)
  from aE  obtain \<alpha> where "\<alpha>  = butlast \<alpha>E"  by blast
  from this and last and nonempty  have "\<alpha>@[E] = \<alpha>E" by auto
  from this and aE and eq have aE1:"x1 = (\<alpha>@[E])" by auto
  from this and l4 and eq have "LeftDerives1 [E] 0 (snd d) (\<alpha>@[E])" by auto
  from aE1 and x2' have "LeftDerivation (\<alpha>@[E]) (derivation_shift D (length \<mu>) 0) (drop (length \<mu>) s1)" by auto
  obtain D' where "D' = derivation_shift D (length \<mu>) 0" by blast

  show  "\<exists>D1. LeftDerivation [E] D1 (\<mu> @ [E])" sorry
  show "LeftDerivation \<mu> D2 v \<and> is_word v" sorry
  show "LeftDerivation [E] D3 (E # \<gamma>)" sorry
qed

lemma rotatetype1_type2:
  assumes valid:"is_leftderivation s" and s_deriv:"is_word (take (length s -1) s) \<and> is_nonterminal (last s)  "and leftrecursive:"leftrecursive E (snd d)" and deriv:"LeftDerivation s (d#D) s1" and " \<exists>r1. r1 \<in> leftspine (snd d) D "
  shows "\<exists> D1 .LeftDerivation [E]  D1 (\<mu>@[E]) \<and> is_word \<mu>" and "LeftDerivation \<alpha> D2 v" and tail':"LeftDerivation [E] D3 (E#\<gamma>)"
proof -

  show  "\<exists>D1. LeftDerivation [E] D1 (\<mu> @ [E]) \<and> is_word \<mu>" sorry
  show "LeftDerivation \<alpha> D2 v" sorry
  show "LeftDerivation [E] D3 (E # \<gamma>)" sorry
qed
(*prove theorems that enable a swap given an ambiguous rule pairing \<Longrightarrow> i.e. this left spine, right spine thing*)
(*transitivity *)
theorem soundness:
  shows  "LeftDerivation s D s1 \<Longrightarrow>\<exists> D1. PrecedenceLeftDerivation s D1  s1"
proof (induction D arbitrary: s s1)
  case Nil
  from Nil  have "s = s1" by auto
  with this show ?case apply (rule_tac x="[]" in exI) by auto
next
  case (Cons d D)
  then show ?case sorry
qed
(*alternative formulation of safety, formalize removal scheme*)

(*theorem safety:
  sorry
  *)
(*by induction on length of derivation sequences*)

(*completeness relies on total order though*)
theorem completeness:"PrecedenceLeftDerivation s D1 s1 \<Longrightarrow> PrecedenceLeftDerivation s D2 s2 \<Longrightarrow> D1 = D2"
  sorry
end

end


(*<*)
\<comment>\<open> ********************************************************************
 * Project         : CSP-RefTK - A Refinement Toolkit for HOL-CSP
 * Version         : 1.0
 *
 * Author          : Burkhart Wolff, Safouan Taha, Lina Ye.
 *
 * This file       : A Normalization Theory
 *
 * Copyright (c) 2020 Université Paris-Saclay, France
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *
 *     * Redistributions in binary form must reproduce the above
 *       copyright notice, this list of conditions and the following
 *       disclaimer in the documentation and/or other materials provided
 *       with the distribution.
 *
 *     * Neither the name of the copyright holders nor the names of its
 *       contributors may be used to endorse or promote products derived
 *       from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ******************************************************************************\<close>
(*>*)

chapter\<open> Normalisation of Deterministic CSP Processes \<close>

theory Process_norm

imports "Properties" "Fix_ind_ext"

begin

section\<open>Deterministic normal-forms with explicit state\<close>

abbreviation "P_dnorm Tr Up \<equiv> (\<mu> X. (\<lambda> s. \<box> e \<in> (Tr s) \<rightarrow> X (Up s e)))"

notation P_dnorm ("P\<^sub>n\<^sub>o\<^sub>r\<^sub>m\<lbrakk>_,_\<rbrakk>" 60)

lemma dnorm_cont[simp]:
  fixes Tr::"'state::type \<Rightarrow> 'event::type set" and Up::"'state \<Rightarrow> 'event \<Rightarrow> 'state"
  shows "cont (\<lambda>X. (\<lambda>s. \<box> e \<in> (Tr s) \<rightarrow> X (Ur s e)))" (is "cont ?f")
proof -
  have  "cont (\<lambda>X. ?f X s)" for s by (simp add:cont_fun)
  then show ?thesis by simp
qed

section\<open>Interleaving product lemma\<close>

lemma dnorm_inter:
  fixes Tr\<^sub>1 ::"'state\<^sub>1::type \<Rightarrow> 'event::type set" and Tr\<^sub>2::"'state\<^sub>2::type \<Rightarrow> 'event set"
    and Up\<^sub>1 ::"'state\<^sub>1 \<Rightarrow> 'event \<Rightarrow> 'state\<^sub>1" and Up\<^sub>2::"'state\<^sub>2 \<Rightarrow> 'event \<Rightarrow> 'state\<^sub>2"
  defines P: "P \<equiv> P\<^sub>n\<^sub>o\<^sub>r\<^sub>m\<lbrakk>Tr\<^sub>1,Up\<^sub>1\<rbrakk>" (is "P \<equiv> fix\<cdot>(\<Lambda> X. ?P X)")
  defines Q: "Q \<equiv> P\<^sub>n\<^sub>o\<^sub>r\<^sub>m\<lbrakk>Tr\<^sub>2,Up\<^sub>2\<rbrakk>" (is "Q \<equiv> fix\<cdot>(\<Lambda> X. ?Q X)")

  assumes indep: \<open>\<forall>s\<^sub>1 s\<^sub>2. Tr\<^sub>1 s\<^sub>1 \<inter> Tr\<^sub>2 s\<^sub>2 = {}\<close>

  defines Tr: "Tr \<equiv> (\<lambda>(s\<^sub>1,s\<^sub>2). Tr\<^sub>1 s\<^sub>1 \<union> Tr\<^sub>2 s\<^sub>2)"
  defines Up: "Up \<equiv> (\<lambda>(s\<^sub>1,s\<^sub>2) e. if e \<in> Tr\<^sub>1 s\<^sub>1 then (Up\<^sub>1 s\<^sub>1 e,s\<^sub>2)
                                else if e \<in> Tr\<^sub>2 s\<^sub>2 then (s\<^sub>1, Up\<^sub>2 s\<^sub>2 e)
                                else (s\<^sub>1,s\<^sub>2))"
  defines S: "S \<equiv> P\<^sub>n\<^sub>o\<^sub>r\<^sub>m\<lbrakk>Tr,Up\<rbrakk>" (is "S \<equiv> fix\<cdot>(\<Lambda> X. ?S X)")

  shows "(P s\<^sub>1 ||| Q s\<^sub>2) = S (s\<^sub>1,s\<^sub>2)"
proof -
  have P_rec: "P = ?P P" using fix_eq[of "(\<Lambda> X. ?P X)"] P by simp
  have Q_rec: "Q = ?Q Q" using fix_eq[of "(\<Lambda> X. ?Q X)"] Q by simp
  have S_rec: "S = ?S S" using fix_eq[of "(\<Lambda> X. ?S X)"] S by simp
  have dir1: "\<forall> s\<^sub>1 s\<^sub>2. (P s\<^sub>1 ||| Q s\<^sub>2) \<sqsubseteq> S (s\<^sub>1, s\<^sub>2)"
  proof(subst P, subst Q,
        induct rule:parallel_fix_ind_inc[of "\<lambda>x y. \<forall> s\<^sub>1 s\<^sub>2. (x s\<^sub>1 ||| y s\<^sub>2) \<sqsubseteq> S (s\<^sub>1,s\<^sub>2)"])
      case adm:1
      then show ?case
        by (intro adm_all adm_below) (simp_all add: cont2cont_fun)
    next
      case base_fst:(2 y)
      then show ?case by (metis Inter_commute app_strict minimal par_Int_bot)
    next
      case base_snd:(3 x)
      then show ?case by (simp add: par_Int_bot)
    next
      case step:(4 x y)
      then show ?case (is "\<forall> s\<^sub>1 s\<^sub>2. ?C s\<^sub>1 s\<^sub>2")
      proof(intro allI)
        fix s\<^sub>1 s\<^sub>2
        show "?C s\<^sub>1 s\<^sub>2"
          apply(simp)
          apply(subst mprefix_Par_Int[where C="{}", simplified])
          apply(subst S_rec, simp add: Tr Up mprefix_Un_distr)
          apply(intro mono_det_ref mono_mprefix_ref)
          using step(3)[simplified] indep apply simp
          using step(2)[simplified] indep by fastforce
      qed
    qed
  have dir2: "\<forall> s\<^sub>1 s\<^sub>2.  S (s\<^sub>1, s\<^sub>2) \<sqsubseteq> (P s\<^sub>1 ||| Q s\<^sub>2)"
    proof(subst S, induct rule:fix_ind_k[of "\<lambda>x. \<forall> s\<^sub>1 s\<^sub>2. x (s\<^sub>1,s\<^sub>2) \<sqsubseteq> (P s\<^sub>1 ||| Q s\<^sub>2)" 1])
      case adm:1
      show ?case  by (intro adm_all adm_below) (simp_all add: cont_fun)
    next
      case base_k_steps:2
      then show ?case by simp
    next
      case step:(3 x)
      then show ?case (is "\<forall> s\<^sub>1 s\<^sub>2. ?C s\<^sub>1 s\<^sub>2")
      proof(intro allI)
        fix s\<^sub>1 s\<^sub>2
        have P_rec_sym:"Mprefix (Tr\<^sub>1 s\<^sub>1) (\<lambda>e. P (Up\<^sub>1 s\<^sub>1 e)) = P s\<^sub>1" using P_rec by metis
        have Q_rec_sym:"Mprefix (Tr\<^sub>2 s\<^sub>2) (\<lambda>e. Q (Up\<^sub>2 s\<^sub>2 e)) = Q s\<^sub>2" using Q_rec by metis
        show "?C s\<^sub>1 s\<^sub>2"
          apply(simp add: Tr Up mprefix_Un_distr)
          apply(subst P_rec, subst Q_rec, subst mprefix_Par_Int[where C="{}", simplified])
          apply(intro mono_det_ref mono_mprefix_ref)
          apply(subst Q_rec_sym, simp add:step[simplified])
          apply(subst P_rec_sym) using step[simplified] indep by fastforce
      qed
    qed
  from dir1 dir2 show ?thesis using below_antisym by blast
qed

section \<open>Synchronous product lemma\<close>
lemma dnorm_par:
  fixes Tr\<^sub>1 ::"'state\<^sub>1::type \<Rightarrow> 'event::type set" and Tr\<^sub>2::"'state\<^sub>2::type \<Rightarrow> 'event set"
    and Up\<^sub>1 ::"'state\<^sub>1 \<Rightarrow> 'event \<Rightarrow> 'state\<^sub>1" and Up\<^sub>2::"'state\<^sub>2 \<Rightarrow> 'event \<Rightarrow> 'state\<^sub>2"
  defines P: "P \<equiv> P\<^sub>n\<^sub>o\<^sub>r\<^sub>m\<lbrakk>Tr\<^sub>1,Up\<^sub>1\<rbrakk>" (is "P \<equiv> fix\<cdot>(\<Lambda> X. ?P X)")
  defines Q: "Q \<equiv> P\<^sub>n\<^sub>o\<^sub>r\<^sub>m\<lbrakk>Tr\<^sub>2,Up\<^sub>2\<rbrakk>" (is "Q \<equiv> fix\<cdot>(\<Lambda> X. ?Q X)")

  defines Tr: "Tr \<equiv> (\<lambda>(s\<^sub>1,s\<^sub>2). Tr\<^sub>1 s\<^sub>1 \<inter> Tr\<^sub>2 s\<^sub>2)"
  defines Up: "Up \<equiv> (\<lambda>(s\<^sub>1,s\<^sub>2) e. (Up\<^sub>1 s\<^sub>1 e, Up\<^sub>2 s\<^sub>2 e))"
  defines S: "S \<equiv> P\<^sub>n\<^sub>o\<^sub>r\<^sub>m\<lbrakk>Tr,Up\<rbrakk>" (is "S \<equiv> fix\<cdot>(\<Lambda> X. ?S X)")

  shows "(P s\<^sub>1 || Q s\<^sub>2) = S (s\<^sub>1,s\<^sub>2)"
proof -
  have P_rec: "P = ?P P" using fix_eq[of "(\<Lambda> X. ?P X)"] P by simp
  have Q_rec: "Q = ?Q Q" using fix_eq[of "(\<Lambda> X. ?Q X)"] Q by simp
  have S_rec: "S = ?S S" using fix_eq[of "(\<Lambda> X. ?S X)"] S by simp
  have dir1: "\<forall> s\<^sub>1 s\<^sub>2. (P s\<^sub>1 || Q s\<^sub>2) \<sqsubseteq> S (s\<^sub>1, s\<^sub>2)"
  proof(subst P, subst Q,
        induct rule:parallel_fix_ind[of "\<lambda>x y. \<forall> s\<^sub>1 s\<^sub>2. (x s\<^sub>1 || y s\<^sub>2) \<sqsubseteq> S (s\<^sub>1,s\<^sub>2)"])
      case adm:1
      then show ?case
        by (intro adm_all adm_below) (simp_all add: cont2cont_fun)
    next
      case base:2
      then show ?case by (simp add: par_Int_bot)
    next
      case step:(3 x y)
      then show ?case (is "\<forall> s\<^sub>1 s\<^sub>2. ?C s\<^sub>1 s\<^sub>2")
      proof(intro allI)
        fix s\<^sub>1 s\<^sub>2
        show "?C s\<^sub>1 s\<^sub>2"
          apply(simp)
          apply(subst mprefix_Par_distr[where C="UNIV", simplified])
          apply(subst S_rec, simp add: Tr Up mprefix_Un_distr)
          by (simp add:step mono_mprefix_ref)
      qed
    qed
  have dir2: "\<forall> s\<^sub>1 s\<^sub>2.  S (s\<^sub>1, s\<^sub>2) \<sqsubseteq> (P s\<^sub>1 || Q s\<^sub>2)"
    proof(subst S, induct rule:fix_ind_k[of "\<lambda>x. \<forall> s\<^sub>1 s\<^sub>2. x (s\<^sub>1,s\<^sub>2) \<sqsubseteq> (P s\<^sub>1 || Q s\<^sub>2)" 1])
      case adm:1
      show ?case  by (intro adm_all adm_below) (simp_all add: cont_fun)
    next
      case base_k_steps:2
      then show ?case by simp
    next
      case step:(3 x)
      then show ?case (is "\<forall> s\<^sub>1 s\<^sub>2. ?C s\<^sub>1 s\<^sub>2")
      proof(intro allI)
        fix s\<^sub>1 s\<^sub>2
        have P_rec_sym:"Mprefix (Tr\<^sub>1 s\<^sub>1) (\<lambda>e. P (Up\<^sub>1 s\<^sub>1 e)) = P s\<^sub>1" using P_rec by metis
        have Q_rec_sym:"Mprefix (Tr\<^sub>2 s\<^sub>2) (\<lambda>e. Q (Up\<^sub>2 s\<^sub>2 e)) = Q s\<^sub>2" using Q_rec by metis
        show "?C s\<^sub>1 s\<^sub>2"
          apply(simp add: Tr Up)
          apply(subst P_rec, subst Q_rec, subst mprefix_Par_distr[where C="UNIV", simplified])
          apply(rule mono_mprefix_ref)
          using step by auto
      qed
    qed
  from dir1 dir2 show ?thesis using below_antisym by blast
qed

section\<open>Consequences\<close>
\<comment>\<open>reachable states from one starting state\<close>
inductive_set \<RR> for Tr ::"'state::type \<Rightarrow> 'event::type set"
                and Up::"'state \<Rightarrow> 'event \<Rightarrow> 'state"
                and s\<^sub>0::'state
  where rbase: "s\<^sub>0 \<in> \<RR> Tr Up s\<^sub>0"
      | rstep: "s \<in> \<RR> Tr Up s\<^sub>0 \<Longrightarrow> e \<in> Tr s  \<Longrightarrow> Up s e \<in> \<RR> Tr Up s\<^sub>0"

\<comment>\<open>Deadlock freeness\<close>
lemma deadlock_free_dnorm_ :
  fixes Tr ::"'state::type \<Rightarrow> 'event::type set"
    and Up ::"'state \<Rightarrow> 'event \<Rightarrow> 'state"
    and s\<^sub>0::'state
  assumes non_reachable_sink: "\<forall>s \<in> \<RR> Tr Up s\<^sub>0. Tr s \<noteq> {}"
  defines P: "P \<equiv> P\<^sub>n\<^sub>o\<^sub>r\<^sub>m\<lbrakk>Tr,Up\<rbrakk>" (is "P \<equiv> fix\<cdot>(\<Lambda> X. ?P X)")
  shows  "s \<in> \<RR> Tr Up s\<^sub>0 \<Longrightarrow> deadlock_free_v2 (P s)"
proof(unfold deadlock_free_v2_FD DF\<^sub>S\<^sub>K\<^sub>I\<^sub>P_def, induct arbitrary:s rule:fix_ind)
  show "adm (\<lambda>a. \<forall>x. x \<in> \<RR> Tr Up s\<^sub>0 \<longrightarrow> a \<sqsubseteq>\<^sub>F\<^sub>D P x)" by (simp add: le_FD_adm monofun_def)
next
  fix s :: "'state"
  show "s \<in> \<RR> Tr Up s\<^sub>0 \<Longrightarrow> \<bottom> \<sqsubseteq>\<^sub>F\<^sub>D P s" by simp
next
  fix s :: "'state"  and x :: "'event process"
  have P_rec: "P = ?P P" using fix_eq[of "(\<Lambda> X. ?P X)"] P by simp
  assume 1 : "\<And>s. s \<in> \<RR> Tr Up s\<^sub>0 \<Longrightarrow> x \<sqsubseteq>\<^sub>F\<^sub>D P s"
   and   2 : "s \<in> \<RR> Tr Up s\<^sub>0 "
  from   1 2 show "(\<Lambda> x. (\<sqinter>xa\<in>UNIV \<rightarrow>  x) \<sqinter> SKIP)\<cdot>x \<sqsubseteq>\<^sub>F\<^sub>D P s"
    apply(simp add:failure_divergence_refine_def)
    apply(subst P_rec, rule_tac trans_FD[simplified failure_divergence_refine_def,
                       rotated, OF Mprefix_refines_Mndet])
    apply(rule_tac CSP.mono_ndet_FD_left)
    by (metis CSP.mono_ndet_FD_right rstep empty_not_UNIV mndet_distrib mono_mndet_FD
              non_reachable_sink sup_top_left)
qed

lemmas deadlock_free_dnorm = deadlock_free_dnorm_[rotated, OF rbase, rule_format]

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory AbstractArrays
imports
  "CLib.TypHeapLib"
  "Word_Lib.WordSetup"
begin

(*
 * Return a list of addresses that contain an element for an array at location
 * "p" of length "n".
 *)
primrec
  array_addrs :: "('a::mem_type) ptr \<Rightarrow> nat \<Rightarrow> 'a ptr list"
where
  "array_addrs _ 0 = []"
| "array_addrs p (Suc n) = p # (array_addrs (p +\<^sub>p 1) n)"

declare array_addrs.simps(2) [simp del]

(* The first element is in the array if the array has non-zero length. *)
lemma hd_in_array_addrs [simp]:
  "(x \<in> set (array_addrs x n)) = (n > 0)"
  by (case_tac n, auto simp: array_addrs.simps(2))

lemma array_addrs_1 [simp]:
  "array_addrs p (Suc 0) = [p]"
  "array_addrs p 1 = [p]"
  by (auto simp: array_addrs.simps(2))

(* All array elements are aligned if the array itself is aligned. *)
lemma array_addrs_ptr_aligned:
     "\<lbrakk> x \<in> set (array_addrs p n); ptr_aligned p \<rbrakk> \<Longrightarrow> ptr_aligned x"
  apply (induct n arbitrary: x p)
   apply clarsimp
  apply (clarsimp simp: array_addrs.simps(2))
  apply (erule disjE)
   apply clarsimp
  apply atomize
  apply (drule_tac x=x in spec)
  apply (drule_tac x="p +\<^sub>p 1" in spec)
  apply (clarsimp simp: ptr_aligned_plus)
  done

(* Split off the last element in an array. *)
lemma set_array_addrs_unfold_last:
  shows "set (array_addrs a (Suc n)) = set (array_addrs a n) \<union> {(a :: ('a::mem_type) ptr) +\<^sub>p int n}"
    (is "?LHS a n = ?RHS a n")
proof (induct n arbitrary: a)
  fix a
  show "?LHS a 0 = ?RHS a 0"
    by clarsimp
next
  fix a n
  assume induct: "\<And>a. ?LHS a n = ?RHS a n"
  show "?LHS a (Suc n) = ?RHS a (Suc n)"
  apply (subst array_addrs.simps(2))
  apply (subst set_simps)
  apply (subst induct [where a="a +\<^sub>p 1"])
  apply (subst array_addrs.simps(2))
  apply (subst set_simps)
  apply (clarsimp simp: CTypesDefs.ptr_add_def field_simps insert_commute)
  done
qed

(* Alternative representation of the set of array elements. *)
lemma set_array_addrs:
  "set (array_addrs (p :: ('a::mem_type) ptr) n)
           = {x. \<exists>k. x = p +\<^sub>p int k \<and> k < n }"
  apply (induct n arbitrary: p)
   apply (clarsimp simp: not_less)
  apply (subst set_array_addrs_unfold_last)
  apply atomize
  apply (drule_tac x=p in spec)
  apply (erule ssubst)
  apply (rule set_eqI)
  apply (rule iffI)
   apply clarsimp
   apply (erule disjE)
    apply clarsimp
    apply force
   apply force
  apply clarsimp
  apply (drule_tac x=k in spec)
  apply (clarsimp simp: not_less)
  apply (subgoal_tac "k = n")
   apply clarsimp
  apply clarsimp
  done

end