(*  Author:      Andreas Lochbihler
    Maintainer:  Andreas Lochbihler
*)
header {* Manual construction of a resumption codatatype *}

theory Resumption imports
  "~~/src/HOL/Library/Old_Datatype"
begin

text {*
  This theory defines the following codatatype:

\begin{verbatim}
codatatype ('a,'b,'c,'d) resumption =
    Terminal 'a
  | Linear 'b "('a,'b,'c,'d) resumption"
  | Branch 'c "'d => ('a,'b,'c,'d) resumption"
\end{verbatim}

*}

subsection {* Auxiliary definitions and lemmata similar to @{theory Old_Datatype} *}

lemma Lim_mono: "(\<And>d. rs d \<subseteq> rs' d) \<Longrightarrow> Old_Datatype.Lim rs \<subseteq> Old_Datatype.Lim rs'"
by(simp add: Lim_def) blast

lemma Lim_UN1:  "Old_Datatype.Lim (\<lambda>x. \<Union>y. f x y) = (\<Union>y. Old_Datatype.Lim (\<lambda>x. f x y))"
by(simp add: Old_Datatype.Lim_def) blast

text {*
  Inverse for @{term "Old_Datatype.Lim"} like @{term "Old_Datatype.Split"} and @{term "Old_Datatype.Case"}
  for @{term "Old_Datatype.Scons"} and @{term "In0"}/@{term "In1"}
*}

definition DTBranch :: "(('b \<Rightarrow> ('a, 'b) Old_Datatype.dtree) \<Rightarrow> 'c) \<Rightarrow> ('a, 'b) Old_Datatype.dtree \<Rightarrow> 'c"
where "DTBranch f M = (THE u. \<exists>x. M = Old_Datatype.Lim x \<and> u = f x)"

lemma DTBranch_Lim [simp]: "DTBranch f (Old_Datatype.Lim M) = f M"
by(auto simp add: DTBranch_def dest: Lim_inject)

text {* Lemmas for @{term Old_Datatype.ntrunc} and @{term "Old_Datatype.Lim"} *}

lemma ndepth_Push_Node_Inl_aux:
     "case_nat (Inl n) f k = Inr 0 \<Longrightarrow> Suc (LEAST x. f x = Inr 0) <= k"
apply (induct "k", auto)
apply (erule Least_le)
done

lemma ndepth_Push_Node_Inl:
  "ndepth (Push_Node (Inl a) n) = Suc (ndepth n)"
using Rep_Node[of n, unfolded Node_def]
apply(simp add: ndepth_def Push_Node_def Abs_Node_inverse[OF Node_Push_I[OF Rep_Node]])
apply(simp add: Push_def split_beta)
apply(rule Least_equality)
apply(auto elim: LeastI intro: ndepth_Push_Node_Inl_aux)
done

lemma ntrunc_Lim [simp]: "ntrunc (Suc k) (Old_Datatype.Lim rs) = Old_Datatype.Lim (\<lambda>x. ntrunc k (rs x))"
unfolding Lim_def ntrunc_def
apply(rule equalityI)
apply clarify
apply(auto simp add: ndepth_Push_Node_Inl)
done

subsection {* Definition for the codatatype universe *}

text {* Constructors *}

definition TERMINAL :: "'a \<Rightarrow> ('c + 'b + 'a, 'd) Old_Datatype.dtree"
where "TERMINAL a = In0 (Old_Datatype.Leaf (Inr (Inr a)))"

definition LINEAR :: "'b \<Rightarrow> ('c + 'b + 'a, 'd) Old_Datatype.dtree \<Rightarrow> ('c + 'b + 'a, 'd) Old_Datatype.dtree"
  where "LINEAR b r = In1 (In0 (Scons (Old_Datatype.Leaf (Inr (Inl b))) r))"

definition BRANCH :: "'c \<Rightarrow> ('d \<Rightarrow> ('c + 'b + 'a, 'd) Old_Datatype.dtree) \<Rightarrow> ('c + 'b + 'a, 'd) Old_Datatype.dtree"
 where "BRANCH c rs = In1 (In1 (Scons (Old_Datatype.Leaf (Inl c)) (Old_Datatype.Lim rs)))"

text {* case operator *}

definition case_RESUMPTION :: "('a \<Rightarrow> 'e) \<Rightarrow> ('b \<Rightarrow> (('c + 'b + 'a, 'd) Old_Datatype.dtree) \<Rightarrow> 'e) \<Rightarrow> ('c \<Rightarrow> ('d \<Rightarrow> ('c + 'b + 'a, 'd) Old_Datatype.dtree) \<Rightarrow> 'e) \<Rightarrow> ('c + 'b + 'a, 'd) Old_Datatype.dtree \<Rightarrow> 'e"
where
  "case_RESUMPTION t l br =
   Old_Datatype.Case (t o inv (Old_Datatype.Leaf o Inr o Inr))
                 (Old_Datatype.Case (Old_Datatype.Split (\<lambda>x. l (inv (Old_Datatype.Leaf o Inr o Inl) x)))
                                (Old_Datatype.Split (\<lambda>x. DTBranch (br (inv (Old_Datatype.Leaf o Inl) x)))))"

lemma case_RESUMPTION_simps [simp]:
  shows case_RESUMPTION_TERMINAL: "case_RESUMPTION t l br (TERMINAL a) = t a"
  and case_RESUMPTION_LINEAR: "case_RESUMPTION t l br (LINEAR b r) = l b r"
  and case_RESUMPTION_BRANCH: "case_RESUMPTION t l br (BRANCH c rs) = br c rs"
apply(simp_all add: case_RESUMPTION_def TERMINAL_def LINEAR_def BRANCH_def o_def)
apply(rule arg_cong) back
apply(blast intro: injI inv_f_f)
apply(rule arg_cong) back
apply(blast intro: injI inv_f_f)
apply(rule arg_cong) back
apply(blast intro: injI inv_f_f)
done

lemma LINEAR_mono: "r \<subseteq> r' \<Longrightarrow> LINEAR b r \<subseteq> LINEAR b r'"
by(simp add: LINEAR_def In1_mono In0_mono Scons_mono)

lemma BRANCH_mono: "(\<And>d. rs d \<subseteq> rs' d) \<Longrightarrow> BRANCH c rs \<subseteq> BRANCH c rs'"
by(simp add: BRANCH_def In1_mono Scons_mono Lim_mono)

lemma LINEAR_UN: "LINEAR b (\<Union>x. f x) = (\<Union>x. LINEAR b (f x))"
by (simp add: LINEAR_def In1_UN1 In0_UN1 Scons_UN1_y)

lemma BRANCH_UN: "BRANCH b (\<lambda>d. \<Union>x. f d x) = (\<Union>x. BRANCH b (\<lambda>d. f d x))"
by (simp add: BRANCH_def Lim_UN1 In1_UN1 In0_UN1 Scons_UN1_y)

text {* The codatatype universe *}

coinductive_set resumption :: "('c + 'b + 'a, 'd) Old_Datatype.dtree set"
where
resumption_TERMINAL:
  "TERMINAL a \<in> resumption"
| resumption_LINEAR:
  "r \<in> resumption \<Longrightarrow> LINEAR b r \<in> resumption"
| resumption_BRANCH:
  "(\<And>d. rs d \<in> resumption) \<Longrightarrow> BRANCH c rs \<in> resumption"

subsection {* Definition of the codatatype as a type *}

typedef ('a,'b,'c,'d) resumption = "resumption :: ('c + 'b + 'a, 'd) Old_Datatype.dtree set"
proof
  show "TERMINAL undefined \<in> ?resumption" by(blast intro: resumption.intros)
qed

text {* Constructors *}

definition Terminal :: "'a \<Rightarrow> ('a,'b,'c,'d) resumption"
where "Terminal a = Abs_resumption (TERMINAL a)"

definition Linear :: "'b \<Rightarrow> ('a,'b,'c,'d) resumption \<Rightarrow> ('a,'b,'c,'d) resumption"
where "Linear b r = Abs_resumption (LINEAR b (Rep_resumption r))"

definition Branch :: "'c \<Rightarrow> ('d \<Rightarrow> ('a,'b,'c,'d) resumption) \<Rightarrow> ('a,'b,'c,'d) resumption"
where "Branch c rs = Abs_resumption (BRANCH c (\<lambda>d. Rep_resumption (rs d)))"

lemma [iff]:
  shows Terminal_not_Linear: "Terminal a \<noteq> Linear b r"
  and Linear_not_Terminal: "Linear b R \<noteq> Terminal a"
  and Termina_not_Branch: "Terminal a \<noteq> Branch c rs"
  and Branch_not_Terminal: "Branch c rs \<noteq> Terminal a"
  and Linear_not_Branch: "Linear b r \<noteq> Branch c rs"
  and Branch_not_Linear: "Branch c rs \<noteq> Linear b r"
  and Terminal_inject: "Terminal a = Terminal a' \<longleftrightarrow> a = a'"
  and Linear_inject: "Linear b r = Linear b' r' \<longleftrightarrow> b = b' \<and> r = r'"
  and Branch_inject: "Branch c rs = Branch c' rs' \<longleftrightarrow> c = c' \<and> rs = rs'"
apply(auto simp add: Terminal_def Linear_def Branch_def simp add: Rep_resumption resumption.intros Abs_resumption_inject Rep_resumption_inject)
apply(subst (asm) fun_eq_iff, auto simp add: Rep_resumption_inject)
done

lemma Rep_resumption_constructors:
  shows Rep_resumption_Terminal: "Rep_resumption (Terminal a) = TERMINAL a"
  and Rep_resumption_Linear: "Rep_resumption (Linear b r) = LINEAR b (Rep_resumption r)"
  and Rep_resumption_Branch: "Rep_resumption (Branch c rs) = BRANCH c (\<lambda>d. Rep_resumption (rs d))"
by(simp_all add: Terminal_def Linear_def Branch_def Abs_resumption_inverse resumption.intros Rep_resumption)

text {* Case operator *}

definition case_resumption :: "('a \<Rightarrow> 'e) \<Rightarrow> ('b \<Rightarrow> ('a,'b,'c,'d) resumption \<Rightarrow> 'e) \<Rightarrow>
                            ('c \<Rightarrow> ('d \<Rightarrow> ('a,'b,'c,'d) resumption) \<Rightarrow> 'e) \<Rightarrow> ('a,'b,'c,'d) resumption \<Rightarrow> 'e"
where [code del]:
  "case_resumption t l br r =
   case_RESUMPTION t (\<lambda>b r. l b (Abs_resumption r)) (\<lambda>c rs. br c (\<lambda>d. Abs_resumption (rs d))) (Rep_resumption r)"

lemma case_resumption_simps [simp, code]:
  shows case_resumption_Terminal: "case_resumption t l br (Terminal a) = t a"
  and case_resumption_Linear: "case_resumption t l br (Linear b r) = l b r"
  and case_resumption_Branch: "case_resumption t l br (Branch c rs) = br c rs"
by(simp_all add: Terminal_def Linear_def Branch_def case_resumption_def Abs_resumption_inverse resumption.intros Rep_resumption Rep_resumption_inverse)

declare [[case_translation case_resumption Terminal Linear Branch]]

lemma case_resumption_cert:
  assumes "CASE \<equiv> case_resumption t l br"
  shows "(CASE (Terminal a) \<equiv> t a) &&& (CASE (Linear b r) \<equiv> l b r) &&& (CASE (Branch c rs) \<equiv> br c rs)"
using assms by simp_all

code_datatype Terminal Linear Branch

setup {*
  Code.add_case @{thm case_resumption_cert}
*}

setup {*
  Nitpick.register_codatatype @{typ "('a,'b,'c,'d) resumption"} @{const_name case_resumption}
                              (map dest_Const [@{term Terminal}, @{term Linear}, @{term Branch}])
*}

lemma resumption_exhaust [cases type: resumption]:
  obtains (Terminal) a where "x = Terminal a"
  | (Linear) b r where "x = Linear b r"
  | (Branch) c rs where "x = Branch c rs"
proof(cases x)
  case (Abs_resumption y)
  note [simp] = `x = Abs_resumption y`
  from `y \<in> resumption` show thesis
  proof(cases rule: resumption.cases)
    case resumption_TERMINAL thus ?thesis
      by -(rule Terminal, simp add: Terminal_def)
  next
    case (resumption_LINEAR r b)
    from `r \<in> resumption` have "Rep_resumption (Abs_resumption r) = r"
      by(simp add: Abs_resumption_inverse)
    hence "y = LINEAR b (Rep_resumption (Abs_resumption r))"
      using `y = LINEAR b r` by simp
    thus ?thesis by -(rule Linear, simp add: Linear_def)
  next
    case (resumption_BRANCH rs c)
    from `\<And>d. rs d \<in> resumption`
    have eq: "rs = (\<lambda>d. Rep_resumption (Abs_resumption (rs d)))"
      by(subst Abs_resumption_inverse) blast+
    show ?thesis using `y = BRANCH c rs`
      by -(rule Branch, simp add: Branch_def, subst eq, simp)
  qed
qed

lemma resumption_split:
  "P (case_resumption t l br r) \<longleftrightarrow>
  (\<forall>a. r = Terminal a \<longrightarrow> P (t a)) \<and>
  (\<forall>b r'. r = Linear b r' \<longrightarrow> P (l b r')) \<and>
  (\<forall>c rs. r = Branch c rs \<longrightarrow> P (br c rs))"
by(cases r) simp_all

lemma resumption_split_asm:
  "P (case_resumption t l br r) \<longleftrightarrow>
  \<not> ((\<exists>a. r = Terminal a \<and> \<not> P (t a)) \<or>
     (\<exists>b r'. r = Linear b r' \<and> \<not> P (l b r')) \<or>
     (\<exists>c rs. r = Branch c rs \<and> \<not> P (br c rs)))"
by(cases r) simp_all

lemmas resumption_splits = resumption_split resumption_split_asm

text {* corecursion operator *}

datatype (dead 'a, dead 'b, dead 'c, dead 'd, dead 'e) resumption_corec =
    Terminal_corec 'a
  | Linear_corec 'b 'e
  | Branch_corec 'c "'d \<Rightarrow> 'e"
  | Resumption_corec "('a, 'b, 'c, 'd) resumption"

primrec RESUMPTION_corec_aux :: "nat \<Rightarrow> ('e \<Rightarrow> ('a,'b,'c,'d,'e) resumption_corec) \<Rightarrow> 'e \<Rightarrow> ('c + 'b + 'a,'d) Old_Datatype.dtree"
where
  "RESUMPTION_corec_aux 0 f e = {}"
| "RESUMPTION_corec_aux (Suc n) f e =
  (case f e of Terminal_corec a \<Rightarrow> TERMINAL a
            | Linear_corec b e' \<Rightarrow> LINEAR b (RESUMPTION_corec_aux n f e')
            | Branch_corec c es \<Rightarrow> BRANCH c (\<lambda>d. RESUMPTION_corec_aux n f (es d))
            | Resumption_corec r \<Rightarrow> Rep_resumption r)"

definition RESUMPTION_corec :: "('e \<Rightarrow> ('a,'b,'c,'d,'e) resumption_corec) \<Rightarrow> 'e \<Rightarrow> ('c + 'b + 'a,'d) Old_Datatype.dtree"
where
  "RESUMPTION_corec f e = (\<Union>n. RESUMPTION_corec_aux n f e)"

lemma RESUMPTION_corec [nitpick_simp]:
  "RESUMPTION_corec f e =
  (case f e of Terminal_corec a \<Rightarrow> TERMINAL a
            | Linear_corec b e' \<Rightarrow> LINEAR b (RESUMPTION_corec f e')
            | Branch_corec c es \<Rightarrow> BRANCH c (\<lambda>d. RESUMPTION_corec f (es d))
            | Resumption_corec r \<Rightarrow> Rep_resumption r)"
  (is "?lhs = ?rhs")
proof
  show "?lhs \<subseteq> ?rhs" unfolding RESUMPTION_corec_def
  proof(rule UN_least)
    fix n
    show "RESUMPTION_corec_aux n f e
        \<subseteq> (case f e of Terminal_corec a \<Rightarrow> TERMINAL a
           | Linear_corec b e' \<Rightarrow> LINEAR b (\<Union>n. RESUMPTION_corec_aux n f e')
           | Branch_corec c es \<Rightarrow> BRANCH c (\<lambda>d. \<Union>n. RESUMPTION_corec_aux n f (es d))
           | Resumption_corec r \<Rightarrow> Rep_resumption r)"
      apply(cases n, simp_all split: resumption_corec.split)
      by(rule conjI strip LINEAR_mono[OF UN_upper] BRANCH_mono[OF UN_upper] UNIV_I)+
  qed
next
  show "?rhs \<subseteq> ?lhs" unfolding RESUMPTION_corec_def
    apply(simp split: resumption_corec.split add: LINEAR_UN BRANCH_UN)
    by safe(rule_tac a="Suc ?n" in UN_I, rule UNIV_I, simp)+
qed

lemma RESUMPTION_corec_type: "RESUMPTION_corec f e \<in> resumption"
proof -
  have "\<exists>x. RESUMPTION_corec f e = RESUMPTION_corec f x" by blast
  thus ?thesis
  proof coinduct
    case (resumption x)
    then obtain e where x: "x = RESUMPTION_corec f e" by blast
    thus ?case
    proof(cases "f e")
      case (Resumption_corec r)
      thus ?thesis using x
        by(cases r)(simp_all add: RESUMPTION_corec Rep_resumption_constructors Rep_resumption)
    qed(auto simp add: RESUMPTION_corec)
  qed
qed

text {* corecursion operator for the resumption type *}

definition resumption_corec :: "('e \<Rightarrow> ('a,'b,'c,'d,'e) resumption_corec) \<Rightarrow> 'e \<Rightarrow> ('a,'b,'c,'d) resumption"
where
  "resumption_corec f e = Abs_resumption (RESUMPTION_corec f e)"

lemma resumption_corec:
  "resumption_corec f e =
  (case f e of Terminal_corec a \<Rightarrow> Terminal a
            | Linear_corec b e' \<Rightarrow> Linear b (resumption_corec f e')
            | Branch_corec c es \<Rightarrow> Branch c (\<lambda>d. resumption_corec f (es d))
            | Resumption_corec r \<Rightarrow> r)"
unfolding resumption_corec_def
apply(subst RESUMPTION_corec)
apply(auto split: resumption_corec.splits simp add: Terminal_def Linear_def Branch_def RESUMPTION_corec_type Abs_resumption_inverse Rep_resumption_inverse)
done

text {* Equality as greatest fixpoint *}

coinductive Eq_RESUMPTION :: "('c+'b+'a, 'd) Old_Datatype.dtree \<Rightarrow> ('c+'b+'a, 'd) Old_Datatype.dtree \<Rightarrow> bool"
where
  EqTERMINAL: "Eq_RESUMPTION (TERMINAL a) (TERMINAL a)"
| EqLINEAR: "Eq_RESUMPTION r r' \<Longrightarrow> Eq_RESUMPTION (LINEAR b r) (LINEAR b r')"
| EqBRANCH: "(\<And>d. Eq_RESUMPTION (rs d) (rs' d)) \<Longrightarrow> Eq_RESUMPTION (BRANCH c rs) (BRANCH c rs')"

lemma Eq_RESUMPTION_refl:
  assumes "r \<in> resumption"
  shows "Eq_RESUMPTION r r"
proof -
  def r' == r
  with assms have "r = r' \<and> r \<in> resumption" by auto
  thus "Eq_RESUMPTION r r'"
  proof(coinduct)
    case (Eq_RESUMPTION r r')
    hence [simp]: "r = r'" and "r \<in> resumption" by auto
    from `r \<in> resumption` show ?case
      by(cases rule: resumption.cases) auto
  qed
qed

lemma Eq_RESUMPTION_into_resumption:
  assumes "Eq_RESUMPTION r r"
  shows "r \<in> resumption"
using assms
proof(coinduct)
  case resumption thus ?case by cases auto
qed

lemma Eq_RESUMPTION_eq:
  "Eq_RESUMPTION r r' \<longleftrightarrow> r = r' \<and> r \<in> resumption"
proof(rule iffI)
  assume "Eq_RESUMPTION r r'"
  hence "\<And>k. ntrunc k r = ntrunc k r'" by(rule Eq_RESUMPTION_implies_ntrunc_equality)
  hence "r = r'" by(rule ntrunc_equality)
  moreover with `Eq_RESUMPTION r r'` have "r \<in> resumption"
    by(auto intro: Eq_RESUMPTION_into_resumption)
  ultimately show "r = r' \<and> r \<in> resumption" ..
next
  assume "r = r' \<and> r \<in> resumption"
  thus "Eq_RESUMPTION r r'" by(blast intro: Eq_RESUMPTION_refl)
qed

lemma Eq_RESUMPTION_I [consumes 1, case_names Eq_RESUMPTION, case_conclusion Eq_RESUMPTION EqTerminal EqLinear EqBranch]:
  assumes "X r r'"
  and step: "\<And>r r'. X r r' \<Longrightarrow>
             (\<exists>a. r = TERMINAL a \<and> r' = TERMINAL a) \<or>
             (\<exists>R R' b. r = LINEAR b R \<and> r' = LINEAR b R' \<and> (X R R' \<or> Eq_RESUMPTION R R')) \<or>
             (\<exists>rs rs' c. r = BRANCH c rs \<and> r' = BRANCH c rs' \<and> (\<forall>d. X (rs d) (rs' d) \<or> Eq_RESUMPTION (rs d) (rs' d)))"
  shows "r = r'"
proof -
  from `X r r'` have "Eq_RESUMPTION r r'"
    by(coinduct)(rule step)
  thus ?thesis by(simp add: Eq_RESUMPTION_eq)
qed

lemma resumption_equalityI [consumes 1, case_names Eq_resumption, case_conclusion Eq_resumption EqTerminal EqLinear EqBranch]:
  assumes "X r r'"
  and step: "\<And>r r'. X r r' \<Longrightarrow>
             (\<exists>a. r = Terminal a \<and> r' = Terminal a) \<or>
             (\<exists>R R' b. r = Linear b R \<and> r' = Linear b R' \<and> (X R R' \<or> R = R')) \<or>
             (\<exists>rs rs' c. r = Branch c rs \<and> r' = Branch c rs' \<and> (\<forall>d. X (rs d) (rs' d) \<or> rs d = rs' d))"
  shows "r = r'"
proof -
  def M == "Rep_resumption r" and N == "Rep_resumption r'"
  with `X r r'` have "\<exists>r r'. M = Rep_resumption r \<and> N = Rep_resumption r' \<and> X r r'" by blast
  hence "M = N"
  proof(coinduct rule: Eq_RESUMPTION_I)
    case (Eq_RESUMPTION M N)
    then obtain r r' where [simp]: "M = Rep_resumption r" "N = Rep_resumption r'"
      and "X r r'" by blast
    { assume "\<exists>a. r = Terminal a \<and> r' = Terminal a"
      hence ?EqTerminal by(auto simp add: Rep_resumption_constructors)
      hence ?case .. }
    moreover
    { assume "\<exists>R R' b. r = Linear b R \<and> r' = Linear b R' \<and> (X R R' \<or> R = R')"
      hence ?EqLinear
        by(clarsimp simp add: Rep_resumption_constructors Eq_RESUMPTION_eq Rep_resumption_inject Rep_resumption)
      hence ?case by blast }
    moreover
    { assume "\<exists>rs rs' c. r = Branch c rs \<and> r' = Branch c rs' \<and> (\<forall>d. X (rs d) (rs' d) \<or> rs d = rs' d)"
      hence ?EqBranch
        by(clarsimp simp add: Rep_resumption_constructors Eq_RESUMPTION_eq Rep_resumption_inject Rep_resumption)
      hence ?case by blast }
    ultimately show ?case using step[OF `X r r'`] by blast
  qed
  thus ?thesis unfolding M_def N_def by(simp add: Rep_resumption_inject)
qed

text {*
  Finality of @{text "resumption"}: Uniqueness of functions defined by corecursion.
*}

lemma equals_RESUMPTION_corec:
  assumes h: "\<And>x. h x = (case f x of Terminal_corec a \<Rightarrow> TERMINAL a
                                   | Linear_corec b x' \<Rightarrow> LINEAR b (h x')
                                   | Branch_corec c xs \<Rightarrow> BRANCH c (\<lambda>d. h (xs d))
                                   | Resumption_corec r \<Rightarrow> Rep_resumption r)"
  shows "h = RESUMPTION_corec f"
proof
  fix x
  def h' == "RESUMPTION_corec f"
  have h': "\<And>x. h' x = (case f x of Terminal_corec a \<Rightarrow> TERMINAL a
                                   | Linear_corec b x' \<Rightarrow> LINEAR b (h' x')
                                   | Branch_corec c xs \<Rightarrow> BRANCH c (\<lambda>d. h' (xs d))
                                   | Resumption_corec r \<Rightarrow> Rep_resumption r)"
    unfolding h'_def by(simp add: RESUMPTION_corec)
  def M == "h x" and N == "h' x"
  hence "\<exists>x. M = h x \<and> N = h' x" by blast
  thus "M = N"
  proof(coinduct rule: Eq_RESUMPTION_I)
    case (Eq_RESUMPTION M N)
    then obtain x where [simp]: "M = h x" "N = h' x" by blast
    show ?case
    proof(cases "f x")
      case (Terminal_corec a)
      with h h' have ?EqTerminal by simp
      thus ?thesis ..
    next
      case (Linear_corec b x')
      with h h' have ?EqLinear by auto
      thus ?thesis by blast
    next
      case (Branch_corec c xs)
      with h h' have ?EqBranch by auto
      thus ?thesis by blast
    next
      case (Resumption_corec r)
      thus ?thesis
        by(cases r)(simp_all add: h h' Rep_resumption_constructors Eq_RESUMPTION_refl Rep_resumption)
    qed
  qed
qed

lemma equals_resumption_corec:
  assumes h: "\<And>x. h x = (case f x of Terminal_corec a \<Rightarrow> Terminal a
                                   | Linear_corec b x' \<Rightarrow> Linear b (h x')
                                   | Branch_corec c xs \<Rightarrow> Branch c (\<lambda>d. h (xs d))
                                   | Resumption_corec r \<Rightarrow> r)"
  shows "h = resumption_corec f"
proof(rule ext)
  fix x
  { fix x
    from h[of x]
    have "Rep_resumption (h x) =
      (case f x of Terminal_corec a \<Rightarrow> TERMINAL a
                | Linear_corec b x' \<Rightarrow> LINEAR b (Rep_resumption (h x'))
                | Branch_corec c xs \<Rightarrow> BRANCH c (\<lambda>d. Rep_resumption (h (xs d)))
                | Resumption_corec r \<Rightarrow> Rep_resumption r)"
      by(auto split: resumption_corec.split simp add: Rep_resumption_constructors) }
  hence eq: "(\<lambda>x. Rep_resumption (h x)) = RESUMPTION_corec f" by(rule equals_RESUMPTION_corec)
  hence "Abs_resumption (Rep_resumption (h x)) = Abs_resumption (RESUMPTION_corec f x)"
    by(subst (asm) fun_eq_iff)(auto)
  from this[symmetric] show "h x = resumption_corec f x"
    unfolding resumption_corec_def by(simp add: Rep_resumption_inverse)
qed

end


(*  Title:       CoreC++
    Author:      Daniel Wasserrab
    Maintainer:  Daniel Wasserrab <wasserra at fmi.uni-passau.de>

   Based on extracts from the Jinja theories:
      Common/Objects.thy by David von Oheimb
      Common/Conform.thy by David von Oheimb and Tobias Nipkow
      Common/Exceptions.thy by Gerwin Klein and Martin Strecker
      J/BigStep.thy by Tobias Nipkow
      J/SmallStep.thy by Tobias Nipkow
      J/WellTypeRT.thy by Tobias Nipkow
*)

header {* \isaheader{Heap Extension} *}

theory HeapExtension
imports Progress
begin

section {* The Heap Extension *}

definition hext :: "heap \<Rightarrow> heap \<Rightarrow> bool" ("_ \<unlhd> _" [51,51] 50) where
  "h \<unlhd> h'  \<equiv>  \<forall>a C S. h a = Some(C,S) \<longrightarrow> (\<exists>S'. h' a = Some(C,S'))"

lemma hextI: "\<forall>a C S. h a = Some(C,S) \<longrightarrow> (\<exists>S'. h' a = Some(C,S')) \<Longrightarrow> h \<unlhd> h'"

apply (unfold hext_def)
apply auto
done

lemma hext_objD: "\<lbrakk> h \<unlhd> h'; h a = Some(C,S) \<rbrakk> \<Longrightarrow> \<exists>S'. h' a = Some(C,S')"

apply (unfold hext_def)
apply (force)
done

lemma hext_refl [iff]: "h \<unlhd> h"

apply (rule hextI)
apply (fast)
done

lemma hext_new [simp]: "h a = None \<Longrightarrow> h \<unlhd> h(a\<mapsto>x)"

apply (rule hextI)
apply (auto simp:fun_upd_apply)
done

lemma hext_trans: "\<lbrakk> h \<unlhd> h'; h' \<unlhd> h'' \<rbrakk> \<Longrightarrow> h \<unlhd> h''"

apply (rule hextI)
apply (fast dest: hext_objD)
done

lemma hext_upd_obj: "h a = Some (C,S) \<Longrightarrow> h \<unlhd> h(a\<mapsto>(C,S'))"

apply (rule hextI)
apply (auto simp:fun_upd_apply)
done

section {* @{text"\<unlhd>"} and preallocated *}

lemma preallocated_hext:
  "\<lbrakk> preallocated h; h \<unlhd> h' \<rbrakk> \<Longrightarrow> preallocated h'"
by (simp add: preallocated_def hext_def)

lemmas preallocated_upd_obj = preallocated_hext [OF _ hext_upd_obj]
lemmas preallocated_new  = preallocated_hext [OF _ hext_new]

section {* @{text"\<unlhd>"} in Small- and BigStep *}

lemma red_hext_incr: "P,E \<turnstile> \<langle>e,(h,l)\<rangle> \<rightarrow> \<langle>e',(h',l')\<rangle>  \<Longrightarrow> h \<unlhd> h'"
  and reds_hext_incr: "P,E \<turnstile> \<langle>es,(h,l)\<rangle> [\<rightarrow>] \<langle>es',(h',l')\<rangle>  \<Longrightarrow> h \<unlhd> h'"

proof(induct rule:red_reds_inducts)
  case RedNew thus ?case
    by(fastforce dest:new_Addr_SomeD simp:hext_def split:if_splits)
next
  case RedFAss thus ?case by(simp add:hext_def split:if_splits)
qed simp_all

lemma step_hext_incr: "P,E \<turnstile> \<langle>e,s\<rangle> \<rightarrow>* \<langle>e',s'\<rangle>  \<Longrightarrow> hp s \<unlhd> hp s'"

proof(induct rule:converse_rtrancl_induct2)
  case refl thus ?case by(rule hext_refl)
next
  case (step e s e'' s'')
  have Red:"((e, s), e'', s'') \<in> Red P E"
    and hext:"hp s'' \<unlhd> hp s'" by fact+
  from Red have "P,E \<turnstile> \<langle>e,s\<rangle> \<rightarrow> \<langle>e'',s''\<rangle>" by simp
  hence "hp s \<unlhd> hp s''"
    by(cases s,cases s'')(auto dest:red_hext_incr)
  with hext show ?case by-(rule hext_trans)
qed

lemma steps_hext_incr: "P,E \<turnstile> \<langle>es,s\<rangle> [\<rightarrow>]* \<langle>es',s'\<rangle>  \<Longrightarrow> hp s \<unlhd> hp s'"

proof(induct rule:converse_rtrancl_induct2)
  case refl thus ?case by(rule hext_refl)
next
  case (step es s es'' s'')
  have Reds:"((es, s), es'', s'') \<in> Reds P E"
    and hext:"hp s'' \<unlhd> hp s'" by fact+
  from Reds have "P,E \<turnstile> \<langle>es,s\<rangle> [\<rightarrow>] \<langle>es'',s''\<rangle>" by simp
  hence "hp s \<unlhd> hp s''"
    by(cases s,cases s'',auto dest:reds_hext_incr)
  with hext show ?case by-(rule hext_trans)
qed

lemma eval_hext: "P,E \<turnstile> \<langle>e,(h,l)\<rangle> \<Rightarrow> \<langle>e',(h',l')\<rangle> \<Longrightarrow> h \<unlhd> h'"
and evals_hext:  "P,E \<turnstile> \<langle>es,(h,l)\<rangle> [\<Rightarrow>] \<langle>es',(h',l')\<rangle> \<Longrightarrow> h \<unlhd> h'"

proof (induct rule:eval_evals_inducts)
  case New thus ?case
    by(fastforce intro!: hext_new intro:someI simp:new_Addr_def
                split:split_if_asm simp del:fun_upd_apply)
next
  case FAss thus ?case
    by(auto simp:sym[THEN hext_upd_obj] simp del:fun_upd_apply
            elim!: hext_trans)
qed (auto elim!: hext_trans)

section {* @{text"\<unlhd>"} and conformance *}

lemma conf_hext: "h \<unlhd> h' \<Longrightarrow> P,h \<turnstile> v :\<le> T \<Longrightarrow> P,h' \<turnstile> v :\<le> T"
by(cases T)(induct v,auto dest: hext_objD split:split_if_asm)+

lemma confs_hext: "P,h \<turnstile> vs [:\<le>] Ts \<Longrightarrow> h \<unlhd> h' \<Longrightarrow> P,h' \<turnstile> vs [:\<le>] Ts"
by (erule list_all2_mono, erule conf_hext, assumption)

lemma fconf_hext: "\<lbrakk> P,h \<turnstile> fs (:\<le>) E; h \<unlhd> h' \<rbrakk> \<Longrightarrow> P,h' \<turnstile> fs (:\<le>) E"

apply (unfold fconf_def)
apply  (fast elim: conf_hext)
done

lemmas fconf_upd_obj = fconf_hext [OF _ hext_upd_obj]
lemmas fconf_new = fconf_hext [OF _ hext_new]

lemma oconf_hext: "P,h \<turnstile> obj \<surd> \<Longrightarrow> h \<unlhd> h' \<Longrightarrow> P,h' \<turnstile> obj \<surd>"

apply (auto simp:oconf_def)
apply (erule allE)
apply (erule_tac x="Cs" in allE)
apply (erule_tac x="fs'" in allE)
apply (fastforce elim:fconf_hext)
done

lemmas oconf_new = oconf_hext [OF _ hext_new]
lemmas oconf_upd_obj = oconf_hext [OF _ hext_upd_obj]

lemma hconf_new: "\<lbrakk> P \<turnstile> h \<surd>; h a = None; P,h \<turnstile> obj \<surd> \<rbrakk> \<Longrightarrow> P \<turnstile> h(a\<mapsto>obj) \<surd>"
by (unfold hconf_def) (auto intro: oconf_new preallocated_new)

lemma "\<lbrakk>P \<turnstile> h \<surd>; h' = h(a \<mapsto> (C, Collect (init_obj P C))); h a = None; wf_prog wf_md P\<rbrakk>
  \<Longrightarrow> P \<turnstile> h' \<surd>"
apply (simp add:hconf_def oconf_def)
apply auto
     apply (rule_tac x="init_class_fieldmap P (last Cs)" in exI)
     apply (rule init_obj.intros)
     apply assumption
    apply (erule init_obj.cases)
    apply clarsimp
    apply (erule init_obj.cases)
    apply clarsimp
   apply (erule_tac x="a" in allE)
   apply clarsimp
   apply (erule init_obj.cases)
   apply simp
  apply (erule_tac x="a" in allE)
  apply clarsimp
  apply (erule init_obj.cases)
  apply clarsimp
  apply (drule Subobj_last_isClass)
   apply simp
  apply (auto simp:is_class_def)
  apply (rule fconf_init_fields)
  apply auto
 apply (erule_tac x="aa" in allE)
 apply (erule_tac x="aaa" in allE)
 apply (erule_tac x="b" in allE)
 apply clarsimp
 apply (rotate_tac -1)
 apply (erule_tac x="Cs" in allE)
 apply (erule_tac x="fs'" in allE)
 apply clarsimp thm fconf_new
 apply (erule fconf_new)
 apply simp
apply (rule preallocated_new)
apply simp_all
done

lemma hconf_upd_obj:
"\<lbrakk> P \<turnstile> h\<surd>; h a = Some(C,S); P,h \<turnstile> (C,S')\<surd> \<rbrakk> \<Longrightarrow> P \<turnstile> h(a\<mapsto>(C,S'))\<surd>"
by (unfold hconf_def) (auto intro: oconf_upd_obj preallocated_upd_obj)

lemma lconf_hext: "\<lbrakk> P,h \<turnstile> l (:\<le>)\<^sub>w E; h \<unlhd> h' \<rbrakk> \<Longrightarrow> P,h' \<turnstile> l (:\<le>)\<^sub>w E"

apply (unfold lconf_def)
apply  (fast elim: conf_hext)
done

section {* @{text"\<unlhd>"} in the runtime type system *}

lemma hext_typeof_mono: "\<lbrakk> h \<unlhd> h'; P \<turnstile> typeof\<^bsub>h\<^esub> v = Some T \<rbrakk> \<Longrightarrow> P \<turnstile> typeof\<^bsub>h'\<^esub> v = Some T"

apply(cases v)
    apply simp
   apply simp
  apply simp
 apply simp
apply(fastforce simp:hext_def)
done

lemma WTrt_hext_mono: "P,E,h \<turnstile> e : T \<Longrightarrow> (\<And>h'. h \<unlhd> h' \<Longrightarrow> P,E,h' \<turnstile> e : T)"
and WTrts_hext_mono: "P,E,h \<turnstile> es [:] Ts \<Longrightarrow> (\<And>h'. h \<unlhd> h' \<Longrightarrow> P,E,h' \<turnstile> es [:] Ts)"

apply(induct rule: WTrt_inducts)
apply(simp add: WTrtNew)
apply(fastforce intro: WTrtDynCast)
apply(fastforce intro: WTrtStaticCast)
apply(fastforce simp: WTrtVal dest:hext_typeof_mono)
apply(simp add: WTrtVar)
apply(fastforce simp add: WTrtBinOp)
apply(fastforce simp add: WTrtLAss)
apply(fastforce simp: WTrtFAcc del:WTrt_WTrts.intros WTrt_elim_cases)
apply(simp add: WTrtFAccNT)
apply(fastforce simp: WTrtFAss del:WTrt_WTrts.intros WTrt_elim_cases)
apply(fastforce simp: WTrtFAssNT del:WTrt_WTrts.intros WTrt_elim_cases)
apply(fastforce simp: WTrtCall del:WTrt_WTrts.intros WTrt_elim_cases)
apply(fastforce simp: WTrtStaticCall del:WTrt_WTrts.intros WTrt_elim_cases)
apply(fastforce simp: WTrtCallNT del:WTrt_WTrts.intros WTrt_elim_cases)
apply(fastforce)
apply(fastforce simp add: WTrtSeq)
apply(fastforce simp add: WTrtCond)
apply(fastforce simp add: WTrtWhile)
apply(fastforce simp add: WTrtThrow)
apply(simp add: WTrtNil)
apply(simp add: WTrtCons)
done

end


(*  Title:      SSA_CFG.thy
    Author:     Sebastian Ullrich, Denis Lohner
*)

theory SSA_CFG
imports Graph_path "HOL-Library.Sublist"
begin

subsection \<open>CFG\<close>

locale CFG_base = graph_Entry_base \<alpha>e \<alpha>n invar inEdges' Entry
for
  \<alpha>e :: "'g \<Rightarrow> ('node::linorder \<times> 'edgeD \<times> 'node) set" and
  \<alpha>n :: "'g \<Rightarrow> 'node list" and
  invar :: "'g \<Rightarrow> bool" and
  inEdges' :: "'g \<Rightarrow> 'node \<Rightarrow> ('node \<times> 'edgeD) list" and
  Entry :: "'g \<Rightarrow> 'node" +
fixes "defs" :: "'g \<Rightarrow> 'node \<Rightarrow> 'var::linorder set"
fixes "uses" :: "'g \<Rightarrow> 'node \<Rightarrow> 'var set"
begin
  definition "vars g \<equiv> fold (\<union>) (map (uses g) (\<alpha>n g)) {}"
  definition defAss' :: "'g \<Rightarrow> 'node \<Rightarrow> 'var \<Rightarrow> bool" where
    "defAss' g m v \<longleftrightarrow> (\<forall>ns. g \<turnstile> Entry g-ns\<rightarrow>m \<longrightarrow> (\<exists>n \<in> set ns. v \<in> defs g n))"

  definition defAss'Uses :: "'g \<Rightarrow> bool" where
    "defAss'Uses g \<equiv> \<forall>m \<in> set (\<alpha>n g). \<forall>v \<in> uses g m. defAss' g m v"
end

locale CFG = CFG_base \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses"
+ graph_Entry \<alpha>e \<alpha>n invar inEdges' Entry
for
  \<alpha>e :: "'g \<Rightarrow> ('node::linorder \<times> 'edgeD \<times> 'node) set" and
  \<alpha>n :: "'g \<Rightarrow> 'node list" and
  invar :: "'g \<Rightarrow> bool" and
  inEdges' :: "'g \<Rightarrow> 'node \<Rightarrow> ('node \<times> 'edgeD) list" and
  Entry :: "'g \<Rightarrow> 'node" and
  "defs" :: "'g \<Rightarrow> 'node \<Rightarrow> 'var::linorder set" and
  "uses" :: "'g \<Rightarrow> 'node \<Rightarrow> 'var set" +
assumes defs_uses_disjoint: "n \<in> set (\<alpha>n g) \<Longrightarrow> defs g n \<inter> uses g n = {}"
assumes defs_finite[simp]: "finite (defs g n)"
assumes uses_in_\<alpha>n: "v \<in> uses g n \<Longrightarrow> n \<in> set (\<alpha>n g)"
assumes uses_finite[simp, intro!]: "finite (uses g n)"
assumes invar[intro!]: "invar g"
begin
  lemma vars_finite[simp]: "finite (vars g)"
  by (auto simp:vars_def)

  lemma Entry_no_predecessor[simp]: "predecessors g (Entry g) = []"
  using Entry_unreachable
  by (auto simp:predecessors_def)

  lemma uses_in_vars[elim, simp]: "v \<in> uses g n \<Longrightarrow>  v \<in> vars g"
  by (auto simp add:vars_def uses_in_\<alpha>n intro!: fold_union_elemI)

  lemma varsE:
    assumes "v \<in> vars g"
    obtains n where "n \<in> set (\<alpha>n g)" "v \<in> uses g n"
  using assms by (auto simp:vars_def elim!:fold_union_elem)

  lemma defs_uses_disjoint'[simp]: "n \<in> set (\<alpha>n g) \<Longrightarrow> v \<in> defs g n \<Longrightarrow> v \<in> uses g n \<Longrightarrow> False"
  using defs_uses_disjoint by auto
end

context CFG
begin
  lemma defAss'E:
    assumes "defAss' g m v" "g \<turnstile> Entry g-ns\<rightarrow>m"
    obtains n where "n \<in> set ns" "v \<in> defs g n"
  using assms unfolding defAss'_def by auto

  lemmas defAss'I = defAss'_def[THEN iffD2, rule_format]

  lemma defAss'_extend:
    assumes "defAss' g m v"
    assumes "g \<turnstile> n-ns\<rightarrow>m" "\<forall>n \<in> set (tl ns). v \<notin> defs g n"
    shows "defAss' g n v"
  unfolding defAss'_def proof (rule allI, rule impI)
    fix ns'
    assume "g \<turnstile> Entry g-ns'\<rightarrow>n"
    with assms(2) have "g \<turnstile> Entry g-ns'@tl ns\<rightarrow>m" by auto
    with assms(1) obtain n' where n': "n' \<in> set (ns'@tl ns)" "v \<in> defs g n'" by -(erule defAss'E)
    with assms(3) have "n' \<notin> set (tl ns)" by auto
    with n' show "\<exists>n \<in> set ns'. v \<in> defs g n" by auto
  qed
end

text \<open>A CFG is well-formed if it satisfies definite assignment.\<close>

locale CFG_wf = CFG \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses"
for
  \<alpha>e :: "'g \<Rightarrow> ('node::linorder \<times> 'edgeD \<times> 'node) set" and
  \<alpha>n :: "'g \<Rightarrow> 'node list" and
  invar :: "'g \<Rightarrow> bool" and
  inEdges' :: "'g \<Rightarrow> 'node \<Rightarrow> ('node \<times> 'edgeD) list" and
  Entry::"'g \<Rightarrow> 'node" and
  "defs" :: "'g \<Rightarrow> 'node \<Rightarrow> 'var::linorder set" and
  "uses" :: "'g \<Rightarrow> 'node \<Rightarrow> 'var set" +
assumes def_ass_uses: "\<forall>m \<in> set (\<alpha>n g). \<forall>v \<in> uses g m. defAss' g m v"

subsection \<open>SSA CFG\<close>

type_synonym ('node, 'val) phis = "'node \<times> 'val \<rightharpoonup> 'val list"

declare in_set_zipE[elim]
declare zip_same[simp]

locale CFG_SSA_base = CFG_base \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses"
for
  \<alpha>e :: "'g \<Rightarrow> ('node::linorder \<times> 'edgeD \<times> 'node) set" and
  \<alpha>n :: "'g \<Rightarrow> 'node list" and
  invar :: "'g \<Rightarrow> bool" and
  inEdges' :: "'g \<Rightarrow> 'node \<Rightarrow> ('node \<times> 'edgeD) list" and
  Entry::"'g \<Rightarrow> 'node" and
  "defs" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val::linorder set" and
  "uses" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val set" +
fixes phis :: "'g \<Rightarrow> ('node, 'val) phis"
begin
  definition "phiDefs g n \<equiv> {v. (n,v) \<in> dom (phis g)}"
  definition[code]: "allDefs g n \<equiv> defs g n \<union> phiDefs g n"

  definition[code]: "phiUses g n \<equiv>
    \<Union>n' \<in> set (successors g n). \<Union>v' \<in> phiDefs g n'. snd ` Set.filter (\<lambda>(n'',v). n'' = n) (set (zip (predecessors g n') (the (phis g (n',v')))))"
  definition[code]: "allUses g n \<equiv> uses g n \<union> phiUses g n"
  definition[code]: "allVars g \<equiv> \<Union>n \<in> set (\<alpha>n g). allDefs g n \<union> allUses g n"

  definition defAss :: "'g \<Rightarrow> 'node \<Rightarrow> 'val \<Rightarrow> bool" where
    "defAss g m v \<longleftrightarrow> (\<forall>ns. g \<turnstile> Entry g-ns\<rightarrow>m \<longrightarrow> (\<exists>n \<in> set ns. v \<in> allDefs g n))"

  lemmas CFG_SSA_defs = phiDefs_def allDefs_def phiUses_def allUses_def allVars_def defAss_def
end

locale CFG_SSA = CFG \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses" + CFG_SSA_base \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses" phis
for
  \<alpha>e :: "'g \<Rightarrow> ('node::linorder \<times> 'edgeD \<times> 'node) set" and
  \<alpha>n :: "'g \<Rightarrow> 'node list" and
  invar :: "'g \<Rightarrow> bool" and
  inEdges' :: "'g \<Rightarrow> 'node \<Rightarrow> ('node \<times> 'edgeD) list" and
  Entry::"'g \<Rightarrow> 'node" and
  "defs" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val::linorder set" and
  "uses" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val set" and
   phis :: "'g \<Rightarrow> ('node, 'val) phis" +
assumes phis_finite: "finite (dom (phis g))"
assumes phis_in_\<alpha>n: "phis g (n,v) = Some vs \<Longrightarrow> n \<in> set (\<alpha>n g)"
assumes phis_wf:
  "phis g (n,v) = Some args \<Longrightarrow> length (predecessors g n) = length args"
assumes simpleDefs_phiDefs_disjoint:
  "n \<in> set (\<alpha>n g) \<Longrightarrow> defs g n \<inter> phiDefs g n = {}"
assumes allDefs_disjoint:
  "\<lbrakk>n \<in> set (\<alpha>n g); m \<in> set (\<alpha>n g); n \<noteq> m\<rbrakk> \<Longrightarrow> allDefs g n \<inter> allDefs g m = {}"
begin
  lemma phis_disj:
    assumes "phis g (n,v) = Some vs"
    and "phis g (n',v) = Some vs'"
    shows "n = n'" and "vs = vs'"
  proof -
    from assms have "n \<in> set (\<alpha>n g)" and "n' \<in> set (\<alpha>n g)"
      by (auto dest: phis_in_\<alpha>n)
    from allDefs_disjoint [OF this] assms show "n = n'"
      by (auto simp: allDefs_def phiDefs_def)
    with assms show "vs = vs'" by simp
  qed

  lemma allDefs_disjoint': "\<lbrakk>n \<in> set (\<alpha>n g); m \<in> set (\<alpha>n g); v \<in> allDefs g n; v \<in> allDefs g m\<rbrakk> \<Longrightarrow> n = m"
  using allDefs_disjoint by auto

  lemma phiUsesI:
    assumes "n' \<in> set (\<alpha>n g)" "phis g (n',v') = Some vs" "(n,v) \<in> set (zip (predecessors g n') vs)"
    shows "v \<in> phiUses g n"
  proof-
    from assms(3) have "n \<in> set (predecessors g n')" by auto
    hence 1: "n' \<in> set (successors g n)" using assms(1) by simp
    from assms(2) have 2: "v' \<in> phiDefs g n'" by (auto simp add:phiDefs_def)
    from assms(2) have 3: "the (phis g (n',v')) = vs" by simp
    show ?thesis unfolding phiUses_def by (rule UN_I[OF 1], rule UN_I[OF 2], auto simp:image_def Set.filter_def assms(3) 3)
  qed

  lemma phiUsesE:
    assumes "v \<in> phiUses g n"
    obtains  n' v' vs where "n' \<in> set (successors g n)" "(n,v) \<in> set (zip (predecessors g n') vs)" "phis g (n', v') = Some vs"
  proof-
    from assms(1) obtain n' v' where "n'\<in>set (successors g n)" "v'\<in>phiDefs g n'"
      "v \<in> snd ` Set.filter (\<lambda>(n'', v). n'' = n) (set (zip (predecessors g n') (the (phis g (n', v')))))" by (auto simp:phiUses_def)
    thus ?thesis by - (rule that[of n' "the (phis g (n',v'))" v'], auto simp:phiDefs_def)
  qed

  lemma defs_in_allDefs[simp]: "v \<in> defs g n \<Longrightarrow> v \<in> allDefs g n" by (simp add:allDefs_def)
  lemma phiDefs_in_allDefs[simp, elim]: "v \<in> phiDefs g n \<Longrightarrow> v \<in> allDefs g n" by (simp add:allDefs_def)

  lemma phiDefs_finite[simp]: "finite (phiDefs g n)"
  unfolding phiDefs_def
  proof (rule finite_surj[where f=snd], rule phis_finite[where g=g])
    have "\<And>x y. phis g (n,x) = Some y \<Longrightarrow> x \<in> snd ` dom (phis g)" by (metis domI imageI snd_conv)
    thus "{v. (n, v) \<in> dom (phis g)} \<subseteq> snd ` dom (phis g)" by auto
  qed

  lemma phiUses_finite[simp]:
    assumes "n \<in> set (\<alpha>n g)"
    shows "finite (phiUses g n)"
  by (auto simp:phiUses_def Set.filter_def)

  lemma allDefs_finite[simp]: "n \<in> set (\<alpha>n g) \<Longrightarrow> finite (allDefs g n)" by (auto simp add:allDefs_def)
  lemma allUses_finite[simp]: "n \<in> set (\<alpha>n g) \<Longrightarrow> finite (allUses g n)" by (auto simp add:allUses_def)
  lemma allVars_finite[simp]: "finite (allVars g)" by (auto simp add:allVars_def)

  lemmas defAssI = defAss_def[THEN iffD2, rule_format]
  lemmas defAssD = defAss_def[THEN iffD1, rule_format]

  lemma defAss_extend:
    assumes "defAss g m v"
    assumes "g \<turnstile> n-ns\<rightarrow>m" "\<forall>n \<in> set (tl ns). v \<notin> allDefs g n"
    shows "defAss g n v"
  unfolding defAss_def proof (rule allI, rule impI)
    fix ns'
    assume "g \<turnstile> Entry g-ns'\<rightarrow>n"
    with assms(2) have "g \<turnstile> Entry g-ns'@tl ns\<rightarrow>m" by auto
    with assms(1) obtain n' where n': "n' \<in> set (ns'@tl ns)" "v \<in> allDefs g n'" by (auto dest:defAssD)
    with assms(3) have "n' \<notin> set (tl ns)" by auto
    with n' show "\<exists>n \<in> set ns'. v \<in> allDefs g n" by auto
  qed

  lemma defAss_dominating:
    assumes[simp]: "n \<in> set (\<alpha>n g)"
    shows "defAss g n v \<longleftrightarrow> (\<exists>m \<in> set (\<alpha>n g). dominates g m n \<and> v \<in> allDefs g m)"
  proof
    assume asm: "defAss g n v"
    obtain ns where ns: "g \<turnstile> Entry g-ns\<rightarrow>n" by (atomize, auto)
    from defAssD[OF asm this] obtain m where m: "m \<in> set ns" "v \<in> allDefs g m" by auto
    have "dominates g m n"
    proof
      fix ns'
      assume ns': "g \<turnstile> Entry g-ns'\<rightarrow>n"
      from defAssD[OF asm this] obtain m' where m': "m' \<in> set ns'" "v \<in> allDefs g m'" by auto
      with m ns ns' have "m' = m" by - (rule allDefs_disjoint', auto)
      with m' show "m \<in> set ns'" by simp
    qed simp
    with m ns show "\<exists>m\<in>set (\<alpha>n g). dominates g m n \<and> v \<in> allDefs g m" by auto
  next
    assume "\<exists>m \<in> set (\<alpha>n g). dominates g m n \<and> v \<in> allDefs g m"
    then obtain m where[simp]: "m \<in> set (\<alpha>n g)" and m: "dominates g m n" "v \<in> allDefs g m" by auto
    show "defAss g n v"
    proof (rule defAssI)
      fix ns
      assume "g \<turnstile> Entry g-ns\<rightarrow>n"
      with m(1) have "m \<in> set ns" by - (rule dominates_mid, auto)
      with m(2) show "\<exists>n\<in>set ns. v \<in> allDefs g n" by auto
    qed
  qed
end

locale CFG_SSA_wf_base = CFG_SSA_base \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses" phis
for
  \<alpha>e :: "'g \<Rightarrow> ('node::linorder \<times> 'edgeD \<times> 'node) set" and
  \<alpha>n :: "'g \<Rightarrow> 'node list" and
  invar :: "'g \<Rightarrow> bool" and
  inEdges' :: "'g \<Rightarrow> 'node \<Rightarrow> ('node \<times> 'edgeD) list" and
  Entry::"'g \<Rightarrow> 'node" and
  "defs" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val::linorder set" and
  "uses" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val set" and
  phis :: "'g \<Rightarrow> ('node, 'val) phis"
begin
  text \<open>Using the SSA properties, we can map every value to its unique defining node and
    remove the @{typ 'node} parameter of the @{term phis} map.\<close>

  definition defNode :: "'g \<Rightarrow> 'val \<Rightarrow> 'node" where
    defNode_code [code]: "defNode g v \<equiv> hd [n \<leftarrow> \<alpha>n g. v \<in> allDefs g n]"

  abbreviation "def_dominates g v' v \<equiv> dominates g (defNode g v') (defNode g v)"
  abbreviation "strict_def_dom g v' v \<equiv> defNode g v' \<noteq> defNode g v \<and> def_dominates g v' v"

  definition "phi g v = phis g (defNode g v,v)"
  definition[simp]: "phiArg g v v' \<equiv> \<exists>vs. phi g v = Some vs \<and> v' \<in> set vs"

  definition[code]: "isTrivialPhi g v v' \<longleftrightarrow> v' \<noteq> v \<and>
    (case phi g v of
      Some vs \<Rightarrow> set vs = {v,v'} \<or> set vs = {v'}
    | None \<Rightarrow> False)"
  definition[code]: "trivial g v \<equiv> \<exists>v' \<in> allVars g. isTrivialPhi g v v'"
  definition[code]: "redundant g \<equiv> \<exists>v \<in> allVars g. trivial g v"

  definition "defAssUses g \<equiv> \<forall>n \<in> set (\<alpha>n g). \<forall>v \<in> allUses g n. defAss g n v"

  text \<open>'liveness' of an SSA value is defined inductively starting from simple uses so that
    a circle of \pf s is not considered live.\<close>

  declare [[inductive_internals]]
  inductive liveVal :: "'g \<Rightarrow> 'val \<Rightarrow> bool"
    for g :: 'g
  where
    liveSimple: "\<lbrakk>n \<in> set (\<alpha>n g); val \<in> uses g n\<rbrakk> \<Longrightarrow> liveVal g val"
  | livePhi: "\<lbrakk>liveVal g v; phiArg g v v'\<rbrakk> \<Longrightarrow> liveVal g v'"

  definition "pruned g = (\<forall>n \<in> set (\<alpha>n g). \<forall>val. val \<in> phiDefs g n \<longrightarrow> liveVal g val)"

  lemmas "CFG_SSA_wf_defs" = CFG_SSA_defs defNode_code phi_def isTrivialPhi_def trivial_def redundant_def liveVal_def pruned_def
end

locale CFG_SSA_wf = CFG_SSA \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses" phis + CFG_SSA_wf_base \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses" phis
for
  \<alpha>e :: "'g \<Rightarrow> ('node::linorder \<times> 'edgeD \<times> 'node) set" and
  \<alpha>n :: "'g \<Rightarrow> 'node list" and
  invar :: "'g \<Rightarrow> bool" and
  inEdges' :: "'g \<Rightarrow> 'node \<Rightarrow> ('node \<times> 'edgeD) list" and
  Entry::"'g \<Rightarrow> 'node" and
  "defs" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val::linorder set" and
  "uses" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val set" and
  phis :: "'g \<Rightarrow> ('node, 'val) phis" +
  assumes allUses_def_ass: "\<lbrakk>v \<in> allUses g n; n \<in> set (\<alpha>n g)\<rbrakk> \<Longrightarrow> defAss g n v"
  assumes Entry_no_phis[simp]: "phis g (Entry g,v) = None"
begin
  lemma allVars_in_allDefs: "v \<in> allVars g \<Longrightarrow> \<exists>n \<in> set (\<alpha>n g). v \<in> allDefs g n"
    unfolding allVars_def
  apply auto
  apply (drule(1) allUses_def_ass)
  apply (clarsimp simp: defAss_def)
  apply (drule Entry_reaches)
   apply auto[1]
  by fastforce

  lemma phiDefs_Entry_empty[simp]: "phiDefs g (Entry g) = {}"
  by (auto simp: phiDefs_def)

  lemma phi_Entry_empty[simp]: "defNode g v = Entry g \<Longrightarrow> phi g v = None"
    by (simp add:phi_def)

  lemma defNode_ex1:
    assumes "v \<in> allVars g"
    shows "\<exists>!n. n \<in> set (\<alpha>n g) \<and> v \<in> allDefs g n"
  proof (rule ex_ex1I)
    show "\<exists>n. n \<in> set (\<alpha>n g) \<and> v \<in> allDefs g n"
    proof-
      from assms(1) obtain n where n: "n \<in> set (\<alpha>n g)" "v \<in> allDefs g n \<or> v \<in> allUses g n" by (auto simp:allVars_def)
      thus ?thesis
      proof (cases "v \<in> allUses g n")
        case True
        from n(1) obtain ns where ns: "g \<turnstile> Entry g-ns\<rightarrow>n" by (atomize_elim, rule Entry_reaches, auto)
        with allUses_def_ass[OF True n(1)] obtain m where m: "m \<in> set ns" "v \<in> allDefs g m" by - (drule defAssD, auto)
        from ns this(1) have "m \<in> set (\<alpha>n g)" by (rule path2_in_\<alpha>n)
        with n(1) m show ?thesis by auto
      qed auto
    qed
    show "\<And>n m. n \<in> set (\<alpha>n g) \<and> v \<in> allDefs g n \<Longrightarrow> m \<in> set (\<alpha>n g) \<and> v \<in> allDefs g m \<Longrightarrow> n = m" using allDefs_disjoint by auto
  qed

  lemma defNode_def: "v \<in> allVars g \<Longrightarrow> defNode g v = (THE n. n \<in> set (\<alpha>n g) \<and> v \<in> allDefs g n)"
  unfolding defNode_code by (rule the1_list[symmetric], rule defNode_ex1)

  lemma defNode[simp]:
    assumes "v \<in> allVars g"
    shows  "(defNode g v) \<in> set (\<alpha>n g)" "v \<in> allDefs g (defNode g v)"
  apply (atomize(full))
  unfolding defNode_def[OF assms] using assms
  by - (rule theI', rule defNode_ex1)

  lemma defNode_eq[intro]:
    assumes "n \<in> set (\<alpha>n g)" "v \<in> allDefs g n"
    shows "defNode g v = n"
  apply (subst defNode_def, rule allDefs_in_allVars[OF assms(2) assms(1)])
  by (rule the1_equality, rule defNode_ex1, rule allDefs_in_allVars[where n=n], simp_all add:assms)

  lemma defNode_cases[consumes 1]:
    assumes "v \<in> allVars g"
    obtains (simpleDef) "v \<in> defs g (defNode g v)"
          | (phi)       "phi g v \<noteq> None"
  proof (cases "v \<in> defs g (defNode g v)")
    case True
    thus thesis by (rule simpleDef)
  next
    case False
    with assms[THEN defNode(2)] show thesis
      by - (rule phi, auto simp: allDefs_def phiDefs_def phi_def)
  qed

  lemma phi_phiDefs[simp]: "phi g v = Some vs \<Longrightarrow> v \<in> phiDefs g (defNode g v)" by (auto simp:phiDefs_def phi_def)

  lemma simpleDef_not_phi:
    assumes "n \<in> set (\<alpha>n g)" "v \<in> defs g n"
    shows "phi g v = None"
  proof-
    from assms have "defNode g v = n" by auto
    with assms show ?thesis using simpleDefs_phiDefs_disjoint by (auto simp: phi_def phiDefs_def)
  qed

  lemma phi_wf: "phi g v = Some vs \<Longrightarrow> length (predecessors g (defNode g v)) = length vs"
  by (rule phis_wf) (simp add:phi_def)

  lemma phi_finite: "finite (dom (phi g))"
  proof-
    let ?f = "\<lambda>v. (defNode g v,v)"
    have "phi g = phis g \<circ> ?f" by (auto simp add:phi_def)
    moreover have "inj ?f" by (auto intro:injI)
    hence "finite (dom (phis g \<circ> ?f))" by - (rule finite_dom_comp, auto simp add:phis_finite inj_on_def)
    ultimately show ?thesis by simp
  qed

  lemma phiUses_exI:
    assumes "m \<in> set (predecessors g n)" "phis g (n,v) = Some vs" "n \<in> set (\<alpha>n g)"
    obtains v' where "v' \<in> phiUses g m" "v' \<in> set vs"
  proof-
    from assms(1) obtain i where i: "m = predecessors g n ! i" "i < length (predecessors g n)" by (metis in_set_conv_nth)
    with assms(2) phis_wf have[simp]: "i < length vs" by (auto simp add:phi_def)
    from i assms(2,3) have "vs ! i \<in> phiUses g m" by - (rule phiUsesI, auto simp add:phiUses_def phi_def set_zip)
    thus thesis by (rule that) (auto simp add:i(2) phis_wf)
  qed

  lemma phiArg_exI:
    assumes "m \<in> set (predecessors g (defNode g v))" "phi g v \<noteq> None" and[simp]: "v \<in> allVars g"
    obtains v' where "v' \<in> phiUses g m" "phiArg g v v'"
  proof-
    from assms(2) obtain vs where "phi g v = Some vs" by auto
    with assms(1) show thesis
      by - (rule phiUses_exI, auto intro!:that simp: phi_def)
  qed

  lemma phiUses_exI':
    assumes "phiArg g p q" and[simp]: "p \<in> allVars g"
    obtains m where "q \<in> phiUses g m" "m \<in> set (predecessors g (defNode g p))"
  proof-
    let ?n = "defNode g p"
    from assms(1) obtain i vs where vs: "phi g p = Some vs" and i: "q = vs ! i" "i < length vs" by (metis in_set_conv_nth phiArg_def)
    with phis_wf have[simp]: "i < length (predecessors g ?n)" by (auto simp add:phi_def)
    from vs i have "q \<in> phiUses g (predecessors g ?n ! i)" by - (rule phiUsesI, auto simp add:phiUses_def phi_def set_zip)
    thus thesis by (rule that) (auto simp add:i(2) phis_wf)
  qed

  lemma phiArg_in_allVars[simp]:
    assumes "phiArg g v v'"
    shows "v' \<in> allVars g"
  proof-
    let ?n = "defNode g v"
    from assms(1) obtain vs where vs: "phi g v = Some vs" "v' \<in> set vs" by auto
    then obtain m where m: "(m,v') \<in> set (zip (predecessors g ?n) vs)" by - (rule set_zip_leftI, rule phi_wf)
    from vs(1) have n: "?n \<in> set (\<alpha>n g)" by (simp add: phi_def phis_in_\<alpha>n)
    with m have[simp]: "m \<in> set (\<alpha>n g)" by auto
    from n m vs have "v' \<in> phiUses g m" by - (rule phiUsesI, simp_all add:phi_def)
    thus ?thesis by - (rule allUses_in_allVars, auto simp:allUses_def)
  qed

  lemma defAss_defNode:
    assumes "defAss g m v" "v \<in> allVars g" "g \<turnstile> Entry g-ns\<rightarrow>m"
    shows "defNode g v \<in> set ns"
  proof-
    from assms obtain n where n: "n \<in> set ns" "v \<in> allDefs g n" by (auto simp:defAss_def)
    with assms(3) have "n = defNode g v" by - (rule defNode_eq[symmetric], auto)
    with n show "defNode g v \<in> set ns" by (simp add:defAss_def)
  qed

  lemma defUse_path_ex:
    assumes "v \<in> allUses g m" "m \<in> set (\<alpha>n g)"
    obtains ns where "g \<turnstile> defNode g v-ns\<rightarrow>m" "EntryPath g ns"
  proof-
    from assms have "defAss g m v" by - (rule allUses_def_ass, auto)
    moreover from assms obtain ns where ns: "g \<turnstile> Entry g-ns\<rightarrow>m" "EntryPath g ns"
      by - (atomize_elim, rule Entry_reachesE, auto)
    ultimately have "defNode g v \<in> set ns" using assms(1)
      by - (rule defAss_defNode, auto)
    with ns(1) obtain ns' where "g \<turnstile> defNode g v-ns'\<rightarrow>m" "suffix ns' ns"
      by (rule path2_split_ex', auto simp: Sublist.suffix_def)
    thus thesis using ns(2)
      by - (rule that, assumption, rule EntryPath_suffix, auto)
  qed

  lemma defUse_path_dominated:
    assumes "g \<turnstile> defNode g v-ns\<rightarrow>n" "defNode g v \<notin> set (tl ns)" "v \<in> allUses g n" "n' \<in> set ns"
    shows "dominates g (defNode g v) n'"
  proof (rule dominatesI)
    fix es
    assume asm: "g \<turnstile> Entry g-es\<rightarrow>n'"
    from assms(1,4) obtain ns' where ns': "g \<turnstile> n'-ns'\<rightarrow>n" "suffix ns' ns"
      by - (rule path2_split_ex, auto simp: Sublist.suffix_def)
    from assms have "defAss g n v" by - (rule allUses_def_ass, auto)
    with asm ns'(1) assms(3) have "defNode g v \<in> set (es@tl ns')" by - (rule defAss_defNode, auto)
    with suffix_tl_subset[OF ns'(2)] assms(2) show "defNode g v \<in> set es" by auto
  next
    show "n' \<in> set (\<alpha>n g)" using assms(1,4) by auto
  qed

  lemma allUses_dominated:
    assumes "v \<in> allUses g n" "n \<in> set (\<alpha>n g)"
    shows "dominates g (defNode g v) n"
  proof-
    from assms obtain ns where "g \<turnstile> defNode g v-ns\<rightarrow>n" "defNode g v \<notin> set (tl ns)"
      by - (rule defUse_path_ex, auto elim: simple_path2)
    with assms(1) show ?thesis by - (rule defUse_path_dominated, auto)
  qed

  lemma phiArg_path_ex':
    assumes "phiArg g p q" and[simp]: "p \<in> allVars g"
    obtains ns m where "g \<turnstile> defNode g q-ns\<rightarrow>m" "EntryPath g ns" "q \<in> phiUses g m" "m \<in> set (predecessors g (defNode g p))"
  proof-
    from assms obtain m where m: "q \<in> phiUses g m" "m \<in> set (predecessors g (defNode g p))"
      by (rule phiUses_exI')
    then obtain ns where "g \<turnstile> defNode g q-ns\<rightarrow>m" "EntryPath g ns" by - (rule defUse_path_ex, auto)
    with m show thesis by - (rule that)
  qed

  lemma phiArg_path_ex:
    assumes "phiArg g p q" and[simp]: "p \<in> allVars g"
    obtains ns where "g \<turnstile> defNode g q-ns\<rightarrow>defNode g p" "length ns > 1"
    by (rule phiArg_path_ex'[OF assms], rule, auto)

  lemma phiArg_tranclp_path_ex:
    assumes "r\<^sup>+\<^sup>+ p q" "p \<in> allVars g" and[simp]: "\<And>p q. r p q \<Longrightarrow> phiArg g p q"
    obtains ns where "g \<turnstile> defNode g q-ns\<rightarrow>defNode g p" "length ns > 1"
      "\<forall>n \<in> set (butlast ns). \<exists>p q m ns'. r p q \<and> g \<turnstile> defNode g q-ns'\<rightarrow>m \<and> (defNode g q) \<notin> set (tl ns') \<and> q \<in> phiUses g m \<and> m \<in> set (predecessors g (defNode g p)) \<and> n \<in> set ns' \<and> set ns' \<subseteq> set ns \<and> defNode g p \<in> set ns"
  using assms(1,2) proof (induction rule: converse_tranclp_induct)
    case (base p)
    from base.hyps base.prems(2) obtain ns' m where ns': "g \<turnstile> defNode g q-ns'\<rightarrow>m" "defNode g q \<notin> set (tl ns')" "m \<in> set (predecessors g (defNode g p))" "q \<in> phiUses g m"
      by - (rule phiArg_path_ex', rule assms(3), auto intro: simple_path2)
    hence ns: "g \<turnstile> defNode g q-ns'@[defNode g p]\<rightarrow>defNode g p" "length (ns'@[defNode g p]) > 1" by auto

    show ?case
    proof (rule base.prems(1)[OF ns, rule_format], rule exI, rule exI, rule exI, rule exI)
      fix n
      assume "n \<in> set (butlast (ns' @ [defNode g p]))"
      with base.hyps ns'
      show "r p q \<and>
          g \<turnstile> defNode g q-ns'\<rightarrow>m \<and>
          defNode g q \<notin> set (tl ns') \<and>
          q \<in> phiUses g m \<and>
          m \<in> set (predecessors g (defNode g p)) \<and> n \<in> set ns' \<and> set ns' \<subseteq> set (ns' @ [defNode g p]) \<and> defNode g p \<in> set (ns' @ [defNode g p])"
        by auto
    qed
  next
    case (step p p')
    from step.prems(2) step.hyps(1) obtain ns'\<^sub>2 m where ns'\<^sub>2: "g \<turnstile> defNode g p'-ns'\<^sub>2\<rightarrow>m" "m \<in> set (predecessors g (defNode g p))" "defNode g p' \<notin> set (tl ns'\<^sub>2)" "p' \<in> phiUses g m"
      by - (rule phiArg_path_ex', rule assms(3), auto intro: simple_path2)
    then obtain ns\<^sub>2 where ns\<^sub>2: "g \<turnstile> defNode g p'-ns\<^sub>2\<rightarrow>defNode g p" "length ns\<^sub>2 > 1" "ns\<^sub>2 = ns'\<^sub>2@[defNode g p]" by (atomize_elim, auto)

    show thesis
    proof (rule step.IH)
      fix ns
      assume ns: "g \<turnstile> defNode g q-ns\<rightarrow>defNode g p'" "1 < length ns"
      assume IH: "\<forall>n\<in>set (butlast ns).
             \<exists>p q m ns'.
                r p q \<and>
                g \<turnstile> defNode g q-ns'\<rightarrow>m \<and>
                defNode g q \<notin> set (tl ns') \<and>
                q \<in> phiUses g m \<and> m \<in> set (predecessors g (defNode g p)) \<and> n \<in> set ns' \<and> set ns' \<subseteq> set ns \<and> defNode g p \<in> set ns"

      let ?path = "ns@tl ns\<^sub>2"
      have ns_ns\<^sub>2: "g \<turnstile> defNode g q-?path\<rightarrow>defNode g p" "1 < length ?path" using ns ns\<^sub>2(1,2) by auto
      show thesis
      proof (rule step.prems(1)[OF ns_ns\<^sub>2, rule_format])
        fix n
        assume n: "n \<in> set (butlast ?path)"
        show "\<exists>p q m ns'a.
          r p q \<and>
          g \<turnstile> defNode g q-ns'a\<rightarrow>m \<and>
          defNode g q \<notin> set (tl ns'a) \<and>
          q \<in> phiUses g m \<and> m \<in> set (predecessors g (defNode g p)) \<and> n \<in> set ns'a \<and> set ns'a \<subseteq> set ?path \<and> defNode g p \<in> set ?path"
        proof (cases "n \<in> set (butlast ns)")
          case True
          with IH obtain p q m ns' where "
                r p q \<and>
                g \<turnstile> defNode g q-ns'\<rightarrow>m \<and>
                defNode g q \<notin> set (tl ns') \<and>
                q \<in> phiUses g m \<and> m \<in> set (predecessors g (defNode g p)) \<and> n \<in> set ns' \<and> set ns' \<subseteq> set ns \<and> defNode g p \<in> set ns" by auto
          thus ?thesis by - (rule exI, rule exI, rule exI, rule exI, auto)
        next
          case False
          from ns ns\<^sub>2 have 1: "?path = butlast ns@ns\<^sub>2"
            by - (rule concat_join[symmetric], auto simp: path2_def)
          from ns\<^sub>2(1) n False 1 have "n \<in> set (butlast ns\<^sub>2)" by (auto simp: butlast_append path2_not_Nil)
          with step.hyps ns'\<^sub>2 ns\<^sub>2(3) show ?thesis
            by - (subst 1, rule exI[where x=p], rule exI[where x=p'], rule exI, rule exI, auto simp: path2_not_Nil)
        qed
      qed
    next
      show "p' \<in> allVars g" using step.prems(2) step.hyps(1)[THEN assms(3)] by auto
    qed
  qed

  lemma non_dominated_predecessor:
    assumes "n \<in> set (\<alpha>n g)" "n \<noteq> Entry g"
    obtains m where "m \<in> set (predecessors g n)" "\<not>dominates g n m"
  proof-
    obtain ns where "g \<turnstile> Entry g-ns\<rightarrow>n"
      by (atomize_elim, rule Entry_reaches, auto simp add:assms(1))
    then obtain ns' where ns': "g \<turnstile> Entry g-ns'\<rightarrow>n" "n \<notin> set (butlast ns')"
      by (rule simple_path2)
    let ?m = "last (butlast ns')"
    from ns'(1) assms(2) obtain m: "g \<turnstile> Entry g-butlast ns'\<rightarrow>?m" "?m \<in> set (predecessors g n)"
      by - (rule path2_unsnoc, auto)
    with m(1) ns'(2) show thesis
      by - (rule that, auto elim:dominatesE)
  qed

  lemmas dominates_trans'[trans, elim] = dominates_trans[OF invar]
  lemmas strict_dom_trans'[trans, elim] = strict_dom_trans[OF invar]
  lemmas dominates_refl'[simp] = dominates_refl[OF invar]
  lemmas dominates_antisymm'[dest] = dominates_antisymm[OF invar]

  lemma liveVal_in_allVars[simp]: "liveVal g v \<Longrightarrow> v \<in> allVars g"
  by (induction rule: liveVal.induct, auto intro!: allUses_in_allVars)

  lemma phi_no_closed_loop:
    assumes[simp]: "p \<in> allVars g" and "phi g p = Some vs"
    shows "set vs \<noteq> {p}"
  proof (cases "defNode g p = Entry g")
    case True
    with assms(2) show ?thesis by auto
  next
    case False
    show ?thesis
    proof
      assume[simp]: "set vs = {p}"
      let ?n = "defNode g p"
      obtain ns where ns: "g \<turnstile> Entry g-ns\<rightarrow>?n" "?n \<notin> set (butlast ns)" by (rule simple_Entry_path, auto)
      let ?m = "last (butlast ns)"
      from ns False obtain m: "g \<turnstile> Entry g-butlast ns\<rightarrow>?m" "?m \<in> set (predecessors g ?n)"
        by - (rule path2_unsnoc, auto)
      hence "p \<in> phiUses g ?m" using assms(2) by - (rule phiUses_exI, auto simp:phi_def)
      hence "defAss g ?m p" using m by - (rule allUses_def_ass, auto)
      then obtain l where l: "l \<in> set (butlast ns)" "p \<in> allDefs g l" using m by - (drule defAssD, auto)
      with assms(2) m have "l = ?n" by - (rule allDefs_disjoint', auto)
      with ns l m show False by auto
    qed
  qed

  lemma phis_phi: "phis g (n, v) = Some vs \<Longrightarrow> phi g v = Some vs"
  unfolding phi_def
  apply (subst defNode_eq)
  by (auto simp: allDefs_def phi_def phiDefs_def intro: phis_in_\<alpha>n)

  lemma trivial_phi: "trivial g v \<Longrightarrow> phi g v \<noteq> None"
  by (auto simp: trivial_def isTrivialPhi_def split: option.splits)

  lemma trivial_finite: "finite {v. trivial g v}"
  by (rule finite_subset[OF _ phi_finite]) (auto dest: trivial_phi)

  lemma trivial_in_allVars: "trivial g v \<Longrightarrow> v \<in> allVars g"
  by (drule trivial_phi, auto simp: allDefs_def phiDefs_def image_def phi_def intro: phis_in_\<alpha>n intro!: allDefs_in_allVars)

  declare phiArg_def [simp del]
end

subsection \<open>Bundling of CFG and Equivalent SSA CFG\<close>

locale CFG_SSA_Transformed_base = old: CFG_base \<alpha>e \<alpha>n invar inEdges' Entry oldDefs oldUses + CFG_SSA_wf_base \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses" phis
for
  \<alpha>e :: "'g \<Rightarrow> ('node::linorder \<times> 'edgeD \<times> 'node) set" and
  \<alpha>n :: "'g \<Rightarrow> 'node list" and
  invar :: "'g \<Rightarrow> bool" and
  inEdges' :: "'g \<Rightarrow> 'node \<Rightarrow> ('node \<times> 'edgeD) list" and
  Entry::"'g \<Rightarrow> 'node" and
  oldDefs :: "'g \<Rightarrow> 'node \<Rightarrow> 'var::linorder set" and
  oldUses :: "'g \<Rightarrow> 'node \<Rightarrow> 'var set" and
  "defs" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val::linorder set" and
  "uses" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val set" and
  phis :: "'g \<Rightarrow> ('node, 'val) phis" +
  fixes var :: "'g \<Rightarrow> 'val \<Rightarrow> 'var"

locale CFG_SSA_Transformed = CFG_SSA_Transformed_base \<alpha>e \<alpha>n invar inEdges' Entry oldDefs oldUses "defs" "uses" phis var
  + old: CFG_wf \<alpha>e \<alpha>n invar inEdges' Entry oldDefs oldUses + CFG_SSA_wf \<alpha>e \<alpha>n invar inEdges' Entry "defs" "uses" phis
for
  \<alpha>e :: "'g \<Rightarrow> ('node::linorder \<times> 'edgeD \<times> 'node) set" and
  \<alpha>n :: "'g \<Rightarrow> 'node list" and
  invar :: "'g \<Rightarrow> bool" and
  inEdges' :: "'g \<Rightarrow> 'node \<Rightarrow> ('node \<times> 'edgeD) list" and
  Entry::"'g \<Rightarrow> 'node" and
  oldDefs :: "'g \<Rightarrow> 'node \<Rightarrow> 'var::linorder set" and
  oldUses :: "'g \<Rightarrow> 'node \<Rightarrow> 'var set" and
  "defs" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val::linorder set" and
  "uses" :: "'g \<Rightarrow> 'node \<Rightarrow> 'val set" and
  phis :: "'g \<Rightarrow> ('node, 'val) phis" and
  var :: "'g \<Rightarrow> 'val \<Rightarrow> 'var" +
  assumes oldDefs_def: "oldDefs g n = var g ` defs g n"
  assumes oldUses_def: "n \<in> set (\<alpha>n g) \<Longrightarrow> oldUses g n = var g ` uses g n"
  assumes conventional: "
\<lbrakk>g \<turnstile> n-ns\<rightarrow>m; n \<notin> set (tl ns); v \<in> allDefs g n; v \<in> allUses g m; x \<in> set (tl ns); v' \<in> allDefs g x\<rbrakk> \<Longrightarrow> var g v' \<noteq> var g v"
  assumes phis_same_var[elim]: "phis g (n,v) = Some vs \<Longrightarrow> v' \<in> set vs \<Longrightarrow> var g v' = var g v"
  assumes allDefs_var_disjoint: "\<lbrakk>n \<in> set (\<alpha>n g); v \<in> allDefs g n; v' \<in> allDefs g n; v \<noteq> v'\<rbrakk> \<Longrightarrow> var g v' \<noteq> var g v"
begin
  lemma conventional': "\<lbrakk>g \<turnstile> n-ns\<rightarrow>m; n \<notin> set (tl ns); v \<in> allDefs g n; v \<in> allUses g m; v' \<in> allDefs g x; var g v' = var g v\<rbrakk> \<Longrightarrow> x \<notin> set (tl ns)"
    using conventional by auto

  lemma conventional'': "\<lbrakk>g \<turnstile> defNode g v-ns\<rightarrow>m; defNode g v \<notin> set (tl ns); v \<in> allUses g m; var g v' = var g v; v \<in> allVars g; v' \<in> allVars g\<rbrakk> \<Longrightarrow> defNode g v' \<notin> set (tl ns)"
    by (rule conventional'[where v=v and v'=v'], auto)

  lemma phiArg_same_var: "phiArg g p q \<Longrightarrow> var g q = var g p"
    by (metis phiArg_def phi_def phis_same_var)

  lemma oldDef_defAss:
    assumes "v \<in> allUses g n" "g \<turnstile> Entry g-ns\<rightarrow>n"
    obtains m where "m \<in> set ns" "var g v \<in> oldDefs g m"
  using assms proof (induction ns arbitrary: v n rule: length_induct)
    case (1 ns)
    from "1.prems"(2-) have 2: "defNode g v \<in> set ns"
      by - (rule defAss_defNode, rule allUses_def_ass, auto)
    let ?V = "defNode g v"
    from "1.prems"(2,3) have[simp]: "v \<in> allVars g" by auto
    thus ?case
    proof (cases v rule: defNode_cases)
      case simpleDef
      with 2 show thesis by - (rule "1.prems"(1), auto simp: oldDefs_def)
    next
      case phi
      then obtain vs where vs: "phi g v = Some vs" by auto
      from "1.prems"(3) 2 obtain ns' where ns': "g \<turnstile> Entry g-ns'\<rightarrow>?V" "prefix ns' ns"
        by (rule old.path2_split_ex, auto)
      let ?V' = "last (butlast ns')"
      from ns' phi have nontriv: "length ns' \<ge> 2"
        by - (rule old.path2_nontrivial, auto)
      hence 3: "g \<turnstile> Entry g-butlast ns'\<rightarrow>?V'" "?V' \<in> set (old.predecessors g ?V)"
        using ns'(1) by (auto intro: old.path2_unsnoc)
      with phi vs obtain v' where v': "v' \<in> phiUses g ?V'" "var g v' = var g v"
        by - (rule phiArg_exI, auto simp: phi_def phis_same_var phiArg_def)
      show thesis
      proof (rule "1.IH"[rule_format])
        show "length (butlast ns') < length ns" using ns' by (cases ns', auto simp: old.path2_not_Nil2 dest: prefix_length_le)
        show "v' \<in> allUses g ?V'" using v'(1) by simp
      next
        fix n
        assume "n \<in> set (butlast ns')" "var g v' \<in> oldDefs g n"
        thus thesis
          using ns'(2)[THEN set_mono_prefix] v'(2) by - (rule "1.prems"(1)[of n], auto dest: in_set_butlastD)
      qed (rule 3(1))
    qed
  qed

  lemma allDef_path_from_simpleDef:
    assumes[simp]: "v \<in> allVars g"
    obtains n ns where "g \<turnstile> n-ns\<rightarrow>defNode g v" "old.EntryPath g ns" "var g v \<in> oldDefs g n"
  proof-
    let ?V = "defNode g v"
    from assms obtain ns where ns: "g \<turnstile> Entry g-ns\<rightarrow>?V" "old.EntryPath g ns"
      by - (rule old.Entry_reachesE, auto)
    from assms show thesis
    proof (cases v rule: defNode_cases)
      case simpleDef
      thus thesis by - (rule that, auto simp: oldDefs_def)
    next
      case phi
      then obtain vs where vs: "phi g v = Some vs" by auto
      let ?V' = "last (butlast ns)"
      from ns phi have nontriv: "length ns \<ge> 2"
        by - (rule old.path2_nontrivial, auto)
      hence 3: "g \<turnstile> Entry g-butlast ns\<rightarrow>?V'" "?V' \<in> set (old.predecessors g ?V)"
        using ns(1) by (auto intro: old.path2_unsnoc)
      with phi vs obtain v' where v': "v' \<in> phiUses g ?V'" "var g v' = var g v"
        by - (rule phiArg_exI, auto simp: phi_def phis_same_var phiArg_def)
      with 3(1) obtain n where n: "n \<in> set (butlast ns)" "var g v' \<in> oldDefs g n"
        by - (rule oldDef_defAss[of v' g], auto)
      with ns obtain ns' where "g \<turnstile> n-ns'\<rightarrow>?V" "suffix ns' ns"
        by - (rule old.path2_split_ex'[OF ns(1)], auto intro: in_set_butlastD simp: Sublist.suffix_def)
      with n(2) v'(2) ns(2) show thesis
        by - (rule that, assumption, erule old.EntryPath_suffix, auto)
    qed
  qed

  lemma defNode_var_disjoint:
    assumes "p \<in> allVars g" "q \<in> allVars g" "p \<noteq> q" "defNode g p = defNode g q"
    shows "var g p \<noteq> var g q"
  proof-
    have "q \<in> allDefs g (defNode g p)" using assms(2) assms(4) by (auto)
    thus ?thesis using assms(1-3)
      by - (rule allDefs_var_disjoint[of "defNode g p" g], auto)
  qed

  lemma phiArg_distinct_nodes:
    assumes "phiArg g p q" "p \<noteq> q" and[simp]: "p \<in> allVars g"
    shows "defNode g p \<noteq> defNode g q"
  proof
    have "p \<in> allDefs g (defNode g p)" by simp
    moreover assume "defNode g p = defNode g q"
    ultimately have "var g p \<noteq> var g q" using assms
      by - (rule defNode_var_disjoint, auto)
    moreover
    from assms(1) have "var g q = var g p" by (rule phiArg_same_var)
    ultimately show False by simp
  qed

  lemma phiArgs_def_distinct:
    assumes "phiArg g p q" "phiArg g p r" "q \<noteq> r" "p \<in> allVars g"
    shows "defNode g q \<noteq> defNode g r"
  proof (rule)
    assume "defNode g q = defNode g r"
    hence "var g q \<noteq> var g r" using assms by - (rule defNode_var_disjoint, auto)
    thus False using phiArg_same_var[OF assms(1)] phiArg_same_var[OF assms(2)] by simp
  qed

  lemma defNode_not_on_defUse_path:
    assumes p: "g \<turnstile> defNode g p-ns\<rightarrow>n" "defNode g p \<notin> set (tl ns)" "p \<in> allUses g n"
    assumes[simp]: "q \<in> allVars g" "p \<noteq> q" "var g p = var g q"
    shows "defNode g q \<notin> set ns"
  proof-
    let ?P = "defNode g p"
    let ?Q = "defNode g q"

    have[simp]: "p \<in> allVars g" using p(1,3) by auto
    have "?P \<noteq> ?Q" using defNode_var_disjoint[of p g q] by auto
    moreover have "?Q \<notin> set (tl ns)" using p(2,3)
      by - (rule conventional'[OF p(1), of p q], auto)
    ultimately show ?thesis using p(1) by (cases ns, auto simp: old.path2_def)
  qed

  lemma defUse_paths_disjoint:
    assumes p: "g \<turnstile> defNode g p-ns\<rightarrow>n" "defNode g p \<notin> set (tl ns)" "p \<in> allUses g n"
    assumes q: "g \<turnstile> defNode g q-ms\<rightarrow>m" "defNode g q \<notin> set (tl ms)" "q \<in> allUses g m"
    assumes[simp]: "p \<noteq> q" "var g p = var g q"
    shows "set ns \<inter> set ms = {}"
  proof (rule equals0I)
    fix y
    assume y: "y \<in> set ns \<inter> set ms"

    {
      fix p ns n
      assume p: "g \<turnstile> defNode g p-ns\<rightarrow>n" "defNode g p \<notin> set (tl ns)" "p \<in> allUses g n"
      assume y: "y \<in> set ns"
      from p(1,3) have dom: "old.dominates g (defNode g p) n" by - (rule allUses_dominated, auto)
      moreover
      obtain ns' where "g \<turnstile> y-ns'\<rightarrow>n" "suffix ns' ns"
        by (rule old.path2_split_first_last[OF p(1) y], auto)
      ultimately have "old.dominates g (defNode g p) y" using suffix_tl_subset[of ns' ns] p(2)
        by - (rule old.dominates_extend[where ms=ns'], auto)
    }
    with assms y have dom: "old.dominates g (defNode g p) y" "old.dominates g (defNode g q) y" by auto

    {
      fix p ns n q ms m
      let ?P = "defNode g p"
      let ?Q = "defNode g q"

      assume p: "g \<turnstile> defNode g p-ns\<rightarrow>n" "defNode g p \<notin> set (tl ns)" "p \<in> allUses g n" "old.dominates g ?P y" "y \<in> set ns"
      assume q: "g \<turnstile> defNode g q-ms\<rightarrow>m" "defNode g q \<notin> set (tl ms)" "q \<in> allUses g m" "old.dominates g ?Q y" "y \<in> set ms"
      assume[simp]: "p \<noteq> q" "var g p = var g q"
      assume dom: "old.dominates g ?P ?Q"
      then obtain pqs where pqs: "g \<turnstile> ?P-pqs\<rightarrow>?Q" "?P \<notin> set (tl pqs)" by (rule old.dominates_path, auto intro: old.simple_path2)
      from p obtain ns\<^sub>2 where ns\<^sub>2: "g \<turnstile> y-ns\<^sub>2\<rightarrow>n" "suffix ns\<^sub>2 ns" by - (rule old.path2_split_first_last, auto)
      from q obtain ms\<^sub>1 where ms\<^sub>1: "g \<turnstile> ?Q-ms\<^sub>1\<rightarrow>y" "prefix ms\<^sub>1 ms" by - (rule old.path2_split_first_last, auto)
      have "var g q \<noteq> var g p"
      proof (rule conventional[OF _ _ _ p(3)])
        let ?path = "(pqs@tl ms\<^sub>1)@tl ns\<^sub>2"
        show "g \<turnstile> ?P-?path\<rightarrow>n" using pqs ms\<^sub>1 ns\<^sub>2
          by (auto simp del:append_assoc intro:old.path2_app)
        have "?P \<notin> set (tl ns\<^sub>2)" using p(2) ns\<^sub>2(2)[THEN suffix_tl_subset, THEN subsetD] by auto
        moreover
        have[simp]: "q \<in> allVars g" "p \<in> allVars g" using p q by auto
        have "?P \<notin> set (tl ms)" using q
          by - (rule conventional'[where v'=p and v=q], auto)
        hence "?P \<notin> set (tl ms\<^sub>1)" using ms\<^sub>1(2)[simplified, THEN prefix_tl_subset] by auto
        ultimately
        show "?P \<notin> set (tl ?path)" using pqs(2)
          by - (rule notI, auto dest: subsetD[OF set_tl_append'])
        show "p \<in> allDefs g (defNode g p)" by auto
        have "?P \<noteq> ?Q" using defNode_var_disjoint[of p g q] by auto
        hence 1: "length pqs > 1" using pqs by - (rule old.path2_nontriv)
        hence "?Q \<in> set (tl pqs)" using pqs unfolding old.path2_def by (auto intro:last_in_tl)
        moreover from 1 have "pqs \<noteq> []" by auto
        ultimately show "?Q \<in> set (tl ?path)" by simp
        show "q \<in> allDefs g ?Q" by simp
      qed
      hence False by simp
    }
    from this[OF p _ _ q] this[OF q _ _ p] y dom show False
      by - (rule old.dominates_antitrans[OF _ dom], auto)
  qed

  lemma oldDefsI: "v \<in> defs g n \<Longrightarrow> var g v \<in> oldDefs g n" by (simp add: oldDefs_def)

  lemma simpleDefs_phiDefs_var_disjoint:
    assumes "v \<in> phiDefs g n" "n \<in> set (\<alpha>n g)"
    shows "var g v \<notin> oldDefs g n"
  proof
    from assms have[simp]: "v \<in> allVars g" by auto
    assume "var g v \<in> oldDefs g n"
    then obtain v'' where v'': "v'' \<in> defs g n" "var g v'' = var g v"
      by (auto simp: oldDefs_def)
    from this(1) assms have "v'' \<noteq> v"
      using simpleDefs_phiDefs_disjoint[of n g] by (auto simp: phiArg_def)
    with v'' assms show False
      using allDefs_var_disjoint[of n g v'' v] by auto
  qed

  lemma liveVal_use_path:
    assumes "liveVal g v"
    obtains ns m where "g \<turnstile> defNode g v-ns\<rightarrow>m" "var g v \<in> oldUses g m"
      "\<And>x. x \<in> set (tl ns) \<Longrightarrow> var g v \<notin> oldDefs g x"
  using assms proof (induction)
    case (liveSimple m v)
    from liveSimple.hyps have[simp]: "v \<in> allVars g"
      by - (rule allUses_in_allVars, auto)
    from liveSimple.hyps obtain ns where ns: "g \<turnstile> defNode g v-ns\<rightarrow>m" "defNode g v \<notin> set (tl ns)"
      by - (rule defUse_path_ex, auto intro!: uses_in_allUses elim: old.simple_path2)
    from this(1) show thesis
    proof (rule liveSimple.prems)
      show "var g v \<in> oldUses g m" using liveSimple.hyps by (auto simp: oldUses_def)
      {
        fix x
        assume asm: "x \<in> set (tl ns)" "var g v \<in> oldDefs g x"
        then obtain v' where "v' \<in> defs g x" "var g v' = var g v"
          by (auto simp: oldDefs_def)
        with asm liveSimple.hyps have False
          by - (rule conventional[OF ns, of v x v', THEN notE], auto)
      }
      thus "\<And>x. x \<in> set (tl ns) \<Longrightarrow> var g v \<notin> oldDefs g x" by auto
    qed
  next
    case (livePhi v v')
    from livePhi.hyps have[simp]: "v \<in> allVars g" "v' \<in> allVars g" "var g v' = var g v"
      by (auto intro: phiArg_same_var)
    show thesis
    proof (rule livePhi.IH)
      fix ns m
      assume asm: "g \<turnstile> defNode g v-ns\<rightarrow>m" "var g v \<in> oldUses g m"
        "\<And>x. x \<in> set (tl ns) \<Longrightarrow> var g v \<notin> oldDefs g x"
      from livePhi.hyps(2) obtain ns' m' where ns': "g \<turnstile> defNode g v'-ns'\<rightarrow>m'" "v' \<in> phiUses g m'"
        "m' \<in> set (old.predecessors g (defNode g v))" "defNode g v' \<notin> set (tl ns')"
        by (rule phiArg_path_ex', auto elim: old.simple_path2)
      show thesis
      proof (rule livePhi.prems)
        show "g \<turnstile> defNode g v'-(ns'@[defNode g v])@tl ns\<rightarrow>m"
        apply (rule old.path2_app)
         apply (rule old.path2_snoc[OF ns'(1,3)])
        by (rule asm(1))
        show "var g v' \<in> oldUses g m" using asm(2) by simp
        {
          fix x
          assume asm: "x \<in> set (tl ns')" "var g v \<in> oldDefs g x"
          then obtain v'' where "v'' \<in> defs g x" "var g v'' = var g v"
            by (auto simp: oldDefs_def)
          with asm ns'(2) have False
            by - (rule conventional[OF ns'(1,4), of v' x v'', THEN notE], auto)
        }
        then show "\<And>x. x \<in> set (tl ((ns'@[defNode g v])@tl ns)) \<Longrightarrow> var g v' \<notin> oldDefs g x"
          using simpleDefs_phiDefs_var_disjoint[of v g "defNode g v"] livePhi.hyps(2)
          by (auto dest!: set_tl_append'[THEN subsetD] asm(3) simp: phiArg_def)
      qed
    qed
  qed
end

end


theory SINVAR_DomainHierarchyNG_impl
imports SINVAR_DomainHierarchyNG "../TopoS_Interface_impl"
begin

subsubsection \<open>SecurityInvariant DomainHierarchy List Implementation\<close>

code_identifier code_module SINVAR_DomainHierarchyNG_impl => (Scala) SINVAR_DomainHierarchyNG

fun sinvar :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> domainNameTrust) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (s, r) \<in> set (edgesL G). (nP r) \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t (nP s))"

definition DomainHierarchyNG_sanity_check_config :: "domainNameTrust list \<Rightarrow> domainTree \<Rightarrow> bool" where
  "DomainHierarchyNG_sanity_check_config host_attributes tree = (\<forall> c \<in> set host_attributes.
    case c of Unassigned \<Rightarrow> True
            | DN (level, trust) \<Rightarrow> valid_hierarchy_pos tree level
   )"

fun verify_globals :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> domainNameTrust) \<Rightarrow> domainTree \<Rightarrow> bool" where
  "verify_globals G nP tree = (\<forall> v \<in> set (nodesL G).
    case (nP v) of Unassigned \<Rightarrow> True | DN (level, trust) \<Rightarrow> valid_hierarchy_pos tree level
   )"

(*TODO: to get rid of verify_globals
  this stronger DomainHierarchyNG_sanity_check_config sanity checker checks the config
  for all graphs!*)
lemma "DomainHierarchyNG_sanity_check_config c tree \<Longrightarrow>
    {x. \<exists>v. nP v = x} = set c \<Longrightarrow>
    verify_globals G nP tree"
  apply(simp add: DomainHierarchyNG_sanity_check_config_def split: if_split_asm)
  apply(clarify)
  apply(case_tac "nP v")
   apply(simp_all)
  apply(clarify)
  by force

definition DomainHierarchyNG_offending_list:: "'v list_graph \<Rightarrow> ('v \<Rightarrow> domainNameTrust) \<Rightarrow> ('v \<times> 'v) list list" where
  "DomainHierarchyNG_offending_list G nP = (if sinvar G nP then
    []
   else
    [ [e \<leftarrow> edgesL G. case e of (s,r) \<Rightarrow> \<not> (nP r) \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t (nP s) ] ])"

lemma "DomainHierarchyNG.node_props P =
  (\<lambda>i. case node_properties P i of None \<Rightarrow> SINVAR_DomainHierarchyNG.default_node_properties | Some property \<Rightarrow> property)"
by(fact SecurityInvariant.node_props.simps[OF TopoS_DomainHierarchyNG, of "P"])

definition "NetModel_node_props P = (\<lambda> i. (case (node_properties P) i of Some property \<Rightarrow> property | None \<Rightarrow> SINVAR_DomainHierarchyNG.default_node_properties))"
(*

(*TODO does this work?*)
lemma[code_unfold]: "DomainHierarchyNG.node_props P = NetModel_node_props P"
by(simp add: NetModel_node_props_def)

definition "DomainHierarchyNG_eval G P = (wf_list_graph G \<and>
  sinvar G (SecurityInvariant.node_props SINVAR_DomainHierarchyNG.default_node_properties P))"

interpretation DomainHierarchyNG_impl:TopoS_List_Impl
  where default_node_properties=SINVAR_DomainHierarchyNG.default_node_properties
  and sinvar_spec=SINVAR_DomainHierarchyNG.sinvar
  and sinvar_impl=sinvar
  and receiver_violation=SINVAR_DomainHierarchyNG.receiver_violation
  and offending_flows_impl=DomainHierarchyNG_offending_list
  and node_props_impl=NetModel_node_props
  and eval_impl=DomainHierarchyNG_eval
 apply(unfold TopoS_List_Impl_def)
 apply(rule conjI)
  apply(simp add: TopoS_DomainHierarchyNG list_graph_to_graph_def; fail)
 apply(rule conjI)
  apply(simp add: list_graph_to_graph_def DomainHierarchyNG_offending_set
        DomainHierarchyNG_offending_set_def DomainHierarchyNG_offending_list_def; fail)
 apply(rule conjI)
  apply(simp only: NetModel_node_props_def)
  apply(metis DomainHierarchyNG.node_props.simps DomainHierarchyNG.node_props_eq_node_props_formaldef)
 apply(simp only: DomainHierarchyNG_eval_def)
 apply(intro allI)
 apply(rule TopoS_eval_impl_proofrule[OF TopoS_DomainHierarchyNG])
 apply(simp add: list_graph_to_graph_def)
done

subsubsection \<open>DomainHierarchyNG packing\<close>
  definition SINVAR_LIB_DomainHierarchyNG :: "('v::vertex, domainNameTrust) TopoS_packed" where
    "SINVAR_LIB_DomainHierarchyNG \<equiv>
    \<lparr> nm_name = ''DomainHierarchyNG'',
      nm_receiver_violation = SINVAR_DomainHierarchyNG.receiver_violation,
      nm_default = SINVAR_DomainHierarchyNG.default_node_properties,
      nm_sinvar = sinvar,
      nm_offending_flows = DomainHierarchyNG_offending_list,
      nm_node_props = NetModel_node_props,
      nm_eval = DomainHierarchyNG_eval
      \<rparr>"
  interpretation SINVAR_LIB_DomainHierarchyNG_interpretation: TopoS_modelLibrary SINVAR_LIB_DomainHierarchyNG
      SINVAR_DomainHierarchyNG.sinvar
    apply(unfold TopoS_modelLibrary_def SINVAR_LIB_DomainHierarchyNG_def)
    apply(rule conjI)
     apply(simp)
    apply(simp)
    by(unfold_locales)

text \<open>Examples:\<close>
definition example_TUM_net :: "string list_graph" where
  "example_TUM_net \<equiv> \<lparr> nodesL=[''Gateway'', ''LowerSVR'', ''UpperSRV''],
        edgesL=[
          (''Gateway'',''LowerSVR''), (''Gateway'',''UpperSRV''),
          (''LowerSVR'', ''Gateway''),
          (''UpperSRV'', ''Gateway'')
        ] \<rparr>"
value "wf_list_graph example_TUM_net"

definition example_TUM_config :: "string \<Rightarrow> domainNameTrust" where
  "example_TUM_config \<equiv> ((\<lambda> e. default_node_properties)
        (''Gateway'':= DN (''ACD''--''AISD''--Leaf, 1),
         ''LowerSVR'':= DN (''ACD''--''AISD''--Leaf, 0),
         ''UpperSRV'':= DN (''ACD''--Leaf, 0)
       ))"

definition example_TUM_hierarchy :: "domainTree" where
"example_TUM_hierarchy \<equiv> (Department ''ACD'' [
           Department ''AISD'' []
       ])"

value "verify_globals example_TUM_net example_TUM_config example_TUM_hierarchy"
value "sinvar     example_TUM_net example_TUM_config"

definition example_TUM_net_invalid where
"example_TUM_net_invalid \<equiv> example_TUM_net\<lparr>edgesL :=
    (''LowerSRV'', ''UpperSRV'')#(edgesL example_TUM_net)\<rparr>"

value "verify_globals example_TUM_net_invalid example_TUM_config example_TUM_hierarchy"
value "sinvar     example_TUM_net_invalid example_TUM_config"
value "DomainHierarchyNG_offending_list example_TUM_net_invalid example_TUM_config"

hide_const (open) NetModel_node_props

hide_const (open) sinvar

end


section \<open>Algorithms on Nondeterministic Generalized Büchi Automata\<close>

theory NGBA_Algorithms
imports
  NGBA_Graphs
  NGBA_Implement
  NBA_Combine
  NBA_Algorithms
  Degeneralization_Refine
begin

  subsection \<open>Operations\<close>

  definition op_language_empty where [simp]: "op_language_empty A \<equiv> NGBA.language A = {}"

  lemmas [autoref_op_pat] = op_language_empty_def[symmetric]

  subsection \<open>Implementations\<close>

  context
  begin

    interpretation autoref_syn by this

    lemma ngba_g_ahs: "ngba_g A = \<lparr> g_V = UNIV, g_E = E_of_succ (\<lambda> p. CAST
      ((\<Union> a \<in> ngba.alphabet A. ngba.transition A a p ::: \<langle>S\<rangle> list_set_rel) ::: \<langle>S\<rangle> ahs_rel bhc)),
      g_V0 = ngba.initial A \<rparr>"
      unfolding ngba_g_def ngba.successors_alt_def CAST_def id_apply autoref_tag_defs by rule

    schematic_goal ngbai_gi:
      notes [autoref_ga_rules] = map2set_to_list
      fixes S :: "('statei \<times> 'state) set"
      assumes [autoref_ga_rules]: "is_bounded_hashcode S seq bhc"
      assumes [autoref_ga_rules]: "is_valid_def_hm_size TYPE('statei) hms"
      assumes [autoref_rules]: "(seq, HOL.eq) \<in> S \<rightarrow> S \<rightarrow> bool_rel"
      assumes [autoref_rules]: "(Ai, A) \<in> \<langle>L, S\<rangle> ngbai_ngba_rel"
      shows "(?f :: ?'a, RETURN (ngba_g A)) \<in> ?A"
      unfolding ngba_g_ahs[where S = S and bhc = bhc] by (autoref_monadic (plain))
    concrete_definition ngbai_gi uses ngbai_gi
    lemma ngbai_gi_refine[autoref_rules]:
      fixes S :: "('statei \<times> 'state) set"
      assumes "SIDE_GEN_ALGO (is_bounded_hashcode S seq bhc)"
      assumes "SIDE_GEN_ALGO (is_valid_def_hm_size TYPE('statei) hms)"
      assumes "GEN_OP seq HOL.eq (S \<rightarrow> S \<rightarrow> bool_rel)"
      shows "(NGBA_Algorithms.ngbai_gi seq bhc hms, ngba_g) \<in>
        \<langle>L, S\<rangle> ngbai_ngba_rel \<rightarrow> \<langle>unit_rel, S\<rangle> g_impl_rel_ext"
      using ngbai_gi.refine[THEN RETURN_nres_relD] assms unfolding autoref_tag_defs by blast

    schematic_goal ngba_nodes:
      fixes S :: "('statei \<times> 'state) set"
      assumes [simp]: "finite ((g_E (ngba_g A))\<^sup>* `` g_V0 (ngba_g A))"
      assumes [autoref_ga_rules]: "is_bounded_hashcode S seq bhc"
      assumes [autoref_ga_rules]: "is_valid_def_hm_size TYPE('statei) hms"
      assumes [autoref_rules]: "(seq, HOL.eq) \<in> S \<rightarrow> S \<rightarrow> bool_rel"
      assumes [autoref_rules]: "(Ai, A) \<in> \<langle>L, S\<rangle> ngbai_ngba_rel"
      shows "(?f :: ?'a, op_reachable (ngba_g A)) \<in> ?R" by autoref
    concrete_definition ngba_nodes uses ngba_nodes
    lemma ngba_nodes_refine[autoref_rules]:
      fixes S :: "('statei \<times> 'state) set"
      assumes "SIDE_PRECOND (finite (NGBA.nodes A))"
      assumes "SIDE_GEN_ALGO (is_bounded_hashcode S seq bhc)"
      assumes "SIDE_GEN_ALGO (is_valid_def_hm_size TYPE('statei) hms)"
      assumes "GEN_OP seq HOL.eq (S \<rightarrow> S \<rightarrow> bool_rel)"
      assumes "(Ai, A) \<in> \<langle>L, S\<rangle> ngbai_ngba_rel"
      shows "(NGBA_Algorithms.ngba_nodes seq bhc hms Ai,
        (OP NGBA.nodes ::: \<langle>L, S\<rangle> ngbai_ngba_rel \<rightarrow> \<langle>S\<rangle> ahs_rel bhc) $ A) \<in> \<langle>S\<rangle> ahs_rel bhc"
    proof -
      have 1: "NGBA.nodes A = op_reachable (ngba_g A)" by (auto simp: ngba_g_V0 ngba_g_E_rtrancl)
      have 2: "finite ((g_E (ngba_g A))\<^sup>* `` g_V0 (ngba_g A))" using assms(1) unfolding 1 by simp
      show ?thesis using ngba_nodes.refine assms 2 unfolding autoref_tag_defs 1 by blast
    qed

    lemma ngba_igbg_ahs: "ngba_igbg A = \<lparr> g_V = UNIV, g_E = E_of_succ (\<lambda> p. CAST
      ((\<Union> a \<in> NGBA.alphabet A. NGBA.transition A a p ::: \<langle>S\<rangle> list_set_rel) ::: \<langle>S\<rangle> ahs_rel bhc)), g_V0 = NGBA.initial A,
      igbg_num_acc = length (NGBA.accepting A), igbg_acc = ngba_acc (NGBA.accepting A) \<rparr>"
      unfolding ngba_g_def ngba_igbg_def ngba.successors_alt_def CAST_def id_apply autoref_tag_defs
      unfolding graph_rec.defs
      by simp

    definition "ngba_acc_bs cs p \<equiv> fold (\<lambda> (k, c) bs. if c p then bs_insert k bs else bs) (List.enumerate 0 cs) (bs_empty ())"

    lemma ngba_acc_bs_empty[simp]: "ngba_acc_bs [] p = bs_empty ()" unfolding ngba_acc_bs_def by simp
    lemma ngba_acc_bs_insert[simp]:
      assumes "c p"
      shows "ngba_acc_bs (cs @ [c]) p = bs_insert (length cs) (ngba_acc_bs cs p)"
      using assms unfolding ngba_acc_bs_def by (simp add: enumerate_append_eq)
    lemma ngba_acc_bs_skip[simp]:
      assumes "\<not> c p"
      shows "ngba_acc_bs (cs @ [c]) p = ngba_acc_bs cs p"
      using assms unfolding ngba_acc_bs_def by (simp add: enumerate_append_eq)

    lemma ngba_acc_bs_correct[simp]: "bs_\<alpha> (ngba_acc_bs cs p) = ngba_acc cs p"
    proof (induct cs rule: rev_induct)
      case Nil
      show ?case unfolding ngba_acc_def by simp
    next
      case (snoc c cs)
      show ?case using less_Suc_eq snoc by (cases "c p") (force simp: ngba_acc_def)+
    qed

    lemma ngba_acc_impl_bs[autoref_rules]: "(ngba_acc_bs, ngba_acc) \<in> \<langle>S \<rightarrow> bool_rel\<rangle> list_rel \<rightarrow> S \<rightarrow> \<langle>nat_rel\<rangle> bs_set_rel"
    proof -
      have "(ngba_acc_bs, ngba_acc) \<in> \<langle>Id \<rightarrow> bool_rel\<rangle> list_rel \<rightarrow> Id \<rightarrow> \<langle>nat_rel\<rangle> bs_set_rel"
        by (auto simp: bs_set_rel_def in_br_conv)
      also have "(ngba_acc, ngba_acc) \<in> \<langle>S \<rightarrow> bool_rel\<rangle> list_rel \<rightarrow> S \<rightarrow> \<langle>nat_rel\<rangle> set_rel" by parametricity
      finally show ?thesis by simp
    qed

    schematic_goal ngbai_igbgi:
      notes [autoref_ga_rules] = map2set_to_list
      fixes S :: "('statei \<times> 'state) set"
      assumes [autoref_ga_rules]: "is_bounded_hashcode S seq bhc"
      assumes [autoref_ga_rules]: "is_valid_def_hm_size TYPE('statei) hms"
      assumes [autoref_rules]: "(seq, HOL.eq) \<in> S \<rightarrow> S \<rightarrow> bool_rel"
      assumes [autoref_rules]: "(Ai, A) \<in> \<langle>L, S\<rangle> ngbai_ngba_rel"
      shows "(?f :: ?'a, RETURN (ngba_igbg A)) \<in> ?A"
      unfolding ngba_igbg_ahs[where S = S and bhc = bhc] by (autoref_monadic (plain))
    concrete_definition ngbai_igbgi uses ngbai_igbgi
    lemma ngbai_igbgi_refine[autoref_rules]:
      fixes S :: "('statei \<times> 'state) set"
      assumes "SIDE_GEN_ALGO (is_bounded_hashcode S seq bhc)"
      assumes "SIDE_GEN_ALGO (is_valid_def_hm_size TYPE('statei) hms)"
      assumes "GEN_OP seq HOL.eq (S \<rightarrow> S \<rightarrow> bool_rel)"
      shows "(NGBA_Algorithms.ngbai_igbgi seq bhc hms, ngba_igbg) \<in>
        \<langle>L, S\<rangle> ngbai_ngba_rel \<rightarrow> igbg_impl_rel_ext unit_rel S"
      using ngbai_igbgi.refine[THEN RETURN_nres_relD] assms unfolding autoref_tag_defs by blast

    schematic_goal ngba_language_empty:
      fixes S :: "('statei \<times> 'state) set"
      assumes [simp]: "igb_fr_graph (ngba_igbg A)"
      assumes [autoref_ga_rules]: "is_bounded_hashcode S seq bhs"
      assumes [autoref_ga_rules]: "is_valid_def_hm_size TYPE('statei) hms"
      assumes [autoref_rules]: "(seq, HOL.eq) \<in> S \<rightarrow> S \<rightarrow> bool_rel"
      assumes [autoref_rules]: "(Ai, A) \<in> \<langle>L, S\<rangle> ngbai_ngba_rel"
      shows "(?f :: ?'a, do { r \<leftarrow> op_find_lasso_spec (ngba_igbg A); RETURN (r = None)}) \<in> ?A"
      by (autoref_monadic (plain))
    concrete_definition ngba_language_empty uses ngba_language_empty
    lemma nba_language_empty_refine[autoref_rules]:
      fixes S :: "('statei \<times> 'state) set"
      assumes "SIDE_PRECOND (finite (NGBA.nodes A))"
      assumes "SIDE_GEN_ALGO (is_bounded_hashcode S seq bhc)"
      assumes "SIDE_GEN_ALGO (is_valid_def_hm_size TYPE('statei) hms)"
      assumes "GEN_OP seq HOL.eq (S \<rightarrow> S \<rightarrow> bool_rel)"
      assumes "(Ai, A) \<in> \<langle>L, S\<rangle> ngbai_ngba_rel"
      shows "(NGBA_Algorithms.ngba_language_empty seq bhc hms Ai,
        (OP op_language_empty ::: \<langle>L, S\<rangle> ngbai_ngba_rel \<rightarrow> bool_rel) $ A) \<in> bool_rel"
    proof -
      have 1: "NGBA.nodes A = op_reachable (ngba_g A)" by (auto simp: ngba_g_V0 ngba_g_E_rtrancl)
      have 2: "finite ((g_E (ngba_g A))\<^sup>* `` g_V0 (ngba_g A))" using assms(1) unfolding 1 by simp
      interpret igb_fr_graph "ngba_igbg A"
        using 2 unfolding ngba_igbg_def ngba_g_def graph_rec.defs ngba_acc_def by unfold_locales auto
      have "(RETURN (NGBA_Algorithms.ngba_language_empty seq bhc hms Ai),
        do { r \<leftarrow> find_lasso_spec; RETURN (r = None) }) \<in> \<langle>bool_rel\<rangle> nres_rel"
        using ngba_language_empty.refine assms igb_fr_graph_axioms by simp
      also have "(do { r \<leftarrow> find_lasso_spec; RETURN (r = None) },
        RETURN (\<not> Ex is_lasso_prpl)) \<in> \<langle>bool_rel\<rangle> nres_rel"
        unfolding find_lasso_spec_def by (refine_vcg) (auto split: option.splits)
      finally have "NGBA_Algorithms.ngba_language_empty seq bhc hms Ai \<longleftrightarrow> \<not> Ex is_lasso_prpl"
        unfolding nres_rel_comp using RETURN_nres_relD by force
      also have "\<dots> \<longleftrightarrow> \<not> Ex is_acc_run" using lasso_prpl_acc_run_iff by auto
      also have "\<dots> \<longleftrightarrow> NGBA.language A = {}" using NGBA_Graphs.acc_run_language is_igb_graph by auto
      finally show ?thesis by simp
    qed

    lemma degeneralize_alt_def: "degeneralize A = nba
      (ngba.alphabet A)
      ((\<lambda> p. (p, 0)) ` ngba.initial A)
      (\<lambda> a (p, k). (\<lambda> q. (q, Degeneralization.count (ngba.accepting A) p k)) ` ngba.transition A a p)
      (degen (ngba.accepting A))"
      unfolding degeneralization.degeneralize_def by auto

    schematic_goal ngba_degeneralize: "(?f :: ?'a, degeneralize) \<in> ?R"
      unfolding degeneralize_alt_def
      using degen_param[autoref_rules] count_param[autoref_rules]
      by autoref
    concrete_definition ngba_degeneralize uses ngba_degeneralize
    lemmas ngba_degeneralize_refine[autoref_rules] = ngba_degeneralize.refine

    schematic_goal nba_intersect':
      assumes [autoref_rules]: "(seq, HOL.eq) \<in> L \<rightarrow> L \<rightarrow> bool_rel"
      shows "(?f, intersect') \<in> \<langle>L, S\<rangle> nbai_nba_rel \<rightarrow> \<langle>L, T\<rangle> nbai_nba_rel \<rightarrow> \<langle>L, S \<times>\<^sub>r T\<rangle> ngbai_ngba_rel"
      unfolding intersection.product_def by autoref
    concrete_definition nba_intersect' uses nba_intersect'
    lemma nba_intersect'_refine[autoref_rules]:
      assumes "GEN_OP seq HOL.eq (L \<rightarrow> L \<rightarrow> bool_rel)"
      shows "(nba_intersect' seq, intersect') \<in>
        \<langle>L, S\<rangle> nbai_nba_rel \<rightarrow> \<langle>L, T\<rangle> nbai_nba_rel \<rightarrow> \<langle>L, S \<times>\<^sub>r T\<rangle> ngbai_ngba_rel"
      using nba_intersect'.refine assms unfolding autoref_tag_defs by this

  end

end