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

(* Author: Jeremy Dawson, NICTA *)

section \<open>Operation variants with traditional syntax\<close>

theory Traditional_Infix_Syntax
  imports "HOL-Library.Word" More_Word Signed_Words
begin

class semiring_bit_syntax = semiring_bit_shifts
begin

definition test_bit :: \<open>'a \<Rightarrow> nat \<Rightarrow> bool\<close>  (infixl "!!" 100)
  where test_bit_eq_bit: \<open>test_bit = bit\<close>

definition shiftl :: \<open>'a \<Rightarrow> nat \<Rightarrow> 'a\<close>  (infixl "<<" 55)
  where shiftl_eq_push_bit: \<open>a << n = push_bit n a\<close>

definition shiftr :: \<open>'a \<Rightarrow> nat \<Rightarrow> 'a\<close>  (infixl ">>" 55)
  where shiftr_eq_drop_bit: \<open>a >> n = drop_bit n a\<close>

end

instance word :: (len) semiring_bit_syntax ..

context
  includes lifting_syntax
begin

lemma test_bit_word_transfer [transfer_rule]:
  \<open>(pcr_word ===> (=)) (\<lambda>k n. n < LENGTH('a) \<and> bit k n) (test_bit :: 'a::len word \<Rightarrow> _)\<close>
  by (unfold test_bit_eq_bit) transfer_prover

lemma shiftl_word_transfer [transfer_rule]:
  \<open>(pcr_word ===> (=) ===> pcr_word) (\<lambda>k n. push_bit n k) shiftl\<close>
  by (unfold shiftl_eq_push_bit) transfer_prover

lemma shiftr_word_transfer [transfer_rule]:
  \<open>(pcr_word ===> (=) ===> pcr_word) (\<lambda>k n. (drop_bit n \<circ> take_bit LENGTH('a)) k) (shiftr :: 'a::len word \<Rightarrow> _)\<close>
  by (unfold shiftr_eq_drop_bit) transfer_prover

end

lemma test_bit_word_eq:
  \<open>test_bit = (bit :: 'a::len word \<Rightarrow> _)\<close>
  by (fact test_bit_eq_bit)

lemma shiftl_word_eq:
  \<open>w << n = push_bit n w\<close> for w :: \<open>'a::len word\<close>
  by (fact shiftl_eq_push_bit)

lemma shiftr_word_eq:
  \<open>w >> n = drop_bit n w\<close> for w :: \<open>'a::len word\<close>
  by (fact shiftr_eq_drop_bit)

lemma test_bit_eq_iff: "test_bit u = test_bit v \<longleftrightarrow> u = v"
  for u v :: "'a::len word"
  by (simp add: bit_eq_iff test_bit_eq_bit fun_eq_iff)

lemma test_bit_size: "w !! n \<Longrightarrow> n < size w"
  for w :: "'a::len word"
  by transfer simp

lemma word_eq_iff: "x = y \<longleftrightarrow> (\<forall>n<LENGTH('a). x !! n = y !! n)" (is \<open>?P \<longleftrightarrow> ?Q\<close>)
  for x y :: "'a::len word"
  by transfer (auto simp add: bit_eq_iff bit_take_bit_iff)

lemma word_eqI: "(\<And>n. n < size u \<longrightarrow> u !! n = v !! n) \<Longrightarrow> u = v"
  for u :: "'a::len word"
  by (simp add: word_size word_eq_iff)

lemma word_eqD: "u = v \<Longrightarrow> u !! x = v !! x"
  for u v :: "'a::len word"
  by simp

lemma test_bit_bin': "w !! n \<longleftrightarrow> n < size w \<and> bit (uint w) n"
  by transfer (simp add: bit_take_bit_iff)

lemmas test_bit_bin = test_bit_bin' [unfolded word_size]

lemma word_test_bit_def:
  \<open>test_bit a = bit (uint a)\<close>
  by transfer (simp add: fun_eq_iff bit_take_bit_iff)

lemmas test_bit_def' = word_test_bit_def [THEN fun_cong]

lemma word_test_bit_transfer [transfer_rule]:
  "(rel_fun pcr_word (rel_fun (=) (=)))
    (\<lambda>x n. n < LENGTH('a) \<and> bit x n) (test_bit :: 'a::len word \<Rightarrow> _)"
  by (simp only: test_bit_eq_bit) transfer_prover

lemma test_bit_wi [simp]:
  "(word_of_int x :: 'a::len word) !! n \<longleftrightarrow> n < LENGTH('a) \<and> bit x n"
  by transfer simp

lemma word_ops_nth_size:
  "n < size x \<Longrightarrow>
    (x OR y) !! n = (x !! n | y !! n) \<and>
    (x AND y) !! n = (x !! n \<and> y !! n) \<and>
    (x XOR y) !! n = (x !! n \<noteq> y !! n) \<and>
    (NOT x) !! n = (\<not> x !! n)"
  for x :: "'a::len word"
  by transfer (simp add: bit_or_iff bit_and_iff bit_xor_iff bit_not_iff)

lemma word_ao_nth:
  "(x OR y) !! n = (x !! n | y !! n) \<and>
    (x AND y) !! n = (x !! n \<and> y !! n)"
  for x :: "'a::len word"
  by transfer (auto simp add: bit_or_iff bit_and_iff)

lemmas msb0 = len_gt_0 [THEN diff_Suc_less, THEN word_ops_nth_size [unfolded word_size]]
lemmas msb1 = msb0 [where i = 0]

lemma test_bit_numeral [simp]:
  "(numeral w :: 'a::len word) !! n \<longleftrightarrow>
    n < LENGTH('a) \<and> bit (numeral w :: int) n"
  by transfer (rule refl)

lemma test_bit_neg_numeral [simp]:
  "(- numeral w :: 'a::len word) !! n \<longleftrightarrow>
    n < LENGTH('a) \<and> bit (- numeral w :: int) n"
  by transfer (rule refl)

lemma test_bit_1 [iff]: "(1 :: 'a::len word) !! n \<longleftrightarrow> n = 0"
  by transfer (auto simp add: bit_1_iff)

lemma nth_0 [simp]: "\<not> (0 :: 'a::len word) !! n"
  by transfer simp

lemma nth_minus1 [simp]: "(-1 :: 'a::len word) !! n \<longleftrightarrow> n < LENGTH('a)"
  by transfer simp

lemma shiftl1_code [code]:
  \<open>shiftl1 w = push_bit 1 w\<close>
  by transfer (simp add: ac_simps)

lemma uint_shiftr_eq:
  \<open>uint (w >> n) = uint w div 2 ^ n\<close>
  by transfer (simp flip: drop_bit_eq_div add: drop_bit_take_bit min_def le_less less_diff_conv)

lemma shiftr1_code [code]:
  \<open>shiftr1 w = drop_bit 1 w\<close>
  by transfer (simp add: drop_bit_Suc)

lemma shiftl_def:
  \<open>w << n = (shiftl1 ^^ n) w\<close>
proof -
  have \<open>push_bit n = (((*) 2 ^^ n) :: int \<Rightarrow> int)\<close> for n
    by (induction n) (simp_all add: fun_eq_iff funpow_swap1, simp add: ac_simps)
  then show ?thesis
    by transfer simp
qed

lemma shiftr_def:
  \<open>w >> n = (shiftr1 ^^ n) w\<close>
proof -
  have \<open>shiftr1 ^^ n = (drop_bit n :: 'a word \<Rightarrow> 'a word)\<close>
    apply (induction n)
    apply simp
    apply (simp only: shiftr1_eq_div_2 [abs_def] drop_bit_eq_div [abs_def] funpow_Suc_right)
    apply (use div_exp_eq [of _ 1, where ?'a = \<open>'a word\<close>] in simp)
    done
  then show ?thesis
    by (simp add: shiftr_eq_drop_bit)
qed

lemma bit_shiftl_word_iff [bit_simps]:
  \<open>bit (w << m) n \<longleftrightarrow> m \<le> n \<and> n < LENGTH('a) \<and> bit w (n - m)\<close>
  for w :: \<open>'a::len word\<close>
  by (simp add: shiftl_word_eq bit_push_bit_iff not_le)

lemma bit_shiftr_word_iff [bit_simps]:
  \<open>bit (w >> m) n \<longleftrightarrow> bit w (m + n)\<close>
  for w :: \<open>'a::len word\<close>
  by (simp add: shiftr_word_eq bit_drop_bit_eq)

lift_definition sshiftr :: \<open>'a::len word \<Rightarrow> nat \<Rightarrow> 'a word\<close>  (infixl \<open>>>>\<close> 55)
  is \<open>\<lambda>k n. take_bit LENGTH('a) (drop_bit n (signed_take_bit (LENGTH('a) - Suc 0) k))\<close>
  by (simp flip: signed_take_bit_decr_length_iff)

lemma sshiftr_eq [code]:
  \<open>w >>> n = signed_drop_bit n w\<close>
  by transfer simp

lemma sshiftr_eq_funpow_sshiftr1:
  \<open>w >>> n = (sshiftr1 ^^ n) w\<close>
  apply (rule sym)
  apply (simp add: sshiftr1_eq_signed_drop_bit_Suc_0 sshiftr_eq)
  apply (induction n)
   apply simp_all
  done

lemma uint_sshiftr_eq:
  \<open>uint (w >>> n) = take_bit LENGTH('a) (sint w div 2 ^  n)\<close>
  for w :: \<open>'a::len word\<close>
  by transfer (simp flip: drop_bit_eq_div)

lemma sshift1_code [code]:
  \<open>sshiftr1 w = signed_drop_bit 1 w\<close>
  by transfer (simp add: drop_bit_Suc)

lemma sshiftr_0 [simp]: "0 >>> n = 0"
  by transfer simp

lemma sshiftr_n1 [simp]: "-1 >>> n = -1"
  by transfer simp

lemma bit_sshiftr_word_iff [bit_simps]:
  \<open>bit (w >>> m) n \<longleftrightarrow> bit w (if LENGTH('a) - m \<le> n \<and> n < LENGTH('a) then LENGTH('a) - 1 else (m + n))\<close>
  for w :: \<open>'a::len word\<close>
  apply transfer
  apply (auto simp add: bit_take_bit_iff bit_drop_bit_eq bit_signed_take_bit_iff min_def not_le simp flip: bit_Suc)
  using le_less_Suc_eq apply fastforce
  using le_less_Suc_eq apply fastforce
  done

lemma nth_sshiftr :
  "(w >>> m) !! n =
    (n < size w \<and> (if n + m \<ge> size w then w !! (size w - 1) else w !! (n + m)))"
  apply transfer
  apply (auto simp add: bit_take_bit_iff bit_drop_bit_eq bit_signed_take_bit_iff min_def not_le ac_simps)
  using le_less_Suc_eq apply fastforce
  using le_less_Suc_eq apply fastforce
  done

lemma sshiftr_numeral [simp]:
  \<open>(numeral k >>> numeral n :: 'a::len word) =
    word_of_int (drop_bit (numeral n) (signed_take_bit (LENGTH('a) - 1) (numeral k)))\<close>
  apply (rule word_eqI)
  apply (cases \<open>LENGTH('a)\<close>)
   apply (simp_all add: word_size bit_drop_bit_eq nth_sshiftr bit_signed_take_bit_iff min_def not_le not_less less_Suc_eq_le ac_simps)
  done

setup \<open>
  Context.theory_map (fold SMT_Word.add_word_shift' [
    (\<^term>\<open>shiftl :: 'a::len word \<Rightarrow> _\<close>, "bvshl"),
    (\<^term>\<open>shiftr :: 'a::len word \<Rightarrow> _\<close>, "bvlshr"),
    (\<^term>\<open>sshiftr :: 'a::len word \<Rightarrow> _\<close>, "bvashr")
  ])
\<close>

lemma revcast_down_us [OF refl]:
  "rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = ucast (w >>> n)"
  for w :: "'a::len word"
  apply (simp add: source_size_def target_size_def)
  apply (rule bit_word_eqI)
  apply (simp add: bit_revcast_iff bit_ucast_iff bit_sshiftr_word_iff ac_simps)
  done

lemma revcast_down_ss [OF refl]:
  "rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = scast (w >>> n)"
  for w :: "'a::len word"
  apply (simp add: source_size_def target_size_def)
  apply (rule bit_word_eqI)
  apply (simp add: bit_revcast_iff bit_word_scast_iff bit_sshiftr_word_iff ac_simps)
  done

lemma sshiftr_div_2n: "sint (w >>> n) = sint w div 2 ^ n"
  using sint_signed_drop_bit_eq [of n w]
  by (simp add: drop_bit_eq_div sshiftr_eq)

lemmas lsb0 = len_gt_0 [THEN word_ops_nth_size [unfolded word_size]]

lemma nth_sint:
  fixes w :: "'a::len word"
  defines "l \<equiv> LENGTH('a)"
  shows "bit (sint w) n = (if n < l - 1 then w !! n else w !! (l - 1))"
  unfolding sint_uint l_def
  by (auto simp: bit_signed_take_bit_iff word_test_bit_def not_less min_def)

lemma test_bit_2p: "(word_of_int (2 ^ n)::'a::len word) !! m \<longleftrightarrow> m = n \<and> m < LENGTH('a)"
  by transfer (auto simp add: bit_exp_iff)

lemma nth_w2p: "((2::'a::len word) ^ n) !! m \<longleftrightarrow> m = n \<and> m < LENGTH('a::len)"
  by transfer (auto simp add: bit_exp_iff)

lemma bang_is_le: "x !! m \<Longrightarrow> 2 ^ m \<le> x"
  for x :: "'a::len word"
  apply (rule xtrans(3))
   apply (rule_tac [2] y = "x" in le_word_or2)
  apply (rule word_eqI)
  apply (auto simp add: word_ao_nth nth_w2p word_size)
  done

lemma mask_eq:
  \<open>mask n = (1 << n) - (1 :: 'a::len word)\<close>
  by transfer (simp add: mask_eq_exp_minus_1 push_bit_of_1)

lemma nth_ucast:
  "(ucast w::'a::len word) !! n = (w !! n \<and> n < LENGTH('a))"
  by transfer (simp add: bit_take_bit_iff ac_simps)

lemma shiftl_0 [simp]: "(0::'a::len word) << n = 0"
  by transfer simp

lemma shiftr_0 [simp]: "(0::'a::len word) >> n = 0"
  by transfer simp

lemma nth_shiftl1: "shiftl1 w !! n \<longleftrightarrow> n < size w \<and> n > 0 \<and> w !! (n - 1)"
  by transfer (auto simp add: bit_double_iff)

lemma nth_shiftl': "(w << m) !! n \<longleftrightarrow> n < size w \<and> n >= m \<and> w !! (n - m)"
  for w :: "'a::len word"
  by transfer (auto simp add: bit_push_bit_iff)

lemmas nth_shiftl = nth_shiftl' [unfolded word_size]

lemma nth_shiftr1: "shiftr1 w !! n = w !! Suc n"
  by transfer (auto simp add: bit_take_bit_iff simp flip: bit_Suc)

lemma nth_shiftr: "(w >> m) !! n = w !! (n + m)"
  for w :: "'a::len word"
  apply (unfold shiftr_def)
  apply (induct "m" arbitrary: n)
   apply (auto simp add: nth_shiftr1)
  done

lemma nth_sshiftr1: "sshiftr1 w !! n = (if n = size w - 1 then w !! n else w !! Suc n)"
  apply transfer
  apply (auto simp add: bit_take_bit_iff bit_signed_take_bit_iff min_def simp flip: bit_Suc)
  using le_less_Suc_eq apply fastforce
  using le_less_Suc_eq apply fastforce
  done

lemma shiftr_div_2n: "uint (shiftr w n) = uint w div 2 ^ n"
  by (fact uint_shiftr_eq)

lemma shiftl_rev: "shiftl w n = word_reverse (shiftr (word_reverse w) n)"
  by (induct n) (auto simp add: shiftl_def shiftr_def shiftl1_rev)

lemma rev_shiftl: "word_reverse w << n = word_reverse (w >> n)"
  by (simp add: shiftl_rev)

lemma shiftr_rev: "w >> n = word_reverse (word_reverse w << n)"
  by (simp add: rev_shiftl)

lemma rev_shiftr: "word_reverse w >> n = word_reverse (w << n)"
  by (simp add: shiftr_rev)

lemma shiftl_numeral [simp]:
  \<open>numeral k << numeral l = (push_bit (numeral l) (numeral k) :: 'a::len word)\<close>
  by (fact shiftl_word_eq)

lemma shiftl_zero_size: "size x \<le> n \<Longrightarrow> x << n = 0"
  for x :: "'a::len word"
  apply transfer
  apply (simp add: take_bit_push_bit)
  done

lemma shiftl_t2n: "shiftl w n = 2 ^ n * w"
  for w :: "'a::len word"
  by (induct n) (auto simp: shiftl_def shiftl1_2t)

lemma shiftr_numeral [simp]:
  \<open>(numeral k >> numeral n :: 'a::len word) = drop_bit (numeral n) (numeral k)\<close>
  by (fact shiftr_word_eq)

lemma shiftr_numeral_Suc [simp]:
  \<open>(numeral k >> Suc 0 :: 'a::len word) = drop_bit (Suc 0) (numeral k)\<close>
  by (fact shiftr_word_eq)

lemma drop_bit_numeral_bit0_1 [simp]:
  \<open>drop_bit (Suc 0) (numeral k) =
    (word_of_int (drop_bit (Suc 0) (take_bit LENGTH('a) (numeral k))) :: 'a::len word)\<close>
  by (metis Word_eq_word_of_int drop_bit_word.abs_eq of_int_numeral)

lemma nth_mask [simp]:
  \<open>(mask n :: 'a::len word) !! i \<longleftrightarrow> i < n \<and> i < size (mask n :: 'a word)\<close>
  by (auto simp add: test_bit_word_eq word_size Word.bit_mask_iff)

lemma slice_shiftr: "slice n w = ucast (w >> n)"
  apply (rule bit_word_eqI)
  apply (cases \<open>n \<le> LENGTH('b)\<close>)
   apply (auto simp add: bit_slice_iff bit_ucast_iff bit_shiftr_word_iff ac_simps
    dest: bit_imp_le_length)
  done

lemma nth_slice: "(slice n w :: 'a::len word) !! m = (w !! (m + n) \<and> m < LENGTH('a))"
  by (simp add: slice_shiftr nth_ucast nth_shiftr)

lemma revcast_down_uu [OF refl]:
  "rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = ucast (w >> n)"
  for w :: "'a::len word"
  apply (simp add: source_size_def target_size_def)
  apply (rule bit_word_eqI)
  apply (simp add: bit_revcast_iff bit_ucast_iff bit_shiftr_word_iff ac_simps)
  done

lemma revcast_down_su [OF refl]:
  "rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = scast (w >> n)"
  for w :: "'a::len word"
  apply (simp add: source_size_def target_size_def)
  apply (rule bit_word_eqI)
  apply (simp add: bit_revcast_iff bit_word_scast_iff bit_shiftr_word_iff ac_simps)
  done

lemma cast_down_rev [OF refl]:
  "uc = ucast \<Longrightarrow> source_size uc = target_size uc + n \<Longrightarrow> uc w = revcast (w << n)"
  for w :: "'a::len word"
  apply (simp add: source_size_def target_size_def)
  apply (rule bit_word_eqI)
  apply (simp add: bit_revcast_iff bit_word_ucast_iff bit_shiftl_word_iff)
  done

lemma revcast_up [OF refl]:
  "rc = revcast \<Longrightarrow> source_size rc + n = target_size rc \<Longrightarrow>
    rc w = (ucast w :: 'a::len word) << n"
  apply (simp add: source_size_def target_size_def)
  apply (rule bit_word_eqI)
  apply (simp add: bit_revcast_iff bit_word_ucast_iff bit_shiftl_word_iff)
  apply auto
  apply (metis add.commute add_diff_cancel_right)
  apply (metis diff_add_inverse2 diff_diff_add)
  done

lemmas rc1 = revcast_up [THEN
  revcast_rev_ucast [symmetric, THEN trans, THEN word_rev_gal, symmetric]]
lemmas rc2 = revcast_down_uu [THEN
  revcast_rev_ucast [symmetric, THEN trans, THEN word_rev_gal, symmetric]]

lemmas ucast_up =
  rc1 [simplified rev_shiftr [symmetric] revcast_ucast [symmetric]]
lemmas ucast_down =
  rc2 [simplified rev_shiftr revcast_ucast [symmetric]]

\<comment> \<open>problem posed by TPHOLs referee:
      criterion for overflow of addition of signed integers\<close>

lemma sofl_test:
  \<open>sint x + sint y = sint (x + y) \<longleftrightarrow>
    (x + y XOR x) AND (x + y XOR y) >> (size x - 1) = 0\<close>
  for x y :: \<open>'a::len word\<close>
proof -
  obtain n where n: \<open>LENGTH('a) = Suc n\<close>
    by (cases \<open>LENGTH('a)\<close>) simp_all
  have *: \<open>sint x + sint y + 2 ^ Suc n > signed_take_bit n (sint x + sint y) \<Longrightarrow> sint x + sint y \<ge> - (2 ^ n)\<close>
    \<open>signed_take_bit n (sint x + sint y) > sint x + sint y - 2 ^ Suc n \<Longrightarrow> 2 ^ n > sint x + sint y\<close>
    using signed_take_bit_int_greater_eq [of \<open>sint x + sint y\<close> n] signed_take_bit_int_less_eq [of n \<open>sint x + sint y\<close>]
    by (auto intro: ccontr)
  have \<open>sint x + sint y = sint (x + y) \<longleftrightarrow>
    (sint (x + y) < 0 \<longleftrightarrow> sint x < 0) \<or>
    (sint (x + y) < 0 \<longleftrightarrow> sint y < 0)\<close>
    using sint_less [of x] sint_greater_eq [of x] sint_less [of y] sint_greater_eq [of y]
    signed_take_bit_int_eq_self [of \<open>LENGTH('a) - 1\<close> \<open>sint x + sint y\<close>]
    apply (auto simp add: not_less)
       apply (unfold sint_word_ariths)
       apply (subst signed_take_bit_int_eq_self)
         prefer 4
       apply (subst signed_take_bit_int_eq_self)
         prefer 7
       apply (subst signed_take_bit_int_eq_self)
         prefer 10
             apply (subst signed_take_bit_int_eq_self)
       apply (auto simp add: signed_take_bit_int_eq_self signed_take_bit_eq_take_bit_minus take_bit_Suc_from_most n not_less intro!: *)
    done
  then show ?thesis
    apply (simp only: One_nat_def word_size shiftr_word_eq drop_bit_eq_zero_iff_not_bit_last bit_and_iff bit_xor_iff)
    apply (simp add: bit_last_iff)
    done
qed

lemma shiftr_zero_size: "size x \<le> n \<Longrightarrow> x >> n = 0"
  for x :: "'a :: len word"
  by (rule word_eqI) (auto simp add: nth_shiftr dest: test_bit_size)

lemma test_bit_cat [OF refl]:
  "wc = word_cat a b \<Longrightarrow> wc !! n = (n < size wc \<and>
    (if n < size b then b !! n else a !! (n - size b)))"
  apply (simp add: word_size not_less; transfer)
       apply (auto simp add: bit_concat_bit_iff bit_take_bit_iff)
  done

\<comment> \<open>keep quantifiers for use in simplification\<close>
lemma test_bit_split':
  "word_split c = (a, b) \<longrightarrow>
    (\<forall>n m.
      b !! n = (n < size b \<and> c !! n) \<and>
      a !! m = (m < size a \<and> c !! (m + size b)))"
  by (auto simp add: word_split_bin' test_bit_bin bit_unsigned_iff word_size bit_drop_bit_eq ac_simps
           dest: bit_imp_le_length)

lemma test_bit_split:
  "word_split c = (a, b) \<Longrightarrow>
    (\<forall>n::nat. b !! n \<longleftrightarrow> n < size b \<and> c !! n) \<and>
    (\<forall>m::nat. a !! m \<longleftrightarrow> m < size a \<and> c !! (m + size b))"
  by (simp add: test_bit_split')

lemma test_bit_split_eq:
  "word_split c = (a, b) \<longleftrightarrow>
    ((\<forall>n::nat. b !! n = (n < size b \<and> c !! n)) \<and>
     (\<forall>m::nat. a !! m = (m < size a \<and> c !! (m + size b))))"
  apply (rule_tac iffI)
   apply (rule_tac conjI)
    apply (erule test_bit_split [THEN conjunct1])
   apply (erule test_bit_split [THEN conjunct2])
  apply (case_tac "word_split c")
  apply (frule test_bit_split)
  apply (erule trans)
  apply (fastforce intro!: word_eqI simp add: word_size)
  done

lemma test_bit_rcat:
  "sw = size (hd wl) \<Longrightarrow> rc = word_rcat wl \<Longrightarrow> rc !! n =
    (n < size rc \<and> n div sw < size wl \<and> (rev wl) ! (n div sw) !! (n mod sw))"
  for wl :: "'a::len word list"
  by (simp add: word_size word_rcat_def foldl_map rev_map bit_horner_sum_uint_exp_iff)
    (simp add: test_bit_eq_bit)

lemmas test_bit_cong = arg_cong [where f = "test_bit", THEN fun_cong]

lemma max_test_bit: "(max_word::'a::len word) !! n \<longleftrightarrow> n < LENGTH('a)"
  by (fact nth_minus1)

lemma shiftr_x_0 [iff]: "x >> 0 = x"
  for x :: "'a::len word"
  by transfer simp

lemma shiftl_x_0 [simp]: "x << 0 = x"
  for x :: "'a::len word"
  by (simp add: shiftl_t2n)

lemma shiftl_1 [simp]: "(1::'a::len word) << n = 2^n"
  by (simp add: shiftl_t2n)

lemma shiftr_1[simp]: "(1::'a::len word) >> n = (if n = 0 then 1 else 0)"
  by (induct n) (auto simp: shiftr_def)

lemma map_nth_0 [simp]: "map ((!!) (0::'a::len word)) xs = replicate (length xs) False"
  by (induct xs) auto

lemma word_and_1:
  "n AND 1 = (if n !! 0 then 1 else 0)" for n :: "_ word"
  by (rule bit_word_eqI) (auto simp add: bit_and_iff test_bit_eq_bit bit_1_iff intro: gr0I)

lemma test_bit_1' [simp]:
  "(1 :: 'a :: len word) !! n \<longleftrightarrow> 0 < LENGTH('a) \<and> n = 0"
  by simp

lemma shiftl0:
  "x << 0 = (x :: 'a :: len word)"
  by (fact shiftl_x_0)

lemma word_ops_nth [simp]:
  fixes x y :: \<open>'a::len word\<close>
  shows
  word_or_nth:  "(x OR y) !! n = (x !! n \<or> y !! n)" and
  word_and_nth: "(x AND y) !! n = (x !! n \<and> y !! n)" and
  word_xor_nth: "(x XOR y) !! n = (x !! n \<noteq> y !! n)"
  by ((cases "n < size x",
      auto dest: test_bit_size simp: word_ops_nth_size word_size)[1])+

lemma and_not_mask:
  "w AND NOT (mask n) = (w >> n) << n"
  for w :: \<open>'a::len word\<close>
  apply (rule word_eqI)
  apply (simp add : word_ops_nth_size word_size)
  apply (simp add : nth_shiftr nth_shiftl)
  by auto

lemma and_mask:
  "w AND mask n = (w << (size w - n)) >> (size w - n)"
  for w :: \<open>'a::len word\<close>
  apply (rule word_eqI)
  apply (simp add : word_ops_nth_size word_size)
  apply (simp add : nth_shiftr nth_shiftl)
  by auto

lemma nth_w2p_same:
  "(2^n :: 'a :: len word) !! n = (n < LENGTH('a))"
  by (simp add : nth_w2p)

lemma shiftr_div_2n_w: "n < size w \<Longrightarrow> w >> n = w div (2^n :: 'a :: len word)"
  apply (unfold word_div_def)
  apply (simp add: uint_2p_alt word_size)
  apply (metis uint_shiftr_eq word_of_int_uint)
  done

lemma le_shiftr:
  "u \<le> v \<Longrightarrow> u >> (n :: nat) \<le> (v :: 'a :: len word) >> n"
  apply (unfold shiftr_def)
  apply (induct_tac "n")
   apply auto
  apply (erule le_shiftr1)
  done

lemma shiftr_mask_le:
  "n <= m \<Longrightarrow> mask n >> m = (0 :: 'a::len word)"
  apply (rule word_eqI)
  apply (simp add: word_size nth_shiftr)
  done

lemma shiftr_mask [simp]:
  \<open>mask m >> m = (0::'a::len word)\<close>
  by (rule shiftr_mask_le) simp

lemma word_leI:
  "(\<And>n.  \<lbrakk>n < size (u::'a::len word); u !! n \<rbrakk> \<Longrightarrow> (v::'a::len word) !! n) \<Longrightarrow> u <= v"
  apply (rule xtrans(4))
   apply (rule word_and_le2)
  apply (rule word_eqI)
  apply (simp add: word_ao_nth)
  apply safe
    apply assumption
   apply (erule_tac [2] asm_rl)
  apply (unfold word_size)
  by auto

lemma le_mask_iff:
  "(w \<le> mask n) = (w >> n = 0)"
  for w :: \<open>'a::len word\<close>
  apply safe
   apply (rule word_le_0_iff [THEN iffD1])
   apply (rule xtrans(3))
    apply (erule_tac [2] le_shiftr)
   apply simp
  apply (rule word_leI)
  apply (rename_tac n')
  apply (drule_tac x = "n' - n" in word_eqD)
  apply (simp add : nth_shiftr word_size)
  apply (case_tac "n <= n'")
  by auto

lemma and_mask_eq_iff_shiftr_0:
  "(w AND mask n = w) = (w >> n = 0)"
  for w :: \<open>'a::len word\<close>
  apply (unfold test_bit_eq_iff [THEN sym])
  apply (rule iffI)
   apply (rule ext)
   apply (rule_tac [2] ext)
   apply (auto simp add : word_ao_nth nth_shiftr)
    apply (drule arg_cong)
    apply (drule iffD2)
     apply assumption
    apply (simp add : word_ao_nth)
   prefer 2
   apply (simp add : word_size test_bit_bin)
  apply transfer
  apply (auto simp add: fun_eq_iff bit_simps)
  apply (metis add_diff_inverse_nat)
  done

lemma mask_shiftl_decompose:
  "mask m << n = mask (m + n) AND NOT (mask n :: 'a::len word)"
  by (auto intro!: word_eqI simp: and_not_mask nth_shiftl nth_shiftr word_size)

lemma bang_eq:
  fixes x :: "'a::len word"
  shows "(x = y) = (\<forall>n. x !! n = y !! n)"
  by (subst test_bit_eq_iff[symmetric]) fastforce

lemma shiftl_over_and_dist:
  fixes a::"'a::len word"
  shows "(a AND b) << c = (a << c) AND (b << c)"
  apply(rule word_eqI)
  apply(simp add: word_ao_nth nth_shiftl, safe)
  done

lemma shiftr_over_and_dist:
  fixes a::"'a::len word"
  shows "a AND b >> c = (a >> c) AND (b >> c)"
  apply(rule word_eqI)
  apply(simp add:nth_shiftr word_ao_nth)
  done

lemma sshiftr_over_and_dist:
  fixes a::"'a::len word"
  shows "a AND b >>> c = (a >>> c) AND (b >>> c)"
  apply(rule word_eqI)
  apply(simp add:nth_sshiftr word_ao_nth word_size)
  done

lemma shiftl_over_or_dist:
  fixes a::"'a::len word"
  shows "a OR b << c = (a << c) OR (b << c)"
  apply(rule word_eqI)
  apply(simp add:nth_shiftl word_ao_nth, safe)
  done

lemma shiftr_over_or_dist:
  fixes a::"'a::len word"
  shows "a OR b >> c = (a >> c) OR (b >> c)"
  apply(rule word_eqI)
  apply(simp add:nth_shiftr word_ao_nth)
  done

lemma sshiftr_over_or_dist:
  fixes a::"'a::len word"
  shows "a OR b >>> c = (a >>> c) OR (b >>> c)"
  apply(rule word_eqI)
  apply(simp add:nth_sshiftr word_ao_nth word_size)
  done

lemmas shift_over_ao_dists =
  shiftl_over_or_dist shiftr_over_or_dist
  sshiftr_over_or_dist shiftl_over_and_dist
  shiftr_over_and_dist sshiftr_over_and_dist

lemma shiftl_shiftl:
  fixes a::"'a::len word"
  shows "a << b << c = a << (b + c)"
  apply(rule word_eqI)
  apply(auto simp:word_size nth_shiftl add.commute add.left_commute)
  done

lemma shiftr_shiftr:
  fixes a::"'a::len word"
  shows "a >> b >> c = a >> (b + c)"
  apply(rule word_eqI)
  apply(simp add:word_size nth_shiftr add.left_commute add.commute)
  done

lemma shiftl_shiftr1:
  fixes a::"'a::len word"
  shows "c \<le> b \<Longrightarrow> a << b >> c = a AND (mask (size a - b)) << (b - c)"
  apply(rule word_eqI)
  apply(auto simp:nth_shiftr nth_shiftl word_size word_ao_nth)
  done

lemma shiftl_shiftr2:
  fixes a::"'a::len word"
  shows "b < c \<Longrightarrow> a << b >> c = (a >> (c - b)) AND (mask (size a - c))"
  apply(rule word_eqI)
  apply(auto simp:nth_shiftr nth_shiftl word_size word_ao_nth)
  done

lemma shiftr_shiftl1:
  fixes a::"'a::len word"
  shows "c \<le> b \<Longrightarrow> a >> b << c = (a >> (b - c)) AND (NOT (mask c))"
  apply(rule word_eqI)
  apply(auto simp:nth_shiftr nth_shiftl word_size word_ops_nth_size)
  done

lemma shiftr_shiftl2:
  fixes a::"'a::len word"
  shows "b < c \<Longrightarrow> a >> b << c = (a << (c - b)) AND (NOT (mask c))"
  apply(rule word_eqI)
  apply(auto simp:nth_shiftr nth_shiftl word_size word_ops_nth_size)
  done

lemmas multi_shift_simps =
  shiftl_shiftl shiftr_shiftr
  shiftl_shiftr1 shiftl_shiftr2
  shiftr_shiftl1 shiftr_shiftl2

lemma shiftr_mask2:
  "n \<le> LENGTH('a) \<Longrightarrow> (mask n >> m :: ('a :: len) word) = mask (n - m)"
  apply (rule word_eqI)
  apply (simp add: nth_shiftr word_size)
  apply arith
  done

lemma word_shiftl_add_distrib:
  fixes x :: "'a :: len word"
  shows "(x + y) << n = (x << n) + (y << n)"
  by (simp add: shiftl_t2n ring_distribs)

lemma mask_shift:
  "(x AND NOT (mask y)) >> y = x >> y"
  for x :: \<open>'a::len word\<close>
  apply (rule bit_eqI)
  apply (simp add: bit_and_iff bit_not_iff bit_shiftr_word_iff bit_mask_iff not_le)
  using bit_imp_le_length apply auto
  done

lemma shiftr_div_2n':
  "unat (w >> n) = unat w div 2 ^ n"
  apply (unfold unat_eq_nat_uint)
  apply (subst shiftr_div_2n)
  apply (subst nat_div_distrib)
   apply simp
  apply (simp add: nat_power_eq)
  done

lemma shiftl_shiftr_id:
  assumes nv: "n < LENGTH('a)"
  and     xv: "x < 2 ^ (LENGTH('a) - n)"
  shows "x << n >> n = (x::'a::len word)"
  apply (simp add: shiftl_t2n)
  apply (rule word_eq_unatI)
  apply (subst shiftr_div_2n')
  apply (cases n)
   apply simp
  apply (subst iffD1 [OF unat_mult_lem])+
   apply (subst unat_power_lower[OF nv])
   apply (rule nat_less_power_trans [OF _ order_less_imp_le [OF nv]])
   apply (rule order_less_le_trans [OF unat_mono [OF xv] order_eq_refl])
   apply (rule unat_power_lower)
   apply simp
  apply (subst unat_power_lower[OF nv])
  apply simp
  done

lemma ucast_shiftl_eq_0:
  fixes w :: "'a :: len word"
  shows "\<lbrakk> n \<ge> LENGTH('b) \<rbrakk> \<Longrightarrow> ucast (w << n) = (0 :: 'b :: len word)"
  by transfer (simp add: take_bit_push_bit)

lemma word_shift_nonzero:
  "\<lbrakk> (x::'a::len word) \<le> 2 ^ m; m + n < LENGTH('a::len); x \<noteq> 0\<rbrakk>
   \<Longrightarrow> x << n \<noteq> 0"
  apply (simp only: word_neq_0_conv word_less_nat_alt
                    shiftl_t2n mod_0 unat_word_ariths
                    unat_power_lower word_le_nat_alt)
  apply (subst mod_less)
   apply (rule order_le_less_trans)
    apply (erule mult_le_mono2)
   apply (subst power_add[symmetric])
   apply (rule power_strict_increasing)
    apply simp
   apply simp
  apply simp
  done

lemma word_shiftr_lt:
  fixes w :: "'a::len word"
  shows "unat (w >> n) < (2 ^ (LENGTH('a) - n))"
  apply (subst shiftr_div_2n')
  apply transfer
  apply (simp flip: drop_bit_eq_div add: drop_bit_nat_eq drop_bit_take_bit)
  done

lemma neg_mask_test_bit:
  "(NOT(mask n) :: 'a :: len word) !! m = (n \<le> m \<and> m < LENGTH('a))"
  by (metis not_le nth_mask test_bit_bin word_ops_nth_size word_size)

lemma upper_bits_unset_is_l2p:
  \<open>(\<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> p !! n') \<longleftrightarrow> (p < 2 ^ n)\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
    if \<open>n < LENGTH('a)\<close>
    for p :: "'a :: len word"
proof
  assume ?Q
  then show ?P
    by (meson bang_is_le le_less_trans not_le word_power_increasing)
next
  assume ?P
  have \<open>take_bit n p = p\<close>
  proof (rule bit_word_eqI)
    fix q
    assume \<open>q < LENGTH('a)\<close>
    show \<open>bit (take_bit n p) q \<longleftrightarrow> bit p q\<close>
    proof (cases \<open>q < n\<close>)
      case True
      then show ?thesis
        by (auto simp add: bit_simps)
    next
      case False
      then have \<open>n \<le> q\<close>
        by simp
      with \<open>?P\<close> \<open>q < LENGTH('a)\<close> have \<open>\<not> bit p q\<close>
        by (simp add: test_bit_eq_bit)
      then show ?thesis
        by (simp add: bit_simps)
    qed
  qed
  with that show ?Q
    using take_bit_word_eq_self_iff [of n p] by auto
qed

lemma less_2p_is_upper_bits_unset:
  "p < 2 ^ n \<longleftrightarrow> n < LENGTH('a) \<and> (\<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> p !! n')" for p :: "'a :: len word"
  by (meson le_less_trans le_mask_iff_lt_2n upper_bits_unset_is_l2p word_zero_le)

lemma test_bit_over:
  "n \<ge> size (x::'a::len word) \<Longrightarrow> (x !! n) = False"
  by transfer auto

lemma le_mask_high_bits:
  "w \<le> mask n \<longleftrightarrow> (\<forall>i \<in> {n ..< size w}. \<not> w !! i)"
  for w :: \<open>'a::len word\<close>
  by (auto simp: word_size and_mask_eq_iff_le_mask[symmetric] word_eq_iff)

lemma test_bit_conj_lt:
  "(x !! m \<and> m < LENGTH('a)) = x !! m" for x :: "'a :: len word"
  using test_bit_bin by blast

lemma neg_test_bit:
  "(NOT x) !! n = (\<not> x !! n \<and> n < LENGTH('a))" for x :: "'a::len word"
  by (cases "n < LENGTH('a)") (auto simp add: test_bit_over word_ops_nth_size word_size)

lemma shiftr_less_t2n':
  "\<lbrakk> x AND mask (n + m) = x; m < LENGTH('a) \<rbrakk> \<Longrightarrow> x >> n < 2 ^ m" for x :: "'a :: len word"
  apply (simp add: word_size mask_eq_iff_w2p [symmetric] flip: take_bit_eq_mask)
  apply transfer
  apply (simp add: take_bit_drop_bit ac_simps)
  done

lemma shiftr_less_t2n:
  "x < 2 ^ (n + m) \<Longrightarrow> x >> n < 2 ^ m" for x :: "'a :: len word"
  apply (rule shiftr_less_t2n')
   apply (erule less_mask_eq)
  apply (rule ccontr)
  apply (simp add: not_less)
  apply (subst (asm) p2_eq_0[symmetric])
  apply (simp add: power_add)
  done

lemma shiftr_eq_0:
  "n \<ge> LENGTH('a) \<Longrightarrow> ((w::'a::len word) >> n) = 0"
  apply (cut_tac shiftr_less_t2n'[of w n 0], simp)
   apply (simp add: mask_eq_iff)
  apply (simp add: lt2p_lem)
  apply simp
  done

lemma shiftr_not_mask_0:
  "n+m \<ge> LENGTH('a :: len) \<Longrightarrow> ((w::'a::len word) >> n) AND NOT (mask m) = 0"
  by (rule bit_word_eqI) (auto simp add: bit_simps dest: bit_imp_le_length)

lemma shiftl_less_t2n:
  fixes x :: "'a :: len word"
  shows "\<lbrakk> x < (2 ^ (m - n)); m < LENGTH('a) \<rbrakk> \<Longrightarrow> (x << n) < 2 ^ m"
  apply (simp add: word_size mask_eq_iff_w2p [symmetric] flip: take_bit_eq_mask)
  apply transfer
  apply (simp add: take_bit_push_bit)
  done

lemma shiftl_less_t2n':
  "(x::'a::len word) < 2 ^ m \<Longrightarrow> m+n < LENGTH('a) \<Longrightarrow> x << n < 2 ^ (m + n)"
  by (rule shiftl_less_t2n) simp_all

lemma nth_w2p_scast [simp]:
  "((scast ((2::'a::len signed word) ^ n) :: 'a word) !! m)
         \<longleftrightarrow> ((((2::'a::len  word) ^ n) :: 'a word) !! m)"
  by transfer (auto simp add: bit_simps)

lemma scast_bit_test [simp]:
    "scast ((1 :: 'a::len signed word) << n) = (1 :: 'a word) << n"
  by (clarsimp simp: word_eq_iff)

lemma signed_shift_guard_to_word:
  "\<lbrakk> n < len_of TYPE ('a); n > 0 \<rbrakk>
    \<Longrightarrow> (unat (x :: 'a :: len word) * 2 ^ y < 2 ^ n)
    = (x = 0 \<or> x < (1 << n >> y))"
  apply (simp only: nat_mult_power_less_eq)
  apply (cases "y \<le> n")
   apply (simp only: shiftl_shiftr1)
   apply (subst less_mask_eq)
    apply (simp add: word_less_nat_alt word_size)
    apply (rule order_less_le_trans[rotated], rule power_increasing[where n=1])
      apply simp
     apply simp
    apply simp
   apply (simp add: nat_mult_power_less_eq word_less_nat_alt word_size)
   apply auto[1]
  apply (simp only: shiftl_shiftr2, simp add: unat_eq_0)
  done

lemma nth_bounded:
  "\<lbrakk>(x :: 'a :: len word) !! n; x < 2 ^ m; m \<le> len_of TYPE ('a)\<rbrakk> \<Longrightarrow> n < m"
  apply (rule ccontr)
  apply (auto simp add: not_less test_bit_word_eq)
  apply (meson bit_imp_le_length bit_uint_iff less_2p_is_upper_bits_unset test_bit_bin)
  done

lemma shiftl_mask_is_0[simp]:
  "(x << n) AND mask n = 0"
  for x :: \<open>'a::len word\<close>
  by (simp flip: take_bit_eq_mask add: shiftl_eq_push_bit take_bit_push_bit)

lemma rshift_sub_mask_eq:
  "(a >> (size a - b)) AND mask b = a >> (size a - b)"
  for a :: \<open>'a::len word\<close>
  using shiftl_shiftr2[where a=a and b=0 and c="size a - b"]
  apply (cases "b < size a")
   apply simp
  apply (simp add: linorder_not_less mask_eq_decr_exp word_size
                   p2_eq_0[THEN iffD2])
  done

lemma shiftl_shiftr3:
  "b \<le> c \<Longrightarrow> a << b >> c = (a >> c - b) AND mask (size a - c)"
  for a :: \<open>'a::len word\<close>
  apply (cases "b = c")
   apply (simp add: shiftl_shiftr1)
  apply (simp add: shiftl_shiftr2)
  done

lemma and_mask_shiftr_comm:
  "m \<le> size w \<Longrightarrow> (w AND mask m) >> n = (w >> n) AND mask (m-n)"
  for w :: \<open>'a::len word\<close>
  by (simp add: and_mask shiftr_shiftr) (simp add: word_size shiftl_shiftr3)

lemma le_mask_shiftl_le_mask: "s = m + n \<Longrightarrow> x \<le> mask n \<Longrightarrow> x << m \<le> mask s"
  for x :: \<open>'a::len word\<close>
  by (simp add: le_mask_iff shiftl_shiftr3)

lemma word_and_1_shiftl:
  "x AND (1 << n) = (if x !! n then (1 << n) else 0)" for x :: "'a :: len word"
  apply (rule bit_word_eqI; transfer)
  apply (auto simp add: bit_simps not_le ac_simps)
  done

lemmas word_and_1_shiftls'
    = word_and_1_shiftl[where n=0]
      word_and_1_shiftl[where n=1]
      word_and_1_shiftl[where n=2]

lemmas word_and_1_shiftls = word_and_1_shiftls' [simplified]

lemma word_and_mask_shiftl:
  "x AND (mask n << m) = ((x >> m) AND mask n) << m"
  for x :: \<open>'a::len word\<close>
  apply (rule bit_word_eqI; transfer)
  apply (auto simp add: bit_simps not_le ac_simps)
  done

lemma shift_times_fold:
  "(x :: 'a :: len word) * (2 ^ n) << m = x << (m + n)"
  by (simp add: shiftl_t2n ac_simps power_add)

lemma of_bool_nth:
  "of_bool (x !! v) = (x >> v) AND 1"
  for x :: \<open>'a::len word\<close>
  by (simp add: test_bit_word_eq shiftr_word_eq bit_eq_iff)
    (auto simp add: bit_1_iff bit_and_iff bit_drop_bit_eq intro: ccontr)

lemma shiftr_mask_eq:
  "(x >> n) AND mask (size x - n) = x >> n" for x :: "'a :: len word"
  apply (simp flip: take_bit_eq_mask)
  apply transfer
  apply (simp add: take_bit_drop_bit)
  done

lemma shiftr_mask_eq':
  "m = (size x - n) \<Longrightarrow> (x >> n) AND mask m = x >> n" for x :: "'a :: len word"
  by (simp add: shiftr_mask_eq)

lemma and_eq_0_is_nth:
  fixes x :: "'a :: len word"
  shows "y = 1 << n \<Longrightarrow> ((x AND y) = 0) = (\<not> (x !! n))"
  apply safe
   apply (drule_tac u="(x AND (1 << n))" and x=n in word_eqD)
   apply (simp add: nth_w2p)
   apply (simp add: test_bit_bin)
  apply (rule bit_word_eqI)
  apply (auto simp add: bit_simps test_bit_eq_bit)
  done

lemma and_neq_0_is_nth:
  \<open>x AND y \<noteq> 0 \<longleftrightarrow> x !! n\<close> if \<open>y = 2 ^ n\<close> for x y :: \<open>'a::len word\<close>
  apply (simp add: bit_eq_iff bit_simps)
  using that apply (simp add: bit_simps not_le)
  apply transfer
  apply auto
  done

lemma nth_is_and_neq_0:
  "(x::'a::len word) !! n = (x AND 2 ^ n \<noteq> 0)"
  by (subst and_neq_0_is_nth; rule refl)

lemma word_shift_zero:
  "\<lbrakk> x << n = 0; x \<le> 2^m; m + n < LENGTH('a)\<rbrakk> \<Longrightarrow> (x::'a::len word) = 0"
  apply (rule ccontr)
  apply (drule (2) word_shift_nonzero)
  apply simp
  done

lemma mask_shift_and_negate[simp]:"(w AND mask n << m) AND NOT (mask n << m) = 0"
  for w :: \<open>'a::len word\<close>
  by (clarsimp simp add: mask_eq_decr_exp Parity.bit_eq_iff bit_and_iff bit_not_iff shiftl_word_eq bit_push_bit_iff)

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>\<open>Par\<close> as a digraph\<close>
theory CZH_DG_Par
  imports
    CZH_DG_Rel
    CZH_DG_Subdigraph
begin

subsection\<open>Background\<close>

text\<open>
\<open>Par\<close> is usually defined as a category of sets and partial functions
(see nLab \<^cite>\<open>"noauthor_nlab_nodate"\<close>\footnote{
\url{https://ncatlab.org/nlab/show/partial+function}
}).
However, there is little that can prevent one from exposing \<open>Par\<close>
as a digraph and provide additional structure gradually in subsequent
installments of this work. Thus, in this section, \<open>\<alpha>\<close>-\<open>Par\<close> is defined as a
digraph of sets and partial functions in \<open>V\<^sub>\<alpha>\<close>
\<close>

named_theorems dg_Par_cs_simps
named_theorems dg_Par_cs_intros

lemmas [dg_Par_cs_simps] = dg_Rel_shared_cs_simps
lemmas [dg_Par_cs_intros] = dg_Rel_shared_cs_intros

subsection\<open>Arrow for \<open>Par\<close>\<close>

subsubsection\<open>Definition and elementary properties\<close>

locale arr_Par = \<Z> \<alpha> + vfsequence T + ArrVal: vsv \<open>T\<lparr>ArrVal\<rparr>\<close> for \<alpha> T +
  assumes arr_Par_length[dg_Rel_shared_cs_simps, dg_Par_cs_simps]:
    "vcard T = 3\<^sub>\<nat>"
    and arr_Par_ArrVal_vdomain: "\<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) \<subseteq>\<^sub>\<circ> T\<lparr>ArrDom\<rparr>"
    and arr_Par_ArrVal_vrange: "\<R>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>) \<subseteq>\<^sub>\<circ> T\<lparr>ArrCod\<rparr>"
    and arr_Par_ArrDom_in_Vset: "T\<lparr>ArrDom\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    and arr_Par_ArrCod_in_Vset: "T\<lparr>ArrCod\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"

text\<open>Elementary properties.\<close>

sublocale arr_Par \<subseteq> arr_Rel
  by unfold_locales
    (
      simp_all add:
        dg_Par_cs_simps
        arr_Par_ArrVal_vdomain
        arr_Par_ArrVal_vrange
        arr_Par_ArrDom_in_Vset
        arr_Par_ArrCod_in_Vset
    )

lemmas (in arr_Par) [dg_Par_cs_simps] = dg_Rel_shared_cs_simps

text\<open>Rules.\<close>

lemma (in arr_Par) arr_Par_axioms'[dg_cs_intros, dg_Par_cs_intros]:
  assumes "\<alpha>' = \<alpha>"
  shows "arr_Par \<alpha>' T"
  unfolding assms by (rule arr_Par_axioms)

mk_ide rf arr_Par_def[unfolded arr_Par_axioms_def]
  |intro arr_ParI|
  |dest arr_ParD[dest]|
  |elim arr_ParE[elim!]|

lemma (in \<Z>) arr_Par_vfsequenceI:
  assumes "vsv r"
    and "\<D>\<^sub>\<circ> r \<subseteq>\<^sub>\<circ> a"
    and "\<R>\<^sub>\<circ> r \<subseteq>\<^sub>\<circ> b"
    and "a \<in>\<^sub>\<circ> Vset \<alpha>"
    and "b \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "arr_Par \<alpha> [r, a, b]\<^sub>\<circ>"
  by (intro arr_ParI)
    (insert assms, auto simp: arr_Rel_components nat_omega_simps)

lemma arr_Par_arr_RelI:
  assumes "arr_Rel \<alpha> T" and "vsv (T\<lparr>ArrVal\<rparr>)"
  shows "arr_Par \<alpha> T"
proof-
  interpret arr_Rel \<alpha> T by (rule assms(1))
  show ?thesis
    by (intro arr_ParI)
      (
        auto simp:
          dg_Rel_cs_simps
          assms(2)
          vfsequence_axioms
          arr_Rel_ArrVal_vdomain
          arr_Rel_ArrVal_vrange
          arr_Rel_ArrDom_in_Vset
          arr_Rel_ArrCod_in_Vset
      )
qed

lemma arr_Par_arr_RelD:
  assumes "arr_Par \<alpha> T"
  shows "arr_Rel \<alpha> T" and "vsv (T\<lparr>ArrVal\<rparr>)"
proof-
  interpret arr_Par \<alpha> T by (rule assms)
  show "arr_Rel \<alpha> T" and "vsv (T\<lparr>ArrVal\<rparr>)"
    by (rule arr_Rel_axioms) auto
qed

lemma arr_Par_arr_RelE:
  assumes "arr_Par \<alpha> T"
  obtains "arr_Rel \<alpha> T" and "vsv (T\<lparr>ArrVal\<rparr>)"
  using assms by (auto simp: arr_Par_arr_RelD)

text\<open>Further properties.\<close>

lemma arr_Par_eqI:
  assumes "arr_Par \<alpha> S"
    and "arr_Par \<alpha> T"
    and "S\<lparr>ArrVal\<rparr> = T\<lparr>ArrVal\<rparr>"
    and "S\<lparr>ArrDom\<rparr> = T\<lparr>ArrDom\<rparr>"
    and "S\<lparr>ArrCod\<rparr> = T\<lparr>ArrCod\<rparr>"
  shows "S = T"
proof(rule vsv_eqI)
  interpret S: arr_Par \<alpha> S by (rule assms(1))
  interpret T: arr_Par \<alpha> T by (rule assms(2))
  show "vsv S" by (rule S.vsv_axioms)
  show "vsv T" by (rule T.vsv_axioms)
  show "\<D>\<^sub>\<circ> S = \<D>\<^sub>\<circ> T"
    by (simp add: S.vfsequence_vdomain T.vfsequence_vdomain dg_Par_cs_simps)
  have dom: "\<D>\<^sub>\<circ> S = 3\<^sub>\<nat>" by (simp add: S.vfsequence_vdomain dg_Par_cs_simps)
  show "a \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> S \<Longrightarrow> S\<lparr>a\<rparr> = T\<lparr>a\<rparr>" for a
    by (unfold dom, elim_in_numeral, insert assms)
      (auto simp: arr_field_simps)
qed

lemma small_arr_Par[simp]: "small {T. arr_Par \<alpha> T}"
proof(rule smaller_than_small)
  show "{T. arr_Par \<alpha> T} \<subseteq> {T. arr_Rel \<alpha> T}"
    by (simp add: Collect_mono arr_Par_arr_RelD(1))
qed simp

lemma set_Collect_arr_Par[simp]:
  "T \<in>\<^sub>\<circ> set (Collect (arr_Par \<alpha>)) \<longleftrightarrow> arr_Par \<alpha> T"
  by auto

subsubsection\<open>Composition\<close>

abbreviation (input) comp_Par :: "V \<Rightarrow> V \<Rightarrow> V" (infixl \<open>\<circ>\<^sub>P\<^sub>a\<^sub>r\<close> 55)
  where "comp_Par \<equiv> comp_Rel"

lemma arr_Par_comp_Par[dg_Par_cs_intros]:
  assumes "arr_Par \<alpha> S" and "arr_Par \<alpha> T"
  shows "arr_Par \<alpha> (S \<circ>\<^sub>P\<^sub>a\<^sub>r T)"
proof(intro arr_Par_arr_RelI)
  interpret S: arr_Par \<alpha> S by (rule assms(1))
  interpret T: arr_Par \<alpha> T by (rule assms(2))
  show "arr_Rel \<alpha> (S \<circ>\<^sub>P\<^sub>a\<^sub>r T)"
    by (auto simp: S.arr_Rel_axioms T.arr_Rel_axioms arr_Rel_comp_Rel)
  show "vsv ((S \<circ>\<^sub>P\<^sub>a\<^sub>r T)\<lparr>ArrVal\<rparr>)"
    unfolding comp_Rel_components
    by (simp add: S.ArrVal.vsv_axioms T.ArrVal.vsv_axioms vsv_vcomp)
qed

lemma arr_Par_comp_Par_ArrVal_app:
  assumes "arr_Par \<alpha> S"
    and "arr_Par \<alpha> T"
    and "x \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (T\<lparr>ArrVal\<rparr>)"
    and "T\<lparr>ArrVal\<rparr>\<lparr>x\<rparr> \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (S\<lparr>ArrVal\<rparr>)"
  shows "(S \<circ>\<^sub>P\<^sub>a\<^sub>r T)\<lparr>ArrVal\<rparr>\<lparr>x\<rparr> = S\<lparr>ArrVal\<rparr>\<lparr>T\<lparr>ArrVal\<rparr>\<lparr>x\<rparr>\<rparr>"
  using assms unfolding comp_Rel_components by (intro vcomp_atI) auto

subsubsection\<open>Inclusion\<close>

abbreviation (input) incl_Par :: "V \<Rightarrow> V \<Rightarrow> V"
  where "incl_Par \<equiv> incl_Rel"

lemma (in \<Z>) arr_Par_incl_ParI:
  assumes "A \<in>\<^sub>\<circ> Vset \<alpha>" and "B \<in>\<^sub>\<circ> Vset \<alpha>" and "A \<subseteq>\<^sub>\<circ> B"
  shows "arr_Par \<alpha> (incl_Par A B)"
proof(intro arr_Par_arr_RelI)
  from assms show "arr_Rel \<alpha> (incl_Par A B)"
    by (force intro: arr_Rel_incl_RelI)
qed (simp add: incl_Rel_components)

subsubsection\<open>Identity\<close>

abbreviation (input) id_Par :: "V \<Rightarrow> V"
  where "id_Par \<equiv> id_Rel"

lemma (in \<Z>) arr_Par_id_ParI:
  assumes "A \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "arr_Par \<alpha> (id_Par A)"
  using assms
  by (intro arr_Par_arr_RelI)
    (auto intro: arr_Rel_id_RelI simp: id_Rel_components)

lemma arr_Par_comp_Par_id_Par_left[dg_Par_cs_simps]:
  assumes "arr_Par \<alpha> f" and "f\<lparr>ArrCod\<rparr> = A"
  shows "id_Par A \<circ>\<^sub>P\<^sub>a\<^sub>r f = f"
proof-
  interpret f: arr_Par \<alpha> f by (rule assms(1))
  have "arr_Rel \<alpha> f" by (simp add: f.arr_Rel_axioms)
  from arr_Rel_comp_Rel_id_Rel_left[OF this assms(2)] show ?thesis .
qed

lemma arr_Par_comp_Par_id_Par_right[dg_Par_cs_simps]:
  assumes "arr_Par \<alpha> f" and "f\<lparr>ArrDom\<rparr> = A"
  shows "f \<circ>\<^sub>P\<^sub>a\<^sub>r id_Par A = f"
proof-
  interpret f: arr_Par \<alpha> f by (rule assms(1))
  have "arr_Rel \<alpha> f" by (simp add: f.arr_Rel_axioms)
  from arr_Rel_comp_Rel_id_Rel_right[OF this assms(2)] show ?thesis.
qed

subsection\<open>\<open>Par\<close> as a digraph\<close>

subsubsection\<open>Definition and elementary properties\<close>

definition dg_Par :: "V \<Rightarrow> V"
  where "dg_Par \<alpha> =
    [
      Vset \<alpha>,
      set {T. arr_Par \<alpha> T},
      (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Par \<alpha> T}. T\<lparr>ArrDom\<rparr>),
      (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Par \<alpha> T}. T\<lparr>ArrCod\<rparr>)
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma dg_Par_components:
  shows "dg_Par \<alpha>\<lparr>Obj\<rparr> = Vset \<alpha>"
    and "dg_Par \<alpha>\<lparr>Arr\<rparr> = set {T. arr_Par \<alpha> T}"
    and "dg_Par \<alpha>\<lparr>Dom\<rparr> = (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Par \<alpha> T}. T\<lparr>ArrDom\<rparr>)"
    and "dg_Par \<alpha>\<lparr>Cod\<rparr> = (\<lambda>T\<in>\<^sub>\<circ>set {T. arr_Par \<alpha> T}. T\<lparr>ArrCod\<rparr>)"
  unfolding dg_Par_def dg_field_simps by (simp_all add: nat_omega_simps)

subsubsection\<open>Object\<close>

lemma dg_Par_Obj_iff: "x \<in>\<^sub>\<circ> dg_Par \<alpha>\<lparr>Obj\<rparr> \<longleftrightarrow> x \<in>\<^sub>\<circ> Vset \<alpha>"
  unfolding dg_Par_components by auto

subsubsection\<open>Arrow\<close>

lemma dg_Par_Arr_iff[dg_Par_cs_simps]: "x \<in>\<^sub>\<circ> dg_Par \<alpha>\<lparr>Arr\<rparr> \<longleftrightarrow> arr_Par \<alpha> x"
  unfolding dg_Par_components by auto

subsubsection\<open>Domain\<close>

mk_VLambda dg_Par_components(3)
  |vsv dg_Par_Dom_vsv[dg_Par_cs_intros]|
  |vdomain dg_Par_Dom_vdomain[dg_Par_cs_simps]|
  |app dg_Par_Dom_app[unfolded set_Collect_arr_Par, dg_Par_cs_simps]|

lemma dg_Par_Dom_vrange: "\<R>\<^sub>\<circ> (dg_Par \<alpha>\<lparr>Dom\<rparr>) \<subseteq>\<^sub>\<circ> dg_Par \<alpha>\<lparr>Obj\<rparr>"
  unfolding dg_Par_components
  by (rule vrange_VLambda_vsubset, unfold set_Collect_arr_Par) auto

subsubsection\<open>Codomain\<close>

mk_VLambda dg_Par_components(4)
  |vsv dg_Par_Cod_vsv[dg_Par_cs_intros]|
  |vdomain dg_Par_Cod_vdomain[dg_Par_cs_simps]|
  |app dg_Par_Cod_app[unfolded set_Collect_arr_Par, dg_Par_cs_simps]|

lemma dg_Par_Cod_vrange: "\<R>\<^sub>\<circ> (dg_Par \<alpha>\<lparr>Cod\<rparr>) \<subseteq>\<^sub>\<circ> dg_Par \<alpha>\<lparr>Obj\<rparr>"
  unfolding dg_Par_components
  by (rule vrange_VLambda_vsubset, unfold set_Collect_arr_Par) auto

subsubsection\<open>Arrow with a domain and a codomain\<close>

text\<open>Rules.\<close>

lemma dg_Par_is_arrI:
  assumes "arr_Par \<alpha> S" and "S\<lparr>ArrDom\<rparr> = A" and "S\<lparr>ArrCod\<rparr> = B"
  shows "S : A \<mapsto>\<^bsub>dg_Par \<alpha>\<^esub> B"
  using assms by (intro is_arrI, unfold dg_Par_components) simp_all

lemmas [dg_Par_cs_intros] = dg_Par_is_arrI

lemma dg_Par_is_arrD:
  assumes "S : A \<mapsto>\<^bsub>dg_Par \<alpha>\<^esub> B"
  shows "arr_Par \<alpha> S"
    and [dg_cs_simps]: "S\<lparr>ArrDom\<rparr> = A"
    and [dg_cs_simps]: "S\<lparr>ArrCod\<rparr> = B"
  using is_arrD[OF assms] unfolding dg_Par_components by simp_all

lemma dg_Par_is_arrE:
  assumes "S : A \<mapsto>\<^bsub>dg_Par \<alpha>\<^esub> B"
  obtains "arr_Par \<alpha> S" and "S\<lparr>ArrDom\<rparr> = A" and "S\<lparr>ArrCod\<rparr> = B"
  using is_arrD[OF assms] unfolding dg_Par_components by simp_all

text\<open>Elementary properties.\<close>

lemma dg_Par_is_arr_dg_Rel_is_arr:
  assumes "r : a \<mapsto>\<^bsub>dg_Par \<alpha>\<^esub> b"
  shows "r : a \<mapsto>\<^bsub>dg_Rel \<alpha>\<^esub> b"
  using assms arr_Par_arr_RelD(1)
  by (intro dg_Rel_is_arrI; elim dg_Par_is_arrE) auto

lemma dg_Par_Hom_vsubset_dg_Rel_Hom:
  assumes "a \<in>\<^sub>\<circ> dg_Par \<alpha>\<lparr>Obj\<rparr>" "b \<in>\<^sub>\<circ> dg_Par \<alpha>\<lparr>Obj\<rparr>"
  shows "Hom (dg_Par \<alpha>) a b \<subseteq>\<^sub>\<circ> Hom (dg_Rel \<alpha>) a b"
  by (rule vsubsetI) (simp add: dg_Par_is_arr_dg_Rel_is_arr)

lemma (in \<Z>) dg_Par_incl_Par_is_arr:
  assumes "A \<in>\<^sub>\<circ> dg_Par \<alpha>\<lparr>Obj\<rparr>" and "B \<in>\<^sub>\<circ> dg_Par \<alpha>\<lparr>Obj\<rparr>" and "A \<subseteq>\<^sub>\<circ> B"
  shows "incl_Par A B : A \<mapsto>\<^bsub>dg_Par \<alpha>\<^esub> B"
  by (rule dg_Par_is_arrI)
    (
      auto
        simp: incl_Rel_components
        intro!: arr_Par_incl_ParI assms[unfolded dg_Par_components(1)]
    )

lemma (in \<Z>) dg_Par_incl_Par_is_arr'[dg_Par_cs_intros]:
  assumes "A \<in>\<^sub>\<circ> dg_Par \<alpha>\<lparr>Obj\<rparr>"
    and "B \<in>\<^sub>\<circ> dg_Par \<alpha>\<lparr>Obj\<rparr>"
    and "A \<subseteq>\<^sub>\<circ> B"
    and "A' = A"
    and "B' = B"
  shows "incl_Par A B : A' \<mapsto>\<^bsub>dg_Par \<alpha>\<^esub> B'"
  using assms(1-3) unfolding assms(4,5) by (rule dg_Par_incl_Par_is_arr)

lemmas [dg_Par_cs_intros] = \<Z>.dg_Par_incl_Par_is_arr'

subsubsection\<open>\<open>Par\<close> is a digraph\<close>

lemma (in \<Z>) dg_Par_Hom_vifunion_in_Vset:
  assumes "X \<in>\<^sub>\<circ> Vset \<alpha>" and "Y \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "(\<Union>\<^sub>\<circ>A\<in>\<^sub>\<circ>X. \<Union>\<^sub>\<circ>B\<in>\<^sub>\<circ>Y. Hom (dg_Par \<alpha>) A B) \<in>\<^sub>\<circ> Vset \<alpha>"
proof-
  have
    "(\<Union>\<^sub>\<circ>A\<in>\<^sub>\<circ>X. \<Union>\<^sub>\<circ>B\<in>\<^sub>\<circ>Y. Hom (dg_Par \<alpha>) A B) \<subseteq>\<^sub>\<circ>
      (\<Union>\<^sub>\<circ>A\<in>\<^sub>\<circ>X. \<Union>\<^sub>\<circ>B\<in>\<^sub>\<circ>Y. Hom (dg_Rel \<alpha>) A B)"
  proof(intro vsubsetI)
    fix F assume "F \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>A\<in>\<^sub>\<circ>X. \<Union>\<^sub>\<circ>B\<in>\<^sub>\<circ>Y. Hom (dg_Par \<alpha>) A B)"
    then obtain B where B: "B \<in>\<^sub>\<circ> Y" and "F \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>A\<in>\<^sub>\<circ>X. Hom (dg_Par \<alpha>) A B)"
      by fast
    then obtain A where A: "A \<in>\<^sub>\<circ> X" and F_AB: "F \<in>\<^sub>\<circ> Hom (dg_Par \<alpha>) A B" by fast
    from A B assms have "A \<in>\<^sub>\<circ> dg_Par \<alpha>\<lparr>Obj\<rparr>" "B \<in>\<^sub>\<circ> dg_Par \<alpha>\<lparr>Obj\<rparr>"
      unfolding dg_Par_components by auto
    from F_AB A B dg_Par_Hom_vsubset_dg_Rel_Hom[OF this] show
      "F \<in>\<^sub>\<circ> (\<Union>\<^sub>\<circ>A\<in>\<^sub>\<circ>X. \<Union>\<^sub>\<circ>B\<in>\<^sub>\<circ>Y. Hom (dg_Rel \<alpha>) A B)"
      by (intro vifunionI) (auto elim!: vsubsetE simp: in_Hom_iff)
  qed
  with dg_Rel_Hom_vifunion_in_Vset[OF assms] show ?thesis by blast
qed

lemma (in \<Z>) digraph_dg_Par: "digraph \<alpha> (dg_Par \<alpha>)"
proof(intro digraphI)
  show "vfsequence (dg_Par \<alpha>)" unfolding dg_Par_def by simp
  show "vcard (dg_Par \<alpha>) = 4\<^sub>\<nat>"
    unfolding dg_Par_def by (simp add: nat_omega_simps)
  show "\<R>\<^sub>\<circ> (dg_Par \<alpha>\<lparr>Dom\<rparr>) \<subseteq>\<^sub>\<circ> dg_Par \<alpha>\<lparr>Obj\<rparr>" by (simp add: dg_Par_Dom_vrange)
  show "\<R>\<^sub>\<circ> (dg_Par \<alpha>\<lparr>Cod\<rparr>) \<subseteq>\<^sub>\<circ> dg_Par \<alpha>\<lparr>Obj\<rparr>" by (simp add: dg_Par_Cod_vrange)
qed (auto simp: dg_Par_components dg_Par_Hom_vifunion_in_Vset)

subsubsection\<open>\<open>Par\<close> is a wide subdigraph of \<open>Rel\<close>\<close>

lemma (in \<Z>) wide_subdigraph_dg_Par_dg_Rel: "dg_Par \<alpha> \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> dg_Rel \<alpha>"
proof(intro wide_subdigraphI)
  show "dg_Par \<alpha> \<subseteq>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> dg_Rel \<alpha>"
    by (intro subdigraphI, unfold dg_Par_components)
      (
        auto simp:
          dg_Rel_components
          digraph_dg_Par
          digraph_dg_Rel
          dg_Par_is_arr_dg_Rel_is_arr
      )
qed (simp_all add: dg_Rel_components dg_Par_components)

text\<open>\newpage\<close>

end


theory Typing_Urelems
  imports Suc_Theory Typing
begin

section \<open>Typing the Urelements\<close>
text \<open>
  In this theory, we define a recursive procedure that generates Typing
  constraints. We then prove that the constraints can be solved with
  \<^term>\<open>Suc_Theory.assign\<close>. The solution then gives us the urelements.
\<close>

no_notation Set.member  ("(_/ : _)" [51, 51] 50)

abbreviation "SVar \<equiv> Suc_Theory.Var"
abbreviation "SEq \<equiv> Suc_Theory.Eq"
abbreviation "SNEq \<equiv> Suc_Theory.NEq"

fun constrs_term :: "('a pset_term \<Rightarrow> 'b) \<Rightarrow> 'a pset_term \<Rightarrow> 'b suc_atom list" where
  "constrs_term n (Var x) = [SEq (SVar (n (Var x))) (SVar (n (Var x)))]"
| "constrs_term n (\<emptyset> k) = [SEq (SVar (n (\<emptyset> k))) (Succ (Suc k) Zero)]"
| "constrs_term n (t1 \<squnion>\<^sub>s t2) =
    [SEq (SVar (n (t1 \<squnion>\<^sub>s t2))) (SVar (n t1)), SEq (SVar (n t1)) (SVar (n t2)), SNEq (SVar (n t1)) Zero]
    @ constrs_term n t1 @ constrs_term n t2"
| "constrs_term n (t1 \<sqinter>\<^sub>s t2) =
    [SEq (SVar (n (t1 \<sqinter>\<^sub>s t2))) (SVar (n t1)), SEq (SVar (n t1)) (SVar (n t2)), SNEq (SVar (n t1)) Zero]
    @ constrs_term n t1 @ constrs_term n t2"
| "constrs_term n (t1 -\<^sub>s t2) =
    [SEq (SVar (n (t1 -\<^sub>s t2))) (SVar (n t1)), SEq (SVar (n t1)) (SVar (n t2)), SNEq (SVar (n t1)) Zero]
    @ constrs_term n t1 @ constrs_term n t2"
| "constrs_term n (Single t) =
    [SEq (SVar (n (Single t))) (Succ 1 (SVar (n t)))]
    @ constrs_term n t"

fun constrs_atom :: "('a pset_term \<Rightarrow> 'b) \<Rightarrow> 'a pset_atom \<Rightarrow> 'b suc_atom list" where
  "constrs_atom n (t1 =\<^sub>s t2) =
    [SEq (SVar (n t1)) (SVar (n t2))]
    @ constrs_term n t1 @ constrs_term n t2"
| "constrs_atom n (t1 \<in>\<^sub>s t2) =
    [SEq (SVar (n t2)) (Succ 1 (SVar (n t1)))]
    @ constrs_term n t1 @ constrs_term n t2"

fun constrs_fm :: "('a pset_term \<Rightarrow> 'b) \<Rightarrow> 'a pset_fm \<Rightarrow> 'b suc_atom list" where
  "constrs_fm n (Atom a) = constrs_atom n a"
| "constrs_fm n (And p q) = constrs_fm n p @ constrs_fm n q"
| "constrs_fm n (Or p q) = constrs_fm n p @ constrs_fm n q"
| "constrs_fm n (Neg p) = constrs_fm n p"

lemma is_Succ_normal_constrs_term:
  "\<forall>a \<in> set (constrs_term n t). Suc_Theory.is_Eq a \<longrightarrow> is_Succ_normal a"
  by (induction t) auto

lemma is_Succ_normal_constrs_atom:
  "\<forall>a \<in> set (constrs_atom n a). Suc_Theory.is_Eq a \<longrightarrow> is_Succ_normal a"
  by (cases a) (use is_Succ_normal_constrs_term in auto)

lemma is_Succ_normal_constrs_fm:
  "\<forall>a \<in> set (constrs_fm n \<phi>). Suc_Theory.is_Eq a \<longrightarrow> is_Succ_normal a"
  by (induction \<phi>) (use is_Succ_normal_constrs_atom in auto)

lemma is_Var_Eq_Zero_if_is_NEq_constrs_term:
  "\<forall>a \<in> set (constrs_term n t). Suc_Theory.is_NEq a \<longrightarrow> (\<exists>x. a = SNEq (SVar x) Zero)"
  by (induction t) auto

lemma is_Var_Eq_Zero_if_is_NEq_constrs_atom:
  "\<forall>a \<in> set (constrs_atom n a). Suc_Theory.is_NEq a \<longrightarrow> (\<exists>x. a = SNEq (SVar x) Zero)"
  by (cases a) (use is_Var_Eq_Zero_if_is_NEq_constrs_term in auto)

lemma is_Var_Eq_Zero_if_is_NEq_constrs_fm:
  "\<forall>a \<in> set (constrs_fm n \<phi>). Suc_Theory.is_NEq a \<longrightarrow> (\<exists>x. a = SNEq (SVar x) Zero)"
  by (induction \<phi>) (use is_Var_Eq_Zero_if_is_NEq_constrs_atom in auto)

lemma types_term_if_I_atom_constrs_term:
  assumes "(\<forall>e \<in> set (constrs_term n t). Suc_Theory.I_atom v e)"
  shows "(\<lambda>x. v (n (Var x))) \<turnstile> t : v (n t)"
  using assms
  by (induction t) (auto intro: types_pset_term.intros)

lemma types_pset_atom_if_I_atom_constrs_atom:
  fixes a :: "'a pset_atom"
  assumes "(\<forall>e \<in> set (constrs_atom n a). Suc_Theory.I_atom v e)"
  shows "(\<lambda>x. v (n (Var x))) \<turnstile> a"
  using assms
  by (cases a)
     (auto simp: types_pset_atom.simps ball_Un dest!: types_term_if_I_atom_constrs_term)

lemma types_pset_fm_if_I_atom_constrs_fm:
  fixes \<phi> :: "'a pset_fm"
  assumes "(\<forall>e \<in> set (constrs_fm n \<phi>). Suc_Theory.I_atom v e)"
  shows "(\<lambda>x. v (n (Var x))) \<turnstile> \<phi>"
  using assms
  by (induction \<phi>)
     (auto intro: types_fmI types_pset_atom_if_I_atom_constrs_atom)

lemma I_atom_constrs_term_if_types_term:
  assumes "inj_on n T" "subterms t \<subseteq> T"
  assumes "v \<turnstile> t : k"
  shows "(\<forall>e \<in> set (constrs_term n t).
    Suc_Theory.I_atom (\<lambda>x. type_of_term v (inv_into T n x)) e)"
  using assms inv_into_f_f[OF assms(1) subsetD[OF assms(2)]]
  by (induction t arbitrary: T k)
     (auto elim!: types_pset_term_cases intro!: type_of_term_if_types_term
           simp: type_of_term_if_types_term)

lemma I_atom_constrs_atom_if_types_pset_atom:
  fixes a :: "'a pset_atom"
  assumes "inj_on n T" "subterms a \<subseteq> T"
  assumes "v \<turnstile> a"
  shows "(\<forall>e \<in> set (constrs_atom n a).
    Suc_Theory.I_atom (\<lambda>x. type_of_term v (inv_into T n x)) e)"
  using assms I_atom_constrs_term_if_types_term
  by (cases a)
     (force simp: types_pset_atom.simps type_of_term_if_types_term subsetD)+

lemma I_atom_constrs_fm_if_types_pset_fm:
  fixes \<phi> :: "'a pset_fm"
  assumes "inj_on n T" "subterms \<phi> \<subseteq> T"
  assumes "v \<turnstile> \<phi>"
  shows "(\<forall>e \<in> set (constrs_fm n \<phi>).
    Suc_Theory.I_atom (\<lambda>x. type_of_term v (inv_into T n x)) e)"
  using assms
  by (induction \<phi>)
     (auto dest: types_fmD simp: I_atom_constrs_atom_if_types_pset_atom)

lemma inv_into_f_eq_if_subs:
  assumes "inj_on f B" "A \<subseteq> B" "y \<in> f ` A"
  shows "inv_into B f y = inv_into A f y"
  using assms inv_into_f_eq
  by (metis f_inv_into_f inv_into_into subset_eq)

lemma UN_set_suc_atom_constrs_term_eq_image_subterms:
  "\<Union>(set_suc_atom ` set (constrs_term n t)) = n ` subterms t"
  by (induction t) auto

lemma UN_set_suc_atom_constrs_atom_eq_image_subterms:
  "\<Union>(set_suc_atom ` set (constrs_atom n a)) = n ` subterms a"
  by (induction a) (auto simp: UN_set_suc_atom_constrs_term_eq_image_subterms)

lemma UN_set_suc_atom_constrs_fm_eq_image_subterms:
  "\<Union>(set_suc_atom ` set (constrs_fm n \<phi>)) = n ` subterms \<phi>"
  by (induction \<phi>) (auto simp: UN_set_suc_atom_constrs_atom_eq_image_subterms)

lemma
  fixes \<phi> :: "'a pset_fm"
  assumes "inj_on n (subterms \<phi>)"
  assumes "Suc_Theory.solve (Suc_Theory.elim_NEq_Zero (constrs_fm n \<phi>)) = Some ss"
  shows types_pset_fm_assign_solve: "(\<lambda>x. Suc_Theory.assign ss (n (Var x))) \<turnstile> \<phi>"
    and minimal_assign_solve: "\<lbrakk> v \<turnstile> \<phi>; z \<in> vars \<phi> \<rbrakk> \<Longrightarrow> Suc_Theory.assign ss (n (Var z)) \<le> v z"
proof -
  note I_atom_assign_if_solve_elim_NEq_Zero_Some[OF _ _ assms(2)]
  then have "\<forall>e \<in> set (constrs_fm n \<phi>). Suc_Theory.I_atom (Suc_Theory.assign ss) e"
    using is_Succ_normal_constrs_fm is_Var_Eq_Zero_if_is_NEq_constrs_fm by blast
  note types_pset_fm_if_I_atom_constrs_fm[OF this]
  then show "(\<lambda>x. Suc_Theory.assign ss (n (Var x))) \<turnstile> \<phi>" .

  let ?v' = "\<lambda>x. type_of_term v (inv_into (subterms \<phi>) n x)"
  note I_atom_assign_minimal_if_solve_elim_NEq_Zero_Some[OF _ _ assms(2)]
  then have assign_leq: "Suc_Theory.assign ss z \<le> v z"
    if "\<forall>a \<in> set (constrs_fm n \<phi>). Suc_Theory.I_atom v a"
       "z \<in> \<Union> (set_suc_atom ` set (constrs_fm n \<phi>))" for v z
    using that is_Succ_normal_constrs_fm is_Var_Eq_Zero_if_is_NEq_constrs_fm
    by blast
  show "Suc_Theory.assign ss (n (Var z)) \<le> v z" if "v \<turnstile> \<phi>" "z \<in> vars \<phi>"
  proof -
    note assign_leq[unfolded UN_set_suc_atom_constrs_fm_eq_image_subterms, where ?v="?v'"]
    note assign_leq' = this[OF I_atom_constrs_fm_if_types_pset_fm[OF assms(1) _ \<open>v \<turnstile> \<phi>\<close>, simplified]]

    from \<open>z \<in> vars \<phi>\<close> have "n (Var z) \<in> n ` subterms \<phi>"
      by (simp add: vars_fm_subs_subterms_fm)
    from assign_leq'[OF this] \<open>inj_on n (subterms \<phi>)\<close> \<open>z \<in> vars \<phi>\<close> show ?thesis
      using vars_fm_subs_subterms_fm
      by (metis inv_into_f_f type_of_term_if_types_term types_pset_term.intros(2))
  qed
qed

lemma types_term_minimal:
  assumes "\<And>z. z \<in> vars t \<Longrightarrow> v_min z \<le> v z"
  assumes "v_min \<turnstile> t : k'" "v \<turnstile> t : k"
  shows "k' \<le> k"
  using assms
  by (induction t arbitrary: k' k) (auto elim!: types_pset_term_cases)

lemma constrs_term_subs_constrs_term:
  assumes "s \<in> subterms t"
  shows "set (constrs_term n s) \<subseteq> set (constrs_term n t)"
  using assms
  by (induction t) auto

lemma constrs_term_subs_constrs_atom:
  assumes "t \<in> subterms a"
  shows "set (constrs_term n t) \<subseteq> set (constrs_atom n a)"
  using assms constrs_term_subs_constrs_term by (cases a) force+

lemma constrs_term_subs_constrs_fm:
  assumes "t \<in> subterms \<phi>"
  shows "set (constrs_term n t) \<subseteq> set (constrs_fm n \<phi>)"
  using assms
  by (induction \<phi>) (auto simp: constrs_term_subs_constrs_atom)

lemma urelem_iff_assign_eq_0:
  assumes "inj_on n (subterms \<phi>)"
  assumes "t \<in> subterms \<phi>"
  assumes "Suc_Theory.solve (Suc_Theory.elim_NEq_Zero (constrs_fm n \<phi>)) = Some ss"
  shows "urelem \<phi> t \<longleftrightarrow> Suc_Theory.assign ss (n t) = 0"
proof -
  note types = types_pset_fm_assign_solve[OF assms(1,3)]

  note I_atom_assign_if_solve_elim_NEq_Zero_Some[OF _ _ assms(3)]
  then have "\<forall>e \<in> set (constrs_fm n \<phi>). Suc_Theory.I_atom (Suc_Theory.assign ss) e"
    using is_Succ_normal_constrs_fm is_Var_Eq_Zero_if_is_NEq_constrs_fm by blast
  then have "\<forall>e \<in> set (constrs_term n t). Suc_Theory.I_atom (Suc_Theory.assign ss) e"
    using constrs_term_subs_constrs_fm[OF \<open>t \<in> subterms \<phi>\<close>] by blast
  note type_term_t = types_term_if_I_atom_constrs_term[OF this]

  note minimal = minimal_assign_solve[OF assms(1,3)]
  have "\<exists>lt'. v \<turnstile> t : lt' \<and> Suc_Theory.assign ss (n t) \<le> lt'"
    if "v \<turnstile> \<phi>" for v
  proof -
    from that obtain lt' where "v \<turnstile> t : lt'"
      using \<open>t \<in> subterms \<phi>\<close>
      by (meson not_Some_eq subterms_type_pset_fm_not_None)
    moreover note minimal[OF that] types_term_minimal[OF _ type_term_t]
    ultimately show ?thesis
      by (metis assms(2) mem_vars_fm_if_mem_subterms_fm)
  qed

  then show "urelem \<phi> t \<longleftrightarrow> Suc_Theory.assign ss (n t) = 0"
    using types type_term_t types_term_unique unfolding urelem_def
    by (metis le_zero_eq)
qed

lemma not_types_fm_if_solve_eq_None:
  fixes \<phi> :: "'a pset_fm"
  assumes "inj_on n (subterms \<phi>)"
  assumes "Suc_Theory.solve (Suc_Theory.elim_NEq_Zero (constrs_fm n \<phi>)) = None"
  shows "\<not> v \<turnstile> \<phi>"
proof
  assume "v \<turnstile> \<phi>"
  note I_atom_constrs_fm_if_types_pset_fm[OF assms(1) _ this]
  moreover
  note not_I_atom_if_solve_elim_NEq_Zero_None[OF _ _ assms(2)]
  then have "\<exists>a\<in>set (constrs_fm n \<phi>). \<not> Suc_Theory.I_atom v a" for v
    using is_Succ_normal_constrs_fm is_Var_Eq_Zero_if_is_NEq_constrs_fm by blast
  ultimately show False
    by blast
qed

hide_const (open) SVar SEq SNEq

end