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

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)"

(* standard notation for blocks of 2^n-1 words, usually aligned;
   abbreviation so it simplifies directly *)
abbreviation mask_range :: "'a::len word \<Rightarrow> nat \<Rightarrow> 'a word set" where
  "mask_range p n \<equiv> {p .. p + mask n}"

(* 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))"

(* Count trailing zeros  *)
definition
  word_ctz :: "'a::len word \<Rightarrow> nat"
where
  "word_ctz w \<equiv> length (takeWhile Not (rev (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))"

(* Sign extension from bit n *)

definition
  sign_extend :: "nat \<Rightarrow> 'a::len word \<Rightarrow> 'a word"
where
  "sign_extend n w \<equiv> if w !! n then w || ~~ (mask n) else w && mask n"

definition
  sign_extended :: "nat \<Rightarrow> 'a::len word \<Rightarrow> bool"
where
  "sign_extended n w \<equiv> \<forall>i. n < i \<longrightarrow> i < size w \<longrightarrow> w !! i = w !! n"

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

lemma uint_of_bl_is_bl_to_bin_drop:
  "length (dropWhile Not l) \<le> LENGTH('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>LENGTH('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 (\<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 word_combine_masks:
  "w && m = z \<Longrightarrow> w && m' = z' \<Longrightarrow> w && (m || m') = (z || z')"
  by (auto simp: word_eq_iff)

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

lemma p2_gt_0:
  "(0 < (2 ^ n :: 'a :: len word)) = (n < LENGTH('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)

lemmas p2len = iffD2 [OF p2_eq_0 order_refl]

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

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

lemma word_and_mask_le_2pm1: "w && mask n \<le> 2 ^ n - 1"
  by (simp add: mask_2pm1[symmetric] word_and_le1)

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 mask_shiftl_decompose:
  "mask m << n = mask (m + n) && ~~ (mask n)"
  by (auto intro!: word_eqI simp: and_not_mask nth_shiftl nth_shiftr word_size)

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

(* Simplifying with word_and_max_word and max_word_def works for arbitrary word sizes,
   but the conditional rewrite can be slow when combined with other common rewrites on
   word expressions. If we are willing to limit our attention to common word sizes,
   the following will usually be much faster. *)
lemmas word_and_max_simps[simplified max_word_def, simplified] =
  word_and_max[where 'a=8] word_and_max[where 'a=16] word_and_max[where 'a=32] word_and_max[where 'a=64]

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)
  by (simp add: is_down le_imp_power_dvd)

(* 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 LENGTH('a) = 1 then -1 else 1)"
  apply (case_tac "LENGTH('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 (LENGTH('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 LENGTH('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> 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

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 (LENGTH('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 (LENGTH('a) - 1) False @ [True]"
    by (cases "LENGTH('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


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

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

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

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun split :: "'a => ((('a list), ('a list)) pair) list =>
              ((('a list), ('a list)) pair) list" where
"split x (nil2) = nil2"
| "split x (cons2 (pair2 xs ys) x2) =
     cons2 (pair2 (cons2 x xs) ys) (split x x2)"

fun split2 :: "'a list => ((('a list), ('a list)) pair) list" where
"split2 (nil2) = cons2 (pair2 (nil2) (nil2)) (nil2)"
| "split2 (cons2 y s) =
     cons2 (pair2 (nil2) (cons2 y s)) (split y (split2 s))"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun or2 :: "bool list => bool" where
"or2 (nil2) = False"
| "or2 (cons2 y xs) = (y | (or2 xs))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

fun formula :: "R => R => (((A list), (A list)) pair) list =>
              bool list" where
"formula p q (nil2) = nil2"
| "formula p q (cons2 (pair2 s1 s2) z) =
     cons2 ((recognise p s1) & (recognise q s2)) (formula p q z)"

theorem property0 :
  "((recognise (Seq p q) s) = (or2 (formula p q (split2 s))))"
  oops

end


(*  File:       Pass_Module.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Pass Module\<close>

theory Pass_Module
  imports "Component_Types/Electoral_Module"
begin

text \<open>
  This is a family of electoral modules. For a natural number n and a
  lexicon (linear order) r of all alternatives, the according pass module
  defers the lexicographically first n alternatives (from A) and rejects
  the rest. It is primarily used as counterpart to the drop module in a
  parallel composition in order to segment the alternatives into two groups.
\<close>

subsection \<open>Definition\<close>

fun pass_module :: "nat \<Rightarrow> 'a Preference_Relation \<Rightarrow> 'a Electoral_Module" where
  "pass_module n r A p =
    ({},
    {a \<in> A. card(above (limit A r) a) > n},
    {a \<in> A. card(above (limit A r) a) \<le> n})"

subsection \<open>Soundness\<close>

theorem pass_mod_sound[simp]:
  assumes "linear_order r"
  shows "electoral_module (pass_module n r)"
proof (intro electoral_modI)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  let ?mod = "pass_module n r"
  have
    "(\<forall> a \<in> A. a \<in> {x \<in> A. card(above (limit A r) x) > n} \<or>
              a \<in> {x \<in> A. card(above (limit A r) x) \<le> n})"
    using CollectI not_less
    by metis
  hence
    "{a \<in> A. card(above (limit A r) a) > n} \<union>
      {a \<in> A. card(above (limit A r) a) \<le> n} = A"
    by blast
  hence 0: "set_equals_partition A (pass_module n r A p)"
    by simp
  have
    "(\<forall> a \<in> A. \<not>(a \<in> {x \<in> A. card(above (limit A r) x) > n} \<and>
                 a \<in> {x \<in> A. card(above (limit A r) x) \<le> n}))"
    by auto
  hence
    "{a \<in> A. card(above (limit A r) a) > n} \<inter>
      {a \<in> A. card(above (limit A r) a) \<le> n} = {}"
    by blast
  hence 1: "disjoint3 (?mod A p)"
    by simp
  from 0 1
  show "well_formed A (?mod A p)"
    by simp
qed

subsection \<open>Non-Blocking\<close>

text \<open>
  The pass module is non-blocking.
\<close>

theorem pass_mod_non_blocking[simp]:
  assumes
    order: "linear_order r" and
    g0_n:  "n > 0"
  shows "non_blocking (pass_module n r)"
proof (unfold non_blocking_def, safe, simp_all)
  show "electoral_module (pass_module n r)"
    using pass_mod_sound order
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    x :: "'a"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    card_A:
    "{a \<in> A. n <
      card (above
        {(a, b). (a, b) \<in> r \<and>
          a \<in> A \<and> b \<in> A} a)} = A" and
    x_in_A: "x \<in> A"
  have lin_ord_A:
    "linear_order_on A (limit A r)"
    using limit_presv_lin_ord order top_greatest
    by metis
  have
    "\<exists> a \<in> A. above (limit A r) a = {a} \<and>
      (\<forall> x \<in> A. above (limit A r) x = {x} \<longrightarrow> x = a)"
    using above_one fin_A lin_ord_A x_in_A
    by blast
  hence not_all:
    "{a \<in> A. card(above (limit A r) a) > n} \<noteq> A"
    using Suc_leI assms(2) is_singletonI
          is_singleton_altdef leD mem_Collect_eq
    unfolding One_nat_def
    by (metis (no_types, lifting))
  hence "reject (pass_module n r) A p \<noteq> A"
    by simp
  thus False
    using order card_A
    by simp
qed

subsection \<open>Non-Electing\<close>

text \<open>
  The pass module is non-electing.
\<close>

theorem pass_mod_non_electing[simp]:
  assumes "linear_order r"
  shows "non_electing (pass_module n r)"
  unfolding non_electing_def
  using assms
  by simp

subsection \<open>Properties\<close>

text \<open>
  The pass module is strictly defer-monotone.
\<close>

theorem pass_mod_dl_inv[simp]:
  assumes "linear_order r"
  shows "defer_lift_invariance (pass_module n r)"
  unfolding defer_lift_invariance_def
  using assms
  by simp

theorem pass_zero_mod_def_zero[simp]:
  assumes "linear_order r"
  shows "defers 0 (pass_module 0 r)"
proof (unfold defers_def, safe)
  show "electoral_module (pass_module 0 r)"
    using pass_mod_sound assms
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile"
  assume
    card_pos: "0 \<le> card A" and
    finite_A: "finite A" and
    prof_A: "profile A p"
  have lin_ord_on_A:
    "linear_order_on A (limit A r)"
    using assms limit_presv_lin_ord
    by blast
  have f1: "connex A (limit A r)"
    using lin_ord_imp_connex lin_ord_on_A
    by simp
  obtain select_alt :: "('a \<Rightarrow> bool) \<Rightarrow> 'a" where
    "\<forall> p. (Collect p = {} \<longrightarrow> (\<forall> a. \<not> p a)) \<and>
        (Collect p \<noteq> {} \<longrightarrow> p (select_alt p))"
    by moura
  have "\<forall> n. \<not> (n::nat) \<le> 0 \<or> n = 0"
    by blast
  hence
    "\<forall> a A'. \<not> connex A' (limit A r) \<or> a \<notin> A' \<or> a \<notin> A \<or>
              \<not> card (above (limit A r) a) \<le> 0"
    using above_connex above_presv_limit card_eq_0_iff
          equals0D finite_A assms rev_finite_subset
    by (metis (no_types))
  hence "{a \<in> A. card (above (limit A r) a) \<le> 0} = {}"
    using f1
    by auto
  hence "card {a \<in> A. card (above (limit A r) a) \<le> 0} = 0"
    using card.empty
    by metis
  thus "card (defer (pass_module 0 r) A p) = 0"
    by simp
qed

text \<open>
  For any natural number n and any linear order, the according pass module
  defers n alternatives (if there are n alternatives).
  NOTE: The induction proof is still missing. The following are the proofs
  for n=1 and n=2.
\<close>

theorem pass_one_mod_def_one[simp]:
  assumes "linear_order r"
  shows "defers 1 (pass_module 1 r)"
proof (unfold defers_def, safe)
  show "electoral_module (pass_module 1 r)"
    using pass_mod_sound assms
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile"
  assume
    card_pos: "1 \<le> card A" and
    finite_A: "finite A" and
    prof_A: "profile A p"
  show "card (defer (pass_module 1 r) A p) = 1"
  proof -
    have "A \<noteq> {}"
      using card_pos
      by auto
    moreover have lin_ord_on_A:
      "linear_order_on A (limit A r)"
      using assms limit_presv_lin_ord
      by blast
    ultimately have winner_exists:
      "\<exists> a \<in> A. above (limit A r) a = {a} \<and>
        (\<forall> x \<in> A. above (limit A r) x = {x} \<longrightarrow> x = a)"
      using finite_A
      by (simp add: above_one)
    then obtain w where w_unique_top:
      "above (limit A r) w = {w} \<and>
        (\<forall> x \<in> A. above (limit A r) x = {x} \<longrightarrow> x = w)"
      using above_one
      by auto
    hence "{a \<in> A. card(above (limit A r) a) \<le> 1} = {w}"
    proof
      assume
        w_top: "above (limit A r) w = {w}" and
        w_unique: "\<forall> x \<in> A. above (limit A r) x = {x} \<longrightarrow> x = w"
      have "card (above (limit A r) w) \<le> 1"
        using w_top
        by auto
      hence "{w} \<subseteq> {a \<in> A. card (above (limit A r) a) \<le> 1}"
        using winner_exists w_unique_top
        by blast
      moreover have
        "{a \<in> A. card(above (limit A r) a) \<le> 1} \<subseteq> {w}"
      proof
        fix x :: "'a"
        assume x_in_winner_set: "x \<in> {a \<in> A. card (above (limit A r) a) \<le> 1}"
        hence x_in_A: "x \<in> A"
          by auto
        hence connex_limit:
          "connex A (limit A r)"
          using lin_ord_imp_connex lin_ord_on_A
          by simp
        hence "let q = limit A r in x \<preceq>\<^sub>q x"
          using connex_limit above_connex
                pref_imp_in_above x_in_A
          by metis
        hence "(x,x) \<in> limit A r"
          by simp
        hence x_above_x: "x \<in> above (limit A r) x"
          unfolding above_def
          by simp
        have "above (limit A r) x \<subseteq> A"
          using above_presv_limit assms
          by fastforce
        hence above_finite: "finite (above (limit A r) x)"
          using finite_A finite_subset
          by simp
        have "card (above (limit A r) x) \<le> 1"
          using x_in_winner_set
          by simp
        moreover have
          "card (above (limit A r) x) \<ge> 1"
          using One_nat_def Suc_leI above_finite card_eq_0_iff
                equals0D neq0_conv x_above_x
          by metis
        ultimately have
          "card (above (limit A r) x) = 1"
          by simp
        hence "{x} = above (limit A r) x"
          using is_singletonE is_singleton_altdef singletonD x_above_x
          by metis
        hence "x = w"
          using w_unique
          by (simp add: x_in_A)
        thus "x \<in> {w}"
          by simp
      qed
      ultimately have
        "{w} = {a \<in> A. card (above (limit A r) a) \<le> 1}"
        by auto
      thus ?thesis
        by simp
    qed
    hence "defer (pass_module 1 r) A p = {w}"
      by simp
    thus "card (defer (pass_module 1 r) A p) = 1"
      by simp
  qed
qed

theorem pass_two_mod_def_two:
  assumes "linear_order r"
  shows "defers 2 (pass_module 2 r)"
proof (unfold defers_def, safe)
  show "electoral_module (pass_module 2 r)"
    using assms
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile"
  assume
    min_2_card: "2 \<le> card A" and
    finA: "finite A" and
    profA: "profile A p"
  from min_2_card
  have not_empty_A: "A \<noteq> {}"
    by auto
  moreover have limitA_order:
    "linear_order_on A (limit A r)"
    using limit_presv_lin_ord assms
    by auto
  ultimately obtain a where
    a: "above (limit A r) a = {a}"
    using above_one min_2_card finA profA
    by blast
  hence "\<forall> b \<in> A. let q = limit A r in (b \<preceq>\<^sub>q a)"
    using limitA_order pref_imp_in_above empty_iff
          insert_iff insert_subset above_presv_limit
          assms connex_def lin_ord_imp_connex
    by metis
  hence a_best: "\<forall> b \<in> A. (b, a) \<in> limit A r"
    by simp
  hence a_above: "\<forall> b \<in> A. a \<in> above (limit A r) b"
    unfolding above_def
    by simp
  from a have "a \<in> {a \<in> A. card(above (limit A r) a) \<le> 2}"
    using CollectI Suc_leI not_empty_A a_above card_UNIV_bool
          card_eq_0_iff card_insert_disjoint empty_iff finA
          finite.emptyI insert_iff limitA_order above_one
          UNIV_bool nat.simps(3) zero_less_Suc
    by (metis (no_types, lifting))
  hence a_in_defer: "a \<in> defer (pass_module 2 r) A p"
    by simp
  have "finite (A - {a})"
    by (simp add: finA)
  moreover have A_not_only_a: "A - {a} \<noteq> {}"
    using min_2_card Diff_empty Diff_idemp Diff_insert0
          One_nat_def not_empty_A card.insert_remove
          card_eq_0_iff finite.emptyI insert_Diff
          numeral_le_one_iff semiring_norm(69) card.empty
    by metis
  moreover have limitAa_order:
    "linear_order_on (A - {a}) (limit (A - {a}) r)"
    using limit_presv_lin_ord assms top_greatest
    by blast
  ultimately obtain b where
    b: "above (limit (A - {a}) r) b = {b}"
    using above_one
    by metis
  hence "\<forall> c \<in> A - {a}. let q = limit (A - {a}) r in (c \<preceq>\<^sub>q b)"
    using limitAa_order pref_imp_in_above empty_iff insert_iff
          insert_subset above_presv_limit assms connex_def
          lin_ord_imp_connex
    by metis
  hence b_in_limit: "\<forall> c \<in> A - {a}. (c, b) \<in> limit (A - {a}) r"
    by simp
  hence b_best: "\<forall> c \<in> A - {a}. (c, b) \<in> limit A r"
    by auto
  hence c_not_above_b: "\<forall> c \<in> A - {a, b}. c \<notin> above (limit A r) b"
    using b Diff_iff Diff_insert2 above_presv_limit insert_subset
          assms limit_presv_above limit_presv_above2
    by metis
  moreover have above_subset: "above (limit A r) b \<subseteq> A"
    using above_presv_limit assms
    by metis
  moreover have b_above_b: "b \<in> above (limit A r) b"
    using b b_best above_presv_limit mem_Collect_eq assms insert_subset
    unfolding above_def
    by metis
  ultimately have above_b_eq_ab: "above (limit A r) b = {a, b}"
    using a_above
    by auto
  hence card_above_b_eq_2: "card (above (limit A r) b) = 2"
    using A_not_only_a b_in_limit
    by auto
  hence b_in_defer: "b \<in> defer (pass_module 2 r) A p"
    using b_above_b above_subset
    by auto
  from b_best have b_above:
    "\<forall> c \<in> A - {a}. b \<in> above (limit A r) c"
    using mem_Collect_eq
    unfolding above_def
    by metis
  have "connex A (limit A r)"
    using limitA_order lin_ord_imp_connex
    by auto
  hence "\<forall> c \<in> A. c \<in> above (limit A r) c"
    by (simp add: above_connex)
  hence "\<forall> c \<in> A - {a, b}. {a, b, c} \<subseteq> above (limit A r) c"
    using a_above b_above
    by auto
  moreover have "\<forall> c \<in> A - {a, b}. card {a, b, c} = 3"
    using DiffE Suc_1 above_b_eq_ab card_above_b_eq_2
          above_subset card_insert_disjoint finA finite_subset
          insert_commute numeral_3_eq_3
    unfolding One_nat_def
    by metis
  ultimately have
    "\<forall> c \<in> A - {a, b}. card (above (limit A r) c) \<ge> 3"
    using card_mono finA finite_subset above_presv_limit assms
    by metis
  hence "\<forall> c \<in> A - {a, b}. card (above (limit A r) c) > 2"
    using less_le_trans numeral_less_iff order_refl semiring_norm(79)
    by metis
  hence "\<forall> c \<in> A - {a, b}. c \<notin> defer (pass_module 2 r) A p"
    by (simp add: not_le)
  moreover have "defer (pass_module 2 r) A p \<subseteq> A"
    by auto
  ultimately have "defer (pass_module 2 r) A p \<subseteq> {a, b}"
    by blast
  with a_in_defer b_in_defer have
    "defer (pass_module 2 r) A p = {a, b}"
    by fastforce
  thus "card (defer (pass_module 2 r) A p) = 2"
    using above_b_eq_ab card_above_b_eq_2
    by presburger
qed

end


theory T91
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


theory T58
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end


section \<open>Generalised Cylindric Kleene Lattices\<close>

text \<open>Using this mathematical component requires downloading the Archive of Formal Proofs.\<close>

theory GCKL
  imports CKL2

begin

primrec list_inter :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "list_inter [] ys = []" |
  "list_inter (x # xs) ys = (let zs = list_inter xs ys in (if x \<in> set ys then x # zs else zs))"

lemma list_set_inter: "set (list_inter ks ls) = set ks \<inter> set ls"
  by (induct ks, simp_all, metis (full_types) Int_insert_left list.simps(15))

context cylindric_l_monoid_zerol
begin

primrec cyl_list :: "('a::linorder) list \<Rightarrow> 'b \<Rightarrow> 'b" where
  "cyl_list [] x = x" |
  "cyl_list (i # is) x = cyl i (cyl_list is x)"

lemma cyl_list_nil_fun [simp]: "cyl_list [] = id"
  unfolding fun_eq_iff by simp

lemma cyl_list_append: "cyl_list ks (cyl_list ls x) = cyl_list (ks @ ls) x"
  by (induct ks, simp_all)

lemma cyl_list_cons_fun: "cyl_list (l # ls) = cyl l \<circ> cyl_list ls"
  unfolding fun_eq_iff comp_def by simp

lemma setmem_cyl: "l \<in> set ls \<Longrightarrow> cyl_list (l # ls) x = cyl_list ls x"
  by (induct ls, simp_all, metis cyl_comm cyl_fix_im)

lemma cyl_list_remdups: "cyl_list (remdups ls) x = cyl_list ls x"
  apply (induct ls)
  using setmem_cyl by auto

lemma cyl_list_el_comm: "cyl_list ls (cyl i x) = cyl i (cyl_list ls x)"
  by (induct ls, simp_all add: cyl_comm)

lemma cyl_sorted_aux: "sorted ls \<Longrightarrow> cyl i (cyl_list ls x) = cyl_list (insort i ls) x"
  by (induct ls, simp_all add: cyl_comm)

lemma cyl_sorted: "cyl i (cyl_list (sort ls) x) = cyl_list (insort i (sort ls)) x"
  by (simp add: cyl_sorted_aux)

lemma cyl_list_sort: "cyl_list ls x = cyl_list (sort ls) x"
  by (induct ls, simp_all add: cyl_sorted)

definition cyl_set :: "('a::linorder) set \<Rightarrow> 'b \<Rightarrow> 'b" where
  "cyl_set X x = cyl_list (sorted_list_of_set X) x"

lemma cyl_list_set: "cyl_list ls x = cyl_set (set ls) x"
  unfolding cyl_set_def by (metis cyl_list_remdups cyl_list_sort sorted_list_of_set_sort_remdups)

lemma cyl_list_set_eq: "set ks = set ls \<Longrightarrow> cyl_list ks x = cyl_list ls x"
  by (simp add: cyl_list_set)

lemma cyl_list_iso_aux: "cyl_list ls x \<le> cyl_list (ks @ ls) x"
  by (induct ks, simp_all, meson cyl_ext order_trans)

lemma cyl_list_iso: "set ks \<subseteq> set ls \<Longrightarrow> cyl_list ks x \<le> cyl_list ls x"
  by (metis UnCI Un_Int_distrib cyl_list_set cylindric_l_monoid_zerol.cyl_list_iso_aux cylindric_l_monoid_zerol_axioms inf.commute inf.orderE set_append subsetI sup.idem)

lemma "cyl_list ks x \<le> cyl_list ls x \<Longrightarrow> set ks \<subseteq> set ls"
  (*nitpick*)
  oops

lemma cyl_list_idem [simp]: "cyl_list ls (cyl_list ls x) = cyl_list ls x"
  using cyl_list_append cyl_list_set by auto

lemma cyl_list_one_cons: "cyl i 1 \<cdot> cyl_list ls 1 = cyl_list (i # ls) 1"
  apply (induct ls)
   apply simp_all
  by (smt cyl_1_unl cyl_comm cyl_id_seq_eq cyl_oplax cyl_rel_prop_var1 join.le_iff_sup join.sup.order_iff mult.assoc)

lemma cyl_list_one_app: "cyl_list ks 1 \<cdot> cyl_list ls 1 = cyl_list (ks @ ls) 1"
  by (induct ks, simp_all, metis cyl_list.simps(2) cyl_list_one_cons mult.assoc)

lemma "i \<noteq> j \<Longrightarrow> cyl_list (ls @ [i]) 1 \<sqinter> cyl_list (ls @ [j]) 1 = cyl_list ls 1"
  oops

lemma "i \<noteq> j \<Longrightarrow> cyl_list ([i] @ ls) 1 \<sqinter> cyl_list ([j] @ ls) 1 = cyl_list ls 1"
  oops

lemma rect_id: "cyl_list ks 1 \<sqinter> cyl_list ls 1 = cyl_list (list_inter ks ls) 1"
  oops

lemma c1_list [simp]: "cyl_list ls 0 = 0"
  by (induct ls, simp_all)

lemma c2_list: "x \<le> cyl_list ls x"
  apply (induct ls)
   apply simp_all
  using cyl_ext dual_order.trans by blast

lemma c3_list: "cyl_list ls (x + y) = cyl_list ls x + cyl_list ls y"
  by (induct ls, simp_all add: cyl_sup_add)

lemma c4_list: "\<forall>x y. cyl_list ls (x \<sqinter> cyl_list ls y) = cyl_list ls x \<sqinter> cyl_list ls y"
  by (induct ls, simp_all, metis cyl_inf cyl_list_el_comm)

lemma c5_list: "cyl_list ks (cyl_list ls x) = cyl_list ls (cyl_list ks x)"
  by (induct ls, simp_all add: cyl_list_el_comm)

lemma c5_list_var: "cyl_list (ks @ ls) x = cyl_list (ls @ ks) x"
  using c5_list cyl_list_append by auto

lemma c6_list: "\<forall>x y. cyl_list ls (x \<cdot> cyl_list ls y) = cyl_list ls x \<cdot> cyl_list ls y"
  by (induct ls, simp_all, metis cyl_list_el_comm cyl_multr)

lemma c7_list: "\<forall>x y. cyl_list ls (cyl_list ls x \<cdot> y) = cyl_list ls x \<cdot> cyl_list ls y"
  by (induct ls, simp_all, metis cyl_list_el_comm cyl_multl)

lemma c8_list:
  assumes "cyl_list ks 1 \<sqinter> cyl_list ls 1 = cyl_list (list_inter ks ls) 1"
  shows "list_inter ks ls = [] \<Longrightarrow> cyl_list ks 1 \<sqinter> cyl_list ls 1 = 1"
  by (simp add: assms)

lemma c9_list:
  assumes "\<forall>ks ls. cyl_list ks 1 \<sqinter> cyl_list ls 1 = cyl_list (list_inter ks ls) 1"
  shows"(cyl_list ks 1 \<cdot> cyl_list ls 1) \<sqinter> (cyl_list ks 1 \<cdot> cyl_list ms 1) = cyl_list ks (cyl_list ls 1 \<sqinter> cyl_list ms 1)"
  by (metis Un_Int_distrib cyl_list_append cyl_list_one_app cylindric_l_monoid_zerol.cyl_list_set assms cylindric_l_monoid_zerol_axioms list_set_inter set_append)

lemma c10_list: "cyl_list ks (cyl_list ls 1) = cyl_list ks 1 \<cdot> cyl_list ls 1"
  by (simp add: cyl_list_append cyl_list_one_app)

lemma cyl_list_id_absorb1:
  assumes "\<forall>ks ls. cyl_list ks 1 \<sqinter> cyl_list ls 1 = cyl_list (list_inter ks ls) 1"
  shows "cyl_list ks 1 \<cdot> (cyl_list ks 1 \<sqinter> cyl_list ls 1) = cyl_list ks 1"
  by (metis (no_types, lifting) assms c10_list c2_list c4_list c5_list inf.commute inf_absorb2)

lemma cyl_list_id_absorb2:
  assumes "\<forall>ks ls. cyl_list ks 1 \<sqinter> cyl_list ls 1 = cyl_list (list_inter ks ls) 1"
  shows "cyl_list ks 1 \<sqinter> (cyl_list ks 1 \<cdot> cyl_list ls 1) = cyl_list ks 1"
  by (metis (no_types, lifting) assms c10_list c2_list c4_list c5_list inf.commute inf_absorb2)

end

context cylindric_kleene_lattice_zerol
begin

lemma c11_list: "cyl_list ls (x\<^sup>\<oplus>) \<le> (cyl_list ls x::'b::{l_monoid_zerol,kleene_algebra_zerol})\<^sup>\<oplus>"
  by (induct ls, simp_all, metis cyl_iso cyl_kplus cyl_list.simps(2) order_trans)

lemma cyl_id_star_fix [simp]: "(cyl_list ls 1)\<^sup>\<star> = cyl_list ls 1"
  by (metis c2_list c7_list cyl_list_idem mult.right_neutral star_inductr_var_eq2 sup_id_star1)

lemma cyl_id_plus_fix [simp]: "(cyl_list ls 1)\<^sup>\<oplus> = cyl_list ls 1"
  by (metis c7_list cyl_list_idem kplus_def mult_oner star_inductr_var_eq2)

end

context cylindric_l_monoid_zerol
begin

text \<open>We define programs with frames\<close>

definition fprog :: "'a list \<Rightarrow> 'b \<Rightarrow> 'b" where
 "fprog ls x = x \<sqinter> cyl_list ls 1"

lemma fprog1: "fprog ls x \<le> x"
  by (simp add: fprog_def)

lemma fprog2: "set ks \<subseteq> set ls \<Longrightarrow> fprog ks x \<le> fprog ls x"
  unfolding fprog_def using cyl_list_iso inf_mono by blast

lemma fprog3: "x \<le> y \<Longrightarrow> fprog ls x \<le> fprog ls y"
  unfolding fprog_def using inf_mono by blast

lemma fprog4: "fprog ls x + fprog ls y \<le> fprog ls (x + y)"
  by (simp add: fprog3)

lemma fprog4_eq:
  assumes "\<forall>x y z. (x + y) \<sqinter> (z::'b) = (x \<sqinter> y) + (x \<sqinter> z)"
  shows "fprog ls (x + y) = fprog ls x + fprog ls y"
  by (metis (no_types, lifting) add_idem' assms lmon_lat.inf_sup_absorb)

lemma fprog5: "fprog ls x \<cdot> fprog ls y \<le> fprog ls (x \<cdot> y)"
  unfolding fprog_def
  by (metis (no_types, lifting) cyl_list_idem cylindric_l_monoid_zerol.c10_list cylindric_l_monoid_zerol_axioms inf_le1 inf_le2 le_inf_iff mult_isol_var)

lemma fprog7: "x \<le> 1 \<Longrightarrow> fprog ls x = x"
  by (metis c2_list dual_order.trans fprog_def inf.orderE)

end

context cylindric_kleene_lattice_zerol
begin

lemma fprog6: "(fprog ls x)\<^sup>\<star> \<le> fprog ls (x\<^sup>\<star>)"
  by (metis cyl_id_star_fix fprog1 fprog_def inf_le2 le_inf_iff star_iso)

lemma refine_skip: "1 \<le> x \<Longrightarrow> fprog ls 1 \<le> fprog ls x"
  by (simp add: fprog3)

lemma refine4: "y \<le> x \<Longrightarrow> fprog ls y \<le> x"
  using dual_order.trans fprog1 by blast

lemma refine_seq: "x \<cdot> y \<le> z \<Longrightarrow> fprog ls x \<cdot> fprog ls y \<le> fprog ls z"
  by (meson fprog3 fprog5 order_subst1)

lemma refine_cond: "p \<le> 1 \<Longrightarrow> q \<le> 1 \<Longrightarrow> p \<cdot> x + q \<cdot> y \<le> z \<Longrightarrow> p \<cdot> fprog ls x + q \<cdot> fprog ls y \<le> fprog ls z"
  using fprog7 refine_seq by fastforce

lemma refine_loop: "p \<le> 1 \<Longrightarrow> q \<le> 1 \<Longrightarrow> (p \<cdot> x)\<^sup>\<star> \<cdot> q \<le> y \<Longrightarrow> (p \<cdot> fprog ls x)\<^sup>\<star> \<cdot> q \<le> fprog ls y"
proof-
  assume h1: "p \<le> 1"
  and h2: "q \<le> 1"
  and h3: "(p \<cdot> x)\<^sup>\<star> \<cdot> q \<le> y"
  hence "(p \<cdot> fprog ls x)\<^sup>\<star> \<cdot> q \<le> (fprog ls (p \<cdot> x)\<^sup>\<star>) \<cdot> q"
    by (metis fprog5 fprog7 h1 mult_isor star_iso)
  also have "... \<le> fprog ls ((p \<cdot> x)\<^sup>\<star> \<cdot> q)"
    by (smt cyl_id_star_fix cyl_list_idem cylindric_l_monoid_zerol.c10_list cylindric_l_monoid_zerol.fprog1 cylindric_l_monoid_zerol.fprog7 cylindric_l_monoid_zerol_axioms fprog_def h2 inf.absorb_iff2 inf_le2 le_inf_iff mult_isol_var star_iso)
  also have "... \<le> fprog ls y"
    by (simp add: fprog3 h3)
  finally show ?thesis.
qed

end

end


theory Inversion
imports "../List-Index/List_Index"
begin

section "List Inversion"

abbreviation "dist_perm xs ys \<equiv> distinct xs \<and> distinct ys \<and> set xs = set ys"

definition before_in :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool"
  ("(_ </ _/ in _)" [55,55,55] 55) where
"x < y in xs = (index xs x < index xs y \<and> y \<in> set xs)"

definition Inv :: "'a list \<Rightarrow> 'a list \<Rightarrow> ('a * 'a) set" where
"Inv xs ys = {(x,y). x < y in xs \<and> y < x in ys}"

lemma before_in_setD1: "x < y in xs \<Longrightarrow> x : set xs"
by (metis index_conv_size_if_notin index_less before_in_def less_asym order_refl)

lemma before_in_setD2: "x < y in xs \<Longrightarrow> y : set xs"
by (simp add: before_in_def)

lemma not_before_in:
  "x : set xs \<Longrightarrow> y : set xs \<Longrightarrow> \<not> x < y in xs \<longleftrightarrow> y < x in xs \<or> x=y"
by (metis index_eq_index_conv before_in_def less_asym linorder_neqE_nat)

lemma no_before_inI[simp]: "x < y in xs \<Longrightarrow> (\<not> y < x in xs) = True"
by (metis before_in_setD1 not_before_in)

lemma finite_Invs[simp]:  "finite(Inv xs ys)"
apply(rule finite_subset[where B = "set xs \<times> set ys"])
apply(auto simp add: Inv_def before_in_def)
apply(metis index_conv_size_if_notin index_less_size_conv less_asym)+
done

lemma Inv_id[simp]: "Inv xs xs = {}"
by(auto simp add: Inv_def before_in_def)

lemma card_Inv_sym: "card(Inv xs ys) = card(Inv ys xs)"
proof -
  have "Inv xs ys = (\<lambda>(x,y). (y,x)) ` Inv ys xs" by(auto simp: Inv_def)
  thus ?thesis by (metis card_image swap_inj_on)
qed

lemma Inv_tri_ineq:
  "dist_perm xs ys \<Longrightarrow> dist_perm ys zs \<Longrightarrow>
  Inv xs zs \<subseteq> Inv xs ys Un Inv ys zs"
by(auto simp: Inv_def) (metis before_in_setD1 not_before_in)

lemma card_Inv_tri_ineq:
  "dist_perm xs ys \<Longrightarrow> dist_perm ys zs \<Longrightarrow>
  card (Inv xs zs) \<le> card(Inv xs ys) + card (Inv ys zs)"
using card_mono[OF _ Inv_tri_ineq[of xs ys zs]]
by auto (metis card_Un_Int finite_Invs trans_le_add1)

definition "mtf x xs =
  (if x \<in> set xs then x # (take (index xs x) xs) @ drop (index xs x + 1) xs
   else xs)"

lemma mtf_id[simp]: "x \<notin> set xs \<Longrightarrow> mtf x xs = xs"
by(simp add: mtf_def)

lemma Inv_mtf: "set xs = set ys \<Longrightarrow> z : set ys \<Longrightarrow> Inv xs (mtf z ys) =
 Inv xs ys \<union> {(x,z)|x. x < z in xs \<and> x < z in ys}
 - {(z,x)|x. z < x in xs \<and> x < z in ys}"
by(auto simp add: Inv_def before_in_mtf not_before_in dest: before_in_setD1)

lemma set_mtf[simp]: "set(mtf x xs) = set xs"
by(simp add: mtf_def)
  (metis append_take_drop_id Cons_nth_drop_Suc index_less le_refl Un_insert_right nth_index set_append set_simps(2))

lemma length_mtf[simp]: "size (mtf x xs) = size xs"
by (auto simp add: mtf_def min_def) (metis index_less_size_conv leD)

lemma distinct_mtf[simp]: "distinct (mtf x xs) = distinct xs"
by (metis length_mtf set_mtf card_distinct distinct_card)

definition "swapSuc n xs = xs[n := xs!Suc n, Suc n := xs!n]"

lemma index_swapSuc_distinct:
  "distinct xs \<Longrightarrow> Suc n < length xs \<Longrightarrow>
  index (swapSuc n xs) x =
  (if x = xs!n then Suc n else if x = xs!Suc n then n else index xs x)"
by(auto simp add: swapSuc_def index_swap_if_distinct)

lemma set_swapSuc[simp]: "Suc n < size xs \<Longrightarrow> set(swapSuc n xs) = set xs"
by(auto simp add: swapSuc_def set_conv_nth nth_list_update) metis

lemma before_in_swapSuc:
 "dist_perm xs ys \<Longrightarrow> Suc n < size xs \<Longrightarrow>
  x < y in (swapSuc n xs) \<longleftrightarrow>
  x < y in xs \<and> \<not> (x = xs!n \<and> y = xs!Suc n) \<or> x = xs!Suc n \<and> y = xs!n"
by(simp add:before_in_def index_swapSuc_distinct)
  (metis Suc_lessD Suc_lessI index_less_size_conv index_nth_id less_Suc_eq n_not_Suc_n nth_index)

lemma Inv_swap: assumes "dist_perm xs ys" "Suc n < size xs"
shows "Inv xs (swapSuc n ys) =
  (if ys!n < ys!Suc n in xs
   then Inv xs ys \<union> {(ys!n, ys!Suc n)}
   else Inv xs ys - {(ys!Suc n, ys!n)})"
proof-
  have "length xs = length ys" using assms by (metis distinct_card)
  with assms show ?thesis
    by(simp add: Inv_def set_eq_iff)
      (metis before_in_def not_before_in before_in_swapSuc)
qed

end


theory BKR_Algorithm
  imports
    "More_Matrix"
    "Sturm_Tarski.Sturm_Tarski"
begin

section "Setup"

definition retrieve_polys:: "real poly list \<Rightarrow> nat list \<Rightarrow> real poly list"
  where "retrieve_polys qss index_list = (map (nth qss) index_list)"

definition construct_NofI:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat"
  where "construct_NofI p I =  rat_of_int (changes_R_smods p ((pderiv p)*(prod_list I)))"

definition construct_rhs_vector:: "real poly \<Rightarrow> real poly list \<Rightarrow> nat list list \<Rightarrow> rat vec"
  where "construct_rhs_vector p qs Is = vec_of_list (map (\<lambda> I.(construct_NofI p (retrieve_polys qs I))) Is)"

section "Base Case"

definition base_case_info:: "(rat mat \<times> (nat list list \<times> rat list list))"
  where "base_case_info =
    ((mat_of_rows_list 2 [[1,1], [1,-1]]), ([[],[0]], [[1],[-1]]))"

(* When p, q are coprime, this will actually be an int vec, which is why taking the floor is okay *)
definition base_case_solve_for_lhs:: "real poly \<Rightarrow> real poly \<Rightarrow> rat vec"
  where "base_case_solve_for_lhs p q = (mult_mat_vec (mat_of_rows_list 2 [[1/2, 1/2], [1/2, -1/2]])  (construct_rhs_vector p [q] [[], [0]]))"

thm "gauss_jordan_compute_inverse"

primrec matr_option:: "nat \<Rightarrow> 'a::{one, zero} mat option \<Rightarrow> 'a mat"
  where "matr_option dimen None = 1\<^sub>m dimen"
  | "matr_option dimen (Some c) = c"

(* For smooth code export, we want to use a computable notion of matrix equality *)
definition mat_equal:: "'a:: field mat \<Rightarrow> 'a :: field mat \<Rightarrow> bool"
  where "mat_equal A B = (dim_row A = dim_row B \<and> dim_col A = dim_col B \<and> (mat_to_list A) = (mat_to_list B))"

definition mat_inverse_var :: "'a :: field mat \<Rightarrow> 'a mat option" where
  "mat_inverse_var A = (if dim_row A = dim_col A then
    let one = 1\<^sub>m (dim_row A) in
    (case gauss_jordan A one of
      (B, C) \<Rightarrow> if (mat_equal B one) then Some C else None) else None)"

(* Now solve for LHS in general.
  Because mat_inverse returns an option type, we pattern match on this.
  Notice that when we call this function in the algorithm, the matrix we pass will always be invertible,
  given how the construction works. *)
definition solve_for_lhs:: "real poly \<Rightarrow> real poly list \<Rightarrow> nat list list \<Rightarrow> rat mat \<Rightarrow> rat vec"
  where "solve_for_lhs p qs subsets matr =
     mult_mat_vec (matr_option (dim_row matr) (mat_inverse_var matr))  (construct_rhs_vector p qs subsets)"

section "Smashing"

definition subsets_smash::"nat \<Rightarrow> nat list list \<Rightarrow> nat list list \<Rightarrow> nat list list"
  where "subsets_smash n s1 s2 = concat (map (\<lambda>l1. map (\<lambda> l2. l1 @ (map ((+) n) l2)) s2) s1)"

definition signs_smash::"'a list list \<Rightarrow>  'a list list \<Rightarrow> 'a list list"
  where "signs_smash s1 s2 = concat (map (\<lambda>l1. map (\<lambda> l2. l1 @ l2) s2) s1)"

definition smash_systems:: "real poly \<Rightarrow> real poly list \<Rightarrow> real poly list \<Rightarrow> nat list list \<Rightarrow> nat list list \<Rightarrow>
  rat list list \<Rightarrow> rat list list \<Rightarrow> rat mat \<Rightarrow> rat mat \<Rightarrow>
  real poly list \<times> (rat mat \<times> (nat list list \<times> rat list list))"
  where "smash_systems p qs1 qs2 subsets1 subsets2 signs1 signs2 mat1 mat2 =
    (qs1@qs2, (kronecker_product mat1 mat2, (subsets_smash (length qs1) subsets1 subsets2, signs_smash signs1 signs2)))"

fun combine_systems:: "real poly \<Rightarrow> (real poly list \<times> (rat mat \<times> (nat list list \<times> rat list list))) \<Rightarrow> (real poly list \<times> (rat mat \<times> (nat list list \<times> rat list list)))
  \<Rightarrow> (real poly list \<times> (rat mat \<times> (nat list list \<times> rat list list)))"
  where "combine_systems p (qs1, m1, sub1, sgn1) (qs2, m2, sub2, sgn2) =
    (smash_systems p qs1 qs2 sub1 sub2 sgn1 sgn2 m1 m2)"

(* Overall:
  Start with a matrix equation.
  Input a matrix, subsets, and signs.
  Drop columns of the matrix based on the 0's on the LHS---so extract a list of 0's. Reduce signs accordingly.
  Then find a list of rows to delete based on using rank (use the transpose result, pivot positions!),
   and delete those rows.  Reduce subsets accordingly.
  End with a reduced system! *)
section "Reduction"
definition find_nonzeros_from_input_vec:: "rat vec \<Rightarrow> nat list"
  where "find_nonzeros_from_input_vec lhs_vec = filter (\<lambda>i. lhs_vec $ i \<noteq> 0) [0..< dim_vec lhs_vec]"

definition take_indices:: "'a list \<Rightarrow> nat list \<Rightarrow> 'a list"
  where "take_indices subsets indices = map ((!) subsets) indices"

definition take_cols_from_matrix:: "'a mat \<Rightarrow> nat list \<Rightarrow> 'a mat"
  where "take_cols_from_matrix matr indices_to_keep =
    mat_of_cols (dim_row matr) ((take_indices (cols matr) indices_to_keep):: 'a vec list)"

definition take_rows_from_matrix:: "'a mat \<Rightarrow> nat list \<Rightarrow> 'a mat"
  where "take_rows_from_matrix matr indices_to_keep =
    mat_of_rows (dim_col matr) ((take_indices (rows matr) indices_to_keep):: 'a vec list)"

fun reduce_mat_cols:: "'a mat \<Rightarrow> rat vec \<Rightarrow> 'a mat"
  where "reduce_mat_cols A lhs_vec = take_cols_from_matrix A (find_nonzeros_from_input_vec lhs_vec)"

(* Find which rows to drop. *)
definition rows_to_keep:: "('a::field) mat \<Rightarrow> nat list" where
  "rows_to_keep A = map snd (pivot_positions (gauss_jordan_single (A\<^sup>T)))"

fun reduction_step:: "rat mat \<Rightarrow> rat list list \<Rightarrow> nat list list \<Rightarrow> rat vec \<Rightarrow> rat mat \<times> (nat list list \<times> rat list list)"
  where "reduction_step A signs subsets lhs_vec =
    (let reduce_cols_A = (reduce_mat_cols A lhs_vec);
         rows_keep = rows_to_keep reduce_cols_A in
    (take_rows_from_matrix  reduce_cols_A rows_keep,
      (take_indices subsets rows_keep,
      take_indices signs (find_nonzeros_from_input_vec lhs_vec))))"

fun reduce_system:: "real poly \<Rightarrow> (real poly list \<times> (rat mat \<times> (nat list list \<times> rat list list))) \<Rightarrow> (rat mat \<times> (nat list list \<times> rat list list))"
  where "reduce_system p (qs,m,subs,signs) =
    reduction_step m signs subs (solve_for_lhs p qs subs m)"

section "Overall algorithm "
  (*
    Find the matrix, subsets, signs for an input p and qs.
    The "rat mat" in the output is the matrix. The "nat list list" is the list of subsets.
    The "rat list list" is the list of signs.

    We will want to call this when p is nonzero and when every q in qs is pairwise coprime to p.
    Properties of this algorithm are proved in BKR_Proofs.thy.
  *)
fun calculate_data:: "real poly \<Rightarrow> real poly list \<Rightarrow>  (rat mat \<times> (nat list list \<times> rat list list))"
  where
    "calculate_data p qs =
  ( let len = length qs in
    if len = 0 then
      (\<lambda>(a,b,c).(a,b,map (drop 1) c)) (reduce_system p ([1],base_case_info))
    else if len \<le> 1 then reduce_system p (qs,base_case_info)
    else
    (let q1 = take (len div 2) qs; left = calculate_data p q1;
         q2 = drop (len div 2) qs; right = calculate_data p q2;
         comb = combine_systems p (q1,left) (q2,right) in
         reduce_system p comb
    )
  )"

(* Extract the list of consistent sign assignments *)
definition find_consistent_signs_at_roots:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list"
  where [code]:
    "find_consistent_signs_at_roots p qs =
  ( let (M,S,\<Sigma>) = calculate_data p qs in \<Sigma> )"

lemma find_consistent_signs_at_roots_thm:
  shows "find_consistent_signs_at_roots p qs = snd (snd (calculate_data p qs))"
  by (simp add: case_prod_beta find_consistent_signs_at_roots_def)

end


theory BKR_Algorithm
  imports
    Sturm_Tarski.Sturm_Tarski
    More_Matrix

begin

section "Setup"

definition retrieve_polys:: "'a list \<Rightarrow> nat list \<Rightarrow> 'a list"
  where "retrieve_polys qss index_list = (map (nth qss) index_list)"

definition construct_NofI:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat"
  where "construct_NofI p I =  rat_of_int (changes_R_smods p ((pderiv p)*(prod_list I)))"

definition construct_rhs_vector:: "real poly \<Rightarrow> real poly list \<Rightarrow> nat list list \<Rightarrow> rat vec"
  where "construct_rhs_vector p qs Is = vec_of_list (map (\<lambda> I.(construct_NofI p (retrieve_polys qs I))) Is)"

section "Base Case"

definition base_case_info:: "(rat mat \<times> (nat list list \<times> rat list list))"
  where "base_case_info =
    ((mat_of_rows_list 2 [[1,1], [1,-1]]), ([[],[0]], [[1],[-1]]))"

(* When p, q are coprime, this will actually be an int vec, which is why taking the floor is okay *)
definition base_case_solve_for_lhs:: "real poly \<Rightarrow> real poly \<Rightarrow> rat vec"
  where "base_case_solve_for_lhs p q = (mult_mat_vec (mat_of_rows_list 2 [[1/2, 1/2], [1/2, -1/2]])  (construct_rhs_vector p [q] [[], [0]]))"

thm "gauss_jordan_compute_inverse"

primrec matr_option:: "nat \<Rightarrow> 'a::{one, zero} mat option \<Rightarrow> 'a mat"
  where "matr_option dimen None = 1\<^sub>m dimen"
  | "matr_option dimen (Some c) = c"

(* For smooth code export, we want to use a computable notion of matrix equality *)
definition mat_equal:: "'a:: field mat \<Rightarrow> 'a :: field mat \<Rightarrow> bool"
  where "mat_equal A B = (dim_row A = dim_row B \<and> dim_col A = dim_col B \<and> (mat_to_list A) = (mat_to_list B))"

definition mat_inverse_var :: "'a :: field mat \<Rightarrow> 'a mat option" where
  "mat_inverse_var A = (if dim_row A = dim_col A then
    let one = 1\<^sub>m (dim_row A) in
    (case gauss_jordan A one of
      (B, C) \<Rightarrow> if (mat_equal B one) then Some C else None) else None)"

(* Now solve for LHS in general.
  Because mat_inverse returns an option type, we pattern match on this.
  Notice that when we call this function in the algorithm, the matrix we pass will always be invertible,
  given how the construction works. *)
definition solve_for_lhs:: "real poly \<Rightarrow> real poly list \<Rightarrow> nat list list \<Rightarrow> rat mat \<Rightarrow> rat vec"
  where "solve_for_lhs p qs subsets matr =
     mult_mat_vec (matr_option (dim_row matr) (mat_inverse_var matr))  (construct_rhs_vector p qs subsets)"

section "Smashing"

definition subsets_smash::"nat \<Rightarrow> nat list list \<Rightarrow> nat list list \<Rightarrow> nat list list"
  where "subsets_smash n s1 s2 = concat (map (\<lambda>l1. map (\<lambda> l2. l1 @ (map ((+) n) l2)) s2) s1)"

definition signs_smash::"'a list list \<Rightarrow>  'a list list \<Rightarrow> 'a list list"
  where "signs_smash s1 s2 = concat (map (\<lambda>l1. map (\<lambda> l2. l1 @ l2) s2) s1)"

definition smash_systems:: "real poly \<Rightarrow> real poly list \<Rightarrow> real poly list \<Rightarrow> nat list list \<Rightarrow> nat list list \<Rightarrow>
  rat list list \<Rightarrow> rat list list \<Rightarrow> rat mat \<Rightarrow> rat mat \<Rightarrow>
  real poly list \<times> (rat mat \<times> (nat list list \<times> rat list list))"
  where "smash_systems p qs1 qs2 subsets1 subsets2 signs1 signs2 mat1 mat2 =
    (qs1@qs2, (kronecker_product mat1 mat2, (subsets_smash (length qs1) subsets1 subsets2, signs_smash signs1 signs2)))"

fun combine_systems:: "real poly \<Rightarrow> (real poly list \<times> (rat mat \<times> (nat list list \<times> rat list list))) \<Rightarrow> (real poly list \<times> (rat mat \<times> (nat list list \<times> rat list list)))
  \<Rightarrow> (real poly list \<times> (rat mat \<times> (nat list list \<times> rat list list)))"
  where "combine_systems p (qs1, m1, sub1, sgn1) (qs2, m2, sub2, sgn2) =
    (smash_systems p qs1 qs2 sub1 sub2 sgn1 sgn2 m1 m2)"

(* Overall:
  Start with a matrix equation.
  Input a matrix, subsets, and signs.
  Drop columns of the matrix based on the 0's on the LHS---so extract a list of 0's. Reduce signs accordingly.
  Then find a list of rows to delete based on using rank (use the transpose result, pivot positions!),
   and delete those rows.  Reduce subsets accordingly.
  End with a reduced system! *)
section "Reduction"
definition find_nonzeros_from_input_vec:: "rat vec \<Rightarrow> nat list"
  where "find_nonzeros_from_input_vec lhs_vec = filter (\<lambda>i. lhs_vec $ i \<noteq> 0) [0..< dim_vec lhs_vec]"

definition take_indices:: "'a list \<Rightarrow> nat list \<Rightarrow> 'a list"
  where "take_indices subsets indices = map ((!) subsets) indices"

definition take_cols_from_matrix:: "'a mat \<Rightarrow> nat list \<Rightarrow> 'a mat"
  where "take_cols_from_matrix matr indices_to_keep =
    mat_of_cols (dim_row matr) ((take_indices (cols matr) indices_to_keep):: 'a vec list)"

definition take_rows_from_matrix:: "'a mat \<Rightarrow> nat list \<Rightarrow> 'a mat"
  where "take_rows_from_matrix matr indices_to_keep =
    mat_of_rows (dim_col matr) ((take_indices (rows matr) indices_to_keep):: 'a vec list)"

fun reduce_mat_cols:: "'a mat \<Rightarrow> rat vec \<Rightarrow> 'a mat"
  where "reduce_mat_cols A lhs_vec = take_cols_from_matrix A (find_nonzeros_from_input_vec lhs_vec)"

(* Find which rows to drop. *)
definition rows_to_keep:: "('a::field) mat \<Rightarrow> nat list" where
  "rows_to_keep A = map snd (pivot_positions (gauss_jordan_single (A\<^sup>T)))"

fun reduction_step:: "rat mat \<Rightarrow> rat list list \<Rightarrow> nat list list \<Rightarrow> rat vec \<Rightarrow> rat mat \<times> (nat list list \<times> rat list list)"
  where "reduction_step A signs subsets lhs_vec =
    (let reduce_cols_A = (reduce_mat_cols A lhs_vec);
         rows_keep = rows_to_keep reduce_cols_A in
    (take_rows_from_matrix  reduce_cols_A rows_keep,
      (take_indices subsets rows_keep,
      take_indices signs (find_nonzeros_from_input_vec lhs_vec))))"

fun reduce_system:: "real poly \<Rightarrow> (real poly list \<times> (rat mat \<times> (nat list list \<times> rat list list))) \<Rightarrow> (rat mat \<times> (nat list list \<times> rat list list))"
  where "reduce_system p (qs,m,subs,signs) =
    reduction_step m signs subs (solve_for_lhs p qs subs m)"

section "Overall algorithm "
  (*
    Find the matrix, subsets, signs for an input p and qs.
    The "rat mat" in the output is the matrix. The "nat list list" is the list of subsets.
    The "rat list list" is the list of signs.
    We will want to call this when p is nonzero and when every q in qs is pairwise coprime to p.
    Properties of this algorithm are proved in BKR_Proofs.thy.
  *)
fun calculate_data:: "real poly \<Rightarrow> real poly list \<Rightarrow>  (rat mat \<times> (nat list list \<times> rat list list))"
  where
    "calculate_data p qs =
  ( let len = length qs in
    if len = 0 then
      (\<lambda>(a,b,c).(a,b,map (drop 1) c)) (reduce_system p ([1],base_case_info))
    else if len \<le> 1 then reduce_system p (qs,base_case_info)
    else
    (let q1 = take (len div 2) qs; left = calculate_data p q1;
         q2 = drop (len div 2) qs; right = calculate_data p q2;
         comb = combine_systems p (q1,left) (q2,right) in
         reduce_system p comb
    )
  )"

(* Extract the list of consistent sign assignments *)
definition find_consistent_signs_at_roots:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list"
  where [code]:
    "find_consistent_signs_at_roots p qs =
  ( let (M,S,\<Sigma>) = calculate_data p qs in \<Sigma> )"

lemma find_consistent_signs_at_roots_thm:
  shows "find_consistent_signs_at_roots p qs = snd (snd (calculate_data p qs))"
  by (simp add: case_prod_beta find_consistent_signs_at_roots_def)

end


theory tree_Flatten1
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype 'a Tree = Node "'a Tree" "'a" "'a Tree" | Nil2

fun flatten1 :: "('a Tree) list => 'a list" where
"flatten1 (Nil2) = Nil2"
| "flatten1 (Cons2 (Node (Node x3 x4 x5) x2 q) ps) =
     flatten1 (Cons2 (Node x3 x4 x5) (Cons2 (Node (Nil2) x2 q) ps))"
| "flatten1 (Cons2 (Node (Nil2) x2 q) ps) =
     Cons2 x2 (flatten1 (Cons2 q ps))"
| "flatten1 (Cons2 (Nil2) ps) = flatten1 ps"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun flatten0 :: "'a Tree => 'a list" where
"flatten0 (Node p y q) =
   append (append (flatten0 p) (Cons2 y (Nil2))) (flatten0 q)"
| "flatten0 (Nil2) = Nil2"

(*hipster flatten1 append flatten0 *)

theorem x0 :
  "!! (p :: 'a Tree) . (flatten1 (Cons2 p (Nil2))) = (flatten0 p)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end