(*  Title:      Miscellaneous.thy
    Author:     Andreas Viktor Hess, DTU
    SPDX-License-Identifier: BSD-3-Clause
*)

section \<open>Miscellaneous Lemmata\<close>
theory Miscellaneous
imports Main "HOL-Library.Sublist" "HOL-Library.While_Combinator"
begin

subsection \<open>List: zip, filter, map\<close>
lemma zip_arg_subterm_split:
  assumes "(x,y) \<in> set (zip xs ys)"
  obtains xs' xs'' ys' ys'' where "xs = xs'@x#xs''" "ys = ys'@y#ys''" "length xs' = length ys'"
proof -
  from assms have "\<exists>zs zs' vs vs'. xs = zs@x#zs' \<and> ys = vs@y#vs' \<and> length zs = length vs"
  proof (induction ys arbitrary: xs)
    case (Cons y' ys' xs)
    then obtain x' xs' where x': "xs = x'#xs'"
      by (metis empty_iff list.exhaust list.set(1) set_zip_leftD)
    show ?case
      by (cases "(x, y) \<in> set (zip xs' ys')",
          metis \<open>xs = x'#xs'\<close> Cons.IH[of xs'] Cons_eq_appendI list.size(4),
          use Cons.prems x' in fastforce)
  qed simp
  thus ?thesis using that by blast
qed

lemma zip_arg_index:
  assumes "(x,y) \<in> set (zip xs ys)"
  obtains i where "xs ! i = x" "ys ! i = y" "i < length xs" "i < length ys"
proof -
  obtain xs1 xs2 ys1 ys2 where "xs = xs1@x#xs2" "ys = ys1@y#ys2" "length xs1 = length ys1"
    using zip_arg_subterm_split[OF assms] by moura
  thus ?thesis using nth_append_length[of xs1 x xs2] nth_append_length[of ys1 y ys2] that by simp
qed

lemma in_set_zip_swap: "(x,y) \<in> set (zip xs ys) \<longleftrightarrow> (y,x) \<in> set (zip ys xs)"
unfolding in_set_zip by auto

lemma filter_nth: "i < length (filter P xs) \<Longrightarrow> P (filter P xs ! i)"
using nth_mem by force

lemma list_all_filter_eq: "list_all P xs \<Longrightarrow> filter P xs = xs"
by (metis list_all_iff filter_True)

lemma list_all_filter_nil:
  assumes "list_all P xs"
    and "\<And>x. P x \<Longrightarrow> \<not>Q x"
  shows "filter Q xs = []"
using assms by (induct xs) simp_all

lemma list_all_concat: "list_all (list_all f) P \<longleftrightarrow> list_all f (concat P)"
by (induct P) auto

lemma list_all2_in_set_ex:
  assumes P: "list_all2 P xs ys"
    and x: "x \<in> set xs"
  shows "\<exists>y \<in> set ys. P x y"
proof -
  obtain i where i: "i < length xs" "xs ! i = x" by (meson x in_set_conv_nth)
  have "i < length ys" "P (xs ! i) (ys ! i)"
    using P i(1) by (simp_all add: list_all2_iff list_all2_nthD)
  thus ?thesis using i(2) by auto
qed

lemma list_all2_in_set_ex':
  assumes P: "list_all2 P xs ys"
    and y: "y \<in> set ys"
  shows "\<exists>x \<in> set xs. P x y"
proof -
  obtain i where i: "i < length ys" "ys ! i = y" by (meson y in_set_conv_nth)
  have "i < length xs" "P (xs ! i) (ys ! i)"
    using P i(1) by (simp_all add: list_all2_iff list_all2_nthD)
  thus ?thesis using i(2) by auto
qed

lemma list_all2_sym:
  assumes "\<And>x y. P x y \<Longrightarrow> P y x"
    and "list_all2 P xs ys"
  shows "list_all2 P ys xs"
using assms(2) by (induct rule: list_all2_induct) (simp_all add: assms(1))

lemma map_upt_index_eq:
  assumes "j < length xs"
  shows "(map (\<lambda>i. xs ! is i) [0..<length xs]) ! j = xs ! is j"
using assms by (simp add: map_nth)

lemma map_snd_list_insert_distrib:
  assumes "\<forall>(i,p) \<in> insert x (set xs). \<forall>(i',p') \<in> insert x (set xs). p = p' \<longrightarrow> i = i'"
  shows "map snd (List.insert x xs) = List.insert (snd x) (map snd xs)"
using assms
proof (induction xs rule: List.rev_induct)
  case (snoc y xs)
  hence IH: "map snd (List.insert x xs) = List.insert (snd x) (map snd xs)" by fastforce

  obtain iy py where y: "y = (iy,py)" by (metis surj_pair)
  obtain ix px where x: "x = (ix,px)" by (metis surj_pair)

  have "(ix,px) \<in> insert x (set (y#xs))" "(iy,py) \<in> insert x (set (y#xs))" using y x by auto
  hence *: "iy = ix" when "py = px" using that snoc.prems by auto

  show ?case
  proof (cases "px = py")
    case True
    hence "y = x" using * y x by auto
    thus ?thesis using IH by simp
  next
    case False
    hence "y \<noteq> x" using y x by simp
    have "List.insert x (xs@[y]) = (List.insert x xs)@[y]"
    proof -
      have 1: "insert y (set xs) = set (xs@[y])" by simp
      have 2: "x \<notin> insert y (set xs) \<or> x \<in> set xs" using \<open>y \<noteq> x\<close> by blast
      show ?thesis using 1 2 by (metis (no_types) List.insert_def append_Cons insertCI)
    qed
    thus ?thesis using IH y x False by (auto simp add: List.insert_def)
  qed
qed simp

lemma map_append_inv: "map f xs = ys@zs \<Longrightarrow> \<exists>vs ws. xs = vs@ws \<and> map f vs = ys \<and> map f ws = zs"
proof (induction xs arbitrary: ys zs)
  case (Cons x xs')
  note prems = Cons.prems
  note IH = Cons.IH

  show ?case
  proof (cases ys)
    case (Cons y ys')
    then obtain vs' ws where *: "xs' = vs'@ws" "map f vs' = ys'" "map f ws = zs"
      using prems IH[of ys' zs] by auto
    hence "x#xs' = (x#vs')@ws" "map f (x#vs') = y#ys'" using Cons prems by force+
    thus ?thesis by (metis Cons *(3))
  qed (use prems in simp)
qed simp

lemma map2_those_Some_case:
  assumes "those (map2 f xs ys) = Some zs"
    and "(x,y) \<in> set (zip xs ys)"
  shows "\<exists>z. f x y = Some z"
  using assms
proof (induction xs arbitrary: ys zs)
  case (Cons x' xs')
  obtain y' ys' where ys: "ys = y'#ys'" using Cons.prems(2) by (cases ys) simp_all
  obtain z where z: "f x' y' = Some z" using Cons.prems(1) ys by fastforce
  obtain zs' where zs: "those (map2 f xs' ys') = Some zs'" using z Cons.prems(1) ys by auto

  show ?case
  proof (cases "(x,y) = (x',y')")
    case False
    hence "(x,y) \<in> set (zip xs' ys')" using Cons.prems(2) unfolding ys by force
    thus ?thesis using Cons.IH[OF zs] by blast
  qed (use ys z in fast)
qed simp

lemma those_Some_Cons_ex:
  assumes "those (x#xs) = Some ys"
  shows "\<exists>y ys'. ys = y#ys' \<and> those xs = Some ys' \<and> x = Some y"
using assms by (cases x) auto

lemma those_Some_iff:
  "those xs = Some ys \<longleftrightarrow> ((\<forall>x' \<in> set xs. \<exists>x. x' = Some x) \<and> ys = map the xs)"
  (is "?A xs ys \<longleftrightarrow> ?B xs ys")
proof
  show "?A xs ys \<Longrightarrow> ?B xs ys"
  proof (induction xs arbitrary: ys)
    case (Cons x' xs')
    obtain y' ys' where ys: "ys = y'#ys'" "those xs' = Some ys'" and x: "x' = Some y'"
      using Cons.prems those_Some_Cons_ex by blast
    show ?case using Cons.IH[OF ys(2)] unfolding x ys by simp
  qed simp

  show "?B xs ys \<Longrightarrow> ?A xs ys"
    by (induct xs arbitrary: ys) (simp, fastforce)
qed

lemma those_map2_SomeD:
  assumes "those (map2 f ts ss) = Some \<theta>"
    and "\<sigma> \<in> set \<theta>"
  shows "\<exists>(t,s) \<in> set (zip ts ss). f t s = Some \<sigma>"
using those_Some_iff[of "map2 f ts ss" \<theta>] assms by fastforce

lemma those_map2_SomeI:
  assumes "\<And>i. i < length xs \<Longrightarrow> f (xs ! i) (ys ! i) = Some (g i)"
    and "length xs = length ys"
  shows "those (map2 f xs ys) = Some (map g [0..<length xs])"
proof -
  have "\<forall>z \<in> set (map2 f xs ys). \<exists>z'. z = Some z'"
  proof
    fix z assume z: "z \<in> set (map2 f xs ys)"
    then obtain i where i: "i < length xs" "i < length ys" "z = f (xs ! i) (ys ! i)"
      using in_set_conv_nth[of z "map2 f xs ys"] by auto
    thus "\<exists>z'. z = Some z'"
      using assms(1) by blast
  qed
  moreover have "map Some (map g [0..<length xs]) = map (\<lambda>i. f (xs ! i) (ys ! i)) [0..<length xs]"
    using assms by auto
  hence "map Some (map g [0..<length xs]) = map2 f xs ys"
    using assms by (smt map2_map_map map_eq_conv map_nth)
  hence "map (the \<circ> Some) (map g [0..<length xs]) = map the (map2 f xs ys)"
    by (metis map_map)
  hence "map g [0..<length xs] = map the (map2 f xs ys)"
    by simp
  ultimately show ?thesis using those_Some_iff by blast
qed

subsection \<open>List: subsequences\<close>
lemma subseqs_set_subset:
  assumes "ys \<in> set (subseqs xs)"
  shows "set ys \<subseteq> set xs"
using assms subseqs_powset[of xs] by auto

lemma subset_sublist_exists:
  "ys \<subseteq> set xs \<Longrightarrow> \<exists>zs. set zs = ys \<and> zs \<in> set (subseqs xs)"
proof (induction xs arbitrary: ys)
  case Cons thus ?case by (metis (no_types, lifting) Pow_iff imageE subseqs_powset)
qed simp

lemma map_subseqs: "map (map f) (subseqs xs) = subseqs (map f xs)"
proof (induct xs)
  case (Cons x xs)
  have "map (Cons (f x)) (map (map f) (subseqs xs)) = map (map f) (map (Cons x) (subseqs xs))"
    by (induct "subseqs xs") auto
  thus ?case by (simp add: Let_def Cons)
qed simp

lemma subseqs_Cons:
  assumes "ys \<in> set (subseqs xs)"
  shows "ys \<in> set (subseqs (x#xs))"
by (metis assms Un_iff set_append subseqs.simps(2))

lemma subseqs_subset:
  assumes "ys \<in> set (subseqs xs)"
  shows "set ys \<subseteq> set xs"
using assms by (metis Pow_iff image_eqI subseqs_powset)

subsection \<open>List: prefixes, suffixes\<close>
lemma suffix_Cons': "suffix [x] (y#ys) \<Longrightarrow> suffix [x] ys \<or> (y = x \<and> ys = [])"
using suffix_Cons[of "[x]"] by auto

lemma prefix_Cons': "prefix (x#xs) (x#ys) \<Longrightarrow> prefix xs ys"
by simp

lemma prefix_map: "prefix xs (map f ys) \<Longrightarrow> \<exists>zs. prefix zs ys \<and> map f zs = xs"
using map_append_inv unfolding prefix_def by fast

lemma concat_mono_prefix: "prefix xs ys \<Longrightarrow> prefix (concat xs) (concat ys)"
unfolding prefix_def by fastforce

lemma concat_map_mono_prefix: "prefix xs ys \<Longrightarrow> prefix (concat (map f xs)) (concat (map f ys))"
by (rule map_mono_prefix[THEN concat_mono_prefix])

lemma length_prefix_ex:
  assumes "n \<le> length xs"
  shows "\<exists>ys zs. xs = ys@zs \<and> length ys = n"
  using assms
proof (induction n)
  case (Suc n)
  then obtain ys zs where IH: "xs = ys@zs" "length ys = n" by moura
  hence "length zs > 0" using Suc.prems(1) by auto
  then obtain v vs where v: "zs = v#vs" by (metis Suc_length_conv gr0_conv_Suc)
  hence "length (ys@[v]) = Suc n" using IH(2) by simp
  thus ?case using IH(1) v by (metis append.assoc append_Cons append_Nil)
qed simp

lemma length_prefix_ex':
  assumes "n < length xs"
  shows "\<exists>ys zs. xs = ys@xs ! n#zs \<and> length ys = n"
proof -
  obtain ys zs where xs: "xs = ys@zs" "length ys = n" using assms length_prefix_ex[of n xs] by moura
  hence "length zs > 0" using assms by auto
  then obtain v vs where v: "zs = v#vs" by (metis Suc_length_conv gr0_conv_Suc)
  hence "(ys@zs) ! n = v" using xs by auto
  thus ?thesis using v xs by auto
qed

lemma length_prefix_ex2:
  assumes "i < length xs" "j < length xs" "i < j"
  shows "\<exists>ys zs vs. xs = ys@xs ! i#zs@xs ! j#vs \<and> length ys = i \<and> length zs = j - i - 1"
by (smt assms length_prefix_ex' nth_append append.assoc append.simps(2) add_diff_cancel_left'
        diff_Suc_1 length_Cons length_append)

lemma prefix_prefix_inv:
  assumes xs: "prefix xs (ys@zs)"
    and x: "suffix [x] xs"
  shows "prefix xs ys \<or> x \<in> set zs"
proof -
  have "prefix xs ys" when "x \<notin> set zs" using that xs
  proof (induction zs rule: rev_induct)
    case (snoc z zs) show ?case
    proof (rule snoc.IH)
      have "x \<noteq> z" using snoc.prems(1) by simp
      thus "prefix xs (ys@zs)"
        using snoc.prems(2) x by (metis append1_eq_conv append_assoc prefix_snoc suffixE)
    qed (use snoc.prems(1) in simp)
  qed simp
  thus ?thesis by blast
qed

lemma prefix_snoc_obtain:
  assumes xs: "prefix (xs@[x]) (ys@zs)"
    and ys: "\<not>prefix (xs@[x]) ys"
  obtains vs where "xs@[x] = ys@vs@[x]" "prefix (vs@[x]) zs"
proof -
  have "\<exists>vs. xs@[x] = ys@vs@[x] \<and> prefix (vs@[x]) zs" using xs
  proof (induction zs rule: List.rev_induct)
    case (snoc z zs)
    show ?case
    proof (cases "xs@[x] = ys@zs@[z]")
      case False
      hence "prefix (xs@[x]) (ys@zs)" using snoc.prems by (metis append_assoc prefix_snoc)
      thus ?thesis using snoc.IH by auto
    qed simp
  qed (simp add: ys)
  thus ?thesis using that by blast
qed

lemma prefix_snoc_in_iff: "x \<in> set xs \<longleftrightarrow> (\<exists>B. prefix (B@[x]) xs)"
by (induct xs rule: List.rev_induct) auto

subsection \<open>List: products\<close>
lemma product_lists_Cons:
  "x#xs \<in> set (product_lists (y#ys)) \<longleftrightarrow> (xs \<in> set (product_lists ys) \<and> x \<in> set y)"
by auto

lemma product_lists_in_set_nth:
  assumes "xs \<in> set (product_lists ys)"
  shows "\<forall>i<length ys. xs ! i \<in> set (ys ! i)"
proof -
  have 0: "length ys = length xs" using assms(1) by (simp add: in_set_product_lists_length)
  thus ?thesis using assms
  proof (induction ys arbitrary: xs)
    case (Cons y ys)
    obtain x xs' where xs: "xs = x#xs'" using Cons.prems(1) by (metis length_Suc_conv)
    hence "xs' \<in> set (product_lists ys) \<Longrightarrow> \<forall>i<length ys. xs' ! i \<in> set (ys ! i)"
          "length ys = length xs'" "x#xs' \<in> set (product_lists (y#ys))"
      using Cons by simp_all
    thus ?case using xs product_lists_Cons[of x xs' y ys] by (simp add: nth_Cons')
  qed simp
qed

lemma product_lists_in_set_nth':
  assumes "\<forall>i<length xs. ys ! i \<in> set (xs ! i)"
    and "length xs = length ys"
  shows "ys \<in> set (product_lists xs)"
using assms
proof (induction xs arbitrary: ys)
  case (Cons x xs)
  obtain y ys' where ys: "ys = y#ys'" using Cons.prems(2) by (metis length_Suc_conv)
  hence "ys' \<in> set (product_lists xs)" "y \<in> set x" "length xs = length ys'"
    using Cons by fastforce+
  thus ?case using ys product_lists_Cons[of y ys' x xs] by (simp add: nth_Cons')
qed simp

subsection \<open>Other Lemmata\<close>
lemma finite_ballI:
  "\<forall>l \<in> {}. P l" "P x \<Longrightarrow> \<forall>l \<in> xs. P l \<Longrightarrow> \<forall>l \<in> insert x xs. P l"
by (blast, blast)

lemma list_set_ballI:
  "\<forall>l \<in> set []. P l" "P x \<Longrightarrow> \<forall>l \<in> set xs. P l \<Longrightarrow> \<forall>l \<in> set (x#xs). P l"
by (simp, simp)

lemma inv_set_fset: "finite M \<Longrightarrow> set (inv set M) = M"
unfolding inv_def by (metis (mono_tags) finite_list someI_ex)

lemma lfp_eqI':
  assumes "mono f"
    and "f C = C"
    and "\<forall>X \<in> Pow C. f X = X \<longrightarrow> X = C"
  shows "lfp f = C"
by (metis PowI assms lfp_lowerbound lfp_unfold subset_refl)

lemma lfp_while':
  fixes f::"'a set \<Rightarrow> 'a set" and M::"'a set"
  defines "N \<equiv> while (\<lambda>A. f A \<noteq> A) f {}"
  assumes f_mono: "mono f"
    and N_finite: "finite N"
    and N_supset: "f N \<subseteq> N"
  shows "lfp f = N"
proof -
  have *: "f X \<subseteq> N" when "X \<subseteq> N" for X using N_supset monoD[OF f_mono that] by blast
  show ?thesis
    using lfp_while[OF f_mono * N_finite]
    by (simp add: N_def)
qed

lemma lfp_while'':
  fixes f::"'a set \<Rightarrow> 'a set" and M::"'a set"
  defines "N \<equiv> while (\<lambda>A. f A \<noteq> A) f {}"
  assumes f_mono: "mono f"
    and lfp_finite: "finite (lfp f)"
  shows "lfp f = N"
proof -
  have *: "f X \<subseteq> lfp f" when "X \<subseteq> lfp f" for X
    using lfp_fixpoint[OF f_mono] monoD[OF f_mono that]
    by blast
  show ?thesis
    using lfp_while[OF f_mono * lfp_finite]
    by (simp add: N_def)
qed

lemma partition_index_bij:
  fixes n::nat
  obtains I k where
    "bij_betw I {0..<n} {0..<n}" "k \<le> n"
    "\<forall>i. i < k \<longrightarrow> P (I i)"
    "\<forall>i. k \<le> i \<and> i < n \<longrightarrow> \<not>(P (I i))"
proof -
  define A where "A = filter P [0..<n]"
  define B where "B = filter (\<lambda>i. \<not>P i) [0..<n]"
  define k where "k = length A"
  define I where "I = (\<lambda>n. (A@B) ! n)"

  note defs = A_def B_def k_def I_def

  have k1: "k \<le> n" by (metis defs(1,3) diff_le_self dual_order.trans length_filter_le length_upt)

  have "i < k \<Longrightarrow> P (A ! i)" for i by (metis defs(1,3) filter_nth)
  hence k2: "i < k \<Longrightarrow> P ((A@B) ! i)" for i by (simp add: defs nth_append)

  have "i < length B \<Longrightarrow> \<not>(P (B ! i))" for i by (metis defs(2) filter_nth)
  hence "i < length B \<Longrightarrow> \<not>(P ((A@B) ! (k + i)))" for i using k_def by simp
  hence "k \<le> i \<and> i < k + length B \<Longrightarrow> \<not>(P ((A@B) ! i))" for i
    by (metis add.commute add_less_imp_less_right le_add_diff_inverse2)
  hence k3: "k \<le> i \<and> i < n \<Longrightarrow> \<not>(P ((A@B) ! i))" for i by (simp add: defs sum_length_filter_compl)

  have *: "length (A@B) = n" "set (A@B) = {0..<n}" "distinct (A@B)"
    by (metis defs(1,2) diff_zero length_append length_upt sum_length_filter_compl)
       (auto simp add: defs)

  have I: "bij_betw I {0..<n} {0..<n}"
  proof (intro bij_betwI')
    fix x y show "x \<in> {0..<n} \<Longrightarrow> y \<in> {0..<n} \<Longrightarrow> (I x = I y) = (x = y)"
      by (metis *(1,3) defs(4) nth_eq_iff_index_eq atLeastLessThan_iff)
  next
    fix x show "x \<in> {0..<n} \<Longrightarrow> I x \<in> {0..<n}"
      by (metis *(1,2) defs(4) atLeastLessThan_iff nth_mem)
  next
    fix y show "y \<in> {0..<n} \<Longrightarrow> \<exists>x \<in> {0..<n}. y = I x"
      by (metis * defs(4) atLeast0LessThan distinct_Ex1 lessThan_iff)
  qed

  show ?thesis using k1 k2 k3 I that by (simp add: defs)
qed

lemma finite_lists_length_eq':
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> finite {y. P x y}"
  shows "finite {ys. length xs = length ys \<and> (\<forall>y \<in> set ys. \<exists>x \<in> set xs. P x y)}"
proof -
  define Q where "Q \<equiv> \<lambda>ys. \<forall>y \<in> set ys. \<exists>x \<in> set xs. P x y"
  define M where "M \<equiv> {y. \<exists>x \<in> set xs. P x y}"

  have 0: "finite M" using assms unfolding M_def by fastforce

  have "Q ys \<longleftrightarrow> set ys \<subseteq> M"
       "(Q ys \<and> length ys = length xs) \<longleftrightarrow> (length xs = length ys \<and> Q ys)"
    for ys
    unfolding Q_def M_def by auto
  thus ?thesis
    using finite_lists_length_eq[OF 0, of "length xs"]
    unfolding Q_def by presburger
qed

lemma trancl_eqI:
  assumes "\<forall>(a,b) \<in> A. \<forall>(c,d) \<in> A. b = c \<longrightarrow> (a,d) \<in> A"
  shows "A = A\<^sup>+"
proof
  show "A\<^sup>+ \<subseteq> A"
  proof
    fix x assume x: "x \<in> A\<^sup>+"
    then obtain a b where ab: "x = (a,b)" by (metis surj_pair)
    hence "(a,b) \<in> A\<^sup>+" using x by metis
    hence "(a,b) \<in> A" using assms by (induct rule: trancl_induct) auto
    thus "x \<in> A" using ab by metis
  qed
qed auto

lemma trancl_eqI':
  assumes "\<forall>(a,b) \<in> A. \<forall>(c,d) \<in> A. b = c \<and> a \<noteq> d \<longrightarrow> (a,d) \<in> A"
    and "\<forall>(a,b) \<in> A. a \<noteq> b"
  shows "A = {(a,b) \<in> A\<^sup>+. a \<noteq> b}"
proof
  show "{(a,b) \<in> A\<^sup>+. a \<noteq> b} \<subseteq> A"
  proof
    fix x assume x: "x \<in> {(a,b) \<in> A\<^sup>+. a \<noteq> b}"
    then obtain a b where ab: "x = (a,b)" by (metis surj_pair)
    hence "(a,b) \<in> A\<^sup>+" "a \<noteq> b" using x by blast+
    hence "(a,b) \<in> A"
    proof (induction rule: trancl_induct)
      case base thus ?case by blast
    next
      case step thus ?case using assms(1) by force
    qed
    thus "x \<in> A" using ab by metis
  qed
qed (use assms(2) in auto)

lemma distinct_concat_idx_disjoint:
  assumes xs: "distinct (concat xs)"
    and ij: "i < length xs" "j < length xs" "i < j"
  shows "set (xs ! i) \<inter> set (xs ! j) = {}"
proof -
  obtain ys zs vs where ys: "xs = ys@xs ! i#zs@xs ! j#vs" "length ys = i" "length zs = j - i - 1"
    using length_prefix_ex2[OF ij] by moura
  thus ?thesis
    using xs concat_append[of "ys@xs ! i#zs" "xs ! j#vs"]
          distinct_append[of "concat (ys@xs ! i#zs)" "concat (xs ! j#vs)"]
    by auto
qed

lemma remdups_ex2:
  "length (remdups xs) > 1 \<Longrightarrow> \<exists>a \<in> set xs. \<exists>b \<in> set xs. a \<noteq> b"
by (metis distinct_Ex1 distinct_remdups less_trans nth_mem set_remdups zero_less_one zero_neq_one)

lemma trancl_minus_refl_idem:
  defines "cl \<equiv> \<lambda>ts. {(a,b) \<in> ts\<^sup>+. a \<noteq> b}"
  shows "cl (cl ts) = cl ts"
proof -
  have 0: "(ts\<^sup>+)\<^sup>+ = ts\<^sup>+" "cl ts \<subseteq> ts\<^sup>+" "(cl ts)\<^sup>+ \<subseteq> (ts\<^sup>+)\<^sup>+"
  proof -
    show "(ts\<^sup>+)\<^sup>+ = ts\<^sup>+" "cl ts \<subseteq> ts\<^sup>+" unfolding cl_def by auto
    thus "(cl ts)\<^sup>+ \<subseteq> (ts\<^sup>+)\<^sup>+" using trancl_mono[of _ "cl ts" "ts\<^sup>+"] by blast
  qed

  have 1: "t \<in> cl (cl ts)" when t: "t \<in> cl ts" for t
    using t 0 unfolding cl_def by fast

  have 2: "t \<in> cl ts" when t: "t \<in> cl (cl ts)" for t
  proof -
    obtain a b where ab: "t = (a,b)" by (metis surj_pair)
    have "t \<in> (cl ts)\<^sup>+" and a_neq_b: "a \<noteq> b" using t unfolding cl_def ab by force+
    hence "t \<in> ts\<^sup>+" using 0 by blast
    thus ?thesis using a_neq_b unfolding cl_def ab by blast
  qed

  show ?thesis using 1 2 by blast
qed

lemma ex_list_obtain:
  assumes ts: "\<And>t. t \<in> set ts \<Longrightarrow> \<exists>s. P t s"
  obtains ss where "length ss = length ts" "\<forall>i < length ss. P (ts ! i) (ss ! i)"
proof -
  have "\<exists>ss. length ss = length ts \<and> (\<forall>i < length ss. P (ts ! i) (ss ! i))" using ts
  proof (induction ts rule: List.rev_induct)
    case (snoc t ts)
    obtain s ss where s: "length ss = length ts" "\<forall>i < length ss. P (ts ! i) (ss ! i)" "P t s"
      using snoc.IH snoc.prems by force
    have *: "length (ss@[s]) = length (ts@[t])" using s(1) by simp
    hence "P ((ts@[t]) ! i) ((ss@[s]) ! i)" when i: "i < length (ss@[s])" for i
      using s(2,3) i nth_append[of ts "[t]"] nth_append[of ss "[s]"] by force
    thus ?case using * by blast
  qed simp
  thus thesis using that by blast
qed

lemma length_1_conv[iff]:
  "(length ts = 1) = (\<exists>a. ts = [a])"
by (cases ts) simp_all

lemma length_2_conv[iff]:
  "(length ts = 2) = (\<exists>a b. ts = [a,b])"
proof (cases ts)
  case (Cons a ts') thus ?thesis by (cases ts') simp_all
qed simp

lemma length_3_conv[iff]:
  "(length ts = 3) \<longleftrightarrow> (\<exists>a b c. ts = [a,b,c])"
proof (cases ts)
  case (Cons a ts')
  note * = this
  thus ?thesis
  proof (cases ts')
    case (Cons b ts'') thus ?thesis using * by (cases ts'') simp_all
  qed simp
qed simp

subsection \<open>Infinite Paths in Relations as Mappings from Naturals to States\<close>
context
begin

private fun rel_chain_fun::"nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a" where
  "rel_chain_fun 0 x _ _ = x"
| "rel_chain_fun (Suc i) x y r = (if i = 0 then y else SOME z. (rel_chain_fun i x y r, z) \<in> r)"

lemma infinite_chain_intro:
  fixes r::"('a \<times> 'a) set"
  assumes "\<forall>(a,b) \<in> r. \<exists>c. (b,c) \<in> r" "r \<noteq> {}"
  shows "\<exists>f. \<forall>i::nat. (f i, f (Suc i)) \<in> r"
proof -
  from assms(2) obtain a b where "(a,b) \<in> r" by auto

  let ?P = "\<lambda>i. (rel_chain_fun i a b r, rel_chain_fun (Suc i) a b r) \<in> r"
  let ?Q = "\<lambda>i. \<exists>z. (rel_chain_fun i a b r, z) \<in> r"

  have base: "?P 0" using \<open>(a,b) \<in> r\<close> by auto

  have step: "?P (Suc i)" when i: "?P i" for i
  proof -
    have "?Q (Suc i)" using assms(1) i by auto
    thus ?thesis using someI_ex[OF \<open>?Q (Suc i)\<close>] by auto
  qed

  have "\<forall>i::nat. (rel_chain_fun i a b r, rel_chain_fun (Suc i) a b r) \<in> r"
    using base step nat_induct[of ?P] by simp
  thus ?thesis by fastforce
qed

end

lemma infinite_chain_intro':
  fixes r::"('a \<times> 'a) set"
  assumes base: "\<exists>b. (x,b) \<in> r" and step: "\<forall>b. (x,b) \<in> r\<^sup>+ \<longrightarrow> (\<exists>c. (b,c) \<in> r)"
  shows "\<exists>f. \<forall>i::nat. (f i, f (Suc i)) \<in> r"
proof -
  let ?s = "{(a,b) \<in> r. a = x \<or> (x,a) \<in> r\<^sup>+}"

  have "?s \<noteq> {}" using base by auto

  have "\<exists>c. (b,c) \<in> ?s" when ab: "(a,b) \<in> ?s" for a b
  proof (cases "a = x")
    case False
    hence "(x,a) \<in> r\<^sup>+" using ab by auto
    hence "(x,b) \<in> r\<^sup>+" using \<open>(a,b) \<in> ?s\<close> by auto
    thus ?thesis using step by auto
  qed (use ab step in auto)
  hence "\<exists>f. \<forall>i. (f i, f (Suc i)) \<in> ?s" using infinite_chain_intro[of ?s] \<open>?s \<noteq> {}\<close> by blast
  thus ?thesis by auto
qed

lemma infinite_chain_mono:
  assumes "S \<subseteq> T" "\<exists>f. \<forall>i::nat. (f i, f (Suc i)) \<in> S"
  shows "\<exists>f. \<forall>i::nat. (f i, f (Suc i)) \<in> T"
using assms by auto

end


theory Shared_Centralised_Instance imports
  Centralised_Model
  Game_Based_Crypto.Game_Based_Crypto
begin

sledgehammer_params[timeout = 1000]

type_synonym ('share1_sens', 'share2_sens', 'share3_sens') share_user_record = "('share1_sens' \<times> 'share2_sens' \<times> 'share3_sens') set"

type_synonym ('user', 'result') query = "'user' \<Rightarrow> 'result'"

type_synonym ('attrs', 'sens_atrrs') user_attrs = "('attrs' set \<times> 'sens_atrrs' set)"

type_synonym ('user', 'state_attr_hid', 'enc_attrs') attr_hiding_adversary
  = "(('user' \<times> 'user') \<times> 'state_attr_hid') spmf \<times> ('state_attr_hid' \<Rightarrow> 'enc_attrs' \<Rightarrow> bool spmf)"

type_synonym ('user', 'state_attr_hid', 'share1_sens', 'share2_sens', 'share3_sens') attr_hiding_adversary'
  = "(('user' \<times> 'user') \<times> 'state_attr_hid') spmf \<times> ('state_attr_hid' \<Rightarrow> ('share1_sens', 'share2_sens', 'share3_sens') share_user_record \<Rightarrow> bool spmf)"

type_synonym ('token', 'state',  'auth_token') hiding_adversary = "(('token' \<times> 'token') \<times> 'state') spmf \<times> ('state' \<Rightarrow> 'auth_token' \<Rightarrow> bool spmf)"

type_synonym 'token' soundness_adversary = "'token' \<Rightarrow> 'token' spmf"

locale identity_system =
  fixes reg_enc_sens_attrs :: "'sens_atrrs set \<Rightarrow> ('enc_attrs set) spmf" \<comment> \<open>The user encrypts their attributes before sending them to the government.\<close>
    and reg_govt_shares :: "'enc_attrs set \<Rightarrow> (('share1_sens, 'share2_sens, 'share3_sens) share_user_record \<times> 'state_govt) spmf"
    and reg_govt_token :: "'state_govt \<Rightarrow> ('share1_sens, 'share2_sens, 'share3_sens) share_user_record \<Rightarrow> 'token spmf"
    \<comment> \<open>The government first produces the shares of the user record and then a token to be sent back to the user.\<close>
    and auth :: "'token \<Rightarrow> ('user, 'result) query \<Rightarrow> 'auth_token spmf"
    \<comment> \<open>Authentication is run between a user and a service provider.
    The user inputs their token, the service provider their desired query and an authorised token is returned. This is sent to the government.\<close>
    and ver :: "'auth_token \<Rightarrow> 'result spmf"
    \<comment> \<open>The government uses the authorised token to determine the response to the query.\<close>
    and valid_user :: "'user \<Rightarrow> bool"
    and valid_attrs :: "('non_sens_attrs set \<times> 'sens_atrrs set) \<Rightarrow> bool"
    and valid_token :: "'token \<Rightarrow> bool"
    and valid_query :: "('user, 'result) query \<Rightarrow> bool"
    and user_set :: "'user set"
    and attrs_set :: "('non_sens_attrs set \<times> 'sens_atrrs set) set"
    and users_attr_creation :: "'user \<Rightarrow> ('non_sens_attrs set \<times> 'sens_atrrs set)"
  assumes users_are_valid: "user \<in> user_set \<longrightarrow> valid_user user"
    and atrrs_are_valid: "attrs \<in> attrs_set \<longrightarrow> valid_attrs attrs"
    and user_set_not_empty: "user_set \<noteq> {}"
    and attrs_set_not_empty: "attrs_set \<noteq> {}"
    and bij_betw_users_attrs: "bij_betw users_attr_creation user_set attrs_set"
    and lossless_reg_govt_token: "lossless_spmf (reg_govt_token \<sigma> S)"
    and lossless_reg_govt_shares: "lossless_spmf (reg_govt_shares enc_attrs)"
    and lossless_reg_enc_sens_attrs: "lossless_spmf (reg_enc_sens_attrs sens_attrs)"
    and reg_enc_sens_attrs_empty_set: "enc_attrs_set = set_spmf (reg_enc_sens_attrs {}) \<longrightarrow> enc_attrs_set = {}"
    and reg_govt_shares_empty_set: "A \<in> (set_spmf (reg_govt_shares {})) \<longrightarrow> fst A = {}"
begin

lemma all_users_valid: "\<forall> user. user \<in> user_set \<longrightarrow> valid_user user"
  using users_are_valid by simp

lemma all_attrs_valid: "\<forall> attrs. attrs \<in> attrs_set \<longrightarrow> valid_attrs attrs"
  using atrrs_are_valid by simp

text\<open>We define the registration phase using the fixes parameters for the user and government.\<close>

definition reg :: "'user \<Rightarrow> ('token \<times> ('non_sens_attrs set \<times> ('share1_sens, 'share2_sens, 'share3_sens) share_user_record)) spmf"
  where "reg user = do {
   let (non_sens_attrs, sens_attrs) = users_attr_creation user;
   enc_attrs \<leftarrow> reg_enc_sens_attrs sens_attrs;
   (S, \<sigma>) \<leftarrow> reg_govt_shares enc_attrs;
   token \<leftarrow> reg_govt_token \<sigma> S;
   return_spmf (token, (non_sens_attrs, S))}"

sublocale shared_centralised_id: centralised_id reg auth ver valid_user valid_query
  unfolding centralised_id_def reg_def
  by(simp add: split_def Let_def bind_spmf_const lossless_reg_govt_token lossless_reg_govt_shares lossless_reg_enc_sens_attrs)

definition "no_sens_attr \<longleftrightarrow> (\<forall> user. snd (users_attr_creation user) = {})"

lemma
  assumes "no_sens_attr"
  shows "shared_centralised_id.perfect_sens_attrs_hiding \"
proof(rule shared_centralised_id.no_sens_attrs_imp_perfect_sens_attrs_hiding)
  show "\<forall>user token store_non_sens_attr store_nons_sens_attrs store_sens_attr. (token, store_nons_sens_attrs, store_sens_attr) \<in> set_spmf (reg user) \<longrightarrow> store_sens_attr = {}"
    unfolding reg_def using assms[unfolded no_sens_attr_def] reg_enc_sens_attrs_empty_set reg_govt_shares_empty_set
    by(auto simp add: Let_def split_def)
qed

end

locale identity_ind_cpa_base = enc: ind_cpa key_gen encrypt decrypt valid_plains
  for key_gen :: "('pk \<times> 'sk) spmf"
    and encrypt :: "'pk \<Rightarrow> 'sens_atrrs set \<Rightarrow> ('enc_attrs set) spmf"
    and decrypt :: "'sk \<Rightarrow> 'enc_attrs set \<Rightarrow> 'sens_atrrs set option"
    and valid_plains :: "'sens_atrrs set \<Rightarrow> 'sens_atrrs set \<Rightarrow> bool"
begin

definition reg_enc_sens_attrs :: "'sens_atrrs set \<Rightarrow> ('enc_attrs set) spmf"
  where
    "reg_enc_sens_attrs sens_attrs = do {
      (pk,sk) \<leftarrow> key_gen;
      encrypt pk sens_attrs}"

end

locale id_ind_cpa = identity_ind_cpa_base +
  id_sys: identity_system reg_enc_sens_attrs reg_govt_shares reg_govt_token auth ver valid_user valid_attrs valid_token valid_query user_set attrs_set users_attr_creation
  for reg_govt_shares reg_govt_token auth ver valid_user valid_attrs valid_token valid_query user_set attrs_set users_attr_creation
    +
  assumes valid_user_valid_plains: "\<forall> u0 u1. valid_user u0 \<and> valid_user u1  \<longleftrightarrow> valid_plains (snd (users_attr_creation u0)) (snd (users_attr_creation u1))"

begin
term "id_sys.reg"
sublocale shared_id: centralised_id id_sys.reg auth ver valid_user valid_query
  using id_sys.shared_centralised_id.centralised_id_axioms by simp

definition sens_hiding_adversary1 :: "(('j \<times> 'j) \<times> 'n) spmf \<Rightarrow> 'a \<Rightarrow> (('c set \<times> 'c set) \<times> 'n) spmf"
  where "sens_hiding_adversary1 \1 pk = do {
    ((u0,u1), \<sigma>) \<leftarrow> \1;
    \<comment> \<open>_ :: unit \<leftarrow> assert_spmf (valid_user u0 \<and> valid_user u1);\<close>
    let sens_set0 = snd (users_attr_creation u0);
    let sens_set1 = snd (users_attr_creation u1);
    return_spmf ((sens_set0, sens_set1), \<sigma>)}"

definition sens_hiding_adversary2 :: "('n \<Rightarrow> ('e \<times> 'f \<times> 'g) set \<Rightarrow> bool spmf) \<Rightarrow> 'd set \<Rightarrow> 'n \<Rightarrow> bool spmf"
  where "sens_hiding_adversary2 \2 enc \<sigma> = do {
          (S, \<sigma>g) \<leftarrow> reg_govt_shares enc;
          \2 \<sigma> S}"

fun sens_hiding_adversary:: "(('j \<times> 'j) \<times> 'n) spmf \<times> ('n \<Rightarrow> ('e \<times> 'f \<times> 'g) set \<Rightarrow> bool spmf) \<Rightarrow> ('a \<Rightarrow> (('c set \<times> 'c set) \<times> 'n) spmf) \<times> ('d set \<Rightarrow> 'n \<Rightarrow> bool spmf)"
  where "sens_hiding_adversary (\1, \2) = (sens_hiding_adversary1 \1, sens_hiding_adversary2 \2)"

lemma if_cases_sens_hiding_attrs:
  shows "(if b then fst (fst ((snd (users_attr_creation (fst (fst y))), snd (users_attr_creation (snd (fst y)))), snd y))
             else snd (fst ((snd (users_attr_creation (fst (fst y))), snd (users_attr_creation (snd (fst y)))), snd y))) =
                 snd (users_attr_creation (if b then fst (fst y) else snd (fst y)))"
  by(cases b; auto)

lemma sens_attrs_hiding_reduce_to_ind_cpa:
  shows "id_sys.shared_centralised_id.sens_attrs_hiding_advantage (\1, \2) = enc.advantage (sens_hiding_adversary (\1, \2))"
  including monad_normalisation
  unfolding  id_sys.shared_centralised_id.sens_attrs_hiding_advantage_def id_sys.shared_centralised_id.sens_attrs_hiding_game_def id_sys.reg_def reg_enc_sens_attrs_def  enc.advantage_def enc.ind_cpa_def
  apply(simp add: split_def Let_def eq_commute)
  unfolding sens_hiding_adversary1_def sens_hiding_adversary2_def
  by(auto simp add: valid_user_valid_plains if_cases_sens_hiding_attrs Let_def bind_spmf_const id_sys.lossless_reg_govt_token lossless_weight_spmfD split_def)

corollary perfect_sens_attrs_hiding:
  "id_sys.shared_centralised_id.perfect_sens_attrs_hiding (\1, \2)" if "enc.advantage (sens_hiding_adversary (\1, \2)) = 0"
  unfolding id_sys.shared_centralised_id.perfect_sens_attrs_hiding_def
  using sens_attrs_hiding_reduce_to_ind_cpa that
  by (simp add: sens_attrs_hiding_reduce_to_ind_cpa)

end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)
theory Plus2_Prefix
imports
  Lib.Lib
  Prefix_Refinement
begin

section \<open>The plus2 example.\<close>

text \<open>
This example presents an application of prefix refinement
to solve the plus2 verification problem.

The function below can be proven to do two increments per
instance when grouped in parallel. But RG-reasoning doesn't
work well for this proof, since the state change (+1) performed
by the counterparts must be allowed by the rely, which must be
transitively closed, allowing any number of (+1) operations,
which is far too general.

We address the issue with a ghost variable which records the number
of increments by each thread. We use prefix refinement to relate the
program with ghost variable to the initial program.
\<close>

definition
  "plus2 \<equiv> do env_steps; modify ((+) (1 :: nat));
    interference; modify ((+) 1); interference od"

section \<open>The ghost-extended program.\<close>

record
  plus2_xstate =
    mainv :: nat
    threadv :: "nat \<Rightarrow> nat"

definition
  point_update :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b))"
where
  "point_update x fup f = f (x := fup (f x))"

definition
  "plus2_x tid \<equiv> do env_steps;
    modify (mainv_update ((+) 1) o threadv_update (point_update tid ((+) 1)));
    interference;
    modify (mainv_update ((+) 1) o threadv_update (point_update tid ((+) 1)));
    interference
  od"

section \<open>Verifying the extended @{term plus2}.\<close>
text \<open>The RG-reasoning needed to verify the @{term plus2_x} program.\<close>
definition
  "plus2_inv tids s = (mainv s = sum (threadv s) tids)"

definition
  "plus2_rel tids fix_tids s0 s
    = ((plus2_inv tids s0 \<longrightarrow> plus2_inv tids s) \<and> (\<forall>tid \<in> fix_tids. threadv s tid = threadv s0 tid))"

lemma plus2_rel_trans[simp]:
  "rtranclp (plus2_rel tids ftids) = plus2_rel tids ftids"
  apply (rule rtranclp_id2)
   apply (simp add: plus2_rel_def)
  apply (clarsimp simp: plus2_rel_def)
  done

lemma plus2_inv_Suc[simp]:
  "tid \<in> tids \<Longrightarrow> finite tids
    \<Longrightarrow> plus2_inv tids (mainv_update Suc (threadv_update (point_update tid Suc) s))
        = plus2_inv tids s"
  apply (simp add: plus2_inv_def point_update_def)
  apply (simp add: sum.If_cases[where h=f and g=f and P="(=) tid" and A="tids" for f x, simplified])
  done

theorem plus2_x_property:
  "\<lbrace>\<lambda>s0 s. plus2_inv tids s \<and> threadv s tid = 0 \<and> s = s0 \<and> tid \<in> tids \<and> finite tids\<rbrace>,\<lbrace>plus2_rel tids {tid}\<rbrace>
    plus2_x tid \<lbrace>plus2_rel tids (- {tid})\<rbrace>,\<lbrace>\<lambda>_ _ s. plus2_inv tids s \<and> threadv s tid = 2\<rbrace>"
  apply (simp add: plus2_x_def)
  apply (rule validI_weaken_pre)
   apply wp
  apply clarsimp
  apply (clarsimp simp: plus2_rel_def point_update_def)
  done

corollary plus2_x_parallel:
  "\<lbrace>\<lambda>s0 s. mainv s = 0 \<and> (\<forall>tid \<in> {1, 2}. threadv s tid = 0) \<and> s = s0\<rbrace>,\<lbrace>\<lambda>a b. a = b\<rbrace>
    parallel (plus2_x 1) (plus2_x 2) \<lbrace>\<lambda>s0 s. True\<rbrace>,\<lbrace>\<lambda>_ s0 s. mainv s = 4\<rbrace>"
  apply (rule validI_weaken_pre)
   apply (rule validI_strengthen_post)
    apply ((rule rg_validI plus2_x_property[where tids="{1, 2}"])+; simp add: plus2_rel_def le_fun_def)
   apply (clarsimp simp: plus2_inv_def)
  apply (clarsimp simp add: plus2_inv_def)
  done

section \<open>Mapping across prefix refinement.\<close>
text \<open>Proving prefix refinement of @{term plus2} and @{term plus2_x} and
deriving the final result.\<close>

lemma env_stable:
  "env_stable AR R (\<lambda>s t. t = mainv s) (\<lambda>s t. t = mainv s) \<top>"
  apply (simp add: env_stable_def rely_stable_def env_rely_stable_iosr_def)
  apply (simp add: plus2_xstate.splits)
  done

abbreviation(input)
  "p_refn rvr P Q AR R \<equiv> prefix_refinement (\<lambda>s t. t = mainv s) (\<lambda>s t. t = mainv s)
    (\<lambda>s t. t = mainv s) rvr P Q AR R"

theorem pfx_refn_plus2_x:
  "p_refn (\<top>\<top>) (=) (\<top>\<top>) AR R (plus2_x tid) plus2"
  apply (simp add: plus2_x_def plus2_def)
  apply (rule prefix_refinement_weaken_pre)
    apply (rule pfx_refn_bind prefix_refinement_interference
         prefix_refinement_env_steps allI
         pfx_refn_modifyT env_stable
       | simp
       | wp)+
  done

lemma par_tr_fin_plus2_x:
  "par_tr_fin_principle (plus2_x tid)"
  by (simp add: plus2_x_def par_tr_fin_interference par_tr_fin_bind)

lemma prefix_closed_plus2:
  "prefix_closed plus2"
  apply (simp add: plus2_def)
  apply (rule validI_prefix_closed_T, rule validI_weaken_pre, wp)
  apply simp
  done

theorem plus2_parallel:
  "\<lbrace>\<lambda>s0 s. s = 0 \<and> s = s0\<rbrace>,\<lbrace>\<lambda>a b. a = b\<rbrace>
    parallel plus2 plus2 \<lbrace>\<lambda>s0 s. True\<rbrace>,\<lbrace>\<lambda>_ s0 s. s = 4\<rbrace>"
  apply (rule_tac sr="\<lambda>s t. t = mainv s" in prefix_refinement_validI)
  apply (rule prefix_refinement_parallel_triv;
      ((rule par_tr_fin_plus2_x prefix_closed_plus2)?))
       apply (rule pfx_refn_plus2_x[where tid=1])
      apply (rule pfx_refn_plus2_x[where tid=2])
     apply clarsimp
     apply (rule validI_strengthen_post)
      apply (rule plus2_x_parallel[simplified])
     apply clarsimp
    apply (clarsimp simp: plus2_xstate.splits)
    apply (strengthen exI[where x="f(1 := x, 2 := y)" for f x y])
    apply simp
   apply clarsimp
  apply (intro parallel_prefix_closed prefix_closed_plus2)
  done

section \<open>Generalising\<close>
text \<open>Just for fun, generalise to arbitrarily many
copies of the @{term plus2} program.\<close>

lemma plus2_x_n_parallel_induct:
  "n > 0 \<Longrightarrow> n \<le> N \<Longrightarrow>
  \<lbrace>\<lambda>s0 s. plus2_inv {..< N} s \<and> (\<forall>i < N. threadv s i = 0) \<and> s = s0\<rbrace>,\<lbrace>plus2_rel {..< N} {..< n}\<rbrace>
    fold parallel (map plus2_x [1 ..< n]) (plus2_x 0) \<lbrace>plus2_rel {..< N} ( - {..< n})\<rbrace>,\<lbrace>\<lambda>_ _ s.
        plus2_inv {..< N} s \<and> (\<forall>i < n. threadv s i = 2)\<rbrace>"
  apply (induct n)
   apply simp
  apply (case_tac n)
   apply (simp only: lessThan_Suc)
   apply simp
   apply (rule validI_weaken_pre, rule plus2_x_property)
   apply clarsimp
  apply (clarsimp split del: if_split)
  apply (rule validI_weaken_pre, rule validI_strengthen_post,
    rule rg_validI, rule plus2_x_property[where tids="{..< N}"],
    assumption, (clarsimp simp: plus2_rel_def)+)
   apply (auto dest: less_Suc_eq[THEN iffD1])[1]
  apply clarsimp
  done

theorem plus2_x_n_parallel:
  "n > 0 \<Longrightarrow>
  \<lbrace>\<lambda>s0 s. mainv s = 0 \<and> (\<forall>i < n. threadv s i = 0) \<and> s = s0\<rbrace>,\<lbrace>plus2_rel {..< n} {..< n}\<rbrace>
    fold parallel (map plus2_x [1 ..< n]) (plus2_x 0) \<lbrace>\<lambda>s0 s. True\<rbrace>,\<lbrace>\<lambda>_ _ s. mainv s = (n * 2)\<rbrace>"
  apply (rule validI_weaken_pre, rule validI_strengthen_post,
      rule validI_strengthen_guar, erule plus2_x_n_parallel_induct)
     apply simp
    apply simp
   apply (clarsimp simp: plus2_inv_def)
  apply (clarsimp simp: plus2_inv_def)
  done

lemma par_tr_fin_principle_parallel:
  "par_tr_fin_principle f \<Longrightarrow> par_tr_fin_principle g
    \<Longrightarrow> par_tr_fin_principle (parallel f g)"
  apply (subst par_tr_fin_principle_def, clarsimp simp: parallel_def3)
  apply (drule(1) par_tr_fin_principleD)+
  apply (clarsimp simp: neq_Nil_conv)
  done

lemma fold_parallel_par_tr_fin_principle[where xs="rev xs" for xs, simplified]:
  "\<forall>x \<in> insert x (set xs). par_tr_fin_principle x
    \<Longrightarrow> par_tr_fin_principle (fold parallel (rev xs) x)"
  by (induct xs, simp_all add: par_tr_fin_principle_parallel)

lemma fold_parallel_prefix_closed[where xs="rev xs" for xs, simplified]:
  "\<forall>x \<in> insert x (set xs). prefix_closed x
    \<Longrightarrow> prefix_closed (fold parallel (rev xs) x)"
  by (induct xs, simp_all add: parallel_prefix_closed)

lemma bipred_disj_top_eq:
  "(Rel or (\<lambda>_ _. True)) = (\<lambda>_ _. True)"
  "((\<lambda>_ _. True) or Rel) = (\<lambda>_ _. True)"
  by auto

lemma fold_parallel_pfx_refn_induct:
  "list_all2 (prefix_refinement sr sr sr (\<lambda>_ _. True) P Q (\<top>\<top>) (\<top>\<top>)) xs ys
    \<Longrightarrow> prefix_refinement sr sr sr (\<lambda>_ _. True) P Q (\<top>\<top>) (\<top>\<top>) x y
    \<Longrightarrow> \<forall>x \<in> set (x # xs). par_tr_fin_principle x
    \<Longrightarrow> \<forall>y \<in> set (y # ys). prefix_closed y
    \<Longrightarrow> prefix_refinement sr sr sr (\<lambda>_ _. True) P Q (\<top>\<top>) (\<top>\<top>)
        (fold parallel (rev xs) x) (fold parallel (rev ys) y)"
  apply (induct rule: list_all2_induct; simp)
  apply (rule prefix_refinement_parallel_triv[simplified bipred_disj_top_eq]; simp?)
   apply (clarsimp simp: fold_parallel_par_tr_fin_principle
                         fold_parallel_prefix_closed)+
  done

lemmas fold_parallel_pfx_refn
    = fold_parallel_pfx_refn_induct[where xs="rev xs" and ys="rev ys" for xs ys, simplified]

theorem plus2_n_parallel:
  "n > 0
    \<Longrightarrow> \<lbrace>\<lambda>s0 s. s = 0 \<and> s = s0\<rbrace>,\<lbrace>\<lambda>a b. a = b\<rbrace>
        fold parallel (replicate (n - 1) plus2) plus2 \<lbrace>\<lambda>s0 s. True\<rbrace>,\<lbrace>\<lambda>_ s0 s. s = n * 2\<rbrace>"
  apply (rule_tac sr="\<lambda>s t. t = mainv s" in prefix_refinement_validI)
      apply (rule prefix_refinement_weaken_rely,
      rule_tac xs="map plus2_x [1 ..< n]" in fold_parallel_pfx_refn)
           apply (clarsimp simp: list_all2_conv_all_nth)
           apply (rule pfx_refn_plus2_x)
          apply (rule pfx_refn_plus2_x[where tid=0])
         apply (simp add: par_tr_fin_plus2_x)
        apply (simp add: prefix_closed_plus2)
       apply (simp add: le_fun_def)
      apply (simp add: le_fun_def)
     apply simp
     apply (rule validI_strengthen_post, rule plus2_x_n_parallel[simplified], simp)
     apply clarsimp
    apply (clarsimp simp: plus2_xstate.splits exI[where x="\<lambda>_. 0"])
   apply clarsimp
   apply (rule exI, strengthen refl)
   apply (clarsimp simp: plus2_rel_def plus2_inv_def)
  apply (rule fold_parallel_prefix_closed)
  apply (simp add: prefix_closed_plus2)
  done

end


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

theory Residuals imports Substitution begin

consts
  Sres          :: "i"

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

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

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

subsection\<open>Setting up rule lists\<close>

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

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

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

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

declare Sres.intros [simp]

subsection\<open>residuals is a  partial function\<close>

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

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

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

subsection\<open>Residual function\<close>

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

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

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

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

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

subsection\<open>Commutation theorem\<close>

lemma sub_comp [simp]: "u \<Longleftarrow> v \<Longrightarrow> u \<sim> v"
by (erule Ssub.induct, simp_all)

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

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

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

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

subsection\<open>Residuals are comp and regular\<close>

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

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

subsection\<open>Preservation lemma\<close>

lemma union_preserve_comp: "u \<sim> v ==> v \<sim> (u \<squnion> v)"
by (erule Scomp.induct, simp_all)

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

declare sub_comp [THEN comp_sym, simp]

subsection\<open>Prism theorem\<close>

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

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

subsection\<open>Levy's Cube Lemma\<close>

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

subsection\<open>paving theorem\<close>

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

end


theory SimAsm_Inter_Term
  imports SimAsm_Inter_Exec "HOL-Library.While_Combinator" "HOL-Eisbach.Eisbach"
begin

text \<open>
Theorems to demonstrate termination of the SimAsm_Inter analysis
and demonstrate its conversion to executable definitions.
\<close>

section \<open>Termination Proof\<close>

abbreviation vars
  where "vars p \<equiv> (rds p |\<union>| wrs p |\<union>| esc p |\<union>| Sup (snd ` (fset (pairs p))))"

definition nmax
  where "nmax V \<equiv> if V = {||} then 0 else fMax V"

definition pmax
  where "pmax p \<equiv> max (id p) (nmax (fst |`| pairs p))"

definition Pmax
  where "Pmax P \<equiv> if P = {} then 0 else Max (pmax ` P)"

definition varsL
  where "varsL l = Sup ((\<lambda>p. fwr p |\<union>| frd p) ` (set l))"

definition all_points
  where "all_points vs i \<equiv> {p. vars p |\<subseteq>| vs \<and> id p \<le> i \<and> (nmax (fst |`| (pairs p))) \<le> i}"

lemma finite_all_points [intro]:
  "finite (all_points vs i :: ('a, 'b) point set)"
proof -
  let ?f = "\<lambda>d w r b e p. \<lparr>id = d, wrs = w, rds = r, bar = b, esc = e, pairs = p\<rparr>"
  have a: "finite {w. w |\<subseteq>| vs}"
  proof -
    have "finite (Abs_fset ` {w. w \<subseteq> fset vs})" by simp
    moreover have "{w. w |\<subseteq>| vs} \<subseteq> Abs_fset ` {w. w \<subseteq> fset vs}"
      by (auto simp: fset_inverse less_eq_fset.rep_eq rev_image_eqI)
    ultimately show ?thesis by (meson finite_subset)
  qed
  have b: "finite {p. nmax p \<le> i}"
  proof -
    have "finite {p. p \<subseteq> {j. j \<le> i}}" by blast
    hence f: "finite {p. finite p \<and> Max p \<le> i}"
      by (rule rev_finite_subset; insert Max.boundedE; auto)
    hence "finite (insert {||} (Abs_fset ` {p. finite p \<and> Max p \<le> i}))"
      by blast
    thus ?thesis
      apply (rule rev_finite_subset)
      apply (auto simp: nmax_def)
      by (metis (no_types, lifting) fMax.F.rep_eq finite_fset fset_inverse image_iff mem_Collect_eq)
  qed

  have e: "finite {p. (snd  p) |\<subseteq>| vs \<and>  (fst  p) \<le> i}"
    apply (rule finite_subset[where
              B="\<Union>d \<in> {d. d |\<subseteq>| vs}. \<Union>e \<in> {e.  e \<le> i}. {(e,d)}"])
    apply fastforce
    using b a by simp

  have e: "finite {fset p | p. Sup (snd ` fset p) |\<subseteq>| vs \<and> nmax (fst |`| p) \<le> i}"
    apply (rule finite_subset[OF _ finite_Collect_subsets[OF e]])
    apply auto
    apply (metis (no_types, lifting) fimage.rep_eq finite_fset fsubsetD le_cSup_finite rev_image_eqI snd_conv)
    unfolding nmax_def
    apply (auto split: if_splits)
    by (metis (no_types, lifting) Max_ge dual_order.trans fMax.F.rep_eq fimage.rep_eq finite_fset fst_conv rev_image_eqI)

  hence "finite
     (Abs_fset `
      {fset p |p.
       Sup (snd ` fset p) |\<subseteq>| vs \<and>
       nmax (fst |`| p) \<le> i})"
    using finite_imageI[OF e, of Abs_fset]
    by auto

  moreover have "(Abs_fset `
      {fset p |p.
       Sup (snd ` fset p) |\<subseteq>| vs \<and>
       nmax (fst |`| p) \<le> i}) = {p. Sup (snd ` fset p) |\<subseteq>| vs \<and> nmax (fst |`| p) \<le> i}"
    apply auto
    apply (subgoal_tac "finite (fset p)")
    apply (simp add: Abs_fset_inverse fin_mono)
    using finite_fset apply blast
    apply (subgoal_tac "finite (fset p)")
    apply (simp add: fset_inverse)
    using finite_fset apply blast
    by (metis (mono_tags, lifting) fset_inverse image_eqI mem_Collect_eq)

  ultimately have e: "finite {p. Sup (snd ` fset p) |\<subseteq>| vs \<and> nmax (fst |`| p) \<le> i}"
    by simp

  have c: "finite {?f d w r b e p | d w r b e p. w |\<subseteq>| vs \<and> r |\<subseteq>| vs \<and> e |\<subseteq>| vs \<and> Sup (snd ` fset p) |\<subseteq>| vs \<and> d \<le> i \<and> nmax (fst |`| p) \<le> i}"
    using a e finite_subset[where
        A="{?f d w r b e p | d w r b e p. w |\<subseteq>| vs \<and> r |\<subseteq>| vs \<and> e |\<subseteq>| vs \<and> Sup (snd ` fset p) |\<subseteq>| vs \<and> d \<le> i \<and> nmax (fst |`| p) \<le> i}" and
        B="\<Union>d \<in> {d. d \<le> i}. \<Union>w \<in> {w. w |\<subseteq>| vs}. \<Union>r \<in> {r. r |\<subseteq>| vs}. \<Union>b \<in> UNIV. \<Union>e \<in> {e. e |\<subseteq>| vs}. \<Union>p \<in> {p. Sup (snd ` fset p) |\<subseteq>| vs \<and> nmax (fst |`| p) \<le> i}. {?f d w r b e p}"]
    by fastforce
  have d: "all_points vs i \<subseteq> {?f d w r b e p | d w r b e p. w |\<subseteq>| vs \<and> r |\<subseteq>| vs \<and>  e |\<subseteq>| vs \<and> Sup (snd ` fset p) |\<subseteq>| vs \<and> d \<le> i \<and> nmax (fst |`| p) \<le> i}"
    unfolding all_points_def
    by (smt Collect_mono SimAsm_Inter_Exec.point.surjective old.unit.exhaust sup.boundedE)
  show "finite (all_points vs i :: ('a, 'b) point set)"
    using finite_subset[OF d c] .
qed

lemma all_points_rel:
  "P |\<subseteq>| P' \<Longrightarrow> i \<le> i' \<Longrightarrow> all_points P i \<subseteq> all_points P' i'"
  unfolding all_points_def by auto

lemma max_fg:
  assumes "finite P" "\<forall>p. f p \<le> g p"
  shows "Max (f ` P) \<le> Max (g ` P)"
  using assms
  by (smt Max_ge_iff Max_in finite_imageI imageE image_eqI image_is_empty order_refl)

lemma Max_max :
  "finite V \<Longrightarrow> Max ((\<lambda>p. max (f p) (g p)) ` V) = max (Max (f ` V)) (Max (g ` V))" (is "finite V \<Longrightarrow> ?L = ?R")
proof -
  assume a: "finite V"
  have "?L \<ge> ?R"
  proof -
    have "Max (f ` V) \<le> ?L" using a by (rule max_fg) auto
    moreover have "Max (g ` V) \<le> ?L" using a by (rule max_fg) auto
    ultimately show "?L \<ge> ?R" by auto
  qed
  moreover have "?R \<ge> ?L"
  proof (cases "Max (f ` V) \<ge> Max (g ` V)")
    case True
    hence "max (Max (f ` V)) (Max (g ` V)) = Max (f ` V)" using max_absorb1 by blast
    moreover have "(MAX p\<in>V. max (f p) (g p)) \<le> (Max (f ` V))" using a
      by (smt Max_ge Max_in calculation dual_order.trans finite_imageI image_iff image_is_empty max.absorb_iff1 max_def)
    ultimately show ?thesis by auto
  next
    case False
    hence "max (Max (f ` V)) (Max (g ` V)) = Max (g ` V)" using linear max_absorb2 by blast
    moreover have "(MAX p\<in>V. max (f p) (g p)) \<le> (Max (g ` V))" using a
      by (smt Max_ge Max_in calculation dual_order.trans finite_imageI image_iff image_is_empty max.absorb_iff1 max_def)
    ultimately show ?thesis by auto
  qed
  ultimately show ?thesis using eq_iff by blast
qed

lemma set_all_points_bound:
  "finite P \<Longrightarrow> P \<subseteq> all_points (Sup (vars ` P)) (Pmax P)"
  unfolding all_points_def
proof (clarsimp, intro conjI, goal_cases)
  case (1 x)
  hence "vars x |\<subseteq>| Sup (vars ` P)"
    by (meson finite_imageI image_iff le_cSup_finite)
  then show ?case by blast
next
  case (2 x)
  hence "vars x |\<subseteq>| Sup (vars ` P)"
    by (meson finite_imageI image_iff le_cSup_finite)
  then show ?case by blast
next
  case (3 x)
  hence "vars x |\<subseteq>| Sup (vars ` P)"
    by (meson finite_imageI image_iff le_cSup_finite)
  then show ?case by blast
next
  case (5 x)
  hence "id x \<le> (MAX p\<in>P. id p)" by simp
  also have "... \<le> (MAX p\<in>P. max (id p) (nmax (fst |`| pairs p)))"
    apply (rule max_fg)
    using 5 by auto
  also have "... \<le> Pmax P" using 5 by (auto simp: Pmax_def pmax_def)
  finally show ?case .
next
  case (6 x)
  hence "nmax (fst |`| pairs x) \<le> (MAX p\<in>P. nmax (fst |`| pairs p))" by simp
  also have "... \<le> (MAX p\<in>P. max (id p) (nmax (fst |`| pairs p)))"
    apply (rule max_fg)
    using 6 by auto
  also have "... \<le> Pmax P" using 6 by (auto simp: Pmax_def pmax_def)
  finally show ?case .
next
  case (4 x)
  hence "vars x |\<subseteq>| Sup (vars ` P)"
    by (meson finite_imageI image_iff le_cSup_finite)
  thus ?case by blast
qed

lemma set_all_points_bound':
  "finite P \<Longrightarrow> P \<subseteq> all_points (varsL l |\<union>| Sup (vars ` P)) (max (length l) (Pmax P))"
  using set_all_points_bound all_points_rel
  by (metis (mono_tags, lifting) subset_trans sup_ge2 sup_max)

lemma fsubset_sup:
  "\<forall>j \<in> Y. f j |\<subseteq>| X \<Longrightarrow> Sup (f ` Y) |\<subseteq>| X"
proof -
  assume "\<forall>j \<in> Y. f j |\<subseteq>| X"
  hence "\<forall>j \<in> Y. fset (f j) \<subseteq> fset X" by (simp add: less_eq_fset.rep_eq)
  hence "Sup ((fset o f) ` Y) \<subseteq> fset X" by auto
  thus "Sup (f ` Y) |\<subseteq>| X"
    by (simp add: Sup_fset.rep_eq less_eq_fset.rep_eq)
qed

lemma all_points_sub:
  assumes "Y \<subseteq> (all_points vs i :: ('a, 'b) point set)"
  shows "all_points (Sup (vars ` Y)) (Pmax Y) \<subseteq> all_points vs i"
proof (rule all_points_rel)
  have "\<forall>j \<in> pmax ` Y. j \<le> i"
    using assms by (auto simp: all_points_def pmax_def)
  moreover have "finite Y" using finite_subset[OF assms finite_all_points] .
  ultimately show "Pmax Y \<le> i" unfolding Pmax_def by auto
next
  have "\<forall>j \<in> Y. vars j |\<subseteq>| vs" using assms by (auto simp: all_points_def)
  thus "Sup (vars ` Y) |\<subseteq>| vs" by (simp add: fsubset_sup)
qed

lemma all_points_rel_rev:
  "all_points v i \<subseteq> (all_points v' i' :: ('a, 'b) point set) \<Longrightarrow> (v |\<subseteq>| v' \<and> i \<le> i')"
proof (rule ccontr)
  assume s: "all_points v i \<subseteq> (all_points v' i' :: ('a, 'b) point set)" "\<not> (v |\<subseteq>| v' \<and> i \<le> i')"
  hence "\<not> v |\<subseteq>| v' \<or> i > i'" by auto
  hence "\<lparr>id = i, wrs = v, rds = v, bar = True, esc = {||}, pairs = {||}\<rparr> \<notin> all_points v' i'"
    by (auto simp: all_points_def nmax_def)
  moreover have "\<lparr>id = i, wrs = v, rds = v, bar = True, esc = {||}, pairs = {||}\<rparr> \<in> all_points v i"
    by (auto simp: all_points_def nmax_def)
 ultimately show "False" using s(1) by auto
qed

lemma all_points_const:
  assumes "all_points v i \<subseteq> (all_points v' i' :: ('a, 'b) point set)"
  shows "all_points (c |\<union>| v) (max ic i) \<subseteq> all_points (c |\<union>| v') (max ic i')"
proof -
  have "v |\<subseteq>| v' \<and> i \<le> i'" using all_points_rel_rev[OF assms] by auto
  thus ?thesis by (intro all_points_rel) auto
qed

lemma [simp]:
  "Sup (vars ` (all_points vs i :: ('a, 'b) point set) ) = vs"
proof -
  let ?f = "\<lambda>d w r b e p. \<lparr>id = d, wrs = w, rds = r, bar = b, esc = e, pairs = p\<rparr>"
  have a: "(all_points vs i :: ('a, 'b) point set) = {?f d w r b e p | d w r b e p. w |\<subseteq>| vs \<and> r |\<subseteq>| vs \<and> e |\<subseteq>| vs \<and> Sup (snd ` fset p) |\<subseteq>| vs \<and> d \<le> i \<and> nmax (fst |`| p) \<le> i}"
    unfolding all_points_def apply auto
    by (metis (full_types) old.unit.exhaust point.surjective)

  have "(vars ` (all_points vs i :: ('a, 'b) point set)) = {j. j |\<subseteq>| vs}"
    apply (auto simp: a)
    apply (subgoal_tac "?f i x x True {||} {||} \<in> all_points vs i")
    unfolding a
    defer 1
    apply (auto simp: nmax_def)[1]
  proof -
    fix x :: "('a, 'b) SimAsm_State.var fset"
    assume a1: "\<lparr>point.id = i, wrs = x, rds = x, bar = True, esc = {||}, pairs = {||}\<rparr> \<in> {\<lparr>point.id = d, wrs = w, rds = r, bar = b, esc = e, pairs = p\<rparr> | d w r b e p. w |\<subseteq>| vs \<and> r |\<subseteq>| vs \<and> e |\<subseteq>| vs \<and> Sup (snd ` fset p) |\<subseteq>| vs \<and> d \<le> i \<and> nmax (fst |`| p) \<le> i}"
    have f2: "\<forall>p P f fa. (p::('a, 'b) SimAsm_Inter_Exec.point) \<notin> P \<or> (f::('a, 'b) SimAsm_State.var fset) \<noteq> fa p \<or> f \<in> fa ` P"
      by blast
    have "x = vars \<lparr>point.id = i, wrs = x, rds = x, bar = True, esc = {||}, pairs = {||}\<rparr>"
      by force
    then show "x \<in> vars ` {\<lparr>point.id = n, wrs = f, rds = fa, bar = b, esc = fb, pairs = fc\<rparr> | n f fa b fb fc. f |\<subseteq>| vs \<and> fa |\<subseteq>| vs \<and> fb |\<subseteq>| vs \<and> Sup (snd ` fset fc) |\<subseteq>| vs \<and> n \<le> i \<and> nmax (fst |`| fc) \<le> i}"
      using f2 a1 by meson
  qed

  moreover have "Sup {j. j |\<subseteq>| vs} = vs"
    by (metis cSup_eq_maximum mem_Collect_eq order_refl)
  ultimately show ?thesis by metis
qed

lemma all_points_nil:
  "(all_points vs i :: ('a, 'b) point set) \<noteq> {}"
proof -
  have a: "\<lparr>id = 0, wrs = {||}, rds = {||}, bar = True, esc = {||}, pairs = {||}\<rparr> \<in> all_points vs i"
    by (auto simp: all_points_def nmax_def)
  show ?thesis apply (rule ccontr) apply simp using a by blast
qed

lemma [simp]:
  "Pmax (all_points vs i :: ('a, 'b) point set) = i"
proof -
  let ?f = "\<lambda>d w r b e p. \<lparr>id = d, wrs = w, rds = r, bar = b, esc = e, pairs = p\<rparr>"
  have a: "(all_points vs i :: ('a, 'b) point set) = {?f d w r b e p | d w r b e p. w |\<subseteq>| vs \<and> r |\<subseteq>| vs \<and> e |\<subseteq>| vs \<and> Sup (snd ` fset p) |\<subseteq>| vs \<and> d \<le> i \<and> nmax (fst |`| p) \<le> i}"
    unfolding all_points_def apply auto
    by (metis (full_types) old.unit.exhaust point.surjective)

  have "id ` (all_points vs i  :: ('a, 'b) point set) = {j. j \<le> i}" unfolding a
    apply auto
    apply (subgoal_tac "?f x vs vs True {||} {|(x,{||})|} \<in> (all_points vs i  :: ('a, 'b) point set)")
    apply (metis (no_types, lifting) SimAsm_Inter_Exec.point.select_convs(1) a rev_image_eqI)
    unfolding a by (auto simp: nmax_def)
  moreover have b: "Max {j. j \<le> i} = i"
    by (metis Max_ge Max_in antisym emptyE finite_Collect_le_nat mem_Collect_eq order_refl)
  ultimately have c: "Max (id ` (all_points vs i  :: ('a, 'b) point set)) = i" by simp

  have "(nmax o (\<lambda>p. fst |`| pairs p)) ` (all_points vs i  :: ('a, 'b) point set) = {j. j \<le> i}" unfolding a
    apply auto
    apply (subgoal_tac "?f i vs vs True {||} {|(x,{||})|} \<in> all_points vs i")
    prefer 2
     apply (unfold a, auto simp: nmax_def)[1]
    apply (subgoal_tac "x \<in> (\<lambda>x. nmax (fst |`| SimAsm_Inter_Exec.point.pairs x)) ` {?f i vs vs True {||} {|(x,{||})|}}")
    prefer 2
    apply (auto simp: nmax_def)[1]
    unfolding a by fastforce
  hence d: "Max ((nmax o (\<lambda>p. fst |`| pairs p)) ` (all_points vs i  :: ('a, 'b) point set)) = i" using b by simp

  have "(MAX p\<in>(all_points vs i :: ('a, 'b) point set). max (point.id p) (nmax (fst |`| pairs p))) = i"
    using Max_max[OF finite_all_points, of id "nmax o (\<lambda>p. fst |`| pairs p)" vs i]
    unfolding c d by auto
  thus "Pmax (all_points vs i :: ('a, 'b) point set) = i"
    unfolding Pmax_def pmax_def using all_points_nil
    by auto
qed

lemma sup_in:
  assumes "finite P" "y \<in> P" "x |\<in>| f y"
  shows "x |\<in>| Sup (f ` P)"
proof -
  have "x \<in> fset (f y)" using assms(3) by (meson notin_fset)
  hence a: "x \<in> Sup ((fset o f) ` P)" using assms(2) by auto
  have f: "finite ((\<Union>a\<in>P. fset (f a)))" using assms(1) by simp
  hence "Sup ((fset o f) ` P) =  fset (Sup (f ` P))"
    unfolding Sup_fset_def apply auto
    using Abs_fset_inverse f apply blast
    using Abs_fset_inverse f by blast
  thus ?thesis using a notin_fset by metis
qed

lemma sup_in_l:
  assumes "i < length l" "x |\<in>| f (l ! i)"
  shows "x |\<in>| Sup (f ` set l)"
  using assms sup_in[of "set l" "l ! i" x f] by auto

lemma [simp]:
  "nmax (finsert a b) = max (a :: nat) (nmax b)"
  unfolding nmax_def by auto

lemma stren_all_points:
  "finite P \<Longrightarrow> xa \<in> P \<Longrightarrow> tag x < length l \<Longrightarrow>
          stren (l ! tag x) xa
          \<in> all_points
              (varsL l |\<union>| Sup (vars ` P))
              (max (length l) (Pmax P))"
  unfolding stren_def
  apply (subgoal_tac "xa \<in> all_points
              (varsL l |\<union>| Sup (vars ` P))
              (max (length l) (Pmax P))")
  apply (auto simp: all_points_def varsL_def)
  apply (rule sup_in_l; blast)
  apply (rule sup_in_l; blast)

  apply (subgoal_tac "xb |\<in>| Sup (vars ` P)")
  apply simp
  apply (rule sup_in)
  apply blast
  apply blast
  apply blast

  apply (subgoal_tac "xb |\<in>| Sup (vars ` P)")
  apply simp
  apply (rule sup_in)
  apply blast
  apply blast
  apply blast

  apply (subgoal_tac "xb |\<in>| Sup (vars ` P)")
  apply simp
  apply (rule sup_in)
  apply blast
  apply blast
  apply blast

  apply (subgoal_tac "xb |\<in>| Sup (vars ` P)")
  apply simp
  apply (rule sup_in)
  apply blast
  apply blast
  apply blast

  unfolding Pmax_def pmax_def
  apply (simp add: Max_max)
  apply (metis Max.bounded_iff empty_iff finite_imageI image_eqI max.cobounded1 max.coboundedI2)
  apply (simp add: Max_max)
  by (meson Max_ge empty_iff finite_imageI imageI le_max_iff_disj)

lemma [simp]:
  "finite b \<Longrightarrow> x |\<in>| Sup (insert a b) = (x |\<in>| a \<or> x |\<in>| Sup b)"
  unfolding Sup_fset_def
  apply auto
  by (metis Abs_fset_inverse Un_iff finite_UN_I finite_UnI finite_fset mem_Collect_eq notin_fset)+

lemma "finite (fset s)"
  by simp

lemma wken_all_points:
  "finite P \<Longrightarrow> xa \<in> P \<Longrightarrow> tag x < length l \<Longrightarrow>
          wken (tag x) (l ! tag x) xa
          \<in> all_points
              (varsL l |\<union>| Sup (vars ` P))
              (max (length l) (Pmax P))"
  unfolding wken_def
  apply (subgoal_tac "xa \<in> all_points
              (varsL l |\<union>| Sup (vars ` P))
              (max (length l) (Pmax P))")
  apply (auto simp: all_points_def varsL_def)
  apply (rule sup_in_l; blast)
  apply (rule sup_in_l; blast)
  apply (rule sup_in_l; blast)

  apply (subgoal_tac "xb |\<in>| Sup (vars ` P)")
  apply simp
  apply (rule sup_in)
  apply blast
  apply blast
  apply blast

  apply (subgoal_tac "xb |\<in>| Sup (vars ` P)")
  apply simp
  apply (rule sup_in)
  apply blast
  apply blast
  apply blast

  apply (subgoal_tac "xb |\<in>| Sup (vars ` P)")
  apply simp
  apply (rule sup_in)
  apply blast
  apply blast
  apply blast

  apply (subgoal_tac "xb |\<in>| Sup (vars ` P)")
  apply simp
  apply (rule sup_in)
  apply blast
  apply blast
  apply blast

  unfolding Pmax_def pmax_def
  apply (simp add: Max_max)
  apply (metis Max.bounded_iff empty_iff finite_imageI image_eqI max.cobounded1 max.coboundedI2)
  apply (simp add: Max_max)
  by (meson Max_ge empty_iff finite_imageI imageI le_max_iff_disj)

lemma proc1_all_points:
  "finite P \<Longrightarrow> xa \<in> P \<Longrightarrow> tag x < length l \<Longrightarrow>
          proc1 (tag x) (l ! tag x) xa
          \<subseteq> all_points
              (varsL l |\<union>| Sup (vars ` P))
              (max (length l) (Pmax P))"
  unfolding proc1_def
  apply clarsimp
  apply (intro conjI impI)
  using stren_all_points apply blast
  using stren_all_points apply blast
  using wken_all_points apply blast
  done

lemma gen_all_points:
  "tag x < length l \<Longrightarrow>
          gen (tag x) (l ! tag x)
          \<in> all_points
              (varsL l |\<union>| Sup (vars ` P))
              (max (length l) (Pmax P))"
  unfolding all_points_def nmax_def varsL_def
  apply auto
  apply (rule sup_in_l; blast)+
  done

lemma rif_bound:
  "finite P \<Longrightarrow> rif c l P \<subseteq> (all_points (varsL l |\<union>| Sup (vars ` P)) (max (length l) (Pmax P)) :: ('a, 'b) point set)"
proof (induct c arbitrary: P)
  case Nil
  then show ?case using set_all_points_bound' by auto
next
  case (Basic x)
  show ?case using Basic
    apply (auto simp: rif\<^sub>i_def)
    apply (rule gen_all_points; auto)
    using proc1_all_points apply blast
    using set_all_points_bound' by blast
next
  case (Seq c1 c2)
  let ?V="(all_points(varsL l |\<union>| Sup (vars ` P)) (max (length l) (Pmax P)) :: ('a, 'b) point set)"
  have f: "finite ?V" using finite_all_points by auto
  show ?case using Seq(1)[OF f] Seq(2)[OF Seq(3)] by simp (meson dual_order.trans monoD mono_rif)
next
  case (Choice c1 c2)
  then show ?case by auto
next
  case (Loop c)
  show ?case
    unfolding rif.simps
    apply (rule lfp_lowerbound)
    using Loop(1)[OF finite_all_points, of "(varsL l |\<union>| Sup (vars ` P))" "(max (length l) (Pmax P))"] set_all_points_bound'[OF Loop(2), of l]
    by auto
next
  case (Parallel c1 c2)
  show ?case unfolding rif.simps using set_all_points_bound'[OF Parallel(3)] by auto
next
  case (Thread c)
  show ?case unfolding rif.simps using set_all_points_bound'[OF Thread(2)] by auto
next
  case (Ord c1 c2)
  show ?case unfolding rif.simps using set_all_points_bound'[OF Ord(3)] by auto
next
  case (SeqChoice x)
  show ?case unfolding rif.simps using set_all_points_bound'[OF SeqChoice(1)] by auto
next
  case (CaptureAll c)
  show ?case unfolding rif.simps using set_all_points_bound'[OF CaptureAll(2)] by auto
qed

subsection \<open>While Rule\<close>

lemma rif_While:
  fixes b c P l
  assumes "finite (P :: ('a, 'b) point set)"
  defines "f == (\<lambda>Y. (P \<union> rif c l Y))"
  shows "rif (Loop c) l P = while (\<lambda>Y. f Y \<noteq> Y) f {}" (is "_ = ?r")
proof -
  let ?V = "all_points (varsL l |\<union>| Sup (vars ` P)) (max (length l) (Pmax P)) :: ('a, 'b) point set"
  have "lfp f = ?r"
  proof(rule lfp_while[where C = "?V"])
    show "mono f" using f_def mono_union_rif' by blast
  next
    fix Y assume a: "Y \<subseteq> ?V"
    have f: "finite Y" using a finite_all_points finite_subset by blast
    have "P \<subseteq> ?V" using set_all_points_bound' assms(1) by blast
    moreover have "rif c l Y \<subseteq> ?V"
      using rif_bound[OF f, of c l] all_points_const[OF all_points_sub[OF a]] by force
    ultimately show "f Y \<subseteq> ?V" unfolding f_def by blast
  next
    show "finite ?V" by (rule finite_all_points)
  qed
  thus ?thesis unfolding f_def rif.simps(3) by blast
qed

lemma rif_While_let: "finite X \<Longrightarrow> rif (Loop c) l X =
  (let f = (\<lambda>Y. X \<union> rif c l Y) in while (\<lambda>Y. f Y \<noteq> Y) f {})"
  by (simp add: rif_While)

lemma rif_While_set: "rif (Loop c) l (set xs) =
  (let f = (\<lambda>Y. set xs \<union> rif c l Y) in while (\<lambda>Y. f Y \<noteq> Y) f {})"
  by (rule rif_While_let, simp)

lemmas [code] = rif.simps(1,2,4,5,6,7) rif_While_set

section \<open>fset Execution\<close>

text \<open>List implementation of fset, similar to that of set\<close>

code_datatype fset_of_list

lemma fset_empty [code]:
  "{||} = fset_of_list []"
  by simp

lemma fset_insert [code]:
  "finsert a (fset_of_list x) = fset_of_list (List.insert a x)"
  by (simp add: List.insert_def finsert_absorb fset_of_list_elem)

lemma fset_union [code]:
  "fset_of_list a |\<union>| fset_of_list b = fset_of_list (List.union a b)"
  by (metis fset_of_list.abs_eq fset_of_list_append set_append set_union)

lemma fset_inter [code]:
  "A |\<inter>| fset_of_list xs = fset_of_list (List.filter (\<lambda>x. x |\<in>| A) xs)"
  by auto

lemma fset_remove [code]:
  "fset_of_list xs |-| A = fset_of_list (List.filter (\<lambda>x. x |\<notin>| A) xs)"
  by auto

lemma fset_hasGlobal [code]:
  "hasGlobal\<^sub>e (fset_of_list a) = hasGlobalL a"
  by (induct a) (auto simp: hasGlobal_def; case_tac a1, auto)+

lemma fset_mem [code]:
  "(x |\<in>| fset_of_list F) = (List.member F x)"
  by (simp add: fset_of_list_elem member_def)

lemma fset_subset [code]:
  "fset_of_list xs \<le> B \<longleftrightarrow> (\<forall>x\<in>set xs. x |\<in>| B)"
  using fset_of_list.rep_eq notin_fset
  by (metis (full_types) fin_mono fsubsetI)

declare fset_of_list_simps [code_post]

section \<open>Tactics\<close>

text \<open>Tactic to match the executable analysis within more abstract properties\<close>

attribute_setup get_conv = \<open>Args.term >> (fn t =>
        Thm.rule_attribute [] (fn context => fn _ =>
          (Code_Simp.dynamic_conv (Context.proof_of context) o Thm.cterm_of (Context.proof_of context)) t))\<close>

method rif_eval =
  (unfold rif_executable; simp add: Let_def del: rif.simps(1,2,4,5,6,7);
   match conclusion in "wellformed R G \<longrightarrow> checks (expand_points (rif c l {}) l') R G" for c and R and G
      and l' :: "('v :: equal,'g :: equal,'r :: equal,'a :: equal) enuml"
      and l :: "('v,'g,'r) op list"  \<Rightarrow>
    \<open>match [[get_conv "rif c l {}"]] in U: _ \<Rightarrow> \<open>subst U\<close>\<close>)

end


theory Small_Step_7p9
imports
Star
Big_Step_7p9
begin

subsection "The transition relation"

inductive
  small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |

Seq1:    "(SKIP;;c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |
Seq2:    "(c\<^sub>1,s) \<rightarrow> (c\<^sub>1',s') \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s) \<rightarrow> (c\<^sub>1';;c\<^sub>2,s')" |

IfTrue:  "bval b s  \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>1, s)" |
IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |

While:   "(WHILE b DO c,s) \<rightarrow>
            (IF b THEN c;; WHILE b DO c ELSE SKIP, s)" |

(* Non deterministic since left side is same but right side different *)
OrLeft:  "(c\<^sub>1 OR c\<^sub>2, s) \<rightarrow> (c\<^sub>1, s)" |
OrRight: "(c\<^sub>1 OR c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)"

abbreviation
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

code_pred small_step .

lemmas small_step_induct = small_step.induct[split_format(complete)]

declare small_step.intros[simp,intro]

text{* Rule inversion: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<rightarrow> ct"
thm SkipE
inductive_cases AssignE[elim!]: "(x::=a,s) \<rightarrow> ct"
thm AssignE
inductive_cases SeqE[elim]: "(c1;;c2,s) \<rightarrow> ct"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<rightarrow> ct"
thm IfE
inductive_cases WhileE[elim]: "(WHILE b DO c, s) \<rightarrow> ct"
thm WhileE
inductive_cases OrE[elim!]: "(c\<^sub>1 OR c\<^sub>2, s) \<rightarrow> ct"
thm OrE

(* Lemma 7.11 used to say that IMP is deterministic.
   Once you add non-deterministic choice it no longer is.

  lemma "cs \<rightarrow> cs' \<Longrightarrow> cs \<rightarrow> cs'' \<Longrightarrow> cs'' = cs'"
*)

(* Lemma 7.13 *)
lemma star_seq2: "(c1, s1) \<rightarrow>* (c, s2) \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (c;; c2, s2)"
proof (induction "(c1,s1)" "(c,s2)" arbitrary: c1 s1 c s2  rule: star.induct)
  case (refl)
  then show ?case by simp
next
  case (step y)
  obtain c1' s1' where a: "y = (c1', s1')" by fastforce
  have star: "(c1';;c2, s1') \<rightarrow>* (c;;c2, s2)" using step.hyps(3) a by blast
  have first: "(c1;; c2, s1) \<rightarrow> (c1';;c2, s1')" using step.hyps(1) a  by blast
  thus ?case using first star step.hyps by (simp add: star.step)
qed

(* I was having trouble with proving
     obtain c1' s1' where a: "y = (c1', s1')"
  It is equivalent to the following. If you can prove that
  you can prove the "obtain" *)

lemma "\<And>thesis. (\<And>c1' s1'. y = (c1', s1') \<Longrightarrow> thesis) \<Longrightarrow> thesis"
proof -
  fix thesis
  assume [intro]: "\<And>c1' s1'. y = (c1', s1') \<Longrightarrow> thesis"
  then show thesis by fastforce
qed

thm big_step.WhileTrue

(* Lemma 7.12 *)
lemma big_step_imp_small_step: "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP, t)"
proof (induction rule: big_step.induct)
  case (Skip s)
  then show ?case by blast
next
  case (Assign x a s)
  then show ?case by blast
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case by (blast intro: star.step star_seq2 star_trans)
next
  case (IfTrue b s c\<^sub>1 t c\<^sub>2)
  then have "(IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>1, s)" by blast
  then show ?case using IfTrue.IH by (blast intro: star.step)
next
  case (IfFalse b s c\<^sub>2 t c\<^sub>1)
  then have "(IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" by blast
  then show ?case using IfFalse.IH by (blast intro: star.step)
next
  case (WhileFalse b s c)
  then have a: "(WHILE b DO c,s) \<rightarrow>
            (IF b THEN (c;; WHILE b DO c) ELSE SKIP,s)" by blast
  then have "(IF b THEN (c;; WHILE b DO c) ELSE SKIP,s) \<rightarrow>* (SKIP,s)" using WhileFalse.hyps by blast
  then show "(WHILE b DO c, s) \<rightarrow>* (SKIP, s)" using a by (blast intro: star.step)
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  let ?w = "WHILE b DO c"
  let ?if = "IF b THEN c;; ?w ELSE SKIP"
  have 1: "(?w, s\<^sub>1) \<rightarrow>* (?if, s\<^sub>1)" by blast
  have 2: "(?if, s\<^sub>1) \<rightarrow>* (c;;?w, s\<^sub>1)" using WhileTrue(1) by blast
  have 3: "(c;;?w, s\<^sub>1) \<rightarrow>* (SKIP;;?w, s\<^sub>2)" using WhileTrue.IH(1) by (simp add: star_seq2)
  have 4: "(SKIP;;?w, s\<^sub>2) \<rightarrow>* (?w, s\<^sub>2)" by simp
  then have "(?w, s\<^sub>1) \<rightarrow>* (?w, s\<^sub>2)" using 1 2 3 4 by (blast intro: star_trans)
  then show ?case using WhileTrue.IH by (blast intro: star_trans)
next
  case (OrLeft c\<^sub>1 s t c\<^sub>2)
  show ?case using OrLeft.IH by (blast intro: star_trans)
next
  case (OrRight c\<^sub>2 s t c\<^sub>1)
  show ?case using OrRight.IH by (blast intro: star_trans)
qed

(* I could have got an even smaller proof for the WhileTrue cases above if I'd have proved this
   I could then have got
     assume w: "(?w,s') \<rightarrow>* (SKIP,t)"
     assume c: "(c,s) \<rightarrow>* (SKIP,s')"
     have new_3: "(c;; ?w,s) \<rightarrow>* (SKIP,t)" by(rule seq_comp[OF c w])

     Then I could have used 1 2 and new_3

*)
lemma seq_comp: "\<lbrakk> (c\<^sub>1, s\<^sub>1) \<rightarrow>* (SKIP, s\<^sub>2); (c\<^sub>2, s\<^sub>2) \<rightarrow>* (SKIP, s\<^sub>3) \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<rightarrow>* (SKIP, s\<^sub>3)"
  by (blast intro: star_seq2 star_trans)

(* Lemma 7.15 *)
lemma small_big_comp: "\<lbrakk> cs \<rightarrow> cs'; cs' \<Rightarrow> t \<rbrakk> \<Longrightarrow> cs \<Rightarrow> t"
  apply  (induction arbitrary: t rule: small_step.induct)
       apply blast+
done

(* Lemma 7.14 *)

(* The induction here was interesting because we didn't have to use "arbitrary" in
proof (induction "cs" "(SKIP, t)" rule: star.induct *)
lemma small_step_imp_big_step: "cs \<rightarrow>* (SKIP, t) \<Longrightarrow> cs \<Rightarrow> t"
proof (induction "cs" "(SKIP, t)" rule: star.induct)
  case refl
  then show ?case by blast
next
  case (step cs cs')
  assume "cs \<rightarrow> cs'"
     and "cs' \<Rightarrow> t"
  thus ?case by (rule small_big_comp)
qed

(* The textbook got us to prove "(c,s) \<Rightarrow> t \<longleftrightarrow> (c,s) \<rightarrow>* (SKIP, t)"
   which ended up meaning that the proof for 7.18 did not go through easily.
   The form below, using "cs" insteand of "(c,s)" is the same as the form for
   final_iff_SKIP
 *)

(* Lemma 7.16 *)
lemma big_iff_small: "cs \<Rightarrow> t \<longleftrightarrow> cs \<rightarrow>* (SKIP, t)"
proof
  show "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP, t)" by (rule big_step_imp_small_step)
next
  show "cs \<rightarrow>* (SKIP, t) \<Longrightarrow> cs \<Rightarrow> t" by (rule small_step_imp_big_step)
qed

definition final :: "com \<times> state \<Rightarrow> bool" where
  "final cs \<longleftrightarrow> \<not>(\<exists>cs'. cs \<rightarrow> cs')"

(* Lemma 7.17 *)
lemma final_iff_SKIP: "final (c,s) = (c = SKIP)"
proof
  show "c = SKIP \<Longrightarrow> final (c, s)" by (auto simp: final_def)
next
  show "final (c, s) \<Longrightarrow> c = SKIP"
    apply (simp add: final_def)
    apply (induction c rule: com.induct)
        apply blast+
    done
qed

(* Lemma 7.18 *)
lemma "(\<exists>t. cs \<Rightarrow> t) \<longleftrightarrow> (\<exists>cs'. cs \<rightarrow>* cs' \<and> final cs')"
  apply (simp add: final_iff_SKIP)
  apply (simp add: big_iff_small)
  done

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

section "Lemmas for Word Length 32"

theory Word_Lemmas_32
imports
  Word_Lemmas_Prefix
  Word_Setup_32
begin

lemma ucast_8_32_inj:
  "inj (ucast ::  8 word \<Rightarrow> 32 word)"
  by (rule down_ucast_inj) (clarsimp simp: is_down_def target_size source_size)

lemma upto_2_helper:
  "{0..<2 :: 32 word} = {0, 1}"
  by (safe; simp) unat_arith

lemmas upper_bits_unset_is_l2p_32 = upper_bits_unset_is_l2p [where 'a=32, folded word_bits_def]
lemmas le_2p_upper_bits_32 = le_2p_upper_bits [where 'a=32, folded word_bits_def]
lemmas le2p_bits_unset_32 = le2p_bits_unset[where 'a=32, folded word_bits_def]

lemma word_bits_len_of:
  "len_of TYPE (32) = word_bits"
  by (simp add: word_bits_conv)

lemmas unat_power_lower32' = unat_power_lower[where 'a=32]
lemmas unat_power_lower32 [simp] = unat_power_lower32'[unfolded word_bits_len_of]

lemmas word32_less_sub_le' = word_less_sub_le[where 'a = 32]
lemmas word32_less_sub_le[simp] = word32_less_sub_le' [folded word_bits_def]

lemma word_bits_size:
  "size (w::word32) = word_bits"
  by (simp add: word_bits_def word_size)

lemmas word32_power_less_1' = word_power_less_1[where 'a = 32]
lemmas word32_power_less_1[simp] = word32_power_less_1'[folded word_bits_def]

lemma of_nat32_0:
  "\<lbrakk>of_nat n = (0::word32); n < 2 ^ word_bits\<rbrakk> \<Longrightarrow> n = 0"
  by (erule of_nat_0, simp add: word_bits_def)

lemma unat_mask_2_less_4:
  "unat (p && mask 2 :: word32) < 4"
  apply (rule unat_less_helper)
  apply (rule order_le_less_trans, rule word_and_le1)
  apply (simp add: mask_def)
  done

lemmas unat_of_nat32' = unat_of_nat_eq[where 'a=32]
lemmas unat_of_nat32 = unat_of_nat32'[unfolded word_bits_len_of]

lemmas word_power_nonzero_32 = word_power_nonzero [where 'a=32, folded word_bits_def]

lemmas unat_mult_simple = iffD1 [OF unat_mult_lem [where 'a = 32, unfolded word_bits_len_of]]

lemmas div_power_helper_32 = div_power_helper [where 'a=32, folded word_bits_def]

lemma n_less_word_bits:
  "(n < word_bits) = (n < 32)"
  by (simp add: word_bits_def)

lemmas of_nat_less_pow_32 = of_nat_power [where 'a=32, folded word_bits_def]

lemma lt_word_bits_lt_pow:
  "sz < word_bits \<Longrightarrow> sz < 2 ^ word_bits"
  by (simp add: word_bits_conv)

lemma unat_less_word_bits:
  fixes y :: word32
  shows "x < unat y \<Longrightarrow> x < 2 ^ word_bits"
  unfolding word_bits_def
  by (rule order_less_trans [OF _ unat_lt2p])

lemmas unat_mask_word32' = unat_mask[where 'a=32]
lemmas unat_mask_word32 = unat_mask_word32'[folded word_bits_def]

lemma unat_less_2p_word_bits:
  "unat (x :: 32 word) < 2 ^ word_bits"
  apply (simp only: word_bits_def)
  apply (rule unat_lt2p)
  done

lemma Suc_unat_mask_div:
  "Suc (unat (mask sz div word_size::word32)) = 2 ^ (min sz word_bits - 2)"
  apply (case_tac "sz < word_bits")
   apply (case_tac "2\<le>sz")
    apply (clarsimp simp: word_size_def word_bits_def min_def mask_def)
    apply (drule (2) Suc_div_unat_helper
           [where 'a=32 and sz=sz and us=2, simplified, symmetric])
   apply (simp add: not_le word_size_def word_bits_def)
   apply (case_tac sz, simp add: unat_word_ariths)
   apply (case_tac nat, simp add: unat_word_ariths
                                  unat_mask_word32 min_def word_bits_def)
   apply simp
  apply (simp add: unat_word_ariths
                   unat_mask_word32 min_def word_bits_def word_size_def)
  done

lemmas word32_minus_one_le' = word_minus_one_le[where 'a=32]
lemmas word32_minus_one_le = word32_minus_one_le'[simplified]

lemma ucast_not_helper:
  fixes a::word8
  assumes a: "a \<noteq> 0xFF"
  shows "ucast a \<noteq> (0xFF::word32)"
proof
  assume "ucast a = (0xFF::word32)"
  also
  have "(0xFF::word32) = ucast (0xFF::word8)" by simp
  finally
  show False using a
    apply -
    apply (drule up_ucast_inj, simp)
    apply simp
    done
qed

lemma less_4_cases:
  "(x::word32) < 4 \<Longrightarrow> x=0 \<or> x=1 \<or> x=2 \<or> x=3"
  apply clarsimp
  apply (drule word_less_cases, erule disjE, simp, simp)+
  done

lemma unat_ucast_8_32:
  fixes x :: "word8"
  shows "unat (ucast x :: word32) = unat x"
  unfolding ucast_def unat_def
  apply (subst int_word_uint)
  apply (subst mod_pos_pos_trivial)
    apply simp
   apply (rule lt2p_lem)
   apply simp
  apply simp
  done

lemma if_then_1_else_0:
  "((if P then 1 else 0) = (0 :: word32)) = (\<not> P)"
  by simp

lemma if_then_0_else_1:
  "((if P then 0 else 1) = (0 :: word32)) = (P)"
  by simp

lemmas if_then_simps = if_then_0_else_1 if_then_1_else_0

lemma ucast_le_ucast_8_32:
  "(ucast x \<le> (ucast y :: word32)) = (x \<le> (y :: word8))"
  by (simp add: ucast_le_ucast)

lemma in_16_range:
  "0 \<in> S \<Longrightarrow> r \<in> (\<lambda>x. r + x * (16 :: word32)) ` S"
  "n - 1 \<in> S \<Longrightarrow> (r + (16 * n - 16)) \<in> (\<lambda>x :: word32. r + x * 16) ` S"
  by (clarsimp simp: image_def elim!: bexI[rotated])+

lemma eq_2_32_0:
  "(2 ^ 32 :: word32) = 0"
  by simp

lemma x_less_2_0_1:
  fixes x :: word32 shows
  "x < 2 \<Longrightarrow> x = 0 \<or> x = 1"
  by (rule x_less_2_0_1') auto

lemmas mask_32_max_word  = max_word_mask [symmetric, where 'a=32, simplified]

lemma of_nat32_n_less_equal_power_2:
 "n < 32 \<Longrightarrow> ((of_nat n)::32 word) < 2 ^ n"
  by (rule of_nat_n_less_equal_power_2, clarsimp simp: word_size)

lemma word_rsplit_0:
  "word_rsplit (0 :: word32) = [0, 0, 0, 0 :: word8]"
  apply (simp add: word_rsplit_def bin_rsplit_def Let_def)
  done

lemma unat_ucast_10_32 :
  fixes x :: "10 word"
  shows "unat (ucast x :: word32) = unat x"
  unfolding ucast_def unat_def
  apply (subst int_word_uint)
  apply (subst mod_pos_pos_trivial)
    apply simp
   apply (rule lt2p_lem)
   apply simp
  apply simp
  done

lemma bool_mask [simp]:
  fixes x :: word32
  shows "(0 < x && 1) = (x && 1 = 1)"
  by (rule bool_mask') auto

lemma word32_bounds:
  "- (2 ^ (size (x :: word32) - 1)) = (-2147483648 :: int)"
  "((2 ^ (size (x :: word32) - 1)) - 1) = (2147483647 :: int)"
  "- (2 ^ (size (y :: 32 signed word) - 1)) = (-2147483648 :: int)"
  "((2 ^ (size (y :: 32 signed word) - 1)) - 1) = (2147483647 :: int)"
  by (simp_all add: word_size)

lemma word_ge_min:"sint (x::32 word) \<ge> -2147483648"
  by (metis sint_ge word32_bounds(1) word_size)

lemmas signed_arith_ineq_checks_to_eq_word32'
    = signed_arith_ineq_checks_to_eq[where 'a=32]
      signed_arith_ineq_checks_to_eq[where 'a="32 signed"]

lemmas signed_arith_ineq_checks_to_eq_word32
    = signed_arith_ineq_checks_to_eq_word32' [unfolded word32_bounds]

lemmas signed_mult_eq_checks32_to_64'
    = signed_mult_eq_checks_double_size[where 'a=32 and 'b=64]
      signed_mult_eq_checks_double_size[where 'a="32 signed" and 'b=64]

lemmas signed_mult_eq_checks32_to_64 = signed_mult_eq_checks32_to_64'[simplified]

lemmas sdiv_word32_max' = sdiv_word_max [where 'a=32] sdiv_word_max [where 'a="32 signed"]
lemmas sdiv_word32_max = sdiv_word32_max'[simplified word_size, simplified]

lemmas sdiv_word32_min' = sdiv_word_min [where 'a=32] sdiv_word_min [where 'a="32 signed"]
lemmas sdiv_word32_min = sdiv_word32_min' [simplified word_size, simplified]

lemmas sint32_of_int_eq' = sint_of_int_eq [where 'a=32]
lemmas sint32_of_int_eq = sint32_of_int_eq' [simplified]

lemma ucast_of_nats [simp]:
  "(ucast (of_nat x :: word32) :: sword32) = (of_nat x)"
  "(ucast (of_nat x :: word32) :: sword16) = (of_nat x)"
  "(ucast (of_nat x :: word32) :: sword8) = (of_nat x)"
  "(ucast (of_nat x :: word16) :: sword16) = (of_nat x)"
  "(ucast (of_nat x :: word16) :: sword8) = (of_nat x)"
  "(ucast (of_nat x :: word8) :: sword8) = (of_nat x)"
  by (auto simp: ucast_of_nat is_down)

lemmas signed_shift_guard_simpler_32'
    = power_strict_increasing_iff[where b="2 :: nat" and y=31]
lemmas signed_shift_guard_simpler_32 = signed_shift_guard_simpler_32'[simplified]

lemma word32_31_less:
  "31 < len_of TYPE (32 signed)" "31 > (0 :: nat)"
  "31 < len_of TYPE (32)" "31 > (0 :: nat)"
  by auto

lemmas signed_shift_guard_to_word_32
    = signed_shift_guard_to_word[OF word32_31_less(1-2)]
    signed_shift_guard_to_word[OF word32_31_less(3-4)]

lemma le_step_down_word_3:
  fixes x :: "32 word"
  shows "\<lbrakk>x \<le>  y; x \<noteq> y; y < 2 ^ 32 - 1\<rbrakk> \<Longrightarrow> x \<le> y - 1"
  by (rule le_step_down_word_2, assumption+)

lemma shiftr_1:
  "(x::word32) >> 1 = 0 \<Longrightarrow> x < 2"
  by word_bitwise clarsimp

lemma has_zero_byte:
  "~~ (((((v::word32) && 0x7f7f7f7f) + 0x7f7f7f7f) || v) || 0x7f7f7f7f) \<noteq> 0
    \<Longrightarrow> v && 0xff000000 = 0 \<or> v && 0xff0000 = 0 \<or> v && 0xff00 = 0 \<or> v && 0xff = 0"
  apply clarsimp
  apply word_bitwise
  by metis

lemma mask_step_down_32:
  "(b::32word) && 0x1 = (1::32word) \<Longrightarrow> (\<exists>x. x < 32 \<and> mask x = b >> 1) \<Longrightarrow> (\<exists>x. mask x = b)"
  apply clarsimp
  apply (rule_tac x="x + 1" in exI)
  apply (subgoal_tac "x \<le> 31")
   apply (erule le_step_down_nat, clarsimp simp:mask_def, word_bitwise, clarsimp+)+
   apply (clarsimp simp:mask_def, word_bitwise, clarsimp)
  apply clarsimp
  done

lemma unat_of_int_32:
  "\<lbrakk>i \<ge> 0; i \<le>2 ^ 31\<rbrakk> \<Longrightarrow> (unat ((of_int i)::sword32)) = nat i"
  unfolding unat_def
  apply (subst eq_nat_nat_iff, clarsimp+)
  apply (simp add: word_of_int uint_word_of_int)
  done

(* Helper for packing then unpacking a 64-bit variable. *)
lemma cast_chunk_assemble_id_64[simp]:
  "(((ucast ((ucast (x::64 word))::32 word))::64 word) || (((ucast ((ucast (x >> 32))::32 word))::64 word) << 32)) = x"
  by (simp add:cast_chunk_assemble_id)

(* Another variant of packing and unpacking a 64-bit variable. *)
lemma cast_chunk_assemble_id_64'[simp]:
  "(((ucast ((scast (x::64 word))::32 word))::64 word) || (((ucast ((scast (x >> 32))::32 word))::64 word) << 32)) = x"
  by (simp add:cast_chunk_scast_assemble_id)

(* Specialisations of down_cast_same for adding to local simpsets. *)
lemma cast_down_u64: "(scast::64 word \<Rightarrow> 32 word) = (ucast::64 word \<Rightarrow> 32 word)"
  apply (subst down_cast_same[symmetric])
   apply (simp add:is_down)+
  done

lemma cast_down_s64: "(scast::64 sword \<Rightarrow> 32 word) = (ucast::64 sword \<Rightarrow> 32 word)"
  apply (subst down_cast_same[symmetric])
   apply (simp add:is_down)+
  done

end