theory TheoremD9
imports TheoremD8
begin

context LocalLexing begin

definition items_le :: "nat \<Rightarrow> ('a, 'b) items \<Rightarrow>  ('a, 'b) items"
where
  "items_le k I = { x . x \<in> I \<and> item_end x \<le> k }"

definition items_eq :: "nat \<Rightarrow>  ('a, 'b)items \<Rightarrow>  ('a, 'b)items"
where
  "items_eq k I = { x . x \<in> I \<and> item_end x = k }"

definition paths_le :: "nat \<Rightarrow>  ('a, 'b, 'c) tokens set \<Rightarrow>  ('a, 'b, 'c) tokens set"
where
  "paths_le k P = { p . p \<in> P \<and> charslength p \<le> k }"

definition paths_eq :: "nat \<Rightarrow>  ('a, 'b, 'c) tokens set \<Rightarrow>  ('a, 'b, 'c) tokens set"
where
  "paths_eq k P = { p . p \<in> P \<and> charslength p = k }"

lemma items_le_pointwise: "pointwise (items_le k)"
  by (auto simp add: pointwise_def items_le_def)

lemma items_le_is_filter: "items_le k I \<subseteq> I"
  by (auto simp add: items_le_def)

lemma items_eq_pointwise: "pointwise (items_eq k)"
  by (auto simp add: pointwise_def items_eq_def)

lemma items_eq_is_filter: "items_eq k I \<subseteq> I"
  by (auto simp add: items_eq_def)

lemma paths_le_pointwise: "pointwise (paths_le k)"
  by (auto simp add: pointwise_def paths_le_def)

lemma paths_le_continuous: "continuous (paths_le k)"
  by (simp add: paths_le_pointwise pointbased_implies_continuous pointwise_implies_pointbased)

lemma paths_le_mono: "mono (paths_le k)"
  by (simp add: continuous_imp_mono paths_le_continuous)

lemma paths_le_is_filter: "paths_le k P \<subseteq> P"
  by (auto simp add: paths_le_def)

lemma paths_eq_pointwise: "pointwise (paths_eq k)"
  by (auto simp add: pointwise_def paths_eq_def)

lemma paths_eq_is_filter: "paths_eq k P \<subseteq> P"
  by (auto simp add: paths_eq_def)

lemma Predict_item_end: "x \<in> Predict k Y \<Longrightarrow> item_end x = k \<or> x \<in> Y"
  using Predict_def by auto

lemma Complete_item_end: "x \<in> Complete k Y \<Longrightarrow> item_end x = k \<or> x \<in> Y"
  using Complete_def by auto

lemma \<J>_0_0_item_end: "x \<in> \<J> 0 0 \<Longrightarrow> item_end x = 0"
  apply (simp add: \<pi>_def)
  proof (induct rule: limit_induct)
    case (Init x) thus ?case by (auto simp add: Init_def)
  next
    case (Iterate x Y)
    then have "x \<in> Complete 0 (Predict 0 Y)" by (simp add: Scan_empty)
    then have "item_end x = 0 \<or> x \<in> Predict 0 Y" using Complete_item_end by blast
    then have "item_end x = 0 \<or> x \<in> Y" using Predict_item_end by blast
    then show ?case using Iterate by blast
  qed

lemma items_le_\<J>_0_0: "items_le 0 (\<J> 0 0) = \<J> 0 0"
  using LocalLexing.\<J>_0_0_item_end LocalLexing.items_le_def LocalLexing_axioms by fast

lemma paths_le_\<P>_0_0: "paths_le 0 (\<P> 0 0) = \<P> 0 0"
  by (auto simp add: paths_le_def)

definition empty_tokens :: " ('a, 'b, 'c) token set \<Rightarrow>  ('a, 'b, 'c) token set"
where
  "empty_tokens T = { t . t \<in> T \<and> chars_of_token t = [] }"

lemma items_le_Predict: "items_le k (Predict k I) = Predict k (items_le k I)"
  by (auto simp add: items_le_def Predict_def bin_def)

lemma items_le_Complete:
  "wellformed_items I \<Longrightarrow> items_le k (Complete k I) = Complete k (items_le k I)"
  by (auto simp add: items_le_def Complete_def bin_def is_complete_def wellformed_items_def
    wellformed_item_def)

lemma items_le_Scan:
  "items_le k (Scan T k I) = Scan (empty_tokens T) k (items_le k I)"
  by (auto simp add: items_le_def Scan_def bin_def empty_tokens_def)

lemma wellformed_items_Gen: "wellformed_items (Gen P)"
  using Gen_implies_pvalid pvalid_def wellformed_items_def by blast

lemma wellformed_\<J>_0_0: "wellformed_items (\<J> 0 0)"
  using thmD8 wellformed_items_Gen by auto

lemma wellformed_items_Predict:
  "wellformed_items I \<Longrightarrow> wellformed_items (Predict k I)"
  by (auto simp add: wellformed_items_def wellformed_item_def Predict_def bin_def)

lemma wellformed_items_Complete:
  "wellformed_items I \<Longrightarrow> wellformed_items (Complete k I)"
  apply (auto simp add: wellformed_items_def wellformed_item_def Complete_def bin_def)
  apply (metis dual_order.trans)
  using is_complete_def next_symbol_not_complete not_less_eq_eq by blast

lemma \<X>_length_bound: "(t, c) \<in> \<X> k \<Longrightarrow> k + length c \<le> length Doc"
  using \<X>_is_prefix is_prefix_length not_le by fastforce

lemma wellformed_items_Scan:
  "wellformed_items I \<Longrightarrow> T \<subseteq> \<X> k \<Longrightarrow> wellformed_items (Scan T k I)"
  apply (auto simp add: wellformed_items_def wellformed_item_def Scan_def bin_def \<X>_length_bound)
  using is_complete_def next_symbol_not_complete not_less_eq_eq by blast

lemma wellformed_items_\<pi>:
  assumes "wellformed_items I"
  assumes "T \<subseteq> \<X> k"
  shows "wellformed_items (\<pi> k T I)"
proof -
  {
    fix x :: "('a, 'b)item"
    have "x \<in> \<pi> k T I \<Longrightarrow> wellformed_item x"
    proof (simp add: \<pi>_def, induct rule: limit_induct)
      case (Init x) thus ?case using assms(1) by (simp add: wellformed_items_def)
    next
      case (Iterate x Y)
      have "wellformed_items Y" by (simp add: Iterate.hyps(1) wellformed_items_def)
      then have "wellformed_items (Scan T k (Complete k (Predict k Y)))"
        by (simp add: assms(2) wellformed_items_Complete wellformed_items_Predict
          wellformed_items_Scan)
      then show ?case by (simp add: Iterate.hyps(2) wellformed_items_def)
    qed
  }
  then show ?thesis using wellformed_items_def by auto
qed

lemma \<J>_subset_Suc_u: "\<J> k u \<subseteq> \<J> k (Suc u)"
  by (metis Complete_\<pi>_fix Complete_subset_\<pi> \<J>.simps(1) \<J>.simps(2) \<J>.simps(3) not0_implies_Suc)

lemma mono_TokensAt: "mono (TokensAt k)"
  by (auto simp add: mono_def TokensAt_def bin_def)

lemma \<T>_subset_TokensAt: "\<T> k u \<subseteq> TokensAt k (\<J> k u)"
proof (induct u)
  case 0 thus ?case by simp
next
  case (Suc u)
    have 1: "Tokens k (\<T> k u) (\<J> k u) = Sel (\<T> k u) (TokensAt k (\<J> k u))"
      by (simp add: Tokens_def)
    have 2: "Sel (\<T> k u) (TokensAt k (\<J> k u)) \<subseteq> TokensAt k (\<J> k u)"
      by (simp add: Sel_upper_bound Suc.hyps)
    have "\<T> k (Suc u) \<subseteq> TokensAt k (\<J> k u)"
      by (simp add: 1 2)
    then show ?case
      by (meson \<J>_subset_Suc_u mono_TokensAt mono_subset_elem subset_iff)
qed

lemma TokensAt_subset_\<X>: "TokensAt k I \<subseteq> \<X> k"
  using TokensAt_def \<X>_def is_terminal_def \<TT>_def by (auto split: sum.splits)

lemma wellformed_items_\<J>_induct_u:
  assumes "wellformed_items (\<J> k u)"
  shows "wellformed_items (\<J> k (Suc u))"
proof -
  {
    fix x ::"('a, 'b) item"
    have "x \<in> \<J> k (Suc u) \<Longrightarrow> wellformed_item x"
    proof (simp add: \<pi>_def, induct rule: limit_induct)
      case (Init x)
        with assms show ?case by (auto simp add: wellformed_items_def)
    next
      case (Iterate p Y)
        from Iterate(1) have wellformed_Y: "wellformed_items Y"
          by (auto simp add: wellformed_items_def)
        then have "wellformed_items (Complete k (Predict k Y))"
          by (simp add: wellformed_items_Complete wellformed_items_Predict)
        then have "wellformed_items (Scan (Tokens k (\<T> k u) (\<J> k u)) k (Complete k (Predict k Y)))"
          apply (rule_tac wellformed_items_Scan)
          apply simp
          apply (simp add: Tokens_def)
          by (meson Sel_upper_bound TokensAt_subset_\<X> \<T>_subset_TokensAt subset_trans)
        then show ?case
          using Iterate.hyps(2) wellformed_items_def by blast
    qed
  }
  then show ?thesis
    using wellformed_items_def by blast
qed

lemma wellformed_items_\<J>_k_u_if_0: "wellformed_items (\<J> k 0) \<Longrightarrow> wellformed_items (\<J> k u)"
  apply (induct u)
  apply (simp)
  using wellformed_items_\<J>_induct_u by blast

lemma wellformed_items_natUnion: "(\<And> k. wellformed_items (I k)) \<Longrightarrow> wellformed_items (natUnion I)"
  by (auto simp add: natUnion_def wellformed_items_def)

lemma wellformed_items_\<I>_k_if_0: "wellformed_items (\<J> k 0) \<Longrightarrow> wellformed_items (\<I> k)"
  apply (simp)
  apply (rule wellformed_items_natUnion)
  using wellformed_items_\<J>_k_u_if_0 by blast

lemma wellformed_items_\<J>_\<I>: "wellformed_items (\<J> k u) \<and> wellformed_items (\<I> k)"
proof (induct k arbitrary: u)
  case 0
    show ?case
      using wellformed_\<J>_0_0 wellformed_items_\<I>_k_if_0 wellformed_items_\<J>_k_u_if_0 by blast
next
  case (Suc k)
    have 0: "wellformed_items (\<J> (Suc k) 0)"
      apply simp
      using Suc.hyps wellformed_items_\<pi> by auto
    then show ?case
      using wellformed_items_\<I>_k_if_0 wellformed_items_\<J>_k_u_if_0 by blast
qed

lemma wellformed_items_\<J>: "wellformed_items (\<J> k u)"
by (simp add: wellformed_items_\<J>_\<I>)

lemma wellformed_items_\<I>: "wellformed_items (\<I> k)"
using wellformed_items_\<J>_\<I> by blast

lemma funpower_consume_function:
  assumes law: "\<And> X. P X \<Longrightarrow> f (g X) = h (f X) \<and> P (g X)"
  shows "P I \<Longrightarrow> P (funpower g n I) \<and> f (funpower g n I) = funpower h n (f I)"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then have S1: "P (funpower g n I)" and S2: "f (funpower g n I) = funpower h n (f I)"
    by auto
  have law1: "\<And> X. P X \<Longrightarrow> f (g X) = h (f X)" using law by auto
  have law2: "\<And> X. P X \<Longrightarrow> P (g X)" using law by auto
  show ?case
    apply simp
    apply (subst law1[where X="funpower g n I"])
    apply (simp add: S1)
    apply (subst S2)
    apply auto
    apply (rule law2)
    apply (simp add: S1)
    done
qed

lemma limit_consume_function:
  assumes continuous: "continuous f"
  assumes law: "\<And> X. P X \<Longrightarrow> f (g X) = h (f X) \<and> P (g X)"
  assumes setmonotone: "setmonotone g"
  shows "P I \<Longrightarrow> f (limit g I) = limit h (f I)"
proof -
  have 1: "f (limit g I) = f (natUnion (\<lambda>n. funpower g n I))"
    by (simp add: limit_def)
  have "chain (\<lambda>n. funpower g n I)" by (simp add: setmonotone setmonotone_implies_chain_funpower)
  from continuous_apply[OF continuous this]
  have swap: "f (natUnion (\<lambda>n. funpower g n I)) = natUnion (f \<circ> (\<lambda>n. funpower g n I))" by blast
  have "f o (\<lambda>n. funpower g n I) = (\<lambda> n. f (funpower g n I))" by auto
  also have "P I \<Longrightarrow> (\<lambda> n. f (funpower g n I)) = (\<lambda> n. funpower h n (f I))"
    by (metis funpower_consume_function[where P=P and f=f and g=g and h=h, OF law, simplified])
  ultimately have "P I \<Longrightarrow> f o (\<lambda>n. funpower g n I) = (\<lambda> n. funpower h n (f I))" by auto
  with swap have 2: "P I \<Longrightarrow> f (natUnion (\<lambda>n. funpower g n I)) = natUnion (\<lambda> n. funpower h n (f I))"
    by auto
  have 3: "natUnion (\<lambda> n. funpower h n (f I)) = limit h (f I)"
    by (simp add: limit_def)
  assume "P I"
  with 1 2 3 show ?thesis by auto
qed

lemma items_le_\<pi>_swap:
  assumes wellformed_I: "wellformed_items I"
  assumes T: "T \<subseteq> \<X> k"
  shows "items_le k (\<pi> k T I) = \<pi> k (empty_tokens T) (items_le k I)"
proof -
  let ?g = "(Scan T k) o (Complete k) o (Predict k)"
  let ?h = "(Scan (empty_tokens T) k) o (Complete k) o (Predict k)"
  have law2:"\<And> I. wellformed_items I \<Longrightarrow> wellformed_items (Predict k I)" using LocalLexing.wellformed_items_Predict LocalLexing_axioms by fast
  then have law0: "\<And> I. wellformed_items I \<Longrightarrow> items_le k (Complete k (Predict k I)) = Complete k ((Predict k (items_le k I)))" using items_le_Complete items_le_Predict by simp
  then  have law1: "\<And> I. wellformed_items I \<Longrightarrow> items_le k (?g I) = ?h (items_le k I)"
     using LocalLexing.wellformed_items_Predict LocalLexing_axioms
      items_le_Scan  items_le_Complete by auto
  have law2: "\<And> I. wellformed_items I \<Longrightarrow> wellformed_items (?g I)"
    by (simp add: T wellformed_items_Complete wellformed_items_Predict wellformed_items_Scan)
  show ?thesis
    apply (subst \<pi>_functional)
    apply (subst limit_consume_function[where P="wellformed_items" and h="?h"])
    apply (simp add: items_le_pointwise pointbased_implies_continuous pointwise_implies_pointbased)
    using law1 law2 apply blast
    apply (simp add: \<pi>_step_regular regular_implies_setmonotone)
    apply (rule wellformed_I)
    apply (subst \<pi>_functional)
    apply blast
    done
qed

lemma items_le_idempotent: "items_le k (items_le k I) = items_le k I"
  using items_le_def by auto

lemma paths_le_idempotent: "paths_le k (paths_le k P) = paths_le k P"
  using paths_le_def by auto

lemma items_le_fix_D:
  assumes items_le_fix: "items_le k I = I"
  assumes x_dom: "x \<in> I"
  shows "item_end x \<le> k"
using items_le_def items_le_fix x_dom by blast

lemma remove_paths_le_in_subset_Gen:
  assumes "items_le k I = I"
  assumes "I \<subseteq> Gen P"
  shows "I \<subseteq> Gen (paths_le k P)"
proof -
  {
    fix x :: "('a, 'b) item"
    assume x_dom: "x \<in> I"
    then have x_item_end:  "item_end x \<le> k" using assms items_le_fix_D by auto
    have "x \<in> Gen P" using assms x_dom by auto
    then obtain p where p: "p \<in> P \<and> pvalid p x" using Gen_implies_pvalid by blast
    have charslength_p: "charslength p \<le> k" using p pvalid_item_end x_item_end by auto
    then have "p \<in> paths_le k P" by (simp add: p paths_le_def)
    then have "x \<in> Gen (paths_le k P)" using Gen_def p by blast
  }
  then show ?thesis by blast
qed

lemma mono_Gen: "mono Gen"
  by (auto simp add: mono_def Gen_def)

lemma empty_tokens_idempotent: "empty_tokens (empty_tokens T) = empty_tokens T"
  by (auto simp add: empty_tokens_def)

lemma empty_tokens_is_filter: "empty_tokens T \<subseteq> T"
  by (auto simp add: empty_tokens_def)

lemma items_le_paths_le: "items_le k (Gen P) = Gen (paths_le k P)"
proof -
  from LocalLexing.Gen_def LocalLexing_axioms have 1:"Gen P = { x | x p. p \<in> P \<and> pvalid p x }" by fastforce
  from LocalLexing.items_le_def LocalLexing_axioms have  2:"items_le k I = { x . x \<in> I \<and> item_end x \<le> k }" by fastforce
  with 1   pvalid_item_end paths_le_def have "items_le k (Gen P) = { x . x  \<in> (Gen P) \<and> item_end x \<le> k}" using items_le_def by presburger
  with paths_le_def Gen_def show ?thesis
    using pvalid_item_end by auto
qed

lemma bin_items_le[symmetric]: "bin I k = bin (items_le k I) k"
  by (auto simp add: bin_def items_le_def)

lemma TokensAt_items_le[symmetric]: "TokensAt k I = TokensAt k (items_le k I)"
  using TokensAt_def bin_items_le by blast

lemma by_length_paths_le[symmetric]: "by_length k P = by_length k (paths_le k P)"
  using by_length.simps paths_le_def by auto

lemma \<W>_paths_le[symmetric]: "\<W> P k = \<W> (paths_le k P) k"
  using \<W>_def by_length_paths_le by blast

theorem \<T>_equals_\<Z>_induct_step:
  assumes induct: "items_le k (\<J> k u) = Gen (paths_le k (\<P> k u))"
  assumes induct_tokens: "\<T> k u = \<Z> k u"
  shows "\<T> k (Suc u) = \<Z> k (Suc u)"
proof -
  have "TokensAt k (\<J> k u) = TokensAt k (items_le k (\<J> k u))"
    using TokensAt_items_le by blast
  also have "TokensAt k (items_le k (\<J> k u)) = TokensAt k (Gen (paths_le k (\<P> k u)))"
    using induct by auto
  ultimately have TokensAt_le: "TokensAt k (\<J> k u) = TokensAt k (Gen (paths_le k (\<P> k u)))"
    by auto
  have "TokensAt k (\<J> k u) = \<W> (\<P> k u) k"
    apply (subst TokensAt_le)
    apply (subst \<W>_paths_le[symmetric])
    apply (rule_tac thmD4[symmetric])
    using \<PP>_covers_\<P> paths_le_is_filter by blast
  then show ?thesis
    by (simp add: induct_tokens Tokens_def \<Y>_def)
qed

theorem thmD9:
  assumes induct: "items_le k (\<J> k u) = Gen (paths_le k (\<P> k u))"
  assumes induct_tokens: "\<T> k u = \<Z> k u"
  assumes k: "k \<le> length Doc"
  shows "items_le k (\<J> k (Suc u)) \<subseteq> Gen (paths_le k (\<P> k (Suc u)))"
proof -
  have t1: "items_le k (\<J> k (Suc u)) = items_le k (\<pi> k (\<T> k (Suc u)) (\<J> k u))"
    by auto
  have t2: "items_le k (\<pi> k (\<T> k (Suc u)) (\<J> k u)) =
    \<pi> k (empty_tokens (\<T> k (Suc u))) (items_le k (\<J> k u))"
    apply (subst items_le_\<pi>_swap)
    apply (simp add: wellformed_items_\<J>)
    using TokensAt_subset_\<X> \<T>_subset_TokensAt apply blast
    by blast
  have t3: "\<pi> k (empty_tokens (\<T> k (Suc u))) (items_le k (\<J> k u)) =
    \<pi> k (empty_tokens (\<T> k (Suc u))) (Gen (paths_le k (\<P> k u)))"
    using induct by auto
  have \<P>_subset: "\<P> k u \<subseteq> \<P> k (Suc u)" using subset_\<P>Suc by blast
  then have "paths_le k (\<P> k u) \<subseteq> paths_le k (\<P> k (Suc u))"
    by (simp add: mono_subset_elem paths_le_mono subsetI)
  with mono_Gen have "Gen (paths_le k (\<P> k u)) \<subseteq> Gen (paths_le k (\<P> k (Suc u)))"
    by (simp add: mono_subset_elem subsetI)
  then have t4: "\<pi> k (empty_tokens (\<T> k (Suc u))) (Gen (paths_le k (\<P> k u))) \<subseteq>
    \<pi> k (empty_tokens (\<T> k (Suc u))) (Gen (paths_le k (\<P> k (Suc u))))"
    by (rule monoD[OF mono_\<pi>])
  have \<T>_eq_\<Z>: "\<T> k (Suc u) = \<Z> k (Suc u)"
    using \<T>_equals_\<Z>_induct_step assms(1) induct_tokens by blast
  have t5: "\<pi> k (empty_tokens (\<T> k (Suc u))) (Gen (paths_le k (\<P> k (Suc u)))) \<subseteq>
    Gen (paths_le k (\<P> k (Suc u)))"
    apply (rule_tac remove_paths_le_in_subset_Gen)
    apply (subst items_le_\<pi>_swap)
    using wellformed_items_Gen apply blast
    using \<T>_eq_\<Z> \<Z>_subset_\<X> empty_tokens_is_filter apply blast
    apply (simp only: empty_tokens_idempotent paths_le_idempotent items_le_paths_le)
    apply (rule_tac thmD5)
    using items_le_is_filter items_le_paths_le apply blast
    apply (rule k)
    using \<T>_eq_\<Z> empty_tokens_is_filter by blast
  from t1 t2 t3 t4 t5 show ?thesis using subset_trans by blast
qed

end

end


\<^marker>\<open>creator "Alexander Krauss"\<close>
\<^marker>\<open>creator "Kevin Kappelmann"\<close>
\<^marker>\<open>creator "Larry Paulson"\<close>
section \<open>Finite Sets\<close>
theory Finite_Sets
  imports Unordered_Pairs
begin

bundle hotg_finite_sets_syntax
begin
syntax "_finset" :: \<open>args \<Rightarrow> set\<close> ("{(_)}")
end
bundle no_hotg_finite_sets_syntax
begin
no_syntax "_finset" :: \<open>args \<Rightarrow> set\<close> ("{(_)}")
end
unbundle hotg_finite_sets_syntax

translations
  "{x, xs}" \<rightleftharpoons> "CONST insert x {xs}"
  "{x}" \<rightleftharpoons> "CONST insert x {}"

lemma singleton_eq_iff_eq [iff]: "{a} = {b} \<longleftrightarrow> a = b"
  by auto

lemma subset_singleton_iff_eq_or_eq [iff]: "A \<subseteq> {a} \<longleftrightarrow> A = {} \<or> A = {a}"
  by auto

lemma singleton_mem_iff_eq [iff]: "x \<in> {a} \<longleftrightarrow> x = a" by auto

lemma powerset_empty_eq [simp]: "powerset {} = {{}}"
  by auto

lemma powerset_singleton_eq [simp]: "powerset {a} = {{}, {a}}"
  by auto

lemma powerset_powerset_empty_eq [simp]: "powerset (powerset {}) = {{}, {{}}}"
  by simp

corollary powerset_singleton_elems [iff]: "x \<in> powerset {a} \<longleftrightarrow> x = {} \<or> x = {a}"
  by auto

corollary subset_singleton_iff [iff]: "x \<subseteq> {a} \<longleftrightarrow> x = {} \<or> x = {a}" by auto

lemma singleton_subset_iff_mem [iff]: "{a} \<subseteq> B \<longleftrightarrow> a \<in> B"
  by blast

lemma mem_upair_iff [iff]: "x \<in> {a, b} \<longleftrightarrow> x = a \<or> x = b" by auto

lemma upair_eq_iff: "{a, b} = {c, d} \<longleftrightarrow> (a = c \<and> b = d) \<or> (a = d \<and> b = c)"
  by auto

lemma upair_eq_singleton_iff [iff]: "{a, b} = {c} \<longleftrightarrow> a = c \<and> b = c"
  by (subst insert_insert_eq_insert[of c, symmetric]) (auto simp only: upair_eq_iff)

lemma singleton_eq_upair_iff [iff]: "{a} = {b, c} \<longleftrightarrow> b = a \<and> c = a"
  using upair_eq_singleton_iff by (auto dest: sym[of "{a}"])

text \<open>@{term "upair x y"} and @{term "{x, y}"} are equal, and thus
interchangeable in developments.\<close>
lemma upair_eq_insert_singleton [simp]: "upair x y = {x, y}"
  unfolding upair_def by (rule eqI) auto

subsection \<open>Replacement\<close>

lemma repl_singleton_eq [simp]: "{f x | x \<in> {a}} = {f a}"
  by auto

lemma repl_insert_eq: "{f x | x \<in> insert x A} = insert (f x) {f x | x \<in> A}"
  by auto

end


subsection {* Weakest precondition calculus *}

theory utp_wp
imports "../hoare/utp_hoare"
begin

text {* A very quick implementation of wp -- more laws still needed! *}

named_theorems wp

method wp_tac = (simp add: wp)

consts
  uwp :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infix "wp" 60)

definition wp_upred :: "('\<alpha>, '\<beta>) rel \<Rightarrow> '\<beta> cond \<Rightarrow> '\<alpha> cond" where
"wp_upred Q r = \<lfloor>\<not> (Q ;; (\<not> \<lceil>r\<rceil>\<^sub><)) :: ('\<alpha>, '\<beta>) rel\<rfloor>\<^sub><"

adhoc_overloading
  uwp wp_upred

declare wp_upred_def [urel_defs]

theorem wp_assigns_r [wp]:
  "\<langle>\<sigma>\<rangle>\<^sub>a wp r = \<sigma> \<dagger> r"
  by rel_auto

theorem wp_skip_r [wp]:
  "II wp r = r"
  by rel_auto

theorem wp_true [wp]:
  "r \<noteq> true \<Longrightarrow> true wp r = false"
  by rel_auto

theorem wp_conj [wp]:
  "P wp (q \<and> r) = (P wp q \<and> P wp r)"
  by rel_auto

theorem wp_seq_r [wp]: "(P ;; Q) wp r = P wp (Q wp r)"
  by rel_auto

theorem wp_cond [wp]: "(P \<triangleleft> b \<triangleright>\<^sub>r Q) wp r = ((b \<Rightarrow> P wp r) \<and> ((\<not> b) \<Rightarrow> Q wp r))"
  by rel_auto

theorem wp_hoare_link:
  "\<lbrace>p\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u \<longleftrightarrow> (Q wp r \<sqsubseteq> p)"
  by rel_auto

text {* If two programs have the same weakest precondition for any postcondition then the programs
  are the same. *}

theorem wp_eq_intro: "\<lbrakk> \<And> r. P wp r = Q wp r \<rbrakk> \<Longrightarrow> P = Q"
  by (rel_auto robust, fastforce+)
end


theory SINVAR_DomainHierarchyNG
imports "../TopoS_Helper"
  "HOL-Lattice.CompleteLattice" (* markarius lattice *)
begin

subsection\<open>SecurityInvariant DomainHierarchyNG\<close>

subsubsection \<open>Datatype Domain Hierarchy\<close>

  text\<open>A fully qualified domain name for an entity in a tree-like hierarchy\<close>
    datatype domainNameDept =  Dept "string" domainNameDept (infixr "--" 65) |
                               Leaf \<comment> \<open>leaf of the tree, end of all domainNames\<close>

    text \<open>Example: the CoffeeMachine of I8\<close>
    value "''i8''--''CoffeeMachine''--Leaf"

  text\<open>A tree strucuture to represent the general hierarchy, i.e. possible domainNameDepts\<close>
    datatype domainTree = Department
        "string"  \<comment> \<open>division\<close>
        "domainTree list"  \<comment> \<open>sub divisions\<close>

  text\<open>one step in tree to find matching department\<close>
    fun hierarchy_next :: "domainTree list \<Rightarrow> domainNameDept \<Rightarrow> domainTree option" where
      "hierarchy_next [] _ = None" |
      "hierarchy_next (s#ss) Leaf = None" |
      "hierarchy_next ((Department d ds)#ss) (Dept n ns) = (if d=n then Some (Department d ds) else hierarchy_next ss (Dept n ns))"

    text \<open>Examples:\<close>
    lemma "hierarchy_next [Department ''i20'' [], Department ''i8'' [Department ''CoffeeMachine'' [], Department ''TeaMachine'' []]]
        (''i8''--Leaf)
        =
        Some (Department ''i8'' [Department ''CoffeeMachine'' [], Department ''TeaMachine'' []])" by eval
    lemma "hierarchy_next [Department ''i20'' [], Department ''i8'' [Department ''CoffeeMachine'' [], Department ''TeaMachine'' []]]
        (''i8''--''whatsoever''--Leaf)
        =
        Some (Department ''i8'' [Department ''CoffeeMachine'' [], Department ''TeaMachine'' []])" by eval
    lemma "hierarchy_next [Department ''i20'' [], Department ''i8'' [Department ''CoffeeMachine'' [], Department ''TeaMachine'' []]]
        Leaf
        = None" by eval
    lemma "hierarchy_next [Department ''i20'' [], Department ''i8'' [Department ''CoffeeMachine'' [], Department ''TeaMachine'' []]]
        (''i0''--Leaf)
        = None" by eval

  text \<open>Does a given @{typ domainNameDept} match the specified tree structure?\<close>
    fun valid_hierarchy_pos :: "domainTree \<Rightarrow> domainNameDept \<Rightarrow> bool" where
      "valid_hierarchy_pos (Department d ds) Leaf = True" |
      "valid_hierarchy_pos (Department d ds) (Dept n Leaf) = (d=n)" |
      "valid_hierarchy_pos (Department d ds) (Dept n ns) = (n=d \<and>
        (case hierarchy_next ds ns of
          None \<Rightarrow> False |
          Some t \<Rightarrow> valid_hierarchy_pos t ns))"

     text \<open>Examples:\<close>
     lemma "valid_hierarchy_pos (Department ''TUM'' []) Leaf" by eval
     lemma "valid_hierarchy_pos (Department ''TUM'' []) Leaf" by eval
     lemma "valid_hierarchy_pos (Department ''TUM'' []) (''TUM''--Leaf)" by eval
     lemma "valid_hierarchy_pos (Department ''TUM'' []) (''TUM''--''facilityManagement''--Leaf) = False" by eval
     lemma "valid_hierarchy_pos (Department ''TUM'' []) (''LMU''--Leaf) = False" by eval
     lemma "valid_hierarchy_pos (Department ''TUM'' [Department ''i8'' [], (Department ''i20'' [])])  (''TUM''--Leaf)" by eval
     lemma "valid_hierarchy_pos (Department ''TUM'' [Department ''i8'' [], Department ''i20'' []])  (''TUM''--''i8''--Leaf)" by eval
     lemma "valid_hierarchy_pos
        (Department ''TUM'' [
           Department ''i8'' [
            Department ''CoffeeMachine'' [],
            Department ''TeaMachine'' []
           ],
           Department ''i20'' []
        ])
        (''TUM''--''i8''--''CoffeeMachine''--Leaf)" by eval
     lemma "valid_hierarchy_pos (Department ''TUM'' [Department ''i8'' [Department ''CoffeeMachine'' [], Department ''TeaMachine'' []], Department ''i20'' []])
        (''TUM''--''i8''--''CleanKitchen''--Leaf) = False" by eval

     (*end tree*)

  instantiation domainNameDept :: order
  begin
    print_context

    fun less_eq_domainNameDept :: "domainNameDept \<Rightarrow> domainNameDept \<Rightarrow> bool" where
      "Leaf \<le> (Dept _ _) = False" |
      "(Dept _ _) \<le> Leaf = True" |
      "Leaf \<le> Leaf = True" |
      "(Dept n1 n1s) \<le> (Dept n2 n2s) = (n1=n2 \<and> n1s \<le> n2s)"

    fun less_domainNameDept :: "domainNameDept \<Rightarrow> domainNameDept \<Rightarrow> bool" where
      "Leaf < Leaf = False" |
      "Leaf < (Dept _ _) = False" |
      "(Dept _ _) < Leaf = True" |
      "(Dept n1 n1s) < (Dept n2 n2s) = (n1=n2 \<and> n1s < n2s)"

    lemma Leaf_Top: "a \<le> Leaf"
      apply(case_tac a)
      by(simp_all)

    lemma Leaf_Top_Unique: "Leaf \<le> a = (a = Leaf)"
      apply(case_tac a)
      by(simp_all)

    lemma no_Bot: "n1 \<noteq> n2 \<Longrightarrow> z \<le> n1 -- n1s \<Longrightarrow> z \<le> n2 -- n2s \<Longrightarrow> False"
      apply(case_tac z)
      by(simp_all)

    lemma uncomparable_sup_is_Top: "n1 \<noteq> n2 \<Longrightarrow> n1 -- x \<le> z \<Longrightarrow> n2 -- y \<le> z \<Longrightarrow> z = Leaf"
      apply(case_tac z)
      by(simp_all)

   lemma common_inf_imp_comparable: "(z::domainNameDept) \<le> a \<Longrightarrow> z \<le> b \<Longrightarrow> a \<le> b \<or> b \<le> a"
      apply(induction z arbitrary: a b)
       apply(rename_tac zn zdpt a b)
       apply(simp_all add: Leaf_Top_Unique)
      apply(case_tac a)
       apply(rename_tac an adpt)
       apply(simp_all add: Leaf_Top)
      apply(case_tac b)
       apply(rename_tac bn bdpt)
       apply(simp_all add: Leaf_Top)
      done

    lemma prepend_domain: "a \<le> b \<Longrightarrow> x--a \<le> x--b"
      by(simp)
    lemma unfold_dmain_leq: "y \<le> zn -- zns \<Longrightarrow> \<exists>yns. y = zn -- yns \<and> yns \<le> zns"
      proof -
        assume a1: "y \<le> zn -- zns"
        obtain sk\<^sub>3\<^sub>0 :: "domainNameDept \<Rightarrow> char list" and sk\<^sub>3\<^sub>1 :: "domainNameDept \<Rightarrow> domainNameDept" where "\<forall>x\<^sub>0. sk\<^sub>3\<^sub>0 x\<^sub>0 -- sk\<^sub>3\<^sub>1 x\<^sub>0 = x\<^sub>0 \<or> Leaf = x\<^sub>0"
          by (metis domainNameDept.exhaust)
        thus "\<exists>yns. y = zn -- yns \<and> yns \<le> zns"
          using a1 by (metis less_eq_domainNameDept.simps(1) less_eq_domainNameDept.simps(4))
      qed

    lemma less_eq_refl:
      fixes x :: domainNameDept
      shows "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
      proof -
      have "x \<le> y \<longrightarrow> y \<le> z \<longrightarrow> x \<le> z" (*induction over prems and conclusion*)
        proof(induction z arbitrary:x y)
        case Leaf
          have "x \<le> Leaf" using Leaf_Top by simp
          thus ?case by simp
        next
        case (Dept zn zns)
          show ?case proof(clarify)
            assume a1: "x \<le> y" and a2: "y \<le> zn--zns"
            from unfold_dmain_leq[OF a2] obtain yns where y1: "y = zn--yns" and y2: "yns \<le> zns" by auto
            from unfold_dmain_leq this a1 obtain xns where x1: "x = zn -- xns" and x2: "xns \<le> yns" by blast
            from Dept y2 x2 have "xns \<le> zns" by simp
            from this x1 show "x \<le> zn--zns" by simp
          qed
        qed
      thus "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z" by simp
      qed

    instance
      proof
        fix x y ::domainNameDept
        show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
          apply(induction rule: less_domainNameDept.induct)
           apply(simp_all)
          by blast
      next
        fix x::domainNameDept
        show "x \<le> x"
          using[[show_types]] apply(induction x)
          by simp_all
      next
        fix x y z :: domainNameDept
        show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z " apply (rule less_eq_refl) by simp_all
      next
        fix x y ::domainNameDept
        show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
          apply(induction rule: less_domainNameDept.induct)
             by(simp_all)
    qed
  end

  instantiation domainNameDept :: Orderings.top
  begin
    definition top_domainNameDept where "Orderings.top \<equiv> Leaf"
    instance
      by intro_classes
  end

    lemma "(''TUM''--''BLUBB''--Leaf) \<le> (''TUM''--Leaf)" by eval

    lemma "(''TUM''--''i8''--Leaf) \<le> (''TUM''--Leaf)" by eval
    lemma "\<not> (''TUM''--Leaf) \<le> (''TUM''--''i8''--Leaf)"  by eval
    lemma "valid_hierarchy_pos (Department ''TUM'' [Department ''i8'' [], Department ''i20'' []]) (''TUM''--''i8''--Leaf)" by eval

    lemma "(''TUM''--Leaf) \<le> Leaf" by eval
    lemma "valid_hierarchy_pos (Department ''TUM'' [Department ''i8'' [], Department ''i20'' []]) (Leaf)" by eval

    lemma "\<not> Leaf \<le> (''TUM''--Leaf)" by eval
    lemma "valid_hierarchy_pos (Department ''TUM'' [Department ''i8'' [], Department ''i20'' []]) (''TUM''--Leaf)" by eval

    lemma "\<not> (''TUM''--''BLUBB''--Leaf) \<le> (''X''--''TUM''--''BLUBB''--Leaf)" by eval

    lemma "(''TUM''--''i8''--''CoffeeMachine''--Leaf) \<le> (''TUM''--''i8''--Leaf)" by eval
    lemma "(''TUM''--''i8''--Leaf) \<le> (''TUM''--''i8''--Leaf)" by eval
    lemma "(''TUM''--''i8''--''CoffeeMachine''--Leaf) \<le> (''TUM''--Leaf)" by eval
    lemma "(''TUM''--''i8''--''CoffeeMachine''--Leaf) \<le> (Leaf)" by eval
    lemma "\<not> (''TUM''--''i8''--Leaf) \<le> (''TUM''--''i20''--Leaf)" by eval
    lemma "\<not> (''TUM''--''i20''--Leaf) \<le> (''TUM''--''i8''--Leaf)" by eval

  subsubsection \<open>Adding Chop\<close>
  text\<open>by putting entities higher in the hierarchy.\<close>
    fun domainNameDeptChopOne :: "domainNameDept \<Rightarrow> domainNameDept" where
      "domainNameDeptChopOne Leaf = Leaf" |
      "domainNameDeptChopOne (name--Leaf) = Leaf" |
      "domainNameDeptChopOne (name--dpt) = name--(domainNameDeptChopOne dpt)"

    lemma "domainNameDeptChopOne (''i8''--''CoffeeMachine''--Leaf) = ''i8'' -- Leaf" by eval
    lemma "domainNameDeptChopOne (''i8''--''CoffeeMachine''--''CoffeeSlave''--Leaf) = ''i8'' -- ''CoffeeMachine'' -- Leaf" by eval
    lemma "domainNameDeptChopOne Leaf = Leaf" by(fact domainNameDeptChopOne.simps(1))

    theorem chopOne_not_decrease: "dn \<le> domainNameDeptChopOne dn"
      apply(induction dn)
       apply(rename_tac name dpt)
       apply(drule_tac x="name" in prepend_domain)
       apply(case_tac dpt)
        apply simp_all
    done

    lemma chopOneContinue: "dpt \<noteq> Leaf \<Longrightarrow> domainNameDeptChopOne (name -- dpt) = name -- domainNameDeptChopOne (dpt)"
    apply(case_tac dpt)
     by simp_all

    fun domainNameChop :: "domainNameDept \<Rightarrow> nat \<Rightarrow> domainNameDept" where
      "domainNameChop Leaf _ = Leaf" |
      "domainNameChop namedpt 0 = namedpt" |
      "domainNameChop namedpt (Suc n) = domainNameChop (domainNameDeptChopOne namedpt) n"

    lemma "domainNameChop (''i8''--''CoffeeMachine''--Leaf) 2 = Leaf" by eval
    lemma "domainNameChop (''i8''--''CoffeeMachine''--''CoffeeSlave''--Leaf) 2 = ''i8''--Leaf" by eval
    lemma "domainNameChop (''i8''--Leaf) 0 = ''i8''--Leaf" by eval
    lemma "domainNameChop (Leaf) 8 = Leaf" by eval

    lemma chop0[simp]: "domainNameChop dn 0 = dn"
     apply(case_tac dn)
      by simp_all

    lemma "(domainNameDeptChopOne^^2) (''d1''--''d2''--''d3''--Leaf) = ''d1''--Leaf" by eval

    text \<open>domainNameChop is equal to applying n times chop one\<close>
    lemma domainNameChopFunApply: "domainNameChop dn n = (domainNameDeptChopOne^^n) dn"
      apply(induction dn n rule: domainNameChop.induct)
        apply (simp_all)
      apply(rename_tac nat,induct_tac nat, simp_all)
      apply(rename_tac n)
      by (metis funpow_swap1)

    lemma domainNameChopRotateSuc: "domainNameChop dn (Suc n) = domainNameDeptChopOne (domainNameChop dn n)"
    by(simp add: domainNameChopFunApply)

    lemma domainNameChopRotate: "domainNameChop (domainNameDeptChopOne dn) n = domainNameDeptChopOne (domainNameChop dn n)"
      apply(subgoal_tac "domainNameChop (domainNameDeptChopOne dn) n = domainNameChop dn (Suc n)")
       apply simp
       apply(simp add: domainNameChopFunApply)
      apply(case_tac dn)
       by(simp_all)

    theorem chop_not_decrease_hierarchy: "dn \<le> domainNameChop dn n"
      apply(induction n)
       apply(simp)
       apply(case_tac dn)
       apply(rename_tac name dpt)
       apply (simp)
       apply(simp add:domainNameChopRotate)
       apply (metis chopOne_not_decrease less_eq_refl)
      apply simp
     done

    corollary "dn \<le> domainNameDeptChopOne ((domainNameDeptChopOne ^^ n) (dn))"
    by (metis chop_not_decrease_hierarchy domainNameChopFunApply domainNameChopRotateSuc)

   text\<open>compute maximum common level of both inputs\<close>
   fun chop_sup :: "domainNameDept \<Rightarrow> domainNameDept \<Rightarrow> domainNameDept" where
      "chop_sup Leaf _ = Leaf" |
      "chop_sup _ Leaf = Leaf" |
      "chop_sup (a--as) (b--bs) = (if a \<noteq> b then Leaf else a--(chop_sup as bs))"

   lemma "chop_sup (''a''--''b''--''c''--Leaf) (''a''--''b''--''d''--Leaf) = ''a'' -- ''b'' -- Leaf" by eval
   lemma "chop_sup (''a''--''b''--''c''--Leaf) (''a''--''x''--''d''--Leaf) = ''a'' -- Leaf" by eval
   lemma "chop_sup (''a''--''b''--''c''--Leaf) (''x''--''x''--''d''--Leaf) = Leaf" by eval

   lemma chop_sup_commute: "chop_sup a b = chop_sup b a"
    apply(induction a b rule: chop_sup.induct)
      apply(rename_tac a)
      apply(simp_all)
    apply(case_tac a, simp_all)
    done
  lemma chop_sup_max1: "a \<le> chop_sup a b"
    apply(induction a b rule: chop_sup.induct)
      by(simp_all)
  lemma chop_sup_max2: "b \<le> chop_sup a b"
    apply(subst chop_sup_commute)
    by(simp add: chop_sup_max1)

   (* don't need this, preserver \<le> on domainNameDept and \<sqsubseteq> on domainName
   instantiation domainNameDept :: partial_order
   begin
     fun leq_domainNameDept :: "domainNameDept \<Rightarrow> domainNameDept \<Rightarrow> bool" (* \<sqsubseteq> *) where
      "leq_domainNameDept a b = (a \<le> b)"
   instance
      by(intro_classes,simp_all)
   end
   *)
   lemma chop_sup_is_sup: "\<forall>z. a \<le> z \<and> b \<le> z \<longrightarrow> chop_sup a b \<le> z"
    apply(clarify)
    apply(induction a b rule: chop_sup.induct)
      apply(simp_all)
    apply(rule conjI)
     apply(clarify)
     apply(subgoal_tac "z=Leaf")
      apply(simp)
     apply(simp add: uncomparable_sup_is_Top)
    apply(clarify)
    apply(case_tac z)
     by(simp_all)

  datatype domainName = DN domainNameDept | Unassigned

  subsubsection \<open>Makeing it a complete Lattice\<close>
    instantiation domainName :: partial_order
    begin
      (* adding trust here would violate transitivity or antsymmetry *)
      fun leq_domainName :: "domainName \<Rightarrow> domainName \<Rightarrow> bool" (* \<sqsubseteq> *) where
        "leq_domainName Unassigned _ = True" |
        "leq_domainName _ Unassigned = False" |
        "leq_domainName (DN dnA) (DN dnB) = (dnA \<le> dnB)"
    instance
      apply(intro_classes)
      (* x \<sqsubseteq> x *)
        apply(case_tac x)
       apply(simp_all)
      (* x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z *)
       apply(case_tac x, rename_tac dnX)
        apply(case_tac y, rename_tac dnY)
         apply(case_tac z, rename_tac dnZ)
          apply(simp_all)
      (* x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y *)
      apply(case_tac x, rename_tac dnX)
       apply(case_tac y, rename_tac dnY)
        apply(simp_all)
      apply(metis domainName.exhaust leq_domainName.simps(2))
      done
    end

    lemma "is_Inf {Unassigned, DN Leaf} Unassigned"
      by(simp add: is_Inf_def)

    text \<open>The infinum of two elements:\<close>
    fun DN_inf :: "domainName \<Rightarrow> domainName \<Rightarrow> domainName" where
      "DN_inf Unassigned _ = Unassigned" |
      "DN_inf _ Unassigned = Unassigned" |
      "DN_inf (DN a) (DN b) = (if a \<le> b then DN a else if b \<le> a then DN b else Unassigned)"

    lemma "DN_inf (DN (''TUM''--''i8''--Leaf)) (DN (''TUM''--''i20''--Leaf)) = Unassigned" by eval
    lemma "DN_inf (DN (''TUM''--''i8''--Leaf)) (DN (''TUM''--Leaf)) = DN (''TUM'' -- ''i8'' -- Leaf)" by eval

    lemma DN_inf_commute: "DN_inf x y = DN_inf y x"
      apply(induction x y rule: DN_inf.induct)
        apply(rename_tac x)
        apply(case_tac x)
         by (simp_all)

    lemma DN_inf_is_inf: "is_inf x y (DN_inf x y)"
      apply(induction x y rule: DN_inf.induct)
        apply(simp add: is_inf_def)
       apply(simp add: is_inf_def)
      apply(simp add: is_inf_def)
      apply(clarify)
      apply(rename_tac z)
      apply(case_tac z)
       apply(simp)
       apply(rename_tac zn)
       apply(simp_all)
      using common_inf_imp_comparable by blast

    fun DN_sup :: "domainName \<Rightarrow> domainName \<Rightarrow> domainName" where
      "DN_sup Unassigned a = a" |
      "DN_sup a Unassigned = a" |
      "DN_sup (DN a) (DN b) = DN (chop_sup a b)"

    lemma DN_sup_commute: "DN_sup x y = DN_sup y x"
      apply(induction x y rule: DN_sup.induct)
        apply(rename_tac x)
        apply(case_tac x)
         by(simp_all add: chop_sup_commute)

    lemma DN_sup_is_sup: "is_sup x y (DN_sup x y)"
      apply(induction x y rule: DN_inf.induct)
        apply(simp add: is_sup_def leq_refl)
       apply(simp add: is_sup_def)
      apply(simp add: is_sup_def chop_sup_max1 chop_sup_max2)
      apply(clarify)
      apply(rename_tac z)
      apply(case_tac z)
       apply(simp)
       apply(rename_tac zn)
       apply(simp_all)
      apply(clarify)
      apply(simp add: chop_sup_is_sup)
      done

    text \<open>domainName is a Lattice:\<close>
    instantiation domainName :: lattice
      begin
      instance
        apply intro_classes
         apply(rule_tac x="DN_inf x y" in exI)
         apply(fact DN_inf_is_inf)
        apply(rule_tac x="DN_sup x y" in exI)
        apply(rule DN_sup_is_sup)
       done
    end

(*TRUST*)

  datatype domainNameTrust = DN "(domainNameDept \<times> nat)" | Unassigned

    (*transitivity only if trustA \<ge> trust C*)
    fun leq_domainNameTrust :: "domainNameTrust \<Rightarrow> domainNameTrust \<Rightarrow> bool" (infixr "\<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t" 65)  where
      "leq_domainNameTrust Unassigned _ = True" |
      "leq_domainNameTrust _ Unassigned = False" |
      "leq_domainNameTrust (DN (dnA, trustA)) (DN (dnB, trustB)) = (dnA \<le> (domainNameChop dnB trustB))"

    lemma leq_domainNameTrust_refl: "x \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t x"
      apply(case_tac x)
       apply(rename_tac prod)
       apply(case_tac prod)
       apply(simp add: chop_not_decrease_hierarchy)
      by(simp)

   lemma leq_domainNameTrust_NOT_trans: "\<exists>x y z. x \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t y \<and> y \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t z \<and> \<not> x \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t z"
    apply(rule_tac x="DN (''TUM''--Leaf, 0)" in exI)
    apply(rule_tac x="DN (''TUM''--''i8''--Leaf, 1)" in exI)
    apply(rule_tac x="DN (''TUM''--''i8''--Leaf, 0)" in exI)
    apply(simp)
    done

   lemma leq_domainNameTrust_NOT_antisym: "\<exists>x y. x \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t y \<and> y \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t x \<and> x \<noteq> y"
    apply(rule_tac x="DN (Leaf, 3)" in exI)
    apply(rule_tac x="DN (Leaf, 4)" in exI)
    apply(simp)
    done

subsubsection\<open>The network security invariant\<close>

definition default_node_properties :: "domainNameTrust"
  where  "default_node_properties = Unassigned"

text\<open>The sender is, noticing its trust level, on the same or higher hierarchy level as the receiver.\<close>
fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> domainNameTrust) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (s, r) \<in> edges G. (nP r) \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t (nP s))"

(*TODO: old legacy function!*)
text\<open>a domain name must be in the supplied tree\<close>
fun verify_globals :: "'v graph \<Rightarrow> ('v \<Rightarrow> domainNameTrust) \<Rightarrow> domainTree \<Rightarrow> bool" where
  "verify_globals G nP tree = (\<forall> v \<in> nodes G.
    case (nP v) of Unassigned \<Rightarrow> True | DN (level, trust) \<Rightarrow> valid_hierarchy_pos tree level
   )"

lemma "verify_globals \<lparr> nodes=set [1,2,3], edges=set [] \<rparr> (\<lambda>n. default_node_properties) (Department ''TUM'' [])"
  by (simp add: default_node_properties_def)

definition receiver_violation :: "bool" where "receiver_violation = False"

thm SecurityInvariant_withOffendingFlows.sinvar_mono_def

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF wf_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto)[4]
   apply(auto simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops)[1]
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_sinvar_mono[OF sinvar_mono])
 apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
done

subsubsection \<open>ENF\<close>
  lemma DomainHierarchyNG_ENF: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form sinvar (\<lambda> s r. r \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t s)"
    unfolding SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_def
    by simp
  lemma DomainHierarchyNG_ENF_refl: "SecurityInvariant_withOffendingFlows.ENF_refl sinvar (\<lambda> s r. r \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t s)"
    unfolding SecurityInvariant_withOffendingFlows.ENF_refl_def
    apply(rule conjI)
     apply(simp add: DomainHierarchyNG_ENF)
    apply(simp add: leq_domainNameTrust_refl)
  done
  lemma unassigned_default_candidate: "\<forall>nP s r. \<not> (nP r)  \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t (nP s) \<longrightarrow> \<not> (nP r)  \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t default_node_properties"
    apply(clarify)
    apply (simp add: default_node_properties_def)
    by (metis leq_domainNameTrust.elims(3) leq_domainNameTrust.simps(2))

  definition DomainHierarchyNG_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> domainNameTrust) \<Rightarrow> ('v \<times> 'v) set set" where
  "DomainHierarchyNG_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> \<not> (nP e2) \<sqsubseteq>\<^sub>t\<^sub>r\<^sub>u\<^sub>s\<^sub>t (nP e1)} })"
  lemma DomainHierarchyNG_offending_set: "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = DomainHierarchyNG_offending_set"
    apply(simp only: fun_eq_iff SecurityInvariant_withOffendingFlows.ENF_offending_set[OF DomainHierarchyNG_ENF] DomainHierarchyNG_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(auto split:prod.split_asm prod.split simp add: Let_def)
  done

  lemma Unassigned_unique_default: "otherbot \<noteq> default_node_properties \<Longrightarrow>
         \<exists>G nP gP i f.
            wf_graph G \<and>
            \<not> sinvar G nP \<and>
            f \<in> SecurityInvariant_withOffendingFlows.set_offending_flows sinvar G nP \<and>
            sinvar (delete_edges G f) nP \<and>
            (i \<in> fst ` f \<and> sinvar G (nP(i := otherbot)))"
    apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
        SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
        SecurityInvariant_withOffendingFlows.is_offending_flows_def)
    apply (simp add:graph_ops)
    apply (simp split: prod.split_asm prod.split domainNameTrust.split)
    apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
    apply(rule conjI)
     apply(simp add: wf_graph_def)
    apply(case_tac otherbot)
     apply(rename_tac prod)
     apply(case_tac prod)
     apply(rename_tac dn trustlevel)
     apply(clarify)

     apply(case_tac dn)

    (* case (name -- dpt, trustlevel)  *)
      apply(rename_tac name dpt)
      apply(simp)
      apply(rule_tac x="(\<lambda> x. default_node_properties)(vertex_1 := Unassigned, vertex_2 := DN (name--dpt, 0 ))" in exI, simp)
      apply(rule_tac x="vertex_1" in exI, simp)
      apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
      apply(simp add:chop_not_decrease_hierarchy)

    (* case (Leaf, trustlevel)*)
     apply(simp)
     apply(rule_tac x="(\<lambda> x. default_node_properties)(vertex_1 := Unassigned, vertex_2 := DN (Leaf, 0))" in exI, simp)
     apply(rule_tac x="vertex_1" in exI, simp)
     apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)

    (* case Unassigned *)
    apply(simp add: default_node_properties_def)
   done

interpretation DomainHierarchyNG: SecurityInvariant_ACS
where default_node_properties = default_node_properties
and sinvar = sinvar
rewrites "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = DomainHierarchyNG_offending_set"
  apply unfold_locales
    apply(rule ballI)
    apply(drule SecurityInvariant_withOffendingFlows.ENF_fsts_refl_instance[OF DomainHierarchyNG_ENF_refl unassigned_default_candidate], simp_all)[1]
   apply(erule default_uniqueness_by_counterexample_ACS)
   apply(drule Unassigned_unique_default)
   apply(simp)
  apply(fact DomainHierarchyNG_offending_set)
 done

lemma TopoS_DomainHierarchyNG: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by(unfold_locales)

hide_const (open) sinvar receiver_violation

end


header{*Theory of Events for Security Protocols against the General Attacker*}

theory EventGA imports MessageGA begin

consts  (*Initial states of agents -- parameter of the construction*)
  initState :: "agent => msg set"

datatype
  event = Says  agent agent msg
        | Gets  agent       msg
        | Notes agent       msg

primrec knows  :: "agent => event list => msg set" where
   knows_Nil:   "knows A [] = initState A"
 | knows_Cons:
    "knows A (ev # evs) =
        (case ev of
           Says A' B X \<Rightarrow> insert X (knows A evs)
         | Gets A' X   \<Rightarrow> knows A evs
         | Notes A' X  \<Rightarrow>
             if A'=A then insert X (knows A evs) else knows A evs)"

primrec
  (*Set of items that might be visible to somebody:
    complement of the set of fresh items*)
 used :: "event list => msg set" where
   used_Nil:   "used []         = (UN B. parts (initState B))"
 | used_Cons:  "used (ev # evs) =
                     (case ev of
                        Says A B X => parts {X} \<union> used evs
                      | Gets A X   => used evs
                      | Notes A X  => parts {X} \<union> used evs)"
    --{*The case for @{term Gets} seems anomalous, but @{term Gets} always
        follows @{term Says} in real protocols.  Seems difficult to change.
        See @{text Gets_correct} in theory @{text "Guard/Extensions.thy"}. *}

lemma Notes_imp_used [rule_format]: "Notes A X \<in> set evs --> X \<in> used evs"
apply (induct_tac evs)
apply (auto split: event.split)
done

lemma Says_imp_used [rule_format]: "Says A B X \<in> set evs --> X \<in> used evs"
apply (induct_tac evs)
apply (auto split: event.split)
done

subsection{*Function @{term knows}*}

lemmas parts_insert_knows_A = parts_insert [of _ "knows A evs"] for A evs

lemma knows_Says [simp]:
     "knows A (Says A' B X # evs) = insert X (knows A evs)"
by simp

lemma knows_Notes [simp]:
     "knows A (Notes A' X # evs) =
          (if A=A' then insert X (knows A evs) else knows A evs)"
by simp

lemma knows_Gets [simp]: "knows A (Gets A' X # evs) = knows A evs"
by simp

text{*Everybody sees what is sent on the traffic*}
lemma Says_imp_knows [rule_format]:
     "Says A' B X \<in> set evs --> (\<forall>A. X \<in> knows A evs)"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split add: event.split)
apply auto
done

lemma Notes_imp_knows [rule_format]:
"Notes A' X \<in> set evs --> X \<in> knows A' evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split add: event.split)
done

text{*Elimination rules: derive contradictions from old Says events containing
  items known to be fresh*}
lemmas Says_imp_parts_knows =
       Says_imp_knows [THEN parts.Inj, THEN revcut_rl]

lemmas knows_partsEs =
     Says_imp_parts_knows parts.Body [THEN revcut_rl]

lemmas Says_imp_analz = Says_imp_knows [THEN analz.Inj]

subsection{*Knowledge of generic agents*}

lemma knows_subset_knows_Says: "knows A evs \<subseteq> knows A (Says A' B X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Notes: "knows A evs \<subseteq> knows A (Notes A' X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Gets: "knows A evs \<subseteq> knows A (Gets A' X # evs)"
by (simp add: subset_insertI)

lemma knows_imp_Says_Gets_Notes_initState [rule_format]:
     "X \<in> knows A evs ==> EX A' B.
  Says A' B X \<in> set evs | Notes A X \<in> set evs | X \<in> initState A"
apply (erule rev_mp)
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split add: event.split)
apply auto
done

lemma parts_knows_subset_used: "parts (knows A evs) \<subseteq> used evs"
apply (induct_tac "evs", force)
apply (simp add: parts_insert_knows_A add: event.split, blast)
done

lemmas usedI = parts_knows_subset_used [THEN subsetD, intro]

lemma initState_into_used: "X \<in> parts (initState B) ==> X \<in> used evs"
apply (induct_tac "evs")
apply (simp_all add: parts_insert_knows_A split add: event.split, blast)
done

lemma used_Says [simp]: "used (Says A B X # evs) = parts{X} \<union> used evs"
by simp

lemma used_Notes [simp]: "used (Notes A X # evs) = parts{X} \<union> used evs"
by simp

lemma used_Gets [simp]: "used (Gets A X # evs) = used evs"
by simp

lemma used_nil_subset: "used [] \<subseteq> used evs"
apply simp
apply (blast intro: initState_into_used)
done

text{*NOTE REMOVAL--laws above are cleaner, as they don't involve "case"*}
declare knows_Cons [simp del]
        used_Nil [simp del] used_Cons [simp del]

lemmas analz_mono_contra =
       knows_subset_knows_Says [THEN analz_mono, THEN contra_subsetD]
       knows_subset_knows_Notes [THEN analz_mono, THEN contra_subsetD]
       knows_subset_knows_Gets [THEN analz_mono, THEN contra_subsetD]

lemma knows_subset_knows_Cons: "knows A evs \<subseteq> knows A (e # evs)"
by (induct e, auto simp: knows_Cons)

lemma initState_subset_knows: "initState A \<subseteq> knows A evs"
apply (induct_tac evs, simp)
apply (blast intro: knows_subset_knows_Cons [THEN subsetD])
done

text{*For proving @{text new_keys_not_used}*}
lemma keysFor_parts_insert:
     "[| K \<in> keysFor (parts (insert X G));  X \<in> synth (analz H) |]
      ==> K \<in> keysFor (parts (G \<union> H)) | Key (invKey K) \<in> parts H"
by (force
    dest!: parts_insert_subset_Un [THEN keysFor_mono, THEN [2] rev_subsetD]
           analz_subset_parts [THEN keysFor_mono, THEN [2] rev_subsetD]
    intro: analz_subset_parts [THEN subsetD] parts_mono [THEN [2] rev_subsetD])

lemmas analz_impI = impI [where P = "Y \<notin> analz (knows A evs)"] for A evs

ML
{*
val analz_mono_contra_tac =
  rtac @{thm analz_impI} THEN'
  REPEAT1 o (dresolve_tac @{thms analz_mono_contra})
  THEN' mp_tac
*}

method_setup analz_mono_contra = {*
    Scan.succeed (K (SIMPLE_METHOD (REPEAT_FIRST analz_mono_contra_tac))) *}
    "for proving theorems of the form X \<notin> analz (knows A evs) --> P"

text{*Useful for case analysis on whether a hash is a spoof or not*}

lemmas syan_impI = impI [where P = "Y \<notin> synth (analz (knows A evs))"] for Y A evs

ML
{*
val synth_analz_mono_contra_tac =
  rtac @{thm syan_impI} THEN'
  REPEAT1 o
    (dresolve_tac
     [@{thm knows_subset_knows_Says} RS @{thm synth_analz_mono} RS @{thm contra_subsetD},
      @{thm knows_subset_knows_Notes} RS @{thm synth_analz_mono} RS @{thm contra_subsetD},
      @{thm knows_subset_knows_Gets} RS @{thm synth_analz_mono} RS @{thm contra_subsetD}])
  THEN'
  mp_tac
*}

method_setup synth_analz_mono_contra = {*
    Scan.succeed (K (SIMPLE_METHOD (REPEAT_FIRST synth_analz_mono_contra_tac))) *}
    "for proving theorems of the form X \<notin> synth (analz (knows A evs)) --> P"

end


theory Mask
  imports PosRat
begin

section \<open>Definitions\<close>

type_synonym field = string
type_synonym address = nat
type_synonym heap_loc = "address \<times> field"

type_synonym mask = "heap_loc \<Rightarrow> prat"
type_synonym bmask = "heap_loc \<Rightarrow> bool"

definition null where "null = 0"

definition full_mask :: "mask" where
  "full_mask hl = (if fst hl = null then pnone else pwrite)"

definition multiply_mask :: "prat \<Rightarrow> mask \<Rightarrow> mask" where
  "multiply_mask p \<pi> hl = pmult p (\<pi> hl)"

fun empty_mask where
  "empty_mask hl = pnone"

fun empty_bmask where
  "empty_bmask hl = False"

fun add_acc where "add_acc \<pi> hl p = \<pi>(hl := padd (\<pi> hl) p)"

inductive rm_acc where
  "\<pi> hl = padd p r \<Longrightarrow> rm_acc \<pi> hl p (\<pi>(hl := r))"

fun add_masks where
  "add_masks \<pi>' \<pi> hl = padd (\<pi>' hl) (\<pi> hl)"

definition greater_mask where
  "greater_mask \<pi>' \<pi> \<longleftrightarrow> (\<exists>r. \<pi>' = add_masks \<pi> r)"

fun uni_mask where
  "uni_mask hl p = empty_mask(hl := p)"

fun valid_mask :: "mask \<Rightarrow> bool" where
  "valid_mask \<pi> \<longleftrightarrow> (\<forall>hl. pgte pwrite (\<pi> hl)) \<and> (\<forall>f. \<pi> (null, f) = pnone)"

definition valid_null :: "mask \<Rightarrow> bool" where
  "valid_null \<pi> \<longleftrightarrow> (\<forall>f. \<pi> (null, f) = pnone)"

definition equal_on_mask where
  "equal_on_mask \<pi> h h' \<longleftrightarrow> (\<forall>hl. ppos (\<pi> hl) \<longrightarrow> h hl = h' hl)"

definition equal_on_bmask where
  "equal_on_bmask \<pi> h h' \<longleftrightarrow> (\<forall>hl. \<pi> hl \<longrightarrow> h hl = h' hl)"

definition big_add_masks where
  "big_add_masks \<Pi> \<Pi>' h = add_masks (\<Pi> h) (\<Pi>' h)"

definition big_greater_mask where
  "big_greater_mask \<Pi> \<Pi>' \<longleftrightarrow> (\<forall>h. greater_mask (\<Pi> h) (\<Pi>' h))"

definition greater_bmask where
  "greater_bmask H H' \<longleftrightarrow> (\<forall>h. H' h \<longrightarrow> H h)"

definition update_dm where
  "update_dm dm \<pi> \<pi>' hl \<longleftrightarrow> (dm hl \<or> pgt (\<pi> hl) (\<pi>' hl))"

fun pre_get_m where "pre_get_m \<phi> = fst \<phi>"
fun pre_get_h where "pre_get_h \<phi> = snd \<phi>"
fun srm_acc where "srm_acc \<phi> hl p = (rm_acc (pre_get_m \<phi>) hl p, pre_get_h \<phi>)"

datatype val = Bool (the_bool: bool) | Address (the_address: address) | Rat (the_rat: prat)

definition upper_bounded :: "mask \<Rightarrow> prat \<Rightarrow> bool" where
  "upper_bounded \<pi> p \<longleftrightarrow> (\<forall>hl. pgte p (\<pi> hl))"

section \<open>Lemmas\<close>

lemma ssubsetI:
  assumes "\<And>\<pi> h. (\<pi>, h) \<in> A \<Longrightarrow> (\<pi>, h) \<in> B"
  shows "A \<subseteq> B"
  using assms by auto

lemma double_inclusion:
  assumes "A \<subseteq> B"
      and "B \<subseteq> A"
    shows "A = B"
  using assms by blast

lemma add_masks_comm:
  "add_masks a b = add_masks b a"
proof (rule ext)
  fix x show "add_masks a b x = add_masks b a x"
    by (metis Rep_prat_inverse add.commute add_masks.simps padd.rep_eq)
qed

lemma add_masks_asso:
  "add_masks (add_masks a b) c = add_masks a (add_masks b c)"
proof (rule ext)
  fix x show "add_masks (add_masks a b) c x = add_masks a (add_masks b c) x"
    by (metis Rep_prat_inverse add.assoc add_masks.simps padd.rep_eq)
qed

lemma minus_empty:
  "\<pi> = add_masks \<pi> empty_mask"
proof (rule ext)
  fix x show "\<pi> x = add_masks \<pi> empty_mask x"
    by (metis Rep_prat_inverse add.right_neutral add_masks.simps empty_mask.simps padd.rep_eq pnone.rep_eq)
qed

lemma add_acc_uni_mask:
  "add_acc \<pi> hl p = add_masks \<pi> (uni_mask hl p)"
proof (rule ext)
  fix x show "add_acc \<pi> hl p x = add_masks \<pi> (uni_mask hl p) x"
    by (metis (no_types, opaque_lifting) add_acc.simps add_masks.simps fun_upd_apply minus_empty uni_mask.simps)
qed

lemma add_masks_equiv_valid_null:
  "valid_null (add_masks a b) \<longleftrightarrow> valid_null a \<and> valid_null b"
  by (metis (mono_tags, lifting) add_masks.simps padd_zero valid_null_def)

lemma valid_maskI:
  assumes "\<And>hl. pgte pwrite (\<pi> hl)"
      and "\<And>f. \<pi> (null, f) = pnone"
    shows "valid_mask \<pi>"
  by (simp add: assms(1) assms(2))

lemma greater_mask_equiv_def:
  "greater_mask \<pi>' \<pi> \<longleftrightarrow> (\<forall>hl. pgte (\<pi>' hl) (\<pi> hl))"
  (is "?A \<longleftrightarrow> ?B")
proof (rule iffI)
  show "?A \<Longrightarrow> ?B"
  proof (clarify)
    fix hl assume "greater_mask \<pi>' \<pi>"
    then obtain r where "\<pi>' = add_masks \<pi> r"
      using greater_mask_def by blast
    then show "pgte (\<pi>' hl) (\<pi> hl)"
      using Rep_prat padd.rep_eq pgte.rep_eq by auto
  qed
  show "?B \<Longrightarrow> ?A"
  proof -
    assume ?B
    let ?r = "\<lambda>hl. (SOME p. \<pi>' hl = padd (\<pi> hl) p)"
    have "\<pi>' = add_masks \<pi> ?r"
    proof (rule ext)
      fix hl
      have "\<pi>' hl = padd (\<pi> hl) (?r hl)"
        by (meson \<open>\<forall>hl. pgte (\<pi>' hl) (\<pi> hl)\<close> p_greater_exists someI_ex)
      then show "\<pi>' hl = add_masks \<pi> ?r hl"
        by auto
    qed
    then show ?A
      using greater_mask_def by blast
  qed
qed

lemma greater_maskI:
  assumes "\<And>hl. pgte (\<pi>' hl) (\<pi> hl)"
  shows "greater_mask \<pi>' \<pi>"
  by (simp add: assms greater_mask_equiv_def)

lemma greater_mask_properties:
  "greater_mask \<pi> \<pi>"
  "greater_mask a b \<and> greater_mask b c \<Longrightarrow> greater_mask a c"
  "greater_mask \<pi>' \<pi> \<and> greater_mask \<pi> \<pi>' \<Longrightarrow> \<pi> = \<pi>'"
  apply (simp add: greater_maskI pgte.rep_eq)
  apply (metis add_masks_asso greater_mask_def)
proof (rule ext)
  fix x assume "greater_mask \<pi>' \<pi> \<and> greater_mask \<pi> \<pi>'"
  show "\<pi> x = \<pi>' x"
    by (meson \<open>greater_mask \<pi>' \<pi> \<and> greater_mask \<pi> \<pi>'\<close> greater_mask_equiv_def pgte_antisym)
qed

lemma greater_mask_decomp:
  assumes "greater_mask a (add_masks b c)"
  shows "\<exists>a1 a2. a = add_masks a1 a2 \<and> greater_mask a1 b \<and> greater_mask a2 c"
  by (metis add_masks_asso assms greater_mask_def greater_mask_properties(1))

lemma valid_empty:
  "valid_mask empty_mask"
  by (metis empty_mask.simps le_add_same_cancel1 p_greater_exists padd.rep_eq pgte.rep_eq pnone.rep_eq valid_mask.simps)

lemma upper_valid_aux:
  assumes "valid_mask a"
      and "a = add_masks b c"
    shows "valid_mask b"
proof (rule valid_maskI)
  show "\<And>hl. pgte pwrite (b hl)"
    using assms(1) assms(2) p_greater_exists padd_asso by fastforce
  fix f show " b (null, f) = pnone"
    by (metis add_masks_comm assms(1) assms(2) empty_mask.simps greater_mask_def greater_mask_equiv_def minus_empty pgte_antisym valid_mask.simps)
qed

lemma upper_valid:
  assumes "valid_mask a"
      and "a = add_masks b c"
    shows "valid_mask b \<and> valid_mask c"
  using add_masks_comm assms(1) assms(2) upper_valid_aux by blast

lemma equal_on_bmaskI:
  assumes "\<And>hl. \<pi> hl \<Longrightarrow> h hl = h' hl"
  shows "equal_on_bmask \<pi> h h'"
  using assms equal_on_bmask_def by blast

lemma big_add_greater:
  "big_greater_mask (big_add_masks A B) B"
  by (metis add_masks_comm big_add_masks_def big_greater_mask_def greater_mask_def)

lemma big_greater_iff:
  "big_greater_mask A B \<Longrightarrow> (\<exists>C. A = big_add_masks B C)"
proof -
  assume "big_greater_mask A B"
  let ?C = "\<lambda>h. SOME r. A h = add_masks (B h) r"
  have "A = big_add_masks B ?C"
  proof (rule ext)
    fix x
    have "A x = add_masks (B x) (?C x)"
    proof (rule ext)
      fix xa
      have "A x = add_masks (B x) (SOME r. A x = add_masks (B x) r)"
        by (metis (mono_tags, lifting) \<open>big_greater_mask A B\<close> big_greater_mask_def greater_mask_def someI_ex)
      then show "A x xa = add_masks (B x) (SOME r. A x = add_masks (B x) r) xa"
        by auto
    qed
    then show "A x = big_add_masks B (\<lambda>h. SOME r. A h = add_masks (B h) r) x"
      by (metis (no_types, lifting) big_add_masks_def)
  qed
  then show "\<exists>C. A = big_add_masks B C"
    by fast
qed

lemma big_add_masks_asso:
  "big_add_masks A (big_add_masks B C) = big_add_masks (big_add_masks A B) C"
proof (rule ext)
  fix x show "big_add_masks A (big_add_masks B C) x = big_add_masks (big_add_masks A B) C x"
    by (simp add: add_masks_asso big_add_masks_def)
qed

lemma big_add_mask_neutral:
  "big_add_masks \<Pi> (\<lambda>_. empty_mask) = \<Pi>"
proof (rule ext)
  fix x show "big_add_masks \<Pi> (\<lambda>_. empty_mask) x = \<Pi> x"
    by (metis big_add_masks_def minus_empty)
qed

lemma sym_equal_on_mask:
  "equal_on_mask \<pi> a b \<longleftrightarrow> equal_on_mask \<pi> b a"
proof -
  have "\<And>a b. equal_on_mask \<pi> a b \<Longrightarrow> equal_on_mask \<pi> b a"
    by (simp add: equal_on_mask_def)
  then show ?thesis by blast
qed

lemma greater_mask_uni_equiv:
  "greater_mask \<pi> (uni_mask hl r) \<longleftrightarrow> pgte (\<pi> hl) r"
  by (metis add_masks_comm fun_upd_apply greater_mask_def greater_mask_equiv_def minus_empty uni_mask.simps)

lemma greater_mask_uniI:
  assumes "pgte (\<pi> hl) r"
  shows "greater_mask \<pi> (uni_mask hl r)"
  using greater_mask_uni_equiv assms by metis

lemma greater_bmask_refl:
  "greater_bmask H H"
  by (simp add: greater_bmask_def)

lemma greater_bmask_trans:
  assumes "greater_bmask A B"
      and "greater_bmask B C"
    shows "greater_bmask A C"
  by (metis assms(1) assms(2) greater_bmask_def)

lemma update_dm_same:
  "update_dm dm \<pi> \<pi> = dm"
proof (rule ext)
  fix x show "update_dm dm \<pi> \<pi> x = dm x"
    by (simp add: pgt.rep_eq update_dm_def)
qed

lemma update_trans:
  assumes "greater_mask \<pi> \<pi>'"
      and "greater_mask \<pi>' \<pi>''"
  shows "update_dm (update_dm dm \<pi> \<pi>') \<pi>' \<pi>'' = update_dm dm \<pi> \<pi>''"
proof (rule ext)
  fix hl show "update_dm (update_dm dm \<pi> \<pi>') \<pi>' \<pi>'' hl = update_dm dm \<pi> \<pi>'' hl"
  proof -
    have "update_dm (update_dm dm \<pi> \<pi>') \<pi>' \<pi>'' hl \<longleftrightarrow> (update_dm dm \<pi> \<pi>') hl \<or> pgt (\<pi>' hl) (\<pi>'' hl)"
      using update_dm_def by metis
    also have "... \<longleftrightarrow> dm hl \<or> pgt (\<pi> hl) (\<pi>' hl) \<or> pgt (\<pi>' hl) (\<pi>'' hl)"
      using update_dm_def by metis
    moreover have "update_dm dm \<pi> \<pi>'' hl \<longleftrightarrow> dm hl \<or> pgt (\<pi> hl) (\<pi>'' hl)"
      using update_dm_def by metis
    moreover have "pgt (\<pi> hl) (\<pi>' hl) \<or> pgt (\<pi>' hl) (\<pi>'' hl) \<longleftrightarrow> pgt (\<pi> hl) (\<pi>'' hl)"
    proof
      show "pgt (\<pi> hl) (\<pi>' hl) \<or> pgt (\<pi>' hl) (\<pi>'' hl) \<Longrightarrow> pgt (\<pi> hl) (\<pi>'' hl)"
        by (metis assms(1) assms(2) greater_mask_equiv_def greater_mask_properties(2) not_pgte_charact pgte_antisym)
      show "pgt (\<pi> hl) (\<pi>'' hl) \<Longrightarrow> pgt (\<pi> hl) (\<pi>' hl) \<or> pgt (\<pi>' hl) (\<pi>'' hl)"
        by (metis assms(1) greater_mask_equiv_def not_pgte_charact pgte_antisym)
    qed
    ultimately show ?thesis by blast
  qed
qed

lemma equal_on_bmask_greater:
  assumes "equal_on_bmask \<pi>' h h'"
      and "greater_bmask \<pi>' \<pi>"
    shows "equal_on_bmask \<pi> h h'"
  by (metis (mono_tags, lifting) assms(1) assms(2) equal_on_bmask_def greater_bmask_def)

lemma update_dm_equal_bmask:
  assumes "\<pi> = add_masks \<pi>' m"
  shows "equal_on_bmask (update_dm dm \<pi> \<pi>') h' h \<longleftrightarrow> equal_on_mask m h h' \<and> equal_on_bmask dm h h'"
proof -
  have "equal_on_bmask (update_dm dm \<pi> \<pi>') h' h \<longleftrightarrow> (\<forall>hl. update_dm dm \<pi> \<pi>' hl \<longrightarrow> h' hl = h hl)"
    by (simp add: equal_on_bmask_def)
  moreover have "\<And>hl. update_dm dm \<pi> \<pi>' hl \<longleftrightarrow> dm hl \<or> pgt (\<pi> hl) (\<pi>' hl)"
    by (simp add: update_dm_def)
  moreover have "(\<forall>hl. update_dm dm \<pi> \<pi>' hl \<longrightarrow> h' hl = h hl) \<longleftrightarrow> equal_on_mask m h h' \<and> equal_on_bmask dm h h'"
  proof
    show "\<forall>hl. update_dm dm \<pi> \<pi>' hl \<longrightarrow> h' hl = h hl \<Longrightarrow> equal_on_mask m h h' \<and> equal_on_bmask dm h h'"
      by (simp add: assms equal_on_bmask_def equal_on_mask_def padd.rep_eq pgt.rep_eq ppos.rep_eq update_dm_def)
    assume "equal_on_mask m h h' \<and> equal_on_bmask dm h h'"
    then have "\<And>hl. update_dm dm \<pi> \<pi>' hl \<Longrightarrow> h' hl = h hl"
      by (metis (full_types) add.right_neutral add_masks.simps assms dual_order.strict_iff_order equal_on_bmask_def equal_on_mask_def padd.rep_eq pgt.rep_eq pnone.rep_eq ppos_eq_pnone update_dm_def)
    then show "\<forall>hl. update_dm dm \<pi> \<pi>' hl \<longrightarrow> h' hl = h hl"
      by simp
  qed
  then show ?thesis
    by (simp add: calculation)
qed

lemma const_sum_mask_greater:
  assumes "add_masks a b = add_masks c d"
      and "greater_mask a c"
    shows "greater_mask d b"
proof (rule ccontr)
  assume "\<not> greater_mask d b"
  then obtain hl where "\<not> pgte (d hl) (b hl)"
    using greater_mask_equiv_def by blast
  then have "pgt (b hl) (d hl)"
    using not_pgte_charact by auto
  then have "pgt (padd (a hl) (b hl)) (padd (c hl) (d hl))"
    by (metis assms(2) greater_mask_equiv_def padd_comm pgte_pgt)
  then show "False"
    by (metis add_masks.simps assms(1) not_pgte_charact order_refl pgte.rep_eq)
qed

lemma add_masks_cancellative:
  assumes "add_masks b c = add_masks b d"
    shows "c = d"
proof (rule ext)
  fix x show "c x = d x"
    by (metis assms(1) const_sum_mask_greater greater_mask_properties(1) greater_mask_properties(3))
qed

lemma equal_on_maskI:
  assumes "\<And>hl. ppos (\<pi> hl) \<Longrightarrow> h hl = h' hl"
  shows "equal_on_mask \<pi> h h'"
  by (simp add: assms equal_on_mask_def)

lemma greater_equal_on_mask:
  assumes "equal_on_mask \<pi>' h h'"
      and "greater_mask \<pi>' \<pi>"
    shows "equal_on_mask \<pi> h h'"
proof (rule equal_on_maskI)
  fix hl assume asm: "ppos (\<pi> hl)"
  then show "h hl = h' hl"
    by (metis assms(1) assms(2) equal_on_mask_def greater_mask_equiv_def less_le_trans pgte.rep_eq ppos.rep_eq)
qed

lemma equal_on_mask_sum:
  "equal_on_mask \<pi>1 h h' \<and> equal_on_mask \<pi>2 h h' \<longleftrightarrow> equal_on_mask (add_masks \<pi>1 \<pi>2) h h'"
proof
  show "equal_on_mask (add_masks \<pi>1 \<pi>2) h h' \<Longrightarrow> equal_on_mask \<pi>1 h h' \<and> equal_on_mask \<pi>2 h h'"
    using add_masks_comm greater_equal_on_mask greater_mask_def by blast
  assume "equal_on_mask \<pi>1 h h' \<and> equal_on_mask \<pi>2 h h'"
  show "equal_on_mask (add_masks \<pi>1 \<pi>2) h h'"
  proof (rule equal_on_maskI)
    fix hl assume "ppos (add_masks \<pi>1 \<pi>2 hl)"
    then show "h hl = h' hl"
    proof (cases "ppos (\<pi>1 hl)")
      case True
      then show ?thesis
        by (meson \<open>equal_on_mask \<pi>1 h h' \<and> equal_on_mask \<pi>2 h h'\<close> equal_on_mask_def)
    next
      case False
      then show ?thesis
        by (metis \<open>equal_on_mask \<pi>1 h h' \<and> equal_on_mask \<pi>2 h h'\<close> \<open>ppos (add_masks \<pi>1 \<pi>2 hl)\<close> add_masks.simps equal_on_mask_def padd_zero ppos_eq_pnone)
    qed
  qed
qed

lemma valid_larger_mask:
  "valid_mask \<pi> \<longleftrightarrow> greater_mask full_mask \<pi> "
  by (metis fst_eqD full_mask_def greater_maskI greater_mask_def not_one_le_zero not_pgte_charact pgt_implies_pgte pgte.rep_eq pnone.rep_eq pwrite.rep_eq surjective_pairing upper_valid_aux valid_mask.elims(1))

lemma valid_mask_full_mask:
  "valid_mask full_mask"
  using greater_mask_properties(1) valid_larger_mask by blast

lemma mult_greater:
  assumes "greater_mask a b"
  shows "greater_mask (multiply_mask p a) (multiply_mask p b)"
  by (metis (full_types) assms greater_mask_equiv_def multiply_mask_def p_greater_exists pmult_distr)

lemma mult_write_mask:
  "multiply_mask pwrite \<pi> = \<pi>"
proof (rule ext)
  fix x show "multiply_mask pwrite \<pi> x = \<pi> x"
    by (simp add: multiply_mask_def pmult_special(1))
qed

lemma mult_distr_masks:
  "multiply_mask a (add_masks b c) = add_masks (multiply_mask a b) (multiply_mask a c)"
proof (rule ext)
  fix x show "multiply_mask a (add_masks b c) x = add_masks (multiply_mask a b) (multiply_mask a c) x"
    by (simp add: multiply_mask_def pmult_distr)
qed

lemma mult_add_states:
  "multiply_mask (padd a b) \<pi> = add_masks (multiply_mask a \<pi>) (multiply_mask b \<pi>)"
proof (rule ext)
  fix x show "multiply_mask (padd a b) \<pi> x = add_masks (multiply_mask a \<pi>) (multiply_mask b \<pi>) x"
    by (simp add: multiply_mask_def pmult_comm pmult_distr)
qed

lemma upper_boundedI:
  assumes "\<And>hl. pgte p (\<pi> hl)"
  shows "upper_bounded \<pi> p"
  by (simp add: assms upper_bounded_def)

lemma upper_bounded_smaller:
  assumes "upper_bounded \<pi> a"
  shows "upper_bounded (multiply_mask p \<pi>) (pmult p a)"
  by (metis assms multiply_mask_def p_greater_exists pmult_distr upper_bounded_def)

lemma upper_bounded_bigger:
  assumes "upper_bounded \<pi> a"
      and "pgte b a"
    shows "upper_bounded \<pi> b"
  by (meson assms(1) assms(2) order_trans pgte.rep_eq upper_bounded_def)

lemma valid_mult:
  assumes "valid_mask \<pi>"
      and "pgte pwrite p"
    shows "valid_mask (multiply_mask p \<pi>)"
proof (rule valid_maskI)
  have "upper_bounded \<pi> pwrite"
    using assms(1) upper_bounded_def by auto
  then have "upper_bounded (multiply_mask p \<pi>) (pmult p pwrite)"
    by (simp add: upper_bounded_smaller)
  then show "\<And>hl. pgte pwrite (multiply_mask p \<pi> hl)"
    by (metis assms(2) pmult_comm pmult_special(1) upper_bounded_bigger upper_bounded_def)
  show "\<And>f. multiply_mask p \<pi> (null, f) = pnone"
    by (metis Rep_prat_inverse add_0_left assms(1) multiply_mask_def padd.rep_eq padd_cancellative pmult_distr pnone.rep_eq valid_mask.elims(1))
qed

lemma valid_sum:
  assumes "valid_mask a"
      and "valid_mask b"
      and "upper_bounded a ma"
      and "upper_bounded b mb"
      and "pgte pwrite (padd ma mb)"
    shows "valid_mask (add_masks a b)"
      and "upper_bounded (add_masks a b) (padd ma mb)"
proof (rule valid_maskI)
  show "\<And>hl. pgte pwrite (add_masks a b hl)"
  proof -
    fix hl
    have "pgte (padd ma mb) (add_masks a b hl)"
      by (metis (mono_tags, lifting) add_masks.simps add_mono_thms_linordered_semiring(1) assms(3) assms(4) padd.rep_eq pgte.rep_eq upper_bounded_def)
    then show "pgte pwrite (add_masks a b hl)"
      by (meson assms(5) dual_order.trans pgte.rep_eq)
  qed
  show "\<And>f. add_masks a b (null, f) = pnone"
    by (metis Rep_prat_inverse add_0_left add_masks.simps assms(1) assms(2) padd.rep_eq pnone.rep_eq valid_mask.simps)
  show "upper_bounded (add_masks a b) (padd ma mb)"
    using add_mono_thms_linordered_semiring(1) assms(3) assms(4) padd.rep_eq pgte.rep_eq upper_bounded_def by fastforce
qed

lemma valid_multiply:
  assumes "valid_mask a"
      and "upper_bounded a ma"
      and "pgte pwrite (pmult ma p)"
    shows "valid_mask (multiply_mask p a)"
  by (metis (no_types, opaque_lifting) assms(1) assms(2) assms(3) multiply_mask_def pmult_comm pmult_special(2) upper_bounded_bigger upper_bounded_def upper_bounded_smaller valid_mask.elims(1))

lemma greater_mult:
  assumes "greater_mask a b"
  shows "greater_mask (multiply_mask p a) (multiply_mask p b)"
  by (metis Rep_prat assms greater_mask_equiv_def mem_Collect_eq mult_left_mono multiply_mask_def pgte.rep_eq pmult.rep_eq)

end


(*  Title:      Presburger-Automata/DFS.thy
    Author:     Toshiaki Nishihara and Yasuhiko Minamide
    Author:     Stefan Berghofer and Alex Krauss, TU Muenchen, 2008-2009
    Author:     Peter Gammie (data refinement futz), 2010
*)

(*<*)
theory DFS
imports Main
begin
(*>*)

subsection\<open>Generic DFS\<close>

text\<open>

\label{sec:dfs}

We use a generic DFS to construct the transitions and action function
of the implementation of the JKBP. This theory is largely due to
Stefan Berghofer and Alex Krauss
\citep{DBLP:conf/tphol/BerghoferR09}. All proofs are elided as the
fine details of how we explore the state space are inessential to the
synthesis algorithm.

The DFS itself is defined in the standard tail-recursive way:

\<close>

partial_function (tailrec) gen_dfs where
  "gen_dfs succs ins memb S wl = (case wl of
     [] \<Rightarrow> S
   | (x # xs) \<Rightarrow>
       if memb x S then gen_dfs succs ins memb S xs
       else gen_dfs succs ins memb (ins x S) (succs x @ xs))"
(*<*)
lemma gen_dfs_simps[code, simp]:
  "gen_dfs succs ins memb S [] = S"
  "gen_dfs succs ins memb S (x # xs) =
    (if memb x S then gen_dfs succs ins memb S xs
     else gen_dfs succs ins memb (ins x S) (succs x @ xs))"
  by (simp_all add: gen_dfs.simps)
(*>*)

text_raw\<open>
\begin{figure}
\begin{isabellebody}%
\<close>
locale DFS =
  fixes succs :: "'a \<Rightarrow> 'a list"
  and isNode :: "'a \<Rightarrow> bool"
  and invariant :: "'b \<Rightarrow> bool"
  and ins :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
  and memb :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  and empt :: 'b
  and nodeAbs :: "'a \<Rightarrow> 'c"
  assumes ins_eq: "\<And>x y S. \<lbrakk> isNode x; isNode y; invariant S; \<not> memb y S \<rbrakk>
                       \<Longrightarrow> memb x (ins y S)
                       \<longleftrightarrow> ((nodeAbs x = nodeAbs y) \<or> memb x S)"
  and succs: "\<And>x y. \<lbrakk> isNode x; isNode y; nodeAbs x = nodeAbs y \<rbrakk>
                       \<Longrightarrow> nodeAbs ` set (succs x) = nodeAbs ` set (succs y)"
  and empt: "\<And>x. isNode x \<Longrightarrow> \<not> memb x empt"
  and succs_isNode: "\<And>x. isNode x \<Longrightarrow> list_all isNode (succs x)"
  and empt_invariant: "invariant empt"
  and ins_invariant: "\<And>x S. \<lbrakk> isNode x; invariant S; \<not> memb x S \<rbrakk>
                        \<Longrightarrow> invariant (ins x S)"
  and graph_finite: "finite (nodeAbs ` { x . isNode x})"
text_raw\<open>
\end{isabellebody}%
\begin{isamarkuptext}%
\caption{The \<open>DFS\<close> locale.}
\label{fig:kbps-theory-dfs-locale}
\end{isamarkuptext}%
\end{figure}
\<close>

text\<open>

The proofs are carried out in the locale of
Figure~\ref{fig:kbps-theory-dfs-locale}, which details our
requirements on the parameters for the DFS to behave as one would
expect. Intuitively we are traversing a graph defined by @{term
"succs"} from some initial work list @{term "wl"}, constructing an
object of type @{typ "'b"} as we go. The function @{term "ins"}
integrates the current node into this construction. The predicate
@{term "isNode"} is invariant over the set of states reachable from
the initial work list, and is respected by @{term "empt"} and @{term
"ins"}. We can also supply an invariant for the constructed object
(@{term "invariant"}). Inside the locale, @{term "dfs"} abbreviates
@{term "gen_dfs"} partially applied to the fixed parameters.

To support our data refinement
(\S\ref{sec:kbps-automata-synthesis-alg}) we also require that the
representation of nodes be adequate via the abstraction function
@{term "nodeAbs"}, which the transition relation @{term "succs"} and
visited predicate @{term "memb"} must respect. To ensure termination
it must be the case that there are only a finite number of states,
though there might be an infinity of representations.

We characterise the DFS traversal using the reflexive
transitive closure operator:

\<close>

definition (in DFS) reachable :: "'a set \<Rightarrow> 'a set" where
  "reachable xs \<equiv> {(x, y). y \<in> set (succs x)}\<^sup>* `` xs"
(*<*)

context DFS
begin

definition
  "succss xs \<equiv> \<Union>x\<in>xs. set (succs x)"

definition
  "set_of S \<equiv> {x. isNode x \<and> memb x S}"

abbreviation
  "dfs \<equiv> gen_dfs succs ins memb"

definition rel where
  "rel = inv_image finite_psubset (\<lambda>S. nodeAbs ` {n.  isNode n \<and> \<not> memb n S})"

(* Yuck, something to do with Skolems broke. *)
lemma nodeAbs_subset_grot:
  "\<lbrakk>invariant S; isNode x; list_all isNode xs; \<not>memb x S\<rbrakk>
     \<Longrightarrow> nodeAbs ` {n . isNode n \<and> \<not> memb n (ins x S)}
       \<subset> nodeAbs ` {n . isNode n \<and> \<not> memb n S}"
  apply rule
   apply (auto simp add: ins_eq cong: conj_cong)
  apply (subgoal_tac "nodeAbs x \<in> nodeAbs ` {n. isNode n \<and> \<not> memb n S}")
   apply (subgoal_tac "nodeAbs x \<notin> nodeAbs ` {n. isNode n \<and> nodeAbs n \<noteq> nodeAbs x \<and> \<not> memb n S}")
    apply blast
   apply rule
   apply (erule imageE) back
   apply auto[1]
  apply auto[1]
  done

lemma psubsetI2: "\<lbrakk> A \<subseteq> B; x \<in> A; x \<notin> B\<rbrakk> \<Longrightarrow> A \<subset> B"
  by (unfold less_le) blast

lemma dfs_induct[consumes 2, case_names base step]:
  assumes S: "invariant S"
  and xs: "list_all isNode xs"
  and I1: "\<And>S. invariant S \<Longrightarrow> P S []"
  and I2: "\<And>S x xs. invariant S \<Longrightarrow> isNode x \<Longrightarrow> list_all isNode xs \<Longrightarrow>
    (memb x S \<Longrightarrow> P S xs) \<Longrightarrow> (\<not> memb x S \<Longrightarrow> P (ins x S) (succs x @ xs)) \<Longrightarrow> P S (x # xs)"
  shows "P S xs" using I1 I2 S xs
  apply induction_schema
  apply atomize_elim
  apply (case_tac xs, simp+)
  apply atomize_elim
  apply (rule conjI)
  apply (rule ins_invariant, assumption+)
  apply (rule succs_isNode, assumption)
  apply (relation "rel <*lex*> measure length")
  apply (simp add: wf_lex_prod rel_def)
  apply simp
  apply simp
  apply (rule disjI1)
  apply (simp add: rel_def finite_psubset_def)
  apply (rule conjI)
  apply (erule (3) nodeAbs_subset_grot)
  apply (rule finite_subset[OF _ graph_finite])
  apply auto
  done

lemma visit_subset_dfs: "invariant S \<Longrightarrow> list_all isNode xs \<Longrightarrow>
  isNode y \<Longrightarrow> memb y S \<Longrightarrow> memb y (dfs S xs)"
  by (induct S xs rule: dfs_induct) (simp_all add: ins_eq)

lemma next_subset_dfs: "invariant S \<Longrightarrow> list_all isNode xs \<Longrightarrow>
  x \<in> set xs \<Longrightarrow> memb x (dfs S xs)"
proof (induct S xs rule: dfs_induct)
  case (step S y xs)
  then show ?case
    by (auto simp add: visit_subset_dfs ins_eq ins_invariant succs_isNode)
qed simp

lemma succss_closed_dfs':
  "invariant ys \<Longrightarrow> list_all isNode xs \<Longrightarrow>
   nodeAbs ` succss (set_of ys) \<subseteq> nodeAbs ` (set xs \<union> set_of ys) \<Longrightarrow> nodeAbs ` succss (set_of (dfs ys xs)) \<subseteq> nodeAbs ` set_of (dfs ys xs)"
proof(induct ys xs rule: dfs_induct)
  case (base S) thus ?case by simp
next
  case (step S x xs) thus ?case
    apply (auto simp add: succss_def set_of_def cong: conj_cong)
     apply (subgoal_tac "nodeAbs xa \<in> nodeAbs ` (\<Union>x\<in>{x. isNode x \<and> memb x (dfs S xs)}. set (succs x))")
      apply blast
     apply blast
    apply (subgoal_tac "nodeAbs ` (\<Union>x\<in>{xa. isNode xa \<and> memb xa (ins x S)}. set (succs x)) \<subseteq> nodeAbs ` (set (succs x) \<union> set xs \<union> {xa. isNode xa \<and> memb xa (ins x S)})")
     apply blast
    apply (auto simp add: ins_eq succss_def set_of_def cong: conj_cong)
    apply (subgoal_tac "\<exists>xc'. xc' \<in> set (succs x) \<and> nodeAbs xc' = nodeAbs xc")
     apply clarsimp
     apply (rule_tac x=xc' in image_eqI)
      apply simp
     apply simp
    apply (cut_tac x=xd and y=x in succs)
     apply simp_all
    apply (subgoal_tac "nodeAbs xc \<in> nodeAbs ` set (succs x)")
     apply auto[1]
    apply auto[1]
   apply (subgoal_tac "nodeAbs ` set (succs xd) \<subseteq> nodeAbs ` (\<Union>x\<in>{x. isNode x \<and> memb x S}. set (succs x))")
    defer
    apply auto[1]
   apply (subgoal_tac "nodeAbs xc \<in> nodeAbs ` set (succs xd)")
    defer
    apply auto[1]
   apply (subgoal_tac "nodeAbs xc \<in> insert (nodeAbs x) (nodeAbs ` (set xs \<union> {x. isNode x \<and> memb x S}))")
    defer
    apply (erule rev_subsetD)
    apply (erule subset_trans)
    apply blast
   apply auto
   done
qed

lemma succss_closed_dfs: "list_all isNode xs \<Longrightarrow>
  nodeAbs ` succss (set_of (dfs empt xs)) \<subseteq> nodeAbs ` set_of (dfs empt xs)"
  apply (rule succss_closed_dfs')
  apply (rule empt_invariant)
  apply assumption
  apply (simp add: succss_def)
  apply (rule subsetI)
  apply clarsimp
  unfolding set_of_def
  using empt
  apply clarsimp
  done

definition
  "succsr \<equiv> {(x, y). y \<in> set (succs x)}"

theorem succsr_isNode:
  assumes xy: "(x, y) \<in> succsr\<^sup>*"
  shows "isNode x \<Longrightarrow> isNode y" using xy
proof induct
  case (step y z)
  then have "isNode y" by simp
  then have "list_all isNode (succs y)"
    by (rule succs_isNode)
  with step show ?case
    by (simp add: succsr_def list_all_iff)
qed

lemma succss_closed:
  assumes inc: "nodeAbs ` succss X \<subseteq> nodeAbs ` X"
      and X: "X \<subseteq> { x . isNode x }"
  shows "nodeAbs ` reachable X = nodeAbs ` X"
proof
  show "nodeAbs ` X \<subseteq> nodeAbs ` reachable X"
    unfolding reachable_def by auto
next
  show "nodeAbs ` reachable X \<subseteq> nodeAbs ` X"
  proof(unfold reachable_def, auto)
    fix x y
    assume y: "y \<in> X"
    assume "(y, x) \<in> {(x, y). y \<in> set (succs x)}\<^sup>*"
    thus "nodeAbs x \<in> nodeAbs ` X" using y
    proof induct
      case base thus ?case by simp
    next
      case (step r s)
      from X step have "isNode r"
        using succsr_isNode[where x=y and y=r]
        unfolding succsr_def by fastforce
      with inc step show ?case
        apply clarsimp
        apply (subgoal_tac "isNode x")
         apply (cut_tac x=r and y=x in succs)
         apply auto
         apply (subgoal_tac "nodeAbs s \<in> nodeAbs ` set (succs x)")
         using X
         apply (auto simp: succss_def)
         done
     qed
   qed
qed

lemma dfs_isNode:
  assumes S: "invariant S"
      and xs: "list_all isNode xs"
  shows "set_of (dfs S xs) \<subseteq> {x . isNode x}"
  using assms
  by (induct S xs rule: dfs_induct) (auto simp: set_of_def)

lemma reachable_closed_dfs:
  assumes xs: "list_all isNode xs"
  shows "nodeAbs ` reachable (set xs) \<subseteq> nodeAbs ` set_of (dfs empt xs)"
proof -
  from xs have "reachable (set xs) \<subseteq> reachable (set_of (dfs empt xs))"
    apply (unfold reachable_def)
    apply (rule Image_mono)
    apply (auto simp add: set_of_def next_subset_dfs empt_invariant list_all_iff)
    done
  hence "nodeAbs ` reachable (set xs) \<subseteq> nodeAbs ` reachable (set_of (dfs empt xs))"
    by auto
  also from succss_closed_dfs[OF xs] have "\<dots> = nodeAbs ` set_of (dfs empt xs)"
    apply (rule succss_closed)
    apply (rule dfs_isNode[OF empt_invariant xs])
    done
  finally show ?thesis .
qed

lemma reachable_succs: "reachable (set (succs x)) \<subseteq> reachable {x}"
  by (auto simp add: reachable_def intro: converse_rtrancl_into_rtrancl)

lemma dfs_subset_reachable_visit_nodes:
  "invariant ys \<Longrightarrow> list_all isNode xs \<Longrightarrow>
   nodeAbs ` set_of (dfs ys xs) \<subseteq> nodeAbs ` (reachable (set xs) \<union> set_of ys)"
proof(induct ys xs rule: dfs_induct)
  case (step S x xs)
  show ?case
  proof (cases "memb x S")
    case True
    with step show ?thesis by (auto simp add: reachable_def)
  next
    case False
    have "reachable (set (succs x)) \<subseteq> reachable {x}"
      by (rule reachable_succs)
    then have "reachable (set (succs x @ xs)) \<subseteq> reachable (set (x # xs))"
      by (auto simp add: reachable_def)
    then show ?thesis using step
      apply (auto simp add: reachable_def set_of_def cong: conj_cong)
       apply (subgoal_tac "nodeAbs xa \<in> nodeAbs `
            ({(x, y). y \<in> set (succs x)}\<^sup>* `` set xs \<union>
             {x. isNode x \<and> memb x S})")
        apply auto[1]
       apply auto[1]
      apply (subgoal_tac "nodeAbs xa \<in> nodeAbs `
            ({(x, y). y \<in> set (succs x)}\<^sup>* `` (set (succs x) \<union> set xs) \<union>
             {xa. isNode xa \<and> memb xa (ins x S)})")
       defer
       apply auto[1]
      apply auto[1]
       apply (rule_tac x=xb in image_eqI)
        apply auto[1]
       apply auto[1]
      apply (auto iff: ins_eq)
      done
(* by (auto simp add: reachable_def ins_eq set_of_def cong: conj_cong) *)
  qed
qed (simp add: reachable_def)

theorem dfs_imp_reachable:
  assumes y: "isNode y"
      and xs: "list_all isNode xs"
      and m: "memb y (dfs empt xs)"
  shows "\<exists>y'. nodeAbs y' = nodeAbs y \<and> y' \<in> reachable (set xs)"
proof -
  from m dfs_subset_reachable_visit_nodes [OF empt_invariant xs] y
  obtain y'
    where "nodeAbs y' = nodeAbs y"
      and "y' \<in> reachable (set xs)"
    by (auto simp add: empt set_of_def)
  thus ?thesis by blast
qed

(*>*)
text\<open>

We make use of two results about the traversal. Firstly, that some
representation of each reachable node has been incorporated into the
final construction:

\<close>

theorem (in DFS) reachable_imp_dfs:
  assumes y: "isNode y"
      and xs: "list_all isNode xs"
      and m: "y \<in> reachable (set xs)"
  shows "\<exists>y'. nodeAbs y' = nodeAbs y \<and> memb y' (dfs empt xs)"
(*<*)
  using y m reachable_closed_dfs[OF xs]
  apply (auto simp add: set_of_def)
  apply (drule subsetD[where c="nodeAbs y"])
   apply simp
  apply auto
  done

theorem dfs_invariant' [consumes 2, case_names base step]:
  assumes S: "invariant S"
  and xs: "list_all isNode xs"
  and H: "I S"
  and I: "\<And>S x. \<not> memb x S \<Longrightarrow> isNode x \<Longrightarrow> invariant S \<Longrightarrow> I S \<Longrightarrow> I (ins x S)"
  shows "I (dfs S xs)"
proof -
  from S xs H
  have "I (dfs S xs) \<and> invariant (dfs S xs)"
  proof (induct S xs rule: dfs_induct)
    case (step S x xs)
    show ?case
    proof (cases "memb x S")
      case False
      then show ?thesis
        apply simp
        apply (rule step)
        apply assumption
        apply (rule I)
        apply assumption
        apply (rule step)+
        done
    qed (simp add: step)
  qed simp
  then show ?thesis ..
qed

end (* context DFS *)
(*>*)

text\<open>

Secondly, that if an invariant holds on the initial object then it
holds on the final one:

\<close>

theorem (in DFS) dfs_invariant:
  assumes "invariant S"
  assumes "list_all isNode xs"
  shows "invariant (dfs S xs)"
(*<*)
  using assms
  by (induct S xs rule: dfs_induct) auto
(*>*)

text\<open>

\FloatBarrier

\<close>

(*<*)
end
(*>*)


theory JackEvaluation
imports JackLanguage
begin

datatype "value" =
  IntV int
| BoolV bool
| CharV char
| NullV
| ArrayV "value list"
| ObjV "variable \<rightharpoonup> value"

inductive typecheck_value :: "value \<Rightarrow> type \<Rightarrow> bool" where
  [simp]: "typecheck_value (IntV i) IntT"
| [simp]: "typecheck_value (BoolV b) BoolT"
| [simp]: "typecheck_value (CharV b) CharT"
| [simp]: "typecheck_value NullV (ObjT x)"
| [simp]: "\<forall>v \<in> set vs. typecheck_value v t \<Longrightarrow> typecheck_value (ArrayV vs) (ArrayT t)"
| [simp]: "typecheck_value (ObjV fs) (ObjT x)"

inductive eval_binop :: "binop \<Rightarrow> value \<Rightarrow> value \<Rightarrow> value \<Rightarrow> bool" where
  [simp]: "eval_binop Plus (IntV i1) (IntV i2) (IntV (i1 + i2))"
| [simp]: "eval_binop Minus (IntV i1) (IntV i2) (IntV (i1 - i2))"
| [simp]: "eval_binop Times (IntV i1) (IntV i2) (IntV (i1 * i2))"
| [simp]: "eval_binop Div (IntV i1) (IntV i2) (IntV (i1 div i2))"
| [simp]: "eval_binop And (BoolV b1) (BoolV b2) (BoolV (b1 \<and> b2))"
| [simp]: "eval_binop Or (BoolV b1) (BoolV b2) (BoolV (b1 \<or> b2))"
| [simp]: "eval_binop Eq (IntV i1) (IntV i2) (BoolV (i1 = i2))"
| [simp]: "eval_binop Eq (BoolV b1) (BoolV b2) (BoolV (b1 = b2))"
| [simp]: "eval_binop Eq (CharV c1) (CharV c2) (BoolV (c1 = c2))"
| [simp]: "eval_binop Gt (IntV i1) (IntV i2) (BoolV (i1 > i2))"
| [simp]: "eval_binop Lt (IntV i1) (IntV i2) (BoolV (i1 < i2))"

inductive eval_expr :: "(variable \<rightharpoonup> value) \<Rightarrow> value \<Rightarrow> expression \<Rightarrow> value \<Rightarrow> bool" where
  "eval_expr \<Gamma> this (IConst i) (IntV i)"
| "eval_expr \<Gamma> this (BConst b) (BoolV b)"
| "eval_expr \<Gamma> this (CConst c) (CharV c)"
| "\<Gamma> x = Some v \<Longrightarrow> eval_expr \<Gamma> this (Var x) v"
| "eval_expr \<Gamma> this This this"
| "eval_expr \<Gamma> this Null NullV"
| "eval_expr \<Gamma> this e1 (ArrayV vs) \<Longrightarrow> eval_expr \<Gamma> this e2 (IntV n) \<Longrightarrow>
    eval_expr \<Gamma> this (Index e1 e2) (vs ! nat n)"
| "eval_expr \<Gamma> this e (ObjV fs) \<Longrightarrow> fs x = Some v \<Longrightarrow> eval_expr \<Gamma> this (Field e x) v"
| "eval_expr \<Gamma> this (Call e x es) undefined"
| "eval_expr \<Gamma> this e (IntV i) \<Longrightarrow> eval_expr \<Gamma> this (Negate e) (IntV (-i))"
| "eval_expr \<Gamma> this e (BoolV b) \<Longrightarrow> eval_expr \<Gamma> this (Not e) (BoolV (\<not>b))"
| "eval_expr \<Gamma> this e1 v1 \<Longrightarrow> eval_expr \<Gamma> this e2 v2 \<Longrightarrow> eval_binop b v1 v2 v \<Longrightarrow>
    eval_expr \<Gamma> this (Binop b e1 e2) v"

(* safety *)

lemma canonical_int [elim]: "typecheck_value v IntT \<Longrightarrow> \<exists>i. v = IntV i"
  by (induction v "IntT" rule: typecheck_value.induct) simp_all

lemma canonical_bool [elim]: "typecheck_value v BoolT \<Longrightarrow> \<exists>b. v = BoolV b"
  by (induction v "BoolT" rule: typecheck_value.induct) simp_all

lemma canonical_char [elim]: "typecheck_value v CharT \<Longrightarrow> \<exists>c. v = CharV c"
  by (induction v "CharT" rule: typecheck_value.induct) simp_all

end


(* Author: Andreas Lochbihler, ETH Zurich
   Author: Joshua Schneider, ETH Zurich *)

section \<open>Quotient preservation\<close>

theory Quotient_Preservation imports
  Axiomatised_BNF_CC
begin

lemma G_Quotient:
  fixes T_l1 :: "'l1 \<Rightarrow> 'l1' \<Rightarrow> bool" and T_l2 :: "'l2 \<Rightarrow> 'l2' \<Rightarrow> bool"
    and tytok :: "('l1 \<times> 'l1' \<times> 'l1 \<times> 'l2 \<times> 'l2' \<times> 'l2 \<times> 'f) itself"
  assumes "Quotient R_l1 Abs_l1 Rep_l1 T_l1" and "Quotient R_l2 Abs_l2 Rep_l2 T_l2"
    and "Quotient R_co1 Abs_co1 Rep_co1 T_co1" and "Quotient R_co2 Abs_co2 Rep_co2 T_co2"
    and "Quotient R_contra1 Abs_contra1 Rep_contra1 T_contra1"
    and "Quotient R_contra2 Abs_contra2 Rep_contra2 T_contra2"
    and "rel_G_pos_distr_cond T_co1 T_co1\<inverse>\<inverse> T_co2 T_co2\<inverse>\<inverse> T_contra1 T_contra1\<inverse>\<inverse> T_contra2 T_contra2\<inverse>\<inverse>
      tytok"
  shows "Quotient (rel_G R_l1 R_l2 R_co1 R_co2 R_contra1 R_contra2)
    (map_G Abs_l1 Abs_l2 Abs_co1 Abs_co2 Rep_contra1 Rep_contra2)
    (map_G Rep_l1 Rep_l2 Rep_co1 Rep_co2 Abs_contra1 Abs_contra2)
    (rel_G T_l1 T_l2 T_co1 T_co2 T_contra1 T_contra2 :: (_, _, _, _, _, _, 'f) G \<Rightarrow> _)"
  unfolding Quotient_alt_def5
proof (intro conjI, goal_cases)
  case 1
  have "rel_G T_l1 T_l2 T_co1 T_co2 T_contra1 T_contra2 \<le>
    rel_G (Grp UNIV Abs_l1) (Grp UNIV Abs_l2) (Grp UNIV Abs_co1) (Grp UNIV Abs_co2)
    (Grp UNIV Rep_contra1)\<inverse>\<inverse> (Grp UNIV Rep_contra2)\<inverse>\<inverse>"
    apply (rule rel_G_mono)
         apply (rule assms(1-4)[unfolded Quotient_alt_def5, THEN conjunct1])+
     apply (rule assms(5-6)[unfolded Quotient_alt_def5, THEN conjunct2, THEN conjunct1,
          unfolded conversep_le_swap])+
    done
  also have "... = Grp UNIV (map_G Abs_l1 Abs_l2 Abs_co1 Abs_co2 Rep_contra1 Rep_contra2)"
    using rel_G_Grp_weak .
  finally show ?case .
next
  case 2
  have "Grp UNIV (map_G Rep_l1 Rep_l2 Rep_co1 Rep_co2 Abs_contra1 Abs_contra2) =
    rel_G (Grp UNIV Rep_l1) (Grp UNIV Rep_l2) (Grp UNIV Rep_co1) (Grp UNIV Rep_co2)
    (Grp UNIV Abs_contra1)\<inverse>\<inverse> (Grp UNIV Abs_contra2)\<inverse>\<inverse>"
    using rel_G_Grp_weak[symmetric] .
  also have "... \<le> rel_G T_l1\<inverse>\<inverse> T_l2\<inverse>\<inverse> T_co1\<inverse>\<inverse> T_co2\<inverse>\<inverse> T_contra1\<inverse>\<inverse> T_contra2\<inverse>\<inverse>"
    apply (rule rel_G_mono)
         apply (rule assms(1-4)[unfolded Quotient_alt_def5, THEN conjunct2, THEN conjunct1])+
     apply (simp_all)
     apply (rule assms(5-6)[unfolded Quotient_alt_def5, THEN conjunct1])+
    done
  finally show ?case by (simp add: rel_G_conversep)
next
  case 3
  show ?case
    apply (rule antisym)
     apply (rule predicate2I)
     apply (rule relcomppI)
      apply (subst map_G_id[symmetric])
      apply (erule map_G_rel_cong)
           apply (simp_all)[6]
           apply (erule assms(1-4)[THEN Quotient_equiv_abs1])+
       apply (erule assms(5-6)[THEN Quotient_rep_equiv1])+
     apply (subst rel_G_conversep[symmetric])
    subgoal for x y
      apply (subgoal_tac "map_G Abs_l1 Abs_l2 Abs_co1 Abs_co2 Rep_contra1 Rep_contra2 y =
        map_G Abs_l1 Abs_l2 Abs_co1 Abs_co2 Rep_contra1 Rep_contra2 x")
       apply (simp)
       apply (subst (3) map_G_id[symmetric])
       apply (erule map_G_rel_cong)
            apply (simp_all)
            apply (erule assms(1-4)[THEN Quotient_equiv_abs2])+
        apply (erule assms(5-6)[THEN Quotient_rep_equiv2])+
      apply (rule sym)
      apply (subst rel_G_eq[symmetric])
      apply (erule map_G_rel_cong)
           apply (erule assms(1-4)[THEN Quotient_rel_abs])+
       apply (simp, rule assms(5-6)[THEN Quotient_rep_reflp])+
      done
    apply (unfold rel_G_conversep[symmetric]
        assms(1-6)[unfolded Quotient_alt_def5, THEN conjunct2, THEN conjunct2])
    apply (rule rel_G_pos_distr)
    apply (rule assms(7))
    done
qed

end