(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Word Alignment"

theory Aligned
  imports
    "HOL-Library.Word"
    More_Word
    Word_EqI
begin

lift_definition is_aligned :: \<open>'a::len word \<Rightarrow> nat \<Rightarrow> bool\<close>
  is \<open>\<lambda>k n. 2 ^ n dvd take_bit LENGTH('a) k\<close>
  by simp

lemma is_aligned_iff_udvd:
  \<open>is_aligned w n \<longleftrightarrow> 2 ^ n udvd w\<close>
  by transfer (simp flip: take_bit_eq_0_iff add: min_def)

lemma is_aligned_iff_take_bit_eq_0:
  \<open>is_aligned w n \<longleftrightarrow> take_bit n w = 0\<close>
  by (simp add: is_aligned_iff_udvd take_bit_eq_0_iff exp_dvd_iff_exp_udvd)

lemma is_aligned_iff_dvd_int:
  \<open>is_aligned ptr n \<longleftrightarrow> 2 ^ n dvd uint ptr\<close>
  by transfer simp

lemma is_aligned_iff_dvd_nat:
  \<open>is_aligned ptr n \<longleftrightarrow> 2 ^ n dvd unat ptr\<close>
proof -
  have \<open>unat ptr = nat \<bar>uint ptr\<bar>\<close>
    by transfer simp
  then have \<open>2 ^ n dvd unat ptr \<longleftrightarrow> 2 ^ n dvd uint ptr\<close>
    by (simp only: dvd_nat_abs_iff) simp
  then show ?thesis
    by (simp add: is_aligned_iff_dvd_int)
qed

lemma is_aligned_0 [simp]:
  \<open>is_aligned 0 n\<close>
  by transfer simp

lemma is_aligned_at_0 [simp]:
  \<open>is_aligned w 0\<close>
  by transfer simp

lemma is_aligned_beyond_length:
  \<open>is_aligned w n \<longleftrightarrow> w = 0\<close> if \<open>LENGTH('a) \<le> n\<close> for w :: \<open>'a::len word\<close>
  using that
  apply (simp add: is_aligned_iff_udvd)
  apply transfer
  apply auto
  done

lemma is_alignedI [intro?]:
  \<open>is_aligned x n\<close> if \<open>x = 2 ^ n * k\<close> for x :: \<open>'a::len word\<close>
proof (unfold is_aligned_iff_udvd)
  from that show \<open>2 ^ n udvd x\<close>
    using dvd_triv_left exp_dvd_iff_exp_udvd by blast
qed

lemma is_alignedE:
  fixes w :: \<open>'a::len word\<close>
  assumes \<open>is_aligned w n\<close>
  obtains q where \<open>w = 2 ^ n * word_of_nat q\<close> \<open>q < 2 ^ (LENGTH('a) - n)\<close>
proof (cases \<open>n < LENGTH('a)\<close>)
  case False
  with assms have \<open>w = 0\<close>
    by (simp add: is_aligned_beyond_length)
  with that [of 0] show thesis
    by simp
next
  case True
  moreover define m where \<open>m = LENGTH('a) - n\<close>
  ultimately have l: \<open>LENGTH('a) = n + m\<close> and \<open>m \<noteq> 0\<close>
    by simp_all
  from \<open>n < LENGTH('a)\<close> have *: \<open>unat (2 ^ n :: 'a word) = 2 ^ n\<close>
    by transfer simp
  from assms have \<open>2 ^ n udvd w\<close>
    by (simp add: is_aligned_iff_udvd)
  then obtain v :: \<open>'a word\<close>
    where \<open>unat w = unat (2 ^ n :: 'a word) * unat v\<close> ..
  moreover define q where \<open>q = unat v\<close>
  ultimately have unat_w: \<open>unat w = 2 ^ n * q\<close>
    by (simp add: *)
  then have \<open>word_of_nat (unat w) = (word_of_nat (2 ^ n * q) :: 'a word)\<close>
    by simp
  then have w: \<open>w = 2 ^ n * word_of_nat q\<close>
    by simp
  moreover have \<open>q < 2 ^ (LENGTH('a) - n)\<close>
  proof (rule ccontr)
    assume \<open>\<not> q < 2 ^ (LENGTH('a) - n)\<close>
    then have \<open>2 ^ (LENGTH('a) - n) \<le> q\<close>
      by simp
    then have \<open>2 ^ LENGTH('a) \<le> 2 ^ n * q\<close>
      by (simp add: l power_add)
    with unat_w [symmetric] show False
      by (metis le_antisym nat_less_le unsigned_less)
  qed
  ultimately show thesis
    using that by blast
qed

lemma is_alignedE' [elim?]:
  fixes w :: \<open>'a::len word\<close>
  assumes \<open>is_aligned w n\<close>
  obtains q where \<open>w = push_bit n (word_of_nat q)\<close> \<open>q < 2 ^ (LENGTH('a) - n)\<close>
proof -
  from assms
  obtain q where \<open>w = 2 ^ n * word_of_nat q\<close> \<open>q < 2 ^ (LENGTH('a) - n)\<close>
    by (rule is_alignedE)
  then have \<open>w = push_bit n (word_of_nat q)\<close>
    by (simp add: push_bit_eq_mult)
  with that show thesis
    using \<open>q < 2 ^ (LENGTH('a) - n)\<close> .
qed

lemma is_aligned_mask:
  \<open>is_aligned w n \<longleftrightarrow> w AND mask n = 0\<close>
  by (simp add: is_aligned_iff_take_bit_eq_0 take_bit_eq_mask)

lemma is_aligned_imp_not_bit:
  \<open>\<not> bit w m\<close> if \<open>is_aligned w n\<close> and \<open>m < n\<close>
  for w :: \<open>'a::len word\<close>
proof -
  from \<open>is_aligned w n\<close>
  obtain q where \<open>w = push_bit n (word_of_nat q)\<close> \<open>q < 2 ^ (LENGTH('a) - n)\<close> ..
  moreover have \<open>\<not> bit (push_bit n (word_of_nat q :: 'a word)) m\<close>
    using \<open>m < n\<close> by (simp add: bit_simps)
  ultimately show ?thesis
    by simp
qed

lemma is_aligned_weaken:
  "\<lbrakk> is_aligned w x; x \<ge> y \<rbrakk> \<Longrightarrow> is_aligned w y"
  unfolding is_aligned_iff_dvd_nat
  by (erule dvd_trans [rotated]) (simp add: le_imp_power_dvd)

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 ^ (LENGTH('a) - n)"
  using aligned is_alignedE by blast

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 < LENGTH('a)"
  show ?thesis
    unfolding is_aligned_iff_dvd_nat dvd_def
  proof -
    from aligned2 obtain q2 where yv: "y = 2 ^ m * of_nat q2"
      and q2v: "q2 < 2 ^ (LENGTH('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 ^ (LENGTH('a) - (m + k))"
      by (auto elim: is_alignedE)

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

    have l2: "2 ^ m * q2 < 2 ^ LENGTH('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)"
    proof -
      have f1: "unat x = 2 ^ (m + k) * q1"
        using q1v unat_mult_power_lem xv by blast
      have "unat y = 2 ^ m * q2"
        using q2v unat_mult_power_lem yv by blast
      then show ?thesis
        using f1 by (simp add: power_add semiring_normalization_rules(34))
    qed

    (* (2 ^ k * q1 + q2) *)
    show "\<exists>d. unat (x + y) = 2 ^ m * d"
    proof (cases "unat x + unat y < 2 ^ LENGTH('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
      then have "unat (x + y) = (unat x + unat y) mod 2 ^ LENGTH('a)"
        by (subst unat_word_ariths(1)) simp

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

      also
      have "\<dots> = 2 ^ m * ((2 ^ k * q1 +  q2) mod 2 ^ (LENGTH('a) - m))"
      proof -
        have "m \<le> len_of (TYPE('a))"
          by (meson le_trans less_imp_le_nat lt nlt)
        then show ?thesis
          by (metis mult_mod_right ordered_cancel_comm_monoid_diff_class.add_diff_inverse power_add)
      qed

      finally show ?thesis ..
    qed
  qed
next
  assume "\<not> n < LENGTH('a)"
  with assms
  show ?thesis
    by (simp add: is_aligned_mask not_less take_bit_eq_mod power_overflow word_arith_nat_defs(7) flip: take_bit_eq_mask)
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 (push_bit m k) m"
proof cases
  assume mv: "m < LENGTH('a)"
  from mv obtain q where mq: "m + q = LENGTH('a)" and "0 < q"
    by (auto dest: less_imp_add_positive)

  have "(2::nat) ^ m dvd unat (push_bit m k)"
  proof
    have kv: "(unat k div 2 ^ q) * 2 ^ q + unat k mod 2 ^ q = unat k"
      by (rule div_mult_mod_eq)

    have "unat (push_bit m k) = unat (2 ^ m * k)"
      by (simp add: push_bit_eq_mult ac_simps)
    also have "\<dots> = (2 ^ m * unat k) mod (2 ^ LENGTH('a))" using mv
      by (simp add: unat_word_ariths(2))
    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 (push_bit m k) = 2 ^ m * (unat k mod 2 ^ q)" .
  qed

  then show ?thesis by (unfold is_aligned_iff_dvd_nat)
next
  assume "\<not> m < LENGTH('a)"
  then show ?thesis
    by (simp add: not_less power_overflow is_aligned_mask 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 < LENGTH('a)"
  with al
  show ?thesis
    unfolding is_aligned_iff_dvd_nat
    by (simp add: and_mask_dvd_nat p2_gt_0 word_mod_2p_is_mask)
next
  assume "\<not> sz < LENGTH('a)"
  with al show ?thesis
    by (simp add: is_aligned_mask flip: take_bit_eq_mask take_bit_eq_mod)
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 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 ^ LENGTH('a)"
proof -
  have szv: "sz < LENGTH('a)"
  using off p2_gt_0 word_neq_0_conv by fastforce

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

  show ?thesis
  proof (cases "sz = 0")
    case True
    then show ?thesis using off ptrq qv
      by simp
  next
    case False
    then have 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 ^ LENGTH('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<LENGTH('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<LENGTH('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 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 then show ?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 aligned_add_xor:
  \<open>(x + 2 ^ n) XOR 2 ^ n = x\<close>
  if al: \<open>is_aligned (x::'a::len word) n'\<close> and le: \<open>n < n'\<close>
proof -
  have \<open>\<not> bit x n\<close>
    using that by (rule is_aligned_imp_not_bit)
  then have \<open>x + 2 ^ n = x OR 2 ^ n\<close>
    by (subst disjunctive_add) (auto simp add: bit_simps disjunctive_add)
  moreover have \<open>(x OR 2 ^ n) XOR 2 ^ n = x\<close>
    by (rule bit_word_eqI) (auto simp add: bit_simps \<open>\<not> bit x n\<close>)
  ultimately show ?thesis
    by simp
qed

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 is_aligned_no_wrap''':
  fixes ptr :: "'a::len word"
  shows"\<lbrakk> is_aligned ptr sz; sz < LENGTH('a); off < 2 ^ sz \<rbrakk>
         \<Longrightarrow> unat ptr + off < 2 ^ LENGTH('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 (simp add: take_bit_eq_mod)
  apply (subst(asm) unat_of_nat_len)
   apply (erule order_less_trans)
   apply (erule power_strict_increasing)
   apply simp
  apply assumption
  done

lemma aligned_small_is_0:
  "\<lbrakk> is_aligned x n; x < 2 ^ n \<rbrakk> \<Longrightarrow> x = 0"
  by (simp add: is_aligned_mask less_mask_eq)

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 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_bitI:
  \<open>is_aligned p m\<close> if \<open>\<And>n. n < m \<Longrightarrow> \<not> bit p n\<close>
  apply (simp add: is_aligned_mask)
  apply (rule bit_word_eqI)
  using that
  apply (auto simp add: bit_simps)
  done

lemma is_aligned_nth [word_eqI_simps]:
  "is_aligned p m = (\<forall>n < m. \<not> bit p n)"
  apply (auto intro: is_aligned_bitI simp add: is_aligned_mask bit_eq_iff)
   apply (auto simp: bit_simps)
  using bit_imp_le_length not_less apply blast
  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"
  apply (rule ccontr)
  using al apply (rule notE)
  apply simp
  apply (rule is_alignedI [of _ _ \<open>a div 2 ^ n\<close>])
  apply (metis add.right_neutral mult.commute word_mod_div_equality)
  done

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 < LENGTH('a)"
  and    off: "off \<le> 2 ^ sz"
  shows  "unat ptr + off \<le> 2 ^ LENGTH('a)"
proof -
  from al obtain q where ptrq: "ptr = 2 ^ sz * of_nat q" and
    qv: "q < 2 ^ (LENGTH('a) - sz)" by (auto elim: is_alignedE)

  show ?thesis
  proof (cases "sz = 0")
    case True
    then show ?thesis using off ptrq qv
      by (auto simp add: le_Suc_eq Suc_le_eq) (simp add: le_less)
  next
    case False
    then have 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 ^ LENGTH('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 AND NOT (mask n)) m"
  by (rule is_aligned_bitI) (simp add: bit_simps)

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]
  by (simp add: unat_eq_0 word_size)

lemma is_aligned_minus:
  \<open>is_aligned (- p) n\<close> if \<open>is_aligned p n\<close> for p :: \<open>'a::len word\<close>
  using that
  apply (cases \<open>n < LENGTH('a)\<close>)
  apply (simp_all add: not_less is_aligned_beyond_length)
  apply transfer
  apply (simp flip: take_bit_eq_0_iff)
  apply (subst take_bit_minus [symmetric])
  apply simp
  done

lemma add_mask_lower_bits:
  "\<lbrakk>is_aligned (x :: 'a :: len word) n;
    \<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> bit p n'\<rbrakk> \<Longrightarrow> x + p AND NOT (mask n) = x"
  apply (subst word_plus_and_or_coroll)
   apply (rule word_eqI)
   apply (clarsimp simp: word_size is_aligned_nth)
   apply (erule_tac x=na in allE)+
   apply (simp add: bit_simps)
  apply (rule bit_word_eqI)
  apply (auto simp add: bit_simps not_less word_size)
  apply (metis is_aligned_nth not_le)
  done

lemma is_aligned_andI1:
  "is_aligned x n \<Longrightarrow> is_aligned (x AND y) n"
  by (simp add: is_aligned_nth bit_simps)

lemma is_aligned_andI2:
  "is_aligned y n \<Longrightarrow> is_aligned (x AND y) n"
  by (simp add: is_aligned_nth bit_simps)

lemma is_aligned_shiftl:
  "is_aligned w (n - m) \<Longrightarrow> is_aligned (push_bit m w) n"
  by (simp add: is_aligned_nth bit_simps)

lemma is_aligned_shiftr:
  "is_aligned w (n + m) \<Longrightarrow> is_aligned (drop_bit m w) n"
  by (simp add: is_aligned_nth bit_simps)

lemma is_aligned_shiftl_self:
  "is_aligned (push_bit n p) n"
  by (rule is_aligned_shift)

lemma is_aligned_neg_mask_eq:
  "is_aligned p n \<Longrightarrow> p AND NOT (mask n) = p"
  apply (rule bit_word_eqI)
  apply (auto simp add: bit_simps is_aligned_nth)
  done

lemma is_aligned_shiftr_shiftl:
  "is_aligned w n \<Longrightarrow> push_bit n (drop_bit n w) = w"
  apply (rule bit_word_eqI)
  apply (auto simp add: bit_simps is_aligned_nth)
  using not_le_imp_less apply blast
  apply (metis add_diff_inverse_nat)
  done

lemma aligned_shiftr_mask_shiftl:
  "is_aligned x n \<Longrightarrow> push_bit n (drop_bit n x AND mask v) = x AND mask (v + n)"
  apply (rule word_eqI)
  apply (simp add: word_size bit_simps)
  apply (subgoal_tac "\<forall>m. bit x m \<longrightarrow> m \<ge> n")
   apply auto[1]
  apply (clarsimp simp: is_aligned_mask)
  apply (drule_tac x=m in word_eqD)
  apply (frule test_bit_size)
  apply (simp add: word_size bit_simps)
  done

lemma mask_zero:
  "is_aligned x a \<Longrightarrow> x AND mask a = 0"
  by (metis is_aligned_mask)

lemma is_aligned_neg_mask_eq_concrete:
  "\<lbrakk> is_aligned p n; msk AND NOT (mask n) = NOT (mask n) \<rbrakk>
   \<Longrightarrow> p AND msk = p"
  by (metis word_bw_assocs(1) word_bw_comms(1) is_aligned_neg_mask_eq)

lemma is_aligned_and_not_zero:
  "\<lbrakk> is_aligned n k; n \<noteq> 0 \<rbrakk> \<Longrightarrow> 2 ^ k \<le> n"
  using is_aligned_less_sz leI by blast

lemma is_aligned_and_2_to_k:
  "(n AND 2 ^ k - 1) = 0 \<Longrightarrow> is_aligned (n :: 'a :: len word) k"
  by (simp add: is_aligned_mask mask_eq_decr_exp)

lemma is_aligned_power2:
  "b \<le> a \<Longrightarrow> is_aligned (2 ^ a) b"
  by (metis is_aligned_triv is_aligned_weaken)

lemma aligned_sub_aligned':
  "\<lbrakk> is_aligned (a :: 'a :: len word) n; is_aligned b n; n < LENGTH('a) \<rbrakk>
   \<Longrightarrow> is_aligned (a - b) n"
  by (simp add: aligned_sub_aligned)

lemma is_aligned_neg_mask_weaken:
  "\<lbrakk> is_aligned p n; m \<le> n \<rbrakk> \<Longrightarrow> p AND NOT (mask m) = p"
   using is_aligned_neg_mask_eq is_aligned_weaken by blast

lemma is_aligned_neg_mask2 [simp]:
  "is_aligned (a AND NOT (mask n)) n"
  by (rule is_aligned_bitI) (simp add: bit_simps)

lemma is_aligned_0':
  "is_aligned 0 n"
  by (fact is_aligned_0)

lemma aligned_add_offset_no_wrap:
  fixes off :: "('a::len) word"
  and     x :: "'a word"
  assumes al: "is_aligned x sz"
  and   offv: "off < 2 ^ sz"
  shows  "unat x + unat off < 2 ^ LENGTH('a)"
proof cases
  assume szv: "sz < LENGTH('a)"
  from al obtain k where xv: "x = 2 ^ sz * (of_nat k)"
    and kl: "k < 2 ^ (LENGTH('a) - sz)"
    by (auto elim: is_alignedE)

  show ?thesis using szv
    apply (subst xv)
    apply (subst unat_mult_power_lem[OF kl])
    apply (subst mult.commute, rule nat_add_offset_less)
      apply (rule less_le_trans[OF unat_mono[OF offv, simplified]])
      apply (erule eq_imp_le[OF unat_power_lower])
     apply (rule kl)
    apply simp
   done
next
  assume "\<not> sz < LENGTH('a)"
  with offv show ?thesis by (simp add: not_less power_overflow )
qed

lemma aligned_add_offset_mod:
  fixes x :: "('a::len) word"
  assumes al: "is_aligned x sz"
  and     kv: "k < 2 ^ sz"
  shows   "(x + k) mod 2 ^ sz = k"
proof cases
  assume szv: "sz < LENGTH('a)"

  have ux: "unat x + unat k < 2 ^ LENGTH('a)"
    by (rule aligned_add_offset_no_wrap) fact+

  show ?thesis using al szv
    apply (simp flip: take_bit_eq_mod)
    apply (rule bit_word_eqI)
    apply (auto simp add: bit_simps)
    apply (metis assms(2) bit_or_iff is_aligned_mask is_aligned_nth leD less_mask_eq word_and_le1 word_bw_lcs(1) word_neq_0_conv word_plus_and_or_coroll)
     apply (meson assms(2) leI less_2p_is_upper_bits_unset)
    apply (metis assms(2) bit_disjunctive_add_iff bit_imp_le_length bit_push_bit_iff is_alignedE' less_2p_is_upper_bits_unset)
    done
next
  assume "\<not> sz < LENGTH('a)"
  with al show ?thesis
    by (simp add: not_less power_overflow is_aligned_mask mask_eq_decr_exp
                  word_mod_by_0)
qed

    have rl: "\<And>(p::'a word) k w. \<lbrakk>uint p + uint k < 2 ^ LENGTH('a); w = p + k; w \<le> p + (2 ^ sz - 1) \<rbrakk>
      \<Longrightarrow> k < 2 ^ sz"
      apply -
      apply simp
      apply (subst (asm) add.commute, subst (asm) add.commute, drule word_plus_mcs_4)
       apply (subst add.commute, subst no_plus_overflow_uint_size)
       apply transfer
      apply simp
      apply (auto simp add: le_less power_2_ge_iff szv)
      apply (metis le_less_trans mask_eq_decr_exp mask_lt_2pn order_less_imp_le szv)
      done

    from xb obtain kx where
      kx: "z = x + kx" and
      kxl: "uint x + uint kx < 2 ^ LENGTH('a)"
      by (clarsimp dest!: word_le_exists')

    from yb obtain ky where
      ky: "z = y + ky" and
      kyl: "uint y + uint ky < 2 ^ LENGTH('a)"
      by (clarsimp dest!: word_le_exists')

    have "x = y"
    proof -
      have "kx = z mod 2 ^ sz"
      proof (subst kx, rule sym, rule aligned_add_offset_mod)
        show "kx < 2 ^ sz" by (rule rl) fact+
      qed fact+

      also have "\<dots> = ky"
      proof (subst ky, rule aligned_add_offset_mod)
        show "ky < 2 ^ sz"
          using kyl ky yt by (rule rl)
      qed fact+

      finally have kxky: "kx = ky" .
      moreover have "x + kx = y + ky" by (simp add: kx [symmetric] ky [symmetric])
      ultimately show ?thesis by simp
    qed
    then show False using neq by simp
  qed
next
  assume "\<not> sz < LENGTH('a)"
  with neq alx aly
  have False by (simp add: is_aligned_mask mask_eq_decr_exp power_overflow)
  then show ?thesis ..
qed

lemma is_aligned_add_helper:
  "\<lbrakk> is_aligned p n; d < 2 ^ n \<rbrakk>
     \<Longrightarrow> (p + d AND mask n = d) \<and> (p + d AND (NOT (mask n)) = p)"
  apply (subst (asm) is_aligned_mask)
  apply (drule less_mask_eq)
  apply (rule context_conjI)
   apply (subst word_plus_and_or_coroll)
    apply (simp_all flip: take_bit_eq_mask)
   apply (metis take_bit_eq_mask word_bw_lcs(1) word_log_esimps(1))
  apply (metis add.commute add_left_imp_eq take_bit_eq_mask word_plus_and_or_coroll2)
  done

lemmas mask_inner_mask = mask_eqs(1)

lemma mask_add_aligned:
  "is_aligned p n \<Longrightarrow> (p + q) AND mask n = q AND mask n"
  apply (simp add: is_aligned_mask)
  apply (subst mask_inner_mask [symmetric])
  apply simp
  done

lemma mask_out_add_aligned:
  assumes al: "is_aligned p n"
  shows "p + (q AND NOT (mask n)) = (p + q) AND NOT (mask n)"
  using mask_add_aligned [OF al]
  by (simp add: mask_out_sub_mask)

lemma is_aligned_add_or:
  "\<lbrakk>is_aligned p n; d < 2 ^ n\<rbrakk> \<Longrightarrow> p + d = p OR d"
  apply (subst disjunctive_add)
   apply (simp_all add: is_aligned_iff_take_bit_eq_0)
  apply (simp add: bit_eq_iff)
  apply (auto simp add: bit_simps)
  subgoal for m
    apply (cases \<open>m < n\<close>)
     apply (auto simp add: not_less)
    apply (metis bit_take_bit_iff less_mask_eq take_bit_eq_mask)
    done
  done

lemma not_greatest_aligned:
  "\<lbrakk> x < y; is_aligned x n; is_aligned y n \<rbrakk> \<Longrightarrow> x + 2 ^ n \<noteq> 0"
  by (metis NOT_mask add_diff_cancel_right' diff_0 is_aligned_neg_mask_eq not_le word_and_le1)

lemma neg_mask_mono_le:
  "x \<le> y \<Longrightarrow> x AND NOT(mask n) \<le> y AND NOT(mask n)" for x :: "'a :: len word"
proof (rule ccontr, simp add: linorder_not_le, cases "n < LENGTH('a)")
  case False
  then show "y AND NOT(mask n) < x AND NOT(mask n) \<Longrightarrow> False"
    by (simp add: mask_eq_decr_exp linorder_not_less power_overflow)
next
  case True
  assume a: "x \<le> y" and b: "y AND NOT(mask n) < x AND NOT(mask n)"
  have word_bits: "n < LENGTH('a)" by fact
  have "y \<le> (y AND NOT(mask n)) + (y AND mask n)"
    by (simp add: word_plus_and_or_coroll2 add.commute)
  also have "\<dots> \<le> (y AND NOT(mask n)) + 2 ^ n"
    apply (rule word_plus_mono_right)
     apply (rule order_less_imp_le, rule and_mask_less_size)
     apply (simp add: word_size word_bits)
    apply (rule is_aligned_no_overflow'', simp add: is_aligned_neg_mask word_bits)
    apply (rule not_greatest_aligned, rule b; simp add: is_aligned_neg_mask)
    done
  also have "\<dots> \<le> x AND NOT(mask n)"
    using b
    apply (subst add.commute)
    apply (rule le_plus)
     apply (rule aligned_at_least_t2n_diff; simp add: is_aligned_neg_mask)
    apply (rule ccontr, simp add: linorder_not_le)
    apply (drule aligned_small_is_0[rotated]; simp add: is_aligned_neg_mask)
    done
  also have "\<dots> \<le> x" by (rule word_and_le2)
  also have "x \<le> y" by fact
  finally
  show "False" using b by simp
qed

lemma and_neg_mask_eq_iff_not_mask_le:
  "w AND NOT(mask n) = NOT(mask n) \<longleftrightarrow> NOT(mask n) \<le> w"
  for w :: \<open>'a::len word\<close>
  by (metis eq_iff neg_mask_mono_le word_and_le1 word_and_le2 word_bw_same(1))

lemma neg_mask_le_high_bits [word_eqI_simps]:
  \<open>NOT (mask n) \<le> w \<longleftrightarrow> (\<forall>i \<in> {n ..< size w}. bit w i)\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
  for w :: \<open>'a::len word\<close>
proof
  assume ?Q
  then have \<open>w AND NOT (mask n) = NOT (mask n)\<close>
    by (auto simp add: bit_simps word_size intro: bit_word_eqI)
  then show ?P
    by (simp add: and_neg_mask_eq_iff_not_mask_le)
next
  assume ?P
  then have *: \<open>w AND NOT (mask n) = NOT (mask n)\<close>
    by (simp add: and_neg_mask_eq_iff_not_mask_le)
  show \<open>?Q\<close>
  proof (rule ccontr)
    assume \<open>\<not> (\<forall>i\<in>{n..<size w}. bit w i)\<close>
    then obtain m where m: \<open>\<not> bit w m\<close> \<open>n \<le> m\<close> \<open>m < LENGTH('a)\<close>
      by (auto simp add: word_size)
    from * have \<open>bit (w AND NOT (mask n)) m \<longleftrightarrow> bit (NOT (mask n :: 'a word)) m\<close>
      by auto
    with m show False by (auto simp add: bit_simps)
  qed
qed

lemma is_aligned_add_less_t2n:
  "\<lbrakk>is_aligned (p::'a::len word) n; d < 2^n; n \<le> m; p < 2^m\<rbrakk> \<Longrightarrow> p + d < 2^m"
  apply (case_tac "m < LENGTH('a)")
   apply (subst mask_eq_iff_w2p[symmetric])
    apply (simp add: word_size)
   apply (simp add: is_aligned_add_or word_ao_dist less_mask_eq)
   apply (subst less_mask_eq)
    apply (erule order_less_le_trans)
    apply (erule(1) two_power_increasing)
   apply simp
  apply (simp add: power_overflow)
  done

lemma aligned_offset_non_zero:
  "\<lbrakk> is_aligned x n; y < 2 ^ n; x \<noteq> 0 \<rbrakk> \<Longrightarrow> x + y \<noteq> 0"
  apply (cases "y = 0")
   apply simp
  apply (subst word_neq_0_conv)
  apply (subst gt0_iff_gem1)
  apply (erule is_aligned_get_word_bits)
   apply (subst field_simps[symmetric], subst plus_le_left_cancel_nowrap)
     apply (rule is_aligned_no_wrap')
      apply simp
     apply (rule word_leq_le_minus_one)
      apply simp
     apply assumption
    apply (erule (1) is_aligned_no_wrap')
   apply (simp add: gt0_iff_gem1 [symmetric] word_neq_0_conv)
  apply simp
  done

lemma is_aligned_over_length:
  "\<lbrakk> is_aligned p n; LENGTH('a) \<le> n \<rbrakk> \<Longrightarrow> (p::'a::len word) = 0"
  by (simp add: is_aligned_mask mask_over_length)

lemma is_aligned_no_overflow_mask:
  "is_aligned x n \<Longrightarrow> x \<le> x + mask n"
  by (simp add: mask_eq_decr_exp) (erule is_aligned_no_overflow')

lemma aligned_mask_step:
  "\<lbrakk> n' \<le> n; p' \<le> p + mask n; is_aligned p n; is_aligned p' n' \<rbrakk> \<Longrightarrow>
   (p'::'a::len word) + mask n' \<le> p + mask n"
  apply (cases "LENGTH('a) \<le> n")
   apply (frule (1) is_aligned_over_length)
   apply (drule mask_over_length)
   apply clarsimp
  apply (simp add: not_le)
  apply (simp add: word_le_nat_alt unat_plus_simple)
  apply (subst unat_plus_simple[THEN iffD1], erule is_aligned_no_overflow_mask)+
  apply (subst (asm) unat_plus_simple[THEN iffD1], erule is_aligned_no_overflow_mask)
  apply (clarsimp simp: dvd_def is_aligned_iff_dvd_nat)
  apply (rename_tac k k')
  apply (thin_tac "unat p = x" for p x)+
  apply (subst Suc_le_mono[symmetric])
  apply (simp only: Suc_2p_unat_mask)
  apply (drule le_imp_less_Suc, subst (asm) Suc_2p_unat_mask, assumption)
  apply (erule (1) power_2_mult_step_le)
  done

lemma is_aligned_mask_offset_unat:
  fixes off :: "('a::len) word"
  and     x :: "'a word"
  assumes al: "is_aligned x sz"
  and   offv: "off \<le> mask sz"
  shows  "unat x + unat off < 2 ^ LENGTH('a)"
proof cases
  assume szv: "sz < LENGTH('a)"
  from al obtain k where xv: "x = 2 ^ sz * (of_nat k)"
    and kl: "k < 2 ^ (LENGTH('a) - sz)"
    by (auto elim: is_alignedE)

  from offv szv have offv': "unat off < 2 ^ sz"
    by (simp add: mask_2pm1 unat_less_power)

  show ?thesis using szv
    using al is_aligned_no_wrap''' offv' by blast
next
  assume "\<not> sz < LENGTH('a)"
  with al have "x = 0"
    by (meson is_aligned_get_word_bits)
  thus ?thesis by simp
qed

lemma aligned_less_plus_1:
  "\<lbrakk> is_aligned x n; n > 0 \<rbrakk> \<Longrightarrow> x < x + 1"
  apply (rule plus_one_helper2)
   apply (rule order_refl)
  apply (clarsimp simp: field_simps)
  apply (drule arg_cong[where f="\<lambda>x. x - 1"])
  apply (clarsimp simp: is_aligned_mask)
  apply (drule word_eqD[where x=0])
  apply (simp add: even_mask_iff)
  done

lemma aligned_add_offset_less:
  "\<lbrakk>is_aligned x n; is_aligned y n; x < y; z < 2 ^ n\<rbrakk> \<Longrightarrow> x + z < y"
  apply (cases "y = 0")
   apply simp
  apply (erule is_aligned_get_word_bits[where p=y], simp_all)
  apply (cases "z = 0", simp_all)
  apply (drule(2) aligned_at_least_t2n_diff[rotated -1])
  apply (drule plus_one_helper2)
   apply (rule less_is_non_zero_p1)
   apply (rule aligned_less_plus_1)
    apply (erule aligned_sub_aligned[OF _ _ order_refl],
           simp_all add: is_aligned_triv)[1]
   apply (cases n, simp_all)[1]
  apply (simp only: trans[OF diff_add_eq diff_diff_eq2[symmetric]])
  apply (drule word_less_add_right)
   apply (rule ccontr, simp add: linorder_not_le)
   apply (drule aligned_small_is_0, erule order_less_trans)
    apply (clarsimp simp: power_overflow)
   apply simp
  apply (erule order_le_less_trans[rotated],
         rule word_plus_mono_right)
   apply (erule word_le_minus_one_leq)
  apply (simp add: is_aligned_no_wrap' is_aligned_no_overflow field_simps)
  done

lemma gap_between_aligned:
  "\<lbrakk>a < (b :: 'a ::len word); is_aligned a n; is_aligned b n; n < LENGTH('a) \<rbrakk>
  \<Longrightarrow> a + (2^n - 1) < b"
  by (simp add: aligned_add_offset_less)

lemma is_aligned_add_step_le:
  "\<lbrakk> is_aligned (a::'a::len word) n; is_aligned b n; a < b; b \<le> a + mask n \<rbrakk> \<Longrightarrow> False"
  apply (simp flip: not_le)
  apply (erule notE)
  apply (cases "LENGTH('a) \<le> n")
   apply (drule (1) is_aligned_over_length)+
   apply (drule mask_over_length)
   apply clarsimp
  apply (clarsimp simp: word_le_nat_alt not_less not_le)
  apply (subst (asm) unat_plus_simple[THEN iffD1], erule is_aligned_no_overflow_mask)
  apply (subst (asm) unat_add_lem' [symmetric])
   apply (simp add: is_aligned_mask_offset_unat)
  apply (metis gap_between_aligned linorder_not_less mask_eq_decr_exp unat_arith_simps(2))
  done

lemma aligned_add_mask_lessD:
  "\<lbrakk> x + mask n < y; is_aligned x n \<rbrakk> \<Longrightarrow> x < y" for y::"'a::len word"
  by (metis is_aligned_no_overflow' mask_2pm1 order_le_less_trans)

lemma aligned_add_mask_less_eq:
  "\<lbrakk> is_aligned x n; is_aligned y n;  n < LENGTH('a) \<rbrakk> \<Longrightarrow> (x + mask n < y) = (x < y)"
  for y::"'a::len word"
  using aligned_add_mask_lessD is_aligned_add_step_le word_le_not_less by blast

lemma is_aligned_diff:
  fixes m :: "'a::len word"
  assumes alm: "is_aligned m s1"
  and     aln: "is_aligned n s2"
  and    s2wb: "s2 < LENGTH('a)"
  and      nm: "m \<in> {n .. n + (2 ^ s2 - 1)}"
  and    s1s2: "s1 \<le> s2"
  and     s10: "0 < s1" (* Probably can be folded into the proof \<dots> *)
shows  "\<exists>q. m - n = of_nat q * 2 ^ s1 \<and> q < 2 ^ (s2 - s1)"
proof -
  have rl: "\<And>m s. \<lbrakk> m < 2 ^ (LENGTH('a) - s); s < LENGTH('a) \<rbrakk> \<Longrightarrow> unat ((2::'a word) ^ s * of_nat m) = 2 ^ s * m"
  proof -
    fix m :: nat and  s
    assume m: "m < 2 ^ (LENGTH('a) - s)" and s: "s < LENGTH('a)"
    then have "unat ((of_nat m) :: 'a word) = m"
      apply (subst unat_of_nat)
      apply (subst mod_less)
       apply (erule order_less_le_trans)
       apply (rule power_increasing)
        apply simp_all
      done

    then show "?thesis m s" using s m
      apply (subst iffD1 [OF unat_mult_lem])
      apply (simp add: nat_less_power_trans)+
      done
  qed
  have s1wb: "s1 < LENGTH('a)" using s2wb s1s2 by simp
  from alm obtain mq where mmq: "m = 2 ^ s1 * of_nat mq" and mq: "mq < 2 ^ (LENGTH('a) - s1)"
    by (auto elim: is_alignedE simp: field_simps)
  from aln obtain nq where nnq: "n = 2 ^ s2 * of_nat nq" and nq: "nq < 2 ^ (LENGTH('a) - s2)"
    by (auto elim: is_alignedE simp: field_simps)
  from s1s2 obtain sq where sq: "s2 = s1 + sq" by (auto simp: le_iff_add)

  note us1 = rl [OF mq s1wb]
  note us2 = rl [OF nq s2wb]

  from nm have "n \<le> m" by clarsimp
  then have "(2::'a word) ^ s2 * of_nat nq \<le> 2 ^ s1 * of_nat mq" using nnq mmq by simp
  then have "2 ^ s2 * nq \<le> 2 ^ s1 * mq" using s1wb s2wb
    by (simp add: word_le_nat_alt us1 us2)
  then have nqmq: "2 ^ sq * nq \<le> mq" using sq by (simp add: power_add)

  have "m - n = 2 ^ s1 * of_nat mq - 2 ^ s2 * of_nat nq" using mmq nnq by simp
  also have "\<dots> = 2 ^ s1 * of_nat mq - 2 ^ s1 * 2 ^ sq * of_nat nq" using sq by (simp add: power_add)
  also have "\<dots> = 2 ^ s1 * (of_nat mq - 2 ^ sq * of_nat nq)" by (simp add: field_simps)
  also have "\<dots> = 2 ^ s1 * of_nat (mq - 2 ^ sq * nq)" using s1wb s2wb us1 us2 nqmq
    by (simp add: of_nat_diff)
  finally have mn: "m - n = of_nat (mq - 2 ^ sq * nq) * 2 ^ s1" by simp
  moreover
  from nm have "m - n \<le> 2 ^ s2 - 1"
    by - (rule word_diff_ls', (simp add: field_simps)+)
  then have "(2::'a word) ^ s1 * of_nat (mq - 2 ^ sq * nq) < 2 ^ s2" using mn s2wb by (simp add: field_simps)
  then have "of_nat (mq - 2 ^ sq * nq) < (2::'a word) ^ (s2 - s1)"
  proof (rule word_power_less_diff)
    have mm: "mq - 2 ^ sq * nq < 2 ^ (LENGTH('a) - s1)" using mq by simp
    moreover from s10 have "LENGTH('a) - s1 < LENGTH('a)"
      by (rule diff_less, simp)
    ultimately show "of_nat (mq - 2 ^ sq * nq) < (2::'a word) ^ (LENGTH('a) - s1)"
      using take_bit_nat_less_self_iff [of \<open>LENGTH('a)\<close> \<open>mq - 2 ^ sq * nq\<close>]
      apply (auto simp add: word_less_nat_alt not_le not_less)
      apply (metis take_bit_nat_eq_self_iff)
      done
  qed
  then have "mq - 2 ^ sq * nq < 2 ^ (s2 - s1)" using mq s2wb
    apply (simp add: word_less_nat_alt take_bit_eq_mod)
    apply (subst (asm) mod_less)
    apply auto
     apply (rule order_le_less_trans)
      apply (rule diff_le_self)
     apply (erule order_less_le_trans)
    apply simp
    done
  ultimately show ?thesis
    by auto
qed

lemma is_aligned_addD1:
  assumes al1: "is_aligned (x + y) n"
  and     al2: "is_aligned (x::'a::len word) n"
  shows "is_aligned y n"
  using al2
proof (rule is_aligned_get_word_bits)
  assume "x = 0" then show ?thesis using al1 by simp
next
  assume nv: "n < LENGTH('a)"
  from al1 obtain q1
    where xy: "x + y = 2 ^ n * of_nat q1" and "q1 < 2 ^ (LENGTH('a) - n)"
    by (rule is_alignedE)
  moreover from al2 obtain q2
    where x: "x = 2 ^ n * of_nat q2" and "q2 < 2 ^ (LENGTH('a) - n)"
    by (rule is_alignedE)
  ultimately have "y = 2 ^ n * (of_nat q1 - of_nat q2)"
    by (simp add: field_simps)
  then show ?thesis using nv by (simp add: is_aligned_mult_triv1)
qed

lemmas is_aligned_addD2 =
       is_aligned_addD1[OF subst[OF add.commute,
                                 of "%x. is_aligned x n" for n]]

lemma is_aligned_add:
  "\<lbrakk>is_aligned p n; is_aligned q n\<rbrakk> \<Longrightarrow> is_aligned (p + q) n"
  by (simp add: is_aligned_mask mask_add_aligned)

lemma aligned_shift:
  "\<lbrakk>x < 2 ^ n; is_aligned (y :: 'a :: len word) n;n \<le> LENGTH('a)\<rbrakk>
   \<Longrightarrow> drop_bit n (x + y) = drop_bit n y"
  apply (subst word_plus_and_or_coroll; rule bit_word_eqI)
   apply (auto simp add: bit_simps is_aligned_nth)
   apply (metis less_2p_is_upper_bits_unset not_le)
  apply (metis le_add1 less_2p_is_upper_bits_unset test_bit_bin)
  done

lemma aligned_shift':
  "\<lbrakk>x < 2 ^ n; is_aligned (y :: 'a :: len word) n;n \<le> LENGTH('a)\<rbrakk>
   \<Longrightarrow> drop_bit n (y + x) = drop_bit n y"
  apply (subst word_plus_and_or_coroll; rule bit_word_eqI)
   apply (auto simp add: bit_simps is_aligned_nth)
   apply (metis less_2p_is_upper_bits_unset not_le)
  apply (metis bit_imp_le_length le_add1 less_2p_is_upper_bits_unset)
  done

lemma and_neg_mask_plus_mask_mono: "(p AND NOT (mask n)) + mask n \<ge> p"
  for p :: \<open>'a::len word\<close>
  apply (rule word_le_minus_cancel[where x = "p AND NOT (mask n)"])
   apply (clarsimp simp: subtract_mask)
   using word_and_le1[where a = "mask n" and y = p]
    apply (clarsimp simp: mask_eq_decr_exp word_le_less_eq)
  apply (rule is_aligned_no_overflow'[folded mask_2pm1])
  apply (clarsimp simp: is_aligned_neg_mask)
  done

lemma word_neg_and_le:
  "ptr \<le> (ptr AND NOT (mask n)) + (2 ^ n - 1)"
  for ptr :: \<open>'a::len word\<close>
  by (simp add: and_neg_mask_plus_mask_mono mask_2pm1[symmetric])

lemma is_aligned_sub_helper:
  "\<lbrakk> is_aligned (p - d) n; d < 2 ^ n \<rbrakk>
     \<Longrightarrow> (p AND mask n = d) \<and> (p AND (NOT (mask n)) = p - d)"
  by (drule(1) is_aligned_add_helper, simp)

lemma is_aligned_after_mask:
  "\<lbrakk>is_aligned k m;m\<le> n\<rbrakk> \<Longrightarrow> is_aligned (k AND mask n) m"
  by (rule is_aligned_andI1)

lemma and_mask_plus:
  "\<lbrakk>is_aligned ptr m; m \<le> n; a < 2 ^ m\<rbrakk>
   \<Longrightarrow> ptr + a AND mask n = (ptr AND mask n) + a"
  apply (rule mask_eqI[where n = m])
   apply (simp add:mask_twice min_def)
    apply (simp add:is_aligned_add_helper)
    apply (subst is_aligned_add_helper[THEN conjunct1])
      apply (erule is_aligned_after_mask)
     apply simp
    apply simp
   apply simp
  apply (subgoal_tac "(ptr + a AND mask n) AND NOT (mask m)
     = (ptr + a AND NOT (mask m) ) AND mask n")
   apply (simp add:is_aligned_add_helper)
   apply (subst is_aligned_add_helper[THEN conjunct2])
     apply (simp add:is_aligned_after_mask)
    apply simp
   apply simp
  apply (simp add:word_bw_comms word_bw_lcs)
  done

lemma is_aligned_add_not_aligned:
  "\<lbrakk>is_aligned (p::'a::len word) n; \<not> is_aligned (q::'a::len word) n\<rbrakk> \<Longrightarrow> \<not> is_aligned (p + q) n"
  by (metis is_aligned_addD1)

lemma neg_mask_add_aligned:
  "\<lbrakk> is_aligned p n; q < 2 ^ n \<rbrakk> \<Longrightarrow> (p + q) AND NOT (mask n) = p AND NOT (mask n)"
  by (metis is_aligned_add_helper is_aligned_neg_mask_eq)

lemma word_add_power_off:
  fixes a :: "'a :: len word"
  assumes ak: "a < k"
  and kw: "k < 2 ^ (LENGTH('a) - m)"
  and mw: "m < LENGTH('a)"
  and off: "off < 2 ^ m"
shows "(a * 2 ^ m) + off < k * 2 ^ m"
proof (cases "m = 0")
  case True
  then show ?thesis using off ak by simp
next
  case False

  from ak have ak1: "a + 1 \<le> k" by (rule inc_le)
  then have "(a + 1) * 2 ^ m \<noteq> 0"
    apply -
    apply (rule word_power_nonzero)
    apply (erule order_le_less_trans  [OF _ kw])
    apply (rule mw)
    apply (rule less_is_non_zero_p1 [OF ak])
    done
  then have "(a * 2 ^ m) + off < ((a + 1) * 2 ^ m)" using kw mw
    apply -
    apply (simp add: distrib_right)
    apply (rule word_plus_strict_mono_right [OF off])
    apply (rule is_aligned_no_overflow'')
    apply (rule is_aligned_mult_triv2)
    apply assumption
    done
  also have "\<dots> \<le> k * 2 ^ m" using ak1 mw kw False
    apply -
    apply (erule word_mult_le_mono1)
    apply (simp add: p2_gt_0)
    apply (simp add: word_less_nat_alt)
    apply (meson nat_mult_power_less_eq zero_less_numeral)
    done
  finally show ?thesis .
qed

lemma offset_not_aligned:
  "\<lbrakk> is_aligned (p::'a::len word) n; i > 0; i < 2 ^ n; n < LENGTH('a)\<rbrakk> \<Longrightarrow>
   \<not> is_aligned (p + of_nat i) n"
  apply (erule is_aligned_add_not_aligned)
  apply transfer
  apply (auto simp add: is_aligned_iff_udvd)
  apply (metis (no_types, lifting) le_less_trans less_not_refl2 less_or_eq_imp_le of_nat_eq_0_iff take_bit_eq_0_iff take_bit_nat_eq_self_iff take_bit_of_nat unat_lt2p unat_power_lower)
  done

lemma le_or_mask:
  "w \<le> w' \<Longrightarrow> w OR mask x \<le> w' OR mask x"
  for w w' :: \<open>'a::len word\<close>
  by (metis neg_mask_add_mask add.commute le_word_or1 mask_2pm1 neg_mask_mono_le word_plus_mono_left)

end


section \<open> Proof Support for Quantities \<close>

theory ISQ_Proof
  imports ISQ_Quantities
begin

named_theorems si_transfer

definition magQ :: "'a['u::dim_type, 's::unit_system] \<Rightarrow> 'a" ("\<lbrakk>_\<rbrakk>\<^sub>Q") where
[si_def]: "magQ x = mag (fromQ x)"

definition dimQ :: "'a['u::dim_type, 's::unit_system] \<Rightarrow> Dimension" where
[si_def]: "dimQ x = dim (fromQ x)"

lemma quant_eq_iff_mag_eq [si_eq]:
  "x = y \<longleftrightarrow> \<lbrakk>x\<rbrakk>\<^sub>Q = \<lbrakk>y\<rbrakk>\<^sub>Q"
  by (auto simp add: magQ_def, transfer, simp add: eq_unit)

lemma quant_eqI [si_transfer]:
  "\<lbrakk>x\<rbrakk>\<^sub>Q = \<lbrakk>y\<rbrakk>\<^sub>Q \<Longrightarrow> x = y"
  by (simp add: quant_eq_iff_mag_eq)

lemma quant_equiv_iff [si_eq]:
  fixes x :: "'a['u\<^sub>1::dim_type, 's::unit_system]" and y :: "'a['u\<^sub>2::dim_type, 's::unit_system]"
  shows "x \<cong>\<^sub>Q y \<longleftrightarrow> \<lbrakk>x\<rbrakk>\<^sub>Q = \<lbrakk>y\<rbrakk>\<^sub>Q \<and> QD('u\<^sub>1) = QD('u\<^sub>2)"
proof -
  have "\<forall>t ta. (ta::'a['u\<^sub>2, 's]) = t \<or> mag (fromQ ta) \<noteq> mag (fromQ t)"
    by (simp add: magQ_def quant_eq_iff_mag_eq)
  then show ?thesis
    by (metis (full_types) qequiv.rep_eq coerceQuant_eq_iff2 qeq magQ_def)
qed

lemma quant_equivI [si_transfer]:
  fixes x :: "'a['u\<^sub>1::dim_type, 's::unit_system]" and y :: "'a['u\<^sub>2::dim_type, 's::unit_system]"
  assumes "QD('u\<^sub>1) = QD('u\<^sub>2)" "QD('u\<^sub>1) = QD('u\<^sub>2) \<Longrightarrow> \<lbrakk>x\<rbrakk>\<^sub>Q = \<lbrakk>y\<rbrakk>\<^sub>Q"
  shows "x \<cong>\<^sub>Q y"
  using assms quant_equiv_iff by blast

lemma quant_le_iff_magn_le [si_eq]:
  "x \<le> y \<longleftrightarrow> \<lbrakk>x\<rbrakk>\<^sub>Q \<le> \<lbrakk>y\<rbrakk>\<^sub>Q"
  by (auto simp add: magQ_def; (transfer, simp))

lemma quant_leI [si_transfer]:
  "\<lbrakk>x\<rbrakk>\<^sub>Q \<le> \<lbrakk>y\<rbrakk>\<^sub>Q \<Longrightarrow> x \<le> y"
  by (simp add: quant_le_iff_magn_le)

lemma quant_less_iff_magn_less [si_eq]:
  "x < y \<longleftrightarrow> \<lbrakk>x\<rbrakk>\<^sub>Q < \<lbrakk>y\<rbrakk>\<^sub>Q"
  by (auto simp add: magQ_def; (transfer, simp))

lemma quant_lessI [si_transfer]:
  "\<lbrakk>x\<rbrakk>\<^sub>Q < \<lbrakk>y\<rbrakk>\<^sub>Q \<Longrightarrow> x < y"
  by (simp add: quant_less_iff_magn_less)

lemma magQ_zero [si_eq]: "\<lbrakk>0\<rbrakk>\<^sub>Q = 0"
  by (simp add: magQ_def, transfer, simp)

lemma magQ_one [si_eq]: "\<lbrakk>1\<rbrakk>\<^sub>Q = 1"
  by (simp add: magQ_def, transfer, simp)

lemma magQ_plus [si_eq]: "\<lbrakk>x + y\<rbrakk>\<^sub>Q = \<lbrakk>x\<rbrakk>\<^sub>Q + \<lbrakk>y\<rbrakk>\<^sub>Q"
  by (simp add: magQ_def, transfer, simp)

lemma magQ_minus [si_eq]: "\<lbrakk>x - y\<rbrakk>\<^sub>Q = \<lbrakk>x\<rbrakk>\<^sub>Q - \<lbrakk>y\<rbrakk>\<^sub>Q"
  by (simp add: magQ_def, transfer, simp)

lemma magQ_uminus [si_eq]: "\<lbrakk>- x\<rbrakk>\<^sub>Q = - \<lbrakk>x\<rbrakk>\<^sub>Q"
  by (simp add: magQ_def, transfer, simp)

lemma magQ_scaleQ [si_eq]: "\<lbrakk>x *\<^sub>Q y\<rbrakk>\<^sub>Q = x * \<lbrakk>y\<rbrakk>\<^sub>Q"
  by (simp add: magQ_def, transfer, simp)

lemma magQ_qtimes [si_eq]: "\<lbrakk>x \<^bold>\<cdot> y\<rbrakk>\<^sub>Q = \<lbrakk>x\<rbrakk>\<^sub>Q \<cdot> \<lbrakk>y\<rbrakk>\<^sub>Q"
  by (simp add: magQ_def, transfer, simp)

lemma magQ_qdivivide [si_eq]: "\<lbrakk>(x::('a::field)[_,_]) \<^bold>/ y\<rbrakk>\<^sub>Q = \<lbrakk>x\<rbrakk>\<^sub>Q / \<lbrakk>y\<rbrakk>\<^sub>Q"
  by (simp add: magQ_def, transfer, simp add: field_class.field_divide_inverse)

lemma magQ_numeral [si_eq]: "\<lbrakk>numeral n\<rbrakk>\<^sub>Q = numeral n"
  apply (induct n, simp_all add: si_def)
  apply (metis magQ_def magQ_one)
  apply (metis magQ_def magQ_plus numeral_code(2))
  apply (metis magQ_def magQ_one magQ_plus numeral_code(3))
  done

lemma magQ_coerce [si_eq]:
  fixes q :: "'a['d\<^sub>1::dim_type, 's::unit_system]" and t :: "'d\<^sub>2::dim_type itself"
  assumes "QD('d\<^sub>1) = QD('d\<^sub>2)"
  shows "\<lbrakk>coerceQuantT t q\<rbrakk>\<^sub>Q = \<lbrakk>q\<rbrakk>\<^sub>Q"
  by (simp add: coerceQuantT_def magQ_def assms, metis assms qequiv.rep_eq updown_eq_iff)

lemma dimQ [simp]: "dimQ(x :: 'a['d::dim_type, 's::unit_system]) = QD('d)"
  by (simp add: dimQ_def, transfer, simp)

text \<open> The following tactic breaks an SI conjecture down to numeric and unit properties \<close>

method si_simp uses add =
  (rule_tac si_transfer; simp add: add si_eq field_simps)

text \<open> The next tactic additionally compiles the semantics of the underlying units \<close>

method si_calc uses add =
  (si_simp add: add; simp add: si_def add)

lemma "QD(N \<cdot> \<Theta> \<cdot> N) = QD(\<Theta> \<cdot> N\<^sup>2)" by (simp add: si_eq si_def)

end


theory SubExt
imports SubRel
begin

section \<open>Extending subsomption relations\<close>

text \<open>In this section, we are interested in the evolution of the set of sub-paths of a rooted
graph equipped with a subsumption relation after adding a subsumption to this relation. We are
only interested in adding subsumptions such that the resulting relation is a well-formed
sub-relation of the graph (provided the original relation was such). As
for the extension
by edges, a number of side conditions must be met for the new subsumption to be added.\<close>

subsection \<open>Definition\<close>

text \<open>Extending a subsumption relation @{term subs} consists in adding a subsumption @{term "sub"}
such that:
\begin{itemize}
  \item the two vertices involved are distinct,
  \item they are occurrences of the same vertex,
  \item they are both vertices of the graph,
  \item the subsumee must not already be a subsumer or a subsumee,
  \item the subsumer must not be a subsumee (but it can already be a subsumer),
  \item the subsumee must have no out-edges.
\end{itemize}\<close>

text \<open>Once again, in order to ease proofs, we use a predicate stating when a
subsumpion relation is the extension of another instead of using a function that would produce the
extension.\<close>

abbreviation extends ::
  "(('v \<times> nat),'x) rgraph_scheme \<Rightarrow> 'v sub_rel_t \<Rightarrow> 'v sub_t \<Rightarrow> 'v sub_rel_t \<Rightarrow> bool"
where
  "extends g subs sub subs' \<equiv> (
     subsumee sub \<noteq> subsumer sub
   \<and> fst (subsumee sub)  = fst (subsumer sub)
   \<and> subsumee sub \<in> Graph.vertices g
   \<and> subsumee sub \<notin> subsumers subs
   \<and> subsumee sub \<notin> subsumees subs
   \<and> subsumer sub \<in> Graph.vertices g
   \<and> subsumer sub \<notin> subsumees subs
   \<and> out_edges g (subsumee sub) = {}
   \<and> subs' = subs \<union> {sub})"

subsection \<open>Properties of extensions\<close>

text \<open>First, we show that such extensions yield sub-relations (resp.\ well-formed relations),
provided the original relation is a sub-relation (resp.\ well-formed relation).\<close>

text \<open>Extending the sub-relation of a graph yields a new sub-relation for this graph.\<close>

lemma (in sub_rel_of)
  assumes "extends g subs sub subs'"
  shows   "sub_rel_of g subs'"
using assms sub_rel_of unfolding sub_rel_of_def by force

text \<open>Extending a well-formed relation yields a well-formed relation.\<close>

    assume "v \<in> subsumees subs'"

    hence  "v = subsumee sub \<or> v \<in> subsumees subs" using assms by auto

    thus "\<exists>! v'. (v,v') \<in> subs'"
    proof (elim disjE, goal_cases)
      case 1 show ?thesis
      unfolding Ex1_def
      proof (rule_tac ?x="subsumer sub" in exI, intro conjI)
        show "(v, subsumer sub) \<in> subs'" using 1 assms by simp
      next
        have "v \<notin> subsumees subs" using assms 1 by auto

        thus "\<forall> v'. (v, v') \<in> subs' \<longrightarrow> v' = subsumer sub"
        using assms by auto force
      qed
    next
      case 2

      then obtain v' where "(v,v') \<in> subs" by auto

      hence "v \<noteq> subsumee sub"
      using assms unfolding subsumees_conv by (force simp del : split_paired_All split_paired_Ex)

      show ?thesis
      using assms
            \<open>v \<noteq> subsumee sub\<close>
            \<open>(v,v') \<in> subs\<close> subsumed_by_one
      unfolding subsumees_conv Ex1_def
      by (rule_tac ?x="v'" in exI)
         (auto simp del : split_paired_All split_paired_Ex)
    qed
  qed
next
  case 3 show ?case using wf_sub_rel assms by auto
qed

text \<open>Thus, extending a well-formed sub-relation yields a well-formed sub-relation.\<close>

lemma (in wf_sub_rel_of) extends_imp_wf_sub_rel_of :
  assumes "extends g subs sub subs'"
  shows   "wf_sub_rel_of g subs'"
using sub_rel_of assms
      wf_sub_rel.extends_imp_wf_sub_rel[OF wf_sub_rel assms]
by (simp add : wf_sub_rel_of_def sub_rel_of_def)

subsection \<open>Properties of sub-paths in an extension\<close>

text \<open>Extending a sub-relation of a graph preserves the existing sub-paths.\<close>

lemma sp_in_extends :
  assumes "extends g subs sub subs'"
  assumes "subpath g v1 es v2 subs"
  shows   "subpath g v1 es v2 subs'"
using assms ces_Un[of v1 es v2 subs "{sub}"]
by (simp add : subpath_def sub_rel_of_def)

text \<open>We want to describe how the addition of a subsumption modifies the set of sub-paths in the
graph. As in the previous theories, we will focus on a small number of theorems expressing
sub-paths in extensions as functions of sub-paths in the graphs before extending them (their
subsumption relations).
We first express sub-paths starting at the subsumee of the new subsumption, then the sub-paths
starting at any other vertex.\<close>

text \<open>First, we are interested in sub-paths starting at the subsumee of the new subsumption. Since
such vertices have no out-edges, these sub-paths must be either empty or must  be sub-paths from
the subsumer of this subsumption.\<close>

lemma (in wf_sub_rel_of) sp_in_extends_imp1 :
  assumes "extends g subs (v1,v2) subs'"
  assumes "subpath g v1 es v subs'"
  shows   "es = [] \<or> subpath g v2 es v subs'"
using assms
      extends_imp_wf_sub_rel_of[OF assms(1)]
      wf_sub_rel_of.sp_from_subsumee[of g subs' v1 v2 es v]
by simp

text \<open>After an extension, sub-paths starting at any other vertex than the new subsumee are either:
\begin{itemize}
  \item sub-paths of the graph before the extension if they do not ``use'' the new subsumption,
  \item made of a finite number of sub-paths of the graph before the extension if they use the
new subsumption.
\end{itemize}
In order to state the lemmas expressing these facts, we first need to introduce the concept of
\emph{usage} of a subsumption by a sub-path.\<close>

text \<open>The idea is that, if a sequence of edges that uses a subsumption @{term sub} is consistent
wrt.\ a subsumption relation @{term subs}, then @{term sub} must occur in the transitive closure
of @{term subs} i.e.\ the consistency of the sequence directly (and partially) depends on
@{term sub}. In the case of well-formed subsumption relations, whose transitive
closures equal the relations themselves, the dependency of the consistency reduces to the fact that
@{term sub} is a member of @{term subs}.\<close>

fun uses_sub ::
  "('v \<times> nat) \<Rightarrow> ('v \<times> nat) edge list \<Rightarrow> ('v \<times> nat) \<Rightarrow> (('v \<times> nat) \<times> ('v \<times> nat)) \<Rightarrow> bool"
where
  "uses_sub v1 [] v2 sub     = (v1 \<noteq> v2 \<and> sub = (v1,v2))"
| "uses_sub v1 (e#es) v2 sub = (v1 \<noteq> src e \<and> sub = (v1,src e) \<or> uses_sub (tgt e) es v2 sub)"

text \<open>In order for a sequence @{term es} using the subsumption @{term sub} to be consistent wrt.\
to a subsumption relation @{term subs}, the subsumption @{term sub} must occur in the transitive
closure of @{term subs}.\<close>

lemma
  assumes "uses_sub v1 es v2 sub"
  assumes "ces v1 es v2 subs"
  shows   "sub \<in> subs\<^sup>+"
using assms by (induction es arbitrary : v1) fastforce+

text \<open>This reduces to the membership of @{term sub} to @{term subs} when the latter is
well-formed.\<close>

lemma (in wf_sub_rel)
  assumes "uses_sub v1 es v2 sub"
  assumes "ces v1 es v2 subs"
  shows   "sub \<in> subs"
using assms trancl_eq by (induction es arbitrary : v1) fastforce+

text \<open>Sub-paths prior to the extension do not use the new subsumption.\<close>

lemma extends_and_sp_imp_not_using_sub :
  assumes "extends g subs (v,v') subs'"
  assumes "subpath g v1 es v2 subs"
  shows   "\<not> uses_sub v1 es v2 (v,v')"
proof (intro notI)
  assume "uses_sub v1 es v2 (v,v')"

  moreover
  have "ces v1 es v2 subs" using assms(2) by (simp add : subpath_def)

  ultimately
  have "(v,v') \<in> subs\<^sup>+" by (induction es arbitrary : v1) fastforce+

  thus False
  using assms(1) unfolding subsumees_conv
  by (elim conjE) (frule tranclD, force)
qed

text \<open>Suppose that the empty sequence is a sub-path leading from @{term v1} to @{term v2} after
the extension. Then, the empty sequence is a sub-path leading from @{term v1} to @{term v2}
in the graph before the extension if and only if @{term "(v1,v2)"} is not the new subsumption.\<close>

lemma (in wf_sub_rel_of) sp_Nil_in_extends_imp :
  assumes "extends g subs (v,v') subs'"
  assumes "subpath g v1 [] v2 subs'"
  shows   "subpath g v1 [] v2 subs \<longleftrightarrow> (v1 \<noteq> v \<or> v2 \<noteq> v')"
proof (intro iffI, goal_cases)
  case 1 thus ?case
  using assms(1)
        extends_and_sp_imp_not_using_sub[OF assms(1), of v1 "[]" v2]
  by auto
next
  case 2

  have "v1 = v2 \<or> (v1,v2) \<in> subs'"
  and  "v1 \<in> Graph.vertices g"
  using assms(2)
        wf_sub_rel.extends_imp_wf_sub_rel[OF wf_sub_rel assms(1)]
  by (simp_all add : wf_sub_rel.Nil_sp)

  moreover
  hence "v1 = v2 \<or> (v1,v2) \<in> subs"
  using assms(1) 2 by auto

  moreover
  have "v2 \<in> Graph.vertices g"
  using assms(2) by (intro lst_of_sp_is_vert)

  ultimately
  show "subpath g v1 [] v2 subs"
  using sub_rel_of by (auto simp add : subpath_def)
qed

text \<open>Thus, sub-paths after the extension that do not use the new subsumption are also sub-paths
before the extension.\<close>

lemma (in wf_sub_rel_of) sp_in_extends_not_using_sub :
  assumes "extends g subs (v,v') subs'"
  assumes "subpath g v1 es v2 subs'"
  assumes "\<not> uses_sub v1 es v2 (v,v')"
  shows   "subpath g v1 es v2 subs"
using sub_rel_of assms extends_imp_wf_sub_rel_of
by (induction es arbitrary : v1)
   (auto simp add : sp_Nil_in_extends_imp wf_sub_rel_of.sp_Cons sp_Cons)

text \<open>We are finally able to describe sub-paths starting at any other vertex than the new
subsumee after the extension. Such sub-paths are made of a finite number of sub-paths before the
extension: the usage of the new subsumption between such (sub-)sub-paths makes them sub-paths
after the extension. We express this idea as follows. Sub-paths starting at any other vertex
than the new subsumee are either:
\begin{itemize}
  \item sub-paths of the graph before the extension,
  \item made of a non-empty prefix that is a sub-path leading to the new subsumee in the original
graph and a (potentially empty) suffix that is a sub-path starting at the new subsumer after
the extension.
\end{itemize}
For the second case, the lemma \verb?sp_in_extends_imp1? as well as the following lemma could be
applied to the suffix in order to decompose it into sub-paths of the graph before extension
(combined with the fact that we only consider finite sub-paths, we indirectly obtain that sub-paths
after the extension are made of a finite number of sub-paths before the extension, that are made
consistent with the new relation by using the new subsumption).\<close>

lemma (in wf_sub_rel_of) sp_in_extends_imp2 :
  assumes "extends g subs (v,v') subs'"
  assumes "subpath g v1 es v2 subs'"
  assumes "v1 \<noteq> v"

  shows   "subpath g v1 es v2 subs \<or> (\<exists> es1 es2. es = es1 @ es2
                                               \<and> es1 \<noteq> []
                                               \<and> subpath g v1 es1 v subs
                                               \<and> subpath g v es2 v2 subs')"
          (is "?P es v1")
proof (case_tac "uses_sub v1 es v2 (v,v')", goal_cases)
  case 1

  thus ?thesis
  using assms(2,3)
  proof (induction es arbitrary : v1)
    case (Nil v1) thus ?case by auto
  next
    case (Cons edge es v1)

    hence "v1 = src edge \<or> (v1, src edge) \<in> subs'"
    and   "edge \<in> edges g"
    and   "subpath g (tgt edge) es v2 subs'"
    using assms(1) extends_imp_wf_sub_rel_of
    by (simp_all add : wf_sub_rel_of.sp_Cons)

    hence "subpath g v1 [edge] (tgt edge) subs'"
    using  wf_sub_rel_of.sp_one[OF extends_imp_wf_sub_rel_of[OF assms(1)]]
    by (simp add : subpath_def) fast

    have "subpath g v1 [edge] (tgt edge) subs"
    proof -
      have "\<not> uses_sub v1 [edge] (tgt edge) (v,v')"
      using assms(1) Cons(2,4) by auto

      thus ?thesis
      using assms(1) \<open>subpath g v1 [edge] (tgt edge) subs'\<close>
      by (elim sp_in_extends_not_using_sub)
    qed

    thus ?case
    proof (case_tac "tgt edge = v", goal_cases)
      case 1 thus ?thesis
      using \<open>subpath g v1 [edge] (tgt edge) subs\<close>
            \<open>subpath g (tgt edge) es v2 subs'\<close>
      by (intro disjI2, rule_tac ?x="[edge]" in exI) auto
    next
      case 2

      moreover
      have "uses_sub (tgt edge) es v2 (v,v')" using Cons(2,4) by simp

      ultimately
      have "?P es (tgt edge)"
      using \<open>subpath g (tgt edge) es v2 subs'\<close>
      by (intro Cons.IH)

      thus ?thesis
      proof (elim disjE exE conjE, goal_cases)
        case 1 thus ?thesis
        using \<open>subpath g (tgt edge) es v2 subs'\<close>
              \<open>uses_sub (tgt edge) es v2 (v,v')\<close>
              extends_and_sp_imp_not_using_sub[OF assms(1)]
        by fast
      next
        case (2 es1 es2) thus ?thesis
        using \<open>es = es1 @ es2\<close>
              \<open>subpath g v1 [edge] (tgt edge) subs\<close>
              \<open>subpath g v es2 v2 subs'\<close>
        by (intro disjI2, rule_tac ?x="edge # es1" in exI) (auto simp add : sp_Cons)
      qed
    qed
  qed
next
  case 2 thus ?thesis
  using assms(1,2) by (simp add : sp_in_extends_not_using_sub)
qed

end


(*File: AssocLists.thy
  Author: L Beringer & M Hofmann, LMU Munich
  Date: 05/12/2008
  Purpose: Representation of partial maps by association lists
*)
(*<*)
theory AssocLists imports Main begin
(*>*)

section\<open>Preliminaries: association lists \label{sec:preliminaries}\<close>

text\<open>Finite maps are used frequently, both in the representation of
syntax and in the program logics. Instead of restricting Isabelle's
partial map type $\alpha \rightharpoonup \beta$ to finite domains, we
found it easier for the present development to use the following adhoc
data type of association lists.\<close>

type_synonym ('a,'b) AssList = "('a \<times> 'b) list"

primrec lookup::"('a, 'b) AssList \<Rightarrow> 'a \<Rightarrow> ('b option)" ("_\<down>_" [90,0] 90)
where
"lookup [] l = None" |
"lookup (h # t) l = (if fst h = l then Some(snd h) else lookup t l)"

(*<*)
lemma AL_lookup1[rule_format]:"\<forall> a b . (L\<down>a = Some b) \<longrightarrow> ((a,b) \<in> set L)"
by (induct L, simp_all)(* add: set_mem_eq)*)

lemma AL_Triv1:"a=b \<Longrightarrow> L\<down>a = L\<down>b" by simp

lemma AL_Triv2: "\<lbrakk>L\<down>a = X; L\<down>a = Y\<rbrakk> \<Longrightarrow> X=Y" by simp

lemma AL_Triv3:"\<lbrakk>L=M ; M\<down>b = X\<rbrakk> \<Longrightarrow> L\<down>b = X" by clarsimp

lemma AL_Triv4:"\<lbrakk>L=M ; L\<down>b = X\<rbrakk> \<Longrightarrow> M\<down>b = X" by clarsimp
(*>*)

text\<open>The statement following the type declaration of \<open>lookup\<close>
indicates that we may use the infix notation \<open>L\<down>a\<close> for the
lookup operation, and asserts some precedence for bracketing. In a
similar way, shorthands are introduced for various operations
throughout this document.\<close>

primrec delete::"('a, 'b) AssList \<Rightarrow> 'a \<Rightarrow> ('a, 'b) AssList"
where
"delete [] a = []" |
"delete (h # t) a = (if (fst h) = a then delete t a else (h # (delete t a)))"

(*<*)
lemma AL_delete1: "(delete L a) \<down> a = None"
by (induct L, auto)

lemma AL_delete2[rule_format]:"b \<noteq> a \<longrightarrow> (delete l a)\<down>b = l\<down>b"
by (induct l, simp, simp)

lemma AL_delete3: "L\<down>a = None \<Longrightarrow> delete L a = L"
apply (induct L)
apply simp
apply clarsimp
apply (subgoal_tac "L\<down>a = None", clarsimp)
apply (case_tac "aa=a", clarsimp) apply clarsimp
done

lemma AL_delete4[simp]: "length(delete t a) < Suc(length t)"
by (induct t, simp+)

lemma AL_delete5[rule_format]:"[|b \<noteq> a; l\<down>b = x|] ==> (delete l a)\<down>b = x"
by (drule_tac l=l in AL_delete2, simp)

lemma AL_delete_idempotent: "delete M x = delete (delete M x) x"
by (induct M, auto)

lemma AL_delete_commutative: "delete (delete M c) x = delete (delete M x) c"
apply (induct M)
apply simp
apply simp
done
(*>*)

definition upd::"('a, 'b) AssList \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) AssList"
         ("_[_\<mapsto>_]" [1000,0,0] 1000)
where "upd L a b = (a,b) # (delete L a)"
(*<*)
lemma AL_update1: "(L::('a, 'b) AssList)[a\<mapsto>b]\<down>a = Some b"
by (simp add: upd_def)

lemma AL_update1a: "a=c \<Longrightarrow> (L::('a, 'b) AssList)[a\<mapsto>b]\<down>c = Some b" by (simp add: AL_update1)

lemma AL_update2: "a \<noteq> b \<Longrightarrow> (L::('a, 'b) AssList)[a\<mapsto>v]\<down>b = L\<down>b"
by (induct L, simp_all add: upd_def)

lemma AL_update4:"\<lbrakk> (L::('a, 'b) AssList)\<down>b = Some X; a \<noteq> b\<rbrakk>\<Longrightarrow> L[a\<mapsto>v]\<down>b = Some X"
by (subgoal_tac "(L::('a, 'b) AssList)[a\<mapsto>v]\<down>b = L\<down>b", clarsimp, erule AL_update2)

lemma AL_update5: "\<lbrakk>(L::('a, 'b) AssList)\<down>b = M; a \<noteq> b\<rbrakk> \<Longrightarrow> L[a\<mapsto>X]\<down>b = M"
apply (subgoal_tac "(L::('a, 'b) AssList)[a\<mapsto>X]\<down>b = L\<down>b", simp)
apply (erule AL_update2)
done
(*>*)

text\<open>The empty map is represented by the empty list.\<close>

definition emp::"('a, 'b)AssList"
where "emp = []"
(*<*)
lemma AL_emp1: "emp\<down>a = None"
by (simp add: emp_def)

definition AL_isEmp::"('a,'b) AssList \<Rightarrow> bool"
where "AL_isEmp l = (\<forall> a . l\<down>a = None)"
(*>*)

definition contained::"('a,'b) AssList \<Rightarrow> ('a,'b) AssList \<Rightarrow> bool"
where "contained L M = (\<forall> a b . L\<down>a = Some b \<longrightarrow> M\<down>a = Some b)"

text\<open>The following operation defined the cardinality of a map.\<close>

fun AL_Size :: "('a, 'b) AssList \<Rightarrow> nat"  ("|_|" [1000] 1000) where
  "AL_Size [] = 0"
| "AL_Size (h # t) = Suc (AL_Size (delete t (fst h)))"

(*<*)
lemma AL_Size_Zero: "|L| = 0 \<Longrightarrow> None = L\<down>a"
by (induct L, simp, simp)

lemma AL_Size_Suc: "\<forall> n . |L| = Suc n \<longrightarrow> (\<exists> a b . L\<down>a = Some b)"
apply (induct L)
apply clarsimp
apply clarsimp
apply (rule_tac x=a in exI, simp)
done

lemma AL_Size_UpdateSuc:"L\<down>a = None \<Longrightarrow> |L[a\<mapsto>b]| = Suc |L|"
apply (induct L)
apply (simp add: upd_def)
apply (simp add: upd_def)
apply clarsimp
apply (case_tac "aa=a", clarsimp)
apply clarsimp
apply (drule AL_delete3) apply clarsimp
done

lemma AL_Size_SucSplit[rule_format]:
"\<forall> n . |L| = Suc n \<longrightarrow>
  (\<exists> a b M . |M| = n \<and> M\<down>a = None \<and> L\<down>a = Some b \<and> (\<forall> c . c\<noteq> a \<longrightarrow> M\<down>c = L\<down>c))"
apply (induct L)
apply clarsimp
apply clarsimp
apply (rule_tac x=a in exI)  apply simp
apply (rule_tac x="delete L a" in exI, clarsimp)
  apply rule  apply (rule AL_delete1)
apply clarsimp apply (erule AL_delete2)
done

lemma updSizeAux[rule_format]:
"\<forall> h a obj obj1 . |h[a\<mapsto>obj1]| = n \<longrightarrow> h\<down>a = Some obj \<longrightarrow> |h| = n"
apply (induct n)
apply clarsimp
  apply (drule_tac a=a in AL_Size_Zero) apply (simp add: AL_update1)
apply clarify
  apply (case_tac h, clarify) apply (erule thin_rl) apply (simp add: AL_emp1)
  apply clarify
  apply (case_tac "aa=a", clarify) apply (erule thin_rl) apply (simp add: upd_def)
    apply (subgoal_tac "(delete list a) = (delete (delete list a) a)", simp)
    apply (rule AL_delete_idempotent)
  apply (erule_tac x="delete list aa" in allE, erule_tac x=a in allE)
  apply (erule_tac x=obj in allE, erule_tac x=obj1 in allE)
  apply (erule impE) apply (simp add: upd_def)
    apply (subgoal_tac "(delete (delete (delete list aa) a) a) = (delete (delete (delete list a) a) aa)", simp)
    apply (subgoal_tac "(delete (delete list a) a) = (delete list a)", simp)
      apply (subgoal_tac "delete (delete (delete list aa) a) a = delete (delete list aa) a", simp)
        apply (rule AL_delete_commutative)
      apply (subgoal_tac "delete (delete list aa) a = delete (delete (delete list aa) a) a", simp)
      apply (rule AL_delete_idempotent)
    apply (subgoal_tac "delete list a = delete (delete list a) a", simp)
    apply (rule AL_delete_idempotent)
  apply (erule impE) apply (simp add: upd_def) apply (rule AL_delete5) apply fast apply assumption
  apply simp
done

lemma updSize: "h\<down>a = Some obj \<Longrightarrow> |h[a\<mapsto>obj1]| = |h|"
by (insert updSizeAux [of h a obj1 "|h[a\<mapsto>obj1]|" obj], simp)
(*>*)

text\<open>Some obvious basic properties of association lists and their
operations are easily proven, but have been suppressed
during the document preparation.\<close>

(*<*)
end
(*>*)


(*  Title:       Syntactic Ordinals in Cantor Normal Form
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2017
    Author:      Dmitriy Traytel <traytel at inf.ethz.ch>, 2017
*)

theory Syntactic_Ordinal_Bridge
imports "HOL-Library.Sublist" Ordinal.OrdinalOmega Syntactic_Ordinal
abbrevs
  "!h" = "\<^sub>h"
begin

section \<open>Bridge between Huffman's Ordinal Library and the Syntactic Ordinals\<close>

subsection \<open>Missing Lemmas about Huffman's Ordinals\<close>

instantiation ordinal :: order_bot
begin

definition bot_ordinal :: ordinal where
  "bot_ordinal = 0"

instance
  by intro_classes (simp add: bot_ordinal_def)

end

lemmas insort_0_ordinal[simp] = insort_bot[of "xs :: ordinal list" for xs, unfolded bot_ordinal_def]

lemma from_cnf_less_\<omega>_exp:
  assumes "\<forall>k \<in> set ks. k < l"
  shows "from_cnf ks < \<omega> ** l"
  using assms by (induct ks) (auto simp: additive_principal.sum_less additive_principal_omega_exp)

lemma from_cnf_0_iff[simp]: "from_cnf ks = 0 \<longleftrightarrow> ks = []"
  by (induct ks) (auto simp: ordinal_plus_not_0)

lemma from_cnf_append[simp]: "from_cnf (ks @ ls) = from_cnf ks + from_cnf ls"
  by (induct ks) (auto simp: ordinal_plus_assoc)

lemma subseq_from_cnf_less_eq: "Sublist.subseq ks ls \<Longrightarrow> from_cnf ks \<le> from_cnf ls"
  by (induct rule: list_emb.induct) (auto intro: ordinal_le_plusL order_trans)

subsection \<open>Embedding of Syntactic Ordinals into Huffman's Ordinals\<close>

abbreviation \<omega>\<^sub>h :: hmultiset where
  "\<omega>\<^sub>h \<equiv> Syntactic_Ordinal.\<omega>"

abbreviation \<omega>\<^sub>h_exp :: "hmultiset \<Rightarrow> hmultiset" ("\<omega>\<^sub>h^") where
  "\<omega>\<^sub>h^ \<equiv> Syntactic_Ordinal.\<omega>_exp"

primrec ordinal_of_hmset :: "hmultiset \<Rightarrow> ordinal" where
  "ordinal_of_hmset (HMSet M) =
   from_cnf (rev (sorted_list_of_multiset (image_mset ordinal_of_hmset M)))"

lemma ordinal_of_hmset_0[simp]: "ordinal_of_hmset 0 = 0"
  unfolding zero_hmultiset_def by simp

lemma ordinal_of_hmset_suc[simp]: "ordinal_of_hmset (k + 1) = ordinal_of_hmset k + 1"
  unfolding plus_hmultiset_def one_hmultiset_def by (cases k) simp

lemma ordinal_of_hmset_1[simp]: "ordinal_of_hmset 1 = 1"
  using ordinal_of_hmset_suc[of 0] by simp

lemma ordinal_of_hmset_singleton[simp]: "ordinal_of_hmset (\<omega>^k) = \<omega> ** ordinal_of_hmset k"
  by simp

lemma ordinal_of_hmset_iff[simp]: "ordinal_of_hmset k = 0 \<longleftrightarrow> k = 0"
  by (induct k) auto

lemma less_imp_ordinal_of_hmset_less: "k < l \<Longrightarrow> ordinal_of_hmset k < ordinal_of_hmset l"
proof (simp only: atomize_imp,
    rule measure_induct_rule[of "\<lambda>(k, l). {#k, l#}"
        "\<lambda>(k, l). k < l \<longrightarrow> ordinal_of_hmset k < ordinal_of_hmset l" "(k, l)",
      simplified prod.case],
    simp only: split_paired_all prod.case atomize_imp[symmetric])
  fix k l
  assume
    ih: "\<And>ka la. {#ka, la#} < {#k, l#} \<Longrightarrow> ka < la \<Longrightarrow> ordinal_of_hmset ka < ordinal_of_hmset la" and
    k_lt_l: "k < l"

  show "ordinal_of_hmset k < ordinal_of_hmset l"
  proof (cases "k = 0")
    case True
    thus ?thesis
      using k_lt_l ordinal_neq_0 by fastforce
  next
    case k_nz: False

    have l_nz: "l \<noteq> 0"
      using k_lt_l by auto

    define K where K: "K = hmsetmset k"
    define L where L: "L = hmsetmset l"

    have k: "k = HMSet K" and l: "l = HMSet L"
      by (simp_all add: K L)

    have K_lt_L: "K < L"
      unfolding K L using k_lt_l by simp

    define x where x: "x = Max_mset K"
    define Ka where Ka: "Ka = K - {#x#}"

    have k_eq_xKa: "k = HMSet (add_mset x Ka)"
      using K x Ka k_nz by auto
    have x_max: "\<forall>a \<in># Ka. a \<le> x"
      unfolding x Ka by (meson Max_ge finite_set_mset in_diffD)

    have ord_x_max: "\<forall>a \<in># Ka. ordinal_of_hmset a \<le> ordinal_of_hmset x"
    proof
      fix a
      assume a_in: "a \<in># Ka"

      have a_le_x: "a \<le> x"
        by (simp add: x_max a_in)
      moreover
      {
        assume a_lt_x: "a < x"
        moreover have x_lt_k: "x < k"
          unfolding k_eq_xKa by (rule mem_imp_less_HMSet) simp
        ultimately have a_lt_k: "a < k"
          by simp

        have "{#a, x#} < {#k#}"
          using x_lt_k a_lt_k by simp
        also have "\<dots> < {#k, l#}"
          unfolding k_eq_xKa using a_in
          by simp
        finally have "ordinal_of_hmset a < ordinal_of_hmset x"
          by (rule ih[OF _ a_lt_x])
      }
      ultimately show "ordinal_of_hmset a \<le> ordinal_of_hmset x"
        by force
    qed

    define y where y: "y = Max_mset L"
    define La where La: "La = L - {#y#}"

    have l_eq_yLa: "l = HMSet (add_mset y La)"
      using L y La l_nz by auto
    have y_max: "\<forall>b \<in># La. b \<le> y"
      unfolding y La by (meson Max_ge finite_set_mset in_diffD)

    have ord_y_max: "\<forall>b \<in># La. ordinal_of_hmset b \<le> ordinal_of_hmset y"
    proof
      fix b
      assume b_in: "b \<in># La"

      have b_le_y: "b \<le> y"
        by (simp add: y_max b_in)
      moreover
      {
        assume b_lt_y: "b < y"
        moreover have y_lt_l: "y < l"
          unfolding l_eq_yLa by (rule mem_imp_less_HMSet) simp
        ultimately have b_lt_l: "b < l"
          by simp

        have "{#b, y#} < {#l#}"
          using y_lt_l b_lt_l by simp
        also have "\<dots> < {#k, l#}"
          unfolding l_eq_yLa using b_in
          by simp
        finally have "ordinal_of_hmset b < ordinal_of_hmset y"
          by (rule ih[OF _ b_lt_y])
      }
      ultimately show "ordinal_of_hmset b \<le> ordinal_of_hmset y"
        by force
    qed

    {
      assume x_eq_y: "x = y"

      have "ordinal_of_hmset (HMSet Ka) < ordinal_of_hmset (HMSet La)"
      proof (rule ih)
        show "{#HMSet Ka, HMSet La#} < {#k, l#}"
          unfolding k l
          by (metis add_mset_add_single hmsetmset_less hmultiset.sel k k_eq_xKa l l_eq_yLa
            le_multiset_right_total mset_lt_single_iff union_less_mono)
      next
        have "\<omega>^x + HMSet Ka < \<omega>^y + HMSet La"
          using k_lt_l[unfolded k_eq_xKa l_eq_yLa]
          by (metis HMSet_plus add.commute add_mset_add_single)
        thus "HMSet Ka < HMSet La"
          using x_eq_y by simp
      qed
      hence ?thesis
        unfolding k_eq_xKa l_eq_yLa
        by (simp, subst (1 2) sorted_insort_is_snoc, simp_all add: ord_x_max ord_y_max,
          force simp: x_eq_y)
    }
    moreover
    {
      assume x_ne_y: "x \<noteq> y"

      have x_lt_y: "x < y"
        by (metis K L head_\<omega>_def head_\<omega>_lt_imp_lt hmsetmset_less hmultiset.sel k_lt_l k_nz l_nz
          less_imp_not_less mset_lt_single_iff neqE x x_ne_y y)

      have ord_y_smax_K: "ordinal_of_hmset a < ordinal_of_hmset y" if a_in_K: "a \<in># K" for a
      proof (rule ih)
        show "{#a, y#} < {#k, l#}"
          unfolding k_eq_xKa l_eq_yLa using a_in_K k k_eq_xKa
          by (metis add_mset_add_single mem_imp_less_HMSet mset_lt_single_iff union_less_mono
            union_single_eq_member)
      next
        show "a < y"
          by (metis Max_ge finite_set_mset less_le_trans not_less_iff_gr_or_eq that x x_lt_y)
      qed

      have "ordinal_of_hmset k < ordinal_of_hmset (\<omega>^y)"
      proof (cases La)
        case empty
        show ?thesis
          unfolding k by (auto intro!: from_cnf_less_\<omega>_exp simp: ord_y_smax_K)
      next
        case La: (add ya Lb)
        show ?thesis
        proof (rule ih)
          show "{#k, \<omega>^y#} < {#k, l#}"
            unfolding l_eq_yLa La by simp
        next
          show "k < \<omega>^y"
          proof -
            have "\<And>m. x < Max_mset (add_mset y m)"
              by (meson Max_ge finite_set_mset less_le_trans union_single_eq_member x_lt_y)
            then show ?thesis
              by (metis K x head_\<omega>_def head_\<omega>_lt_imp_lt hmsetmset_less hmultiset.sel k_nz
                mset_lt_single_iff x_lt_y)
          qed
        qed
      qed
      also have "\<dots> \<le> ordinal_of_hmset l"
        unfolding l_eq_yLa
        by (auto simp del: from_cnf.simps intro!: subseq_from_cnf_less_eq
          simp: subseq_from_cnf_less_eq sorted_insort_is_snoc ord_y_max)
      ultimately have ?thesis
        by simp
    }
    ultimately show ?thesis
      by sat
  qed
qed

lemma ordinal_of_hmset_less[simp]: "ordinal_of_hmset k < ordinal_of_hmset l \<longleftrightarrow> k < l"
  using less_imp_not_less less_imp_ordinal_of_hmset_less neq_iff by blast

end


theory Name_Exec
imports "../../Nominal2"
begin

atom_decl name

definition Name :: "nat \<Rightarrow> name" where "Name n = Abs_name (Atom (Sort ''Name_Exec.name'' []) n)"

definition "nat_of_name n = nat_of (Rep_name n)"

code_datatype Name

definition [code]: "N0 = Name 0"
definition [code]: "N1 = Name 1"
definition [code]: "N2 = Name 2"

instantiation name :: equal begin

definition equal_name_def: "equal_name a b \<longleftrightarrow> nat_of_name a = nat_of_name b"

instance
  by default
    (metis (lifting) Rep_name_inject atom_components_eq_iff atom_name_def equal_name_def nat_of_name_def sort_of_atom_eq)

end

lemma equal_name_code [code]: "(equal_class.equal (Name x) (Name y)) \<longleftrightarrow> (x = y)"
  by (auto simp add: equal_name_def)

lemma atom_name_code[code]:
  "atom (Name n) = Atom (Sort ''Name_Exec.name'' []) n"
  by (simp add: Abs_name_inject[symmetric] Name_def)
     (simp add: atom_name_def Rep_name_inverse)

lemma permute_name_code[code]: "p \<bullet> n = Name (nat_of (p \<bullet> (atom n)))"
  apply (simp add: atom_eqvt)
  apply (simp add: atom_name_def Name_def)
  by (metis Rep_name_inverse atom_name_def atom_name_sort nat_of.simps sort_of.simps atom.exhaust)

(*
Test:
definition "t \<longleftrightarrow> 0 = (N0 \<leftrightarrow> N1)"

export_code t in SML

value "(N0 \<leftrightarrow> N1) + (N1 \<leftrightarrow> N0) = 0"
*)

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_sort_NStoogeSort2IsSort
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

(*fun did not finish the proof*)
function twoThirds :: "int => int" where
  "twoThirds y =
   (if (y = 2) then 1 else
      (if (y = 1) then 1 else
         (if (y = 0) then 0 else 2 + (twoThirds (y - 3)))))"
  by pat_completeness auto

(*fun did not finish the proof*)
function third :: "int => int" where
  "third y =
   (if (y = 2) then 0 else
      (if (y = 1) then 0 else
         (if (y = 0) then 0 else 1 + (third (y - 3)))))"
  by pat_completeness auto

fun take :: "int => 'a list => 'a list" where
  "take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
  "sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun insert :: "int => int list => int list" where
  "insert y (nil2) = cons2 y (nil2)"
| "insert y (cons2 z2 xs) =
     (if y <= z2 then cons2 y (cons2 z2 xs) else
        cons2 z2 (insert y xs))"

fun isort :: "int list => int list" where
  "isort (nil2) = nil2"
| "isort (cons2 z xs) = insert z (isort xs)"

fun drop :: "int => 'a list => 'a list" where
  "drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge2sort2 :: "int list => int list"
  and nstoogesort2 :: "int list => int list"
  and nstooge2sort1 :: "int list => int list" where
  "nstooge2sort2 y =
   (case splitAt (twoThirds (length y)) y of
      pair2 ys2 zs1 => x (nstoogesort2 ys2) zs1)"
| "nstoogesort2 (nil2) = nil2"
| "nstoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge2sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort2 zs1))"
  by pat_completeness auto

theorem property0 :
  "((nstoogesort2 xs) = (isort xs))"
  oops

end