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

theory Aligned
imports WordLib MoreDivides WordSetup
begin

lemma is_aligned_mask: "(is_aligned w n) = (w && mask n = 0)"
  unfolding is_aligned_def by (rule and_mask_dvd_nat)

lemma list_of_false:
  "True \<notin> set xs \<Longrightarrow> xs = replicate (length xs) False"
  by (induct xs, simp_all)

lemma eq_zero_set_bl: "(w = 0) = (True \<notin> set (to_bl w))"
  apply (subst word_bl.Rep_inject[symmetric])
  apply (subst to_bl_0)
  apply (rule iffI)
   apply clarsimp
  apply (drule list_of_false)
  apply simp
  done

lemmas and_bang = word_and_nth

lemma diff_diff_less: "(i < m - (m - (n :: nat))) = (i < m \<and> i < n)"
  apply (case_tac "n \<le> m")
   apply fastforce+
  done

lemma is_aligned_to_bl:
  "is_aligned (w :: 'a :: len word) n = (True \<notin> set (drop (size w - n) (to_bl w)))"
  apply (simp add: is_aligned_mask eq_zero_set_bl)
  apply (clarsimp simp: in_set_conv_nth word_size)
  apply (simp add: to_bl_nth word_size cong: conj_cong)
  apply (simp add: diff_diff_less)
  apply safe
   apply (case_tac "n \<le> len_of TYPE('a)")
    prefer 2
    apply (rule_tac x=i in exI)
    apply clarsimp
   apply (subgoal_tac "\<exists>j < len_of TYPE('a). j < n \<and> len_of TYPE('a) - n + j = i")
    apply (erule exE)
    apply (rule_tac x=j in exI)
    apply clarsimp
   apply (thin_tac "w !! ?t")
   apply (rule_tac x="i + n - len_of TYPE('a)" in exI)
   apply clarsimp
   apply arith
  apply (rule_tac x="len_of TYPE('a) - n + i" in exI)
  apply clarsimp
  apply arith
  done

lemma unat_power_lower [simp]:
  assumes nv: "n < len_of TYPE('a::len)"
  shows "unat ((2::'a::len word) ^ n) = 2 ^ n"
  apply (subst word_unat_power)
  apply (subst unat_of_nat)
  apply (subst mod_less)
   apply (simp add: nv)
  apply simp
  done

lemma power_overflow:
  "n \<ge> len_of TYPE('a) \<Longrightarrow> 2 ^ n = (0 :: 'a::len word)"
  apply (subgoal_tac "\<exists>m. n = (len_of TYPE ('a)) + m")
   apply safe
   apply (simp only: power_add word_pow_0)
   apply simp
  apply (rule exI[where x="n - len_of TYPE ('a)"])
  apply simp
  done

lemma is_alignedI [intro?]:
  fixes x::"'a::len word"
  assumes xv: "x = 2 ^ n * k"
  shows   "is_aligned x n"
proof cases
  assume nv: "n < len_of TYPE('a)"
  show ?thesis
    unfolding is_aligned_def
  proof (rule dvdI [where k = "unat k mod 2 ^ (len_of TYPE('a) - n)"])
    from xv
    have "unat x = (unat (2::word32) ^ n * unat k) mod 2 ^ len_of TYPE('a)"
      using nv
      by (subst (asm) word_unat.Rep_inject [symmetric], simp,
          subst unat_word_ariths, simp)

    also have "\<dots> =  2 ^ n * (unat k mod 2 ^ (len_of TYPE('a) - n))" using nv
      by (simp add: mult_mod_right power_add [symmetric] add_diff_inverse)

    finally show "unat x = 2 ^ n * (unat k mod 2 ^ (len_of TYPE('a) - n))" .
  qed
next
  assume "\<not> n < len_of TYPE('a)"
  with xv
  show ?thesis by (simp add: not_less power_overflow is_aligned_def)
qed

lemma is_aligned_weaken:
  "\<lbrakk> is_aligned w x; x \<ge> y \<rbrakk> \<Longrightarrow> is_aligned w y"
  apply (simp add: is_aligned_def)
  apply (rule dvd_trans)
   prefer 2
   apply assumption
  apply (simp add: le_imp_power_dvd)
  done

lemma nat_power_less_diff:
  assumes lt: "(2::nat) ^ n * q < 2 ^ m"
  shows "q < 2 ^ (m - n)"
  using lt
proof (induct n arbitrary: m)
  case 0
  thus ?case by simp
next
  case (Suc n)

  have ih: "\<And>m. 2 ^ n * q < 2 ^ m \<Longrightarrow> q < 2 ^ (m - n)"
    and prem: "2 ^ Suc n * q < 2 ^ m" by fact+

  show ?case
  proof (cases m)
    case 0
    thus ?thesis using Suc by simp
  next
    case (Suc m')
    thus ?thesis using prem
      by (simp add: ac_simps ih)
  qed
qed

lemma is_alignedE_pre:
  fixes w::"'a::len word"
  assumes aligned: "is_aligned w n"
  shows        rl: "\<exists>q. w = 2 ^ n * (of_nat q) \<and> q < 2 ^ (len_of TYPE('a) - n)"
proof -
  from aligned obtain q where wv: "unat w = 2 ^ n * q"
    unfolding is_aligned_def ..

  show ?thesis
  proof (rule exI, intro conjI)
    show "q < 2 ^ (len_of TYPE('a) - n)"
    proof (rule nat_power_less_diff)
      have "unat w < 2 ^ size w" unfolding word_size ..
      hence "unat w < 2 ^ len_of TYPE('a)" by simp
      with wv show "2 ^ n * q < 2 ^ len_of TYPE('a)" by simp
    qed

    have r: "of_nat (2 ^ n) = (2::word32) ^ n"
      by (induct n) simp+

    from wv have "of_nat (unat w) = of_nat (2 ^ n * q)" by simp
    hence "w = of_nat (2 ^ n * q)" by (subst word_unat.Rep_inverse [symmetric])
    thus "w = 2 ^ n * (of_nat q)" by (simp add: r)
  qed
qed

lemma is_alignedE:
  "\<lbrakk>is_aligned (w::'a::len word) n;
    \<And>q. \<lbrakk>w = 2 ^ n * (of_nat q); q < 2 ^ (len_of TYPE('a) - n)\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (auto dest: is_alignedE_pre)

lemma is_aligned_replicate:
  fixes w::"'a::len word"
  assumes aligned: "is_aligned w n"
  and          nv: "n \<le> len_of TYPE('a)"
  shows   "to_bl w = (take (len_of TYPE('a) - n) (to_bl w)) @ replicate n False"
proof -
    from nv have rl: "\<And>q. q < 2 ^ (len_of TYPE('a) - n) \<Longrightarrow>
      to_bl (2 ^ n * (of_nat q :: 'a word)) =
      drop n (to_bl (of_nat q :: 'a word)) @ replicate n False"
      apply (subst shiftl_t2n [symmetric])
      apply (subst bl_shiftl)
      apply (simp add: min_def word_size)
      done

    show ?thesis using aligned
      by (auto simp: rl elim: is_alignedE)
qed

lemma is_aligned_drop:
  fixes w::"'a::len word"
  assumes "is_aligned w n" "n \<le> len_of TYPE('a)"
  shows "drop (len_of TYPE('a) - n) (to_bl w) = replicate n False"
proof -
  have "to_bl w = take (len_of TYPE('a) - n) (to_bl w) @ replicate n False"
    by (rule is_aligned_replicate) fact+
  hence "drop (len_of TYPE('a) - n) (to_bl w) = drop (len_of TYPE('a) - n) \<dots>" by simp
  also have "\<dots> = replicate n False" by simp
  finally show ?thesis .
qed

lemma less_is_drop_replicate:
  fixes x::"'a::len word"
  assumes lt: "x < 2 ^ n"
  shows   "to_bl x = replicate (len_of TYPE('a) - n) False @ drop (len_of TYPE('a) - n) (to_bl x)"
proof -
  show ?thesis
    apply (subst less_mask_eq [OF lt, symmetric])
    apply (subst bl_and_mask)
    apply simp
    done
qed

lemma is_aligned_add_conv:
  fixes off::"'a::len word"
  assumes aligned: "is_aligned w n"
  and        offv: "off < 2 ^ n"
  shows    "to_bl (w + off) =
   (take (len_of TYPE('a) - n) (to_bl w)) @ (drop (len_of TYPE('a) - n) (to_bl off))"
proof cases
  assume nv: "n \<le> len_of TYPE('a)"
  show ?thesis
  proof (subst aligned_bl_add_size, simp_all only: word_size)
    show "drop (len_of TYPE('a) - n) (to_bl w) = replicate n False"
      by (subst is_aligned_replicate [OF aligned nv]) (simp add: word_size)

    from offv show "take (len_of TYPE('a) - n) (to_bl off) =
                    replicate (len_of TYPE('a) - n) False"
      by (subst less_is_drop_replicate, assumption) simp
  qed fact
next
  assume "\<not> n \<le> len_of TYPE('a)"
  with offv show ?thesis by (simp add: power_overflow)
qed

lemma nat_less_power_trans:
  fixes n :: nat
  assumes nv: "n < 2 ^ (m - k)"
  and     kv: "k \<le> m"
  shows "2 ^ k * n < 2 ^ m"
proof (rule order_less_le_trans)
  show "2 ^ k * n < 2 ^ k * 2 ^ (m - k)"
    by (rule mult_less_mono2 [OF nv zero_less_power]) simp

  show "(2::nat) ^ k * 2 ^ (m - k) \<le> 2 ^ m" using nv kv
    by (subst power_add [symmetric]) simp
qed

lemma aligned_add_aligned:
  fixes x::"'a::len word"
  assumes aligned1: "is_aligned x n"
  and     aligned2: "is_aligned y m"
  and           lt: "m \<le> n"
  shows   "is_aligned (x + y) m"
proof cases
  assume nlt: "n < len_of TYPE('a)"
  show ?thesis
    unfolding is_aligned_def dvd_def
  proof -
    from aligned2 obtain q2 where yv: "y = 2 ^ m * of_nat q2"
      and q2v: "q2 < 2 ^ (len_of TYPE('a) - m)"
      by (auto elim: is_alignedE)

    from lt obtain k where kv: "m + k = n" by (auto simp: le_iff_add)
    with aligned1 obtain q1 where xv: "x = 2 ^ (m + k) * of_nat q1"
      and q1v: "q1 < 2 ^ (len_of TYPE('a) - (m + k))"
      by (auto elim: is_alignedE)

    have l1: "2 ^ (m + k) * q1 < 2 ^ len_of TYPE('a)"
      by (rule nat_less_power_trans [OF q1v])
         (subst kv, rule order_less_imp_le [OF nlt])

    have l2: "2 ^ m * q2 < 2 ^ len_of TYPE('a)"
      by (rule nat_less_power_trans [OF q2v],
          rule order_less_imp_le [OF order_le_less_trans])
         fact+

    have "x = of_nat (2 ^ (m + k) *  q1)" using xv
      by simp

    moreover have "y = of_nat (2 ^ m * q2)" using yv
      by simp

    ultimately have upls: "unat x + unat y = 2 ^ m * (2 ^ k * q1 + q2)"
      apply -
      apply (erule ssubst)+
      apply (subst unat_of_nat)
      apply (subst mod_less [OF l1])
      apply (subst unat_of_nat)
      apply (subst mod_less [OF l2])
      apply (subst power_add)
      apply (subst add_mult_distrib2)
      apply simp
      done

    (* (2 ^ k * q1 + q2) *)
    show "\<exists>d. unat (x + y) = 2 ^ m * d"
    proof (cases "unat x + unat y < 2 ^ len_of TYPE('a)")
      case True

      have "unat (x + y) = unat x + unat y"
        by (subst unat_plus_if', rule if_P) fact

      also have "\<dots> = 2 ^ m * (2 ^ k * q1 + q2)" by (rule upls)
      finally show ?thesis ..
    next
      case False
      hence "unat (x + y) = (unat x + unat y) mod 2 ^ len_of TYPE('a)"
        by (subst unat_word_ariths(1)) simp

      also have "\<dots> = (2 ^ m * (2 ^ k * q1 + q2)) mod 2 ^ len_of TYPE('a)"
        by (subst upls, rule refl)

      also have "\<dots> = 2 ^ m * ((2 ^ k * q1 +  q2) mod 2 ^ (len_of TYPE('a) - m))"
        apply (subst mult_mod_right)
        apply (subst power_add [symmetric])
        apply (subst le_add_diff_inverse
                     [OF order_trans[OF lt order_less_imp_le[OF nlt]]])
        apply (rule refl)
        done

      finally show ?thesis ..
    qed
  qed
next
  assume "\<not> n < len_of TYPE('a)"
  with assms
  show ?thesis by (simp add: not_less power_overflow is_aligned_mask mask_def)
qed

corollary aligned_sub_aligned:
  "\<lbrakk>is_aligned (x::'a::len word) n; is_aligned y m; m \<le> n\<rbrakk>
   \<Longrightarrow> is_aligned (x - y) m"
  apply (simp del: add_uminus_conv_diff add:diff_conv_add_uminus)
  apply (erule aligned_add_aligned, simp_all)
  apply (erule is_alignedE)
  apply (rule_tac k="- of_nat q" in is_alignedI)
  apply simp
  done

lemma is_aligned_shift:
  fixes k::"'a::len word"
  shows "is_aligned (k << m) m"
proof cases
  assume mv: "m < len_of TYPE('a)"
  from mv obtain q where mq: "m + q = len_of TYPE('a)" and "0 < q"
    by (auto dest: less_imp_add_positive)

  have "(2\<Colon>nat) ^ m dvd unat (k << m)"
  proof
    have kv: "(unat k div 2 ^ q) * 2 ^ q + unat k mod 2 ^ q = unat k"
      by (rule mod_div_equality)

    have "unat (k << m) = unat (2 ^ m * k)" by (simp add: shiftl_t2n)
    also have "\<dots> = (2 ^ m * unat k) mod (2 ^ len_of TYPE('a))" using mv
      by (subst unat_word_ariths(2))+ simp
    also have "\<dots> = 2 ^ m * (unat k mod 2 ^ q)"
      by (subst mq [symmetric], subst power_add, subst mod_mult2_eq) simp
    finally show "unat (k << m) = 2 ^ m * (unat k mod 2 ^ q)" .
  qed

  thus ?thesis by (unfold is_aligned_def)
next
  assume "\<not> m < len_of TYPE('a)"
  thus ?thesis
    by (simp add: not_less power_overflow is_aligned_mask mask_def
                  shiftl_zero_size word_size)
qed

lemma aligned_mod_eq_0:
  fixes p::"'a::len word"
  assumes al: "is_aligned p sz"
  shows   "p mod 2 ^ sz = 0"
proof cases
  assume szv: "sz < len_of TYPE('a)"
  with al
  show ?thesis
    unfolding is_aligned_def
    apply -
    apply (rule word_unat.Rep_eqD)
    apply (subst unat_mod)
    apply (simp add: dvd_eq_mod_eq_0)
    done
next
  assume "\<not> sz < len_of TYPE('a)"
  with al show ?thesis
    by (simp add: not_less power_overflow is_aligned_mask mask_def
                  word_mod_by_0)
qed

lemma is_aligned_triv: "is_aligned (2 ^ n ::'a::len word) n"
  by (rule is_alignedI [where k = 1], simp)

lemma is_aligned_mult_triv1: "is_aligned (2 ^ n * x  ::'a::len word) n"
  by (rule is_alignedI [OF refl])

lemma is_aligned_mult_triv2: "is_aligned (x * 2 ^ n ::'a::len word) n"
  by (subst mult.commute, simp add: is_aligned_mult_triv1)

lemma word_power_less_0_is_0:
  fixes x :: "'a::len word"
  shows "x < a ^ 0 \<Longrightarrow> x = 0" by simp

lemma nat_add_offset_less:
  fixes x :: nat
  assumes yv: "y < 2 ^ n"
  and     xv: "x < 2 ^ m"
  and     mn: "sz = m + n"
  shows   "x * 2 ^ n + y < 2 ^ sz"
proof (subst mn)
  from yv obtain qy where "y + qy = 2 ^ n" and "0 < qy"
    by (auto dest: less_imp_add_positive)

  have "x * 2 ^ n + y < x * 2 ^ n + 2 ^ n" by simp fact+
  also have "\<dots> = (x + 1) * 2 ^ n" by simp
  also have "\<dots> \<le> 2 ^ (m + n)" using xv
    by (subst power_add) (rule mult_le_mono1, simp)
  finally show "x * 2 ^ n + y < 2 ^ (m + n)" .
qed

lemma is_aligned_no_wrap:
  fixes off :: "'a::len word"
  fixes ptr :: "'a::len word"
  assumes al: "is_aligned ptr sz"
  and    off: "off < 2 ^ sz"
  shows  "unat ptr + unat off < 2 ^ len_of TYPE('a)"
proof -
  have szv: "sz < len_of TYPE('a)"
    apply (rule ccontr)
    using off
    by (clarsimp simp: not_less p2_eq_0[THEN iffD2])

  from al obtain q where ptrq: "ptr = 2 ^ sz * of_nat q" and
    qv: "q < 2 ^ (len_of TYPE('a) - sz)" by (auto elim: is_alignedE)

  show ?thesis
  proof (cases "sz = 0")
    case True
    thus ?thesis using off ptrq qv
      by clarsimp
  next
    case False
    hence sne: "0 < sz" ..

    show ?thesis
    proof -
      have uq: "unat (of_nat q ::'a::len word) = q"
        apply (subst unat_of_nat)
        apply (rule mod_less)
        apply (rule order_less_trans [OF qv])
        apply (rule power_strict_increasing [OF diff_less [OF sne]])
         apply (simp_all)
        done

      have uptr: "unat ptr = 2 ^ sz * q"
        apply (subst ptrq)
        apply (subst iffD1 [OF unat_mult_lem])
         apply (subst unat_power_lower [OF szv])
         apply (subst uq)
         apply (rule nat_less_power_trans [OF qv order_less_imp_le [OF szv]])
        apply (subst uq)
        apply (subst unat_power_lower [OF szv])
        apply simp
        done

      show "unat ptr + unat off < 2 ^ len_of TYPE('a)" using szv
        apply (subst uptr)
        apply (subst mult.commute, rule nat_add_offset_less [OF _ qv])
        apply (rule order_less_le_trans [OF unat_mono [OF off] order_eq_refl])
         apply simp_all
        done
    qed
  qed
qed

lemma is_aligned_no_wrap':
  fixes ptr :: "'a::len word"
  assumes al: "is_aligned ptr sz"
  and    off: "off < 2 ^ sz"
  shows  "ptr \<le> ptr + off"
  by (subst no_plus_overflow_unat_size, subst word_size, rule is_aligned_no_wrap) fact+

lemma is_aligned_no_overflow':
  fixes p :: "'a::len word"
  assumes al: "is_aligned p n"
  shows "p \<le> p + (2 ^ n - 1)"
proof cases
  assume "n<len_of TYPE('a)"
  with al
  have "2^n - (1::'a::len word) < 2^n"
    by (simp add: word_less_nat_alt unat_sub_if_size)
  with al
  show ?thesis by (rule is_aligned_no_wrap')
next
  assume "\<not> n<len_of TYPE('a)"
  with al
  show ?thesis
  by (simp add: not_less power_overflow is_aligned_mask mask_2pm1)
qed

lemma replicate_not_True:
  "\<And>n. xs = replicate n False \<Longrightarrow> True \<notin> set xs"
  by (induct xs) auto

lemma is_aligned_replicateI:
  "to_bl p = addr @ replicate n False \<Longrightarrow> is_aligned (p::'a::len word) n"
  apply (simp add: is_aligned_to_bl word_size)
  apply (subgoal_tac "length addr = len_of TYPE('a) - n")
   apply (simp add: replicate_not_True)
  apply (drule arg_cong [where f=length])
  apply simp
  done

lemma to_bl_1: "to_bl (1::'a::len word) = replicate (len_of TYPE('a) - 1) False @ [True]"
proof -
  have "to_bl (1 :: 'a::len word) = to_bl (mask 1 :: 'a::len word)"
    by (simp add: mask_def)

  also have "\<dots> = replicate (len_of TYPE('a) - 1) False @ [True]"
    apply (subst to_bl_mask)
    apply (clarsimp simp add: min_def)
    apply (case_tac "len_of TYPE('a)", simp)
    apply simp
    done

  finally show ?thesis .
qed

lemma to_bl_2p:
  "n < len_of TYPE('a) \<Longrightarrow>
   to_bl ((2::'a::len word) ^ n) =
   replicate (len_of TYPE('a) - Suc n) False @ True # replicate n False"
  apply (subst shiftl_1 [symmetric])
  apply (subst bl_shiftl)
  apply (simp add: to_bl_1 min_def word_size)
  done

lemma map_zip_replicate_False_xor:
  "n = length xs \<Longrightarrow> map (\<lambda>(x, y). x = (\<not> y)) (zip xs (replicate n False)) = xs"
  by (induct xs arbitrary: n, auto)

lemma drop_minus_lem:
  "\<lbrakk> n \<le> length xs; 0 < n; n' = length xs \<rbrakk> \<Longrightarrow> drop (n' - n) xs = rev xs ! (n - 1)  # drop (Suc (n' - n)) xs"
proof (induct xs arbitrary: n n')
  case Nil thus ?case by simp
next
  case (Cons y ys)
  from Cons.prems
  show ?case
    apply simp
    apply (cases "n = Suc (length ys)")
     apply (simp add: nth_append)
    apply (simp add: Suc_diff_le Cons.hyps nth_append)
    apply clarsimp
    apply arith
    done
qed

lemma drop_minus:
  "\<lbrakk> n < length xs; n' = length xs \<rbrakk> \<Longrightarrow> drop (n' - Suc n) xs = rev xs ! n  # drop (n' - n) xs"
  apply (subst drop_minus_lem)
     apply simp
    apply simp
   apply simp
  apply simp
  apply (cases "length xs", simp)
  apply (simp add: Suc_diff_le)
  done

lemma xor_2p_to_bl:
  fixes x::"'a::len word"
  shows "to_bl (x xor 2^n) =
  (if n < len_of TYPE('a)
   then take (len_of TYPE('a)-Suc n) (to_bl x) @ (\<not>rev (to_bl x)!n) # drop (len_of TYPE('a)-n) (to_bl x)
   else to_bl x)"
proof -
  have x: "to_bl x = take (len_of TYPE('a)-Suc n) (to_bl x) @ drop (len_of TYPE('a)-Suc n) (to_bl x)"
    by simp

  show ?thesis
  apply simp
  apply (rule conjI)
   apply (clarsimp simp: word_size)
   apply (simp add: bl_word_xor map2_def to_bl_2p)
   apply (subst x)
   apply (subst zip_append)
    apply simp
   apply (simp add: map_append)
   apply (simp add: map_zip_replicate_False_xor drop_minus)
  apply clarsimp
  apply (rule word_eqI)
  apply (simp add: word_size nth_w2p)
  done
qed

lemma aligned_add_xor:
  assumes al: "is_aligned (x::'a::len word) n'" and le: "n < n'"
  shows "(x + 2^n) xor 2^n = x"
proof cases
  assume "n' < len_of TYPE('a)"
  with assms show ?thesis
  apply -
  apply (rule word_bl.Rep_eqD)
  apply (subst xor_2p_to_bl)
  apply simp
  apply (subst is_aligned_add_conv, simp,
         simp add: word_less_nat_alt)+
  apply (simp add: to_bl_2p nth_append)
  apply (cases "n' = Suc n")
   apply simp
   apply (subst is_aligned_replicate [where n="Suc n",
                                      simplified, symmetric])
     apply assumption
    apply simp
   apply (rule refl)
  apply (subgoal_tac "\<not> len_of TYPE('a) - Suc n \<le> len_of TYPE('a) - n'")
   prefer 2
   apply arith
  apply (simp add: min_def)
  apply (subst replicate_Suc [symmetric])
  apply (subst replicate_add [symmetric])
  apply simp
  apply (simp add: is_aligned_replicate [simplified, symmetric])
  done
next
  assume "\<not> n' < len_of TYPE('a)"
  with al show ?thesis
    by (simp add: is_aligned_mask mask_def not_less power_overflow)
qed

lemma is_aligned_0 [simp]:
  "is_aligned p 0"
  by (simp add: is_aligned_def)

lemma is_aligned_replicateD:
  "\<lbrakk> is_aligned (w::'a::len word) n; n \<le> len_of TYPE('a) \<rbrakk>
     \<Longrightarrow> \<exists>xs. to_bl w = xs @ replicate n False
               \<and> length xs = size w - n"
  apply (subst is_aligned_replicate, assumption+)
  apply (rule exI, rule conjI, rule refl)
  apply (simp add: word_size)
  done

lemma is_aligned_add_multI:
  fixes p :: "'a::len word"
  shows "\<lbrakk>is_aligned p m; n \<le> m; n' = n\<rbrakk> \<Longrightarrow> is_aligned (p + x * 2 ^ n) n'"
  apply (erule aligned_add_aligned)
  apply (auto intro: is_alignedI [where k="x"])
  done

lemma unat_of_nat_len:
  "x < 2 ^ len_of TYPE('a) \<Longrightarrow> unat (of_nat x :: 'a::len word) = x"
  by (simp add: word_size unat_of_nat)

lemma is_aligned_no_wrap''':
  fixes ptr :: "'a::len word"
  shows"\<lbrakk> is_aligned ptr sz; sz < len_of TYPE('a); off < 2 ^ sz \<rbrakk>
         \<Longrightarrow> unat ptr + off < 2 ^ len_of TYPE('a)"
  apply (drule is_aligned_no_wrap[where off="of_nat off"])
   apply (simp add: word_less_nat_alt)
   apply (erule order_le_less_trans[rotated])
   apply (subst unat_of_nat)
   apply (rule mod_le_dividend)
  apply (subst(asm) unat_of_nat_len)
   apply (erule order_less_trans)
   apply (erule power_strict_increasing)
   apply simp
  apply assumption
  done

lemma rsubst:
  "\<lbrakk> P s; s = t \<rbrakk> \<Longrightarrow> P t"
  by simp

lemma aligned_small_is_0:
  "\<lbrakk> is_aligned x n; x < 2 ^ n \<rbrakk> \<Longrightarrow> x = 0"
  apply (erule is_aligned_get_word_bits)
   apply (frule is_aligned_add_conv [rotated, where w=0])
    apply (simp add: is_aligned_def)
   apply simp
   apply (drule is_aligned_replicateD)
    apply simp
   apply (clarsimp simp: word_size)
   apply (subst (asm) replicate_add [symmetric])
   apply (drule arg_cong[where f="of_bl :: bool list \<Rightarrow> 'a::len word"])
   apply simp
  apply (simp only: replicate.simps[symmetric, where x=False]
                    drop_replicate)
  done

corollary is_aligned_less_sz:
  "\<lbrakk>is_aligned a sz; a \<noteq> 0\<rbrakk> \<Longrightarrow> \<not> a < 2 ^ sz"
  by (rule notI, drule(1) aligned_small_is_0, erule(1) notE)

lemma aligned_at_least_t2n_diff:
  "\<lbrakk>is_aligned x n; is_aligned y n; x < y\<rbrakk> \<Longrightarrow> x \<le> y - 2 ^ n"
  apply (erule is_aligned_get_word_bits[where p=y])
   apply (rule ccontr)
   apply (clarsimp simp: linorder_not_le)
   apply (subgoal_tac "y - x = 0")
    apply clarsimp
   apply (rule aligned_small_is_0)
    apply (erule(1) aligned_sub_aligned)
    apply simp
   apply unat_arith
  apply simp
  done

lemma word_sub_1_le:
  "x \<noteq> 0 \<Longrightarrow> x - 1 \<le> (x :: ('a :: len) word)"
  apply (subst no_ulen_sub)
  apply simp
  apply (cases "uint x = 0")
   apply (simp add: uint_0_iff)
  apply (insert uint_ge_0[where x=x])
  apply arith
  done

lemma is_aligned_no_overflow'':
  "\<lbrakk>is_aligned x n; x + 2 ^ n \<noteq> 0\<rbrakk> \<Longrightarrow> x \<le> x + 2 ^ n"
  apply (frule is_aligned_no_overflow')
  apply (erule order_trans)
  apply (simp add: field_simps)
  apply (erule word_sub_1_le)
  done

lemma is_aligned_nth:
  "is_aligned p m = (\<forall>n < m. \<not>p !! n)"
  apply (clarsimp simp: is_aligned_mask bang_eq word_size)
  apply (rule iffI)
   apply clarsimp
   apply (case_tac "n < size p")
    apply (simp add: word_size)
   apply (drule test_bit_size)
   apply simp
  apply clarsimp
  done

lemma range_inter:
  "({a..b} \<inter> {c..d} = {}) = (\<forall>x. \<not>(a \<le> x \<and> x \<le> b \<and> c \<le> x \<and> x \<le> d))"
  by auto

lemma aligned_inter_non_empty:
  "\<lbrakk> {p..p + (2 ^ n - 1)} \<inter> {p..p + 2 ^ m - 1} = {};
     is_aligned p n; is_aligned p m\<rbrakk> \<Longrightarrow> False"
  apply (clarsimp simp only: range_inter)
  apply (erule_tac x=p in allE)
  apply simp
  apply (erule impE)
   apply (erule is_aligned_no_overflow')
  apply (erule notE)
  apply (erule is_aligned_no_overflow)
  done

lemma not_aligned_mod_nz:
  assumes al: "\<not> is_aligned a n"
  shows "a mod 2 ^ n \<noteq> 0"
proof cases
  assume "n < len_of TYPE('a)"
  with al
  show ?thesis
    apply (simp add: is_aligned_def dvd_eq_mod_eq_0 word_arith_nat_mod
                del: word_neq_0_conv)
    apply (erule of_nat_neq_0)
    apply (rule order_less_trans)
     apply (rule mod_less_divisor)
     apply simp
    apply simp
    done
next
  assume "\<not> n < len_of TYPE('a)"
  with al
  show ?thesis
    by (simp add: is_aligned_mask mask_def not_less power_overflow
                  word_less_nat_alt word_mod_by_0)
qed

lemma nat_add_offset_le:
  fixes x :: nat
  assumes yv: "y \<le> 2 ^ n"
  and     xv: "x < 2 ^ m"
  and     mn: "sz = m + n"
  shows   "x * 2 ^ n + y \<le> 2 ^ sz"
proof (subst mn)
  from yv obtain qy where "y + qy = 2 ^ n"
    by (auto simp: le_iff_add)

  have "x * 2 ^ n + y \<le> x * 2 ^ n + 2 ^ n"
    using yv xv by simp
  also have "\<dots> = (x + 1) * 2 ^ n" by simp
  also have "\<dots> \<le> 2 ^ (m + n)" using xv
    by (subst power_add) (rule mult_le_mono1, simp)
  finally show "x * 2 ^ n + y \<le> 2 ^ (m + n)" .
qed

lemma is_aligned_no_wrap_le:
  fixes ptr::"'a::len word"
  assumes al: "is_aligned ptr sz"
  and    szv: "sz < len_of TYPE('a)"
  and    off: "off \<le> 2 ^ sz"
  shows  "unat ptr + off \<le> 2 ^ len_of TYPE('a)"
proof -
  from al obtain q where ptrq: "ptr = 2 ^ sz * of_nat q" and
    qv: "q < 2 ^ (len_of TYPE('a) - sz)" by (auto elim: is_alignedE)

  show ?thesis
  proof (cases "sz = 0")
    case True
    thus ?thesis using off ptrq qv
      apply (clarsimp)
      apply (erule le_SucE)
       apply (simp add: unat_of_nat)
      apply (simp add: less_eq_Suc_le [symmetric] unat_of_nat)
      done
  next
    case False
    hence sne: "0 < sz" ..

    show ?thesis
    proof -
      have uq: "unat (of_nat q :: 'a word) = q"
        apply (subst unat_of_nat)
        apply (rule mod_less)
        apply (rule order_less_trans [OF qv])
        apply (rule power_strict_increasing [OF diff_less [OF sne]])
        apply simp_all
        done

      have uptr: "unat ptr = 2 ^ sz * q"
        apply (subst ptrq)
        apply (subst iffD1 [OF unat_mult_lem])
        apply (subst unat_power_lower [OF szv])
        apply (subst uq)
        apply (rule nat_less_power_trans [OF qv order_less_imp_le [OF szv]])
        apply (subst uq)
        apply (subst unat_power_lower [OF szv])
        apply simp
        done

      show "unat ptr + off \<le> 2 ^ len_of TYPE('a)" using szv
        apply (subst uptr)
        apply (subst mult.commute, rule nat_add_offset_le [OF off qv])
        apply simp
        done
    qed
  qed
qed

lemma is_aligned_neg_mask:
  "m \<le> n \<Longrightarrow> is_aligned (x && ~~ mask n) m"
  apply (simp add: and_not_mask)
  apply (erule is_aligned_weaken[rotated])
  apply (rule is_aligned_shift)
  done

lemma unat_minus:
  "unat (- (x :: ('a :: len) word))
    = (if x = 0 then 0 else (2 ^ size x) - unat x)"
  using unat_sub_if_size[where x="2 ^ size x" and y=x]
  apply (simp add: unat_eq_0 word_size)
  done

lemma is_aligned_minus:
  "is_aligned p n \<Longrightarrow> is_aligned (- p) n"
  apply (clarsimp simp: is_aligned_def unat_minus word_size word_neq_0_conv)
  apply (rule dvd_diff_nat, simp_all)
  apply (rule le_imp_power_dvd)
  apply (fold is_aligned_def)
  apply (erule_tac Q="0<p" in contrapos_pp)
  apply (clarsimp simp add: is_aligned_mask mask_def power_overflow)
  done

end


theory Submission
  imports Defs
begin

inductive taval :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
"taval (N i) s (Iv i)" |
"taval (V x) s (s x)" |
"taval a1 s (Iv i1) \<Longrightarrow> taval a2 s (Iv i2)
 \<Longrightarrow> taval (Plus a1 a2) s (Iv (i1 + i2))" |
"taval a1 s v1 \<Longrightarrow> taval a2 s v2 \<Longrightarrow> taval (Pair a1 a2) s (Pv v1 v2)" |
"taval p s (Pv v1 v2) \<Longrightarrow> taval (Fst p) s v1" |
"taval p s (Pv v1 v2) \<Longrightarrow> taval (Snd p) s v2"

inductive_cases [elim!]:
  "taval (N i) s v"
  "taval (V x) s v"
  "taval (Plus a1 a2) s v"
  "taval (Pair a1 a2) s v"
  "taval (Fst p) s v"
  "taval (Snd p) s v"

inductive tbval :: "bexp \<Rightarrow> state \<Rightarrow> bool \<Rightarrow> bool" where
"tbval (Bc v) s v" |
"tbval b s bv \<Longrightarrow> tbval (Not b) s (\<not> bv)" |
"tbval b1 s bv1 \<Longrightarrow> tbval b2 s bv2 \<Longrightarrow> tbval (And b1 b2) s (bv1 \<and> bv2)" |
"taval a1 s (Iv i1) \<Longrightarrow> taval a2 s (Iv i2) \<Longrightarrow> tbval (Less a1 a2) s (i1 < i2)"

inductive
  small_step :: "(com \<times> state) \<Rightarrow> (com \<times> state) \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "taval a s v \<Longrightarrow> (x ::= a, s) \<rightarrow> (SKIP, s(x := v))" |
Seq1:   "(SKIP;;c,s) \<rightarrow> (c,s)" |
Seq2:   "(c1,s) \<rightarrow> (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow> (c1';;c2,s')" |
IfTrue:  "tbval b s True \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c1,s)" |
IfFalse: "tbval b s False \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c2,s)" |
While:   "(WHILE b DO c,s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP,s)" |
Swap:   "taval (V x) s (Pv v1 v2) \<Longrightarrow> (SWAP x, s) \<rightarrow> (x ::= Pair (Snd (V x)) (Fst (V x)), s)"

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

inductive atyping :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty \<Rightarrow> bool"
  ("(1_/ \<turnstile>/ (_ :/ _))" [50,0,50] 50) where
Ic_ty: "\<Gamma> \<turnstile> N i : Ity" |
V_ty: "\<Gamma> \<turnstile> V x : \<Gamma> x" |
P_ty: "\<Gamma> \<turnstile> a1 : \<tau>\<^sub>1 \<Longrightarrow> \<Gamma> \<turnstile> a2 : \<tau>\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> Pair a1 a2 : Pty \<tau>\<^sub>1 \<tau>\<^sub>2" |
Fst_ty: " \<Gamma> \<turnstile> p : Pty \<tau>\<^sub>1 \<tau>\<^sub>2 \<Longrightarrow>  \<Gamma> \<turnstile> Fst p : \<tau>\<^sub>1" |
Snd_ty: " \<Gamma> \<turnstile> p : Pty \<tau>\<^sub>1 \<tau>\<^sub>2 \<Longrightarrow>  \<Gamma> \<turnstile> Snd p : \<tau>\<^sub>2"

declare atyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> V x : \<tau>" "\<Gamma> \<turnstile> N i : \<tau>" "\<Gamma> \<turnstile> Plus a1 a2 : \<tau>" "\<Gamma> \<turnstile> Pair a1 a2 : \<tau>" "\<Gamma> \<turnstile> Fst p : \<tau>" "\<Gamma> \<turnstile> Snd p : \<tau>"

inductive btyping :: "tyenv \<Rightarrow> bexp \<Rightarrow> bool" (infix "\<turnstile>" 50) where
B_ty: "\<Gamma> \<turnstile> Bc v" |
Not_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> Not b" |
And_ty: "\<Gamma> \<turnstile> b1 \<Longrightarrow> \<Gamma> \<turnstile> b2 \<Longrightarrow> \<Gamma> \<turnstile> And b1 b2" |
Less_ty: "\<Gamma> \<turnstile> a1 : Ity \<Longrightarrow> \<Gamma> \<turnstile> a2 : Ity \<Longrightarrow> \<Gamma> \<turnstile> Less a1 a2"

declare btyping.intros [intro!]
inductive_cases [elim!]: "\<Gamma> \<turnstile> Not b" "\<Gamma> \<turnstile> And b1 b2" "\<Gamma> \<turnstile> Less a1 a2"

inductive ctyping :: "tyenv \<Rightarrow> com \<Rightarrow> bool" (infix "\<turnstile>" 50) where
Skip_ty: "\<Gamma> \<turnstile> SKIP" |
Assign_ty: "\<Gamma> \<turnstile> a : \<Gamma>(x) \<Longrightarrow> \<Gamma> \<turnstile> x ::= a" |
Seq_ty: "\<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> c1;;c2" |
If_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> IF b THEN c1 ELSE c2" |
While_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> WHILE b DO c" |
Swap_ty: "\<Gamma> \<turnstile> V x : Pty \<tau> \<tau> \<Longrightarrow> \<Gamma> \<turnstile> SWAP x"

declare ctyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> x ::= a" "\<Gamma> \<turnstile> c1;;c2"
  "\<Gamma> \<turnstile> IF b THEN c1 ELSE c2"
  "\<Gamma> \<turnstile> WHILE b DO c"
  "\<Gamma> \<turnstile> SWAP x"

theorem apreservation:
  "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> taval a s v \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> type v = \<tau>"
apply(induction arbitrary: v rule: atyping.induct)
by (fastforce simp: styping_def)+

thm taval.simps
theorem aprogress: "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. taval a s v"
proof(induction rule: atyping.induct)
  case (Fst_ty \<Gamma> p \<tau>\<^sub>1 \<tau>\<^sub>2)
  then show ?case
    by (metis apreservation taval.intros(5) ty.distinct(1) type.elims)
next
  case (Snd_ty \<Gamma> p \<tau>\<^sub>1 \<tau>\<^sub>2)
  then show ?case
    by (metis apreservation taval.intros(6) ty.distinct(1) type.elims)
qed(auto intro: taval.intros)

theorem bprogress: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. tbval b s v"
proof(induction rule: btyping.induct)
  case (Less_ty \<Gamma> a1 a2)
  then obtain v1 v2 where v: "taval a1 s v1" "taval a2 s v2"
    by (metis aprogress)
  then show ?case
  proof (cases v1)
    case Iv
    with Less_ty v show ?thesis
      by (cases v2) (fastforce intro!: tbval.intros dest!:apreservation)+
  next
    case Pv
    then show ?thesis
      using Less_ty.hyps(1) Less_ty.prems apreservation v(1) by fastforce
  qed
qed(auto intro: tbval.intros)

theorem progress:
  "\<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c \<noteq> SKIP \<Longrightarrow> \<exists>cs'. (c,s) \<rightarrow> cs'"
proof(induction rule: ctyping.induct)
  case Skip_ty thus ?case by simp
next
  case Assign_ty
  thus ?case by (metis Assign aprogress)
next
  case Seq_ty thus ?case by simp (metis Seq1 Seq2)
next
  case (If_ty \<Gamma> b c1 c2)
  then obtain bv where "tbval b s bv" by (metis bprogress)
  show ?case
  proof(cases bv)
    assume "bv"
    with \<open>tbval b s bv\<close> show ?case by simp (metis IfTrue)
  next
    assume "\<not>bv"
    with \<open>tbval b s bv\<close> show ?case by simp (metis IfFalse)
  qed
next
  case While_ty show ?case by (metis While)
next
  case (Swap_ty \<Gamma> x \<tau>)
  then have "\<exists>v1 v2. taval (V x) s (Pv v1 v2)"
    by (metis apreservation aprogress ty.distinct(1) type.elims)
  then show ?case by(metis Swap)
qed

theorem styping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<Gamma> \<turnstile> s'"
proof(induction rule: small_step_induct)
  case Assign thus ?case
    by (auto simp: styping_def) (metis Assign(1,3) apreservation)
qed auto

theorem ctyping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> c'"
proof (induct rule: small_step_induct)
  case (Swap x s v1 v2)
  then have "\<exists>\<tau>. \<Gamma> \<turnstile> V x : Pty \<tau> \<tau>"
    by(auto simp: ctyping.intros) (metis V_ty)
  then obtain \<tau> where vty: "\<Gamma> \<turnstile> V x : Pty \<tau> \<tau>"
    by presburger
  then have "\<Gamma> \<turnstile> Fst (V x) : \<tau>" "\<Gamma> \<turnstile> Snd (V x) : \<tau>"
    using Fst_ty Snd_ty by auto
  then have spty: "\<Gamma> \<turnstile> Pair (Snd (V x)) (Fst (V x)) : Pty \<tau> \<tau>"
    by blast
  then show ?case by(auto simp: ctyping.intros) (metis spty ty.inject)
qed(auto simp: ctyping.intros)

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

theorem type_sound:
  "(c,s) \<rightarrow>* (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c' \<noteq> SKIP
   \<Longrightarrow> \<exists>cs''. (c',s') \<rightarrow> cs''"
apply(induction rule:star_induct)
apply (metis progress)
by (metis styping_preservation ctyping_preservation)

end


(* Title: thys/HaltingProblem_K_aux.thy
   Author: Franz Regensburger (FABR) 02/2022
 *)

subsubsection \<open>K0: A Variant of the Special Halting Problem K1\<close>

theory HaltingProblems_K_aux
  imports
    HaltingProblems_K_H

begin

(* -------------------------------------------------------------------------- *)

(*
declare adjust.simps[simp del]

declare seq_tm.simps [simp del]
declare shift.simps[simp del]
declare composable_tm.simps[simp del]
declare step.simps[simp del]
declare steps.simps[simp del]
*)

context hpk
begin

definition K0 :: "(nat list) set"
  where
     "K0 \<equiv> {nl. (\<exists>n. nl = [n] \<and> reaches_final (c2t n) [n]) }"

text\<open>Assuming the existence of a Turing Machine K0D0, which is able to decide the set K0,
 we derive a contradiction using the machine @{term "tm_semi_id_gt0"}.
 Thus, we show that the {\em Special Halting Problem K0} is not Turing decidable.
 The proof uses a diagonal argument.
\<close>

lemma existence_of_decider_K0D0_for_K0_imp_False:
  assumes "\<exists>K0D0'. (\<forall>nl.
          (nl \<in> K0 \<longrightarrow>TMC_yields_num_res K0D0' nl (0::nat))
       \<and>  (nl \<notin> K0 \<longrightarrow>TMC_yields_num_res K0D0' nl (1::nat) ))"
  shows False
proof -
  from assms have
    "\<exists>K0D0'. (\<forall>nl.
          (nl \<in> K0 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K0 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>) )"
    unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
    by (simp add: tape_of_nat_def)
  then obtain K0D0' where
    "(\<forall>nl.
          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>) )"
    by blast

(* first, create a composable version of the potentially non-composable machine K0D0' *)

  then have "composable_tm0 (mk_composable0 K0D0') \<and> (\<forall>nl.
          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 K0D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 K0D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>))"
    using Hoare_halt_tm_impl_Hoare_halt_mk_composable0 composable_tm0_mk_composable0 by blast

  then have "\<exists>K0D0. composable_tm0 K0D0 \<and> (\<forall>nl.
          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>))"
    by blast

  then obtain K0D0 where w_K0D0: "composable_tm0 K0D0 \<and> (\<forall>nl.
          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>))"
    by blast

  define tm_contra where "tm_contra = K0D0 |+| tm_semi_id_gt0"

(* second, we derive some theorems from our assumptions *)
  have c2t_comp_t2c_TM_eq_for_tm_contra: "c2t (t2c tm_contra) = tm_contra"
    by (auto simp add: c2t_comp_t2c_eq)

(* now, we derive the contradiction *)
  show False
  proof (cases "[t2c tm_contra] \<in> K0")
    case True
    from \<open>[t2c tm_contra] \<in> K0\<close> and w_K0D0 have
      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> K0D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>"
      by auto

    then have
      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> tm_contra \<up>"
      unfolding tm_contra_def

    proof (rule Hoare_plus_unhalt)
      from tm_semi_id_gt0_loops' show "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace> tm_semi_id_gt0 \<up>"
        using Hoare_unhalt_add_Bks_left_tape_L1 Hoare_unhalt_def assms
        by auto
    next
      from w_K0D0 show "composable_tm0 K0D0" by auto
    qed
    then have
      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> c2t (t2c tm_contra) \<up>"
      by (auto simp add: c2t_comp_t2c_TM_eq_for_tm_contra)

    then have "\<not>(reaches_final (c2t (t2c tm_contra)) [t2c tm_contra])"
      by (simp add: Hoare_unhalt_def Hoare_unhalt_impl_not_reaches_final)

    then have "[t2c tm_contra] \<notin> K0"
      by (auto simp add: K0_def)

    with  \<open>[t2c tm_contra] \<in> K0\<close> show False by auto
  next

    case False
    from \<open>[t2c tm_contra] \<notin> K0\<close> and w_K0D0 have
      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> K0D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
      by auto
    then have
      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> tm_contra \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
      unfolding tm_contra_def

    proof (rule Hoare_plus_halt)
      from tm_semi_id_gt0_halts''
      show "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace> tm_semi_id_gt0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
        by auto
    next
      from w_K0D0 show "composable_tm0 K0D0" by auto
    qed

    then have
      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> c2t (t2c tm_contra) \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
      by (auto simp add: c2t_comp_t2c_TM_eq_for_tm_contra)

    then have
      "reaches_final (c2t (t2c tm_contra)) [t2c tm_contra]"
      by (metis (mono_tags, lifting) Hoare_haltE reaches_final_iff)

    then have "[t2c tm_contra] \<in> K0"
      by (auto simp add: K0_def)

    with \<open>[t2c tm_contra] \<notin> K0\<close> show False by auto
  qed
qed

text\<open>Assuming the existence of a Turing Machine K0D1, which is able to decide the set K0,
 we derive a contradiction using the machine @{term "tm_semi_id_eq0"}.
 Thus, we show that the {\em Special Halting Problem K0} is not Turing decidable.
 The proof uses a diagonal argument.
\<close>

lemma existence_of_decider_K0D1_for_K0_imp_False:
  assumes "\<exists>K0D1'. (\<forall>nl.
          (nl \<in> K0 \<longrightarrow>TMC_yields_num_res K0D1' nl (1::nat))
       \<and>  (nl \<notin> K0 \<longrightarrow>TMC_yields_num_res K0D1' nl (0::nat) ))"
  shows False
proof -
  from assms have
    "\<exists>K0D1'. (\<forall>nl.
          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>))"
  unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
  by (simp add: tape_of_nat_def)
  then obtain K0D1' where
     "(\<forall>nl.
          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>))"
    by blast

(* first, create a composable version of the potentially non-composable machine K0D1' *)

  then have "composable_tm0 (mk_composable0 K0D1') \<and> (\<forall>nl.
          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 K0D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 K0D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>))"
    using Hoare_halt_tm_impl_Hoare_halt_mk_composable0 composable_tm0_mk_composable0 by blast

  then have "\<exists>K0D1. composable_tm0 K0D1 \<and> (\<forall>nl.
          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D1 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D1 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>))"
    by blast

  then obtain K0D1 where w_K0D1: "composable_tm0 K0D1 \<and> (\<forall>nl.
          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D1 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D1 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>))"
    by blast

  define tm_contra where "tm_contra = K0D1 |+| tm_semi_id_eq0"

(* second, we derive some theorems from our assumptions *)
  have c2t_comp_t2c_TM_eq_for_tm_contra: "c2t (t2c tm_contra) = tm_contra"
    by (auto simp add: c2t_comp_t2c_eq)

(* now, we derive the contradiction *)
  show False
  proof (cases "[t2c tm_contra] \<in> K0")
    case True
    from \<open>[t2c tm_contra] \<in> K0\<close> and w_K0D1 have
      "\<lbrace>\<lambda>tap.\<exists>z. tap = ([], <[t2c tm_contra]>)\<rbrace> K0D1 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
      by auto

    then have
      "\<lbrace>\<lambda>tap.\<exists>z. tap = ([], <[t2c tm_contra]>)\<rbrace> tm_contra \<up>"
      unfolding tm_contra_def
    proof (rule Hoare_plus_unhalt)
      from tm_semi_id_eq0_loops' show "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace> tm_semi_id_eq0 \<up>"
        using Hoare_unhalt_add_Bks_left_tape_L1 Hoare_unhalt_def assms
        by auto
    next
      from w_K0D1 show "composable_tm0 K0D1" by auto
    qed

    then have
      "\<lbrace>\<lambda>tap.\<exists>z. tap = ([], <[t2c tm_contra]>)\<rbrace> c2t (t2c tm_contra) \<up>"
      by (auto simp add: c2t_comp_t2c_TM_eq_for_tm_contra)

    then have "\<not>(reaches_final (c2t (t2c tm_contra)) [t2c tm_contra])"
      by (simp add: Hoare_unhalt_def Hoare_unhalt_impl_not_reaches_final)

    then have "[t2c tm_contra] \<notin> K0"
      by (auto simp add: K0_def)

    with  \<open>[t2c tm_contra] \<in> K0\<close> show False by auto
  next
    case False
    from \<open>[t2c tm_contra] \<notin> K0\<close> and w_K0D1 have
      "\<lbrace>\<lambda>tap.\<exists>z. tap = ([], <[t2c tm_contra]>)\<rbrace> K0D1 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>"
      by auto
    then have
      "\<lbrace>\<lambda>tap.\<exists>z. tap = ([], <[t2c tm_contra]>)\<rbrace> tm_contra \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>"
      unfolding tm_contra_def
    proof (rule Hoare_plus_halt)
      from tm_semi_id_eq0_halts'' show "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace> tm_semi_id_eq0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>"
        by auto
    next
      from w_K0D1 show "composable_tm0 K0D1" by auto
    qed

    then have
      "\<lbrace>\<lambda>tap.\<exists>z. tap = ([], <[t2c tm_contra]>)\<rbrace> c2t (t2c tm_contra) \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>"
      by (auto simp add: c2t_comp_t2c_TM_eq_for_tm_contra)

    then have
      "reaches_final (c2t (t2c tm_contra)) [t2c tm_contra]"
      by (metis (mono_tags, lifting) Hoare_halt_def reaches_final_iff)

    then have "[t2c tm_contra] \<in> K0"
      by (auto simp add: K0_def)

    with \<open>[t2c tm_contra] \<notin> K0\<close> show False by auto
  qed
qed

corollary not_Turing_decidable_K0: "\<not>(turing_decidable K0)"
proof
  assume "turing_decidable K0"
  then have "(\<exists>D. (\<forall>nl.
          (nl \<in> K0 \<longrightarrow>TMC_yields_num_res D nl (1::nat))
       \<and>  (nl \<notin> K0 \<longrightarrow>TMC_yields_num_res D nl (0::nat) )))"
    by (auto simp add: turing_decidable_unfolded_into_TMC_yields_conditions tape_of_nat_def)
  with existence_of_decider_K0D1_for_K0_imp_False show False
    by blast
qed

end (* locale hpk *)

end


(*  Title:      HOL/Hoare/Pointer_ExamplesAbort.thy
    Author:     Tobias Nipkow
    Copyright   2002 TUM

Examples of verifications of pointer programs
*)

theory Pointer_ExamplesAbort imports HeapSyntaxAbort begin

section "Verifications"

subsection "List reversal"

text "Interestingly, this proof is the same as for the unguarded program:"

lemma "VARS tl p q r
  {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                 rev ps @ qs = rev Ps @ Qs}
  DO r := p; (p \<noteq> Null \<rightarrow> p := p^.tl); r^.tl := q; q := r OD
  {List tl q (rev Ps @ Qs)}"
apply vcg_simp
  apply fastforce
 apply(fastforce intro:notin_List_update[THEN iffD2])
apply fastforce
done

end


(* Title:     Quantum-Semantics/QSemantics.thy
   Author:    David Sanan, Nanyang Technological University
   Copyright   2020
   License:     BSD
*)

theory QSemanticsBig
  imports QSyntax
begin

subsection \<open>Syntax\<close>

text \<open>Semantics for quantum programs\<close>

(* m = partial_state2.ptensor_mat (dims_heap \<vv>) (q \<sigma>) ((Q_domain \<vv>)-(q \<sigma>)) (M::complex mat) (1\<^sub>m (card ((Q_domain \<vv>) - (q \<sigma>))))*)
(* abbreviation "tensor_vec \<equiv> partial_state2.ptensor_vec" *)

definition
  unit_vecl :: "nat \<Rightarrow> nat \<Rightarrow> complex list"
  where "unit_vecl n i = list_of_vec (unit_vec n i)"

definition matrix_sep :: "nat set \<Rightarrow> qstate \<Rightarrow> complex mat \<Rightarrow> qstate"
  where "matrix_sep sep_vars q M \<equiv>
           let qs = snd q in
           let var_d = QState_vars qs in
           let var_r = var_d - sep_vars in
           let v = QState_vector qs in
           let m = partial_state2.ptensor_mat sep_vars var_r
                                        (M::complex mat) (1\<^sub>m (2^(card var_r)))  in
             (fst q, QState (var_d, list_of_vec (m *\<^sub>v v)))
        "

(* definition measure_vars1::"nat \<Rightarrow>  nat set \<Rightarrow> qstate  \<Rightarrow> (real \<times> qstate)"
  where "measure_vars1 k  sep_vars q \<equiv>
   let qs = snd q in
   let vars_dom = QState_vars qs in
    let v =   QState_vector qs in
    let vars= (vars_dom - sep_vars) in
    let mk = partial_state2.ptensor_mat  vars_dom vars (1\<^sub>k (2^(card vars_dom))) (1\<^sub>m (2^(card vars))) in
    let qn' =  mk  *\<^sub>v v in
    let \<delta>k =  Re (((mat_adjoint (mat_of_rows (dim_vec v) [v]) *\<^sub>v qn') $ 0) div vec_norm qn') in
    let qnprod = list_of_vec (((sqrt \<delta>k)::complex) \<cdot>\<^sub>v qn') in
       (\<delta>k, (fst q, QState (vars_dom, qnprod)))" *)

definition measure_vars::"nat \<Rightarrow>  nat set \<Rightarrow> qstate  \<Rightarrow> (real \<times> qstate)"
  where "measure_vars k  sep_vars q \<equiv>
   let qs = snd q in
   let vars_dom = QState_vars qs in
    let v =   QState_vector qs in
    let vars= (vars_dom - sep_vars) in
    let mk = partial_state2.ptensor_mat  sep_vars vars (1\<^sub>k (2^(card sep_vars))) (1\<^sub>m (2^(card vars))) in
    let v' =  mk  *\<^sub>v v in
    let \<delta>k =  Re ((vec_norm v')^2 div (vec_norm v)^2) in
    let qnprod = list_of_vec (((sqrt \<delta>k)::complex) \<cdot>\<^sub>v v') in
       (\<delta>k, (fst q, QState (vars_dom, qnprod)))"

context vars
begin

inductive QExec::"('v, 's) com \<Rightarrow> 's XQState \<Rightarrow> 's XQState \<Rightarrow> bool"
  ("\<turnstile> \<langle>_,_\<rangle> \<Rightarrow> _"  [20,98,98] 89)
  where
  Skip : "\<turnstile>  \<langle>Skip, Normal \<sigma>\<rangle> \<Rightarrow> Normal \<sigma>"
\<comment>\<open>SMod  modifies the stack of non-qubits variables \<sigma> with f \<sigma>, where f is a
  function modifying the stack\<close>
 | StackMod: "\<turnstile> \<langle>SMod f, Normal (\<delta>,\<sigma>,\<Q>)\<rangle> \<Rightarrow>  Normal (\<delta>,f \<sigma>,\<Q>)"

\<comment>\<open>QMod modifies the set of qubits of the Quantum State given by q \<sigma> with the
  transformation matrix M, any qubit not included in q \<sigma> remains the same\<close>

 | QMod:"(q (\<sigma>,\<vv>)) \<subseteq> (QState_vars \<qq>) \<Longrightarrow>
         \<qq>' = matrix_sep (q (\<sigma>,\<vv>)) (\<vv>,\<qq>) M \<Longrightarrow>
         \<turnstile> \<langle>QMod M q, Normal (\<delta>,\<sigma>,(\<vv>,\<qq>))\<rangle> \<Rightarrow> Normal (\<delta>, \<sigma>, \<qq>')"

\<comment>\<open>QMod fails if the set of qubits to be modified is not included in the quantum state\<close>
 | QMod_F:"\<not> ((q (\<sigma>,\<vv>)) \<subseteq> (QState_vars \<qq>)) \<Longrightarrow>
          \<turnstile> \<langle>QMod M q, Normal (\<delta>,\<sigma>,(\<vv>,\<qq>))\<rangle> \<Rightarrow> Fault"

\<comment>\<open>Alloc takes a normal variable "q" representing the variable where the index to the qubits is store
   an function e from the state \<sigma> to a natural number representing the number of qubits to allocate
  and an initialization value for the allocated qubits

  We will require that a program is well formed, meaning that the types are correct.
  A call to Alloc is well formed if the type of q is a natural number\<close>

 | Alloc:"q' \<notin> (dom_q_vars \<vv>) \<Longrightarrow> q'_addr \<in> new_q_addr e (\<delta>,\<sigma>,(\<vv>,\<qq>)) \<Longrightarrow> e \<sigma> \<noteq> 0 \<Longrightarrow>
          \<vv>' = \<vv>(q' := q'_addr)  \<Longrightarrow> length (v \<sigma>) = (e \<sigma>) \<Longrightarrow> \<sigma>' = set_value \<sigma> q (from_nat q') \<Longrightarrow>
          \<turnstile> \<langle>Alloc q e v, Normal (\<delta>,\<sigma>,(\<vv>,\<qq>))\<rangle> \<Rightarrow> Normal (\<delta>, \<sigma>',(\<vv>',\<qq> + QState (q'_addr,(v \<sigma>)) ))"

\<comment>\<open>Alloc will fail if the length of the initial value is not equal to the number of qubits allocated \<close>

 | Alloc_F:"length (v \<sigma>) \<noteq> (e \<sigma>) \<or> e \<sigma> = 0 \<Longrightarrow>
          \<turnstile> \<langle>Alloc q e v, Normal (\<delta>,\<sigma>,(\<vv>,\<qq>))\<rangle> \<Rightarrow> Fault"

\<comment>\<open>the conditional, while, and seq statements follow the standard definitions\<close>

 | CondTrue:"\<sigma>\<in>b \<Longrightarrow>  \<turnstile> \<langle>c1, Normal (\<delta>,\<sigma>,\<Q>)\<rangle> \<Rightarrow> \<sigma>' \<Longrightarrow> \<turnstile> \<langle>IF b c1 c2, Normal  (\<delta>,\<sigma>,\<Q>)\<rangle> \<Rightarrow> \<sigma>'"

 | CondFalse:"\<sigma>\<notin>b  \<Longrightarrow>  \<turnstile> \<langle>c2, Normal (\<delta>,\<sigma>,\<Q>)\<rangle> \<Rightarrow> \<sigma>' \<Longrightarrow>
           \<turnstile> \<langle>IF b c1 c2, Normal (\<delta>,\<sigma>,\<Q>)\<rangle> \<Rightarrow> \<sigma>'"

 | WhileTrue: "\<sigma>\<in>b \<Longrightarrow> \<turnstile> \<langle>c, Normal (\<delta>,\<sigma>,\<Q>)\<rangle> \<Rightarrow> \<sigma>' \<Longrightarrow> \<turnstile> \<langle>While b c,\<sigma>'\<rangle> \<Rightarrow>  \<sigma>'' \<Longrightarrow>
                \<turnstile> \<langle>While b c,Normal (\<delta>,\<sigma>,\<Q>)\<rangle> \<Rightarrow> \<sigma>''"

 | WhileFalse: "\<sigma>\<notin>b \<Longrightarrow>
                 \<turnstile> \<langle>While b c,Normal  (\<delta>,\<sigma>,\<Q>)\<rangle> \<Rightarrow> Normal  (\<delta>,\<sigma>,\<Q>)"

 | Seq:"\<lbrakk>\<turnstile> \<langle>C1, Normal \<sigma>\<rangle> \<Rightarrow> \<sigma>'; \<turnstile> \<langle>C2, \<sigma>'\<rangle> \<Rightarrow> \<sigma>'' \<rbrakk> \<Longrightarrow> \<turnstile> \<langle>Seq C1 C2, Normal \<sigma>\<rangle> \<Rightarrow> \<sigma>''"

\<comment>\<open>Dispose takes an expression from the stack to a natural number and removes those qubits
  from the quantum state if they are not entangled with the rest of qubits in the current
  Quantum state. The entanglement condition is that it is possible to find a vector \<qq>1 such that
  \<qq> =  \<qq>' +  \<qq>''\<close>

 | Dispose: "\<vv> (q \<sigma>) \<noteq> {} \<Longrightarrow> \<vv>' = \<vv>((q \<sigma>):={}) \<Longrightarrow> \<qq>' ## \<qq>''  \<Longrightarrow>
            \<vv> (q \<sigma>) = QState_vars \<qq>'' \<Longrightarrow> \<qq> =   \<qq>' +  \<qq>'' \<Longrightarrow>
            n = vec_norm (QState_vector \<qq>'') \<Longrightarrow>
             \<turnstile> \<langle>Dispose q, Normal (\<delta>,\<sigma>,(\<vv>,\<qq>))\<rangle> \<Rightarrow> Normal (\<delta>,\<sigma>,(\<vv>',n \<cdot>\<^sub>q \<qq>'))"

\<comment>\<open>Dispose dispose will fail if it is not possible to find such states \<qq>',  \<qq>''\<close>

 | Dispose_F: "\<nexists>\<qq>' \<qq>''. \<vv> (q \<sigma>) \<noteq> {} \<and> \<vv> (q \<sigma>) = QState_vars \<qq>'' \<and>
               \<qq> =   \<qq>' +  \<qq>'' \<and> \<qq>' ## \<qq>'' \<Longrightarrow>
               \<turnstile> \<langle>Dispose q, Normal (\<delta>,\<sigma>,(\<vv>,\<qq>))\<rangle> \<Rightarrow> Fault"

\<comment>\<open>Measure measures the value of the set of qubits given by q \<sigma> and it stores the result in
  the stack variable v. Similar to allocate, we will require that the construct is well formed
 and that the type of v is a real number\<close>

 | Measure: "q (\<sigma>,\<vv>) = (QState_vars \<qq>1) \<Longrightarrow> k \<in> {0.. 2^(card (q (\<sigma>,\<vv>)))} \<Longrightarrow>
            (\<delta>k, (\<vv>',\<qq>')) = measure_vars k (q (\<sigma>,\<vv>)) (\<vv>,\<qq>) \<Longrightarrow> \<qq> =   \<qq>1 +  \<qq>2 \<and> \<qq>1 ## \<qq>2 \<Longrightarrow>
            \<delta>k > 0 \<Longrightarrow> \<delta>' = \<delta> * \<delta>k \<Longrightarrow> \<sigma>' = set_value \<sigma> v (from_nat k) \<Longrightarrow>
            \<turnstile> \<langle>Measure v q, Normal (\<delta>,\<sigma>,(\<vv>,\<qq>))\<rangle> \<Rightarrow> Normal (\<delta>',\<sigma>',(\<vv>',\<qq>'))"

\<comment>\<open>Since Measure access to the values of the qubits given by q \<sigma> as QMod,
  Measure will similarly fail if the set of qubits to be mesured does not
  belong to the set of allocated qubits\<close>

 | Measure_F: "\<not> (q (\<sigma>,\<vv>) \<subseteq> (QState_vars \<qq>)) \<Longrightarrow>
              \<turnstile> \<langle>Measure v q, Normal (\<delta>,\<sigma>,(\<vv>,\<qq>))\<rangle> \<Rightarrow> Fault"

| Fault_Prop:"\<turnstile> \<langle>C, Fault\<rangle> \<Rightarrow> Fault"

inductive_cases QExec_elim_cases [cases set]:
 "\<turnstile>\<langle>c,Fault\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>Skip,s\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>SMod f,s\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>QMod m q,s\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>Seq c1 c2,s\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>While b c,s\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>IF b c1 c2,s\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>Measure v q,s\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>Alloc v q e,s\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>Dispose q,s\<rangle> \<Rightarrow>  t"

inductive_cases QExec_Normal_elim_cases [cases set]:
 "\<turnstile>\<langle>c,Fault\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>Skip,Normal s\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>SMod f,Normal s\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>QMod m q,Normal s\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>Seq c1 c2,Normal s\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>While b c1,Normal s\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>IF b c1 c2,Normal s\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>Measure v q,Normal s\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>Alloc v q e,Normal s\<rangle> \<Rightarrow>  t"
  "\<turnstile>\<langle>Dispose q,Normal s\<rangle> \<Rightarrow>  t"

primrec modify_locals :: "('v, 's) com  \<Rightarrow> 'v set" where
  "modify_locals  Skip = {}"
| "modify_locals (SMod f) = {v. modify_v f v = True}"
| "modify_locals (QMod _ _) = {}"
| "modify_locals (IF b c1 c2) = modify_locals c1 \<union> modify_locals c2"
| "modify_locals (While b c) = modify_locals c"
| "modify_locals (Seq c1 c2) = modify_locals c1 \<union> modify_locals c2"
| "modify_locals (Measure v e) = {v}"
| "modify_locals (Alloc v e val) = {v}"
| "modify_locals (Dispose e) = {}"

thm QExec_Normal_elim_cases

lemma exec_Fault_end: assumes exec: "\<turnstile>\<langle>c,s\<rangle> \<Rightarrow>  t" and s: "s=Fault"
  shows "t=Fault"
using exec s by (induct) auto

end

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section \<open>\isaheader{Fifo Queue by Pair of Lists}\<close>
theory Fifo
imports
  "../gen_algo/ListGA"
  "../tools/Record_Intf"
  "../tools/Locale_Code"
begin
text_raw \<open>\label{thy:Fifo}\<close>

(* TODO: Move to Misc *)
lemma rev_tl_rev: "rev (tl (rev l)) = butlast l"
  by (induct l) auto

(*@impl List
  @type 'a fifo
  @abbrv fifo
  Fifo-Queues implemented by two stacks.
*)

text \<open>
  A fifo-queue is implemented by a pair of two lists (stacks).
  New elements are pushed on the first stack, and elements are popped from
  the second stack. If the second stack is empty, the first stack is reversed
  and replaces the second stack.

  If list reversal is implemented efficiently (what is the case in Isabelle/HOL,
  cf @{thm [source] List.rev_conv_fold})
  the amortized time per buffer operation is constant.

  Moreover, this fifo implementation also supports efficient push and pop operations.
\<close>

subsection \<open>Definitions\<close>
type_synonym 'a fifo = "'a list \<times> 'a list"

text "Abstraction of the fifo to a list. The next element to be got is at
      the head of the list, and new elements are appended at the end of the
      list"
definition fifo_\<alpha> :: "'a fifo \<Rightarrow> 'a list"
  where "fifo_\<alpha> F == snd F @ rev (fst F)"

text "This fifo implementation has no invariants, any pair of lists is a
  valid fifo"
definition [simp, intro!]: "fifo_invar x = True"

  \<comment> \<open>The empty fifo\<close>
definition fifo_empty :: "unit \<Rightarrow> 'a fifo"
  where "fifo_empty == \<lambda>_::unit. ([],[])"

  \<comment> \<open>True, iff the fifo is empty\<close>
definition fifo_isEmpty :: "'a fifo \<Rightarrow> bool" where "fifo_isEmpty F == F=([],[])"

definition fifo_size :: "'a fifo \<Rightarrow> nat" where
  "fifo_size F \<equiv> length (fst F) + length (snd F)"

  \<comment> \<open>Add an element to the fifo\<close>
definition fifo_appendr :: "'a \<Rightarrow> 'a fifo \<Rightarrow> 'a fifo"
  where "fifo_appendr a F == (a#fst F, snd F)"

definition fifo_appendl :: "'a \<Rightarrow> 'a fifo \<Rightarrow> 'a fifo"
  where "fifo_appendl x F == case F of (e,d) \<Rightarrow> (e,x#d)"

\<comment> \<open>Get an element from the fifo\<close>
definition fifo_remover :: "'a fifo \<Rightarrow> ('a fifo \<times> 'a)" where
  "fifo_remover F ==
    case fst F of
      (a#l) \<Rightarrow> ((l,snd F),a) |
      [] \<Rightarrow> let rp=rev (snd F) in
        ((tl rp,[]),hd rp)"

definition fifo_removel :: "'a fifo \<Rightarrow> ('a \<times> 'a fifo)" where
  "fifo_removel F ==
    case snd F of
      (a#l) \<Rightarrow> (a, (fst F, l)) |
      [] \<Rightarrow> let rp=rev (fst F) in
        (hd rp, ([], tl rp))
"

definition fifo_leftmost :: "'a fifo \<Rightarrow> 'a" where
  "fifo_leftmost F \<equiv> case F of (_,x#_) \<Rightarrow> x | (l,[]) \<Rightarrow> last l"

definition fifo_rightmost :: "'a fifo \<Rightarrow> 'a" where
  "fifo_rightmost F \<equiv> case F of (x#_,_) \<Rightarrow> x | ([],l) \<Rightarrow> last l"

definition "fifo_iteratei F \<equiv> foldli (fifo_\<alpha> F)"
definition "fifo_rev_iteratei F \<equiv> foldri (fifo_\<alpha> F)"

definition "fifo_get F i \<equiv>
  let
    l2 = length (snd F)
  in
    if i < l2 then
      snd F!i
    else
      (fst F)!(length (fst F) - Suc (i - l2))
  "

definition "fifo_set F i a \<equiv> case F of (f1,f2) \<Rightarrow>
  let
    l2 = length f2
  in
    if i < l2 then
      (f1,f2[i:=a])
    else
      (f1[length (fst F) - Suc (i - l2) := a],f2)"

subsection "Correctness"

lemma fifo_empty_impl: "list_empty fifo_\<alpha> fifo_invar fifo_empty"
  apply (unfold_locales)
  by (auto simp add: fifo_\<alpha>_def fifo_empty_def)

lemma fifo_isEmpty_impl: "list_isEmpty fifo_\<alpha> fifo_invar fifo_isEmpty"
  apply (unfold_locales)
  by (case_tac s) (auto simp add: fifo_isEmpty_def fifo_\<alpha>_def)

lemma fifo_size_impl: "list_size fifo_\<alpha> fifo_invar fifo_size"
  apply unfold_locales
  by (auto simp add: fifo_size_def fifo_\<alpha>_def)

lemma fifo_appendr_impl: "list_appendr fifo_\<alpha> fifo_invar fifo_appendr"
  apply (unfold_locales)
  by (auto simp add: fifo_appendr_def fifo_\<alpha>_def)

lemma fifo_appendl_impl: "list_appendl fifo_\<alpha> fifo_invar fifo_appendl"
  apply (unfold_locales)
  by (auto simp add: fifo_appendl_def fifo_\<alpha>_def)

lemma fifo_removel_impl: "list_removel fifo_\<alpha> fifo_invar fifo_removel"
  apply (unfold_locales)
  apply (case_tac s)
  apply (case_tac b)
  apply (auto simp add: fifo_removel_def fifo_\<alpha>_def Let_def) [2]
  apply (case_tac s)
  apply (case_tac "b")
  apply (auto simp add: fifo_removel_def fifo_\<alpha>_def Let_def)
  done

lemma fifo_remover_impl: "list_remover fifo_\<alpha> fifo_invar fifo_remover"
  apply (unfold_locales)
  unfolding fifo_remover_def fifo_\<alpha>_def Let_def
  by (auto split: list.split simp: hd_rev rev_tl_rev butlast_append)

lemma fifo_leftmost_impl: "list_leftmost fifo_\<alpha> fifo_invar fifo_leftmost"
  apply unfold_locales
  by (auto simp: fifo_leftmost_def fifo_\<alpha>_def hd_rev split: list.split)

lemma fifo_rightmost_impl: "list_rightmost fifo_\<alpha> fifo_invar fifo_rightmost"
  apply unfold_locales
  by (auto simp: fifo_rightmost_def fifo_\<alpha>_def hd_rev split: list.split)

lemma fifo_get_impl: "list_get fifo_\<alpha> fifo_invar fifo_get"
  apply unfold_locales
  apply (auto simp: fifo_\<alpha>_def fifo_get_def Let_def nth_append rev_nth)
  done

lemma fifo_set_impl: "list_set fifo_\<alpha> fifo_invar fifo_set"
  apply unfold_locales
  apply (auto simp: fifo_\<alpha>_def fifo_set_def Let_def list_update_append
    rev_update)
  done

definition [icf_rec_def]: "fifo_ops \<equiv> \<lparr>
  list_op_\<alpha> = fifo_\<alpha>,
  list_op_invar = fifo_invar,
  list_op_empty = fifo_empty,
  list_op_isEmpty = fifo_isEmpty,
  list_op_size = fifo_size,
  list_op_appendl = fifo_appendl,
  list_op_removel = fifo_removel,
  list_op_leftmost = fifo_leftmost,
  list_op_appendr = fifo_appendr,
  list_op_remover = fifo_remover,
  list_op_rightmost = fifo_rightmost,
  list_op_get = fifo_get,
  list_op_set = fifo_set
  \<rparr>"

setup Locale_Code.open_block
interpretation fifo: StdList fifo_ops
  apply (rule StdList.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule
    fifo_empty_impl
    fifo_isEmpty_impl
    fifo_size_impl
    fifo_appendl_impl
    fifo_removel_impl
    fifo_leftmost_impl
    fifo_appendr_impl
    fifo_remover_impl
    fifo_rightmost_impl
    fifo_get_impl
    fifo_set_impl)+
  done
interpretation fifo: StdList_no_invar fifo_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block
setup \<open>ICF_Tools.revert_abbrevs "fifo"\<close>

definition test_codegen where "test_codegen \<equiv>
  (
    fifo.empty,
    fifo.isEmpty,
    fifo.size,
    fifo.appendl,
    fifo.removel,
    fifo.leftmost,
    fifo.appendr,
    fifo.remover,
    fifo.rightmost,
    fifo.get,
    fifo.set,
    fifo.iteratei,
    fifo.rev_iteratei
  )"

export_code test_codegen checking SML

end


(*  Title:      ZF/Resid/Substitution.thy
    Author:     Ole Rasmussen, University of Cambridge
*)

theory Substitution imports Redex begin

(** The clumsy _aux functions are required because other arguments vary
    in the recursive calls ***)

consts
  lift_aux      :: "i=>i"
primrec
  "lift_aux(Var(i)) = (\<lambda>k \<in> nat. if i<k then Var(i) else Var(succ(i)))"

  "lift_aux(Fun(t)) = (\<lambda>k \<in> nat. Fun(lift_aux(t) ` succ(k)))"

  "lift_aux(App(b,f,a)) = (\<lambda>k \<in> nat. App(b, lift_aux(f)`k, lift_aux(a)`k))"

definition
  lift_rec      :: "[i,i]=> i"  where
    "lift_rec(r,k) == lift_aux(r)`k"

abbreviation
  lift :: "i=>i" where
  "lift(r) == lift_rec(r,0)"

consts
  subst_aux     :: "i=>i"
primrec
  "subst_aux(Var(i)) =
     (\<lambda>r \<in> redexes. \<lambda>k \<in> nat. if k<i then Var(i #- 1)
                                else if k=i then r else Var(i))"
  "subst_aux(Fun(t)) =
     (\<lambda>r \<in> redexes. \<lambda>k \<in> nat. Fun(subst_aux(t) ` lift(r) ` succ(k)))"

  "subst_aux(App(b,f,a)) =
     (\<lambda>r \<in> redexes. \<lambda>k \<in> nat. App(b, subst_aux(f)`r`k, subst_aux(a)`r`k))"

definition
  subst_rec     :: "[i,i,i]=> i"        (**NOTE THE ARGUMENT ORDER BELOW**)  where
    "subst_rec(u,r,k) == subst_aux(r)`u`k"

abbreviation
  subst :: "[i,i]=>i"  (infixl "'/" 70)  where
  "u/v == subst_rec(u,v,0)"

(* ------------------------------------------------------------------------- *)
(*   Arithmetic extensions                                                   *)
(* ------------------------------------------------------------------------- *)

lemma gt_not_eq: "p < n ==> n\<noteq>p"
by blast

lemma succ_pred [rule_format, simp]: "j \<in> nat ==> i < j \<longrightarrow> succ(j #- 1) = j"
by (induct_tac "j", auto)

lemma lt_pred: "[|succ(x)<n; n \<in> nat|] ==> x < n #- 1 "
apply (rule succ_leE)
apply (simp add: succ_pred)
done

lemma gt_pred: "[|n < succ(x); p<n; n \<in> nat|] ==> n #- 1 < x "
apply (rule succ_leE)
apply (simp add: succ_pred)
done

declare not_lt_iff_le [simp] if_P [simp] if_not_P [simp]

(* ------------------------------------------------------------------------- *)
(*     lift_rec equality rules                                               *)
(* ------------------------------------------------------------------------- *)
lemma lift_rec_Var:
     "n \<in> nat ==> lift_rec(Var(i),n) = (if i<n then Var(i) else Var(succ(i)))"
by (simp add: lift_rec_def)

lemma lift_rec_le [simp]:
     "[|i \<in> nat; k\<le>i|] ==> lift_rec(Var(i),k) = Var(succ(i))"
by (simp add: lift_rec_def le_in_nat)

lemma lift_rec_gt [simp]: "[| k \<in> nat; i<k |] ==> lift_rec(Var(i),k) = Var(i)"
by (simp add: lift_rec_def)

lemma lift_rec_Fun [simp]:
     "k \<in> nat ==> lift_rec(Fun(t),k) = Fun(lift_rec(t,succ(k)))"
by (simp add: lift_rec_def)

lemma lift_rec_App [simp]:
     "k \<in> nat ==> lift_rec(App(b,f,a),k) = App(b,lift_rec(f,k),lift_rec(a,k))"
by (simp add: lift_rec_def)

(* ------------------------------------------------------------------------- *)
(*    substitution quality rules                                             *)
(* ------------------------------------------------------------------------- *)

lemma subst_Var:
     "[|k \<in> nat; u \<in> redexes|]
      ==> subst_rec(u,Var(i),k) =
          (if k<i then Var(i #- 1) else if k=i then u else Var(i))"
by (simp add: subst_rec_def gt_not_eq leI)

lemma subst_eq [simp]:
     "[|n \<in> nat; u \<in> redexes|] ==> subst_rec(u,Var(n),n) = u"
by (simp add: subst_rec_def)

lemma subst_gt [simp]:
     "[|u \<in> redexes; p \<in> nat; p<n|] ==> subst_rec(u,Var(n),p) = Var(n #- 1)"
by (simp add: subst_rec_def)

lemma subst_lt [simp]:
     "[|u \<in> redexes; p \<in> nat; n<p|] ==> subst_rec(u,Var(n),p) = Var(n)"
by (simp add: subst_rec_def gt_not_eq leI lt_nat_in_nat)

lemma subst_Fun [simp]:
     "[|p \<in> nat; u \<in> redexes|]
      ==> subst_rec(u,Fun(t),p) = Fun(subst_rec(lift(u),t,succ(p))) "
by (simp add: subst_rec_def)

lemma subst_App [simp]:
     "[|p \<in> nat; u \<in> redexes|]
      ==> subst_rec(u,App(b,f,a),p) = App(b,subst_rec(u,f,p),subst_rec(u,a,p))"
by (simp add: subst_rec_def)

lemma lift_rec_type [rule_format, simp]:
     "u \<in> redexes ==> \<forall>k \<in> nat. lift_rec(u,k) \<in> redexes"
apply (erule redexes.induct)
apply (simp_all add: lift_rec_Var lift_rec_Fun lift_rec_App)
done

lemma subst_type [rule_format, simp]:
     "v \<in> redexes ==>  \<forall>n \<in> nat. \<forall>u \<in> redexes. subst_rec(u,v,n) \<in> redexes"
apply (erule redexes.induct)
apply (simp_all add: subst_Var lift_rec_type)
done

(* ------------------------------------------------------------------------- *)
(*    lift and  substitution proofs                                          *)
(* ------------------------------------------------------------------------- *)

(*The i\<in>nat is redundant*)
lemma lift_lift_rec [rule_format]:
     "u \<in> redexes
      ==> \<forall>n \<in> nat. \<forall>i \<in> nat. i\<le>n \<longrightarrow>
           (lift_rec(lift_rec(u,i),succ(n)) = lift_rec(lift_rec(u,n),i))"
apply (erule redexes.induct, auto)
apply (case_tac "n < i")
apply (frule lt_trans2, assumption)
apply (simp_all add: lift_rec_Var leI)
done

lemma lift_lift:
     "[|u \<in> redexes; n \<in> nat|]
      ==> lift_rec(lift(u),succ(n)) = lift(lift_rec(u,n))"
by (simp add: lift_lift_rec)

lemma lt_not_m1_lt: "\<lbrakk>m < n; n \<in> nat; m \<in> nat\<rbrakk>\<Longrightarrow> ~ n #- 1 < m"
by (erule natE, auto)

lemma lift_rec_subst_rec [rule_format]:
     "v \<in> redexes ==>
       \<forall>n \<in> nat. \<forall>m \<in> nat. \<forall>u \<in> redexes. n\<le>m\<longrightarrow>
          lift_rec(subst_rec(u,v,n),m) =
               subst_rec(lift_rec(u,m),lift_rec(v,succ(m)),n)"
apply (erule redexes.induct, simp_all (no_asm_simp) add: lift_lift)
apply safe
apply (rename_tac n n' m u)
apply (case_tac "n < n'")
 apply (frule_tac j = n' in lt_trans2, assumption)
 apply (simp add: leI, simp)
apply (erule_tac j=n in leE)
apply (auto simp add: lift_rec_Var subst_Var leI lt_not_m1_lt)
done

lemma lift_subst:
     "[|v \<in> redexes; u \<in> redexes; n \<in> nat|]
      ==> lift_rec(u/v,n) = lift_rec(u,n)/lift_rec(v,succ(n))"
by (simp add: lift_rec_subst_rec)

lemma lift_rec_subst_rec_lt [rule_format]:
     "v \<in> redexes ==>
       \<forall>n \<in> nat. \<forall>m \<in> nat. \<forall>u \<in> redexes. m\<le>n\<longrightarrow>
          lift_rec(subst_rec(u,v,n),m) =
               subst_rec(lift_rec(u,m),lift_rec(v,m),succ(n))"
apply (erule redexes.induct, simp_all (no_asm_simp) add: lift_lift)
apply safe
apply (rename_tac n n' m u)
apply (case_tac "n < n'")
apply (case_tac "n < m")
apply (simp_all add: leI)
apply (erule_tac i=n' in leE)
apply (frule lt_trans1, assumption)
apply (simp_all add: succ_pred leI gt_pred)
done

lemma subst_rec_lift_rec [rule_format]:
     "u \<in> redexes ==>
        \<forall>n \<in> nat. \<forall>v \<in> redexes. subst_rec(v,lift_rec(u,n),n) = u"
apply (erule redexes.induct, auto)
apply (case_tac "n < na", auto)
done

lemma subst_rec_subst_rec [rule_format]:
     "v \<in> redexes ==>
        \<forall>m \<in> nat. \<forall>n \<in> nat. \<forall>u \<in> redexes. \<forall>w \<in> redexes. m\<le>n \<longrightarrow>
          subst_rec(subst_rec(w,u,n),subst_rec(lift_rec(w,m),v,succ(n)),m) =
          subst_rec(w,subst_rec(u,v,m),n)"
apply (erule redexes.induct)
apply (simp_all add: lift_lift [symmetric] lift_rec_subst_rec_lt, safe)
apply (rename_tac n' u w)
apply (case_tac "n \<le> succ(n') ")
 apply (erule_tac i = n in leE)
 apply (simp_all add: succ_pred subst_rec_lift_rec leI)
 apply (case_tac "n < m")
  apply (frule lt_trans2, assumption, simp add: gt_pred)
 apply simp
 apply (erule_tac j = n in leE, simp add: gt_pred)
 apply (simp add: subst_rec_lift_rec)
(*final case*)
apply (frule nat_into_Ord [THEN le_refl, THEN lt_trans], assumption)
apply (erule leE)
 apply (frule succ_leI [THEN lt_trans], assumption)
 apply (frule_tac i = m in nat_into_Ord [THEN le_refl, THEN lt_trans],
        assumption)
 apply (simp_all add: succ_pred lt_pred)
done

lemma substitution:
     "[|v \<in> redexes; u \<in> redexes; w \<in> redexes; n \<in> nat|]
      ==> subst_rec(w,u,n)/subst_rec(lift(w),v,succ(n)) = subst_rec(w,u/v,n)"
by (simp add: subst_rec_subst_rec)

(* ------------------------------------------------------------------------- *)
(*          Preservation lemmas                                              *)
(*          Substitution preserves comp and regular                          *)
(* ------------------------------------------------------------------------- *)

lemma lift_rec_preserve_comp [rule_format, simp]:
     "u \<sim> v ==> \<forall>m \<in> nat. lift_rec(u,m) \<sim> lift_rec(v,m)"
by (erule Scomp.induct, simp_all add: comp_refl)

lemma subst_rec_preserve_comp [rule_format, simp]:
     "u2 \<sim> v2 ==> \<forall>m \<in> nat. \<forall>u1 \<in> redexes. \<forall>v1 \<in> redexes.
                  u1 \<sim> v1\<longrightarrow> subst_rec(u1,u2,m) \<sim> subst_rec(v1,v2,m)"
by (erule Scomp.induct,
    simp_all add: subst_Var lift_rec_preserve_comp comp_refl)

lemma lift_rec_preserve_reg [simp]:
     "regular(u) ==> \<forall>m \<in> nat. regular(lift_rec(u,m))"
by (erule Sreg.induct, simp_all add: lift_rec_Var)

lemma subst_rec_preserve_reg [simp]:
     "regular(v) ==>
        \<forall>m \<in> nat. \<forall>u \<in> redexes. regular(u)\<longrightarrow>regular(subst_rec(u,v,m))"
by (erule Sreg.induct, simp_all add: subst_Var lift_rec_preserve_reg)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_escape_Injective
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Token = A | B | C | D | ESC | P | Q | R

fun isSpecial :: "Token => bool" where
"isSpecial x =
   (case x of
      ESC => True
      | P => True
      | Q => True
      | R => True
      | other => False)"

fun code :: "Token => Token" where
"code x =
   (case x of
      ESC => ESC
      | P => A
      | Q => B
      | R => C
      | other => x)"

fun escape :: "Token list => Token list" where
"escape (nil2) = nil2"
| "escape (cons2 y xs) =
     (if isSpecial y then cons2 ESC (cons2 (code y) (escape xs)) else
        cons2 y (escape xs))"

theorem property0 :
  "(((escape xs) = (escape ys)) ==> (xs = ys))"
  oops

end


chapter \<open>Tagged Sum-of-Products Representation\<close>
text \<open>
This theory sets up a version of the sum-of-products representation that includes constructor and
selector names. For an example of a type class that uses this representation see Derive\_Show.
\<close>

theory Tagged_Prod_Sum
imports Main
begin

context begin

qualified datatype ('a, 'b) prod = Prod "string option" "string option" 'a 'b
qualified datatype ('a, 'b) sum = Inl "string option" 'a | Inr "string option" 'b

qualified definition fst where "fst p = (case p of (Prod _ _ a _) \<Rightarrow> a)"
qualified definition snd where "snd p = (case p of (Prod _ _ _ b) \<Rightarrow> b)"
qualified definition sel_name_fst where "sel_name_fst p = (case p of (Prod s _ _ _) \<Rightarrow> s)"
qualified definition sel_name_snd where "sel_name_snd p = (case p of (Prod _ s _ _) \<Rightarrow> s)"

qualified definition constr_name where "constr_name x = (case x of (Inl s _) \<Rightarrow> s | (Inr s _) \<Rightarrow> s)"

end

lemma measure_tagged_fst[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda> p. f (Tagged_Prod_Sum.fst p))"
  by (rule is_measure_trivial)

lemma measure_tagged_snd[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda> p. f (Tagged_Prod_Sum.snd p))"
  by (rule is_measure_trivial)

lemma size_tagged_prod_simp:
  "Tagged_Prod_Sum.prod.size_prod f g p = f (Tagged_Prod_Sum.fst p) + g (Tagged_Prod_Sum.snd p) + Suc 0"
  apply (induct p)
  by (simp add: Tagged_Prod_Sum.fst_def Tagged_Prod_Sum.snd_def)

lemma size_tagged_sum_simp:
  "Tagged_Prod_Sum.sum.size_sum f g x = (case x of Tagged_Prod_Sum.Inl _ a \<Rightarrow> f a + Suc 0 | Tagged_Prod_Sum.Inr _ b \<Rightarrow> g b + Suc 0)"
  apply (induct x)
  by auto

lemma size_tagged_prod_measure:
  "is_measure f \<Longrightarrow> is_measure g \<Longrightarrow> is_measure (Tagged_Prod_Sum.prod.size_prod f g)"
by (rule is_measure_trivial)

lemma size_tagged_sum_measure:
  "is_measure f \<Longrightarrow> is_measure g \<Longrightarrow> is_measure (Tagged_Prod_Sum.sum.size_sum f g)"
by (rule is_measure_trivial)

end