(*  Title:    Irreducible.thy
    Author:   Max Wagner
*)

section \<open>Minimality under Irreducible Control Flow\<close>

txt \<open>Braun~et~al.~\<^cite>\<open>"braun13cc"\<close> provide an extension to the original construction algorithm to ensure
minimality according to Cytron's definition even in the case of irreducible control flow. This extension
establishes the property of being \emph{redundant-scc-free}, i.e.\ the resulting graph $G$ contains no
subsets inducing a strongly connected subgraph $G'$ via \pf s such that $G'$ has less than two
$\phi$ arguments in $G\setminus G'$. In this section we will show that a graph with this property is Cytron-minimal.

Our formalization follows the proof sketch given in \<^cite>\<open>"braun13cc"\<close>.
We first provide a formal proof of Lemma 1 from \<^cite>\<open>"braun13cc"\<close> which states that every redundant set of \pf s contains at least one redundant SCC.
A redundant set of \pf s is a set $P$ of \pf s with $P \cup \{v\} \supseteq A$, where $A$ is the union over all \pf s arguments contained in $P$.
I.e.\ $P$ references at most one SSA value ($v$) outside $P$.
A redundant SCC is a redundant set that is strongly connected according to the \emph{is-argument} relation.

Next, we show that a CFG in SSA form without redundant sets of \pf s is Cytron-minimal.

Finally putting those results together, we conclude that the extension to Braun~et~al.'s algorithm always produces minimal SSA form.
\<close>

theory Irreducible
  imports Formal_SSA.Minimality
begin

context CFG_SSA_Transformed
begin

subsection \<open>Proof of Lemma 1 from Braun~et~al.\<close>

txt \<open>To preserve readability, we won't distinguish between graph nodes and the \pf s contained inside such a node.\<close>

txt \<open>The graph induced by the $\phi$ network contained in the vertex set @{term P}. Note that the edges
of this graph are not necessarily a subset of the edges of the input graph.\<close>
definition "induced_phi_graph g P \<equiv> {(\<phi>,\<phi>'). phiArg g \<phi> \<phi>'} \<inter> P \<times> P"

txt \<open>For the purposes of this section, we define a "redundant set" as a nonempty set of \pf s with
at most one $\phi$ argument outside itself. A redundant SCC is defined analogously. Note that since
any uses of values in a redundant set can be replaced by uses of its singular argument (without
modifying program semantics), the name is adequate.\<close>
definition "redundant_set g P \<equiv> P \<noteq> {} \<and> P \<subseteq> dom (phi g) \<and> (\<exists>v' \<in> allVars g. \<forall>\<phi> \<in> P. \<forall>\<phi>'. phiArg g \<phi> \<phi>' \<longrightarrow> \<phi>' \<in> P \<union> {v'})"
definition "redundant_scc g P scc \<equiv> redundant_set g scc \<and> is_scc (induced_phi_graph g P) scc"

txt \<open>We prove an important lemma via condensation graphs of $\phi$ networks, so the relevant definitions are introduced here.\<close>
definition "condensation_nodes g P \<equiv> scc_of (induced_phi_graph g P) ` P"
definition "condensation_edges g P \<equiv> ((\<lambda>(x,y). (scc_of (induced_phi_graph g P) x, scc_of (induced_phi_graph g P) y)) ` (induced_phi_graph g P)) - Id"

txt \<open>For a finite @{term P}, the condensation graph induced by @{term P} is finite and acyclic.\<close>

lemma condensation_finite: "finite (condensation_edges g P)"
txt \<open>The set of edges of the condensation graph, spanning at most all $\phi$ nodes and their arguments (both of which are finite sets), is finite itself.\<close>
proof -
  let ?phiEdges="{(a,b). phiArg g a b}"
  have "finite ?phiEdges"
  proof -
    let ?phiDomRan="(dom (phi g) \<times> \<Union> (set ` (ran (phi g))))"
    from phi_finite
    have "finite ?phiDomRan" by (simp add: imageE phi_finite map_dom_ran_finite)
    have "?phiEdges \<subseteq> ?phiDomRan"
     apply (rule subst[of "\<forall>a \<in> ?phiEdges. a \<in> ?phiDomRan"])
      apply (simp_all add: subset_eq[symmetric] phiArg_def)
     by (auto simp: ran_def)
    with \<open>finite ?phiDomRan\<close>
    show "finite ?phiEdges" by (rule Finite_Set.rev_finite_subset)
  qed
  hence "\<And>f. finite (f ` (?phiEdges \<inter> (P \<times> P)))" by auto
  thus "finite (condensation_edges g P)" unfolding condensation_edges_def induced_phi_graph_def by auto
qed

txt \<open>auxiliary lemmas for acyclicity\<close>

lemma condensation_nodes_edges: "(condensation_edges g P) \<subseteq> (condensation_nodes g P \<times> condensation_nodes g P)"
unfolding condensation_edges_def condensation_nodes_def induced_phi_graph_def
by auto

lemma condensation_edge_impl_path:
assumes "(a, b) \<in> (condensation_edges g P)"
assumes "(\<phi>\<^sub>a \<in> a)"
assumes "(\<phi>\<^sub>b \<in> b)"
shows "(\<phi>\<^sub>a, \<phi>\<^sub>b) \<in> (induced_phi_graph g P)\<^sup>*"
unfolding condensation_edges_def
proof -
  from assms(1)
  obtain x y where x_y_props:
    "(x, y) \<in> (induced_phi_graph g P)"
    "a = scc_of (induced_phi_graph g P) x"
    "b = scc_of (induced_phi_graph g P) y"
   unfolding condensation_edges_def by auto
  hence "x \<in> a" "y \<in> b" by auto

  txt \<open>All that's left is to combine these paths.\<close>
  with assms(2) x_y_props(2)
  have "(\<phi>\<^sub>a, x) \<in> (induced_phi_graph g P)\<^sup>*" by (meson is_scc_connected scc_of_is_scc)
  moreover with assms(3) x_y_props(3) \<open>y \<in> b\<close>
  have "(y, \<phi>\<^sub>b) \<in> (induced_phi_graph g P)\<^sup>*" by (meson is_scc_connected scc_of_is_scc)
  ultimately
  show "(\<phi>\<^sub>a, \<phi>\<^sub>b) \<in> (induced_phi_graph g P)\<^sup>*" using x_y_props(1)  by auto
qed

lemma path_in_condensation_impl_path:
assumes "(a, b) \<in> (condensation_edges g P)\<^sup>+"
assumes "(\<phi>\<^sub>a \<in> a)"
assumes "(\<phi>\<^sub>b \<in> b)"
shows "(\<phi>\<^sub>a, \<phi>\<^sub>b) \<in> (induced_phi_graph g P)\<^sup>*"
using assms
proof (induction arbitrary: \<phi>\<^sub>b rule:trancl_induct)
  fix y z \<phi>\<^sub>b
  assume "(y, z) \<in> condensation_edges g P"

  hence "is_scc (induced_phi_graph g P) y" unfolding condensation_edges_def by auto
  hence "\<exists>\<phi>\<^sub>y. \<phi>\<^sub>y \<in> y" using scc_non_empty' by auto
  then obtain \<phi>\<^sub>y where \<phi>\<^sub>y_in_y: "\<phi>\<^sub>y \<in> y" by auto

  assume \<phi>\<^sub>b_elem: "\<phi>\<^sub>b \<in> z"
  assume "\<And>\<phi>\<^sub>b. \<phi>\<^sub>a \<in> a \<Longrightarrow> \<phi>\<^sub>b \<in> y \<Longrightarrow> (\<phi>\<^sub>a, \<phi>\<^sub>b) \<in> (induced_phi_graph g P)\<^sup>*"
  with assms(2) \<phi>\<^sub>y_in_y
  have \<phi>\<^sub>a_to_\<phi>\<^sub>y: "(\<phi>\<^sub>a, \<phi>\<^sub>y) \<in> (induced_phi_graph g P)\<^sup>*" using condensation_edge_impl_path by auto

  from \<phi>\<^sub>b_elem \<phi>\<^sub>y_in_y \<open>(y, z) \<in> condensation_edges g P\<close>
  have "(\<phi>\<^sub>y, \<phi>\<^sub>b) \<in> (induced_phi_graph g P)\<^sup>*" using condensation_edge_impl_path by auto
  with \<phi>\<^sub>a_to_\<phi>\<^sub>y
  show "(\<phi>\<^sub>a, \<phi>\<^sub>b) \<in> (induced_phi_graph g P)\<^sup>*"  by auto
qed (auto intro:condensation_edge_impl_path)

lemma condensation_acyclic: "acyclic (condensation_edges g P)"
proof (rule acyclicI, rule allI, rule ccontr, simp)
  fix x
  txt \<open>Assume there is a cycle in the condensation graph.\<close>
  assume cyclic: "(x, x) \<in> (condensation_edges g P)\<^sup>+"
  have nonrefl: "(x, x) \<notin> (condensation_edges g P)" unfolding condensation_edges_def by auto
  txt \<open>Then there must be a second SCC \<open>b\<close> on this path.\<close>
  from this cyclic
  obtain b where b_on_path: "(x, b) \<in> (condensation_edges g P)" "(b, x) \<in> (condensation_edges g P)\<^sup>+"
   by (meson converse_tranclE)

  hence "x \<in> (condensation_nodes g P)" "b \<in> (condensation_nodes g P)" using condensation_nodes_edges by auto
  hence nodes_are_scc: "is_scc (induced_phi_graph g P) x" "is_scc (induced_phi_graph g P) b"
    using scc_of_is_scc unfolding induced_phi_graph_def condensation_nodes_def by auto

  txt \<open>However, the existence of this path means all nodes in @{term b} and @{term x} are mutually reachable.\<close>
  have "\<exists>\<phi>\<^sub>x. \<phi>\<^sub>x \<in> x" "\<exists>\<phi>\<^sub>b. \<phi>\<^sub>b \<in> b" using nodes_are_scc scc_non_empty' ex_in_conv by auto
  then obtain \<phi>\<^sub>x \<phi>\<^sub>b where \<phi>xb_elem: "\<phi>\<^sub>x \<in> x" "\<phi>\<^sub>b \<in> b" by metis
  with nodes_are_scc(1) b_on_path path_in_condensation_impl_path condensation_edge_impl_path \<phi>xb_elem(2)
  have "\<phi>\<^sub>b \<in> x"
   by - (rule is_scc_closed)
  txt \<open>This however means @{term x} and @{term b} must be the same SCC, which is a contradiction to the nonreflexivity of @{theory_text condensation_edges}.\<close>
  with nodes_are_scc \<phi>xb_elem
  have "x = b" using is_scc_unique[of "induced_phi_graph g P"] by simp
  hence "(x, x) \<in> (condensation_edges g P)" using b_on_path by simp
  with nonrefl
  show "False" by simp
qed

txt \<open>Since the condensation graph of a set is acyclic and finite, it must have a leaf.\<close>
lemma Ex_condensation_leaf:
assumes "P \<noteq> {}"
shows "\<exists>leaf. leaf \<in> (condensation_nodes g P) \<and> (\<forall> scc.(leaf, scc) \<notin> condensation_edges g P)"
proof -
  from assms obtain x where "x \<in> condensation_nodes g P" unfolding condensation_nodes_def by auto
  show ?thesis
  proof (rule wfE_min)
    from condensation_finite condensation_acyclic
    show "wf ((condensation_edges g P)\<inverse>)" by (rule finite_acyclic_wf_converse)
  next
    fix leaf
    assume leaf_node: "leaf \<in> condensation_nodes g P"
    moreover
    assume leaf_is_leaf: "scc \<notin> condensation_nodes g P" if "(scc, leaf) \<in> (condensation_edges g P)\<inverse>" for scc
    ultimately
    have "leaf \<in> condensation_nodes g P \<and> (\<forall>scc. (leaf, scc) \<notin> condensation_edges g P)" using condensation_nodes_edges by blast
    thus "\<exists>leaf. leaf \<in> condensation_nodes g P \<and> (\<forall>scc. (leaf, scc) \<notin> condensation_edges g P)" by blast
  qed fact
qed

lemma scc_in_P:
assumes "scc \<in> condensation_nodes g P"
shows "scc \<subseteq> P"
proof -
  have "scc \<subseteq> P" if y_props: "scc = scc_of (induced_phi_graph g P) n" "n \<in> P" for n
  proof -
    from y_props
    show "scc \<subseteq> P"
    proof (clarsimp simp:y_props(1); case_tac "n = x")
      fix x
      assume different: "n \<noteq> x"
      assume "x \<in> scc_of (induced_phi_graph g P) n"
      hence "(n, x) \<in> (induced_phi_graph g P)\<^sup>*" by (metis is_scc_connected scc_of_is_scc node_in_scc_of_node)
      with different
      have "(n, x) \<in> (induced_phi_graph g P)\<^sup>+" by (metis rtranclD)
      then obtain z where step: "(z, x) \<in> (induced_phi_graph g P)" by (meson tranclE)
      from step
      show "x \<in> P" unfolding induced_phi_graph_def by auto
    qed simp
  qed
  from this assms(1) have "x \<in> P" if x_node: "x \<in> scc" for x
   apply -
   apply (rule imageE[of scc "scc_of (induced_phi_graph g P)"])
    using condensation_nodes_def x_node by blast+
  thus ?thesis by clarify
qed

lemma redundant_scc_phis:
assumes "redundant_set g P" "scc \<in> condensation_nodes g P" "x \<in> scc"
shows "phi g x \<noteq> None"
using assms by (meson domIff redundant_set_def scc_in_P subsetCE)

txt \<open>The following lemma will be important for the main proof of this section.
If @{term P} is redundant, a leaf in the condensation graph induced by P corresponds to a strongly connected set
with at most one argument, thus a redundant strongly connected set exists.\<close>

txt \<open>Lemma 1. Every redundant set contains a redundant SCC.\<close>

lemma 1:
assumes "redundant_set g P"
shows "\<exists>scc \<subseteq> P. redundant_scc g P scc"
proof -
  from assms Ex_condensation_leaf[of P g]
  obtain leaf where leaf_props: "leaf \<in> (condensation_nodes g P)" "\<forall>scc. (leaf, scc) \<notin> condensation_edges g P"
   unfolding redundant_set_def by auto
  hence "is_scc (induced_phi_graph g P) leaf" unfolding condensation_nodes_def by auto
  moreover
  hence "leaf \<noteq> {}" by (rule scc_non_empty')
  moreover
  have "leaf \<subseteq> dom (phi g)"
    apply (subst subset_eq, rule ballI)
    using redundant_scc_phis leaf_props(1) assms(1) by auto
  moreover
  from assms
  obtain pred where pred_props: "pred \<in> allVars g" "\<forall>\<phi>\<in>P. \<forall>\<phi>'. phiArg g \<phi> \<phi>' \<longrightarrow> \<phi>' \<in> P \<union> {pred}" unfolding redundant_set_def by auto
  {
    txt \<open>Any argument of a \pf\ in the leaf SCC which is \emph{not} in the leaf SCC itself must be the unique argument of P\<close>
    fix \<phi> \<phi>'

    consider (in_P) "\<phi>' \<notin> leaf \<and> \<phi>' \<in> P" | (neither) "\<phi>' \<notin> leaf \<and> \<phi>' \<notin> P \<union> {pred}" | "\<phi>' \<notin> leaf \<and> \<phi>' \<in> {pred}" | "\<phi>' \<in> leaf" by auto
    hence "\<phi>' \<in> leaf \<union> {pred}" if "\<phi> \<in> leaf" and "phiArg g \<phi> \<phi>'"
    proof cases
      case in_P \<comment> \<open>In this case @{term leaf} wasn't really a leaf, a contradiction\<close>
      moreover
      from in_P that leaf_props(1) scc_in_P[of leaf g P]
      have "(\<phi>, \<phi>') \<in> induced_phi_graph g P" unfolding induced_phi_graph_def by auto
      ultimately
      have "(leaf, scc_of (induced_phi_graph g P) \<phi>') \<in> condensation_edges g P" unfolding condensation_edges_def
       using leaf_props(1) that \<open>is_scc (induced_phi_graph g P) leaf\<close>
       apply -
       apply clarsimp
       apply (rule conjI)
        prefer 2
        apply auto[1]
       unfolding condensation_nodes_def
       by (metis (no_types, lifting) is_scc_unique node_in_scc_of_node pair_imageI scc_of_is_scc)
      with leaf_props(2)
      show ?thesis by auto
    next
      case neither \<comment> \<open>In which case @{term P} itself wasn't redundant, a contradiction\<close>
      with that leaf_props pred_props
      have "\<not>redundant_set g P" unfolding redundant_set_def
        by (meson rev_subsetD scc_in_P)
      with assms
      show ?thesis by auto
    qed auto \<comment> \<open>the other cases are trivial\<close>
  }
  with pred_props(1)
  have "\<exists>v'\<in>allVars g. \<forall>\<phi>\<in>leaf. \<forall>\<phi>'. phiArg g \<phi> \<phi>' \<longrightarrow> \<phi>' \<in> leaf \<union> {v'}"  by auto
  ultimately
  have "redundant_scc g P leaf" unfolding redundant_scc_def redundant_set_def by auto
  thus ?thesis using leaf_props(1) scc_in_P by meson
qed

subsection \<open>Proof of Minimality\<close>

txt \<open>We inductively define the reachable-set of a \pf\ as all \pf s reachable from a given node via an
unbroken chain of $\phi$ argument edges to unnecessary \pf s.\<close>

inductive_set reachable :: "'g \<Rightarrow> 'val \<Rightarrow> 'val set"
  for g :: "'g" and \<phi> :: "'val"
  where refl: "unnecessaryPhi g \<phi> \<Longrightarrow> \<phi> \<in> reachable g \<phi>"
  | step: "\<phi>' \<in> reachable g \<phi> \<Longrightarrow> phiArg g \<phi>' \<phi>'' \<Longrightarrow> unnecessaryPhi g \<phi>'' \<Longrightarrow> \<phi>'' \<in> reachable g \<phi>"

lemma reachable_props:
  assumes "\<phi>' \<in> reachable g \<phi>"
  shows "(phiArg g)\<^sup>*\<^sup>* \<phi> \<phi>'" and "unnecessaryPhi g \<phi>'"
  using assms
  by (induction \<phi>' rule: reachable.induct) auto

txt \<open>We call the transitive arguments of a \pf\ not in its reachable-set the "true arguments" of this \pf.\<close>
definition [simp]: "trueArgs g \<phi> \<equiv> {\<phi>'. \<phi>' \<notin> reachable g \<phi>} \<inter> {\<phi>'. \<exists>\<phi>'' \<in> reachable g \<phi>. phiArg g \<phi>'' \<phi>'}"

lemma preds_finite: "finite (trueArgs g \<phi>)"
proof (rule ccontr)
  assume "infinite (trueArgs g \<phi>)"
  hence a: "infinite {\<phi>'. \<exists>\<phi>'' \<in> reachable g \<phi>. phiArg g \<phi>'' \<phi>'}" by auto
  have phiarg_set: "{\<phi>'. \<exists>\<phi>. phiArg g \<phi> \<phi>'} = \<Union> (set `{b. \<exists>a. phi g a = Some b})" unfolding phiArg_def by auto
  txt \<open>If the true arguments of a \pf\ are infinite in number, there must be an infinite number of \pf s\ldots\<close>
  have "infinite {\<phi>'. \<exists>\<phi>. phiArg g \<phi> \<phi>'}"
    by (rule infinite_super[of "{\<phi>'. \<exists>\<phi>'' \<in> reachable g \<phi>. phiArg g \<phi>'' \<phi>'}"])  (auto simp: a)
  with phiarg_set
  have "infinite (ran (phi g))" unfolding ran_def phiArg_def by clarsimp
  txt \<open>Which cannot be.\<close>
  thus False by (simp add:phi_finite map_dom_ran_finite)
qed

txt \<open>Any unnecessary $\phi$ with less than 2 true arguments induces with @{term "reachable g \<phi>"} a redundant set itself.\<close>

lemma few_preds_redundant:
assumes "card (trueArgs g \<phi>) < 2" "unnecessaryPhi g \<phi>"
shows "redundant_set g (reachable g \<phi>)"
unfolding redundant_set_def
proof (intro conjI)
  from assms
  show "reachable g \<phi> \<noteq> {}"
    using empty_iff reachable.intros(1) by auto
next
  from assms(2)
  show "reachable g \<phi> \<subseteq> dom (phi g)"
    by (metis domIff reachable.cases subsetI unnecessaryPhi_def)
next
  from assms(1)
  consider (single) "card (trueArgs g \<phi>) = 1" | (empty) "card (trueArgs g \<phi>) = 0" by force
  thus "\<exists>pred\<in>allVars g. \<forall>\<phi>'\<in>reachable g \<phi>. \<forall>\<phi>''. phiArg g \<phi>' \<phi>'' \<longrightarrow> \<phi>'' \<in> reachable g \<phi> \<union> {pred}"
  proof cases
    case single
    then obtain pred where pred_prop: "trueArgs g \<phi> = {pred}" using card_eq_1_singleton by blast
    hence "pred \<in> allVars g" by (auto intro: Int_Collect phiArg_in_allVars)
    moreover
    from pred_prop
    have "\<forall>\<phi>'\<in>reachable g \<phi>. \<forall>\<phi>''. phiArg g \<phi>' \<phi>'' \<longrightarrow> \<phi>'' \<in> reachable g \<phi> \<union> {pred}" by auto
    ultimately
    show ?thesis by auto
  next
    case empty
    from allDefs_in_allVars[of _ g "defNode g \<phi>"] assms
    have phi_var: "\<phi> \<in> allVars g" unfolding unnecessaryPhi_def phiDefs_def allDefs_def defNode_def phi_def trueArgs_def
      by (clarsimp simp: domIff phis_in_\<alpha>n)
    from empty assms(1)
    have no_preds: "trueArgs g \<phi> = {}"  by (subst card_0_eq[OF preds_finite, symmetric]) auto
    show ?thesis
    proof (rule bexI, rule ballI, rule allI, rule impI)
      fix \<phi>' \<phi>''
      assume phis_props: "\<phi>' \<in> reachable g \<phi>" "phiArg g \<phi>' \<phi>''"
      with no_preds
      have "\<phi>'' \<in> reachable g \<phi>"
      unfolding trueArgs_def
      proof -
        from phis_props
        have "\<phi>'' \<in> {\<phi>'. \<exists>\<phi>''\<in>reachable g \<phi>. phiArg g \<phi>'' \<phi>'}" by auto
        with phis_props no_preds
        show "\<phi>'' \<in> reachable g \<phi>" unfolding trueArgs_def by auto
      qed
      thus "\<phi>'' \<in> reachable g \<phi> \<union> {\<phi>}" by simp
    qed (auto simp: phi_var)
  qed
qed

lemma phiArg_trancl_same_var:
assumes "(phiArg g)\<^sup>+\<^sup>+ \<phi> n"
shows "var g \<phi> = var g n"
using assms
apply (induction rule: tranclp_induct)
  apply (rule phiArg_same_var[symmetric])
  apply simp
 using phiArg_same_var by auto

txt \<open>The following path extension lemma will be used a number of times in the inner induction of the
main proof. Basically, the idea is to extend a path ending in a $\phi$ argument to the corresponding \pf\
while preserving disjointness to a second path.\<close>

lemma phiArg_disjoint_paths_extend:
assumes "var g r = V" and "var g s = V" and "r \<in> allVars g" and "s \<in> allVars g"
and "V \<in> oldDefs g n" and "V \<in> oldDefs g m"
and "g \<turnstile> n-ns\<rightarrow>defNode g r" and "g \<turnstile> m-ms\<rightarrow>defNode g s"
and "set ns \<inter> set ms = {}"
and "phiArg g \<phi>\<^sub>r r"
obtains ns'
where "g \<turnstile> n-ns@ns'\<rightarrow>defNode g \<phi>\<^sub>r"
and "set (butlast (ns@ns')) \<inter> set ms = {}"
proof (cases "r = \<phi>\<^sub>r")
  case (True)
  txt \<open>If the node to extend the path to is already the endpoint, the lemma is trivial.\<close>
  with assms(7,8,9) in_set_butlastD
  have "g \<turnstile> n-ns@[]\<rightarrow>defNode g \<phi>\<^sub>r" "set (butlast (ns@[])) \<inter> set ms = {}"
    by simp_all fastforce
  with that show ?thesis .
next
  case False
  txt \<open>It suffices to obtain any path from r to @{term \<phi>\<^sub>r}.
     However, since we'll need the corresponding predecessor of @{term \<phi>\<^sub>r} later, we must do this as follows:\<close>
  from assms(10)
  have "\<phi>\<^sub>r \<in> allVars g" unfolding phiArg_def
    by (metis allDefs_in_allVars phiDefs_in_allDefs phi_def phi_phiDefs phis_in_\<alpha>n)
  with assms(10)
  obtain rs' pred\<^sub>\<phi>\<^sub>r where rs'_props: "g \<turnstile> defNode g r-rs'\<rightarrow> pred\<^sub>\<phi>\<^sub>r" "old.EntryPath g rs'" "r \<in> phiUses g pred\<^sub>\<phi>\<^sub>r" "pred\<^sub>\<phi>\<^sub>r \<in> set (old.predecessors g (defNode g \<phi>\<^sub>r))"
   by (rule phiArg_path_ex')

  define rs where "rs = rs'@[defNode g \<phi>\<^sub>r]"
  from rs'_props(2,1) old.EntryPath_distinct old.path2_hd
  have rs'_loopfree: "defNode g r \<notin> set (tl rs')"  by (simp add: Misc.distinct_hd_tl)

  from False assms have "defNode g \<phi>\<^sub>r \<noteq> defNode g r"
   apply -
   apply (rule phiArg_distinct_nodes)
     apply (auto intro:phiArg_in_allVars)[2]
   unfolding phiArg_def by (metis allDefs_in_allVars phiDefs_in_allDefs phi_def phi_phiDefs phis_in_\<alpha>n)

  from rs'_props
  have rs_props: "g \<turnstile> defNode g r-rs\<rightarrow> defNode g \<phi>\<^sub>r" "length rs > 1" "defNode g r \<notin> set (tl rs)"
     apply (subgoal_tac "defNode g r = hd rs'")
      prefer 2 using rs'_props(1)
     apply (rule old.path2_hd)
     using old.path2_snoc old.path2_def rs'_props(1) rs_def rs'_loopfree \<open>defNode g \<phi>\<^sub>r \<noteq> defNode g r\<close> by auto

  show thesis
  proof (cases "set (butlast rs) \<inter> set ms = {}")
    case inter_empty: True
    txt \<open>If the intersection of these is empty, @{term "tl rs"} is already the extension we're looking for\<close>
    show thesis
    proof (rule that)
      show "set (butlast (ns @ tl rs)) \<inter> set ms = {}"
      proof (rule ccontr, simp only: ex_in_conv[symmetric])
        assume "\<exists>x. x \<in> set (butlast (ns @ tl rs)) \<inter> set ms"
        then obtain x where x_props: "x \<in> set (butlast (ns @ tl rs))" "x \<in> set ms" by auto
        with rs_props(2)
        consider (in_ns) "x \<in> set ns" | (in_rs) "x \<in> set (butlast (tl rs))" by (metis Un_iff butlast_append in_set_butlastD set_append)
        thus False
         apply (cases)
          using x_props(2) assms(9)
          apply (simp add: disjoint_elem)
         by (metis x_props(2) inter_empty in_set_tlD List.butlast_tl disjoint_iff_not_equal)
      qed
    qed (auto intro:assms(7) rs_props(1) old.path2_app)
  next
    case inter_ex: False
    txt \<open>If the intersection is nonempty, there must be a first point of intersection @{term i}.\<close>
    from inter_ex assms(7,8) rs_props
    obtain i ri where ri_props: "g \<turnstile> defNode g r-ri\<rightarrow>i" "i \<in> set ms" "\<forall>n \<in> set (butlast ri). n \<notin> set ms" "prefix ri rs"
     apply -
     apply (rule old.path2_split_first_prop[of g "defNode g r" rs "defNode g \<phi>\<^sub>r", where P="\<lambda>m. m \<in> set ms"])
       apply blast
      apply (metis disjoint_iff_not_equal in_set_butlastD)
     by blast
    with assms(8) old.path2_prefix_ex
    obtain ms' where ms'_props: "g \<turnstile> m -ms'\<rightarrow> i" "prefix ms' ms" "i \<notin> set (butlast ms')" by blast

    txt \<open>We proceed by case distinction:
      \<^item> if @{prop "i = defNode g \<phi>\<^sub>r"}, the path @{term ri} is already the path extension we're looking for
      \<^item> Otherwise, the fact that @{term i} is on the path from $\phi$ argument to the $\phi$ itself leads to a contradiction.
        However, we still need to distinguish the cases of whether @{prop "m = i"}\<close>
    consider (ri_is_valid) "i = defNode g \<phi>\<^sub>r" | (m_i_same) "i \<noteq> defNode g \<phi>\<^sub>r" "m = i" | (m_i_differ) "i \<noteq> defNode g \<phi>\<^sub>r" "m \<noteq> i" by auto

    thus thesis
    proof (cases)
      case ri_is_valid
      txt \<open>@{term ri} is a valid path extension.\<close>
      with assms(7) ri_props(1)
      have "g \<turnstile> n -ns@(tl ri)\<rightarrow> defNode g \<phi>\<^sub>r" by auto

      moreover
      have "set (butlast (ns@(tl ri))) \<inter> set ms = {}"
      proof (rule ccontr)
        assume contr: "set (butlast (ns @ tl ri)) \<inter> set ms \<noteq> {}"
        from this
        obtain x where x_props: "x \<in> set (butlast (ns @ tl ri))" "x \<in> set ms" by auto
        with assms(9) have "x \<notin> set ns" by auto
        with x_props \<open>g \<turnstile> n-ns @ tl ri\<rightarrow>defNode g \<phi>\<^sub>r\<close> \<open>defNode g \<phi>\<^sub>r \<noteq> defNode g r\<close> assms(7)
        have "x \<in> set (butlast (tl ri))"
         by (metis Un_iff append_Nil2 butlast_append old.path2_last set_append)
        with x_props(2) ri_props(3)
        show "False" by (metis FormalSSA_Misc.in_set_tlD List.butlast_tl)
      qed
      ultimately
      show thesis by (rule that)
    next
      case m_i_same
      txt \<open>If @{prop "m = i"}, we have, with @{term m}, a variable definition on the path from a \pf\ to its argument.
          This constitutes a contradiction to the conventional property.\<close>
      note rs'_props(1) rs'_loopfree
      moreover have "r \<in> allDefs g (defNode g r)" by (simp add: assms(3))
      moreover from rs'_props(3) have "r \<in> allUses g pred\<^sub>\<phi>\<^sub>r" unfolding allUses_def by simp

      moreover
      from rs_props(1) m_i_same rs_def ri_props(1,2,4) \<open>defNode g \<phi>\<^sub>r \<noteq> defNode g r\<close> assms(7,9)
      have "m \<in> set (tl rs')"
       by (metis disjoint_elem hd_append in_hd_or_tl_conv in_prefix list.sel(1) old.path2_hd old.path2_last old.path2_last_in_ns prefix_snoc)

      moreover
      from assms(6) obtain def\<^sub>m where "def\<^sub>m \<in> allDefs g m" "var g def\<^sub>m = V" unfolding oldDefs_def using defs_in_allDefs by blast

      ultimately
      have "var g def\<^sub>m \<noteq> var g r" by - (rule conventional, simp_all)
      with \<open>var g def\<^sub>m = V\<close> assms(1)
      have "False" by simp
      thus ?thesis by simp

    next
      case m_i_differ
      txt \<open>If @{prop "m \<noteq> i"}, @{term i} constitutes a proper path convergence point.\<close>
      have "old.pathsConverge g m ms' n (ns @ tl ri) i"
      proof (rule old.pathsConvergeI)
        show "1 < length ms'" using m_i_differ ms'_props old.path2_nontriv by blast
      next
        show "1 < length (ns @ tl ri)"
        using ri_props old.path2_nontriv assms(9) by (metis assms(7) disjoint_elem old.path2_app old.path2_hd_in_ns)
      next
        show "set (butlast ms') \<inter> set (butlast (ns @ tl ri)) = {}"
        proof (rule ccontr)
          assume "set (butlast ms') \<inter> set (butlast (ns @ tl ri)) \<noteq> {}"
          then obtain i' where i'_props: "i' \<in> set (butlast ms')" "i' \<in> set (butlast (ns @ tl ri))" by auto
          with ms'_props(2)
          have i'_not_in_ms: "i' \<in> set (butlast ms)" by (metis in_set_butlast_appendI prefixE)

          with assms(9)
          show False
          proof (cases "i' \<notin> set ns")
            case True
            with i'_props(2)
            have "i' \<in> set (butlast (tl ri))"
             by (metis Un_iff butlast_append in_set_butlastD set_append)
            hence "i' \<in> set (butlast ri)" by (simp add:in_set_tlD List.butlast_tl)
            with i'_not_in_ms ri_props(3)
            show False by (auto dest:in_set_butlastD)
          qed (meson disjoint_elem in_set_butlastD)
        qed
      qed (auto intro: assms(7) ri_props(1) old.path2_app ms'_props(1))

      txt \<open>At this intersection of paths we can find a \pf.\<close>
      from this assms(6,5)
      have "necessaryPhi g V i" by (rule necessaryPhiI)

      txt \<open>Before we can conclude that there is indeed a $\phi$ at @{term i}, we have to prove a couple of technicalities\ldots\<close>
      moreover
      from m_i_differ ri_props(1,4) rs_def old.path2_last prefix_snoc
      have ri_rs'_prefix: "prefix ri rs'" by fastforce
      then obtain rs'_rest where rs'_rest_prop: "rs' = ri@rs'_rest" using prefixE by auto
      from old.path2_last[OF ri_props(1)] last_snoc[of _ i] obtain tmp where "ri = tmp@[i]"
       apply (subgoal_tac "ri \<noteq> []")
        prefer 2
        using ri_props(1) apply (simp add: old.path2_not_Nil)
       apply (rule_tac that)
       using append_butlast_last_id[symmetric] by auto
      with rs'_rest_prop have rs'_rest_def: "rs' = tmp@i#rs'_rest" by auto
      with rs'_props(1) have "g \<turnstile> i -i#rs'_rest\<rightarrow> pred\<^sub>\<phi>\<^sub>r"
       by (simp add:old.path2_split)
      moreover
      note \<open>var g r = V\<close> [simp]
      from rs'_props(3)
      have "r \<in> allUses g pred\<^sub>\<phi>\<^sub>r" unfolding allUses_def by simp

      moreover
      from \<open>defNode g r \<notin> set (tl rs')\<close> rs'_rest_def
      have "defNode g r \<notin> set rs'_rest" by auto
      with \<open>g \<turnstile> i -i#rs'_rest\<rightarrow> pred\<^sub>\<phi>\<^sub>r\<close>
      have "\<And>x. x \<in> set rs'_rest \<Longrightarrow> r \<notin> allDefs g x"
       by (metis defNode_eq list.distinct(1) list.sel(3) list.set_cases old.path2_cases old.path2_in_\<alpha>n)

      moreover
      from assms(7,9) \<open>g \<turnstile> i -i#rs'_rest\<rightarrow> pred\<^sub>\<phi>\<^sub>r\<close> ri_props(2)
      have "r \<notin> defs g i"
       by (metis defNode_eq defs_in_allDefs disjoint_elem old.path2_hd_in_\<alpha>n old.path2_last_in_ns)
      ultimately

      txt \<open>The convergence property gives us that there is a $\phi$ in the last node fulfilling @{theory_text necessaryPhi}
          on a path to a use of @{term r} without a definition of @{term r}.
          Thus @{term i} bears a \pf\ for the value of @{term r}.\<close>

      have "\<exists>y. phis g (i, r) = Some y"
       by (rule convergence_prop [where g=g and n=i and v=r and ns="i#rs'_rest", simplified])
      moreover

      from \<open>g \<turnstile> n-ns\<rightarrow>defNode g r\<close> have "defNode g r \<in> set ns" by auto
      with \<open>set ns \<inter> set ms = {}\<close> \<open>i \<in> set ms\<close> have "i \<noteq> defNode g r" by auto
      moreover

      from ms'_props(1) have "i \<in> set (\<alpha>n g)" by auto
      moreover

      have "defNode g r \<in> set (\<alpha>n g)" by (simp add: assms(3))

      txt \<open>However, we now have two definitions of @{term r}: one in @{term i}, and one in @{term "defNode g r"}, which we know to be distinct.
          This is a contradiction to the @{theory_text allDefs_disjoint}-property.\<close>
      ultimately have False
        using allDefs_disjoint [where g=g and n=i and m="defNode g r"]
        unfolding allDefs_def phiDefs_def
        apply clarsimp
        apply (erule_tac c=r in equalityCE)
        using phi_def phis_phi by auto
      thus ?thesis by simp
    qed
  qed
qed

lemma reachable_same_var:
assumes "\<phi>' \<in> reachable g \<phi>"
shows "var g \<phi> = var g \<phi>'"
using assms by (metis Nitpick.rtranclp_unfold phiArg_trancl_same_var reachable_props(1))

lemma \<phi>_node_no_defs:
assumes "unnecessaryPhi g \<phi>" "\<phi> \<in> allVars g" "var g \<phi> \<in> oldDefs g n"
shows "defNode g \<phi> \<noteq> n"
using assms simpleDefs_phiDefs_var_disjoint defNode(1) not_None_eq phi_phiDefs
  unfolding unnecessaryPhi_def by auto

lemma defNode_differ_aux:
assumes "\<phi>\<^sub>s \<in> reachable g \<phi>" "\<phi> \<in> allVars g" "s \<in> allVars g" "\<phi>\<^sub>s \<noteq> s" "var g \<phi> = var g s"
shows "defNode g \<phi>\<^sub>s \<noteq> defNode g s" unfolding reachable_def
proof (rule ccontr)
  assume "\<not> defNode g \<phi>\<^sub>s \<noteq> defNode g s"
  hence eq: "defNode g \<phi>\<^sub>s = defNode g s" by simp
  from assms(1)
  have vars_eq: "var g \<phi> = var g \<phi>\<^sub>s"
    apply -
    apply (cases "\<phi> = \<phi>\<^sub>s")
    apply simp
    apply (rule phiArg_trancl_same_var)
    apply (drule reachable_props)
    unfolding reachable_def by (meson IntD1 mem_Collect_eq rtranclpD)
  have \<phi>\<^sub>s_in_allVars: "\<phi>\<^sub>s \<in> allVars g" unfolding reachable_def
  proof (cases "\<phi> = \<phi>\<^sub>s")
    case False
    with assms(1)
    obtain \<phi>' where "phiArg g \<phi>' \<phi>\<^sub>s"  by (metis rtranclp.cases reachable_props(1))
    thus "\<phi>\<^sub>s \<in> allVars g" by (rule phiArg_in_allVars)
  next
    case eq: True
    with assms(2)
    show "\<phi>\<^sub>s \<in> allVars g" by (subst eq[symmetric])
  qed

  from eq \<phi>\<^sub>s_in_allVars assms(3,4)
  have "var g \<phi>\<^sub>s \<noteq> var g s" by - (rule defNode_var_disjoint)
  with vars_eq assms(5)
  show False by auto
qed

txt \<open>Theorem 1. A graph which does not contain any redundant set is minimal according to Cytron et al.'s definition of minimality.\<close>

theorem no_redundant_set_minimal:
assumes no_redundant_set: "\<not>(\<exists>P. redundant_set g P)"
shows "cytronMinimal g"
proof (rule ccontr)
  assume "\<not>cytronMinimal g"
  txt \<open>Assume the graph is not Cytron-minimal. Thus there is a \pf\ which does not sit at the
      convergence point of multiple liveness intervals.\<close>
  then obtain \<phi> where \<phi>_props: "unnecessaryPhi g \<phi>" "\<phi> \<in> allVars g" "\<phi> \<in> reachable g \<phi>"
  using cytronMinimal_def unnecessaryPhi_def reachable_def unnecessaryPhi_def reachable.intros by auto

  txt \<open>We consider the reachable-set of @{term \<phi>}. If @{term \<phi>} has less than two true arguments, we
     know it to be a redundant set, a contradiction. Otherwise, we know there to be at least two
     paths from different definitions leading into the reachable-set of @{term \<phi>}.\<close>

  consider (nontrivial) "card (trueArgs g \<phi>) \<ge> 2" | (trivial) "card (trueArgs g \<phi>) < 2" using linorder_not_le by auto
  thus False
  proof cases
    case trivial
    txt \<open>If there are less than 2 true arguments of this set, the set is trivially redundant (see @{theory_text few_preds_redundant}).\<close>
    from this \<phi>_props(1)
    have "redundant_set g (reachable g \<phi>)" by (rule few_preds_redundant)
    with no_redundant_set
    show False by simp
  next
    case nontrivial
    txt \<open>If there are two or more necessary arguments, there must be disjoint paths from Defs to two of these \pf s.\<close>
    then obtain r s \<phi>\<^sub>r \<phi>\<^sub>s where assign_nodes_props:
      "r \<noteq> s" "\<phi>\<^sub>r \<in> reachable g \<phi>" "\<phi>\<^sub>s \<in> reachable g \<phi>"
      "\<not> unnecessaryPhi g r" "\<not> unnecessaryPhi g s"
      "r \<in> {n. (phiArg g)\<^sup>*\<^sup>* \<phi> n}" "s \<in> {n. (phiArg g)\<^sup>*\<^sup>* \<phi> n}"
      "phiArg g \<phi>\<^sub>r r" "phiArg g \<phi>\<^sub>s s"
     apply simp
     apply (rule set_take_two[OF nontrivial])
     apply simp
     by (meson reachable.intros(2) reachable_props(1) rtranclp_tranclp_tranclp tranclp.r_into_trancl tranclp_into_rtranclp)
    moreover from assign_nodes_props
    have \<phi>_r_s_uneq: "\<phi> \<noteq> r" "\<phi> \<noteq> s" using \<phi>_props by auto
    moreover
    from assign_nodes_props this
    have r_s_in_tranclp: "(phiArg g)\<^sup>+\<^sup>+ \<phi> r" "(phiArg g)\<^sup>+\<^sup>+ \<phi> s"
      by (meson mem_Collect_eq rtranclpD) (meson assign_nodes_props(7) \<phi>_r_s_uneq(2) mem_Collect_eq rtranclpD)
    from this
    obtain V where V_props: "var g r = V" "var g s = V" "var g \<phi> = V" by (metis phiArg_trancl_same_var)
    moreover
    from r_s_in_tranclp
    have r_s_allVars: "r \<in> allVars g" "s \<in> allVars g" by (metis phiArg_in_allVars tranclp.cases)+
    moreover
    from V_props defNode_var_disjoint r_s_allVars assign_nodes_props(1)
    have r_s_defNode_distinct: "defNode g r \<noteq> defNode g s" by auto
    ultimately
    obtain n ns m ms where r_s_path_props: "V \<in> oldDefs g n" "g \<turnstile> n-ns\<rightarrow>defNode g r" "V \<in> oldDefs g m" "g \<turnstile> m-ms\<rightarrow>defNode g s"
      "set ns \<inter> set ms = {}" by (auto intro: ununnecessaryPhis_disjoint_paths[of g r s])

    have n_m_distinct: "n \<noteq> m"
    proof (rule ccontr)
      assume n_m: "\<not> n \<noteq> m"
      with r_s_path_props(2) old.path2_hd_in_ns
      have "n \<in> set ns" by blast
      moreover
      from n_m r_s_path_props(4) old.path2_hd_in_ns
      have "n \<in> set ms" by blast
      ultimately
      show False using r_s_path_props(5) by auto
    qed

    txt \<open>These paths can be extended into paths reaching \pf s in our set.\<close>

    from V_props r_s_allVars r_s_path_props assign_nodes_props
    obtain rs where rs_props: "g \<turnstile> n -ns@rs\<rightarrow> defNode g \<phi>\<^sub>r" "set (butlast (ns@rs)) \<inter> set ms = {}"
    using phiArg_disjoint_paths_extend by blast

    txt \<open>(In fact, we can prove that @{prop "set (ns@rs) \<inter> set ms = {}"}, which we need for the next path extension.)\<close>
    have "defNode g \<phi>\<^sub>r \<notin> set ms"
    proof (rule ccontr)
      assume \<phi>\<^sub>r_in_ms: "\<not> defNode g \<phi>\<^sub>r \<notin> set ms"
      from this r_s_path_props(4)
      obtain ms' where ms'_props: "g \<turnstile> m -ms'\<rightarrow> defNode g \<phi>\<^sub>r" "prefix ms' ms" by -(rule old.path2_prefix_ex[of g m ms "defNode g s" "defNode g \<phi>\<^sub>r"], auto)

      have "old.pathsConverge g n (ns@rs) m ms' (defNode g \<phi>\<^sub>r)"
      proof (rule old.pathsConvergeI)
        show "set (butlast (ns @ rs)) \<inter> set (butlast ms') = {}"
        proof (rule ccontr)
          assume "set (butlast (ns @ rs)) \<inter> set (butlast ms') \<noteq> {}"
          then obtain c where c_props: "c \<in> set (butlast (ns@rs))" "c \<in> set (butlast ms')" by auto
          from this(2) ms'_props(2)
          have "c \<in> set ms" by (simp add: in_prefix in_set_butlastD)
          with c_props(1) rs_props(2)
          show False by auto
        qed
      next
        have m_n_\<phi>\<^sub>r_differ: "n \<noteq> defNode g \<phi>\<^sub>r" "m \<noteq> defNode g \<phi>\<^sub>r"
          using assign_nodes_props(2,3,4,5) V_props r_s_path_props \<phi>\<^sub>r_in_ms
          apply fastforce
         using V_props(1) \<phi>\<^sub>r_in_ms assign_nodes_props(8) old.path2_in_\<alpha>n phiArg_def phiArg_same_var r_s_path_props(3,4) simpleDefs_phiDefs_var_disjoint
         by auto
        with ms'_props(1)
        show "1 < length ms'" using old.path2_nontriv by simp
        from m_n_\<phi>\<^sub>r_differ rs_props(1)
        show "1 < length (ns@rs)" using old.path2_nontriv by blast
      qed (auto intro: rs_props set_mono_prefix ms'_props)
      with V_props r_s_path_props
      have "necessaryPhi' g \<phi>\<^sub>r" unfolding necessaryPhi_def using assign_nodes_props(8) phiArg_same_var by auto
      with reachable_props(2)[OF assign_nodes_props(2)]
      show False unfolding unnecessaryPhi_def by simp
    qed

    with rs_props
    have aux: "set ms \<inter> set (ns @ rs) = {}"
      by (metis disjoint_iff_not_equal not_in_butlast old.path2_last)

    have \<phi>\<^sub>r_V: "var g \<phi>\<^sub>r = V"
      using V_props(1) assign_nodes_props(8) phiArg_same_var by auto

    have \<phi>\<^sub>r_allVars: "\<phi>\<^sub>r \<in> allVars g"
      by (meson phiArg_def assign_nodes_props(8) allDefs_in_allVars old.path2_tl_in_\<alpha>n phiDefs_in_allDefs phi_phiDefs rs_props)

    from V_props(2) \<phi>\<^sub>r_V r_s_allVars(2) \<phi>\<^sub>r_allVars r_s_path_props(3) r_s_path_props(1)
             r_s_path_props(4) rs_props(1) aux assign_nodes_props(9)
    obtain ss where ss_props: "g \<turnstile> m -ms@ss\<rightarrow> defNode g \<phi>\<^sub>s" "set (butlast (ms@ss)) \<inter> set (butlast (ns@rs)) = {}"
     by (rule phiArg_disjoint_paths_extend) (metis disjoint_iff_not_equal in_set_butlastD)

    define p\<^sub>m where "p\<^sub>m = ms@ss"
    define p\<^sub>n where "p\<^sub>n = ns@rs"

    have ind_props: "g \<turnstile> m -p\<^sub>m\<rightarrow> defNode g \<phi>\<^sub>s" "g \<turnstile> n -p\<^sub>n\<rightarrow> defNode g \<phi>\<^sub>r" "set (butlast p\<^sub>m) \<inter> set (butlast p\<^sub>n) = {}"
    using rs_props(1) ss_props p\<^sub>m_def p\<^sub>n_def by auto

    txt \<open>The following case will occur twice in the induction, with swapped identifiers, so we're proving it outside.
    Basically, if the paths @{term p\<^sub>m} and @{term p\<^sub>n} intersect, the first such intersection point must be a \pf\ in @{term "reachable g \<phi>"},
    yielding the path convergence we seek.\<close>

    have path_crossing_yields_convergence:
      "\<exists>\<phi>\<^sub>z \<in> reachable g \<phi>. \<exists>ns ms. old.pathsConverge g n ns m ms (defNode g \<phi>\<^sub>z)"
      if "\<phi>\<^sub>r \<in> reachable g \<phi>" and "\<phi>\<^sub>s \<in> reachable g \<phi>" and "g \<turnstile> n -p\<^sub>n\<rightarrow> defNode g \<phi>\<^sub>r"
        and "g \<turnstile> m -p\<^sub>m\<rightarrow> defNode g \<phi>\<^sub>s" and "set (butlast p\<^sub>m) \<inter> set (butlast p\<^sub>n) = {}"
        and "set p\<^sub>m \<inter> set p\<^sub>n \<noteq> {}"
      for \<phi>\<^sub>r \<phi>\<^sub>s p\<^sub>m p\<^sub>n
    proof -
      from that(6) split_list_first_propE
      obtain p\<^sub>m1 n\<^sub>z p\<^sub>m2 where n\<^sub>z_props: "n\<^sub>z \<in> set p\<^sub>n" "p\<^sub>m = p\<^sub>m1 @ n\<^sub>z # p\<^sub>m2" "\<forall>n \<in> set p\<^sub>m1. n \<notin> set p\<^sub>n"
         by (auto intro: split_list_first_propE)

      with that(3,4)
      obtain p\<^sub>n' where p\<^sub>n'_props: "g \<turnstile> n-p\<^sub>n'\<rightarrow>n\<^sub>z" "g \<turnstile> m-p\<^sub>m1@[n\<^sub>z]\<rightarrow>n\<^sub>z" "prefix p\<^sub>n' p\<^sub>n" "n\<^sub>z \<notin> set (butlast p\<^sub>n')"
          by (meson old.path2_prefix_ex old.path2_split(1))

      from V_props(3) reachable_same_var[OF that(1)] reachable_same_var[OF that(2)]
      have phis_V: "var g \<phi>\<^sub>r = V" "var g \<phi>\<^sub>s = V" by simp_all
      from reachable_props(1) that(1,2) \<phi>_props(2) phiArg_in_allVars
      have phis_allVars: "\<phi>\<^sub>r \<in> allVars g" "\<phi>\<^sub>s \<in> allVars g" by (metis rtranclp.cases)+

      txt \<open>Various inequalities for proving paths aren't trivial.\<close>
      have "n \<noteq> defNode g \<phi>\<^sub>r" "m \<noteq> defNode g \<phi>\<^sub>r"
       using \<phi>_node_no_defs phis_V(1) phis_allVars(1) r_s_path_props(1,3) reachable_props(2) that(1) by blast+

      from \<phi>_node_no_defs reachable_props(2) that(2) r_s_path_props(1,3) phis_V(2) that phis_allVars
      have "m \<noteq> defNode g \<phi>\<^sub>s" "n \<noteq> defNode g \<phi>\<^sub>s" by blast+

      txt \<open>With this scenario, since @{prop "set (butlast p\<^sub>n) \<inter> set (butlast p\<^sub>m) = {}"}, one of the paths @{term p\<^sub>n} and
      @{term p\<^sub>m} must end somewhere within the other, however this means the \pf\ in that node must either be @{term \<phi>} or @{term \<phi>\<^sub>r}\<close>

      from assms n\<^sub>z_props
      consider (p\<^sub>n_ends_in_p\<^sub>m) "n\<^sub>z = defNode g \<phi>\<^sub>s" | (p\<^sub>m_ends_in_p\<^sub>n) "n\<^sub>z = defNode g \<phi>\<^sub>r"
      proof (cases "n\<^sub>z = last p\<^sub>n")
        case True
        with \<open>g \<turnstile> n -p\<^sub>n\<rightarrow> defNode g \<phi>\<^sub>r\<close>
        have "n\<^sub>z = defNode g \<phi>\<^sub>r" using old.path2_last by auto
        with that(2) show ?thesis.
      next
        case False
        from n\<^sub>z_props(2)
        have "n\<^sub>z \<in> set p\<^sub>m" by simp
        with False n\<^sub>z_props(1) \<open>set (butlast p\<^sub>m) \<inter> set (butlast p\<^sub>n) = {}\<close> \<open>g \<turnstile> m -p\<^sub>m\<rightarrow> defNode g \<phi>\<^sub>s\<close>
        have "n\<^sub>z = defNode g \<phi>\<^sub>s" by (metis disjoint_elem not_in_butlast old.path2_last)
        with that(1) show ?thesis.
      qed

      thus "\<exists>\<phi>\<^sub>z \<in> reachable g \<phi>. \<exists>ns ms. old.pathsConverge g n ns m ms (defNode g \<phi>\<^sub>z)"
      proof (cases)
        case p\<^sub>n_ends_in_p\<^sub>m
        have "old.pathsConverge g n p\<^sub>n' m p\<^sub>m (defNode g \<phi>\<^sub>s)"
        proof (rule old.pathsConvergeI)
          from p\<^sub>n_ends_in_p\<^sub>m p\<^sub>n'_props(1) show "g \<turnstile> n-p\<^sub>n'\<rightarrow>defNode g \<phi>\<^sub>s" by simp
          from \<open>n \<noteq> defNode g \<phi>\<^sub>s\<close> p\<^sub>n_ends_in_p\<^sub>m p\<^sub>n'_props(1) old.path2_nontriv show "1 < length p\<^sub>n'" by auto
          from that(4) show "g \<turnstile> m -p\<^sub>m\<rightarrow> defNode g \<phi>\<^sub>s".
          with \<open>m \<noteq> defNode g \<phi>\<^sub>s\<close> old.path2_nontriv show "1 < length p\<^sub>m" by simp
          from that p\<^sub>n'_props(3) show "set (butlast p\<^sub>n') \<inter> set (butlast p\<^sub>m) = {}"
           by (meson butlast_prefix disjointI disjoint_elem in_prefix)
        qed
        with that(1,2,3) show ?thesis by (auto intro:reachable.intros(2))
      next
        case p\<^sub>m_ends_in_p\<^sub>n
        have "old.pathsConverge g n p\<^sub>n' m (p\<^sub>m1@[n\<^sub>z]) (defNode g \<phi>\<^sub>r)"
        proof (rule old.pathsConvergeI)
          from p\<^sub>m_ends_in_p\<^sub>n  p\<^sub>n'_props(1,2) show "g \<turnstile> n-p\<^sub>n'\<rightarrow>defNode g \<phi>\<^sub>r" "g \<turnstile> m-p\<^sub>m1 @ [n\<^sub>z]\<rightarrow>defNode g \<phi>\<^sub>r" by simp_all
          with \<open>n \<noteq> defNode g \<phi>\<^sub>r\<close> \<open>m \<noteq> defNode g \<phi>\<^sub>r\<close> show "1 < length p\<^sub>n'" "1 < length (p\<^sub>m1 @ [n\<^sub>z])"
           using old.path2_nontriv[of g m "p\<^sub>m1 @ [n\<^sub>z]"] old.path2_nontriv[of g n] by simp_all
          from n\<^sub>z_props p\<^sub>n'_props(3) show "set (butlast p\<^sub>n') \<inter> set (butlast (p\<^sub>m1 @ [n\<^sub>z])) = {}"
           using butlast_snoc disjointI in_prefix in_set_butlastD by fastforce
        qed
        with that(1) show ?thesis by (auto intro:reachable.intros)
      qed
    qed

    txt \<open>Since the reachable-set was built starting at a single $\phi$, these paths must at some
         point converge \emph{within} @{term "reachable g \<phi>"}.\<close>
    from assign_nodes_props(3,2) ind_props V_props(3) \<phi>\<^sub>r_V \<phi>\<^sub>r_allVars
    have "\<exists>\<phi>\<^sub>z \<in> reachable g \<phi>. \<exists>ns ms. old.pathsConverge g n ns m ms (defNode g \<phi>\<^sub>z)"
    proof (induction arbitrary: p\<^sub>m p\<^sub>n rule: reachable.induct)
      case refl
      txt \<open>In the induction basis, we know that @{prop "\<phi> = \<phi>\<^sub>s"}, and a path to @{term \<phi>\<^sub>r} must be obtained
          -- for this we need a second induction.\<close>
      from refl.prems refl.hyps show ?case
      proof (induction arbitrary: p\<^sub>m p\<^sub>n rule: reachable.induct)
        case refl
        txt \<open>The first case, in which \<open>\<phi>\<^sub>r = \<phi>\<^sub>s = \<phi>\<close>, is trivial -- \<open>\<phi>\<close> suffices.\<close>
        have "old.pathsConverge g n p\<^sub>n m p\<^sub>m (defNode g \<phi>)"
        proof (rule old.pathsConvergeI)
          show "1 < length p\<^sub>n" "1 < length p\<^sub>m"
            using refl V_props simpleDefs_phiDefs_var_disjoint unfolding unnecessaryPhi_def
            by (metis domD domIff old.path2_hd_in_\<alpha>n old.path2_nontriv phi_phiDefs r_s_path_props(1) r_s_path_props(3))+
          show "g \<turnstile> n-p\<^sub>n\<rightarrow>defNode g \<phi>" "g \<turnstile> m-p\<^sub>m\<rightarrow>defNode g \<phi>" "set (butlast p\<^sub>n) \<inter> set (butlast p\<^sub>m) = {}"
          using refl by auto
        qed
        with \<open>\<phi> \<in> reachable g \<phi>\<close> show ?case by auto
      next
        case (step \<phi>' \<phi>\<^sub>r)
        txt \<open>In this case we have that @{prop "\<phi> = \<phi>\<^sub>s"} and need to acquire a path going to @{term \<phi>\<^sub>r},
            however with the aux.\ lemma we have, we still need that @{term p\<^sub>n} and @{term p\<^sub>m} are disjoint.\<close>
        thus ?case
        proof (cases "set p\<^sub>n \<inter> set p\<^sub>m = {}")
          case paths_cross: False
          with step reachable.intros
          show ?thesis using path_crossing_yields_convergence[of \<phi>\<^sub>r \<phi> p\<^sub>n p\<^sub>m] by (metis disjointI disjoint_elem)
        next
          case True
          txt \<open>If the paths are intersection-free, we can apply our path extension lemma to obtain the path needed.\<close>
          from step(9,8,10) \<open>\<phi> \<in> allVars g\<close> r_s_path_props(1,3) step(6,5) True step(2)
          obtain ns where "g \<turnstile> n -p\<^sub>n@ns\<rightarrow> defNode g \<phi>'" "set (butlast (p\<^sub>n@ns)) \<inter> set p\<^sub>m = {}" by (rule phiArg_disjoint_paths_extend)

          from this(2) have "set (butlast p\<^sub>m) \<inter> set (butlast (p\<^sub>n @ ns)) = {}"
            using in_set_butlastD by fastforce
          moreover
          from phiArg_same_var step.hyps(2) step.prems(5) have "var g \<phi>' = V"
            by auto
          moreover
          have "\<phi>' \<in> allVars g"
            by (metis \<phi>_props(2) phiArg_in_allVars reachable.cases step.hyps(1))
          ultimately
          show "\<exists>\<phi>\<^sub>z\<in>reachable g \<phi>. \<exists>ns ms. old.pathsConverge g n ns m ms (defNode g \<phi>\<^sub>z)"
            using step.prems(1) \<phi>_props V_props \<open>g \<turnstile> n -p\<^sub>n@ns\<rightarrow> defNode g \<phi>'\<close>
            by -(rule step.IH; blast)
        qed
      qed
    next
      case (step \<phi>' \<phi>\<^sub>s)
      txt \<open>With the induction basis handled, we can finally move on to the induction proper.\<close>

      show ?thesis
      proof (cases "set p\<^sub>m \<inter> set p\<^sub>n = {}")
        case True
        have \<phi>\<^sub>s_V: "var g \<phi>\<^sub>s = V" using step(1,2,3,9) reachable_same_var by (simp add: phiArg_same_var)
        from step(2) have \<phi>\<^sub>s_allVars: "\<phi>\<^sub>s \<in> allVars g" by (rule phiArg_in_allVars)

        obtain p\<^sub>m' where tmp: "g \<turnstile> m -p\<^sub>m@p\<^sub>m'\<rightarrow> defNode g \<phi>'" "set (butlast (p\<^sub>m@p\<^sub>m')) \<inter> set (butlast p\<^sub>n) = {}"
         by (rule phiArg_disjoint_paths_extend[of g \<phi>\<^sub>s V  \<phi>\<^sub>r m n p\<^sub>m p\<^sub>n \<phi>'])
            (metis \<phi>\<^sub>s_V \<phi>\<^sub>s_allVars step r_s_path_props(1,3) True disjoint_iff_not_equal in_set_butlastD)+

        from step(5) this(1) step(7) this(2) step(9) step(10) step(11)
        show ?thesis by (rule step.IH[of "p\<^sub>m@p\<^sub>m'" p\<^sub>n])
      next
        case paths_cross: False
        with step reachable.intros
        show ?thesis using path_crossing_yields_convergence[of \<phi>\<^sub>r \<phi>\<^sub>s p\<^sub>n p\<^sub>m] by blast
      qed
    qed

    then obtain \<phi>\<^sub>z ns ms where "\<phi>\<^sub>z \<in> reachable g \<phi>" and "old.pathsConverge g n ns m ms (defNode g \<phi>\<^sub>z)"
      by blast
    moreover
    with reachable_props have "var g \<phi>\<^sub>z = V" by (metis V_props(3) phiArg_trancl_same_var rtranclpD)
    ultimately have "necessaryPhi' g \<phi>\<^sub>z " using r_s_path_props
      unfolding necessaryPhi_def by blast
    moreover with \<open>\<phi>\<^sub>z \<in> reachable g \<phi>\<close> have "unnecessaryPhi g \<phi>\<^sub>z" by -(rule reachable_props)
    ultimately show False unfolding unnecessaryPhi_def by blast
  qed
qed

txt \<open>Together with lemma 1, we thus have that a CFG without redundant SCCs is cytron-minimal, proving that the
     property established by Braun et al.'s algorithm suffices.\<close>
corollary no_redundant_SCC_minimal:
assumes "\<not>(\<exists>P scc. redundant_scc g P scc)"
shows "cytronMinimal g"
using assms 1 no_redundant_set_minimal by blast

txt \<open>Finally, to conclude, we'll show that the above theorem is indeed a stronger assertion about a graph
     than the lack of trivial \pf s. Intuitively, this is because a set containing only a
     trivial \pf\ is a redundant set.\<close>

corollary
assumes "\<not>(\<exists>P. redundant_set g P)"
shows "\<not>redundant g"
proof -
  have "redundant g \<Longrightarrow> \<exists>P. redundant_set g P"
  proof -
    assume "redundant g"
    then obtain \<phi> where "phi g \<phi> \<noteq> None" "trivial g \<phi>"
     unfolding redundant_def redundant_set_def dom_def phiArg_def trivial_def isTrivialPhi_def
     by (clarsimp split: option.splits) fastforce
    hence "redundant_set g {\<phi>}"
     unfolding redundant_set_def dom_def phiArg_def trivial_def isTrivialPhi_def
     by auto
    thus ?thesis by auto
  qed
  with assms show ?thesis by auto
qed

end

end


theory CFGExit_wf imports CFGExit CFG_wf begin

subsection {* New well-formedness lemmas using @{text "(_Exit_)"} *}

locale CFGExit_wf =
  CFG_wf sourcenode targetnode kind valid_edge Entry Def Use state_val +
  CFGExit sourcenode targetnode kind valid_edge Entry Exit
  for sourcenode :: "'edge \<Rightarrow> 'node" and targetnode :: "'edge \<Rightarrow> 'node"
  and kind :: "'edge \<Rightarrow> 'state edge_kind" and valid_edge :: "'edge \<Rightarrow> bool"
  and Entry :: "'node" ("'('_Entry'_')") and Def :: "'node \<Rightarrow> 'var set"
  and Use :: "'node \<Rightarrow> 'var set" and state_val :: "'state \<Rightarrow> 'var \<Rightarrow> 'val"
  and Exit :: "'node" ("'('_Exit'_')") +
  assumes Exit_empty:"Def (_Exit_) = {} \<and> Use (_Exit_) = {}"

begin

lemma Exit_Use_empty [dest!]: "V \<in> Use (_Exit_) \<Longrightarrow> False"
by(simp add:Exit_empty)

lemma Exit_Def_empty [dest!]: "V \<in> Def (_Exit_) \<Longrightarrow> False"
by(simp add:Exit_empty)

end

end


(*  Title:      HOL/ex/Reflection_Examples.thy
    Author:     Amine Chaieb, TU Muenchen
*)

section \<open>Examples for generic reflection and reification\<close>

theory Reflection_Examples
imports Complex_Main "~~/src/HOL/Library/Reflection"
begin

text \<open>This theory presents two methods: reify and reflection\<close>

text \<open>
Consider an HOL type \<open>\<sigma>\<close>, the structure of which is not recongnisable
on the theory level.  This is the case of @{typ bool}, arithmetical terms such as @{typ int},
@{typ real} etc \dots  In order to implement a simplification on terms of type \<open>\<sigma>\<close> we
often need its structure.  Traditionnaly such simplifications are written in ML,
proofs are synthesized.

An other strategy is to declare an HOL datatype \<open>\<tau>\<close> and an HOL function (the
interpretation) that maps elements of \<open>\<tau>\<close> to elements of \<open>\<sigma>\<close>.

The functionality of \<open>reify\<close> then is, given a term \<open>t\<close> of type \<open>\<sigma>\<close>,
to compute a term \<open>s\<close> of type \<open>\<tau>\<close>.  For this it needs equations for the
interpretation.

N.B: All the interpretations supported by \<open>reify\<close> must have the type
\<open>'a list \<Rightarrow> \<tau> \<Rightarrow> \<sigma>\<close>.  The method \<open>reify\<close> can also be told which subterm
of the current subgoal should be reified.  The general call for \<open>reify\<close> is
\<open>reify eqs (t)\<close>, where \<open>eqs\<close> are the defining equations of the interpretation
and \<open>(t)\<close> is an optional parameter which specifies the subterm to which reification
should be applied to.  If \<open>(t)\<close> is abscent, \<open>reify\<close> tries to reify the whole
subgoal.

The method \<open>reflection\<close> uses \<open>reify\<close> and has a very similar signature:
\<open>reflection corr_thm eqs (t)\<close>.  Here again \<open>eqs\<close> and \<open>(t)\<close>
are as described above and \<open>corr_thm\<close> is a theorem proving
@{prop "I vs (f t) = I vs t"}.  We assume that \<open>I\<close> is the interpretation
and \<open>f\<close> is some useful and executable simplification of type \<open>\<tau> \<Rightarrow> \<tau>\<close>.
The method \<open>reflection\<close> applies reification and hence the theorem @{prop "t = I xs s"}
and hence using \<open>corr_thm\<close> derives @{prop "t = I xs (f s)"}.  It then uses
normalization by equational rewriting to prove @{prop "f s = s'"} which almost finishes
the proof of @{prop "t = t'"} where @{prop "I xs s' = t'"}.
\<close>

text \<open>Example 1 : Propositional formulae and NNF.\<close>
text \<open>The type \<open>fm\<close> represents simple propositional formulae:\<close>

datatype form = TrueF | FalseF | Less nat nat
  | And form form | Or form form | Neg form | ExQ form

primrec interp :: "form \<Rightarrow> ('a::ord) list \<Rightarrow> bool"
where
  "interp TrueF vs \<longleftrightarrow> True"
| "interp FalseF vs \<longleftrightarrow> False"
| "interp (Less i j) vs \<longleftrightarrow> vs ! i < vs ! j"
| "interp (And f1 f2) vs \<longleftrightarrow> interp f1 vs \<and> interp f2 vs"
| "interp (Or f1 f2) vs \<longleftrightarrow> interp f1 vs \<or> interp f2 vs"
| "interp (Neg f) vs \<longleftrightarrow> \<not> interp f vs"
| "interp (ExQ f) vs \<longleftrightarrow> (\<exists>v. interp f (v # vs))"

lemmas interp_reify_eqs = interp.simps
declare interp_reify_eqs [reify]

lemma "\<exists>x. x < y \<and> x < z"
  apply reify
  oops

datatype fm = And fm fm | Or fm fm | Imp fm fm | Iff fm fm | NOT fm | At nat

primrec Ifm :: "fm \<Rightarrow> bool list \<Rightarrow> bool"
where
  "Ifm (At n) vs \<longleftrightarrow> vs ! n"
| "Ifm (And p q) vs \<longleftrightarrow> Ifm p vs \<and> Ifm q vs"
| "Ifm (Or p q) vs \<longleftrightarrow> Ifm p vs \<or> Ifm q vs"
| "Ifm (Imp p q) vs \<longleftrightarrow> Ifm p vs \<longrightarrow> Ifm q vs"
| "Ifm (Iff p q) vs \<longleftrightarrow> Ifm p vs = Ifm q vs"
| "Ifm (NOT p) vs \<longleftrightarrow> \<not> Ifm p vs"

lemma "Q \<longrightarrow> (D \<and> F \<and> ((\<not> D) \<and> (\<not> F)))"
  apply (reify Ifm.simps)
oops

text \<open>Method \<open>reify\<close> maps a @{typ bool} to an @{typ fm}.  For this it needs the
semantics of \<open>fm\<close>, i.e.\ the rewrite rules in \<open>Ifm.simps\<close>.\<close>

text \<open>You can also just pick up a subterm to reify.\<close>
lemma "Q \<longrightarrow> (D \<and> F \<and> ((\<not> D) \<and> (\<not> F)))"
  apply (reify Ifm.simps ("((\<not> D) \<and> (\<not> F))"))
oops

text \<open>Let's perform NNF. This is a version that tends to generate disjunctions\<close>
primrec fmsize :: "fm \<Rightarrow> nat"
where
  "fmsize (At n) = 1"
| "fmsize (NOT p) = 1 + fmsize p"
| "fmsize (And p q) = 1 + fmsize p + fmsize q"
| "fmsize (Or p q) = 1 + fmsize p + fmsize q"
| "fmsize (Imp p q) = 2 + fmsize p + fmsize q"
| "fmsize (Iff p q) = 2 + 2* fmsize p + 2* fmsize q"

lemma [measure_function]: "is_measure fmsize" ..

fun nnf :: "fm \<Rightarrow> fm"
where
  "nnf (At n) = At n"
| "nnf (And p q) = And (nnf p) (nnf q)"
| "nnf (Or p q) = Or (nnf p) (nnf q)"
| "nnf (Imp p q) = Or (nnf (NOT p)) (nnf q)"
| "nnf (Iff p q) = Or (And (nnf p) (nnf q)) (And (nnf (NOT p)) (nnf (NOT q)))"
| "nnf (NOT (And p q)) = Or (nnf (NOT p)) (nnf (NOT q))"
| "nnf (NOT (Or p q)) = And (nnf (NOT p)) (nnf (NOT q))"
| "nnf (NOT (Imp p q)) = And (nnf p) (nnf (NOT q))"
| "nnf (NOT (Iff p q)) = Or (And (nnf p) (nnf (NOT q))) (And (nnf (NOT p)) (nnf q))"
| "nnf (NOT (NOT p)) = nnf p"
| "nnf (NOT p) = NOT p"

text \<open>The correctness theorem of @{const nnf}: it preserves the semantics of @{typ fm}\<close>
lemma nnf [reflection]:
  "Ifm (nnf p) vs = Ifm p vs"
  by (induct p rule: nnf.induct) auto

text \<open>Now let's perform NNF using our @{const nnf} function defined above.  First to the
  whole subgoal.\<close>
lemma "A \<noteq> B \<and> (B \<longrightarrow> A \<noteq> (B \<or> C \<and> (B \<longrightarrow> A \<or> D))) \<longrightarrow> A \<or> B \<and> D"
  apply (reflection Ifm.simps)
oops

text \<open>Now we specify on which subterm it should be applied\<close>
lemma "A \<noteq> B \<and> (B \<longrightarrow> A \<noteq> (B \<or> C \<and> (B \<longrightarrow> A \<or> D))) \<longrightarrow> A \<or> B \<and> D"
  apply (reflection Ifm.simps only: "B \<or> C \<and> (B \<longrightarrow> A \<or> D)")
oops

text \<open>Example 2: Simple arithmetic formulae\<close>

text \<open>The type \<open>num\<close> reflects linear expressions over natural number\<close>
datatype num = C nat | Add num num | Mul nat num | Var nat | CN nat nat num

text \<open>This is just technical to make recursive definitions easier.\<close>
primrec num_size :: "num \<Rightarrow> nat"
where
  "num_size (C c) = 1"
| "num_size (Var n) = 1"
| "num_size (Add a b) = 1 + num_size a + num_size b"
| "num_size (Mul c a) = 1 + num_size a"
| "num_size (CN n c a) = 4 + num_size a "

lemma [measure_function]: "is_measure num_size" ..

text \<open>The semantics of num\<close>
primrec Inum:: "num \<Rightarrow> nat list \<Rightarrow> nat"
where
  Inum_C  : "Inum (C i) vs = i"
| Inum_Var: "Inum (Var n) vs = vs!n"
| Inum_Add: "Inum (Add s t) vs = Inum s vs + Inum t vs "
| Inum_Mul: "Inum (Mul c t) vs = c * Inum t vs "
| Inum_CN : "Inum (CN n c t) vs = c*(vs!n) + Inum t vs "

text \<open>Let's reify some nat expressions \dots\<close>
lemma "4 * (2 * x + (y::nat)) + f a \<noteq> 0"
  apply (reify Inum.simps ("4 * (2 * x + (y::nat)) + f a"))
oops
text \<open>We're in a bad situation! \<open>x\<close>, \<open>y\<close> and \<open>f\<close> have been recongnized
as constants, which is correct but does not correspond to our intuition of the constructor C.
It should encapsulate constants, i.e. numbers, i.e. numerals.\<close>

text \<open>So let's leave the \<open>Inum_C\<close> equation at the end and see what happens \dots\<close>
lemma "4 * (2 * x + (y::nat)) \<noteq> 0"
  apply (reify Inum_Var Inum_Add Inum_Mul Inum_CN Inum_C ("4 * (2 * x + (y::nat))"))
oops
text \<open>Hm, let's specialize \<open>Inum_C\<close> with numerals.\<close>

lemma Inum_number: "Inum (C (numeral t)) vs = numeral t" by simp
lemmas Inum_eqs = Inum_Var Inum_Add Inum_Mul Inum_CN Inum_number

text \<open>Second attempt\<close>
lemma "1 * (2 * x + (y::nat)) \<noteq> 0"
  apply (reify Inum_eqs ("1 * (2 * x + (y::nat))"))
oops

text\<open>That was fine, so let's try another one \dots\<close>

lemma "1 * (2 * x + (y::nat) + 0 + 1) \<noteq> 0"
  apply (reify Inum_eqs ("1 * (2 * x + (y::nat) + 0 + 1)"))
oops

text \<open>Oh!! 0 is not a variable \dots\ Oh! 0 is not a \<open>numeral\<close> \dots\ thing.
The same for 1. So let's add those equations, too.\<close>

lemma Inum_01: "Inum (C 0) vs = 0" "Inum (C 1) vs = 1" "Inum (C(Suc n)) vs = Suc n"
  by simp_all

lemmas Inum_eqs'= Inum_eqs Inum_01

text\<open>Third attempt:\<close>

lemma "1 * (2 * x + (y::nat) + 0 + 1) \<noteq> 0"
  apply (reify Inum_eqs' ("1 * (2 * x + (y::nat) + 0 + 1)"))
oops

text \<open>Okay, let's try reflection. Some simplifications on @{typ num} follow. You can
  skim until the main theorem \<open>linum\<close>.\<close>

fun lin_add :: "num \<Rightarrow> num \<Rightarrow> num"
where
  "lin_add (CN n1 c1 r1) (CN n2 c2 r2) =
    (if n1 = n2 then
      (let c = c1 + c2
       in (if c = 0 then lin_add r1 r2 else CN n1 c (lin_add r1 r2)))
     else if n1 \<le> n2 then (CN n1 c1 (lin_add r1 (CN n2 c2 r2)))
     else (CN n2 c2 (lin_add (CN n1 c1 r1) r2)))"
| "lin_add (CN n1 c1 r1) t = CN n1 c1 (lin_add r1 t)"
| "lin_add t (CN n2 c2 r2) = CN n2 c2 (lin_add t r2)"
| "lin_add (C b1) (C b2) = C (b1 + b2)"
| "lin_add a b = Add a b"

lemma lin_add:
  "Inum (lin_add t s) bs = Inum (Add t s) bs"
  apply (induct t s rule: lin_add.induct, simp_all add: Let_def)
  apply (case_tac "c1+c2 = 0",case_tac "n1 \<le> n2", simp_all)
  apply (case_tac "n1 = n2", simp_all add: algebra_simps)
  done

fun lin_mul :: "num \<Rightarrow> nat \<Rightarrow> num"
where
  "lin_mul (C j) i = C (i * j)"
| "lin_mul (CN n c a) i = (if i=0 then (C 0) else CN n (i * c) (lin_mul a i))"
| "lin_mul t i = (Mul i t)"

lemma lin_mul:
  "Inum (lin_mul t i) bs = Inum (Mul i t) bs"
  by (induct t i rule: lin_mul.induct) (auto simp add: algebra_simps)

fun linum:: "num \<Rightarrow> num"
where
  "linum (C b) = C b"
| "linum (Var n) = CN n 1 (C 0)"
| "linum (Add t s) = lin_add (linum t) (linum s)"
| "linum (Mul c t) = lin_mul (linum t) c"
| "linum (CN n c t) = lin_add (linum (Mul c (Var n))) (linum t)"

lemma linum [reflection]:
  "Inum (linum t) bs = Inum t bs"
  by (induct t rule: linum.induct) (simp_all add: lin_mul lin_add)

text \<open>Now we can use linum to simplify nat terms using reflection\<close>

lemma "Suc (Suc 1) * (x + Suc 1 * y) = 3 * x + 6 * y"
  apply (reflection Inum_eqs' only: "Suc (Suc 1) * (x + Suc 1 * y)")
oops

text \<open>Let's lift this to formulae and see what happens\<close>

datatype aform = Lt num num  | Eq num num | Ge num num | NEq num num |
  Conj aform aform | Disj aform aform | NEG aform | T | F

primrec linaformsize:: "aform \<Rightarrow> nat"
where
  "linaformsize T = 1"
| "linaformsize F = 1"
| "linaformsize (Lt a b) = 1"
| "linaformsize (Ge a b) = 1"
| "linaformsize (Eq a b) = 1"
| "linaformsize (NEq a b) = 1"
| "linaformsize (NEG p) = 2 + linaformsize p"
| "linaformsize (Conj p q) = 1 + linaformsize p + linaformsize q"
| "linaformsize (Disj p q) = 1 + linaformsize p + linaformsize q"

lemma [measure_function]: "is_measure linaformsize" ..

primrec is_aform :: "aform => nat list => bool"
where
  "is_aform T vs = True"
| "is_aform F vs = False"
| "is_aform (Lt a b) vs = (Inum a vs < Inum b vs)"
| "is_aform (Eq a b) vs = (Inum a vs = Inum b vs)"
| "is_aform (Ge a b) vs = (Inum a vs \<ge> Inum b vs)"
| "is_aform (NEq a b) vs = (Inum a vs \<noteq> Inum b vs)"
| "is_aform (NEG p) vs = (\<not> (is_aform p vs))"
| "is_aform (Conj p q) vs = (is_aform p vs \<and> is_aform q vs)"
| "is_aform (Disj p q) vs = (is_aform p vs \<or> is_aform q vs)"

text\<open>Let's reify and do reflection\<close>
lemma "(3::nat) * x + t < 0 \<and> (2 * x + y \<noteq> 17)"
  apply (reify Inum_eqs' is_aform.simps)
oops

text \<open>Note that reification handles several interpretations at the same time\<close>
lemma "(3::nat) * x + t < 0 \<and> x * x + t * x + 3 + 1 = z * t * 4 * z \<or> x + x + 1 < 0"
  apply (reflection Inum_eqs' is_aform.simps only: "x + x + 1")
oops

text \<open>For reflection we now define a simple transformation on aform: NNF + linum on atoms\<close>

fun linaform:: "aform \<Rightarrow> aform"
where
  "linaform (Lt s t) = Lt (linum s) (linum t)"
| "linaform (Eq s t) = Eq (linum s) (linum t)"
| "linaform (Ge s t) = Ge (linum s) (linum t)"
| "linaform (NEq s t) = NEq (linum s) (linum t)"
| "linaform (Conj p q) = Conj (linaform p) (linaform q)"
| "linaform (Disj p q) = Disj (linaform p) (linaform q)"
| "linaform (NEG T) = F"
| "linaform (NEG F) = T"
| "linaform (NEG (Lt a b)) = Ge a b"
| "linaform (NEG (Ge a b)) = Lt a b"
| "linaform (NEG (Eq a b)) = NEq a b"
| "linaform (NEG (NEq a b)) = Eq a b"
| "linaform (NEG (NEG p)) = linaform p"
| "linaform (NEG (Conj p q)) = Disj (linaform (NEG p)) (linaform (NEG q))"
| "linaform (NEG (Disj p q)) = Conj (linaform (NEG p)) (linaform (NEG q))"
| "linaform p = p"

lemma linaform: "is_aform (linaform p) vs = is_aform p vs"
  by (induct p rule: linaform.induct) (auto simp add: linum)

lemma "(Suc (Suc (Suc 0)) * ((x::nat) + Suc (Suc 0)) + Suc (Suc (Suc 0)) *
  (Suc (Suc (Suc 0))) * ((x::nat) + Suc (Suc 0))) < 0 \<and> Suc 0 + Suc 0 < 0"
  apply (reflection Inum_eqs' is_aform.simps rules: linaform)
oops

declare linaform [reflection]

lemma "(Suc (Suc (Suc 0)) * ((x::nat) + Suc (Suc 0)) + Suc (Suc (Suc 0)) *
  (Suc (Suc (Suc 0))) * ((x::nat) + Suc (Suc 0))) < 0 \<and> Suc 0 + Suc 0 < 0"
  apply (reflection Inum_eqs' is_aform.simps)
oops

text \<open>We now give an example where interpretaions have zero or more than only
  one envornement of different types and show that automatic reification also deals with
  bindings\<close>

datatype rb = BC bool | BAnd rb rb | BOr rb rb

primrec Irb :: "rb \<Rightarrow> bool"
where
  "Irb (BC p) \<longleftrightarrow> p"
| "Irb (BAnd s t) \<longleftrightarrow> Irb s \<and> Irb t"
| "Irb (BOr s t) \<longleftrightarrow> Irb s \<or> Irb t"

lemma "A \<and> (B \<or> D \<and> B) \<and> A \<and> (B \<or> D \<and> B) \<or> A \<and> (B \<or> D \<and> B) \<or> A \<and> (B \<or> D \<and> B)"
  apply (reify Irb.simps)
oops

datatype rint = IC int | IVar nat | IAdd rint rint | IMult rint rint
  | INeg rint | ISub rint rint

primrec Irint :: "rint \<Rightarrow> int list \<Rightarrow> int"
where
  Irint_Var: "Irint (IVar n) vs = vs ! n"
| Irint_Neg: "Irint (INeg t) vs = - Irint t vs"
| Irint_Add: "Irint (IAdd s t) vs = Irint s vs + Irint t vs"
| Irint_Sub: "Irint (ISub s t) vs = Irint s vs - Irint t vs"
| Irint_Mult: "Irint (IMult s t) vs = Irint s vs * Irint t vs"
| Irint_C: "Irint (IC i) vs = i"

lemma Irint_C0: "Irint (IC 0) vs = 0"
  by simp

lemma Irint_C1: "Irint (IC 1) vs = 1"
  by simp

lemma Irint_Cnumeral: "Irint (IC (numeral x)) vs = numeral x"
  by simp

lemmas Irint_simps = Irint_Var Irint_Neg Irint_Add Irint_Sub Irint_Mult Irint_C0 Irint_C1 Irint_Cnumeral

lemma "(3::int) * x + y * y - 9 + (- z) = 0"
  apply (reify Irint_simps ("(3::int) * x + y * y - 9 + (- z)"))
  oops

datatype rlist = LVar nat | LEmpty | LCons rint rlist | LAppend rlist rlist

primrec Irlist :: "rlist \<Rightarrow> int list \<Rightarrow> int list list \<Rightarrow> int list"
where
  "Irlist (LEmpty) is vs = []"
| "Irlist (LVar n) is vs = vs ! n"
| "Irlist (LCons i t) is vs = Irint i is # Irlist t is vs"
| "Irlist (LAppend s t) is vs = Irlist s is vs @ Irlist t is vs"

lemma "[(1::int)] = []"
  apply (reify Irlist.simps Irint_simps ("[1] :: int list"))
  oops

lemma "([(3::int) * x + y * y - 9 + (- z)] @ []) @ xs = [y * y - z - 9 + (3::int) * x]"
  apply (reify Irlist.simps Irint_simps ("([(3::int) * x + y * y - 9 + (- z)] @ []) @ xs"))
  oops

datatype rnat = NC nat| NVar nat| NSuc rnat | NAdd rnat rnat | NMult rnat rnat
  | NNeg rnat | NSub rnat rnat | Nlgth rlist

primrec Irnat :: "rnat \<Rightarrow> int list \<Rightarrow> int list list \<Rightarrow> nat list \<Rightarrow> nat"
where
  Irnat_Suc: "Irnat (NSuc t) is ls vs = Suc (Irnat t is ls vs)"
| Irnat_Var: "Irnat (NVar n) is ls vs = vs ! n"
| Irnat_Neg: "Irnat (NNeg t) is ls vs = 0"
| Irnat_Add: "Irnat (NAdd s t) is ls vs = Irnat s is ls vs + Irnat t is ls vs"
| Irnat_Sub: "Irnat (NSub s t) is ls vs = Irnat s is ls vs - Irnat t is ls vs"
| Irnat_Mult: "Irnat (NMult s t) is ls vs = Irnat s is ls vs * Irnat t is ls vs"
| Irnat_lgth: "Irnat (Nlgth rxs) is ls vs = length (Irlist rxs is ls)"
| Irnat_C: "Irnat (NC i) is ls vs = i"

lemma Irnat_C0: "Irnat (NC 0) is ls vs = 0"
  by simp

lemma Irnat_C1: "Irnat (NC 1) is ls vs = 1"
  by simp

lemma Irnat_Cnumeral: "Irnat (NC (numeral x)) is ls vs = numeral x"
  by simp

lemmas Irnat_simps = Irnat_Suc Irnat_Var Irnat_Neg Irnat_Add Irnat_Sub Irnat_Mult Irnat_lgth
  Irnat_C0 Irnat_C1 Irnat_Cnumeral

lemma "Suc n * length (([(3::int) * x + y * y - 9 + (- z)] @ []) @ xs) = length xs"
  apply (reify Irnat_simps Irlist.simps Irint_simps
     ("Suc n * length (([(3::int) * x + y * y - 9 + (- z)] @ []) @ xs)"))
  oops

datatype rifm = RT | RF | RVar nat
  | RNLT rnat rnat | RNILT rnat rint | RNEQ rnat rnat
  | RAnd rifm rifm | ROr rifm rifm | RImp rifm rifm| RIff rifm rifm
  | RNEX rifm | RIEX rifm | RLEX rifm | RNALL rifm | RIALL rifm | RLALL rifm
  | RBEX rifm | RBALL rifm

primrec Irifm :: "rifm \<Rightarrow> bool list \<Rightarrow> int list \<Rightarrow> (int list) list \<Rightarrow> nat list \<Rightarrow> bool"
where
  "Irifm RT ps is ls ns \<longleftrightarrow> True"
| "Irifm RF ps is ls ns \<longleftrightarrow> False"
| "Irifm (RVar n) ps is ls ns \<longleftrightarrow> ps ! n"
| "Irifm (RNLT s t) ps is ls ns \<longleftrightarrow> Irnat s is ls ns < Irnat t is ls ns"
| "Irifm (RNILT s t) ps is ls ns \<longleftrightarrow> int (Irnat s is ls ns) < Irint t is"
| "Irifm (RNEQ s t) ps is ls ns \<longleftrightarrow> Irnat s is ls ns = Irnat t is ls ns"
| "Irifm (RAnd p q) ps is ls ns \<longleftrightarrow> Irifm p ps is ls ns \<and> Irifm q ps is ls ns"
| "Irifm (ROr p q) ps is ls ns \<longleftrightarrow> Irifm p ps is ls ns \<or> Irifm q ps is ls ns"
| "Irifm (RImp p q) ps is ls ns \<longleftrightarrow> Irifm p ps is ls ns \<longrightarrow> Irifm q ps is ls ns"
| "Irifm (RIff p q) ps is ls ns \<longleftrightarrow> Irifm p ps is ls ns = Irifm q ps is ls ns"
| "Irifm (RNEX p) ps is ls ns \<longleftrightarrow> (\<exists>x. Irifm p ps is ls (x # ns))"
| "Irifm (RIEX p) ps is ls ns \<longleftrightarrow> (\<exists>x. Irifm p ps (x # is) ls ns)"
| "Irifm (RLEX p) ps is ls ns \<longleftrightarrow> (\<exists>x. Irifm p ps is (x # ls) ns)"
| "Irifm (RBEX p) ps is ls ns \<longleftrightarrow> (\<exists>x. Irifm p (x # ps) is ls ns)"
| "Irifm (RNALL p) ps is ls ns \<longleftrightarrow> (\<forall>x. Irifm p ps is ls (x#ns))"
| "Irifm (RIALL p) ps is ls ns \<longleftrightarrow> (\<forall>x. Irifm p ps (x # is) ls ns)"
| "Irifm (RLALL p) ps is ls ns \<longleftrightarrow> (\<forall>x. Irifm p ps is (x#ls) ns)"
| "Irifm (RBALL p) ps is ls ns \<longleftrightarrow> (\<forall>x. Irifm p (x # ps) is ls ns)"

lemma " \<forall>x. \<exists>n. ((Suc n) * length (([(3::int) * x + f t * y - 9 + (- z)] @ []) @ xs) = length xs) \<and> m < 5*n - length (xs @ [2,3,4,x*z + 8 - y]) \<longrightarrow> (\<exists>p. \<forall>q. p \<and> q \<longrightarrow> r)"
  apply (reify Irifm.simps Irnat_simps Irlist.simps Irint_simps)
oops

text \<open>An example for equations containing type variables\<close>

datatype prod = Zero | One | Var nat | Mul prod prod
  | Pw prod nat | PNM nat nat prod

primrec Iprod :: " prod \<Rightarrow> ('a::linordered_idom) list \<Rightarrow>'a"
where
  "Iprod Zero vs = 0"
| "Iprod One vs = 1"
| "Iprod (Var n) vs = vs ! n"
| "Iprod (Mul a b) vs = Iprod a vs * Iprod b vs"
| "Iprod (Pw a n) vs = Iprod a vs ^ n"
| "Iprod (PNM n k t) vs = (vs ! n) ^ k * Iprod t vs"

datatype sgn = Pos prod | Neg prod | ZeroEq prod | NZeroEq prod | Tr | F
  | Or sgn sgn | And sgn sgn

primrec Isgn :: "sgn \<Rightarrow> ('a::linordered_idom) list \<Rightarrow> bool"
where
  "Isgn Tr vs \<longleftrightarrow> True"
| "Isgn F vs \<longleftrightarrow> False"
| "Isgn (ZeroEq t) vs \<longleftrightarrow> Iprod t vs = 0"
| "Isgn (NZeroEq t) vs \<longleftrightarrow> Iprod t vs \<noteq> 0"
| "Isgn (Pos t) vs \<longleftrightarrow> Iprod t vs > 0"
| "Isgn (Neg t) vs \<longleftrightarrow> Iprod t vs < 0"
| "Isgn (And p q) vs \<longleftrightarrow> Isgn p vs \<and> Isgn q vs"
| "Isgn (Or p q) vs \<longleftrightarrow> Isgn p vs \<or> Isgn q vs"

lemmas eqs = Isgn.simps Iprod.simps

lemma "(x::'a::{linordered_idom}) ^ 4 * y * z * y ^ 2 * z ^ 23 > 0"
  apply (reify eqs)
  oops

end


(*  Title:      ZF/Resid/Residuals.thy
    Author:     Ole Rasmussen
    Copyright   1995  University of Cambridge
*)

theory Residuals imports Substitution begin

consts
  Sres          :: "i"

abbreviation
  "residuals(u,v,w) == <u,v,w> \<in> Sres"

inductive
  domains       "Sres" \<subseteq> "redexes*redexes*redexes"
  intros
    Res_Var:    "n \<in> nat ==> residuals(Var(n),Var(n),Var(n))"
    Res_Fun:    "[|residuals(u,v,w)|]==>
                     residuals(Fun(u),Fun(v),Fun(w))"
    Res_App:    "[|residuals(u1,v1,w1);
                   residuals(u2,v2,w2); b \<in> bool|]==>
                 residuals(App(b,u1,u2),App(0,v1,v2),App(b,w1,w2))"
    Res_redex:  "[|residuals(u1,v1,w1);
                   residuals(u2,v2,w2); b \<in> bool|]==>
                 residuals(App(b,Fun(u1),u2),App(1,Fun(v1),v2),w2/w1)"
  type_intros    subst_type nat_typechecks redexes.intros bool_typechecks

definition
  res_func      :: "[i,i]=>i"     (infixl "|>" 70)  where
  "u |> v == THE w. residuals(u,v,w)"

subsection{*Setting up rule lists*}

declare Sres.intros [intro]
declare Sreg.intros [intro]
declare subst_type [intro]

inductive_cases [elim!]:
  "residuals(Var(n),Var(n),v)"
  "residuals(Fun(t),Fun(u),v)"
  "residuals(App(b, u1, u2), App(0, v1, v2),v)"
  "residuals(App(b, u1, u2), App(1, Fun(v1), v2),v)"
  "residuals(Var(n),u,v)"
  "residuals(Fun(t),u,v)"
  "residuals(App(b, u1, u2), w,v)"
  "residuals(u,Var(n),v)"
  "residuals(u,Fun(t),v)"
  "residuals(w,App(b, u1, u2),v)"

inductive_cases [elim!]:
  "Var(n) <== u"
  "Fun(n) <== u"
  "u <== Fun(n)"
  "App(1,Fun(t),a) <== u"
  "App(0,t,a) <== u"

inductive_cases [elim!]:
  "Fun(t) \<in> redexes"

declare Sres.intros [simp]

subsection{*residuals is a  partial function*}

lemma residuals_function [rule_format]:
     "residuals(u,v,w) ==> \<forall>w1. residuals(u,v,w1) \<longrightarrow> w1 = w"
by (erule Sres.induct, force+)

lemma residuals_intro [rule_format]:
     "u~v ==> regular(v) \<longrightarrow> (\<exists>w. residuals(u,v,w))"
by (erule Scomp.induct, force+)

lemma comp_resfuncD:
     "[| u~v;  regular(v) |] ==> residuals(u, v, THE w. residuals(u, v, w))"
apply (frule residuals_intro, assumption, clarify)
apply (subst the_equality)
apply (blast intro: residuals_function)+
done

subsection{*Residual function*}

lemma res_Var [simp]: "n \<in> nat ==> Var(n) |> Var(n) = Var(n)"
by (unfold res_func_def, blast)

lemma res_Fun [simp]:
    "[|s~t; regular(t)|]==> Fun(s) |> Fun(t) = Fun(s |> t)"
apply (unfold res_func_def)
apply (blast intro: comp_resfuncD residuals_function)
done

lemma res_App [simp]:
    "[|s~u; regular(u); t~v; regular(v); b \<in> bool|]
     ==> App(b,s,t) |> App(0,u,v) = App(b, s |> u, t |> v)"
apply (unfold res_func_def)
apply (blast dest!: comp_resfuncD intro: residuals_function)
done

lemma res_redex [simp]:
    "[|s~u; regular(u); t~v; regular(v); b \<in> bool|]
     ==> App(b,Fun(s),t) |> App(1,Fun(u),v) = (t |> v)/ (s |> u)"
apply (unfold res_func_def)
apply (blast elim!: redexes.free_elims dest!: comp_resfuncD
             intro: residuals_function)
done

lemma resfunc_type [simp]:
     "[|s~t; regular(t)|]==> regular(t) \<longrightarrow> s |> t \<in> redexes"
  by (erule Scomp.induct, auto)

subsection{*Commutation theorem*}

lemma sub_comp [simp]: "u<==v ==> u~v"
by (erule Ssub.induct, simp_all)

lemma sub_preserve_reg [rule_format, simp]:
     "u<==v  ==> regular(v) \<longrightarrow> regular(u)"
by (erule Ssub.induct, auto)

lemma residuals_lift_rec: "[|u~v; k \<in> nat|]==> regular(v)\<longrightarrow> (\<forall>n \<in> nat.
         lift_rec(u,n) |> lift_rec(v,n) = lift_rec(u |> v,n))"
apply (erule Scomp.induct, safe)
apply (simp_all add: lift_rec_Var subst_Var lift_subst)
done

lemma residuals_subst_rec:
     "u1~u2 ==>  \<forall>v1 v2. v1~v2 \<longrightarrow> regular(v2) \<longrightarrow> regular(u2) \<longrightarrow>
                  (\<forall>n \<in> nat. subst_rec(v1,u1,n) |> subst_rec(v2,u2,n) =
                    subst_rec(v1 |> v2, u1 |> u2,n))"
apply (erule Scomp.induct, safe)
apply (simp_all add: lift_rec_Var subst_Var residuals_lift_rec)
apply (drule_tac psi = "\<forall>x.?P (x) " in asm_rl)
apply (simp add: substitution)
done

lemma commutation [simp]:
     "[|u1~u2; v1~v2; regular(u2); regular(v2)|]
      ==> (v1/u1) |> (v2/u2) = (v1 |> v2)/(u1 |> u2)"
by (simp add: residuals_subst_rec)

subsection{*Residuals are comp and regular*}

lemma residuals_preserve_comp [rule_format, simp]:
     "u~v ==> \<forall>w. u~w \<longrightarrow> v~w \<longrightarrow> regular(w) \<longrightarrow> (u|>w) ~ (v|>w)"
by (erule Scomp.induct, force+)

lemma residuals_preserve_reg [rule_format, simp]:
     "u~v ==> regular(u) \<longrightarrow> regular(v) \<longrightarrow> regular(u|>v)"
apply (erule Scomp.induct, auto)
done

subsection{*Preservation lemma*}

lemma union_preserve_comp: "u~v ==> v ~ (u un v)"
by (erule Scomp.induct, simp_all)

lemma preservation [rule_format]:
     "u ~ v ==> regular(v) \<longrightarrow> u|>v = (u un v)|>v"
apply (erule Scomp.induct, safe)
apply (drule_tac [3] psi = "Fun (?u) |> ?v = ?w" in asm_rl)
apply (auto simp add: union_preserve_comp comp_sym_iff)
done

declare sub_comp [THEN comp_sym, simp]

subsection{*Prism theorem*}

(* Having more assumptions than needed -- removed below  *)
lemma prism_l [rule_format]:
     "v<==u ==>
       regular(u) \<longrightarrow> (\<forall>w. w~v \<longrightarrow> w~u \<longrightarrow>
                            w |> u = (w|>v) |> (u|>v))"
by (erule Ssub.induct, force+)

lemma prism: "[|v <== u; regular(u); w~v|] ==> w |> u = (w|>v) |> (u|>v)"
apply (rule prism_l)
apply (rule_tac [4] comp_trans, auto)
done

subsection{*Levy's Cube Lemma*}

lemma cube: "[|u~v; regular(v); regular(u); w~u|]==>
           (w|>u) |> (v|>u) = (w|>v) |> (u|>v)"
apply (subst preservation [of u], assumption, assumption)
apply (subst preservation [of v], erule comp_sym, assumption)
apply (subst prism [symmetric, of v])
apply (simp add: union_r comp_sym_iff)
apply (simp add: union_preserve_regular comp_sym_iff)
apply (erule comp_trans, assumption)
apply (simp add: prism [symmetric] union_l union_preserve_regular
                 comp_sym_iff union_sym)
done

subsection{*paving theorem*}

lemma paving: "[|w~u; w~v; regular(u); regular(v)|]==>
           \<exists>uv vu. (w|>u) |> vu = (w|>v) |> uv & (w|>u)~vu &
             regular(vu) & (w|>v)~uv & regular(uv) "
apply (subgoal_tac "u~v")
apply (safe intro!: exI)
apply (rule cube)
apply (simp_all add: comp_sym_iff)
apply (blast intro: residuals_preserve_comp comp_trans comp_sym)+
done

end