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

section "Additional Word Operations"

theory Word_Lib
imports
  Word_Syntax
begin

definition
  ptr_add :: "'a :: len word \<Rightarrow> nat \<Rightarrow> 'a word" where
  "ptr_add ptr n \<equiv> ptr + of_nat n"

definition
  complement :: "'a :: len word \<Rightarrow> 'a word"  where
 "complement x \<equiv> ~~ x"

definition
  alignUp :: "'a::len word \<Rightarrow> nat \<Rightarrow> 'a word" where
 "alignUp x n \<equiv> x + 2 ^ n - 1 && complement (2 ^ n - 1)"

(* Haskellish names/syntax *)
notation (input)
  test_bit ("testBit")

definition
  w2byte :: "'a :: len word \<Rightarrow> 8 word" where
  "w2byte \<equiv> ucast"

(*
 * Signed division: when the result of a division is negative,
 * we will round towards zero instead of towards minus infinity.
 *)
class signed_div =
  fixes sdiv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "sdiv" 70)
  fixes smod :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "smod" 70)

instantiation int :: signed_div
begin
definition "(a :: int) sdiv b \<equiv> sgn (a * b) * (abs a div abs b)"
definition "(a :: int) smod b \<equiv> a - (a sdiv b) * b"
instance ..
end

instantiation word :: (len) signed_div
begin
definition "(a :: ('a::len) word) sdiv b = word_of_int (sint a sdiv sint b)"
definition "(a :: ('a::len) word) smod b = word_of_int (sint a smod sint b)"
instance ..
end

(* Tests *)
lemma
  "( 4 :: word32) sdiv  4 =  1"
  "(-4 :: word32) sdiv  4 = -1"
  "(-3 :: word32) sdiv  4 =  0"
  "( 3 :: word32) sdiv -4 =  0"
  "(-3 :: word32) sdiv -4 =  0"
  "(-5 :: word32) sdiv -4 =  1"
  "( 5 :: word32) sdiv -4 = -1"
  by (simp_all add: sdiv_word_def sdiv_int_def)

lemma
  "( 4 :: word32) smod  4 =   0"
  "( 3 :: word32) smod  4 =   3"
  "(-3 :: word32) smod  4 =  -3"
  "( 3 :: word32) smod -4 =   3"
  "(-3 :: word32) smod -4 =  -3"
  "(-5 :: word32) smod -4 =  -1"
  "( 5 :: word32) smod -4 =   1"
  by (simp_all add: smod_word_def smod_int_def sdiv_int_def)

(* Count leading zeros  *)
definition
  word_clz :: "'a::len word \<Rightarrow> nat"
where
  "word_clz w \<equiv> length (takeWhile Not (to_bl w))"

definition
  word_log2 :: "'a::len word \<Rightarrow> nat"
where
  "word_log2 (w::'a::len word) \<equiv> size w - 1 - word_clz w"

(* Bit population count. Equivalent of __builtin_popcount. *)
definition
  pop_count :: "('a::len) word \<Rightarrow> nat"
where
  "pop_count w \<equiv> length (filter id (to_bl w))"

lemma ptr_add_0 [simp]:
  "ptr_add ref 0 = ref "
  unfolding ptr_add_def by simp

lemma shiftl_power:
  "(shiftl1 ^^ x) (y::'a::len word) = 2 ^ x * y"
  apply (induct x)
   apply simp
  apply (simp add: shiftl1_2t)
  done

lemmas of_bl_reasoning = to_bl_use_of_bl of_bl_append

(*TODO: delete, this will be in the Isabelle main distribution in future*)
lemma bl_to_bin_lt2p_drop: "bl_to_bin bs < 2 ^ length (dropWhile Not bs)"
  unfolding bl_to_bin_def
proof(induction bs)
  case(Cons b bs) with bl_to_bin_lt2p_aux[where w=1] show ?case by simp
qed simp

lemma uint_of_bl_is_bl_to_bin_drop:
  "length (dropWhile Not l) \<le> len_of TYPE('a) \<Longrightarrow> uint (of_bl l :: 'a::len word) = bl_to_bin l"
  apply (simp add: of_bl_def)
  apply (rule word_uint.Abs_inverse)
  apply (simp add: uints_num bl_to_bin_ge0)
  apply (rule order_less_le_trans)
  apply (rule bl_to_bin_lt2p_drop)
  apply (simp)
  done

corollary uint_of_bl_is_bl_to_bin:
  "length l\<le>len_of TYPE('a) \<Longrightarrow> uint ((of_bl::bool list\<Rightarrow> ('a :: len) word) l) = bl_to_bin l"
  apply(rule uint_of_bl_is_bl_to_bin_drop)
  using le_trans length_dropWhile_le by blast

lemma bin_to_bl_or:
  "bin_to_bl n (a OR b) = map2 (op \<or>) (bin_to_bl n a) (bin_to_bl n b)"
  using bl_or_aux_bin[where n=n and v=a and w=b and bs="[]" and cs="[]"]
  by simp

lemma word_ops_nth [simp]:
  shows
  word_or_nth:  "(x || y) !! n = (x !! n \<or> y !! n)" and
  word_and_nth: "(x && 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])+

(* simp del to avoid warning on the simp add in iff *)
declare test_bit_1 [simp del, iff]

(* test: *)
lemma "1 < (1024::32 word) \<and> 1 \<le> (1024::32 word)" by simp

lemma and_not_mask:
  "w AND NOT mask n = (w >> n) << n"
  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)"
  apply (rule word_eqI)
  apply (simp add : word_ops_nth_size word_size)
  apply (simp add : nth_shiftr nth_shiftl)
  by auto

lemma AND_twice [simp]:
  "(w && m) && m = w && m"
  by (simp add: word_eqI)

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

lemma p2_gt_0:
  "(0 < (2 ^ n :: 'a :: len word)) = (n < len_of TYPE('a))"
  apply (simp add : word_gt_0)
  apply safe
   apply (erule swap)
   apply (rule word_eqI)
   apply (simp add : nth_w2p)
  apply (drule word_eqD)
  apply simp
  apply (erule notE)
  apply (erule nth_w2p_same [THEN iffD2])
  done

lemmas uint_2p_alt = uint_2p [unfolded p2_gt_0]

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 (rule word_uint.Rep_inverse' [THEN sym])
  apply (rule shiftr_div_2n)
  done

lemmas less_def = less_eq [symmetric]
lemmas le_def = not_less [symmetric, where ?'a = nat]

lemmas p2_eq_0 [simp] = trans [OF eq_commute
  iffD2 [OF Not_eq_iff p2_gt_0, folded le_def, unfolded word_gt_0 not_not]]

lemma neg_mask_is_div':
  "n < size w \<Longrightarrow> w AND NOT mask n = ((w div (2 ^ n)) * (2 ^ n))"
  by (simp add : and_not_mask shiftr_div_2n_w shiftl_t2n word_size)

lemma neg_mask_is_div:
  "w AND NOT mask n = (w div 2^n) * 2^n"
  apply (cases "n < size w")
   apply (erule neg_mask_is_div')
  apply (simp add: word_size)
  apply (frule p2_gt_0 [THEN Not_eq_iff [THEN iffD2], THEN iffD2])
  apply (simp add: word_gt_0  del: p2_eq_0)
  apply (rule word_eqI)
  apply (simp add: word_ops_nth_size word_size)
  done

lemma and_mask_arith':
  "0 < n \<Longrightarrow> w AND mask n = (w * 2^(size w - n)) div 2^(size w - n)"
  by (simp add: and_mask shiftr_div_2n_w shiftl_t2n word_size mult.commute)

lemma mask_0[simp]: "mask 0 = 0"
  unfolding mask_def by simp

lemmas p2len = iffD2 [OF p2_eq_0 order_refl]

lemma mask_2pm1: "mask n = 2 ^ n - 1"
  by (simp add : mask_def)

lemma is_aligned_AND_less_0:
  "u && mask n = 0 \<Longrightarrow> v < 2^n \<Longrightarrow> u && v = 0"
  apply (drule less_mask_eq)
  apply (simp add: mask_2pm1)
  apply (rule word_eqI)
  apply (clarsimp simp add: word_size)
  apply (drule_tac x=na in word_eqD)
  apply (drule_tac x=na in word_eqD)
  apply simp
  done

lemma le_shiftr1:
  "u <= v \<Longrightarrow> shiftr1 u <= shiftr1 v"
  apply (unfold word_le_def shiftr1_def word_ubin.eq_norm)
  apply (unfold bin_rest_trunc_i
                trans [OF bintrunc_bintrunc_l word_ubin.norm_Rep,
                          unfolded word_ubin.norm_Rep,
                       OF order_refl [THEN le_SucI]])
  apply (case_tac "uint u" rule: bin_exhaust)
  apply (rename_tac bs bit)
  apply (case_tac "uint v" rule: bin_exhaust)
  apply (rename_tac bs' bit')
  apply (case_tac "bit")
   apply (case_tac "bit'", auto simp: less_eq_int_code le_Bits)[1]
  apply (case_tac bit')
   apply (simp add: le_Bits less_eq_int_code)
  apply (auto simp: le_Bits less_eq_int_code)
  done

lemma le_shiftr:
  "u \<le> v \<Longrightarrow> u >> (n :: nat) \<le> (v :: 'a :: len0 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"
  apply (rule word_eqI)
  apply (simp add: word_size nth_shiftr)
  done

lemmas shiftr_mask = order_refl [THEN shiftr_mask_le, simp]

lemma word_leI:
  "(\<And>n.  \<lbrakk>n < size (u::'a::len0 word); u !! n \<rbrakk> \<Longrightarrow> (v::'a::len0 word) !! n) \<Longrightarrow> u <= v"
  apply (rule xtr4)
   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)"
  apply safe
   apply (rule word_le_0_iff [THEN iffD1])
   apply (rule xtr3)
    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)"
  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 (drule_tac f = "%u. u !! (x - n)" in arg_cong)
  apply (simp add : nth_shiftr)
  apply (case_tac "n <= x")
   apply auto
  done

lemmas and_mask_eq_iff_le_mask = trans
  [OF and_mask_eq_iff_shiftr_0 le_mask_iff [THEN sym]]

lemma one_bit_shiftl: "set_bit 0 n True = (1 :: 'a :: len word) << n"
  apply (rule word_eqI)
  apply (auto simp add: test_bit_set_gen nth_shiftl word_size
              simp del: word_set_bit_0 shiftl_1)
  done

lemmas one_bit_pow = trans [OF one_bit_shiftl shiftl_1]

lemmas bin_sc_minus_simps =
  bin_sc_simps (2,3,4) [THEN [2] trans, OF bin_sc_minus [THEN sym]]

lemma NOT_eq:
  "NOT (x :: 'a :: len word) = - x - 1"
  apply (cut_tac x = "x" in word_add_not)
  apply (drule add.commute [THEN trans])
  apply (drule eq_diff_eq [THEN iffD2])
  by simp

lemma NOT_mask: "NOT (mask n) = -(2 ^ n)"
  by (simp add : NOT_eq mask_2pm1)

lemma le_m1_iff_lt: "(x > (0 :: 'a :: len word)) = ((y \<le> x - 1) = (y < x))"
  by uint_arith

lemmas gt0_iff_gem1 = iffD1 [OF iffD1 [OF iff_left_commute le_m1_iff_lt] order_refl]

lemmas power_2_ge_iff = trans [OF gt0_iff_gem1 [THEN sym] p2_gt_0]

lemma le_mask_iff_lt_2n:
  "n < len_of TYPE ('a) = (((w :: 'a :: len word) \<le> mask n) = (w < 2 ^ n))"
  unfolding mask_2pm1 by (rule trans [OF p2_gt_0 [THEN sym] le_m1_iff_lt])

lemmas mask_lt_2pn =
  le_mask_iff_lt_2n [THEN iffD1, THEN iffD1, OF _ order_refl]

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

lemma word_unat_power:
  "(2 :: 'a :: len word) ^ n = of_nat (2 ^ n)"
  by simp

lemma of_nat_mono_maybe:
  assumes xlt: "x < 2 ^ len_of TYPE ('a)"
  shows   "y < x \<Longrightarrow> of_nat y < (of_nat x :: 'a :: len word)"
  apply (subst word_less_nat_alt)
  apply (subst unat_of_nat)+
  apply (subst mod_less)
   apply (erule order_less_trans [OF _ xlt])
  apply (subst mod_less [OF xlt])
  apply assumption
  done

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 word_and_max_word:
  fixes a::"'a::len word"
  shows "x = max_word \<Longrightarrow> a AND x = a"
  by simp

lemma word_and_1:
  fixes x::"'a::len word"
  shows "(x AND 1) = (if x!!0 then 1 else 0)"
  apply(rule word_eqI)
  apply(simp add:word_ao_nth)
  apply(rule conjI)
   apply(auto)[1]
  apply clarsimp
  apply (case_tac n)
   apply simp
  apply simp
  done

lemma word_and_1_bl:
  fixes x::"'a::len word"
  shows "(x AND 1) = of_bl [x !! 0]"
  by (simp add: word_and_1)

lemma word_1_and_bl:
  fixes x::"'a::len word"
  shows "(1 AND x) = of_bl [x !! 0]"
  by (subst word_bw_comms) (simp add: word_and_1)

lemma scast_scast_id [simp]:
  "scast (scast x :: ('a::len) signed word) = (x :: 'a word)"
  "scast (scast y :: ('a::len) word) = (y :: 'a signed word)"
  by (auto simp: is_up scast_up_scast_id)

lemma scast_ucast_id [simp]:
    "scast (ucast (x :: 'a::len word) :: 'a signed word) = x"
  by (metis down_cast_same is_down len_signed order_refl scast_scast_id(1))

lemma ucast_scast_id [simp]:
    "ucast (scast (x :: 'a::len signed word) :: 'a word) = x"
  by (metis scast_scast_id(2) scast_ucast_id)

lemma scast_of_nat [simp]:
    "scast (of_nat x :: 'a::len signed word) = (of_nat x :: 'a word)"
  by (metis (hide_lams, no_types) len_signed scast_def uint_sint
         word_of_nat word_ubin.Abs_norm word_ubin.eq_norm)

lemma ucast_of_nat:
  "is_down (ucast :: 'a :: len word \<Rightarrow> 'b :: len word)
    \<Longrightarrow> ucast (of_nat n :: 'a word) = (of_nat n :: 'b word)"
  apply (rule sym)
  apply (subst word_unat.inverse_norm)
  apply (simp add: ucast_def word_of_int[symmetric]
                   of_nat_nat[symmetric] unat_def[symmetric])
  apply (simp add: unat_of_nat)
  apply (rule nat_int.Rep_eqD)
  apply (simp only: zmod_int)
  apply (rule mod_mod_cancel)
  apply (subst zdvd_int[symmetric])
  apply (rule le_imp_power_dvd)
  apply (simp add: is_down_def target_size_def source_size_def word_size)
  done

(* shortcut for some specific lengths *)
lemma word_fixed_sint_1[simp]:
  "sint (1::8 word) = 1"
  "sint (1::16 word) = 1"
  "sint (1::32 word) = 1"
  "sint (1::64 word) = 1"
  by (auto simp: sint_word_ariths)

lemma word_sint_1 [simp]:
  "sint (1::'a::len word) = (if len_of TYPE('a) = 1 then -1 else 1)"
  apply (case_tac "len_of TYPE('a) \<le> 1")
   apply (metis diff_is_0_eq sbintrunc_0_numeral(1) sint_n1 word_1_wi
           word_m1_wi word_msb_1 word_msb_n1 word_sbin.Abs_norm)
  apply (metis bin_nth_1 diff_is_0_eq neq0_conv sbintrunc_minus_simps(4)
            sint_word_ariths(8) uint_1 word_msb_1 word_msb_nth)
  done

lemma scast_1':
  "(scast (1::'a::len word) :: 'b::len word) =
   (word_of_int (sbintrunc (len_of TYPE('a::len) - Suc 0) (1::int)))"
  by (metis One_nat_def scast_def sint_word_ariths(8))

lemma scast_1 [simp]:
  "(scast (1::'a::len word) :: 'b::len word) = (if len_of TYPE('a) = 1 then -1 else 1)"
  by (clarsimp simp: scast_1')
     (metis Suc_pred len_gt_0 nat.exhaust sbintrunc_Suc_numeral(1) uint_1 word_uint.Rep_inverse')

lemma scast_eq_scast_id [simp]:
  "((scast (a :: 'a::len signed word) :: 'a word) = scast b) = (a = b)"
  by (metis ucast_scast_id)

lemma ucast_eq_ucast_id [simp]:
  "((ucast (a :: 'a::len word) :: 'a signed word) = ucast b) = (a = b)"
  by (metis scast_ucast_id)

lemma scast_ucast_norm [simp]:
  "(ucast (a :: 'a::len word) = (b :: 'a signed word)) = (a = scast b)"
  "((b :: 'a signed word) = ucast (a :: 'a::len word)) = (a = scast b)"
  by (metis scast_ucast_id ucast_scast_id)+

lemma of_bl_drop:
  "of_bl (drop n xs) = (of_bl xs && mask (length xs - n))"
  apply (clarsimp simp: bang_eq test_bit_of_bl rev_nth cong: rev_conj_cong)
  apply (safe; simp add: word_size to_bl_nth)
  done

lemma of_int_uint [simp]:
  "of_int (uint x) = x"
  by (metis word_of_int word_uint.Rep_inverse')

lemma shiftr_mask2:
  "n \<le> len_of TYPE('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

corollary word_plus_and_or_coroll:
  "x && y = 0 \<Longrightarrow> x + y = x || y"
  using word_plus_and_or[where x=x and y=y]
  by simp

corollary word_plus_and_or_coroll2:
  "(x && w) + (x && ~~ w) = x"
  apply (subst word_plus_and_or_coroll)
   apply (rule word_eqI, simp add: word_size word_ops_nth_size)
  apply (rule word_eqI, simp add: word_size word_ops_nth_size)
  apply blast
  done

lemma less_le_mult_nat':
  "w * c < b * c ==> 0 \<le> c ==> Suc w * c \<le> b * (c::nat)"
  apply (rule mult_right_mono)
   apply (rule Suc_leI)
   apply (erule (1) mult_right_less_imp_less)
  apply assumption
  done

lemmas less_le_mult_nat = less_le_mult_nat'[simplified distrib_right, simplified]

(* FIXME: these should eventually be moved to HOL/Word. *)
lemmas extra_sle_sless_unfolds [simp] =
    word_sle_def[where a=0 and b=1]
    word_sle_def[where a=0 and b="numeral n"]
    word_sle_def[where a=1 and b=0]
    word_sle_def[where a=1 and b="numeral n"]
    word_sle_def[where a="numeral n" and b=0]
    word_sle_def[where a="numeral n" and b=1]
    word_sless_alt[where a=0 and b=1]
    word_sless_alt[where a=0 and b="numeral n"]
    word_sless_alt[where a=1 and b=0]
    word_sless_alt[where a=1 and b="numeral n"]
    word_sless_alt[where a="numeral n" and b=0]
    word_sless_alt[where a="numeral n" and b=1]
  for n

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

  also have "\<dots> = replicate (len_of TYPE('a) - 1) False @ [True]"
    by (cases "len_of TYPE('a)"; clarsimp simp: to_bl_mask)

  finally show ?thesis .
qed

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

lemma eq_zero_set_bl:
  "(w = 0) = (True \<notin> set (to_bl w))"
  using list_of_false word_bl.Rep_inject by fastforce

lemma diff_diff_less:
  "(i < m - (m - (n :: nat))) = (i < m \<and> i < n)"
  by auto

lemma pop_count_0[simp]:
  "pop_count 0 = 0"
  by (clarsimp simp:pop_count_def)

lemma pop_count_1[simp]:
  "pop_count 1 = 1"
  by (clarsimp simp:pop_count_def to_bl_1)

lemma pop_count_0_imp_0:
  "(pop_count w = 0) = (w = 0)"
  apply (rule iffI)
   apply (clarsimp simp:pop_count_def)
   apply (subst (asm) filter_empty_conv)
   apply (clarsimp simp:eq_zero_set_bl)
   apply fast
  apply simp
  done

end


(*
  File: Morphism.thy
  Author: Bohua Zhan

  Morphisms (functions between two structures).
*)

theory Morphism
  imports Functions
begin

section \<open>Components of morphisms\<close>

(* A morphism is a function with two additional components, giving the source
   and target structure of the morphism. *)
definition "source_str_name = succ(succ(succ(\<emptyset>)))"
definition "target_str_name = succ(succ(succ(succ(\<emptyset>))))"

definition "source_str(S) = graph_eval(S, source_str_name)"
definition "target_str(S) = graph_eval(S, target_str_name)"

setup {* add_field_data (@{term source_str_name}, @{term source_str}) *}
setup {* add_field_data (@{term target_str_name}, @{term target_str}) *}
setup {* fold add_property_field_const [@{term source_str}, @{term target_str}] *}

definition is_morphism :: "i \<Rightarrow> o" where [rewrite]:
  "is_morphism(f) \<longleftrightarrow>
     graph(f) \<in> func_graphs(source(f),target(f)) \<and>
     carrier(source_str(f)) = source(f) \<and> carrier(target_str(f)) = target(f)"

definition mor_form :: "i \<Rightarrow> o" where [rewrite]:
  "mor_form(f) \<longleftrightarrow> is_morphism(f) \<and>
    is_func_graph(f,{source_name,target_name,graph_name,source_str_name,target_str_name})"

setup {* add_rewrite_rule @{thm is_function_def} *}
lemma is_morphism_gen_to_fun [forward]: "is_morphism(F) \<Longrightarrow> is_function(F)" by auto2
setup {* del_prfstep_thm @{thm is_function_def} *}

lemma is_morphism_to_gen [forward]: "mor_form(F) \<Longrightarrow> is_morphism(F)" by auto2

lemma is_morphism_src [forward]:
  "is_morphism(F) \<Longrightarrow> carrier(source_str(F)) = source(F) \<and> carrier(target_str(F)) = target(F)" by auto2

(* Space of all morphisms between structures S and T. *)
definition mor_space :: "i \<Rightarrow> i \<Rightarrow> i" (infix "\<rightharpoonup>" 60) where [rewrite]:
  "mor_space(S,T) = (let A = carrier(S) in let B = carrier(T) in
    {Struct({\<langle>source_name,A\<rangle>,\<langle>target_name,B\<rangle>,\<langle>graph_name,G\<rangle>,\<langle>source_str_name,S\<rangle>,\<langle>target_str_name,T\<rangle>}). G\<in>func_graphs(A,B)})"

lemma mor_space_iff [rewrite]:
  "A = carrier(S) \<Longrightarrow> B = carrier(T) \<Longrightarrow> F \<in> S \<rightharpoonup> T \<longleftrightarrow>
  (\<exists>G\<in>func_graphs(A,B). F = Struct({\<langle>source_name,A\<rangle>,\<langle>target_name,B\<rangle>,\<langle>graph_name,G\<rangle>,\<langle>source_str_name,S\<rangle>,\<langle>target_str_name,T\<rangle>}))" by auto2
setup {* del_prfstep_thm @{thm mor_space_def} *}

lemma mor_spaceD [forward]:
  "F \<in> S \<rightharpoonup> T \<Longrightarrow> mor_form(F) \<and> source_str(F) = S \<and> target_str(F) = T" by auto2

lemma mor_spaceI [forward]:
  "mor_form(F) \<Longrightarrow> F \<in> source_str(F) \<rightharpoonup> target_str(F)" by auto2

(* Constructor for morphisms *)
definition Mor :: "[i, i, i \<Rightarrow> i] \<Rightarrow> i" where [rewrite]:
  "Mor(S,T,b) = (let A = carrier(S) in let B = carrier(T) in
    Struct({\<langle>source_name,A\<rangle>,\<langle>target_name,B\<rangle>,\<langle>graph_name,{p\<in>A\<times>B. snd(p) = b(fst(p))}\<rangle>,\<langle>source_str_name,S\<rangle>,\<langle>target_str_name,T\<rangle>}))"
setup {* add_prfstep_check_req ("Mor(S,T,b)", "Mor(S,T,b) \<in> S \<rightharpoonup> T") *}

lemma Mor_is_morphism [backward]:
  "\<forall>x\<in>.S. f(x)\<in>.T \<Longrightarrow> Mor(S,T,f) \<in> S \<rightharpoonup> T"
@proof
  @let "A = carrier(S)" "B = carrier(T)"
  @let "G = {p\<in>A\<times>B. snd(p) = f(fst(p))}"
  @have "is_graph(G)"
  @have "\<forall>x. x \<in> gr_source(G) \<longleftrightarrow> x \<in> A" @with
    @case "x \<in> gr_source(G)" @with @obtain y where "\<langle>x,y\<rangle> \<in> G" @end
    @case "x \<in> A" @with @have "\<langle>x, f(x)\<rangle> \<in> G" @end
  @end
  @have "G \<in> func_graphs(A,B)"
@qed

lemma Mor_eval [rewrite]:
  "F = Mor(S,T,f) \<Longrightarrow> x \<in> source(F) \<Longrightarrow> is_morphism(F) \<Longrightarrow> F`x = f(x)" by auto2

(* Equality between morphisms *)
lemma morphism_eq [backward]:
  "mor_form(f) \<Longrightarrow> mor_form(g) \<Longrightarrow> source_str(f) = source_str(g) \<Longrightarrow> target_str(f) = target_str(g) \<Longrightarrow>
   \<forall>x\<in>source(f). f`x = g`x \<Longrightarrow> f = g"
@proof @have "\<forall>x\<in>source(f). graph_eval(graph(f),x) = graph_eval(graph(g),x)" @qed

setup {* fold del_prfstep_thm [@{thm mor_form_def}, @{thm is_morphism_def}, @{thm mor_space_iff}, @{thm Mor_def}] *}

(* A small exercise *)
lemma Mor_eq_self:
  "f \<in> A \<rightharpoonup> B \<Longrightarrow> f = Mor(A,B, \<lambda>x. f`x)" by auto2

section \<open>Important examples of morphisms\<close>

(* Identity morphism *)
definition id_mor :: "i \<Rightarrow> i" where [rewrite]:
  "id_mor(A) = Mor(A,A, \<lambda>x. x)"

lemma id_mor_is_morphism [typing]: "id_mor(A) \<in> A \<rightharpoonup> A" by auto2
lemma id_mor_eval [rewrite]: "x \<in> source(id_mor(A)) \<Longrightarrow> id_mor(A) ` x = x" by auto2
lemma id_mor_vImage [rewrite]: "X \<subseteq> source(id_mor(A)) \<Longrightarrow> id_mor(A) -`` X = X" by auto2
setup {* del_prfstep_thm @{thm id_mor_def} *}
setup {* add_rewrite_rule_back @{thm id_mor_def} *}

(* Constant morphism *)
definition const_mor :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "const_mor(A,B,y) = Mor(A,B, \<lambda>x. y)"
setup {* register_wellform_data ("const_mor(A,B,y)", ["y \<in>. B"]) *}
setup {* add_prfstep_check_req ("const_mor(A,B,y)", "y \<in>. B") *}

lemma const_mor_is_function [typing]: "y \<in>. B \<Longrightarrow> const_mor(A,B,y) \<in> A \<rightharpoonup> B" by auto2
lemma const_mor_eval [rewrite]: "y \<in>. B \<Longrightarrow> f = const_mor(A,B,y) \<Longrightarrow> x \<in> source(f) \<Longrightarrow> f`x = y" by auto2
lemma const_mor_vImage [rewrite]: "y \<in>. Y \<Longrightarrow> y \<notin> A \<Longrightarrow> const_mor(X,Y,y) -`` A = \<emptyset>" by auto2
lemma const_mor_vImage2 [rewrite]: "y \<in>. Y \<Longrightarrow> y \<in> A \<Longrightarrow> const_mor(X,Y,y) -`` A = carrier(X)" by auto2
setup {* del_prfstep_thm @{thm const_mor_def} *}
setup {* add_rewrite_rule_back @{thm const_mor_def} *}

section \<open>Composition and inverse of morphisms\<close>

(* Composition of two morphisms *)
definition mor_comp :: "i \<Rightarrow> i \<Rightarrow> i"  (infixr "\<circ>\<^sub>m" 60) where [rewrite]:
  "g \<circ>\<^sub>m f = Mor(source_str(f), target_str(g), \<lambda>x. g`(f`x))"
setup {* register_wellform_data
  ("g \<circ>\<^sub>m f", ["mor_form(g)", "mor_form(f)", "target_str(f) = source_str(g)"]) *}
setup {* add_prfstep_check_req ("g \<circ>\<^sub>m f", "target_str(f) = source_str(g)") *}

lemma mor_comp_is_morphism [typing]:
  "is_morphism(f) \<Longrightarrow> is_morphism(g) \<Longrightarrow> target_str(f) = source_str(g) \<Longrightarrow>
   g \<circ>\<^sub>m f \<in> source_str(f) \<rightharpoonup> target_str(g)" by auto2

lemma mor_comp_eval [rewrite]:
  "is_morphism(f) \<Longrightarrow> is_morphism(g) \<Longrightarrow> target_str(f) = source_str(g) \<Longrightarrow>
   x \<in> source(f) \<Longrightarrow> (g \<circ>\<^sub>m f) ` x = g ` (f ` x)" by auto2
setup {* add_rewrite_rule_back_cond @{thm mor_comp_eval} [with_term "?g \<circ>\<^sub>m ?f"] *}
setup {* del_prfstep_thm @{thm mor_comp_def} *}

lemma mor_comp_assoc_l:
  "mor_form(x) \<Longrightarrow> mor_form(y) \<Longrightarrow> mor_form(z) \<Longrightarrow> target_str(z) = source_str(y) \<Longrightarrow>
   target_str(y \<circ>\<^sub>m z) = source_str(x) \<Longrightarrow> x \<circ>\<^sub>m (y \<circ>\<^sub>m z) = (x \<circ>\<^sub>m y) \<circ>\<^sub>m z \<and>
   mor_form(x \<circ>\<^sub>m y) \<and> target_str(y) = source_str(x) \<and> target_str(z) = source_str(x \<circ>\<^sub>m y)" by auto2
setup {* add_prfstep (FOL_Assoc.alg_assoc_prfstep (@{term mor_comp}, @{thm mor_comp_assoc_l})) *}

lemma comp_id_left [rewrite]:
  "mor_form(f) \<Longrightarrow> id_mor(target_str(f)) \<circ>\<^sub>m f = f" by auto2

lemma comp_id_right [rewrite]:
  "mor_form(f) \<Longrightarrow> f \<circ>\<^sub>m id_mor(source_str(f)) = f" by auto2

lemma const_mor_left_compose [rewrite]:
  "is_morphism(f) \<Longrightarrow> Y = source_str(f) \<Longrightarrow> Z = target_str(f) \<Longrightarrow> a \<in>. Y \<Longrightarrow>
   f \<circ>\<^sub>m const_mor(X,Y,a) = const_mor(X,Z,f`a)" by auto2

lemma mor_vImage_comp [rewrite]:
  "is_morphism(f) \<Longrightarrow> is_morphism(g) \<Longrightarrow> target_str(f) = source_str(g) \<Longrightarrow>
   (g \<circ>\<^sub>m f) -`` V = f -`` (g -`` V)" by auto2
setup {* add_rewrite_rule_back_cond @{thm mor_vImage_comp} [with_term "?g \<circ>\<^sub>m ?f"] *}

section \<open>Injective, surjective, and bijective morphisms.\<close>

(* Example: injective morphism. *)
definition inj_mor :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "inj_mor(S,T) = Mor(S,T,\<lambda>x. x)"
setup {* register_wellform_data ("inj_mor(S,T)", ["carrier(S) \<subseteq> carrier(T)"]) *}

lemma inj_mor_is_morphism [typing]: "carrier(S) \<subseteq> carrier(T) \<Longrightarrow> inj_mor(S,T) \<in> S \<rightharpoonup> T" by auto2
lemma inj_mor_eval [rewrite]: "carrier(S) \<subseteq> carrier(T) \<Longrightarrow> x \<in> source(inj_mor(S,T)) \<Longrightarrow> inj_mor(S,T)`x = x" by auto2
lemma inj_mor_vImage [rewrite]:
  "carrier(X) \<subseteq> carrier(Y) \<Longrightarrow> inj_mor(X,Y) -`` A = carrier(X) \<inter> A" by auto2
setup {* del_prfstep_thm @{thm inj_mor_def} *}
setup {* add_rewrite_rule_back @{thm inj_mor_def} *}

lemma inj_mor_is_injective: "carrier(S) \<subseteq> carrier(T) \<Longrightarrow> injective(inj_mor(S,T))" by auto2
lemma id_mor_is_bijective: "bijective(id_mor(S))" by auto2

section \<open>Inverse morphism\<close>

definition inverse_mor :: "i \<Rightarrow> i" where [rewrite]:
  "inverse_mor(f) = Mor(target_str(f), source_str(f), \<lambda>y. THE x. x\<in>source(f) \<and> f`x=y)"

lemma has_inverse_mor [typing]:
  "is_morphism(f) \<Longrightarrow> bijective(f) \<Longrightarrow> inverse_mor(f) \<in> target_str(f) \<rightharpoonup> source_str(f)" by auto2

lemma inverse_mor_eval1 [rewrite]:
  "is_morphism(f) \<Longrightarrow> bijective(f) \<Longrightarrow> x \<in> source(f) \<Longrightarrow> f`x = y \<Longrightarrow> inverse_mor(f)`y = x" by auto2

lemma inverse_mor_eval2 [rewrite]:
  "is_morphism(f) \<Longrightarrow> bijective(f) \<Longrightarrow> y \<in> source(inverse_mor(f)) \<Longrightarrow> inverse_mor(f)`y = x \<Longrightarrow> f`x = y" by auto2
setup {* del_prfstep_thm @{thm inverse_mor_def} *}

lemma inv_mor_bijective [forward]:
  "is_morphism(f) \<Longrightarrow> bijective(f) \<Longrightarrow> bijective(inverse_mor(f))"
@proof @have (@rule) "\<forall>x\<in>source(f). inverse_mor(f)`(f`x) = x" @qed

lemma inverse_is_left_inv [rewrite]:
  "is_morphism(f) \<Longrightarrow> bijective(f) \<Longrightarrow> inverse_mor(f) \<circ>\<^sub>m f = id_mor(source_str(f))" by auto2

lemma inverse_is_right_inv [rewrite]:
  "is_morphism(f) \<Longrightarrow> bijective(f) \<Longrightarrow> f \<circ>\<^sub>m inverse_mor(f) = id_mor(target_str(f))" by auto2

lemma inverse_mor_unique [rewrite]:
  "is_morphism(f) \<Longrightarrow> bijective(f) \<Longrightarrow> mor_form(g) \<Longrightarrow> target_str(f) = source_str(g) \<Longrightarrow>
   g \<circ>\<^sub>m f = id_mor(source_str(f)) \<Longrightarrow> inverse_mor(f) = g"
@proof
  @have "\<forall>x\<in>target(f). inverse_mor(f)`x = g`x" @with
    @obtain "y\<in>source(f)" where "f`y = x"
  @end
@qed

lemma inverse_mor_unique' [rewrite]:
  "is_morphism(f) \<Longrightarrow> bijective(f) \<Longrightarrow> mor_form(g) \<Longrightarrow> target_str(g) = source_str(f) \<Longrightarrow>
   f \<circ>\<^sub>m g = id_mor(source_str(g)) \<Longrightarrow> inverse_mor(f) = g"
@proof
  @have "\<forall>x\<in>target(f). inverse_mor(f)`x = g`x" @with
    @have "f ` (g ` x) = (f \<circ> g) ` x"
  @end
@qed

section \<open>Left and right inverses\<close>

lemma has_left_inverse_mor_inj [forward]:
  "is_morphism(f) \<Longrightarrow> is_morphism(r) \<Longrightarrow> target_str(f) = source_str(r) \<Longrightarrow>
   r \<circ>\<^sub>m f = id_mor(source_str(f)) \<Longrightarrow> injective(f)"
@proof
  @have "\<forall>x\<in>source(f). \<forall>y\<in>source(f). f`x = f`y \<longrightarrow> x=y" @with @have "r`(f`x)=x" @end
@qed

lemma has_right_inverse_mor_surj [forward]:
  "is_morphism(f) \<Longrightarrow> is_morphism(s) \<Longrightarrow> target_str(s) = source_str(f) \<Longrightarrow>
   f \<circ>\<^sub>m s = id_mor(target_str(f)) \<Longrightarrow> surjective(f)"
@proof
  @have "\<forall>x\<in>target(f). x\<in>image(f)" @with @have "f`(s`x) = x" @end
@qed

(* Two morphisms that are inverses of each other. *)
definition inverse_mor_pair :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "inverse_mor_pair(f,g) \<longleftrightarrow> (is_morphism(f) \<and> is_morphism(g) \<and>
     source_str(f) = target_str(g) \<and> target_str(f) = source_str(g) \<and>
     f \<circ>\<^sub>m g = id_mor(source_str(g)) \<and> g \<circ>\<^sub>m f = id_mor(source_str(f)))"

lemma inverse_mor_pair_bijective [forward]:
  "inverse_mor_pair(f,g) \<Longrightarrow> is_morphism(f) \<and> is_morphism(g) \<and>
   source_str(f) = target_str(g) \<and> source_str(g) = target_str(f) \<and> bijective(f) \<and> bijective(g)" by auto2

lemma inverse_mor_pairI [backward]:
  "is_morphism(f) \<Longrightarrow> is_morphism(g) \<Longrightarrow> source_str(f) = target_str(g) \<Longrightarrow> source_str(g) = target_str(f) \<Longrightarrow>
   \<forall>x\<in>source(g). f`(g`x) = x \<Longrightarrow> \<forall>x\<in>source(f). g`(f`x) = x \<Longrightarrow> inverse_mor_pair(f,g)" by auto2

lemma inverse_mor_pairE [rewrite]:
  "inverse_mor_pair(f,g) \<Longrightarrow> f \<circ>\<^sub>m g = id_mor(source_str(g))"
  "inverse_mor_pair(f,g) \<Longrightarrow> g \<circ>\<^sub>m f = id_mor(source_str(f))" by auto2+
setup {* del_prfstep_thm @{thm inverse_mor_pair_def} *}

lemma inverse_mor_pair_inverse [rewrite]:
  "mor_form(g) \<Longrightarrow> inverse_mor_pair(f,g) \<Longrightarrow> inverse_mor(f) = g"
@proof @have "g \<circ>\<^sub>m f = id_mor(source_str(f))" @qed

lemma inverse_mor_pair_inverse2 [rewrite]:
  "mor_form(f) \<Longrightarrow> inverse_mor_pair(f,g) \<Longrightarrow> inverse_mor(g) = f"
@proof @have "g \<circ>\<^sub>m f = id_mor(source_str(f))" @qed

(* Construction of left and right inverses. *)
lemma exists_right_inverse_mor [resolve]:
  "is_morphism(f) \<Longrightarrow> surjective(f) \<Longrightarrow> A = source_str(f) \<Longrightarrow> B = target_str(f) \<Longrightarrow> \<exists>s\<in>B\<rightharpoonup>A. f \<circ>\<^sub>m s = id_mor(B)"
@proof @let "s = Mor(B,A, \<lambda>y. SOME x\<in>.A. f`x=y)" @qed

lemma exists_pullback_surj_mor [backward1]:
  "is_morphism(f) \<Longrightarrow> surjective(g) \<Longrightarrow> g \<in> E \<rightharpoonup> F \<Longrightarrow> f \<in> E \<rightharpoonup> G \<Longrightarrow>
   \<forall>x\<in>.E. \<forall>y\<in>.E. g`x=g`y \<longrightarrow> f`x=f`y \<Longrightarrow> \<exists>!h. h\<in>F\<rightharpoonup>G \<and> f = h \<circ>\<^sub>m g"
@proof
  @have "\<exists>h\<in>F\<rightharpoonup>G. f = h \<circ>\<^sub>m g" @with
    @obtain "s\<in>F\<rightharpoonup>E" where "g \<circ>\<^sub>m s = id_mor(F)"
    @obtain "h\<in>F\<rightharpoonup>G" where "h = f \<circ>\<^sub>m s"
  @end
  @have "\<forall>h1 h2. h1 \<in> F \<rightharpoonup> G \<and> f = h1 \<circ>\<^sub>m g \<longrightarrow> h2 \<in> F \<rightharpoonup> G \<and> f = h2 \<circ>\<^sub>m g \<longrightarrow> h1 = h2" @with
    @have "\<forall>x\<in>.F. h1`x = h2`x" @with
      @obtain "y\<in>.E" where "g`y = x"
    @end
  @end
@qed

end