theory InsertionSort
  imports Main "HOL-Hoare.Separation"
begin

fun swapAt where
  "swapAt i j xs = list_update (list_update xs i (xs ! j)) j (xs ! i)"

lemma swapAt_same: "i < length xs \<Longrightarrow> swapAt i i xs = xs"
  apply (induct xs)
  apply simp
  apply simp
  done

lemma swapAt_nth: "\<And>k. i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> swapAt i j xs ! k = (if k = i then xs ! j else if k = j then xs ! i else xs ! k)"
  apply (induct xs)
  apply auto
  apply (metis list_update.simps(2) list_update_id)
  apply (metis length_Cons length_list_update list_update.simps(2) nth_list_update_eq)
  apply (metis length_Cons list_update.simps(2) nth_list_update_eq)
  by (metis list_update.simps(2) nth_list_update_neq)

inductive array where
  "array H p 0 []"
| "H p = Some a \<Longrightarrow> array H (p+1) k as \<Longrightarrow> array H p (Suc k) (a#as)"

lemma array_length:
  "array H p k xs \<Longrightarrow> length xs = k"
  apply (induct rule: array.induct)
  apply auto
  done

lemma array_singleton:
  assumes "array H p 1 xs"
  obtains x where "xs = [x]"
  using assms
  by (metis One_nat_def array.cases nat.simps(1) nat.simps(3))

lemma array_empty_from: "array H p n [] \<Longrightarrow> n = 0"
  apply (cases n)
  apply simp
  apply simp
  using array_length by force

lemma array_exists_under_heap_modification:
  assumes "array H p n xs"
  obtains zs where "array (H(x \<mapsto> y)) p n zs" "\<And>i. i < n \<Longrightarrow> if x = p + i then zs ! i = y else zs ! i = xs ! i"
proof-
  have "array H p n xs \<Longrightarrow> \<exists>zs. array (H(x \<mapsto> y)) p n zs \<and> (\<forall>i. i < n \<longrightarrow> (if x = p + i then zs ! i = y else zs ! i = xs ! i))"
    apply (induct rule: array.induct)
    using array.intros(1) apply blast
  proof-
    fix H p a k as
    assume "H p = Some a" "array H (p + 1) k as"
    and "\<exists>zs. array (H(x \<mapsto> y)) (p + 1) k zs \<and> (\<forall>i<k. if x = p + 1 + i then zs ! i = y else zs ! i = as ! i)"
    obtain zs where "array (H(x \<mapsto> y)) (p + 1) k zs \<and> (\<forall>i<k. if x = p + 1 + i then zs ! i = y else zs ! i = as ! i)"
      using \<open>\<exists>zs. array (H(x \<mapsto> y)) (p + 1) k zs \<and> (\<forall>i<k. if x = p + 1 + i then zs ! i = y else zs ! i = as ! i)\<close> by blast
    have "length zs = k"
      using \<open>array (H(x \<mapsto> y)) (p + 1) k zs \<and> (\<forall>i<k. if x = p + 1 + i then zs ! i = y else zs ! i = as ! i)\<close> array_length by blast

    { assume "p = x"
      have "\<And>i. i < k \<Longrightarrow> x \<noteq> p + 1 + i"
        by (simp add: \<open>p = x\<close>)
      hence "\<And>i. i < k \<Longrightarrow> zs ! i = as ! i"
        by (simp add: \<open>array (H(x \<mapsto> y)) (p + 1) k zs \<and> (\<forall>i<k. if x = p + 1 + i then zs ! i = y else zs ! i = as ! i)\<close>)
      hence "zs = as"
        by (metis \<open>array H (p + 1) k as\<close> \<open>length zs = k\<close> array_length list_eq_iff_nth_eq)

      have "array (H(x \<mapsto> y)) p (Suc k) (y # zs) \<and> (\<forall>i<Suc k. if x = p + i then (y # zs) ! i = y else (y # zs) ! i = (a # as) ! i)"
        by (metis \<open>array (H(x \<mapsto> y)) (p + 1) k zs \<and> (\<forall>i<k. if x = p + 1 + i then zs ! i = y else zs ! i = as ! i)\<close> \<open>p = x\<close> \<open>zs = as\<close> add.right_neutral add_left_cancel array.intros(2) fun_upd_same nth_Cons')
    }
    hence "p = x \<Longrightarrow> array (H(x \<mapsto> y)) p (Suc k) (y # zs) \<and> (\<forall>i<Suc k. if x = p + i then (y # zs) ! i = y else (y # zs) ! i = (a # as) ! i)"
      by blast

    { assume "p \<noteq> x"

      have "array (H(x \<mapsto> y)) p (Suc k) (a # zs) \<and> (\<forall>i<Suc k. if x = p + i then (a # zs) ! i = y else (a # zs) ! i = (a # as) ! i)"
        by (smt \<open>H p = Some a\<close> \<open>array (H(x \<mapsto> y)) (p + 1) k zs \<and> (\<forall>i<k. if x = p + 1 + i then zs ! i = y else zs ! i = as ! i)\<close> \<open>p \<noteq> x\<close> add.right_neutral add_diff_cancel_left' array.intros(2) group_cancel.add1 less_Suc_eq_0_disj map_upd_Some_unfold nth_Cons_0 nth_Cons_pos plus_1_eq_Suc)
    }
    hence "p \<noteq> x \<Longrightarrow> array (H(x \<mapsto> y)) p (Suc k) (a # zs) \<and> (\<forall>i<Suc k. if x = p + i then (a # zs) ! i = y else (a # zs) ! i = (a # as) ! i)"
      by blast

    show "\<exists>zs. array (H(x \<mapsto> y)) p (Suc k) zs \<and> (\<forall>i<Suc k. if x = p + i then zs ! i = y else zs ! i = (a # as) ! i)"
      using \<open>p = x \<Longrightarrow> array (H(x \<mapsto> y)) p (Suc k) (y # zs) \<and> (\<forall>i<Suc k. if x = p + i then (y # zs) ! i = y else (y # zs) ! i = (a # as) ! i)\<close> \<open>p \<noteq> x \<Longrightarrow> array (H(x \<mapsto> y)) p (Suc k) (a # zs) \<and> (\<forall>i<Suc k. if x = p + i then (a # zs) ! i = y else (a # zs) ! i = (a # as) ! i)\<close> by blast
  qed

  show "(\<And>zs. array (H(x \<mapsto> y)) p n zs \<Longrightarrow> (\<And>i. i < n \<Longrightarrow> if x = p + i then zs ! i = y else zs ! i = xs ! i) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
    using assms
    using \<open>array H p n xs \<Longrightarrow> \<exists>zs. array (H(x \<mapsto> y)) p n zs \<and> (\<forall>i<n. if x = p + i then zs ! i = y else zs ! i = xs ! i)\<close> by blast
qed

lemma array_list_at:
  "array H p n xs \<Longrightarrow> (\<And>k. k < n \<Longrightarrow> Some (xs ! k) = H (p + k))"
  apply (induct rule: array.induct)
  apply auto
  using less_Suc_eq_0_disj by auto

lemma array_swap_at:
  assumes "array H p n xs" "i < length xs" "j < length xs"
  shows "array (H(p + i \<mapsto> the (H (p + j)), p + j \<mapsto> the (H (p + i)))) p n (swapAt i j xs)"
proof-
  obtain ys where
    ys_array: "array (H(p + i \<mapsto> the (H (p + j)))) p n ys"
    and "\<And>k. k < n \<Longrightarrow> if p + i = p + k then ys ! k = the (H (p + j)) else ys ! k = xs ! k"
    apply (rule array_exists_under_heap_modification [OF assms(1), of "p + i" "the (H (p + j))"])
    by blast
  obtain zs where
    "array (H(p + i \<mapsto> the (H (p + j)), p + j \<mapsto> the (H (p + i)))) p n zs"
    "\<And>k. k < n \<Longrightarrow> if p + j = p + k then zs ! k = the (H (p + i)) else zs ! k = ys ! k"
    apply (rule array_exists_under_heap_modification [OF ys_array, of "p + j" "the (H (p + i))"])
    by blast

  have "\<And>k. k < n \<Longrightarrow> if k = i then zs ! k = the (H (p + j)) else if k = j then zs ! k = the (H (p + i)) else zs ! k = xs ! k"
    by (simp add: \<open>\<And>k. k < n \<Longrightarrow> if p + i = p + k then ys ! k = the (H (p + j)) else ys ! k = xs ! k\<close> \<open>\<And>k. k < n \<Longrightarrow> if p + j = p + k then zs ! k = the (H (p + i)) else zs ! k = ys ! k\<close>)
  have "xs ! j = the (H (p + j))" "xs ! i = the (H (p + i))"
    apply (metis array_length array_list_at assms(1) assms(3) option.sel)
    by (metis array_length array_list_at assms(1) assms(2) option.sel)
  have "\<And>k. k < n \<Longrightarrow> zs ! k = (if k = i then xs ! j else if k = j then xs ! i else xs ! k)"
    by (simp add: \<open>\<And>k. k < n \<Longrightarrow> if k = i then zs ! k = the (H (p + j)) else if k = j then zs ! k = the (H (p + i)) else zs ! k = xs ! k\<close> \<open>xs ! i = the (H (p + i))\<close> \<open>xs ! j = the (H (p + j))\<close>)
  have "\<And>k. k < n \<Longrightarrow> swapAt i j xs ! k = (if k = i then xs ! j else if k = j then xs ! i else xs ! k)"
    using assms(2) assms(3) swapAt_nth by blast
  have "\<And>k. k < n \<Longrightarrow> zs ! k = swapAt i j xs ! k"
    using \<open>\<And>k. k < n \<Longrightarrow> swapAt i j xs ! k = (if k = i then xs ! j else if k = j then xs ! i else xs ! k)\<close> \<open>\<And>k. k < n \<Longrightarrow> zs ! k = (if k = i then xs ! j else if k = j then xs ! i else xs ! k)\<close> by auto
  have "length zs = n"
    using \<open>array (H(p + i \<mapsto> the (H (p + j)), p + j \<mapsto> the (H (p + i)))) p n zs\<close> array_length by blast
  have "zs = swapAt i j xs"
    by (metis \<open>\<And>k. k < n \<Longrightarrow> zs ! k = swapAt i j xs ! k\<close> \<open>length zs = n\<close> array_length assms(1) length_list_update list_eq_iff_nth_eq swapAt.simps)

  show ?thesis
    using \<open>array (H(p + i \<mapsto> the (H (p + j)), p + j \<mapsto> the (H (p + i)))) p n zs\<close> \<open>zs = swapAt i j xs\<close> by blast
qed

primrec count where
  "count a [] = 0"
| "count a (x#xs) = (if a = x then Suc (count a xs) else count a xs)"

definition permute where
  "permute xs ys \<equiv> (\<forall>a. count a xs = count a ys)"

primrec head_swap_with where
  "head_swap_with [] y = [y]"
| "head_swap_with (x#xs) y = x#y#xs"

fun removeAt where
  "removeAt i xs = take i xs @ drop (i+1) xs"

lemma removeAt_length: "i < length xs \<Longrightarrow> length (removeAt i xs) = length xs - 1"
  apply (induct xs arbitrary: i)
  apply auto
  done

lemma removeAt_at: "\<And>k. i < length xs \<Longrightarrow> removeAt i xs ! k = (if k < i then xs ! k else xs ! (k + 1))"
  apply (induct xs arbitrary: i)
  apply auto
  apply (simp add: nth_append)
  by (simp add: min.absorb2 nth_append)

fun slice where
  "slice i j xs = drop (i - 1) (take j xs)"

lemma take_as_slice: "take n xs = slice 0 n xs"
  by simp

lemma sorted_for_slice: "sorted xs \<Longrightarrow> sorted (slice i j xs)"
  by (simp add: sorted_drop sorted_take)

lemma sorted_snoc:
  assumes "sorted xs" "\<And>k. k < length xs \<Longrightarrow> xs ! k \<le> z"
  shows "sorted (xs @ [z])"
proof-
  { fix n
    have "n = length xs \<and> sorted xs \<and> (\<forall>k. k < length xs \<longrightarrow> xs ! k \<le> z) \<Longrightarrow> sorted (xs @ [z])"
      apply (induct n arbitrary: xs)
      apply auto
    proof-
      fix n xs
      assume "(\<And>xs. n = length xs \<and> sorted xs \<and> (\<forall>k<length xs. xs ! k \<le> z) \<Longrightarrow> sorted (xs @ [z]))"
        "Suc n = length xs" "sorted xs" "\<forall>k<length xs. xs ! k \<le> z"
      obtain y ys where "xs = y # ys" "length ys = n"
        by (meson Suc_length_conv \<open>Suc n = length xs\<close>)
      have "sorted ys"
        using \<open>sorted xs\<close> \<open>xs = y # ys\<close> sorted.simps(2) by blast
      moreover have "\<forall>k < length ys. ys ! k \<le> z"
        using \<open>\<forall>k<length xs. xs ! k \<le> z\<close> \<open>xs = y # ys\<close> by auto
      ultimately have "sorted (ys @ [z])"
        by (simp add: \<open>\<And>xs. n = length xs \<and> sorted xs \<and> (\<forall>k<length xs. xs ! k \<le> z) \<Longrightarrow> sorted (xs @ [z])\<close> \<open>length ys = n\<close>)

      show "sorted (xs @ [z])"
        using \<open>\<forall>k<length xs. xs ! k \<le> z\<close> \<open>sorted (ys @ [z])\<close> \<open>sorted xs\<close> \<open>xs = y # ys\<close> list.discI by auto
    qed
  }
  hence "\<And>n. n = length xs \<and> sorted xs \<and> (\<forall>k. k < length xs \<longrightarrow> xs ! k \<le> z) \<Longrightarrow> sorted (xs @ [z])"
    by simp

  show ?thesis
    by (simp add: \<open>\<And>n. n = length xs \<and> sorted xs \<and> (\<forall>k<length xs. xs ! k \<le> z) \<Longrightarrow> sorted (xs @ [z])\<close> assms(1) assms(2))
qed

lemma sorted_concat:
  fixes xs :: "('a::linorder) list"
  assumes "sorted xs" "sorted ys" "\<And>k. k < length xs \<Longrightarrow> xs ! k \<le> z" "\<And>k. k < length ys \<Longrightarrow> z \<le> ys ! k"
  shows "sorted (xs @ [z] @ ys)"
proof-
  have "sorted (xs @ [z])"
    by (simp add: assms(1) assms(3) sorted_snoc)
  { fix n and xs :: "'a::linorder list" and ys :: "'a::linorder list"
    have "length ys = n \<Longrightarrow> sorted xs \<Longrightarrow> sorted ys \<Longrightarrow> (\<And>k. ys \<noteq> [] \<Longrightarrow> k < length xs \<Longrightarrow> xs ! k \<le> ys ! 0) \<Longrightarrow> sorted (xs @ ys)"
      apply (induct n arbitrary: xs ys)
      apply simp
    proof-
      fix n and xs :: "'a::linorder list" and ys :: "'a::linorder list"
      assume hyp: "(\<And>(xs :: 'a::linorder list) ys. length ys = n \<Longrightarrow> sorted xs \<Longrightarrow> sorted ys \<Longrightarrow> (\<And>k. ys \<noteq> [] \<Longrightarrow> k < length xs \<Longrightarrow> xs ! k \<le> ys ! 0) \<Longrightarrow> sorted (xs @ ys))"
        and "length ys = Suc n" "sorted xs" "sorted ys" "(\<And>k. ys \<noteq> [] \<Longrightarrow> k < length xs \<Longrightarrow> xs ! k \<le> ys ! 0)"
      obtain w and ws :: "'a::linorder list" where "ys = w # ws" "length ws = n"
        by (metis Suc_length_conv \<open>length ys = Suc n\<close>)
      have "sorted ws"
        using \<open>sorted ys\<close> \<open>ys = w # ws\<close> sorted.simps(2) by blast
      moreover have "sorted (xs @ [w])"
        using \<open>\<And>k. \<lbrakk>ys \<noteq> []; k < length xs\<rbrakk> \<Longrightarrow> xs ! k \<le> ys ! 0\<close> \<open>sorted xs\<close> \<open>ys = w # ws\<close> sorted_snoc by auto
      moreover have "\<And>k. ws \<noteq> [] \<Longrightarrow> k < length (xs @ [w]) \<Longrightarrow> (xs @ [w]) ! k \<le> ws ! 0"
        by (metis (no_types, hide_lams) \<open>\<And>k. \<lbrakk>ys \<noteq> []; k < length xs\<rbrakk> \<Longrightarrow> xs ! k \<le> ys ! 0\<close> \<open>sorted ys\<close> \<open>ys = w # ws\<close> dual_order.trans length_append_singleton less_Suc_eq list.distinct(1) list.exhaust nth_Cons_0 nth_append nth_append_length sorted2)
      ultimately show "sorted (xs @ ys)"
        using \<open>length ws = n\<close> \<open>ys = w # ws\<close> hyp by fastforce
    qed
  }
  thus ?thesis
    by (metis append_Cons append_Nil assms(1) assms(2) assms(3) assms(4) length_greater_0_conv nth_Cons_0 sorted.elims(2) sorted1 sorted2)
qed

lemma "
  VARS H i j tmp
  {array H arr N xs}
  i := 1;
  WHILE i < N
  INV {\<exists>zs. array H arr (i - 1) zs \<and> sorted zs} DO
    j := i;
    WHILE j > 0 & the (H (arr + j - 1)) > the (H (arr + j))
    INV {\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs')} DO
      tmp := the (H (arr + j));
      H := H (arr + j \<mapsto> the (H (arr + j - 1)));
      H := H (arr + j - 1 \<mapsto> tmp);
      j := j - 1
    OD;
    i := i + 1
  OD
  {array H arr N ys \<and> sorted ys \<and> permute xs ys}
"
  apply vcg
proof-
  show "\<And>H i j tmp. array H arr N xs \<Longrightarrow> \<exists>zs. array H arr (1 - 1) zs \<and> sorted zs"
    apply simp
    using array.intros(1) sorted.simps(1) by blast
  show "\<And>H i j tmp. (\<exists>zs. array H arr (i - 1) zs \<and> sorted zs) \<and> i < N \<Longrightarrow> (\<exists>zs'. i \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt i zs'))"
    sorry

  show "\<And>H i j tmp.
       ((\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs'))) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1)) \<Longrightarrow>
       (\<exists>zs'. j - 1 \<le> i \<and> array (H(arr + j \<mapsto> the (H (arr + j - 1)), arr + j - 1 \<mapsto> the (H (arr + j)))) arr (i - 1) zs' \<and> sorted (removeAt (j - 1) zs'))"
  proof-
    fix H i j tmp
    assume "((\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs'))) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))"
    obtain xs where "j \<le> i \<and> array H arr (i - 1) xs \<and> sorted (removeAt j xs)"
      using \<open>((\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs'))) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> by blast

    obtain ys where "array (H(arr + j \<mapsto> the (H (arr + j - 1)))) arr (i - 1) ys" "\<And>k. k < length ys \<Longrightarrow> ys ! k = (if arr + k = arr + j then the (H (arr + j - 1)) else xs ! k)"
      apply (rule array_exists_under_heap_modification [of "H" arr "i - 1" xs "arr + j" "the (H (arr + j - 1))"])
      using \<open>j \<le> i \<and> array H arr (i - 1) xs \<and> sorted (removeAt j xs)\<close> apply blast
      by (simp add: array_length)
    obtain zs where "array (H(arr + j \<mapsto> the (H (arr + j - 1)), arr + j - 1 \<mapsto> the (H (arr + j)))) arr (i - 1) zs" "\<And>k. k < length zs \<Longrightarrow> zs ! k = (if arr + k = arr + j - 1 then the (H (arr + j)) else ys ! k)"
      apply (rule array_exists_under_heap_modification [of "H(arr + j \<mapsto> the (H (arr + j - 1)))" arr "i - 1" ys "arr + j - 1" "the (H (arr + j))"])
      using \<open>array (H(arr + j \<mapsto> the (H (arr + j - 1)))) arr (i - 1) ys\<close> apply blast
      by (simp add: array_length)

    have "length zs = i - 1"
      using \<open>array (H(arr + j \<mapsto> the (H (arr + j - 1)), arr + j - 1 \<mapsto> the (H (arr + j)))) arr (i - 1) zs\<close> array_length by blast
    have "length ys = i - 1"
      using \<open>array (H(arr + j \<mapsto> the (H (arr + j - 1)))) arr (i - 1) ys\<close> array_length by blast

    have "\<And>k. k < length zs \<Longrightarrow> zs ! k = (if k = j - 1 then the (H (arr + j)) else if k = j then the (H (arr + j - 1)) else xs ! k)"
      by (metis (no_types, lifting) Nat.add_diff_assoc One_nat_def Suc_leI \<open>(\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs')) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> \<open>\<And>k. k < length ys \<Longrightarrow> ys ! k = (if arr + k = arr + j then the (H (arr + j - 1)) else xs ! k)\<close> \<open>\<And>k. k < length zs \<Longrightarrow> zs ! k = (if arr + k = arr + j - 1 then the (H (arr + j)) else ys ! k)\<close> \<open>length ys = i - 1\<close> \<open>length zs = i - 1\<close> add_diff_cancel_left')

    have "sorted (removeAt j xs)"
      using \<open>j \<le> i \<and> array H arr (i - 1) xs \<and> sorted (removeAt j xs)\<close> by blast

    { assume "j = i"
      have "\<And>k. k < i - 1 \<Longrightarrow> zs ! k = xs ! k"
        by (simp add: \<open>\<And>k. k < length zs \<Longrightarrow> zs ! k = (if k = j - 1 then the (H (arr + j)) else if k = j then the (H (arr + j - 1)) else xs ! k)\<close> \<open>j = i\<close> \<open>length zs = i - 1\<close> less_not_refl3)
      have "removeAt (i - 1) zs = removeAt (i - 1) xs"
        by (metis \<open>\<And>k. k < i - 1 \<Longrightarrow> zs ! k = xs ! k\<close> \<open>j \<le> i \<and> array H arr (i - 1) xs \<and> sorted (removeAt j xs)\<close> \<open>length zs = i - 1\<close> array_length nth_equalityI)
      have "sorted (removeAt (i - 1) zs)"
        by (metis One_nat_def Suc_pred \<open>(\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs')) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> \<open>j = i\<close> \<open>j \<le> i \<and> array H arr (i - 1) xs \<and> sorted (removeAt j xs)\<close> \<open>removeAt (i - 1) zs = removeAt (i - 1) xs\<close> add.commute append_Nil2 array_length diff_le_self drop_all order_refl plus_1_eq_Suc removeAt.simps sorted_append take_all)
      have "sorted (removeAt (j - 1) zs)"
        using \<open>j = i\<close> \<open>sorted (removeAt (i - 1) zs)\<close> by blast
    }
    hence "j = i \<Longrightarrow> sorted (removeAt (j - 1) zs)"
      by blast

    { assume "j = i - 1"
      have "j - 1 < length zs"
        using \<open>(\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs')) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> \<open>j = i - 1\<close> \<open>length zs = i - 1\<close> by linarith
      have "\<And>k. k < j - 1 \<Longrightarrow> zs ! k = xs ! k"
        using \<open>\<And>k. k < length zs \<Longrightarrow> zs ! k = (if k = j - 1 then the (H (arr + j)) else if k = j then the (H (arr + j - 1)) else xs ! k)\<close> \<open>j = i - 1\<close> \<open>length zs = i - 1\<close> by auto
      have "length zs = j"
        by (simp add: \<open>j = i - 1\<close> \<open>length zs = i - 1\<close>)
      have "length (removeAt (j - 1) zs) = j - 1"
        using \<open>j - 1 < length zs\<close> \<open>length zs = j\<close> removeAt_length by blast
      have "\<And>k. k < length (removeAt (j - 1) zs) \<Longrightarrow> removeAt (j - 1) zs ! k = removeAt (j - 1) xs ! k"
        by (metis \<open>\<And>k. k < j - 1 \<Longrightarrow> zs ! k = xs ! k\<close> \<open>j - 1 < length zs\<close> \<open>j = i - 1\<close> \<open>j \<le> i \<and> array H arr (i - 1) xs \<and> sorted (removeAt j xs)\<close> \<open>length (removeAt (j - 1) zs) = j - 1\<close> \<open>length zs = j\<close> array_length removeAt_at)

      have "removeAt (j - 1) zs = removeAt (j - 1) xs"
        by (metis \<open>\<And>k. k < length (removeAt (j - 1) zs) \<Longrightarrow> removeAt (j - 1) zs ! k = removeAt (j - 1) xs ! k\<close> \<open>j - 1 < length zs\<close> \<open>j = i - 1\<close> \<open>j \<le> i \<and> array H arr (i - 1) xs \<and> sorted (removeAt j xs)\<close> \<open>length zs = j\<close> array_length nth_equalityI removeAt_length)
      have "sorted (removeAt (j - 1) zs)"
        by (metis One_nat_def Suc_pred \<open>(\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs')) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> \<open>j = i - 1\<close> \<open>j \<le> i \<and> array H arr (i - 1) xs \<and> sorted (removeAt j xs)\<close> \<open>removeAt (j - 1) zs = removeAt (j - 1) xs\<close> add.commute append_Nil2 array_length drop_all order_refl plus_1_eq_Suc removeAt.simps sorted_append sorted_take take_all)
    }
    hence "j = i - 1 \<Longrightarrow> sorted (removeAt (j - 1) zs)"
      by blast

    { assume "j < i - 1"
      have "j < length zs"
        using \<open>j < i - 1\<close> \<open>length zs = i - 1\<close> by auto
      have "\<And>k. k < j - 1 \<Longrightarrow> zs ! k = xs ! k"
        using \<open>\<And>k. k < length zs \<Longrightarrow> zs ! k = (if k = j - 1 then the (H (arr + j)) else if k = j then the (H (arr + j - 1)) else xs ! k)\<close> \<open>j < i - 1\<close> \<open>length zs = i - 1\<close> by auto
      have "zs ! (j - 1) = the (H (arr + j))"
        by (simp add: \<open>\<And>k. k < length zs \<Longrightarrow> zs ! k = (if k = j - 1 then the (H (arr + j)) else if k = j then the (H (arr + j - 1)) else xs ! k)\<close> \<open>j < length zs\<close> less_imp_diff_less)
      have "zs ! j = the (H (arr + j - 1))"
        using \<open>(\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs')) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> \<open>\<And>k. k < length zs \<Longrightarrow> zs ! k = (if k = j - 1 then the (H (arr + j)) else if k = j then the (H (arr + j - 1)) else xs ! k)\<close> \<open>j < length zs\<close> by auto

      have "xs ! (j - 1) = the (H (arr + j - 1))"
        by (metis (mono_tags, lifting) Nat.add_diff_assoc One_nat_def Suc_leI \<open>(\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs')) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> \<open>j < length zs\<close> \<open>j \<le> i \<and> array H arr (i - 1) xs \<and> sorted (removeAt j xs)\<close> \<open>length zs = i - 1\<close> array_list_at less_imp_diff_less option.sel)
      have "\<And>k. k < j - 1 \<Longrightarrow> (removeAt j xs) ! k \<le> (removeAt j xs) ! (j - 1)"
        by (metis One_nat_def Suc_leI \<open>(\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs')) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> \<open>j < i - 1\<close> \<open>j \<le> i \<and> array H arr (i - 1) xs \<and> sorted (removeAt j xs)\<close> array_length diff_less_mono less_imp_le_nat removeAt_length sorted_nth_mono)
      have "\<And>k. k < j - 1 \<Longrightarrow> (removeAt j xs) ! k = xs ! k \<and> (removeAt j xs) ! (j - 1) = xs ! (j - 1)"
        by (metis One_nat_def Suc_pred \<open>(\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs')) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> \<open>j < i - 1\<close> \<open>j \<le> i \<and> array H arr (i - 1) xs \<and> sorted (removeAt j xs)\<close> array_length less_Suc_eq removeAt_at)
      have "\<And>k. k < j - 1 \<Longrightarrow> xs ! k \<le> xs ! (j - 1)"
        using \<open>\<And>k. k < j - 1 \<Longrightarrow> removeAt j xs ! k = xs ! k \<and> removeAt j xs ! (j - 1) = xs ! (j - 1)\<close> \<open>\<And>k. k < j - 1 \<Longrightarrow> removeAt j xs ! k \<le> removeAt j xs ! (j - 1)\<close> by auto
      have "\<And>k. k < j - 1 \<Longrightarrow> zs ! k \<le> zs ! j"
        using \<open>\<And>k. k < j - 1 \<Longrightarrow> xs ! k \<le> xs ! (j - 1)\<close> \<open>\<And>k. k < j - 1 \<Longrightarrow> zs ! k = xs ! k\<close> \<open>xs ! (j - 1) = the (H (arr + j - 1))\<close> \<open>zs ! j = the (H (arr + j - 1))\<close> by auto

      have "\<And>k. j < k \<and> k < length zs \<Longrightarrow> zs ! k = xs ! k"
        using \<open>\<And>k. k < length zs \<Longrightarrow> zs ! k = (if k = j - 1 then the (H (arr + j)) else if k = j then the (H (arr + j - 1)) else xs ! k)\<close> by auto
      have "\<And>k. j < k \<and> k < length zs \<Longrightarrow> zs ! j \<le> zs ! k"
      proof-
        fix k
        assume "j < k \<and> k < length zs"
        have "zs ! j = the (H (arr + j - 1))"
          using \<open>zs ! j = the (H (arr + j - 1))\<close> by blast
        have "zs ! k = xs ! k"
          using \<open>\<And>k. j < k \<and> k < length zs \<Longrightarrow> zs ! k = xs ! k\<close> \<open>j < k \<and> k < length zs\<close> by blast
        also have "xs ! k = (removeAt j xs) ! (k - 1)"
          by (smt One_nat_def Suc_leI Suc_pred \<open>(\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs')) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> \<open>j < i - 1\<close> \<open>j < k \<and> k < length zs\<close> \<open>j \<le> i \<and> array H arr (i - 1) xs \<and> sorted (removeAt j xs)\<close> array_length leD le_add_diff_inverse2 less_trans removeAt_at)
        finally have "zs ! k = (removeAt j xs) ! (k - 1)"
          by simp

        have "\<And>k. j \<le> k \<and> k < length (removeAt j xs) \<Longrightarrow> (removeAt j xs) ! (j - 1) \<le> (removeAt j xs) ! k"
          by (metis \<open>j \<le> i \<and> array H arr (i - 1) xs \<and> sorted (removeAt j xs)\<close> diff_le_self less_imp_diff_less nat_less_le sorted_nth_mono)
        have "removeAt j xs ! (j - 1) = the (H (arr + j - 1))"
          by (metis One_nat_def \<open>(\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs')) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> \<open>j < i - 1\<close> \<open>j \<le> i \<and> array H arr (i - 1) xs \<and> sorted (removeAt j xs)\<close> \<open>xs ! (j - 1) = the (H (arr + j - 1))\<close> array_length diff_Suc_less removeAt_at)

        show "zs ! j \<le> zs ! k"
          by (metis (no_types, lifting) One_nat_def Suc_leI Suc_pred \<open>(\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs')) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> \<open>\<And>k. j \<le> k \<and> k < length (removeAt j xs) \<Longrightarrow> removeAt j xs ! (j - 1) \<le> removeAt j xs ! k\<close> \<open>j < k \<and> k < length zs\<close> \<open>j \<le> i \<and> array H arr (i - 1) xs \<and> sorted (removeAt j xs)\<close> \<open>length zs = i - 1\<close> \<open>removeAt j xs ! (j - 1) = the (H (arr + j - 1))\<close> \<open>zs ! j = the (H (arr + j - 1))\<close> \<open>zs ! k = removeAt j xs ! (k - 1)\<close> array_length diff_less_mono less_trans removeAt_length)
      qed

      have "sorted (removeAt (j - 1) zs)"
      proof-
        { fix k
          assume "k < length (removeAt (j - 1) zs)"

          have "k < j - 1 \<Longrightarrow> (removeAt (j - 1) zs) ! k \<le> (removeAt (j - 1) zs) ! (j - 1)"
            by (metis One_nat_def Suc_leI \<open>(\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs')) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> \<open>\<And>k. k < j - 1 \<Longrightarrow> zs ! k \<le> zs ! j\<close> \<open>j < i - 1\<close> \<open>length zs = i - 1\<close> le_add_diff_inverse2 less_imp_diff_less neq_iff removeAt_at)
          have "j \<le> k \<Longrightarrow> (removeAt (j - 1) zs) ! (j - 1) \<le> (removeAt (j - 1) zs) ! k"
            by (smt One_nat_def Suc_less_eq \<open>(\<exists>zs'. j \<le> i \<and> array H arr (i - 1) zs' \<and> sorted (removeAt j zs')) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> \<open>\<And>k. j < k \<and> k < length zs \<Longrightarrow> zs ! j \<le> zs ! k\<close> \<open>j < i - 1\<close> \<open>k < length (removeAt (j - 1) zs)\<close> \<open>length zs = i - 1\<close> add.commute leD le_add_diff_inverse2 less_Suc_eq less_Suc_eq_le less_trans plus_1_eq_Suc removeAt_at removeAt_length)

          have "sorted (take (j - 2) (removeAt (j - 1) zs))"
          proof-
            have "take (j - 2) (removeAt (j - 1) zs) = take (j - 2) (removeAt j xs)"

        }
    }

    have "sorted (removeAt (j - 1) zs)"
    proof-
      have "zs ! (j - 1) = xs ! j"

    show "\<exists>zs'. j - 1 \<le> i \<and> array (H(arr + j \<mapsto> the (H (arr + j - 1)), arr + j - 1 \<mapsto> the (H (arr + j)))) arr (i - 1) zs' \<and> sorted (removeAt (j - 1) zs')"

  show "\<And>H i j tmp.
       (\<exists>k zs1 zs2.
           k < j \<and>
           j \<le> i \<and>
           array H arr k zs1 \<and>
           the (H (arr + k)) \<le> Min (set zs1) \<and> array H (arr + k) (i - k) zs2 \<and> Min (set (removeAt (j - k) zs2)) \<le> the (H (arr + k))) \<and>
       0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1)) \<Longrightarrow>
       \<exists>k zs1 zs2.
          k < j - 1 \<and>
          j - 1 \<le> i \<and>
          array (H(arr + j \<mapsto> the (H (arr + j - 1)), arr + j - 1 \<mapsto> the (H (arr + j)))) arr k zs1 \<and>
          the ((H(arr + j \<mapsto> the (H (arr + j - 1)), arr + j - 1 \<mapsto> the (H (arr + j)))) (arr + k)) \<le> Min (set zs1) \<and>
          array (H(arr + j \<mapsto> the (H (arr + j - 1)), arr + j - 1 \<mapsto> the (H (arr + j)))) (arr + k) (i - k) zs2 \<and>
          Min (set (removeAt (j - 1 - k) zs2)) \<le> the ((H(arr + j \<mapsto> the (H (arr + j - 1)), arr + j - 1 \<mapsto> the (H (arr + j)))) (arr + k))"
  proof-
    fix H i j tmp
    assume "(\<exists>k zs1 zs2.
           k < j \<and>
           j \<le> i \<and>
           array H arr k zs1 \<and>
           the (H (arr + k)) \<le> Min (set zs1) \<and> array H (arr + k) (i - k) zs2 \<and> Min (set (removeAt (j - k) zs2)) \<le> the (H (arr + k))) \<and>
       0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))"
    obtain k zs1 zs2 where "k < j \<and>
           j \<le> i \<and>
           array H arr k zs1 \<and>
           the (H (arr + k)) \<le> Min (set zs1) \<and> array H (arr + k) (i - k) zs2 \<and> Min (set (removeAt (j - k) zs2)) \<le> the (H (arr + k))"
      using \<open>(\<exists>k zs1 zs2. k < j \<and> j \<le> i \<and> array H arr k zs1 \<and> the (H (arr + k)) \<le> Min (set zs1) \<and> array H (arr + k) (i - k) zs2 \<and> Min (set (removeAt (j - k) zs2)) \<le> the (H (arr + k))) \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> by blast
    have "k = j - 1 \<Longrightarrow> False"
    proof-
      assume "k = j - 1"
      have ""

    show "\<exists>k zs1 zs2.
          k < j - 1 \<and>
          j - 1 \<le> i \<and>
          array (H(arr + j \<mapsto> the (H (arr + j - 1)), arr + j - 1 \<mapsto> the (H (arr + j)))) arr k zs1 \<and>
          the ((H(arr + j \<mapsto> the (H (arr + j - 1)), arr + j - 1 \<mapsto> the (H (arr + j)))) (arr + k)) \<le> Min (set zs1) \<and>
          array (H(arr + j \<mapsto> the (H (arr + j - 1)), arr + j - 1 \<mapsto> the (H (arr + j)))) (arr + k) (i - k) zs2 \<and>
          Min (set (removeAt (j - 1 - k) zs2)) \<le> the ((H(arr + j \<mapsto> the (H (arr + j - 1)), arr + j - 1 \<mapsto> the (H (arr + j)))) (arr + k))"

  show "\<And>H i j tmp.
       (\<exists>zs'. 0 < j \<and> j \<le> i \<and> array H (arr + j) (i - j) zs' \<and> sorted zs') \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1)) \<Longrightarrow>
       \<exists>zs'. 0 < j - 1 \<and>
             j - 1 \<le> i \<and> array (H(arr + j \<mapsto> the (H (arr + j - 1)), arr + j - 1 \<mapsto> the (H (arr + j)))) (arr + (j - 1)) (i - (j - 1)) zs' \<and> sorted zs'"
  proof-
    fix H and i j tmp
    assume "(\<exists>zs'. 0 < j \<and> j \<le> i \<and> array H (arr + j) (i - j) zs' \<and> sorted zs') \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))"
    obtain zs where "0 < j \<and> j \<le> i \<and> array H (arr + j) (i - j) zs \<and> sorted zs"
      using \<open>(\<exists>zs'. 0 < j \<and> j \<le> i \<and> array H (arr + j) (i - j) zs' \<and> sorted zs') \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> by blast
    define zs' where "zs' \<equiv> head_swap_with zs (the (H (arr + j - 1)))"

    have "array (H(arr + j \<mapsto> the (H (arr + j - 1)), arr + j - 1 \<mapsto> the (H (arr + j)))) (arr + j - 1) (i - (j - 1)) zs'"
      apply (simp add: zs'_def)
      apply (cases zs)
    proof-
      assume "zs = []"
      have "i = j"
        using \<open>0 < j \<and> j \<le> i \<and> array H (arr + j) (i - j) zs \<and> sorted zs\<close> \<open>zs = []\<close> array_empty_from diff_is_0_eq le_antisym by blast
      hence h: "i - (j - Suc 0) = 1"
        by (simp add: Suc_leI \<open>(\<exists>zs'. 0 < j \<and> j \<le> i \<and> array H (arr + j) (i - j) zs' \<and> sorted zs') \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close>)

      have h2: "head_swap_with zs (the (H (arr + j - Suc 0))) = [the (H (arr + j - Suc 0))]"
        by (simp add: \<open>zs = []\<close>)

      show "array (H(arr + j \<mapsto> the (H (arr + j - Suc 0)), arr + j - Suc 0 \<mapsto> the (H (arr + j)))) (arr + j - Suc 0) (i - (j - Suc 0))
        (head_swap_with zs (the (H (arr + j - Suc 0))))"
        apply (simp add: h h2)
        apply rule
        apply (simp add: Suc_leI \<open>(\<exists>zs'. 0 < j \<and> j \<le> i \<and> array H (arr + j) (i - j) zs' \<and> sorted zs') \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close>)
        apply rule
        done
    next
      fix a as
      assume "zs = a # as"
      have h: "head_swap_with zs (the (H (arr + j - Suc 0))) = a # the (H (arr + j - Suc 0)) # as"
        by (simp add: \<open>zs = a # as\<close>)
      have a: "a = the (H (arr + j))"
        by (metis \<open>0 < j \<and> j \<le> i \<and> array H (arr + j) (i - j) zs \<and> sorted zs\<close> \<open>zs = a # as\<close> array.cases list.discI nth_Cons_0 option.sel)

      have "array H (arr + j + 1) (i - j - 1) as"
        by (metis One_nat_def \<open>0 < j \<and> j \<le> i \<and> array H (arr + j) (i - j) zs \<and> sorted zs\<close> \<open>zs = a # as\<close> add_diff_cancel_right' add_is_0 array.cases array_length list.inject list.size(4) nat.simps(3))

      have "i - j \<ge> 1"
        using \<open>0 < j \<and> j \<le> i \<and> array H (arr + j) (i - j) zs \<and> sorted zs\<close> \<open>zs = a # as\<close> array_length by fastforce
      obtain k where k: "i - (j - Suc 0) = Suc (Suc k)"
        using Suc_diff_le \<open>(\<exists>zs'. 0 < j \<and> j \<le> i \<and> array H (arr + j) (i - j) zs' \<and> sorted zs') \<and> 0 < j \<and> the (H (arr + j)) < the (H (arr + j - 1))\<close> \<open>1 \<le> i - j\<close> diff_Suc_1 by fastforce

      show "array (H(arr + j \<mapsto> the (H (arr + j - Suc 0)), arr + j - Suc 0 \<mapsto> the (H (arr + j)))) (arr + j) (i - (j - Suc 0))
        (head_swap_with zs (the (H (arr + j - Suc 0))))"
        apply (simp add: h k)
        apply rule
        apply (simp add: a)

    show "\<exists>zs'. j - 1 \<le> i \<and> array (H(arr + j \<mapsto> the (H (arr + j - 1)), arr + j - 1 \<mapsto> the (H (arr + j)))) (arr + (j - 1)) (i - (j - 1)) zs' \<and> sorted zs'"

end


(*  Title:       Implementing field extensions of the form Q[sqrt(b)]
    Author:      René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  René Thiemann
    License:     LGPL
*)

(*
Copyright 2009-2014 René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)
header {* A unique representation of real numbers via triples *}
theory Real_Unique_Impl
imports
  Prime_Product
  Real_Impl
  "../Show/Show_Instances"
begin

text {* We implement the real numbers again using triples, but now we require an additional
 invariant on the triples, namely that the base has to be a prime product. This has the consequence
 that the mapping of triples into $\reals$ is injective. Hence, equality on reals is now equality
 on triples, which can even be executed in case of different bases. Similarly, we now also allow
 different basis in comparisons. Ultimately, injectivity allows us to define a show-function for
 real numbers, which pretty prints real numbers into strings. *}

typedef mini_alg_unique =
  "{ r :: mini_alg . ma_coeff r = 0 \<and> ma_base r = 0 \<or> ma_coeff r \<noteq> 0 \<and> prime_product (ma_base r)}"
  by (transfer, auto)

setup_lifting type_definition_mini_alg_unique

lift_definition real_of_u :: "mini_alg_unique \<Rightarrow> real" is real_of .
lift_definition mau_floor :: "mini_alg_unique \<Rightarrow> int" is ma_floor .
lift_definition mau_of_rat :: "rat \<Rightarrow> mini_alg_unique" is ma_of_rat by (transfer, auto)
lift_definition mau_rat :: "mini_alg_unique \<Rightarrow> rat" is ma_rat .
lift_definition mau_base :: "mini_alg_unique \<Rightarrow> nat" is ma_base .
lift_definition mau_coeff :: "mini_alg_unique \<Rightarrow> rat" is ma_coeff .
lift_definition mau_uminus :: "mini_alg_unique \<Rightarrow> mini_alg_unique" is ma_uminus by (transfer, auto)
lift_definition mau_compatible :: "mini_alg_unique \<Rightarrow> mini_alg_unique \<Rightarrow> bool" is ma_compatible .
lift_definition mau_ge_0 :: "mini_alg_unique \<Rightarrow> bool" is ma_ge_0 .
lift_definition mau_inverse :: "mini_alg_unique \<Rightarrow> mini_alg_unique" is ma_inverse
  by (transfer, auto simp: ma_normalize_def Let_def split: if_splits)
lift_definition mau_plus :: "mini_alg_unique \<Rightarrow> mini_alg_unique \<Rightarrow> mini_alg_unique" is ma_plus
  by (transfer, auto simp: ma_normalize_def split: if_splits)
lift_definition mau_times :: "mini_alg_unique \<Rightarrow> mini_alg_unique \<Rightarrow> mini_alg_unique" is ma_times
  by (transfer, auto simp: ma_normalize_def split: if_splits)
lift_definition ma_identity :: "mini_alg \<Rightarrow> mini_alg \<Rightarrow> bool" is "op =" .
lift_definition mau_equal :: "mini_alg_unique \<Rightarrow> mini_alg_unique \<Rightarrow> bool" is ma_identity .
lift_definition mau_is_rat :: "mini_alg_unique \<Rightarrow> bool" is ma_is_rat .

lemma mau_floor: "floor (real_of_u r) = mau_floor r"
  using ma_floor by (transfer, auto)
lemma mau_inverse: "inverse (real_of_u r) = real_of_u (mau_inverse r)"
  using ma_inverse by (transfer, auto)
lemma mau_uminus: "- (real_of_u r) = real_of_u (mau_uminus r)"
  using ma_uminus by (transfer, auto)
lemma mau_times:
  "(real_of_u r1 * real_of_u r2) = (if mau_compatible r1 r2
    then real_of_u (mau_times r1 r2) else
    Code.abort (STR ''different base'') (\<lambda> _. real_of_u r1 * real_of_u r2))"
  using ma_times by (transfer, auto)
lemma mau_plus:
  "(real_of_u r1 + real_of_u r2) = (if mau_compatible r1 r2
    then real_of_u (mau_plus r1 r2) else
    Code.abort (STR ''different base'') (\<lambda> _. real_of_u r1 + real_of_u r2))"
  using ma_plus by (transfer, auto)

lemma real_of_u_inj[simp]: "real_of_u x = real_of_u y \<longleftrightarrow> x = y"
proof
  note field_simps[simp] of_rat_diff[simp]
  assume "real_of_u x = real_of_u y"
  thus "x = y"
  proof (transfer)
    fix x y
    assume "ma_coeff x = 0 \<and> ma_base x = 0 \<or> ma_coeff x \<noteq> 0 \<and> prime_product (ma_base x)"
      and  "ma_coeff y = 0 \<and> ma_base y = 0 \<or> ma_coeff y \<noteq> 0 \<and> prime_product (ma_base y)"
      and  "real_of x = real_of y"
    thus "x = y"
    proof (transfer, clarsimp)
      fix p1 q1 p2 q2 :: rat and b1 b2
      let ?p1 = "real_of_rat p1"
      let ?p2 = "real_of_rat p2"
      let ?q1 = "real_of_rat q1"
      let ?q2 = "real_of_rat q2"
      let ?b1 = "real_of_nat b1"
      let ?b2 = "real_of_nat b2"
      assume q1: "q1 = 0 \<and> b1 = 0 \<or> q1 \<noteq> 0 \<and> prime_product b1"
      and q2: "q2 = 0 \<and> b2 = 0 \<or> q2 \<noteq> 0 \<and> prime_product b2"
      and i1: "q1 = 0 \<or> b1 \<in> sqrt_irrat"
      and i2: "q2 = 0 \<or> b2 \<in> sqrt_irrat"
      and eq: "?p1 + ?q1 * sqrt ?b1 = ?p2 + ?q2 * sqrt ?b2"
      show "p1 = p2 \<and> q1 = q2 \<and> b1 = b2"
      proof (cases "q1 = 0")
        case True
        have "q2 = 0"
          by (rule sqrt_irrat[OF i2, of "p2 - p1"], insert eq True q1, auto)
        with True q1 q2 eq show ?thesis by auto
      next
        case False
        hence 1: "q1 \<noteq> 0" "prime_product b1" using q1 by auto
        {
          assume *: "q2 = 0"
          have "q1 = 0"
            by (rule sqrt_irrat[OF i1, of "p1 - p2"], insert eq * q2, auto)
          with False have False by auto
        }
        hence 2: "q2 \<noteq> 0" "prime_product b2" using q2 by auto
        from 1 i1 have b1: "b1 \<noteq> 0" unfolding sqrt_irrat_def by (cases b1, auto)
        from 2 i2 have b2: "b2 \<noteq> 0" unfolding sqrt_irrat_def by (cases b2, auto)
        let ?sq = "\<lambda> x. x * x"
        def q3 \<equiv> "p2 - p1"
        let ?q3 = "real_of_rat q3"
        let ?e = "of_rat (q2 * q2 * of_nat b2 + ?sq q3  - ?sq q1 * of_nat b1) + of_rat (2 * q2 * q3) * sqrt ?b2"
        from eq have *: "?q1 * sqrt ?b1 = ?q2 * sqrt ?b2 + ?q3"
          by (simp add: q3_def)
        from arg_cong[OF this, of ?sq] have "0 = (real_of_rat 2 * ?q2 * ?q3) * sqrt ?b2 +
          (?sq ?q2 * ?b2 +  ?sq ?q3 - ?sq ?q1 * ?b1)"
          by auto
        also have "\<dots> = ?e"
          by (simp add: of_rat_mult of_rat_add of_rat_minus)
        finally have eq: "?e = 0" by simp
        from sqrt_irrat[OF _ this] 2 i2 have q3: "q3 = 0" by auto
        hence p: "p1 = p2" unfolding q3_def by simp
        let ?b1 = "rat_of_nat b1"
        let ?b2 = "rat_of_nat b2"
        from eq[unfolded q3] have eq: "?sq q2 * ?b2 = ?sq q1 * ?b1" by auto
        obtain z1 n1 where d1: "quotient_of q1 = (z1,n1)" by force
        obtain z2 n2 where d2: "quotient_of q2 = (z2,n2)" by force
        note id = quotient_of_div[OF d1] quotient_of_div[OF d2]
        note pos = quotient_of_denom_pos[OF d1] quotient_of_denom_pos[OF d2]
        from id(1) 1(1) pos(1) have z1: "z1 \<noteq> 0" by auto
        from id(2) 2(1) pos(2) have z2: "z2 \<noteq> 0" by auto
        let ?n1 = "rat_of_int n1"
        let ?n2 = "rat_of_int n2"
        let ?z1 = "rat_of_int z1"
        let ?z2 = "rat_of_int z2"
        from arg_cong[OF eq[unfolded id], of "\<lambda> x. x * ?sq ?n1 * ?sq ?n2",
          unfolded field_simps]
        have "?sq (?n1 * ?z2) * ?b2 = ?sq (?n2 * ?z1) * ?b1"
          using pos by auto
        moreover have "?n1 * ?z2 \<noteq> 0" "?n2 * ?z1 \<noteq> 0" using z1 z2 pos by auto
        ultimately obtain i1 i2 where 0: "rat_of_int i1 \<noteq> 0" "rat_of_int i2 \<noteq> 0"
          and eq: "?sq (rat_of_int i2) * ?b2 = ?sq (rat_of_int i1) * ?b1"
          unfolding of_int_mult[symmetric] by blast+
        let ?b1 = "int b1"
        let ?b2 = "int b2"
        from eq have eq: "?sq i1 * ?b1 = ?sq i2 * ?b2"
          by (metis (hide_lams, no_types) of_int_eq_iff of_int_mult of_int_of_nat_eq)
        from 0 have 0: "i1 \<noteq> 0" "i2 \<noteq> 0" by auto
        from arg_cong[OF eq, of nat] have "?sq (nat (abs i1)) * b1 = ?sq (nat (abs i2)) * b2"
          by (metis abs_of_nat eq nat_abs_mult_distrib nat_int)
        moreover have "nat (abs i1) > 0" "nat (abs i2) > 0" using 0 by auto
        ultimately obtain n1 n2 where 0: "n1 > 0" "n2 > 0" and eq: "?sq n1 * b1 = ?sq n2 * b2" by blast
        from b1 0 have b1: "b1 > 0" "n1 > 0" "n1 * n1 > 0" by auto
        from b2 0 have b2: "b2 > 0" "n2 > 0" "n2 * n2 > 0" by auto
        {
          fix p
          have id1: "multiplicity p (?sq n1 * b1) mod 2 = multiplicity p b1 mod 2"
            unfolding multiplicity_product_nat[OF b1(3,1)] multiplicity_product_nat[OF b1(2,2)]
            by presburger
          have id2: "multiplicity p (?sq n2 * b2) mod 2 = multiplicity p b2 mod 2"
            unfolding multiplicity_product_nat[OF b2(3,1)] multiplicity_product_nat[OF b2(2,2)]
            by presburger
          from id1 id2 eq have eq: "multiplicity p b1 mod 2 = multiplicity p b2 mod 2" by simp
          from 1(2) 2(2) have "multiplicity p b1 \<le> 1" "multiplicity p b2 \<le> 1"
            unfolding prime_product_def by auto
          with eq have "multiplicity p b1 = multiplicity p b2" by simp
        }
        with b1(1) b2(1) have b: "b1 = b2" by (rule multiplicity_eq_nat)
        from *[unfolded b q3] b1(1) b2(1) have q: "q1 = q2" by simp
        from p q b show ?thesis by blast
      qed
    qed
  qed
qed simp

lift_definition mau_sqrt :: "mini_alg_unique \<Rightarrow> mini_alg_unique" is
   "\<lambda> ma. let (a,b) = quotient_of (ma_rat ma); (sq,fact) = prime_product_factor (nat (abs a * b));
      ma' = ma_of_rat (of_int (sgn(a)) * of_nat sq / of_int b)
      in ma_times ma' (ma_sqrt (ma_of_rat (of_nat fact)))"
proof -
  fix ma :: mini_alg
  let ?num = "let (a, b) = quotient_of (ma_rat ma); (sq, fact) = prime_product_factor (nat (\<bar>a\<bar> * b));
             ma' = ma_of_rat (rat_of_int (sgn a) * rat_of_nat sq / of_int b)
         in ma_times ma' (ma_sqrt (ma_of_rat (rat_of_nat fact)))"
  obtain a b where q: "quotient_of (ma_rat ma) = (a,b)" by force
  obtain sq fact where ppf: "prime_product_factor (nat (abs a * b)) = (sq,fact)" by force
  def asq \<equiv> "rat_of_int (sgn a) * of_nat sq / of_int b"
  def ma' \<equiv> "ma_of_rat asq"
  def sqrt \<equiv> "ma_sqrt (ma_of_rat (rat_of_nat fact))"
  have num: "?num = ma_times ma' sqrt" unfolding q ppf asq_def Let_def split ma'_def sqrt_def ..
  let ?inv = "\<lambda> ma. ma_coeff ma = 0 \<and> ma_base ma = 0 \<or> ma_coeff ma \<noteq> 0 \<and> prime_product (ma_base ma)"
  have ma': "?inv ma'" unfolding ma'_def
    by (transfer, auto)
  have id: "\<And> i. int i * 1 = i" "\<And> i :: rat. i / 1 = i" "rat_of_int 1 = 1" "inverse (1 :: rat) = 1"
    "\<And> n. nat \<bar>int n\<bar> = n" by auto
  from prime_product_factor[OF ppf] have "prime_product fact" by auto
  hence sqrt: "?inv sqrt" unfolding sqrt_def
    by (transfer, unfold split quotient_of_nat Let_def id, case_tac "sqrt_int \<bar>int facta\<bar>", auto)
  show "?inv ?num" unfolding num using ma' sqrt
    by (transfer, auto simp: ma_normalize_def split: if_splits)
qed

lemma sqrt_sgn[simp]: "sqrt (of_int (sgn a)) = of_int (sgn a)"
  by (cases "a \<ge> 0", cases "a = 0", auto simp: real_sqrt_minus)

lemma mau_sqrt_main: "mau_coeff r = 0 \<Longrightarrow> sqrt (real_of_u r) = real_of_u (mau_sqrt r)"
proof (transfer)
  fix r
  assume "ma_coeff r = 0"
  hence rr: "real_of r = of_rat (ma_rat r)" by (transfer, auto)
  obtain a b where q: "quotient_of (ma_rat r) = (a,b)" by force
  from quotient_of_div[OF q] have r: "ma_rat r = of_int a / of_int b" by auto
  from quotient_of_denom_pos[OF q] have b: "b > 0" by auto
  obtain sq fact where ppf: "prime_product_factor (nat (\<bar>a\<bar> * b)) = (sq, fact)" by force
  from prime_product_factor[OF ppf] have ab: "nat (\<bar>a\<bar> * b) = sq * sq * fact" ..
  have "sqrt (real_of r) = sqrt(of_int a / of_int b)" unfolding rr r
    by (metis of_rat_divide of_rat_of_int_eq)
  also have "real_of_int a / of_int b = of_int a * of_int b / (of_int b * of_int b)" using b by auto
  also have "sqrt (\<dots>) = sqrt (of_int a * of_int b) / of_int b" using sqrt_sqrt[of "real_of_int b"] b
    by (metis less_eq_real_def of_int_0_less_iff real_sqrt_divide real_sqrt_mult_distrib2)
  also have "real_of_int a * of_int b = real_of_int (a * b)" by auto
  also have "a * b = sgn a * (abs a * b)" by (simp, metis mult_sgn_abs)
  also have "real_of_int (\<dots>) = of_int (sgn a) * real_of_int (\<bar>a\<bar> * b)"
    unfolding of_int_mult[of "sgn a"] ..
  also have "real_of_int (\<bar>a\<bar> * b) = of_nat (nat (abs a * b))" using b
    by (metis abs_sgn mult_pos_pos mult_zero_left nat_int of_int_of_nat_eq of_nat_0 zero_less_abs_iff zero_less_imp_eq_int)
  also have "\<dots> = of_nat fact * (of_nat sq * of_nat sq)" unfolding ab of_nat_mult by simp
  also have "sqrt (of_int (sgn a) * (of_nat fact * (of_nat sq * of_nat sq))) =
    of_int (sgn a) * sqrt (of_nat fact) * of_nat sq"
    unfolding real_sqrt_mult_distrib by simp
  finally have r: "sqrt (real_of r) = real_of_int (sgn a) * real_of_nat sq / real_of_int b * sqrt (real_of_nat fact)" by simp
  let ?asqb = "ma_of_rat (rat_of_int (sgn a) * rat_of_nat sq / rat_of_int b)"
  let ?f = "ma_of_rat (rat_of_nat fact)"
  let ?sq = "ma_sqrt ?f"
  have sq: "0 \<le> ma_rat ?f" "ma_coeff ?f = 0" by ((transfer, simp)+)
  have compat: "\<And> m. (ma_compatible ?asqb m) = True"
    by (transfer, auto)
  show "sqrt (real_of r) =
         real_of
          (let (a, b) = quotient_of (ma_rat r); (sq, fact) = prime_product_factor (nat (\<bar>a\<bar> * b));
               ma' = ma_of_rat (rat_of_int (sgn a) * rat_of_nat sq / rat_of_int b)
           in ma_times ma' (ma_sqrt (ma_of_rat (rat_of_nat fact))))"
    unfolding q ppf Let_def split
    unfolding r
    unfolding ma_times[symmetric, of ?asqb, unfolded compat if_True]
    unfolding ma_sqrt_main[OF sq, symmetric]
    unfolding ma_of_rat[symmetric]
    by (simp add: of_rat_divide of_rat_mult)
qed

lemma mau_sqrt: "sqrt (real_of_u r) = (if mau_coeff r = 0 then
  real_of_u (mau_sqrt r)
  else Code.abort (STR ''cannot represent sqrt of irrational number'') (\<lambda> _. sqrt (real_of_u r)))"
  using mau_sqrt_main[of r] by (cases "mau_coeff r = 0", auto)

lemma mau_0: "0 = real_of_u (mau_of_rat 0)" using ma_0 by (transfer, auto)

lemma mau_1: "1 = real_of_u (mau_of_rat 1)" using ma_1 by (transfer, auto)

lemma mau_equal:
  "HOL.equal (real_of_u r1) (real_of_u r2) = mau_equal r1 r2" unfolding equal_real_def
  using real_of_u_inj[of r1 r2]
  by (transfer, transfer, auto)

lemma mau_ge_0: "ge_0 (real_of_u x) = mau_ge_0 x" using ma_ge_0
  by (transfer, auto)

definition real_lt :: "real \<Rightarrow> real \<Rightarrow> bool" where "real_lt = op <"

text{* The following code equation terminates if it is started on two
  different inputs. *}
lemma real_lt[code]: "real_lt x y = (let fx = floor x; fy = floor y in
  (if fx < fy then True else if fx > fy then False else real_lt (x * 1024) (y * 1024)))"
proof (cases "floor x < floor y")
  case True
  thus ?thesis by (auto simp: real_lt_def floor_less_cancel)
next
  case False note nless = this
  show ?thesis
  proof (cases "floor x > floor y")
    case True
    from floor_less_cancel[OF this] True nless show ?thesis
      by (simp add: real_lt_def)
  next
    case False
    with nless show ?thesis unfolding real_lt_def by auto
  qed
qed

text {* For comparisons we first check for equality. Then, if the bases are
  compatible we can just compare the differences with 0. Otherwise, we start
  the recursive algorithm @{const real_lt} which works on arbitrary bases.
  In this way, we have an implementation of comparisons which can compare
  all representable numbers.

  Note that in @{theory Real_Impl} we did not use @{const real_lt} as there
  the code-equations for equality already require identical bases.
 *}
lemma comparison_impl:
  "real_of_u x \<le> real_of_u y \<longleftrightarrow> real_of_u x = real_of_u y \<or>
    (if mau_compatible x y then ge_0 (real_of_u y - real_of_u x) else real_lt (real_of_u x) (real_of_u y))"
  "real_of_u x < real_of_u y \<longleftrightarrow> real_of_u x \<noteq> real_of_u y \<and>
    (if mau_compatible x y then ge_0 (real_of_u y - real_of_u x) else real_lt (real_of_u x) (real_of_u y))"
  unfolding ge_0_def real_lt_def by (auto simp del: real_of_u_inj)

lemma mau_is_rat: "is_rat (real_of_u x) = mau_is_rat x" using ma_is_rat
  by (transfer, auto)

lift_definition ma_show_real :: "mini_alg \<Rightarrow> string" is
  "\<lambda> (p,q,b). let sb = shows ''sqrt('' \<circ> shows b \<circ> shows '')'';
      qb = (if q = 1 then sb else if q = -1 then shows ''-'' \<circ> sb else shows q \<circ> shows ''*'' \<circ> sb) in
      if q = 0 then shows p [] else
      if p = 0 then qb [] else
      if q < 0 then ((shows p \<circ> qb) [])
      else ((shows p \<circ> shows ''+'' \<circ> qb) [])" .

lift_definition mau_show_real :: "mini_alg_unique \<Rightarrow> string" is ma_show_real .

definition show_real :: "real \<Rightarrow> string" where
  "show_real x = (if (\<exists> y. x = real_of_u y) then mau_show_real (THE y. x = real_of_u y) else [])"

lemma mau_show_real: "show_real (real_of_u x) = mau_show_real x"
  unfolding show_real_def by simp

lemmas mau_code_eqns = mau_floor mau_0 mau_1 mau_uminus mau_inverse mau_sqrt mau_plus mau_times mau_equal mau_ge_0 mau_is_rat
  mau_show_real comparison_impl

code_datatype real_of_u
declare real_code_dels[code, code del]
declare ma_code_eqns[code del]
declare real_code_unfold_dels[code_unfold del]
declare real_standard_impls[code]
declare mau_code_eqns[code]

text {* Some tests with small numbers. To work on larger number, one should
  additionally import the theories for efficient calculation on numbers *}

value "\<lfloor>101.1 * (sqrt 18 + 6 * sqrt 0.5)\<rfloor>"
value "\<lfloor>324 * sqrt 7 + 0.001\<rfloor>"
value "101.1 * (sqrt 18 + 6 * sqrt 0.5) = 324 * sqrt 7 + 0.001"
value "101.1 * (sqrt 18 + 6 * sqrt 0.5) > 324 * sqrt 7 + 0.001"
value "show_real (101.1 * (sqrt 18 + 6 * sqrt 0.5))"
value "(sqrt 0.1 \<in> \<rat>, sqrt (- 0.09) \<in> \<rat>)"

end


(* Theory be Kirstin Peters *)

theory Pi
  imports "../Nominal2"
begin

atom_decl name

subsection {* Capture-Avoiding Substitution of Names *}

definition
  subst_name :: "name \<Rightarrow> name \<Rightarrow> name \<Rightarrow> name" ("_[_:::=_]" [110, 110, 110] 110)
where
  "a[b:::=c] \<equiv> if (a = b) then c else a"

declare subst_name_def[simp]

lemma subst_name_mix_eqvt[eqvt]:
  fixes p :: perm
  and   a :: name
  and   b :: name
  and   c :: name

  shows "p \<bullet> (a[b:::=c]) = (p \<bullet> a)[(p \<bullet> b):::=(p \<bullet> c)]"
proof -
  show ?thesis
    by(auto)
qed

nominal_function
  subst_name_list :: "name \<Rightarrow> (name \<times> name) list \<Rightarrow> name"
where
  "subst_name_list a [] = a"
| "subst_name_list a ((b, c)#xs) = (if (a = b) then c else (subst_name_list a xs))"
  apply(simp add: eqvt_def subst_name_list_graph_aux_def)
  apply(simp)
  apply(auto)
  apply(rule_tac y="b" in list.exhaust)
  by(auto)

nominal_termination (eqvt)
  by (lexicographic_order)

section {* The Synchronous Pi-Calculus *}

subsection {* Syntax: Synchronous, Monadic Pi-Calculus with n-ary, Mixed Choice *}

nominal_datatype
      guardedTerm_mix = Output name name piMix                     ("_!<_>\<onesuperior>._" [120, 120, 110] 110)
                      | Input name b::name P::piMix  binds b in P  ("_?<_>\<onesuperior>._" [120, 120, 110] 110)
                      | Tau piMix                                  ("<\<tau>\<onesuperior>>._" [110] 110)
  and sumList_mix     = SumNil                                     ("\<zero>\<onesuperior>")
                      | AddSummand guardedTerm_mix sumList_mix     (infixr "\<oplus>\<onesuperior>" 65)
  and piMix           = Res a::name P::piMix         binds a in P  ("<\<nu>_>\<onesuperior>_" [100, 100] 100)
                      | Par piMix piMix                            (infixr "\<parallel>\<onesuperior>" 85)
                      | Match name name piMix                      ("[_\<frown>\<onesuperior>_]_" [120, 120, 110] 110)
                      | Sum sumList_mix                            ("\<oplus>\<onesuperior>{_}" 90)
                      | Rep name b::name P::piMix    binds b in P  ("\<infinity>_?<_>\<onesuperior>._" [120, 120, 110] 110)
                      | Succ                                       ("succ\<onesuperior>")

lemmas piMix_strong_induct  = guardedTerm_mix_sumList_mix_piMix.strong_induct
lemmas piMix_fresh          = guardedTerm_mix_sumList_mix_piMix.fresh
lemmas piMix_eq_iff         = guardedTerm_mix_sumList_mix_piMix.eq_iff
lemmas piMix_distinct       = guardedTerm_mix_sumList_mix_piMix.distinct
lemmas piMix_size           = guardedTerm_mix_sumList_mix_piMix.size

subsection {* Alpha-Conversion Lemmata *}

lemma alphaRes_mix:
  fixes a :: name
  and   P :: piMix
  and   z :: name

  assumes "atom z \<sharp> P"

  shows "<\<nu>a>\<onesuperior>P = <\<nu>z>\<onesuperior>((atom a \<rightleftharpoons> atom z) \<bullet> P)"
proof(cases "a = z")
  assume "a = z"
  thus ?thesis
    by(simp)
next
  assume "a \<noteq> z"
  thus ?thesis
    using assms
    by (simp add: flip_def piMix_eq_iff Abs1_eq_iff fresh_permute_left)
qed

lemma alphaInput_mix:
  fixes a :: name
  and   b :: name
  and   P :: piMix
  and   z :: name

  assumes "atom z \<sharp> P"

  shows "a?<b>\<onesuperior>.P = a?<z>\<onesuperior>.((atom b \<rightleftharpoons> atom z) \<bullet> P)"
proof(cases "b = z")
  assume "b = z"
  thus ?thesis
    by(simp)
next
  assume "b \<noteq> z"
  thus ?thesis
    using assms
    by(simp add: flip_def piMix_eq_iff Abs1_eq_iff fresh_permute_left)
qed

lemma alphaRep_mix:
  fixes a :: name
  and   b :: name
  and   P :: piMix
  and   z :: name

  assumes "atom z \<sharp> P"

  shows "\<infinity>a?<b>\<onesuperior>.P = \<infinity>a?<z>\<onesuperior>.((atom b \<rightleftharpoons> atom z) \<bullet> P)"
proof(cases "b = z")
  assume "b = z"
  thus ?thesis
    by(simp)
next
  assume "b \<noteq> z"
  thus ?thesis
    using assms
    by(simp add: flip_def piMix_eq_iff Abs1_eq_iff fresh_permute_left)
qed

subsection {* Capture-Avoiding Substitution of Names *}

lemma testl:
  assumes a: "\<exists>y. f = Inl y"
  shows "(p \<bullet> (Sum_Type.projl f)) = Sum_Type.projl (p \<bullet> f)"
using a by auto

lemma testrr:
  assumes a: "\<exists>y. f = Inr (Inr y)"
  shows "(p \<bullet> (Sum_Type.projr (Sum_Type.projr f))) = Sum_Type.projr (Sum_Type.projr (p \<bullet> f))"
using a by auto

lemma testlr:
  assumes a: "\<exists>y. f = Inr (Inl y)"
  shows "(p \<bullet> (Sum_Type.projl (Sum_Type.projr f))) = Sum_Type.projl (Sum_Type.projr (p \<bullet> f))"
using a by auto

nominal_function (default "case_sum (\<lambda>x. Inl undefined) (case_sum (\<lambda>x. Inr (Inl undefined)) (\<lambda>x. Inr (Inr undefined)))")
  subsGuard_mix :: "guardedTerm_mix \<Rightarrow> name \<Rightarrow> name \<Rightarrow> guardedTerm_mix"  ("_[_::=\<onesuperior>\<onesuperior>_]" [100, 100, 100] 100) and
  subsList_mix  :: "sumList_mix \<Rightarrow> name \<Rightarrow> name \<Rightarrow> sumList_mix"          ("_[_::=\<onesuperior>\<twosuperior>_]" [100, 100, 100] 100) and
  subs_mix      :: "piMix \<Rightarrow> name \<Rightarrow> name \<Rightarrow> piMix"                      ("_[_::=\<onesuperior>_]" [100, 100, 100] 100)
where
  "(a!<b>\<onesuperior>.P)[x::=\<onesuperior>\<onesuperior>y] = (a[x:::=y])!<(b[x:::=y])>\<onesuperior>.(P[x::=\<onesuperior>y])"
| "\<lbrakk>atom b \<sharp> (x, y)\<rbrakk> \<Longrightarrow> (a?<b>\<onesuperior>.P)[x::=\<onesuperior>\<onesuperior>y] = (a[x:::=y])?<b>\<onesuperior>.(P[x::=\<onesuperior>y])"
| "(<\<tau>\<onesuperior>>.P)[x::=\<onesuperior>\<onesuperior>y] = <\<tau>\<onesuperior>>.(P[x::=\<onesuperior>y])"
| "(\<zero>\<onesuperior>)[x::=\<onesuperior>\<twosuperior>y] = \<zero>\<onesuperior>"
| "(g \<oplus>\<onesuperior> xg)[x::=\<onesuperior>\<twosuperior>y] = (g[x::=\<onesuperior>\<onesuperior>y]) \<oplus>\<onesuperior> (xg[x::=\<onesuperior>\<twosuperior>y])"
| "\<lbrakk>atom a \<sharp> (x, y)\<rbrakk> \<Longrightarrow> (<\<nu>a>\<onesuperior>P)[x::=\<onesuperior>y] = <\<nu>a>\<onesuperior>(P[x::=\<onesuperior>y])"
| "(P \<parallel>\<onesuperior> Q)[x::=\<onesuperior>y] = (P[x::=\<onesuperior>y]) \<parallel>\<onesuperior> (Q[x::=\<onesuperior>y])"
| "([a\<frown>\<onesuperior>b]P)[x::=\<onesuperior>y] = ([(a[x:::=y])\<frown>\<onesuperior>(b[x:::=y])](P[x::=\<onesuperior>y]))"
| "(\<oplus>\<onesuperior>{xg})[x::=\<onesuperior>y] = \<oplus>\<onesuperior>{(xg[x::=\<onesuperior>\<twosuperior>y])}"
| "\<lbrakk>atom b \<sharp> (x, y)\<rbrakk> \<Longrightarrow> (\<infinity>a?<b>\<onesuperior>.P)[x::=\<onesuperior>y] = \<infinity>(a[x:::=y])?<b>\<onesuperior>.(P[x::=\<onesuperior>y])"
| "(succ\<onesuperior>)[x::=\<onesuperior>y] = succ\<onesuperior>"
  using [[simproc del: alpha_lst]]
  apply(auto simp add: piMix_distinct piMix_eq_iff)
  apply(simp add: eqvt_def  subsGuard_mix_subsList_mix_subs_mix_graph_aux_def)
  --"Covered all cases"
  apply(case_tac x)
  apply(simp)
  apply(case_tac a)
  apply(simp)
  apply (rule_tac y="aa" and c="(b, c)" in guardedTerm_mix_sumList_mix_piMix.strong_exhaust(1))
  apply(blast)
  apply(auto simp add: fresh_star_def)[1]
  apply(blast)
  apply(simp)
  apply(case_tac b)
  apply(simp)
  apply(case_tac a)
  apply(simp)
  apply (rule_tac ya="aa" in guardedTerm_mix_sumList_mix_piMix.strong_exhaust(2))
  apply(blast)
  apply(blast)
  apply(simp)
  apply(case_tac ba)
  apply(simp)
  apply (rule_tac yb="a" and c="(bb,c)" in guardedTerm_mix_sumList_mix_piMix.strong_exhaust(3))
  using [[simproc del: alpha_lst]]
  apply(auto simp add: fresh_star_def)[1]
  apply(blast)
  apply(blast)
  apply(blast)
  using [[simproc del: alpha_lst]]
  apply(auto simp add: fresh_star_def)[1]
  apply(simp)
  --"compatibility"
  apply (simp only: meta_eq_to_obj_eq[OF subs_mix_def, symmetric, unfolded fun_eq_iff])
  apply (subgoal_tac "eqvt_at (\<lambda>(a, b, c). subs_mix a b c) (P, xa, ya)")
  apply (thin_tac "eqvt_at subsGuard_mix_subsList_mix_subs_mix_sumC (Inr (Inr (P, xa, ya)))")
  apply (thin_tac "eqvt_at subsGuard_mix_subsList_mix_subs_mix_sumC (Inr (Inr (Pa, xa, ya)))")
  prefer 2
  apply (simp only: eqvt_at_def subs_mix_def)
  apply rule
  apply(simp (no_asm))
  apply (subst testrr)
  apply (simp add: subsGuard_mix_subsList_mix_subs_mix_sumC_def)
  apply (simp add: THE_default_def)
apply (case_tac "Ex1 (subsGuard_mix_subsList_mix_subs_mix_graph (Inr (Inr (P, xa, ya))))")
apply simp_all[2]
apply auto[1]
apply (erule_tac x="x" in allE)
apply simp
apply(thin_tac "\<forall>p. p \<bullet> The (subsGuard_mix_subsList_mix_subs_mix_graph (Inr (Inr (P, xa, ya)))) =
            (if \<exists>!x. subsGuard_mix_subsList_mix_subs_mix_graph (Inr (Inr (p \<bullet> P, p \<bullet> xa, p \<bullet> ya))) x
             then THE x. subsGuard_mix_subsList_mix_subs_mix_graph (Inr (Inr (p \<bullet> P, p \<bullet> xa, p \<bullet> ya))) x
             else Inr (Inr undefined))")
apply(thin_tac "\<forall>p. p \<bullet> (if \<exists>!x. subsGuard_mix_subsList_mix_subs_mix_graph (Inr (Inr (Pa, xa, ya))) x
                 then THE x. subsGuard_mix_subsList_mix_subs_mix_graph (Inr (Inr (Pa, xa, ya))) x
                 else Inr (Inr undefined)) =
            (if \<exists>!x. subsGuard_mix_subsList_mix_subs_mix_graph (Inr (Inr (p \<bullet> Pa, p \<bullet> xa, p \<bullet> ya))) x
             then THE x. subsGuard_mix_subsList_mix_subs_mix_graph (Inr (Inr (p \<bullet> Pa, p \<bullet> xa, p \<bullet> ya))) x
             else Inr (Inr undefined))")
apply (thin_tac "atom b \<sharp> (xa, ya)")
apply (thin_tac "atom ba \<sharp> (xa, ya)")
apply (thin_tac "[[atom b]]lst. P = [[atom ba]]lst. Pa")
apply(cases rule: subsGuard_mix_subsList_mix_subs_mix_graph.cases)
apply assumption
apply (metis Inr_not_Inl)
apply (metis Inr_not_Inl)
apply (metis Inr_not_Inl)
apply (metis Inr_inject Inr_not_Inl)
apply (metis Inr_inject Inr_not_Inl)
apply (rule_tac x="<\<nu>a>\<onesuperior>Sum_Type.projr
                            (Sum_Type.projr
                              (subsGuard_mix_subsList_mix_subs_mix_sum (Inr (Inr (Pb, xb, y)))))" in exI)
apply clarify
apply (rule the1_equality)
apply blast apply assumption
apply (rule_tac x="Sum_Type.projr
                       (Sum_Type.projr (subsGuard_mix_subsList_mix_subs_mix_sum (Inr (Inr (Pb, xb, y))))) \<parallel>\<onesuperior>
                      Sum_Type.projr
                       (Sum_Type.projr (subsGuard_mix_subsList_mix_subs_mix_sum (Inr (Inr (Q, xb, y)))))" in exI)
apply clarify
apply (rule the1_equality)
apply blast apply assumption
apply (rule_tac x="[(a[xb:::=y])\<frown>\<onesuperior>(bb[xb:::=y])]Sum_Type.projr
                                                    (Sum_Type.projr
(subsGuard_mix_subsList_mix_subs_mix_sum (Inr (Inr (Pb, xb, y)))))" in exI)
apply clarify
apply (rule the1_equality)
apply blast apply assumption
apply (rule_tac x="\<oplus>\<onesuperior>{Sum_Type.projl
                          (Sum_Type.projr
                            (subsGuard_mix_subsList_mix_subs_mix_sum (Inr (Inl (xg, xb, y)))))}" in exI)
apply clarify
apply (rule the1_equality)
apply blast apply assumption
apply (rule_tac x="\<infinity>(a[xb:::=y])?<bb>\<onesuperior>.Sum_Type.projr
                                           (Sum_Type.projr
                                             (subsGuard_mix_subsList_mix_subs_mix_sum
                                               (Inr (Inr (Pb, xb, y)))))" in exI)
apply clarify
apply (rule the1_equality)
apply blast apply assumption
apply (rule_tac x="succ\<onesuperior>" in exI)
apply clarify
apply (rule the1_equality)
apply blast apply assumption
apply simp
(* Here the only real goal compatibility is left *)
  apply (erule Abs_lst1_fcb)
  apply (simp_all add: Abs_fresh_iff fresh_fun_eqvt_app)
  apply (subgoal_tac "atom ba \<sharp> (\<lambda>(a, x, y). subs_mix a x y) (P, xa, ya)")
  apply simp
  apply (erule fresh_eqvt_at)
  apply(simp add: finite_supp)
  apply(simp)
  apply(simp add: eqvt_at_def)
  apply(drule_tac x="(b \<leftrightarrow> ba)" in spec)
  apply(simp)
  apply (simp only: meta_eq_to_obj_eq[OF subs_mix_def, symmetric, unfolded fun_eq_iff])
  apply(rename_tac b P ba xa ya Pa)
 apply (subgoal_tac "eqvt_at (\<lambda>(a, b, c). subs_mix a b c) (P, xa, ya)")
  apply (thin_tac "eqvt_at subsGuard_mix_subsList_mix_subs_mix_sumC (Inr (Inr (P, xa, ya)))")
  apply (thin_tac "eqvt_at subsGuard_mix_subsList_mix_subs_mix_sumC (Inr (Inr (Pa, xa, ya)))")
  prefer 2
  apply (simp only: eqvt_at_def subs_mix_def)
  apply rule
  apply(simp (no_asm))
  apply (subst testrr)
  apply (simp add: subsGuard_mix_subsList_mix_subs_mix_sumC_def)
  apply (simp add: THE_default_def)
apply (case_tac "Ex1 (subsGuard_mix_subsList_mix_subs_mix_graph (Inr (Inr (P, xa, ya))))")
apply simp_all[2]
apply auto[1]
apply (erule_tac x="x" in allE)
apply simp
apply(thin_tac "\<forall>p. p \<bullet> The (subsGuard_mix_subsList_mix_subs_mix_graph (Inr (Inr (P, xa, ya)))) =
            (if \<exists>!x. subsGuard_mix_subsList_mix_subs_mix_graph (Inr (Inr (p \<bullet> P, p \<bullet> xa, p \<bullet> ya))) x
             then THE x. subsGuard_mix_subsList_mix_subs_mix_graph (Inr (Inr (p \<bullet> P, p \<bullet> xa, p \<bullet> ya))) x
             else Inr (Inr undefined))")
apply(thin_tac "\<forall>p. p \<bullet> (if \<exists>!x. subsGuard_mix_subsList_mix_subs_mix_graph (Inr (Inr (Pa, xa, ya))) x
                 then THE x. subsGuard_mix_subsList_mix_subs_mix_graph (Inr (Inr (Pa, xa, ya))) x
                 else Inr (Inr undefined)) =
            (if \<exists>!x. subsGuard_mix_subsList_mix_subs_mix_graph (Inr (Inr (p \<bullet> Pa, p \<bullet> xa, p \<bullet> ya))) x
             then THE x. subsGuard_mix_subsList_mix_subs_mix_graph (Inr (Inr (p \<bullet> Pa, p \<bullet> xa, p \<bullet> ya))) x
             else Inr (Inr undefined))")
apply (thin_tac "atom b \<sharp> (xa, ya)")
apply (thin_tac "atom ba \<sharp> (xa, ya)")
apply (thin_tac "[[atom b]]lst. P = [[atom ba]]lst. Pa")
apply(cases rule: subsGuard_mix_subsList_mix_subs_mix_graph.cases)
apply assumption
apply (metis Inr_not_Inl)
apply (metis Inr_not_Inl)
apply (metis Inr_not_Inl)
apply (metis Inr_inject Inr_not_Inl)
apply (metis Inr_inject Inr_not_Inl)
apply (rule_tac x="<\<nu>a>\<onesuperior>Sum_Type.projr
                            (Sum_Type.projr
                              (subsGuard_mix_subsList_mix_subs_mix_sum (Inr (Inr (Pb, xb, y)))))" in exI)
apply clarify
apply (rule the1_equality)
apply blast apply assumption
apply (rule_tac x="Sum_Type.projr
                       (Sum_Type.projr (subsGuard_mix_subsList_mix_subs_mix_sum (Inr (Inr (Pb, xb, y))))) \<parallel>\<onesuperior>
                      Sum_Type.projr
                       (Sum_Type.projr (subsGuard_mix_subsList_mix_subs_mix_sum (Inr (Inr (Q, xb, y)))))" in exI)
apply clarify
apply (rule the1_equality)
apply blast apply assumption
apply (rule_tac x="[(a[xb:::=y])\<frown>\<onesuperior>(bb[xb:::=y])]Sum_Type.projr
                                                    (Sum_Type.projr
(subsGuard_mix_subsList_mix_subs_mix_sum (Inr (Inr (Pb, xb, y)))))" in exI)
apply clarify
apply (rule the1_equality)
apply blast apply assumption
apply (rule_tac x="\<oplus>\<onesuperior>{Sum_Type.projl
                          (Sum_Type.projr
                            (subsGuard_mix_subsList_mix_subs_mix_sum (Inr (Inl (xg, xb, y)))))}" in exI)
apply clarify
apply (rule the1_equality)
apply blast apply assumption
apply (rule_tac x="\<infinity>(a[xb:::=y])?<bb>\<onesuperior>.Sum_Type.projr
                                           (Sum_Type.projr
                                             (subsGuard_mix_subsList_mix_subs_mix_sum
                                               (Inr (Inr (Pb, xb, y)))))" in exI)
apply clarify
apply (rule the1_equality)
apply blast apply assumption
apply (rule_tac x="succ\<onesuperior>" in exI)
apply clarify
apply (rule the1_equality)
apply blast apply assumption
apply simp
(* Here the only real goal compatibility is left *)
  apply (erule Abs_lst1_fcb)
  apply (simp_all add: Abs_fresh_iff fresh_fun_eqvt_app)
  apply (subgoal_tac "atom ba \<sharp> (\<lambda>(a, x, y). subs_mix a x y) (P, xa, ya)")
  apply simp
  apply (erule fresh_eqvt_at)
  apply(simp add: finite_supp)
  apply(simp)
  apply(simp add: eqvt_at_def)
  apply(drule_tac x="(b \<leftrightarrow> ba)" in spec)
  apply(simp)
  done

nominal_termination (eqvt)
  by (lexicographic_order)

lemma forget_mix:
  fixes g  :: guardedTerm_mix
  and   xg :: sumList_mix
  and   P  :: piMix
  and   x  :: name
  and   y  :: name

  shows "atom x \<sharp> g \<longrightarrow> g[x::=\<onesuperior>\<onesuperior>y] = g"
  and   "atom x \<sharp> xg \<longrightarrow> xg[x::=\<onesuperior>\<twosuperior>y] = xg"
  and   "atom x \<sharp> P \<longrightarrow> P[x::=\<onesuperior>y] = P"
proof -
  show  "atom x \<sharp> g \<longrightarrow> g[x::=\<onesuperior>\<onesuperior>y] = g"
  and   "atom x \<sharp> xg \<longrightarrow> xg[x::=\<onesuperior>\<twosuperior>y] = xg"
  and   "atom x \<sharp> P \<longrightarrow> P[x::=\<onesuperior>y] = P"
    apply(nominal_induct g and xg and P avoiding: x y rule: piMix_strong_induct)
    by(auto simp add: piMix_eq_iff piMix_fresh fresh_at_base)
qed

lemma fresh_fact_mix:
  fixes g  :: guardedTerm_mix
  and   xg :: sumList_mix
  and   P  :: piMix
  and   x  :: name
  and   y  :: name
  and   z  :: name

  assumes "atom z \<sharp> y"

  shows "(z = x \<or> atom z \<sharp> g) \<longrightarrow> atom z \<sharp> g[x::=\<onesuperior>\<onesuperior>y]"
  and   "(z = x \<or> atom z \<sharp> xg) \<longrightarrow> atom z \<sharp> xg[x::=\<onesuperior>\<twosuperior>y]"
  and   "(z = x \<or> atom z \<sharp> P) \<longrightarrow> atom z \<sharp> P[x::=\<onesuperior>y]"
proof -
  show  "(z = x \<or> atom z \<sharp> g) \<longrightarrow> atom z \<sharp> g[x::=\<onesuperior>\<onesuperior>y]"
  and   "(z = x \<or> atom z \<sharp> xg) \<longrightarrow> atom z \<sharp> xg[x::=\<onesuperior>\<twosuperior>y]"
  and   "(z = x \<or> atom z \<sharp> P) \<longrightarrow> atom z \<sharp> P[x::=\<onesuperior>y]"
    using assms
    apply(nominal_induct g and xg and P avoiding: x y z rule: piMix_strong_induct)
    by(auto simp add: piMix_fresh fresh_at_base)
qed

lemma substitution_lemma_mix:
  fixes g  :: guardedTerm_mix
  and   xg :: sumList_mix
  and   P  :: piMix
  and   s  :: name
  and   u  :: name
  and   x  :: name
  and   y  :: name

  assumes "x \<noteq> y"
  and     "atom x \<sharp> u"

  shows "g[x::=\<onesuperior>\<onesuperior>s][y::=\<onesuperior>\<onesuperior>u] = g[y::=\<onesuperior>\<onesuperior>u][x::=\<onesuperior>\<onesuperior>s[y:::=u]]"
  and   "xg[x::=\<onesuperior>\<twosuperior>s][y::=\<onesuperior>\<twosuperior>u] = xg[y::=\<onesuperior>\<twosuperior>u][x::=\<onesuperior>\<twosuperior>s[y:::=u]]"
  and   "P[x::=\<onesuperior>s][y::=\<onesuperior>u] = P[y::=\<onesuperior>u][x::=\<onesuperior>s[y:::=u]]"
proof -
  show  "g[x::=\<onesuperior>\<onesuperior>s][y::=\<onesuperior>\<onesuperior>u] = g[y::=\<onesuperior>\<onesuperior>u][x::=\<onesuperior>\<onesuperior>s[y:::=u]]"
  and   "xg[x::=\<onesuperior>\<twosuperior>s][y::=\<onesuperior>\<twosuperior>u] = xg[y::=\<onesuperior>\<twosuperior>u][x::=\<onesuperior>\<twosuperior>s[y:::=u]]"
  and   "P[x::=\<onesuperior>s][y::=\<onesuperior>u] = P[y::=\<onesuperior>u][x::=\<onesuperior>s[y:::=u]]"
    using assms
    apply(nominal_induct g and xg and P avoiding: x y s u rule: piMix_strong_induct)
    apply(simp_all add: fresh_fact_mix forget_mix)
    by(auto simp add: fresh_at_base)
qed

lemma perm_eq_subst_mix:
  fixes g  :: guardedTerm_mix
  and   xg :: sumList_mix
  and   P  :: piMix
  and   x  :: name
  and   y  :: name

  shows "atom y \<sharp> g \<longrightarrow> (atom x \<rightleftharpoons> atom y) \<bullet> g = g[x::=\<onesuperior>\<onesuperior>y]"
  and   "atom y \<sharp> xg \<longrightarrow> (atom x \<rightleftharpoons> atom y) \<bullet> xg = xg[x::=\<onesuperior>\<twosuperior>y]"
  and   "atom y \<sharp> P \<longrightarrow> (atom x \<rightleftharpoons> atom y) \<bullet> P = P[x::=\<onesuperior>y]"
proof -
  show  "atom y \<sharp> g \<longrightarrow> (atom x \<rightleftharpoons> atom y) \<bullet> g = g[x::=\<onesuperior>\<onesuperior>y]"
  and   "atom y \<sharp> xg \<longrightarrow> (atom x \<rightleftharpoons> atom y) \<bullet> xg = xg[x::=\<onesuperior>\<twosuperior>y]"
  and   "atom y \<sharp> P \<longrightarrow> (atom x \<rightleftharpoons> atom y) \<bullet> P = P[x::=\<onesuperior>y]"
    apply(nominal_induct g and xg and P avoiding: x y rule: piMix_strong_induct)
    by(auto simp add: piMix_fresh fresh_at_base)
qed

lemma subst_id_mix:
  fixes g  :: guardedTerm_mix
  and   xg :: sumList_mix
  and   P  :: piMix
  and   x  :: name

  shows "g[x::=\<onesuperior>\<onesuperior>x] = g" and "xg[x::=\<onesuperior>\<twosuperior>x] = xg" and "P[x::=\<onesuperior>x] = P"
proof -
  show  "g[x::=\<onesuperior>\<onesuperior>x] = g" and "xg[x::=\<onesuperior>\<twosuperior>x] = xg" and "P[x::=\<onesuperior>x] = P"
    apply(nominal_induct g and xg and P avoiding: x rule: piMix_strong_induct)
    by(auto)
qed

lemma alphaRes_subst_mix:
  fixes a :: name
  and   P :: piMix
  and   z :: name

  assumes "atom z \<sharp> P"

  shows "<\<nu>a>\<onesuperior>P = <\<nu>z>\<onesuperior>(P[a::=\<onesuperior>z])"
proof(cases "a = z")
  assume "a = z"
  thus ?thesis
    by(simp add: subst_id_mix)
next
  assume "a \<noteq> z"
  thus ?thesis
    using assms
    by(simp add: alphaRes_mix perm_eq_subst_mix)
qed

lemma alphaInput_subst_mix:
  fixes a :: name
  and   b :: name
  and   P :: piMix
  and   z :: name

  assumes "atom z \<sharp> P"

  shows "a?<b>\<onesuperior>.P = a?<z>\<onesuperior>.(P[b::=\<onesuperior>z])"
proof(cases "b = z")
  assume "b = z"
  thus ?thesis
    by(simp add: subst_id_mix)
next
  assume "b \<noteq> z"
  thus ?thesis
    using assms
    by(simp add: alphaInput_mix perm_eq_subst_mix)
qed

lemma alphaRep_subst_mix:
  fixes a :: name
  and   b :: name
  and   P :: piMix
  and   z :: name

  assumes "atom z \<sharp> P"

  shows "\<infinity>a?<b>\<onesuperior>.P = \<infinity>a?<z>\<onesuperior>.(P[b::=\<onesuperior>z])"
proof(cases "b = z")
  assume "b = z"
  thus ?thesis
    by(simp add: subst_id_mix)
next
  assume "b \<noteq> z"
  thus ?thesis
    using assms
    by(simp add: alphaRep_mix perm_eq_subst_mix)
qed

inductive
  fresh_list_guard_mix :: "name list \<Rightarrow> guardedTerm_mix \<Rightarrow> bool"
where
  "fresh_list_guard_mix [] g"
| "\<lbrakk>atom n \<sharp> g; fresh_list_guard_mix xn g\<rbrakk> \<Longrightarrow> fresh_list_guard_mix (n#xn) g"

equivariance fresh_list_guard_mix
nominal_inductive fresh_list_guard_mix
  done

inductive
  fresh_list_sumList_mix :: "name list \<Rightarrow> sumList_mix \<Rightarrow> bool"
where
  "fresh_list_sumList_mix [] xg"
| "\<lbrakk>atom n \<sharp> xg; fresh_list_sumList_mix xn xg\<rbrakk> \<Longrightarrow> fresh_list_sumList_mix (n#xn) xg"

equivariance fresh_list_sumList_mix
nominal_inductive fresh_list_sumList_mix
  done

inductive
  fresh_list_mix :: "name list \<Rightarrow> piMix \<Rightarrow> bool"
where
  "fresh_list_mix [] P"
| "\<lbrakk>atom n \<sharp> P; fresh_list_mix xn P\<rbrakk> \<Longrightarrow> fresh_list_mix (n#xn) P"

equivariance fresh_list_mix
nominal_inductive fresh_list_mix
  done

end


(* Title: thys/Turing_aux.thy
   Author:  Franz Regensburger (FABR) 04/2022
 *)

subsection \<open>Auxiliary theorems about Turing Machines\<close>

theory Turing_aux
  imports Turing
begin

(* -------------------------------------------- *)
(* START: enhanced/clarified semantics of fetch *)
(* -------------------------------------------- *)

fun fetch' :: "instr list \<Rightarrow> state \<Rightarrow> cell \<Rightarrow> instr"
  where
    "fetch' []                 s              b = (Nop, 0)"

  | "fetch' [iBk]              0              b  = (Nop, 0)"
  | "fetch' [iBk]              (Suc 0)        Bk = iBk"
  | "fetch' [iBk]              (Suc 0)        Oc = (Nop, 0)"
  | "fetch' [iBk]              (Suc (Suc s')) b  = (Nop, 0)"

  | "fetch' (iBk # iOc # inss) 0              b  = (Nop, 0)"
  | "fetch' (iBk # iOc # inss) (Suc 0)        Bk = iBk"
  | "fetch' (iBk # iOc # inss) (Suc 0)        Oc = iOc"
  | "fetch' (iBk # iOc # inss) (Suc (Suc s')) b  = fetch' inss (Suc s') b"

lemma fetch'_Nil:
  shows "fetch' [] s b = (Nop, 0)"
  by (cases s,force) (cases b;force)

lemma fetch'_eq_fetch_app: "fetch' tm s b = fetch tm s b"
proof (induct rule: fetch'.induct)
  case (1 s b)
  then show ?case by (cases b) (auto simp add: fetch_imp)
next
  case (2 iBk b)
  then show ?case by (cases b) auto
next
  case (3 iBk)
  then show ?case by auto
next
  case (4 iBk)
  then show ?case by auto
next
  case (5 iBk s' b)
  then show ?case by (cases b) auto
next
  case (6 iBk iOc inss b)
  then show ?case by (cases b) auto
next
  case (7 iBk iOc inss)
  then show ?case by  auto
next
  case (8 iBk iOc inss)
  then show ?case by  auto
next
  case (9 iBk iOc inss s' b)
  then show ?case by (cases b) auto
qed

corollary fetch'_eq_fetch: "fetch' = fetch"
  by (blast intro: fetch'_eq_fetch_app)

(* ------------------------------------------- *)
(* END: enhanced/clarified semantics of fetch  *)
(* ------------------------------------------- *)

(* ------------------------------------------- *)
(* step function versus step relation          *)
(* ------------------------------------------- *)

(* Definition for a step relation instead of a step function *)

definition
  tm_step0_rel :: "tprog0 \<Rightarrow> ((config \<times> config) set)"
  where
   "tm_step0_rel tp = {(c1, c2) . step0 c1 tp = c2}"

abbreviation tm_step0_rel_aux :: "[config, tprog0, config] \<Rightarrow> bool"   ("((1_)/ \<Turnstile>\<langle>(_)\<rangle>\<Midarrow>/ (1_))" 50)
  where
            "tm_step0_rel_aux c1 tp c2  \<equiv> (c1,c2) \<in> tm_step0_rel tp"

theorem tm_step0_rel_iff_step0: "(c1 \<Turnstile>\<langle>tp\<rangle>\<Midarrow> c2) \<longleftrightarrow> step0 c1 tp = c2"
  unfolding tm_step0_rel_def by auto

(* The steps relation is the reflexive and transitive closure of the step relation  *)

definition tm_steps0_rel :: "tprog0 \<Rightarrow> ((config \<times> config) set)"
  where
   "tm_steps0_rel tp = rtrancl (tm_step0_rel tp)"

abbreviation tm_steps0_rel_aux :: "[config, tprog0, config] \<Rightarrow> bool"   ("((1_)/ \<Turnstile>\<langle>(_)\<rangle>\<Midarrow>\<^sup>*/ (1_))" 50)
  where
            "tm_steps0_rel_aux c1 tp c2  \<equiv> (c1,c2) \<in> tm_steps0_rel tp"

lemma tm_step0_rel_power: "(tm_step0_rel tp ^^ n) = {(c1,c2) . steps0 c1 tp n = c2}"
proof (induct n)
  case 0
  then show ?case
    using prod.exhaust relpowp_0_I split_conv
       by auto
next
  case (Suc n)
  then have IV: "tm_step0_rel tp ^^ n = {a. case a of (c1, c2) \<Rightarrow> steps0 c1 tp n = c2}"
    by auto
  show "tm_step0_rel tp ^^ Suc n = {a. case a of (c1, c2) \<Rightarrow> steps0 c1 tp (Suc n) = c2}"
  proof
    show "tm_step0_rel tp ^^ Suc n \<subseteq> {a. case a of (c1, c2) \<Rightarrow> steps0 c1 tp (Suc n) = c2}"
      using IV step_red tm_step0_rel_def by auto
  next
    show "{a. case a of (c1, c2) \<Rightarrow> steps0 c1 tp (Suc n) = c2} \<subseteq> tm_step0_rel tp ^^ Suc n"
    proof
      fix cp
      assume "cp \<in> {a. case a of (c1, c2) \<Rightarrow> steps0 c1 tp (Suc n) = c2}"
      then have "\<exists>c1 c2. cp = (c1,c2) \<and> steps0 c1 tp (Suc n) = c2"
        using prod.exhaust_sel by blast
      then obtain c1 c2 where "cp = (c1,c2) \<and> steps0 c1 tp (Suc n) = c2" by blast
      then show "cp \<in> tm_step0_rel tp ^^ Suc n"
        using IV step_red  tm_step0_rel_def by auto
    qed
  qed
qed

theorem tm_steps0_rel_iff_steps0: "(c1 \<Turnstile>\<langle>tp\<rangle>\<Midarrow>\<^sup>* c2) \<longleftrightarrow> (\<exists>stp. steps0 c1 tp stp = c2)"
proof -
  have major: "((c1 \<Turnstile>\<langle>tp\<rangle>\<Midarrow>\<^sup>* c2)) \<longleftrightarrow> (\<exists>n. (c1,c2) \<in> (tm_step0_rel tp ^^ n))"
    by (simp add: relpow_code_def rtrancl_power tm_step0_rel_def tm_steps0_rel_def)
  show ?thesis
  proof
    assume "(c1 \<Turnstile>\<langle>tp\<rangle>\<Midarrow>\<^sup>* c2)"
    with major have "(\<exists>n. (c1,c2) \<in> (tm_step0_rel tp ^^ n))" by auto
    then obtain n where w_n: "(c1,c2) \<in> (tm_step0_rel tp ^^ n)" by blast
    then show "\<exists>stp. steps0 c1 tp stp = c2" using tm_step0_rel_power
      by auto
  next
    assume "\<exists>stp. steps0 c1 tp stp = c2"
    then obtain stp where "steps0 c1 tp stp = c2" by blast
    then show "(c1 \<Turnstile>\<langle>tp\<rangle>\<Midarrow>\<^sup>* c2)"
      using tm_step0_rel_power major
      by auto
  qed
qed

end


theory DP_CRelVS
  imports "./Monad" "./DP_Lifting"
begin

definition rel_imp :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool" where
  "rel_imp R R' \<equiv> \<forall>x y. R x y \<longrightarrow> R' x y"
term 0 (**)

locale dp_consistency =
  fixes dp :: "'param \<Rightarrow> 'result"
begin

context
  includes lifting_syntax
begin

  (* Predicates *)
definition cmem :: "('param \<rightharpoonup> 'result) \<Rightarrow> bool" where
  "cmem M \<equiv> \<forall>param\<in>dom M. M param = Some (dp param)"
term 0 (**)

definition crel_vs :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> ('param \<rightharpoonup> 'result, 'b) state \<Rightarrow> bool" where
  "crel_vs R v s \<equiv> \<forall>M. cmem M \<longrightarrow> (case runState s M of (v', M') \<Rightarrow> R v v' \<and> cmem M')"

definition crel_vs_alt :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> ('param \<rightharpoonup> 'result, 'b) state \<Rightarrow> bool" where
  "crel_vs_alt R v s \<equiv> pred_fun cmem (pred_prod (R v) cmem) (runState s)"

abbreviation rel_fun_lifted :: "('a \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('c ==_\<Longrightarrow> 'd) \<Rightarrow> bool" (infixr "===>\<^sub>T" 55) where
  "rel_fun_lifted R R' \<equiv> R ===> crel_vs R'"
term 0 (**)

lemma "crel_vs = crel_vs_alt"
  unfolding crel_vs_def crel_vs_alt_def
  by (fastforce split: pred_prod_split)

definition consistentDP :: "('param \<Rightarrow>\<^sub>T 'result) \<Rightarrow> bool" where
  "consistentDP \<equiv> (op = ===> crel_vs op =) dp"
term 0 (**)

  (* cmem *)
lemma cmem_intro:
  assumes "\<And>param v. M param = Some v \<Longrightarrow> v = dp param"
  shows "cmem M"
  using assms unfolding cmem_def by blast
term 0 (**)

lemma cmem_elim:
  assumes "cmem M" "M param = Some v"
  obtains "dp param = v"
  using assms unfolding cmem_def dom_def by auto
term 0 (**)

  (* crel_vs *)
lemma crel_vs_intro:
  assumes "\<And>M v' M'. \<lbrakk>cmem M; runState v\<^sub>T M = (v', M')\<rbrakk> \<Longrightarrow> R v v' \<and> cmem M'"
  shows "crel_vs R v v\<^sub>T"
  using assms unfolding crel_vs_def by blast
term 0 (**)

lemma crel_vs_elim:
  assumes "crel_vs R v v\<^sub>T" "cmem M"
  obtains v' M' where "runState v\<^sub>T M = (v', M')" "R v v'" "cmem M'"
  using assms unfolding crel_vs_def by blast
term 0 (**)

lemma crel_vs_mono:
  assumes "crel_vs R v s" "rel_imp R R'"
  shows "crel_vs R' v s"
  using assms unfolding rel_imp_def by (fastforce intro: crel_vs_intro elim: crel_vs_elim)

  (* consistentDP *)
lemma consistentDP_intro:
  assumes "\<And>param. crel_vs (op =) (dp param) (dp\<^sub>T param)"
  shows "consistentDP dp\<^sub>T"
  using assms unfolding consistentDP_def by blast
term 0 (**)

lemma crel_vs_return:
  "\<lbrakk>R x y\<rbrakk> \<Longrightarrow> crel_vs R x (return y)"
  unfolding return_def by (fastforce intro: crel_vs_intro)
term 0 (**)

  (* Low level operators *)
lemma cmem_upd:
  "\<lbrakk>cmem M; v = dp param\<rbrakk> \<Longrightarrow> cmem (M(param\<mapsto>v))"
  unfolding cmem_def by auto
term 0 (**)

lemma crel_vs_get:
  "\<lbrakk>\<And>M. cmem M \<Longrightarrow> crel_vs R v (sf M)\<rbrakk> \<Longrightarrow> crel_vs R v (get \<bind> sf)"
  unfolding get_def bind_def by (fastforce intro: crel_vs_intro elim: crel_vs_elim split: prod.split)
term 0 (**)

lemma crel_vs_put:
  "\<lbrakk>crel_vs R v sf; cmem M\<rbrakk> \<Longrightarrow> crel_vs R v (put M \<then> sf)"
  unfolding put_def bind_def by (fastforce intro: crel_vs_intro elim: crel_vs_elim split: prod.split)
term 0 (**)

lemma unlift_'_transfer[transfer_rule]:
  "(R ===> crel_vs R) (\<lambda> x. x) unlift_'"
  unfolding unlift_'_def by transfer_prover
term 0 (**)

lemma unlift_3_transfer[transfer_rule]:
  "((R0 ===>\<^sub>T R1) ===> (R0 ===> crel_vs R1)) (\<lambda> f x. f x) unlift_3"
  unfolding unlift_3_def by transfer_prover
term 0 (**)

lemma unlift_33_transfer[transfer_rule]:
  "((R0 ===>\<^sub>T R1 ===>\<^sub>T R2) ===> (R0 ===> R1 ===> crel_vs R2)) (\<lambda> f x0 x1. f x0 x1) unlift_33"
  unfolding unlift_33_def by transfer_prover

lemma lift_'_transfer[transfer_rule]:
  "(R ===> crel_vs R) (\<lambda> x. x) lift_'"
  unfolding lift_'_def by transfer_prover

lemma lift_3_transfer[transfer_rule]:
  "((R0 ===> R1) ===> crel_vs (R0 ===>\<^sub>T R1)) (\<lambda> f x. f x) lift_3"
  unfolding lift_3_def by transfer_prover

lemma lift_33_transfer[transfer_rule]:
  "((R0 ===> R1 ===> R2) ===> crel_vs (R0 ===>\<^sub>T R1 ===>\<^sub>T R2)) (\<lambda> f x0 x1. f x0 x1) lift_33"
  unfolding lift_33_def by transfer_prover

lemma lift_333_transfer[transfer_rule]:
  "((R0 ===> R1 ===> R2 ===> R3) ===> crel_vs (R0 ===>\<^sub>T R1 ===>\<^sub>T R2 ===>\<^sub>T R3)) (\<lambda> f x0 x1 x2. f x0 x1 x2) lift_333"
  unfolding lift_333_def by transfer_prover
term 0 (**)

  (* HOL *)
lemma If_transfer[transfer_rule]:
  "crel_vs (op = ===>\<^sub>T R ===>\<^sub>T R ===>\<^sub>T R) If If\<^sub>T"
  unfolding If\<^sub>T_def by transfer_prover

lemma id_transfer[transfer_rule]:
  "crel_vs (R ===>\<^sub>T R) id id\<^sub>T"
  unfolding id_def id\<^sub>T_def by transfer_prover

lemma comp_transfer[transfer_rule]:
  "crel_vs ((R1 ===>\<^sub>T R2) ===>\<^sub>T (R0 ===>\<^sub>T R1) ===>\<^sub>T (R0 ===>\<^sub>T R2)) comp comp\<^sub>T"
  unfolding comp_def comp\<^sub>T_def fun_app_lifted_def by transfer_prover
term 0 (**)

  (* Arithmetic *)

lemma plus_transfer[transfer_rule]:
  "crel_vs (op = ===>\<^sub>T op = ===>\<^sub>T op =) plus plus\<^sub>T"
  unfolding plus\<^sub>T_def by transfer_prover

lemma min_transfer[transfer_rule]:
  "crel_vs (op = ===>\<^sub>T op = ===>\<^sub>T op =) min min\<^sub>T"
  unfolding min\<^sub>T_def by transfer_prover

lemma max_transfer[transfer_rule]:
  "crel_vs (op = ===>\<^sub>T op = ===>\<^sub>T op =) max max\<^sub>T"
  unfolding max\<^sub>T_def by transfer_prover
term 0 (**)

  (* Option *)
lemma case_option_transfer[transfer_rule]:
  "crel_vs (R1 ===>\<^sub>T (R0 ===>\<^sub>T R1) ===>\<^sub>T rel_option R0 ===>\<^sub>T R1) case_option case_option\<^sub>T"
  unfolding case_option\<^sub>T_def by transfer_prover

lemma None_transfer[transfer_rule]:
  "crel_vs (rel_option R) None None\<^sub>T"
  unfolding None\<^sub>T_def by transfer_prover

lemma Some_transfer[transfer_rule]:
  "crel_vs (R ===>\<^sub>T rel_option R) Some Some\<^sub>T"
  unfolding Some\<^sub>T_def by transfer_prover
term 0 (**)

  (* List *)
lemma case_list_transfer[transfer_rule]:
  "crel_vs (R1 ===>\<^sub>T (R0 ===>\<^sub>T list_all2 R0 ===>\<^sub>T R1) ===>\<^sub>T list_all2 R0 ===>\<^sub>T R1) case_list case_list\<^sub>T"
  unfolding case_list\<^sub>T_def by transfer_prover

lemma Nil_transfer[transfer_rule]:
  "crel_vs (list_all2 R) Nil Nil\<^sub>T"
  unfolding Nil\<^sub>T_def by transfer_prover

lemma Cons_transfer[transfer_rule]:
  "crel_vs (R ===>\<^sub>T list_all2 R ===>\<^sub>T list_all2 R) Cons Cons\<^sub>T"
  unfolding Cons\<^sub>T_def by transfer_prover

lemma upt_transfer[transfer_rule]:
  "crel_vs (op = ===>\<^sub>T op = ===>\<^sub>T list_all2 op =) upt upt\<^sub>T"
  unfolding upt\<^sub>T_def by transfer_prover
term 0 (**)

  (* Prod *)
lemma case_prod_transfer[transfer_rule]:
  "crel_vs ((R0 ===>\<^sub>T R1 ===>\<^sub>T R2) ===>\<^sub>T rel_prod R0 R1 ===>\<^sub>T R2) case_prod case_prod\<^sub>T"
  unfolding case_prod\<^sub>T_def by transfer_prover
term 0 (**)

lemma Pair_transfer[transfer_rule]:
  "crel_vs (R0 ===>\<^sub>T R1 ===>\<^sub>T rel_prod R0 R1) Pair Pair\<^sub>T"
  unfolding Pair\<^sub>T_def by transfer_prover
term 0 (**)

  (* Combinator *)
lemma map_transfer[transfer_rule]:
  "crel_vs ((R0 ===>\<^sub>T R1) ===>\<^sub>T list_all2 R0 ===>\<^sub>T list_all2 R1) map map\<^sub>T"
proof -
  have [transfer_rule]: "((R0 ===>\<^sub>T R1) ===> (list_all2 R0 ===>\<^sub>T list_all2 R1)) map map\<^sub>T'"
    apply ((rule rel_funI)+, induct_tac rule: list_all2_induct, assumption; unfold list.map map\<^sub>T'.simps)
    subgoal premises [transfer_rule] by transfer_prover
    subgoal premises [transfer_rule] by transfer_prover
    done
  show ?thesis
    unfolding map\<^sub>T_def by transfer_prover
qed

lemma fold_transfer[transfer_rule]:
  "crel_vs ((R0 ===>\<^sub>T R1 ===>\<^sub>T R1) ===>\<^sub>T list_all2 R0 ===>\<^sub>T R1 ===>\<^sub>T R1) fold fold\<^sub>T"
proof -
  have [transfer_rule]: "((R0 ===>\<^sub>T R1 ===>\<^sub>T R1) ===> list_all2 R0 ===>\<^sub>T R1 ===>\<^sub>T R1) fold fold\<^sub>T'"
    apply ((rule rel_funI)+, induct_tac rule: list_all2_induct, assumption; unfold fold.simps fold\<^sub>T'.simps)
    subgoal premises [transfer_rule] by transfer_prover
    subgoal premises [transfer_rule] by transfer_prover
    done
  show ?thesis
    unfolding fold\<^sub>T_def by transfer_prover
qed

definition "and_leftp R P x y \<equiv> R x y \<and> P x"

lemma eq_onp_and_leftp_eq: "and_leftp (op =) P x y \<longleftrightarrow> eq_onp P x y"
  unfolding and_leftp_def eq_onp_def by auto

lemma and_leftp_elim: "and_leftp R P x y \<Longrightarrow> (R x y \<Longrightarrow> P x \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  unfolding and_leftp_def by auto
term 0 (**)

lemma and_leftp_leftset_intro:
  "list_all2 R xs xs\<^sub>T' \<Longrightarrow> list_all2 (and_leftp R (\<lambda>x. x\<in>set xs)) xs xs\<^sub>T'"
  unfolding list_all2_iff and_leftp_def set_zip by auto
term 0 (**)

lemma and_leftp_lefteq_elim:
  assumes "and_leftp R (op = y) x x\<^sub>T'"
  obtains "x = y" "R y x\<^sub>T'"
  using assms unfolding and_leftp_def by auto

lemma and_leftp_lefteq_same:
  "R x x\<^sub>T' \<Longrightarrow> and_leftp R (op = x) x x\<^sub>T'"
  unfolding and_leftp_def by auto

lemma and_leftp_crel_vs:
  "and_leftp (crel_vs R) P x x\<^sub>T \<Longrightarrow> crel_vs (and_leftp R P) x x\<^sub>T"
  unfolding and_leftp_def by (fastforce intro: crel_vs_intro elim: crel_vs_elim)
term 0 (**)

lemma map_transfer_inset:
   "crel_vs ((and_leftp R0 (\<lambda>x. x\<in>set xs) ===>\<^sub>T R1) ===>\<^sub>T and_leftp (list_all2 R0) (op = xs) ===>\<^sub>T (list_all2 R1)) map map\<^sub>T"
proof -
  { fix f f\<^sub>T' xs\<^sub>T'
    assume [transfer_rule]: "(and_leftp R0 (\<lambda>x. x\<in>set xs) ===>\<^sub>T R1) f f\<^sub>T'" and rx: "list_all2 R0 xs xs\<^sub>T'"
    from rx[THEN and_leftp_leftset_intro] have "crel_vs (list_all2 R1) (map f xs) (map\<^sub>T' f\<^sub>T' xs\<^sub>T')"
      apply (induction rule: list_all2_induct; unfold list.map map\<^sub>T'.simps)
      subgoal premises [transfer_rule] by transfer_prover
      subgoal premises [transfer_rule] by transfer_prover
      done
  }
  hence [transfer_rule]: "((and_leftp R0 (\<lambda>x. x\<in>set xs) ===>\<^sub>T R1) ===> and_leftp (list_all2 R0) (op = xs) ===>\<^sub>T (list_all2 R1)) map map\<^sub>T'"
    by (fastforce elim: and_leftp_lefteq_elim)
  show ?thesis
    unfolding map\<^sub>T_def by transfer_prover
qed

lemma map_transfer_inset_unfolded:
  fixes R0 R1 f f\<^sub>T' xs xs\<^sub>T
  assumes "(and_leftp R0 (\<lambda>x. x\<in>set xs) ===>\<^sub>T R1) f f\<^sub>T'" "crel_vs (list_all2 R0) xs xs\<^sub>T"
  shows "crel_vs (list_all2 R1) (map f xs) (map\<^sub>T . \<langle>f\<^sub>T'\<rangle> . xs\<^sub>T)"
  apply (rule fun_app_lifted_transfer[THEN rel_funD, THEN rel_funD, where x=xs])
   apply (rule fun_app_lifted_transfer[THEN rel_funD, THEN rel_funD, where x=f])
    apply (fact map_transfer_inset)
   apply (rule crel_vs_return)
   apply (fact assms(1))
  apply (rule and_leftp_crel_vs)
  apply (rule and_leftp_lefteq_same)
  apply (fact assms(2))
  done

lemma map_transfer_inset_unfolded':
  fixes R0 R1 f f\<^sub>T' xs xs\<^sub>T
  assumes "\<And>x x\<^sub>T'. R0 x x\<^sub>T' \<Longrightarrow> x\<in>set xs \<Longrightarrow> crel_vs R1 (f x) (f\<^sub>T' x\<^sub>T')" "crel_vs (list_all2 R0) xs xs\<^sub>T"
  shows "crel_vs (list_all2 R1) (map f xs) (map\<^sub>T . \<langle>f\<^sub>T'\<rangle> . xs\<^sub>T)"
  apply (rule map_transfer_inset_unfolded)
   apply (rule rel_funI)
   apply (rule assms(1))
    apply (erule and_leftp_elim[where R=R0])
    apply (assumption)
   apply (erule and_leftp_elim[where R=R0])
   apply (assumption)
  apply (fact assms(2))
  done

lemma crel_vs_map_simple:
  fixes R f f\<^sub>T' xs xs\<^sub>T
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> crel_vs op = (f x) (f\<^sub>T' x)" "crel_vs op = xs xs\<^sub>T"
  shows "crel_vs op = (map f xs) (map\<^sub>T . \<langle>f\<^sub>T'\<rangle> . xs\<^sub>T)"
  apply (rule map_transfer_inset_unfolded'[where ?R0.0="op =" and ?R1.0="op =", unfolded list.rel_eq])
   apply clarify
   apply (fact assms(1))
  apply (fact assms(2))
  done

lemma map_transfer_inset0:
  "crel_vs ((eq_onp (\<lambda>x. x\<in>set xs) ===>\<^sub>T R) ===>\<^sub>T eq_onp (op = xs) ===>\<^sub>T (list_all2 R)) map map\<^sub>T"
  using map_transfer_inset[of "op =", unfolded list.rel_eq eq_onp_and_leftp_eq] .
term 0 (**)

lemma fold_transfer_inset:
  fixes R0 R1 f f\<^sub>T' xs xs\<^sub>T
  assumes "(and_leftp R0 (\<lambda>x. x\<in>set xs) ===>\<^sub>T R1 ===>\<^sub>T R1) f f\<^sub>T'" "crel_vs (list_all2 R0) xs xs\<^sub>T"
  shows  "crel_vs (R1 ===>\<^sub>T R1) (fold f xs) (fold\<^sub>T . \<langle>f\<^sub>T'\<rangle> . xs\<^sub>T)"
proof -
  { fix f f\<^sub>T' xs\<^sub>T' a b
    assume [transfer_rule]: "(and_leftp R0 (\<lambda>x. x\<in>set xs) ===>\<^sub>T R1 ===>\<^sub>T R1) f f\<^sub>T'" and rx: "list_all2 R0 xs xs\<^sub>T'"
    from rx[THEN and_leftp_leftset_intro] have "crel_vs (R1 ===>\<^sub>T R1) (fold f xs) (fold\<^sub>T' f\<^sub>T' xs\<^sub>T')"
      apply (induction rule: list_all2_induct; unfold fold.simps fold\<^sub>T'.simps)
      subgoal premises [transfer_rule] by transfer_prover
      subgoal premises [transfer_rule] by transfer_prover
      done
  }
  hence [transfer_rule]: "((and_leftp R0 (\<lambda>x. x\<in>set xs) ===>\<^sub>T R1 ===>\<^sub>T R1) ===> and_leftp (list_all2 R0) (op = xs) ===>\<^sub>T R1 ===>\<^sub>T R1) fold fold\<^sub>T'"
    by (fastforce elim: and_leftp_lefteq_elim)
  show ?thesis
    unfolding fold\<^sub>T_def supply [transfer_rule] = assms(1) and_leftp_lefteq_same[THEN and_leftp_crel_vs, OF assms(2)] by transfer_prover
qed

end
end

definition K :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "K x \<equiv> eq_onp (op = x)"

lemma K_self: "K x x x"
  unfolding K_def eq_onp_def by auto
end