section \<open>LLVM like Integer Types with Flexible Bit-Width\<close>
theory LLVM_Integer
imports "HOL-Word.Word" "Word_Lib.Word_Lemmas"
begin

(* TODO: Fix in Word.thy!
  Introducing proper infix-syntax for signed comparisons. So, also (<s) and (<=s) get available.
*)
no_notation word_sle ("(_/ <=s _)" [50, 51] 50)
no_notation word_sless  ("(_/ <s _)" [50, 51] 50)
notation word_sle (infix "<=s" 50)
notation word_sless (infix "<s" 50)

(* Try to remove some useless stuff that Word_Lemmas imported via Complex_Main. *)

declare [[coercion_enabled = false]]

subsection \<open>Additional Lemmas\<close>

class len2 = len +
  assumes len2_not_1 [simp]: "LENGTH('a) \<noteq> Suc 0"

lemma len2_simps[simp]:
  "LENGTH('a::len2) > Suc 0"
  "LENGTH('a::len2) \<ge> 2"
  subgoal by (metis Suc_lessI len2_not_1 len_gt_0)
  subgoal using \<open>Suc 0 < LENGTH('a)\<close> by linarith
  done

lemma len2E: obtains n where "LENGTH('a::len2) = 2+n"
  apply (cases "LENGTH('a)"; simp)
  subgoal for k by (cases k; simp)
  done

instance bit0 :: (len) len2
  by standard simp

instance bit1 :: (len) len2
  by standard simp

definition "len2 (TYPE('a::len2)) \<equiv> True"

(* Original theorem is in simpset, but useless due to non-normalized LHS *)
lemmas [simp] = word_sbin.norm_Rep[simplified]

lemma to_bl_scast_down: "is_down SCAST('a::len \<rightarrow> 'b::len) \<Longrightarrow> to_bl (SCAST('a \<rightarrow> 'b) w) = drop (LENGTH('a)-LENGTH('b)) (to_bl w)"
  by (simp add: is_down scast_down_drop source_size target_size)

declare word_unat.Rep_inject[simp del]
declare word_uint.Rep_inject[simp del]

lemma msb_uint_big: "msb (w::'a::len word) \<longleftrightarrow> uint w \<ge> 2^(LENGTH('a)-1)"
  apply (simp add: msb_big)
  by (metis One_nat_def Suc_pred' diff_le_self le_antisym len_gt_0 n_not_Suc_n p2_eq_0 uint_2p word_le_def word_neq_0_conv)

lemma msb_unat_big: "msb (w::'a::len word) \<longleftrightarrow> unat w \<ge> 2^(LENGTH('a)-1)"
  by (simp add: msb_big word_le_nat_alt)

(* TODO: Move *)
lemma word1_neqZ_is_one: "(a::1 word) \<noteq> 0 \<longleftrightarrow> a=1"
  apply transfer
  subgoal for a
    apply (cases "bin_last a")
    by auto
  done

lemma word1_cases[cases type]:
  fixes a :: "1 word" obtains (zero) "a=0" | (one) "a=1"
  apply (cases "a=0")
  by (auto simp: word1_neqZ_is_one)

(* TODO: Move *)
lemma word1_NOT_eq: "~~(x::1 word) = x+1"
  by (auto simp: NOT_eq)

subsection \<open>Integer Division with Rounding Towards Zero\<close>

text \<open>Division with rounding towards zero\<close>

lemma int_sgn_cases: fixes a::int obtains (negative) "a<0" | (zero) "a=0" | (positive) "a>0"
  by (rule linorder_cases)

text \<open>Lemmas to match original definitions from this development to
  definitions from Word-Library, to which we switched at some point.\<close>
lemma sdiv_int_original_def: "(a::int) sdiv b = (if a\<ge>0 \<longleftrightarrow> b\<ge>0 then \<bar>a\<bar> div \<bar>b\<bar> else - ( \<bar>a\<bar> div \<bar>b\<bar>))"
  apply (cases a rule: int_sgn_cases; cases b rule: int_sgn_cases)
  apply (auto simp: sdiv_int_def sgn_mult)
  done

lemma srem_int_original_def: "(a::int) smod b = (if a\<ge>0 then \<bar>a\<bar> mod \<bar>b\<bar> else - (\<bar>a\<bar> mod \<bar>b\<bar>))"
  apply (cases a rule: int_sgn_cases; cases b rule: int_sgn_cases)
  apply (auto
    simp: smod_int_def sdiv_int_def sgn_mult algebra_simps
    simp flip: minus_mod_eq_mult_div mult_minus_left)
  done

text \<open>Standard properties of remainders\<close>
lemma div_rem_rtz_id: "(a::int) sdiv b * b + a smod b = a"
  by (simp add: smod_int_def)

lemma abs_rem_rtz_lt: "b\<noteq>0 \<Longrightarrow> \<bar>a smod b\<bar> < \<bar>b::int\<bar>"
  using srem_int_original_def by auto

text \<open>LLVM documentation: The remainder is either zero, or has the same sign as the dividend\<close>
lemma rem_rtz_sign: "(a::int) smod b = 0 \<or> sgn ((a::int) smod b) = sgn a"
  apply (clarsimp simp: srem_int_original_def)
  by (smt Euclidean_Division.pos_mod_sign sgn_pos zmod_trival_iff)

lemma sdiv_positive[simp]: "(a::int)\<ge>0 \<Longrightarrow> b\<ge>0 \<Longrightarrow> a sdiv b = a div b"
  by (simp add: sdiv_int_original_def)

lemma smod_positive[simp]: "(a::int)\<ge>0 \<Longrightarrow> b\<ge>0 \<Longrightarrow> a smod b = a mod b"
  by (auto simp: srem_int_original_def)

subsection \<open>Additions to @{theory "HOL-Word.Bool_List_Representation"}\<close>
declare bin_to_bl_def[simp del]

(* TODO: Move *)
(* FIXME: map2 is duplicated from List.map2 *)
lemma map2_eq_Nil_conv[simp]: "map2 f a b = [] \<longleftrightarrow> a=[] \<or> b=[]"
  by (cases a; cases b; auto)

(* TODO: Move *)
lemma bin_trunc_xor':
  "bintrunc n x XOR bintrunc n y = bintrunc n (x XOR y)"
  by (auto simp add: bin_eq_iff bin_nth_ops nth_bintr)

lemma uint_xor: "uint (x XOR y) = uint x XOR uint y"
  by (transfer, simp add: bin_trunc_xor')

lemma bin_to_bl_eq_Nil_conv[simp]: "bin_to_bl w i = [] \<longleftrightarrow> w=0"
  by (metis bin_to_bl_aux.Z bin_to_bl_def size_bin_to_bl)

lemma bin_to_bl_aux_eq_Nil_conv[simp]: "bin_to_bl_aux w i acc = [] \<longleftrightarrow> w=0 \<and> acc=[]"
  by (metis bin_to_bl_aux.Z bin_to_bl_eq_Nil_conv take.simps(1) take_bin2bl_lem1)

lemma bl_to_bin_True [simp]: "bl_to_bin (True # bl) = bl_to_bin bl + 2^length bl"
  by (metis Bit_B1 add.commute add.right_neutral bin_bl_bin bin_cat_num bl_bin_bl bl_to_bin_aux.simps(2) bl_to_bin_aux_alt mult_1s(1) mult_zero_left numeral_code(1))

lemma bl_to_bin_append_num: "bl_to_bin (a@b) = 2^length b * bl_to_bin a + bl_to_bin b"
  by (simp add: bin_cat_num bl_to_bin_app_cat)

lemma bl_to_bin_rep_True: "bl_to_bin (replicate n True) = 2 ^ n - 1"
  by (metis bin_bl_bin bin_to_bl_minus1 bintr_Min)

lemma bl_to_bin_rep_T: "bl_to_bin (replicate n True @ bl) = 2 ^ length bl * (2 ^ n - 1) + bl_to_bin bl"
  by (simp add: bl_to_bin_append_num bl_to_bin_rep_True algebra_simps)

lemma bin_to_bl_strunc[simp]:
  "w\<^sub>1 \<le> w\<^sub>2 + 1 \<Longrightarrow> bin_to_bl w\<^sub>1 (sbintrunc w\<^sub>2 i) = bin_to_bl w\<^sub>1 i"
  by (simp add: bintrunc_sbintrunc_le bl_to_bin_inj)

lemma bin_last_x2[simp]: "bin_last (2*n) = False" by (auto simp: bin_last_def)
lemma bin_rest_x2[simp]: "bin_rest (2*n) = n" by (auto simp: bin_rest_def)

lemma bin_to_bl_x2[simp]: "w\<noteq>0 \<Longrightarrow> bin_to_bl w (2*n) = bin_to_bl (w-1) n @ [False]"
  by (cases w) (auto simp: bin_to_bl_def bin_to_bl_aux_append)

lemma bin_to_bl_xp2[simp]:
  assumes "n\<le>w"
  shows "bin_to_bl w (x * 2^n) = bin_to_bl (w-n) x @ replicate n False"
proof -
  have [simp]: "x * (2 * 2 ^ n) = 2 * (x*2^n)" for n by auto

  show ?thesis using assms
    by (induction n) (auto simp: drop_bin2bl[symmetric] replicate_append_same)
qed

lemma bintrunc_eq_if_in_range: "bintrunc w i = i \<longleftrightarrow> i\<in>uints w"
  by (simp add: bintrunc_mod2p int_mod_lem uints_num)

lemma sbintrunc_eq_if_in_range: "sbintrunc (w-Suc 0) i = i \<longleftrightarrow> i\<in>sints w"
  apply (clarsimp simp: sbintrunc_mod2p sints_def)
  by (smt eq_mod_iff mem_Collect_eq range_sbintrunc zero_less_power)

lemma bl_to_bin_in_uints: "bl_to_bin x \<in> uints (length x)"
  using bl_to_bin_def bintrunc_eq_if_in_range by fastforce

(* TODO: This is probably a special case of a more general scheme! *)

method_setup pull_mods = \<open>Scan.succeed (fn ctxt =>  SIMPLE_METHOD' (
  CONVERSION (Conv.top_conv (K (Conv.try_conv (Conv.rewrs_conv @{thms pull_mods}))) ctxt)
))\<close>

method_setup pull_push_mods = \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (
  CONVERSION (Conv.top_conv (K (Conv.try_conv (Conv.rewrs_conv @{thms pull_mods}))) ctxt)
  THEN' (full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms mod_mod_trivial push_mods}))
))\<close> \<open>Pull in, then push out modulos\<close>

subsection \<open>Signed integers in Two's Complement Representation\<close>

definition bl_to_sbin :: "bool list \<Rightarrow> int"
  where "bl_to_sbin bl = sbintrunc (length bl - 1) (bl_to_bin bl)"

lemma bl_to_sbin_alt:
  "bl_to_sbin bl = (case bl of [] \<Rightarrow> 0 | b#bl \<Rightarrow> (if b then -(2^length bl) else 0) + bl_to_bin bl)"
  apply (auto simp: bl_to_sbin_def sbintrunc_mod2p bl_to_bin_ge0 bl_to_bin_lt2p split: list.splits)
  by (smt bl_to_bin_ge0 bl_to_bin_lt2p int_mod_eq')

lemma bl_sbin_bl[simp]: "bin_to_bl (length bs) (bl_to_sbin bs) = bs"
  unfolding bl_to_sbin_def by auto

lemma sbin_bl_bin[simp]:
  "0<w \<Longrightarrow> bl_to_sbin (bin_to_bl w i) = sbintrunc (w-1) i"
  unfolding bl_to_sbin_def by auto

lemma bl_to_sbin_in_sints: "bl_to_sbin x \<in> sints (length x)"
  using bl_to_sbin_def sbintrunc_eq_if_in_range by fastforce

subsection \<open>Lifting of Operations\<close>

definition "cnv_uop1 f a \<equiv> bin_to_bl (length a) (f (bl_to_bin a))"
definition "cnv_uop2 nel f a b \<equiv>
  if length a = length b then
    bin_to_bl (length a) (f (bl_to_bin a) (bl_to_bin b))
  else nel ()"

definition "cnv_uop2b nel f a b \<equiv> if length a = length b then
    f (bl_to_bin a) (bl_to_bin b)
  else nel ()"

lemma cnv_uop1_correct[simp]:
  "bl_to_bin (cnv_uop1 f a) = bintrunc (length a) (f (bl_to_bin a))
  \<and> length (cnv_uop1 f a) = length a"
  by (auto simp: cnv_uop1_def)

lemma cnv_uop2_correct[simp]:
  "length a = length b
    \<Longrightarrow> bl_to_bin (cnv_uop2 nel f a b) = bintrunc (length a) (f (bl_to_bin a) (bl_to_bin b))
      \<and> length (cnv_uop2 nel f a b) = length b"
  by (auto simp: cnv_uop2_def)

lemma cnv_uop2b_correct[simp]:
  "length a = length b \<Longrightarrow> cnv_uop2b nel f a b = f (bl_to_bin a) (bl_to_bin b)"
  by (auto simp: cnv_uop2b_def)

definition "cnv_sop1 f a \<equiv> bin_to_bl (length a) (f (bl_to_sbin a))"
definition "cnv_sop2 nel f a b \<equiv>
  if length a = length b then
    bin_to_bl (length a) (f (bl_to_sbin a) (bl_to_sbin b))
  else
    nel ()"

definition "cnv_sop2b nel f a b \<equiv> if length a = length b then
    f (bl_to_sbin a) (bl_to_sbin b)
  else nel ()"

lemma length_cnv_sop1[simp]: "length (cnv_sop1 f a) = length a"
  unfolding cnv_sop1_def by auto

lemma cnv_sop1_correct[simp]: "a\<noteq>[]
  \<Longrightarrow> bl_to_sbin (cnv_sop1 f a) = sbintrunc (length a - 1) (f (bl_to_sbin a))
    \<and> length (cnv_sop1 f a) = length a"
  by (auto simp: cnv_sop1_def)

lemma cnv_sop2_correct[simp]: "a\<noteq>[] \<Longrightarrow> length a = length b
  \<Longrightarrow> bl_to_sbin (cnv_sop2 nel f a b) = sbintrunc (length a - 1) (f (bl_to_sbin a) (bl_to_sbin b))
    \<and> length (cnv_sop2 nel f a b) = length b"
  apply (auto simp: cnv_sop2_def)
  using sbin_bl_bin by fastforce

lemma cnv_sop2_correct'[simp]: "b\<noteq>[] \<Longrightarrow> length a = length b
  \<Longrightarrow> bl_to_sbin (cnv_sop2 nel f a b) = sbintrunc (length a - 1) (f (bl_to_sbin a) (bl_to_sbin b))
    \<and> length (cnv_sop2 nel f a b) = length b"
  by (metis cnv_sop2_correct length_0_conv)

lemma cnv_sop2b_correct[simp]:
  "length a = length b \<Longrightarrow> cnv_sop2b nel f a b = f (bl_to_sbin a) (bl_to_sbin b)"
  by (auto simp: cnv_sop2b_def)

lemma cnv_uop1_empty_iff[simp]: "cnv_uop1 f a = [] \<longleftrightarrow> a=[]"
  by (auto simp: cnv_uop1_def)

lemma cnv_uop2_empty_iff[simp]: "cnv_uop2 nel f a b = [] \<longleftrightarrow> (if length a = length b then a=[] else nel () = [])"
  by (auto simp: cnv_uop2_def)

lemma cnv_sop2_empty_iff[simp]: "cnv_sop2 nel f a b = [] \<longleftrightarrow> (if length a = length b then a=[] else nel () = [])"
  by (auto simp: cnv_sop2_def)

lemma cnv_sop1_empty_iff[simp]: "cnv_sop1 f a = [] \<longleftrightarrow> a=[]"
  by (auto simp: cnv_sop1_def)

subsubsection \<open>Operations Independent of Signed/Unsigned Interpretation \<close>

definition "signed_unsigned_compat1 f \<equiv> \<forall>w a. sbintrunc w (f (sbintrunc w a)) = sbintrunc w (f a)"
definition "signed_unsigned_compat2 f \<equiv> \<forall>w a b. sbintrunc w (f (sbintrunc w a) (sbintrunc w b)) = sbintrunc w (f a b)"

lemma cnv_uop1_to_sop1:
  assumes "signed_unsigned_compat1 f"
  shows "cnv_uop1 f a = cnv_sop1 f a"
  apply (auto simp: cnv_uop1_def cnv_sop1_def bl_to_sbin_def)
  using assms unfolding signed_unsigned_compat1_def
  by (metis (no_types, lifting) bin_bl_bin bintrunc_sbintruncS0 bl_bin_bl length_greater_0_conv size_bin_to_bl)

lemma cnv_uop2_to_sop2:
  assumes [simp]: "length a = length b"
  assumes "signed_unsigned_compat2 f"
  shows "cnv_uop2 nel f a b = cnv_sop2 nel f a b"
  apply (auto simp: cnv_uop2_def cnv_sop2_def bl_to_sbin_def)
  using assms(2) unfolding signed_unsigned_compat2_def
  by (metis (no_types, lifting) bin_bl_bin bintrunc_sbintruncS0 bl_bin_bl length_greater_0_conv size_bin_to_bl)

lemma cnv_uop1_compat_correct:
  assumes [simp]: "signed_unsigned_compat1 f"
  assumes [simp]: "a\<noteq>[]"
  shows "bl_to_sbin (cnv_uop1 f a) = sbintrunc (length a - 1) (f (bl_to_sbin a))"
  by (auto simp: cnv_uop1_to_sop1)

lemma cnv_uop2_compat_correct:
  assumes [simp]: "length a = length b"
  assumes [simp]: "signed_unsigned_compat2 f"
  assumes [simp]: "a\<noteq>[]"
  shows "bl_to_sbin (cnv_uop2 nel f a b) = sbintrunc (length a - 1) (f (bl_to_sbin a) (bl_to_sbin b))"
  by (auto simp: cnv_uop2_to_sop2)

lemma cnv_uop2_compat_correct':
  assumes [simp]: "length a = length b"
  assumes [simp]: "signed_unsigned_compat2 f"
  assumes [simp]: "b\<noteq>[]"
  shows "bl_to_sbin (cnv_uop2 nel f a b) = sbintrunc (length a - 1) (f (bl_to_sbin a) (bl_to_sbin b))"
  by (metis assms cnv_uop2_compat_correct length_0_conv)

lemma signed_unsigned_compat2_plus[simp]: "signed_unsigned_compat2 (+)"
  apply (auto simp: signed_unsigned_compat2_def sbintrunc_mod2p)
  apply (pull_push_mods)
  by (simp add: algebra_simps)

lemma signed_unsigned_compat2_minus[simp]: "signed_unsigned_compat2 (-)"
  apply (clarsimp simp: signed_unsigned_compat2_def sbintrunc_mod2p)
  apply (pull_push_mods)
  by (simp add: algebra_simps)

lemma signed_unsigned_compat2_mult[simp]: "signed_unsigned_compat2 ( * )"
  apply (auto simp: signed_unsigned_compat2_def sbintrunc_mod2p)
  apply pull_push_mods
  by (simp add: algebra_simps)

subsection \<open>Bitwise Interpretation of Operations\<close>
text \<open>Provides an additional sanity check, by equating our definitions with the definitions found in
  @{theory "HOL-Word.Bool_List_Representation"}. Unfortunately, they do not define minus there.\<close>

lemma cnv_plus_rbl_conv: "length a = length b \<Longrightarrow> cnv_uop2 nel (+) a b = rev (rbl_add (rev a) (rev b))"
  apply (rule sym)
  apply (subst bl_bin_bl[symmetric, of a])
  apply (subst bl_bin_bl[symmetric, of b])
  by (auto simp: cnv_uop2_def rbl_add simp del: bl_bin_bl)

lemma cnv_mult_rbl_conv: "length a = length b \<Longrightarrow> cnv_uop2 nel ( * ) a b = rev (rbl_mult (rev a) (rev b))"
  apply (rule sym)
  apply (subst bl_bin_bl[symmetric, of a])
  apply (subst bl_bin_bl[symmetric, of b])
  by (auto simp: cnv_uop2_def rbl_mult simp del: bl_bin_bl)

lemma cnv_AND_bl_conv: "length a = length b \<Longrightarrow> cnv_uop2 nel (AND) a b = map2 (\<and>) a b"
  apply (rule sym)
  apply (subst bl_bin_bl[symmetric, of a])
  apply (subst bl_bin_bl[symmetric, of b])
  by (auto simp: cnv_uop2_def bl_and_bin simp del: bl_bin_bl)

lemma cnv_OR_bl_conv: "length a = length b \<Longrightarrow> cnv_uop2 nel (OR) a b = map2 (\<or>) a b"
  apply (rule sym)
  apply (subst bl_bin_bl[symmetric, of a])
  apply (subst bl_bin_bl[symmetric, of b])
  by (auto simp: cnv_uop2_def bl_or_bin simp del: bl_bin_bl)

(* TODO: Lemma bl_xor_bin has non-normalized lhs! *)
lemma cnv_XOR_bl_conv: "length a = length b \<Longrightarrow> cnv_uop2 nel (XOR) a b = map2 (\<noteq>) a b"
  apply (rule sym)
  apply (subst bl_bin_bl[symmetric, of a])
  apply (subst bl_bin_bl[symmetric, of b])
  by (auto simp: bl_xor_bin[simplified] cnv_uop2_def simp del: bl_bin_bl)

lemma cnv_NOT_bl_conv: "cnv_uop1 (bitNOT) a = map Not a"
  apply (rule sym)
  apply (subst bl_bin_bl[symmetric, of a])
  apply (simp only: bl_not_bin)
  by (auto simp: cnv_uop1_def)

lemma cnv_SHL_bl_conv: "n\<le>length a \<Longrightarrow> cnv_uop1 (\<lambda>x. x * 2^n) a = drop n a @ replicate n False"
  by (auto simp: cnv_uop1_def bl_bin_bl_rep_drop)

lemma butlast_bin_to_bl_aux: "acc\<noteq>[] \<Longrightarrow> butlast (bin_to_bl_aux w i acc) = bin_to_bl_aux w i (butlast acc)"
  by (simp add: bin_to_bl_aux_alt butlast_append)

lemma bin_rest_div2[simp]: "bin_rest (n div 2) = bin_rest n div 2"
  by (auto simp: bin_rest_def)

lemma bin_last_div2[simp]: "bin_last (n div 2) = bin_last (bin_rest n)"
  by (auto simp: bin_rest_def)

find_theorems bin_to_bl_aux "(@)"

lemma bin_to_bl_Suc: "bin_to_bl (Suc w) i = bin_to_bl w (bin_rest i) @ [bin_last i]"
  by (simp add: bin_to_bl_aux_append bin_to_bl_def)

lemma "butlast (bin_to_bl w n) = bin_to_bl (w-1) (bin_rest n)" oops
  thm butlast_rest_bin

  find_theorems "bin_to_bl _ _ ! _"

lemma bin_to_bl_div2_shift: "\<lbrakk>w\<noteq>0; n\<ge>0; n<2^w\<rbrakk> \<Longrightarrow> bin_to_bl w (n div 2) = False # butlast (bin_to_bl w n)"
  apply (cases w; simp)
  apply (rule nth_equalityI)
  apply (auto simp: butlast_rest_bin bin_rest_def nth_Cons nth_bin_to_bl bin_nth_eq_mod split: nat.splits)
  done

lemma div_div_p2_eq_div_p2s:
  "w div (2^a) div (2^b) = (w::int) div 2^(a+b)"
  "w div 2 div (2^b) = (w::int) div 2^(Suc b)"
  by (simp_all add: div_mult2_eq power_add zdiv_zmult2_eq)

lemma bin_to_bl_div2p_shift: "\<lbrakk>n\<ge>0; n<2^w; k\<le>w\<rbrakk> \<Longrightarrow> bin_to_bl w (n div 2^k) = replicate k False @ take (w-k) (bin_to_bl w n)"
  apply (rule nth_equalityI)
  apply (auto simp: butlast_rest_bin bin_rest_def nth_Cons nth_append nth_bin_to_bl bin_nth_eq_mod split: nat.splits)
  subgoal
    apply (simp add: div_div_p2_eq_div_p2s)
    by (smt Nat.le_add_diff Suc_leI div_pos_pos_trivial even_zero not_less power_strict_increasing_iff)
  subgoal
    by (smt Nat.add_diff_assoc2 Suc_leI add.commute power_add zdiv_zmult2_eq zero_le_power_eq)
  subgoal
    by (smt Nat.add_diff_assoc2 Suc_leI add.commute power_add zdiv_zmult2_eq zero_le_power_eq)
  done

lemma cnv_LSHR_bl_conv: "n\<le>length a \<Longrightarrow> cnv_uop1 (\<lambda>x. x div 2^n) a = replicate n False @ take (length a - n) a"
  apply (cases "length a")
  apply (auto simp: cnv_uop1_def bin_to_bl_div2p_shift)
  by (metis bin_to_bl_div2p_shift bl_bin_bl bl_to_bin_ge0 bl_to_bin_lt2p)

text \<open>Note: This division is with rounding down!\<close>
lemma bin_to_bl_sdiv2_shift:
  assumes ran: "-(2^w)\<le>i" "i<2^w"
  shows "bin_to_bl (Suc w) (i div 2) = hd (bin_to_bl (Suc w) i) # butlast (bin_to_bl (Suc w) i)"
proof -
  have "\<lbrakk> \<not> 0 \<le> (i::int)\<rbrakk> \<Longrightarrow> i div (2*2^w) = -1" using ran
    by (smt cancel_div_mod_rules(2) div_pos_pos_trivial mod_add_self2 mult_cancel_left1 mult_minus_right)

  then show ?thesis using ran
    apply (rule_tac nth_equalityI)
    by (auto
        simp: butlast_rest_bin bin_rest_def nth_Cons bl_sbin_sign nth_bin_to_bl bin_nth_eq_mod bin_sign_def sbintrunc_mod2p div_div_p2_eq_div_p2s
        split: nat.splits)
qed

lemma bin_to_bl_sdiv2p_shift:
  assumes ran: "-(2^w)\<le>i" "i<2^w" and K: "k<Suc w"
  shows "bin_to_bl (Suc w) (i div 2^k) = replicate k (hd (bin_to_bl (Suc w) i)) @ take (Suc w - k) (bin_to_bl (Suc w) i)"
proof -

  have "\<lbrakk>\<not>0\<le>i; x\<ge>w\<rbrakk> \<Longrightarrow> i div (2^x) = -1" for x using ran
    apply auto
    by (smt cancel_div_mod_rules(2) int_mod_eq' linorder_not_le mod_add_self2 mult_cancel_left1 mult_minus_right power_strict_increasing_iff)

  with ran K show ?thesis
    apply (rule_tac nth_equalityI)
    apply (auto
        simp: butlast_rest_bin bin_rest_def nth_Cons bl_sbin_sign nth_bin_to_bl bin_nth_eq_mod bin_sign_def sbintrunc_mod2p div_div_p2_eq_div_p2s
        simp: nth_append algebra_simps
        split: nat.splits)
    by (smt Nat.le_add_diff diff_is_0_eq' div_pos_pos_trivial even_zero less_imp_le power_strict_increasing_iff zero_less_diff)
qed

lemma cnv_ASHR_bl_conv: "n<length a \<Longrightarrow> cnv_sop1 (\<lambda>x. x div 2^n) a = replicate n (hd a) @ take (length a - n) a"
  apply (cases "length a")
  apply (auto simp: cnv_sop1_def)
  by (metis bin_to_bl_sdiv2p_shift bl_sbin_bl bl_to_sbin_def diff_Suc_1 sbintr_ge sbintr_lt)

subsection \<open>Signed and Unsigned Extension and Truncation\<close>

definition bl_trunc :: "nat \<Rightarrow> bool list \<Rightarrow> bool list" where "bl_trunc w bl \<equiv> drop (length bl - w) bl"

lemma bl_trunc_ge[simp]: "length bl < w \<Longrightarrow> bl_trunc w bl = bl"
  by (simp add: bl_trunc_def)

lemma trunc_bl_to_bin[simp]: "bl_to_bin (bl_trunc w bl) = bintrunc w (bl_to_bin bl)"
  by (simp add: bl_trunc_def trunc_bl2bin)

lemma trunc_bl_to_sbin[simp]:
  "w>0 \<Longrightarrow> bl_to_sbin (bl_trunc w bl) = sbintrunc (w-1) (bl_to_sbin bl)"
  apply (cases "w \<le> length bl")
  apply (auto simp: bl_trunc_def bl_to_sbin_def bl2bin_drop min_def)
  done

lemma bl_trunc_len[simp]: "length (bl_trunc w bl) = min w (length bl)"
  by (auto simp: bl_trunc_def)

lemma bl_trunc_eq_Nil_conv[simp]: "bl_trunc w l = [] \<longleftrightarrow> w=0 \<or> l=[]"
  by (cases l) (auto simp: bl_trunc_def)

definition bl_zext :: "nat \<Rightarrow> bool list \<Rightarrow> bool list" where "bl_zext w bl \<equiv> replicate (w - length bl) False @ bl"

lemma bl_zext_le[simp]: "w\<le>length bl \<Longrightarrow> bl_zext w bl = bl"
  by (auto simp: bl_zext_def)

lemma bl_zext_to_bin[simp]: "bl_to_bin (bl_zext w bl) = bl_to_bin bl"
  by (auto simp: bl_zext_def bl_to_bin_rep_F)

lemma bl_zext_len[simp]: "length (bl_zext w bl) = max w (length bl)"
  by (auto simp: bl_zext_def)

lemma bl_zext_Nil_conv[simp]: "bl_zext w bl = [] \<longleftrightarrow> w=0 \<and> bl = []"
  by (auto simp: bl_zext_def)

definition bl_sext :: "nat \<Rightarrow> bool list \<Rightarrow> bool list" where "bl_sext w bl \<equiv> replicate (w - length bl) (hd bl) @ bl"

lemma bl_sext_le[simp]: "w\<le>length bl \<Longrightarrow> bl_sext w bl = bl"
  by (auto simp: bl_sext_def)

lemma bl_to_sbin_pos_conv_bin: "\<not>hd bl \<Longrightarrow> bl_to_sbin bl = bl_to_bin bl"
  by (auto simp: bl_to_sbin_alt split: list.split)

lemma bl_to_sbin_neg_conv_bin: "bl\<noteq>[] \<Longrightarrow> hd bl \<Longrightarrow> bl_to_sbin bl = bl_to_bin bl - 2^(length bl)"
  by (auto simp: bl_to_sbin_alt split: list.split)

lemma bl_sext_to_sbin[simp]:
  assumes [simp]: "bl\<noteq>[]"
  shows "bl_to_sbin (bl_sext w bl) = bl_to_sbin bl"
  apply (cases "w>length bl"; simp?)
proof (cases "hd bl")
  case True
  assume "length bl < w"
  with True show ?thesis
    apply (auto simp: bl_to_sbin_neg_conv_bin bl_sext_def bl_to_bin_rep_T algebra_simps)
    by (metis diff_add_inverse less_imp_add_positive power_add)
next
  case False
  assume "length bl < w"
  with False show ?thesis by (auto simp: bl_to_sbin_pos_conv_bin bl_sext_def bl_to_bin_rep_F)
qed

lemma bl_sext_len[simp]: "length (bl_sext w bl) = max w (length bl)"
  by (auto simp: bl_sext_def)

lemma bl_sext_Nil_conv[simp]: "bl_sext w bl = [] \<longleftrightarrow> w=0 \<and> bl = []"
  by (auto simp: bl_sext_def)

subsection \<open>LLVM Integer Datatype\<close>

typedef lint = "{l::bool list. True }"
  morphisms lint_to_bits bits_to_lint
  by auto

setup_lifting type_definition_lint

(*lemma Rep_lint_neq_Nil[simp]: "lint_to_bits x \<noteq> []"
  using lint_to_bits by simp
*)

instantiation lint :: equal
begin
  lift_definition equal_lint :: "lint \<Rightarrow> lint \<Rightarrow> bool" is "equal_class.equal" .

  instance
    apply intro_classes
    apply transfer
    apply (rule equal_eq)
    done

end

lift_definition width :: "lint \<Rightarrow> nat" is length .
lift_definition lint_to_uint :: "lint \<Rightarrow> int" is bl_to_bin .
lift_definition lint_to_sint :: "lint \<Rightarrow> int" is bl_to_sbin .

(*lemma width_notZ[simp]: "width a \<noteq> 0" by transfer auto*)

lemma uint_lower_bound[simp]: "0\<le>lint_to_uint a"
  apply transfer using bl_to_bin_ge0 by auto

lemma uint_upper_bound[simp]: "lint_to_uint a < 2^width a"
  apply transfer by (simp add: bl_to_bin_lt2p)

lemma sint_lower_bound[simp]: "-(2^(width a - 1))\<le>lint_to_sint a"
  apply transfer by (simp add: bl_to_sbin_def sbintr_ge)

lemma sint_upper_bound[simp]: "lint_to_sint a < 2^(width a - 1)"
  apply transfer by (simp add: bl_to_sbin_def sbintr_lt)

subsubsection \<open>Overflows\<close>

definition "uovf1 f a \<equiv> f (lint_to_uint a) \<notin> uints (width a)"
definition "sovf1 f a \<equiv> f (lint_to_sint a) \<notin> sints (width a)"

definition "uovf2 f a b \<equiv> f (lint_to_uint a) (lint_to_uint b) \<notin> uints (width a)"
definition "sovf2 f a b \<equiv> f (lint_to_sint a) (lint_to_sint b) \<notin> sints (width a)"

subsubsection \<open>Operations\<close>

lift_definition lconst :: "nat \<Rightarrow> int \<Rightarrow> lint" is "\<lambda>w i. bin_to_bl w i" by simp

lemma width_lconst[simp]: "width (lconst w i) = w"
  by transfer auto

lemma uint_const[simp]: "lint_to_uint (lconst w c) = bintrunc w c"
  by transfer auto

lemma sint_const[simp]: "w\<noteq>0 \<Longrightarrow> lint_to_sint (lconst w c) = sbintrunc (w-1) c"
  by transfer (auto)

lemma bits_zero[simp]: "lint_to_bits (lconst w 0) = replicate w False"
  by transfer (auto simp: bin_to_bl_zero)

lemma bits_minus1[simp]: "lint_to_bits (lconst w (-1)) = replicate w True"
  by transfer (auto simp: bin_to_bl_minus1)

lemma lconst_eq_iff[simp]:
  "lconst w c = lconst w' c' \<longleftrightarrow> w'=w \<and> (c' mod 2^w = c mod 2^w)"
  apply safe
  subgoal
    apply transfer
    by (metis len_bin_to_bl)
  subgoal
    apply transfer
    by (metis bin_bl_bin bintrunc_mod2p len_bin_to_bl)
  subgoal
    apply transfer
    by (auto simp: max_def bintrunc_mod2p bl_to_bin_inj)
  done

definition "lint_abort (_::unit) \<equiv> lint_to_bits undefined"
definition "lint_abort_bool (_::unit) \<equiv> undefined::bool"

(*lemma l_abort_ne[simp]: "lint_abort () \<noteq> []" unfolding lint_abort_def by auto*)
declare [[ code abort: lint_abort lint_abort_bool]]

instantiation lint :: "{plus,minus,times,divide,modulo,uminus,signed_div}"
begin
  lift_definition plus_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint" is "cnv_uop2 (lint_abort) (+)" by simp
  lift_definition minus_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint" is "cnv_uop2 (lint_abort) (-)" by simp
  lift_definition times_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint" is "cnv_uop2 (lint_abort) ( * )" by simp
  lift_definition divide_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint" is "cnv_uop2 (lint_abort) (div)" by simp
  lift_definition modulo_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint" is "cnv_uop2 (lint_abort) (mod)" by simp

  lift_definition uminus_lint :: "lint \<Rightarrow> lint" is "cnv_sop1 uminus" by simp

  definition sdivrem_ovf :: "lint \<Rightarrow> lint \<Rightarrow> bool" where
    "sdivrem_ovf a b \<equiv> lint_to_sint a sdiv lint_to_sint b \<notin> sints (width a)"

  lift_definition sdiv_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint"
    is "\<lambda>a b. if bl_to_sbin a sdiv bl_to_sbin b \<in> sints (length a) then cnv_sop2 lint_abort (sdiv) a b else lint_abort ()"
    by simp

  lift_definition smod_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint"
    is "\<lambda>a b. if bl_to_sbin a sdiv bl_to_sbin b \<in> sints (length a) then cnv_sop2 lint_abort (smod) a b else lint_abort ()"
    by simp

  instance ..
end

lemma width_plus[simp]:
  assumes "width a = width b"
  shows "width (a+b) = width b"
  using assms by transfer auto

lemma uint_plus[simp]:
  assumes "width a = width b"
  shows "lint_to_uint (a+b) = bintrunc (width b) (lint_to_uint a + lint_to_uint b)"
  using assms by transfer auto

lemma sint_plus[simp]:
  assumes "width a = width b" "width b \<noteq> 0"
  shows "lint_to_sint (a+b) = sbintrunc (width b - 1) (lint_to_sint a + lint_to_sint b)"
  using assms by transfer (auto simp: cnv_uop2_compat_correct')

lemma width_minus[simp]:
  assumes "width a = width b"
  shows "width (a-b) = width b"
  using assms by transfer auto

lemma uint_minus[simp]:
  assumes "width a = width b"
  shows "lint_to_uint (a-b) = bintrunc (width b) (lint_to_uint a - lint_to_uint b)"
  using assms
  by transfer auto

lemma sint_minus[simp]:
  assumes "width a = width b" "width b \<noteq> 0"
  shows "lint_to_sint (a-b) = sbintrunc (width b - 1) (lint_to_sint a - lint_to_sint b)"
  using assms
  by transfer (auto simp: cnv_uop2_compat_correct')

lemma width_times[simp]:
  assumes "width a = width b"
  shows "width (a*b) = width b"
  using assms by transfer auto

lemma uint_times[simp]:
  assumes "width a = width b"
  shows "lint_to_uint (a*b) = bintrunc (width b) (lint_to_uint a * lint_to_uint b)"
  using assms
  by transfer auto

lemma sint_times[simp]:
  assumes "width a = width b" "width b \<noteq> 0"
  shows "lint_to_sint (a*b) = sbintrunc (width b - 1) (lint_to_sint a * lint_to_sint b)"
  using assms
  by transfer (auto simp: cnv_uop2_compat_correct')

lemma width_divide[simp]:
  assumes "width a = width b"
  shows "width (a div b) = width b"
  using assms by transfer auto

lemma uint_divide[simp]:
  assumes "width a = width b"
  shows "lint_to_uint (a div b) = bintrunc (width b) (lint_to_uint a div lint_to_uint b)"
  using assms
  by transfer auto

lemma width_sdivide[simp]:
  assumes "width a = width b" "width b \<noteq> 0"
  assumes "\<not>sdivrem_ovf a b"
  shows "width (a sdiv b) = width b"
  using assms unfolding sdivrem_ovf_def
  by transfer auto

lemma sint_sdivide[simp]:
  assumes "width a = width b" "width b \<noteq> 0"
  assumes "\<not>sdivrem_ovf a b"
  shows "lint_to_sint (a sdiv b) = sbintrunc (width b - 1) ((lint_to_sint a) sdiv (lint_to_sint b))"
  using assms unfolding sdivrem_ovf_def
  by transfer auto

lemma width_modulo[simp]:
  assumes "width a = width b"
  shows "width (a mod b) = width b"
  using assms by transfer auto

lemma uint_modulo[simp]:
  assumes "width a = width b"
  shows "lint_to_uint (a mod b) = bintrunc (width b) (lint_to_uint a mod lint_to_uint b)"
  using assms
  by transfer auto

lemma width_srem[simp]:
  assumes "width a = width b" "width b \<noteq> 0"
  assumes "\<not>sdivrem_ovf a b"
  shows "width (a smod b) = width b"
  using assms unfolding sdivrem_ovf_def
  by transfer auto

lemma sint_remainder[simp]:
  assumes "width a = width b" "width b \<noteq> 0"
  assumes "\<not>sdivrem_ovf a b"
  shows "lint_to_sint (a smod b) = sbintrunc (width b - 1) ((lint_to_sint a) smod (lint_to_sint b))"
  using assms unfolding sdivrem_ovf_def
  by transfer auto

lemma width_uminus[simp]:
  "width (- a) = width a"
  by transfer auto

lemma sint_uminus[simp]:
  "width a \<noteq> 0 \<Longrightarrow> lint_to_sint (- a) = sbintrunc (width a - 1) (- lint_to_sint a)"
  by transfer auto

instantiation lint :: "{ord}"
begin
  lift_definition less_lint :: "lint \<Rightarrow> lint \<Rightarrow> bool" is "cnv_uop2b lint_abort_bool (<)" .
  lift_definition less_eq_lint :: "lint \<Rightarrow> lint \<Rightarrow> bool" is "cnv_uop2b lint_abort_bool (\<le>)" .
  instance ..
end

lift_definition sless_lint :: "lint \<Rightarrow> lint \<Rightarrow> bool" (infix "<\<^sub>s" 50) is "cnv_sop2b lint_abort_bool (<)" .
lift_definition sless_eq_lint :: "lint \<Rightarrow> lint \<Rightarrow> bool" (infix "\<le>\<^sub>s" 50) is "cnv_sop2b lint_abort_bool (\<le>)" .

lemma uint_less[simp]:
  assumes "width a = width b"
  shows "a < b \<longleftrightarrow> lint_to_uint a < lint_to_uint b"
  using assms by transfer auto

lemma uint_less_eq[simp]:
  assumes "width a = width b"
  shows "a \<le> b \<longleftrightarrow> lint_to_uint a \<le> lint_to_uint b"
  using assms by transfer auto

lemma sint_less[simp]:
  assumes "width a = width b"
  shows "a <\<^sub>s b \<longleftrightarrow> lint_to_sint a < lint_to_sint b"
  using assms by transfer auto

lemma sint_less_eq[simp]:
  assumes "width a = width b"
  shows "a \<le>\<^sub>s b \<longleftrightarrow> lint_to_sint a \<le> lint_to_sint b"
  using assms by transfer auto

text \<open>Yields \<open>0\<^sub>1\<close> on attempt to truncate to zero\<close>
lift_definition trunc :: "nat \<Rightarrow> lint \<Rightarrow> lint" is "\<lambda>w a. if w=0 then [False] else bl_trunc w a"
  by auto

lemma width_trunc[simp]: "w\<noteq>0 \<Longrightarrow> width (trunc w a) = min w (width a)" by transfer auto

lemma uint_trunc[simp]: "w\<noteq>0 \<Longrightarrow> lint_to_uint (trunc w a) = bintrunc w (lint_to_uint a)"
  by transfer auto

lemma sint_trunc[simp]: "w\<noteq>0 \<Longrightarrow> lint_to_sint (trunc w a) = sbintrunc (w-1) (lint_to_sint a)"
  by transfer auto

lift_definition zext :: "nat \<Rightarrow> lint \<Rightarrow> lint" is "bl_zext" by simp
lift_definition sext :: "nat \<Rightarrow> lint \<Rightarrow> lint" is "bl_sext" by simp

lemma width_zext[simp]: "width (zext w a) = max w (width a)"
  by transfer auto
lemma width_sext[simp]: "width (sext w a) = max w (width a)"
  by transfer auto

lemma uint_zext[simp]: "lint_to_uint (zext w a) = lint_to_uint a"
  by transfer auto

lemma sint_sext[simp]: "width a \<noteq> 0 \<Longrightarrow> lint_to_sint (sext w a) = lint_to_sint a"
  by transfer auto

instantiation lint :: bit
begin
  lift_definition bitAND_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint" is "cnv_uop2 lint_abort (AND)" by simp
  lift_definition bitOR_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint" is "cnv_uop2 lint_abort (OR)" by simp
  lift_definition bitXOR_lint :: "lint \<Rightarrow> lint \<Rightarrow> lint" is "cnv_uop2 lint_abort (XOR)" by simp
  lift_definition bitNOT_lint :: "lint \<Rightarrow> lint" is "cnv_uop1 (bitNOT)" by simp

  instance ..
end

lemma width_AND[simp]:
  assumes "width a = width b"
  shows "width (a AND b) = width b"
  using assms by transfer auto

lemma uint_AND[simp]:
  assumes "width a = width b"
  shows "lint_to_uint (a AND b) = lint_to_uint a AND lint_to_uint b"
  using assms apply (transfer)
  apply (auto simp: )
  by (metis bin_trunc_ao(1) trunc_bl2bin_len)

lemma width_OR[simp]:
  assumes "width a = width b"
  shows "width (a OR b) = width b"
  using assms by transfer auto

lemma uint_OR[simp]:
  assumes "width a = width b"
  shows "lint_to_uint (a OR b) = lint_to_uint a OR lint_to_uint b"
  using assms apply (transfer)
  by (metis bin_trunc_ao(2) cnv_uop2_correct trunc_bl2bin_len)

lemma width_XOR[simp]:
  assumes "width a = width b"
  shows "width (a XOR b) = width b"
  using assms by transfer auto

lemma uint_XOR[simp]:
  assumes "width a = width b"
  shows "lint_to_uint (a XOR b) = lint_to_uint a XOR lint_to_uint b"
  using assms apply (transfer)
  by (metis bin_trunc_xor' cnv_uop2_correct trunc_bl2bin_len)

lemma width_NOT[simp]:
  "width (NOT a) = width a"
  by transfer auto

lemma uint_NOT[simp]:
  shows "lint_to_uint (NOT a) = bintrunc (width a) (NOT (lint_to_uint a))"
  by transfer auto

lemma bits_NOT[simp]: "lint_to_bits (NOT a) = map Not (lint_to_bits a)"
  by transfer (auto simp: cnv_NOT_bl_conv)

lemma bits_AND[simp]: "width a = width b \<Longrightarrow> lint_to_bits (a AND b) = map2 (\<and>) (lint_to_bits a) (lint_to_bits b)"
  by transfer (auto simp: cnv_AND_bl_conv)

lemma bits_OR[simp]: "width a = width b \<Longrightarrow> lint_to_bits (a OR b) = map2 (\<or>) (lint_to_bits a) (lint_to_bits b)"
  by transfer (auto simp: cnv_OR_bl_conv)

lemma bits_XOR[simp]: "width a = width b \<Longrightarrow> lint_to_bits (a XOR b) = map2 (\<noteq>) (lint_to_bits a) (lint_to_bits b)"
  by transfer (auto simp: cnv_XOR_bl_conv)

lift_definition bitSHL :: "lint \<Rightarrow> nat \<Rightarrow> lint" is "\<lambda>bl n. cnv_uop1 (\<lambda>x. x*2^n) bl" by simp
lift_definition bitLSHR :: "lint \<Rightarrow> nat \<Rightarrow> lint" is "\<lambda>bl n. cnv_uop1 (\<lambda>x. x div 2^n) bl" by simp
lift_definition bitASHR :: "lint \<Rightarrow> nat \<Rightarrow> lint" is "\<lambda>bl n. cnv_sop1 (\<lambda>x. x div 2^n) bl" by simp

lemma width_bitSHL[simp]: "width (bitSHL a n) = width a"
  by transfer auto

lemma uint_bitSHL[simp]: "lint_to_uint (bitSHL a n) = bintrunc (width a) (2^n * lint_to_uint a)"
  by transfer (auto simp: algebra_simps)

lemma sint_bitSHL[simp]: "width a \<noteq> 0 \<Longrightarrow> lint_to_sint (bitSHL a n) = sbintrunc (width a - 1) (2^n * lint_to_sint a)"
  apply transfer
  apply (simp add: bl_to_sbin_def sbintrunc_mod2p bintrunc_mod2p)
  apply (pull_push_mods)
  apply (auto simp: algebra_simps)
  done

lemma width_bitLSHR[simp]: "width (bitLSHR a n) = width a"
  by transfer auto

lemma uint_bitLSHR[simp]: "lint_to_uint (bitLSHR a n) = lint_to_uint a div 2^n"
  apply transfer
  apply (auto
      simp: bintrunc_mod2p algebra_simps pos_imp_zdiv_nonneg_iff bl_to_bin_ge0
      intro!: mod_pos_pos_trivial)
  by (smt bl_to_bin_ge0 bl_to_bin_lt2p div_by_1 div_pos_pos_trivial int_div_less_self zero_less_power)

lemma width_bitASHR[simp]: "width (bitASHR a n) = width a"
  by transfer auto

lemma sint_bitASHR[simp]: "width a \<noteq> 0 \<Longrightarrow> lint_to_sint (bitASHR a n) = lint_to_sint a div 2^n"
  apply transfer
  using bl_to_sbin_in_sints
  apply (clarsimp simp: sbintrunc_eq_if_in_range sints_num)
  by (smt div_by_1 pos_imp_zdiv_nonneg_iff zdiv_mono2 zdiv_mono2_neg zero_less_power)

lemma uint_eq:
  "a = b \<longleftrightarrow> lint_to_uint a = lint_to_uint b \<and> width a = width b"
  apply (transfer)
  using bl_to_bin_inj
  by auto

lemma sint_eq:
  "a = b \<longleftrightarrow> lint_to_sint a = lint_to_sint b \<and> width a = width b"
  apply (transfer)
  apply auto
  by (metis bl_sbin_bl)

lemma lconst_inj: "lconst w a = lconst w b \<longleftrightarrow> a mod 2^w = b mod 2^w" by auto

subsection \<open>\<open>i1\<close> as Boolean\<close>

definition "ltrue \<equiv> lconst 1 1"
definition "lfalse \<equiv> lconst 1 0"
definition "bool_to_lint b \<equiv> if b then ltrue else lfalse"
definition "lint_to_bool a \<equiv> if a = ltrue then True else if a = lfalse then False else lint_abort_bool ()"

lemma lbool_cases: "width a = 1 \<Longrightarrow> a=ltrue \<or> a=lfalse"
  unfolding ltrue_def lfalse_def
  apply transfer
  apply auto
  by (metis (full_types) BIT_special_simps(2) bin_bl_bin bin_to_bl_aux.Z bin_to_bl_def bin_to_bl_zero bintrunc.Suc bintrunc_n_0 bl_bin_bl zero_neq_one)

lemma lint_bool_simps[simp]:
  "width ltrue = 1"
  "width lfalse = 1"
  "lint_to_uint ltrue = 1"
  "lint_to_uint lfalse = 0"
  "lint_to_sint ltrue = -1"
  "lint_to_sint lfalse = 0"

  "width (bool_to_lint b) = 1"
  "width a = 1 \<Longrightarrow> lint_to_bool a \<longleftrightarrow> a = ltrue"
  "lint_to_bool (bool_to_lint b) = b"
  "width a = 1 \<Longrightarrow> bool_to_lint (lint_to_bool a) = a"
  using lbool_cases
  unfolding ltrue_def lfalse_def bool_to_lint_def lint_to_bool_def
  by (auto)

section \<open>Connection to Word Datatype\<close>

definition lint_to_word :: "lint \<Rightarrow> 'a::len0 word" where "lint_to_word \<equiv> word_of_int o lint_to_uint"
definition word_to_lint :: "'a::len0 word \<Rightarrow> lint" where "word_to_lint \<equiv> lconst (len_of TYPE('a)) o uint"

lemma lint_word_inv[simp]: "lint_to_word (word_to_lint w) = w"
  by (auto simp: word_to_lint_def lint_to_word_def)

lemma word_lint_inv[simp]: "LENGTH ('a::len0) = width i \<Longrightarrow> word_to_lint (lint_to_word i :: 'a word) = i"
  apply (auto simp: word_to_lint_def lint_to_word_def)
  by (metis uint_const uint_eq uint_lower_bound uint_upper_bound width_lconst word_of_int_inverse word_ubin.norm_Rep)

lemma bin_to_bl_eq_iff: "bin_to_bl w x = bin_to_bl w y \<longleftrightarrow> bintrunc w x = bintrunc w y"
  by (metis bin_bl_bin bl_bin_bl size_bin_to_bl)

named_theorems word_to_lint_convs

lemma word_to_lint_plus[word_to_lint_convs]: "word_to_lint (a+b) = word_to_lint a + word_to_lint b"
  apply (auto simp: word_to_lint_def lint_to_word_def)
  apply transfer
  apply (auto simp: cnv_uop2_def bin_to_bl_eq_iff bintrunc_mod2p mod_add_eq)
  done

lemma word_to_lint_minus[word_to_lint_convs]: "word_to_lint (a-b) = word_to_lint a - word_to_lint b"
  apply (auto simp: word_to_lint_def lint_to_word_def)
  apply transfer
  apply (auto simp: cnv_uop2_def bin_to_bl_eq_iff bintrunc_mod2p mod_diff_eq)
  done

lemma word_to_lint_mult[word_to_lint_convs]: "word_to_lint (a*b) = word_to_lint a * word_to_lint b"
  apply (auto simp: word_to_lint_def lint_to_word_def)
  apply transfer
  apply (auto simp: cnv_uop2_def bin_to_bl_eq_iff bintrunc_mod2p mod_mult_eq)
  done

lemma word_to_lint_eq[word_to_lint_convs]: "word_to_lint a = word_to_lint b \<longleftrightarrow> a=b"
  by (auto simp: word_to_lint_def word_uint.Rep_inject)

lemma word_to_lint_ule[word_to_lint_convs]: "word_to_lint a \<le> word_to_lint b \<longleftrightarrow> a\<le>b"
  by (auto simp: word_to_lint_def lint_to_word_def word_le_def)

lemma word_to_lint_ult[word_to_lint_convs]: "word_to_lint a < word_to_lint b \<longleftrightarrow> a<b"
  by (auto simp: word_to_lint_def lint_to_word_def word_less_def)

lemma word_to_lint_sle[word_to_lint_convs]: "word_to_lint a \<le>\<^sub>s word_to_lint b \<longleftrightarrow> a <=s b"
  by (auto simp: word_to_lint_def lint_to_word_def word_sle_def sint_uint)

lemma word_to_lint_slt[word_to_lint_convs]: "word_to_lint a <\<^sub>s word_to_lint b \<longleftrightarrow> a <s b"
  by (auto simp: word_to_lint_def lint_to_word_def word_sless_alt sint_uint)

lemma word_to_lint_div[word_to_lint_convs]: "word_to_lint (a div b) = word_to_lint a div word_to_lint b"
  apply (auto simp: word_to_lint_def lint_to_word_def)
  apply transfer'
  apply (auto simp: cnv_uop2_def bin_to_bl_eq_iff bintrunc_mod2p uint_div_alt)
  done

lemma word_to_lint_mod[word_to_lint_convs]: "word_to_lint (a mod b) = word_to_lint a mod word_to_lint b"
  apply (auto simp: word_to_lint_def lint_to_word_def)
  apply transfer'
  apply (auto simp: cnv_uop2_def bin_to_bl_eq_iff bintrunc_mod2p uint_mod_alt)
  done

lemma word_to_lint_sdiv[word_to_lint_convs]:
  fixes a b :: "'a::len word"
  assumes "sint a sdiv sint b \<in> sints LENGTH('a)"
  shows "word_to_lint (a sdiv b) = word_to_lint a sdiv word_to_lint b"
  using assms
  apply (auto simp: word_to_lint_def lint_to_word_def sints_def)
  apply transfer'
  by (metis (mono_tags, hide_lams) One_nat_def bl_sbin_bl bl_to_sbin_in_sints cnv_sop2_def
      len_gt_0 sbin_bl_bin sdiv_word_def sint_sbintrunc' sint_uint size_bin_to_bl)

lemma word_to_lint_smod[word_to_lint_convs]:
  fixes a b :: "'a::len word"
  assumes "sint a sdiv sint b \<in> sints LENGTH('a)"
  shows "word_to_lint (a smod b) = word_to_lint a smod word_to_lint b"
  using assms
  apply (auto simp: word_to_lint_def lint_to_word_def sints_def)
  apply transfer'
  by (metis (mono_tags) One_nat_def bl_to_sbin_in_sints cnv_sop2_def len_gt_0 sbin_bl_bin sint_uint size_bin_to_bl smod_word_def to_bl_of_bin word_uint.Rep_inverse)

lemma word_to_lint_shl[word_to_lint_convs]: "word_to_lint ((a::_::len word) << n) = bitSHL (word_to_lint a) n"
  apply (auto simp: word_to_lint_def)
  apply transfer'
  apply (auto simp: cnv_uop1_def bin_to_bl_eq_iff bintrunc_mod2p shiftl_t2n uint_word_ariths algebra_simps)
  by (metis mod_mult_cong uint_mod_same word_numeral_alt word_of_int_power_hom word_uint.eq_norm)

lemma word_to_lint_lshr[word_to_lint_convs]: "word_to_lint ((a::_::len word) >> n) = bitLSHR (word_to_lint a) n"
  apply (auto simp: word_to_lint_def)
  apply transfer'
  apply (auto simp: cnv_uop1_def bin_to_bl_eq_iff bintrunc_mod2p uint_word_ariths shiftr_div_2n algebra_simps)
  done

lemma word_to_lint_ashr[word_to_lint_convs]: "word_to_lint (a >>> n) = bitASHR (word_to_lint (a::'a::len word)) n"
  unfolding word_to_lint_def
  apply transfer'
  by (auto simp: cnv_sop1_def uint_sint sshiftr_div_2n)

lemma word_to_lint_ucast_down[word_to_lint_convs]: "is_down UCAST('a \<rightarrow> 'b) \<Longrightarrow> word_to_lint (UCAST('a::len\<rightarrow>'b::len) a) = trunc (LENGTH('b)) (word_to_lint a)"
  unfolding word_to_lint_def
  apply transfer'
  apply (auto simp: cast_simps to_bl_ucast simp flip: to_bl_bin)
  by (metis bl_bin_bl bl_trunc_def diff_diff_cancel length_drop word_bl_Rep')

lemma word_to_lint_scast_down[word_to_lint_convs]: "is_down SCAST('a \<rightarrow> 'b) \<Longrightarrow> word_to_lint (SCAST('a::len\<rightarrow>'b::len) a) = trunc (LENGTH('b)) (word_to_lint a)"
  unfolding word_to_lint_def
  apply transfer'
  apply (auto simp: cast_simps to_bl_scast_down simp flip: to_bl_bin)
  by (metis bl_bin_bl bl_trunc_def diff_diff_cancel length_drop word_bl_Rep')

(* TODO: Move *)
lemma zext_in_range: "\<lbrakk>w'\<noteq>0; w'\<le>w; 0\<le>a; a<2^w'\<rbrakk> \<Longrightarrow> zext w (lconst w' a) = lconst w a"
  apply transfer'
  apply (auto simp: bl_zext_def)
  by (metis bin_bl_bin bintrunc_mod2p bl_bin_bl_rep_drop diff_is_0_eq' diff_zero drop_bin2bl len_bin_to_bl mod_pos_pos_trivial)

lemma word_to_lint_ucast_up[word_to_lint_convs]:
  "is_up UCAST('a::len\<rightarrow>'b::len) \<Longrightarrow> word_to_lint (UCAST('a\<rightarrow>'b) a) = zext LENGTH ('b) (word_to_lint a)"
  unfolding word_to_lint_def
  by (simp add: zext_in_range is_up cast_simps)

lemma word_to_lint_scast_up[word_to_lint_convs]:
  "is_up SCAST('a::len\<rightarrow>'b::len) \<Longrightarrow> word_to_lint (SCAST('a\<rightarrow>'b) a) = sext LENGTH ('b) (word_to_lint a)"
  unfolding word_to_lint_def
  apply (simp add: is_up sint_eq uint_sint max_def)
  by (simp add: is_up sint_up_scast)

lemma word_to_lint_and_simp[word_to_lint_convs]: "word_to_lint (a AND b) = word_to_lint a AND word_to_lint b"
  apply (auto simp: uint_eq word_to_lint_def)
  apply (simp add: uint_and)
  done

lemma word_to_lint_or_simp[word_to_lint_convs]: "word_to_lint (a OR b) = word_to_lint a OR word_to_lint b"
  apply (auto simp: uint_eq word_to_lint_def)
  apply (simp add: uint_or)
  done

lemma word_to_lint_xor_simp[word_to_lint_convs]: "word_to_lint (a XOR b) = word_to_lint a XOR word_to_lint b"
  apply (auto simp: uint_eq word_to_lint_def)
  apply (simp add: uint_xor)
  done

(* TODO: Quite arbitrary lemmas! Sort them! *)

lemma from_bool_lint_conv: "(from_bool b :: 1 word) = lint_to_word (bool_to_lint b)"
  apply (cases b)
  apply (auto simp: from_bool_def bool_to_lint_def ltrue_def lfalse_def lint_to_word_def)
  done

lemma word_to_lint_to_uint_conv: "lint_to_uint (word_to_lint a) = uint a"
  by (auto simp: word_to_lint_def)

lemma word_to_lint_to_sint_conv: "lint_to_sint (word_to_lint a) = sint a"
  by (auto simp: word_to_lint_def sint_uint)

lemma word_to_lint_to_uint_0_iff: "(lint_to_uint (word_to_lint b) = 0) = (b = 0)"
  by (clarsimp simp: word_to_lint_to_uint_conv uint_0_iff)

lemma word_to_lint_to_sint_0_iff: "(lint_to_sint (word_to_lint (b::_::len word)) = 0) = (b = 0)"
  by (auto simp: word_to_lint_to_sint_conv)

lemma width_word_to_lint[simp]: "width (word_to_lint (w::'a::len0 word)) = LENGTH ('a)"
  by (auto simp: word_to_lint_def)

definition is_up' :: "('a::len0 word \<Rightarrow> 'b::len0 word) \<Rightarrow> bool"
  where "is_up' c \<longleftrightarrow> source_size c < target_size c"

definition is_down' :: "('a::len0 word \<Rightarrow> 'b::len0 word) \<Rightarrow> bool"
  where "is_down' c \<longleftrightarrow> target_size c < source_size c"

lemma is_down': "is_down' c \<longleftrightarrow> len_of TYPE('b) < len_of TYPE('a)"
  for c :: "'a::len0 word \<Rightarrow> 'b::len0 word"
  by (simp only: is_down'_def source_size target_size)

lemma is_up': "is_up' c \<longleftrightarrow> len_of TYPE('a) < len_of TYPE('b)"
  for c :: "'a::len0 word \<Rightarrow> 'b::len0 word"
  by (simp only: is_up'_def source_size target_size)

lemmas is_down'_imp[simp, intro] = is_down'[THEN iffD1]
lemmas is_up'_imp[simp, intro] = is_up'[THEN iffD1]

lemma is_down'_imp_down[simp, intro]: "is_down' c \<Longrightarrow> is_down c" by (auto simp: is_down is_down')
lemma is_up'_imp_up[simp, intro]: "is_up' c \<Longrightarrow> is_up c" by (auto simp: is_up is_up')

end


(*  Title:      ZF/Induct/Term.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Terms over an alphabet\<close>

theory Term imports ZF begin

text \<open>
  Illustrates the list functor (essentially the same type as in \<open>Trees_Forest\<close>).
\<close>

consts
  "term" :: "i \<Rightarrow> i"

datatype "term(A)" = Apply ("a \<in> A", "l \<in> list(term(A))")
  monos list_mono
  type_elims list_univ [THEN subsetD, elim_format]

declare Apply [TC]

definition
  term_rec :: "[i, [i, i, i] \<Rightarrow> i] \<Rightarrow> i"  where
  "term_rec(t,d) \<equiv>
    Vrec(t, \<lambda>t g. term_case(\<lambda>x zs. d(x, zs, map(\<lambda>z. g`z, zs)), t))"

definition
  term_map :: "[i \<Rightarrow> i, i] \<Rightarrow> i"  where
  "term_map(f,t) \<equiv> term_rec(t, \<lambda>x zs rs. Apply(f(x), rs))"

definition
  term_size :: "i \<Rightarrow> i"  where
  "term_size(t) \<equiv> term_rec(t, \<lambda>x zs rs. succ(list_add(rs)))"

definition
  reflect :: "i \<Rightarrow> i"  where
  "reflect(t) \<equiv> term_rec(t, \<lambda>x zs rs. Apply(x, rev(rs)))"

definition
  preorder :: "i \<Rightarrow> i"  where
  "preorder(t) \<equiv> term_rec(t, \<lambda>x zs rs. Cons(x, flat(rs)))"

definition
  postorder :: "i \<Rightarrow> i"  where
  "postorder(t) \<equiv> term_rec(t, \<lambda>x zs rs. flat(rs) @ [x])"

lemma term_unfold: "term(A) = A * list(term(A))"
  by (fast intro!: term.intros [unfolded term.con_defs]
    elim: term.cases [unfolded term.con_defs])

lemma term_induct2:
  "\<lbrakk>t \<in> term(A);
      \<And>x.      \<lbrakk>x \<in> A\<rbrakk> \<Longrightarrow> P(Apply(x,Nil));
      \<And>x z zs. \<lbrakk>x \<in> A;  z \<in> term(A);  zs: list(term(A));  P(Apply(x,zs))
\<rbrakk> \<Longrightarrow> P(Apply(x, Cons(z,zs)))
\<rbrakk> \<Longrightarrow> P(t)"
  \<comment> \<open>Induction on \<^term>\<open>term(A)\<close> followed by induction on \<^term>\<open>list\<close>.\<close>
  apply (induct_tac t)
  apply (erule list.induct)
   apply (auto dest: list_CollectD)
  done

lemma term_induct_eqn [consumes 1, case_names Apply]:
  "\<lbrakk>t \<in> term(A);
      \<And>x zs. \<lbrakk>x \<in> A;  zs: list(term(A));  map(f,zs) = map(g,zs)\<rbrakk> \<Longrightarrow>
              f(Apply(x,zs)) = g(Apply(x,zs))
\<rbrakk> \<Longrightarrow> f(t) = g(t)"
  \<comment> \<open>Induction on \<^term>\<open>term(A)\<close> to prove an equation.\<close>
  apply (induct_tac t)
  apply (auto dest: map_list_Collect list_CollectD)
  done

text \<open>
  \medskip Lemmas to justify using \<^term>\<open>term\<close> in other recursive
  type definitions.
\<close>

lemma term_mono: "A \<subseteq> B \<Longrightarrow> term(A) \<subseteq> term(B)"
    unfolding term.defs
  apply (rule lfp_mono)
    apply (rule term.bnd_mono)+
  apply (rule univ_mono basic_monos| assumption)+
  done

lemma term_univ: "term(univ(A)) \<subseteq> univ(A)"
  \<comment> \<open>Easily provable by induction also\<close>
    unfolding term.defs term.con_defs
  apply (rule lfp_lowerbound)
   apply (rule_tac [2] A_subset_univ [THEN univ_mono])
  apply safe
  apply (assumption | rule Pair_in_univ list_univ [THEN subsetD])+
  done

lemma term_subset_univ: "A \<subseteq> univ(B) \<Longrightarrow> term(A) \<subseteq> univ(B)"
  apply (rule subset_trans)
   apply (erule term_mono)
  apply (rule term_univ)
  done

lemma term_into_univ: "\<lbrakk>t \<in> term(A);  A \<subseteq> univ(B)\<rbrakk> \<Longrightarrow> t \<in> univ(B)"
  by (rule term_subset_univ [THEN subsetD])

text \<open>
  \medskip \<open>term_rec\<close> -- by \<open>Vset\<close> recursion.
\<close>

lemma map_lemma: "\<lbrakk>l \<in> list(A);  Ord(i);  rank(l)<i\<rbrakk>
    \<Longrightarrow> map(\<lambda>z. (\<lambda>x \<in> Vset(i).h(x)) ` z, l) = map(h,l)"
  \<comment> \<open>\<^term>\<open>map\<close> works correctly on the underlying list of terms.\<close>
  apply (induct set: list)
   apply simp
  apply (subgoal_tac "rank (a) <i \<and> rank (l) < i")
   apply (simp add: rank_of_Ord)
  apply (simp add: list.con_defs)
  apply (blast dest: rank_rls [THEN lt_trans])
  done

lemma term_rec [simp]: "ts \<in> list(A) \<Longrightarrow>
  term_rec(Apply(a,ts), d) = d(a, ts, map (\<lambda>z. term_rec(z,d), ts))"
  \<comment> \<open>Typing premise is necessary to invoke \<open>map_lemma\<close>.\<close>
  apply (rule term_rec_def [THEN def_Vrec, THEN trans])
    unfolding term.con_defs
  apply (simp add: rank_pair2 map_lemma)
  done

lemma term_rec_type:
  assumes t: "t \<in> term(A)"
    and a: "\<And>x zs r. \<lbrakk>x \<in> A;  zs: list(term(A));
                   r \<in> list(\<Union>t \<in> term(A). C(t))\<rbrakk>
                \<Longrightarrow> d(x, zs, r): C(Apply(x,zs))"
  shows "term_rec(t,d) \<in> C(t)"
  \<comment> \<open>Slightly odd typing condition on \<open>r\<close> in the second premise!\<close>
  using t
  apply induct
  apply (frule list_CollectD)
  apply (subst term_rec)
   apply (assumption | rule a)+
  apply (erule list.induct)
   apply auto
  done

lemma def_term_rec:
  "\<lbrakk>\<And>t. j(t)\<equiv>term_rec(t,d);  ts: list(A)\<rbrakk> \<Longrightarrow>
    j(Apply(a,ts)) = d(a, ts, map(\<lambda>Z. j(Z), ts))"
  apply (simp only:)
  apply (erule term_rec)
  done

lemma term_rec_simple_type [TC]:
  "\<lbrakk>t \<in> term(A);
      \<And>x zs r. \<lbrakk>x \<in> A;  zs: list(term(A));  r \<in> list(C)\<rbrakk>
                \<Longrightarrow> d(x, zs, r): C
\<rbrakk> \<Longrightarrow> term_rec(t,d) \<in> C"
  apply (erule term_rec_type)
  apply (drule subset_refl [THEN UN_least, THEN list_mono, THEN subsetD])
  apply simp
  done

text \<open>
  \medskip \<^term>\<open>term_map\<close>.
\<close>

lemma term_map [simp]:
  "ts \<in> list(A) \<Longrightarrow>
    term_map(f, Apply(a, ts)) = Apply(f(a), map(term_map(f), ts))"
  by (rule term_map_def [THEN def_term_rec])

lemma term_map_type [TC]:
    "\<lbrakk>t \<in> term(A);  \<And>x. x \<in> A \<Longrightarrow> f(x): B\<rbrakk> \<Longrightarrow> term_map(f,t) \<in> term(B)"
    unfolding term_map_def
  apply (erule term_rec_simple_type)
  apply fast
  done

lemma term_map_type2 [TC]:
    "t \<in> term(A) \<Longrightarrow> term_map(f,t) \<in> term({f(u). u \<in> A})"
  apply (erule term_map_type)
  apply (erule RepFunI)
  done

text \<open>
  \medskip \<^term>\<open>term_size\<close>.
\<close>

lemma term_size [simp]:
    "ts \<in> list(A) \<Longrightarrow> term_size(Apply(a, ts)) = succ(list_add(map(term_size, ts)))"
  by (rule term_size_def [THEN def_term_rec])

lemma term_size_type [TC]: "t \<in> term(A) \<Longrightarrow> term_size(t) \<in> nat"
  by (auto simp add: term_size_def)

text \<open>
  \medskip \<open>reflect\<close>.
\<close>

lemma reflect [simp]:
    "ts \<in> list(A) \<Longrightarrow> reflect(Apply(a, ts)) = Apply(a, rev(map(reflect, ts)))"
  by (rule reflect_def [THEN def_term_rec])

lemma reflect_type [TC]: "t \<in> term(A) \<Longrightarrow> reflect(t) \<in> term(A)"
  by (auto simp add: reflect_def)

text \<open>
  \medskip \<open>preorder\<close>.
\<close>

lemma preorder [simp]:
    "ts \<in> list(A) \<Longrightarrow> preorder(Apply(a, ts)) = Cons(a, flat(map(preorder, ts)))"
  by (rule preorder_def [THEN def_term_rec])

lemma preorder_type [TC]: "t \<in> term(A) \<Longrightarrow> preorder(t) \<in> list(A)"
  by (simp add: preorder_def)

text \<open>
  \medskip \<open>postorder\<close>.
\<close>

lemma postorder [simp]:
    "ts \<in> list(A) \<Longrightarrow> postorder(Apply(a, ts)) = flat(map(postorder, ts)) @ [a]"
  by (rule postorder_def [THEN def_term_rec])

lemma postorder_type [TC]: "t \<in> term(A) \<Longrightarrow> postorder(t) \<in> list(A)"
  by (simp add: postorder_def)

text \<open>
  \medskip Theorems about \<open>term_map\<close>.
\<close>

declare map_compose [simp]

lemma term_map_ident: "t \<in> term(A) \<Longrightarrow> term_map(\<lambda>u. u, t) = t"
  by (induct rule: term_induct_eqn) simp

lemma term_map_compose:
    "t \<in> term(A) \<Longrightarrow> term_map(f, term_map(g,t)) = term_map(\<lambda>u. f(g(u)), t)"
  by (induct rule: term_induct_eqn) simp

lemma term_map_reflect:
    "t \<in> term(A) \<Longrightarrow> term_map(f, reflect(t)) = reflect(term_map(f,t))"
  by (induct rule: term_induct_eqn) (simp add: rev_map_distrib [symmetric])

text \<open>
  \medskip Theorems about \<open>term_size\<close>.
\<close>

lemma term_size_term_map: "t \<in> term(A) \<Longrightarrow> term_size(term_map(f,t)) = term_size(t)"
  by (induct rule: term_induct_eqn) simp

lemma term_size_reflect: "t \<in> term(A) \<Longrightarrow> term_size(reflect(t)) = term_size(t)"
  by (induct rule: term_induct_eqn) (simp add: rev_map_distrib [symmetric] list_add_rev)

lemma term_size_length: "t \<in> term(A) \<Longrightarrow> term_size(t) = length(preorder(t))"
  by (induct rule: term_induct_eqn) (simp add: length_flat)

text \<open>
  \medskip Theorems about \<open>reflect\<close>.
\<close>

lemma reflect_reflect_ident: "t \<in> term(A) \<Longrightarrow> reflect(reflect(t)) = t"
  by (induct rule: term_induct_eqn) (simp add: rev_map_distrib)

text \<open>
  \medskip Theorems about preorder.
\<close>

lemma preorder_term_map:
    "t \<in> term(A) \<Longrightarrow> preorder(term_map(f,t)) = map(f, preorder(t))"
  by (induct rule: term_induct_eqn) (simp add: map_flat)

lemma preorder_reflect_eq_rev_postorder:
    "t \<in> term(A) \<Longrightarrow> preorder(reflect(t)) = rev(postorder(t))"
  by (induct rule: term_induct_eqn)
    (simp add: rev_app_distrib rev_flat rev_map_distrib [symmetric])

end


theory More_Jordan_Normal_Forms
  imports
    Jordan_Normal_Form.Matrix_Impl
begin

lemma in_second_append_list: "i\<ge> length a \<Longrightarrow> i < length (a@b) \<Longrightarrow> (a@b)!i \<in> set b"
  by (metis diff_add_inverse diff_less_mono in_set_conv_nth leD length_append nth_append)

section \<open> General Theorems used later, that could be moved \<close>

lemma split_four_block_dual_fst_lst:
  assumes "split_block (four_block_mat A B C D) (dim_row A) (dim_col A) = (U, X, Y, V)"
  shows "U = A" "V = D"
proof -
  define nr where nr: "nr = dim_row (four_block_mat A B C D)"
  define nc where nc: "nc = dim_col (four_block_mat A B C D)"
  define nr2 where nr2: "nr2 = nr - dim_row A"
  define nc2 where nc2: "nc2 = nc - dim_col A"
  define A1 where A1: "A1 = mat (dim_row A) (dim_col A) (($$) (four_block_mat A B C D))"
  define A2 where A2: "A2 = mat (dim_row A) nc2 (\<lambda>(i, j). (four_block_mat A B C D) $$ (i, j + dim_col A))"
  define A3 where A3: "A3 = mat nr2 (dim_col A) (\<lambda>(i, j). (four_block_mat A B C D) $$ (i + dim_row A, j))"
  define A4 where A4: "A4 = mat nr2 nc2 (\<lambda>(i, j). (four_block_mat A B C D) $$ (i + dim_row A, j + dim_col A))"
  have g: "split_block (four_block_mat A B C D) (dim_row A) (dim_col A) = (A1, A2, A3, A4)"
    using split_block_def[of "(four_block_mat A B C D)" "(dim_row A)" "(dim_col A)"]
    by (metis A1 A2 A3 A4 nc nc2 nr nr2)
  have D: "D = A4"
    using A4 by (auto) (standard, (simp add:  nr nr2 nc nc2)+)
  have "A = A1"
    using A1 by auto
  then have "split_block (four_block_mat A B C D) (dim_row A) (dim_col A) = (A, A2, A3, D)"
    using D g by blast
  also show "U = A"
    using assms calculation by auto
  ultimately show "V = D"
    using assms by auto
qed

lemma append_split_vec_distrib_scalar_prod:
  assumes "dim_vec (u @\<^sub>v w) = dim_vec x"
  shows "(u @\<^sub>v w) \<bullet> x = u \<bullet> (vec_first x (dim_vec u)) + w \<bullet> (vec_last x (dim_vec w))"
proof -
  have "(u @\<^sub>v w) \<bullet> (vec_first x (dim_vec u) @\<^sub>v vec_last x (dim_vec w)) =
              u \<bullet> vec_first x (dim_vec u) + w \<bullet> vec_last x (dim_vec w)"
    by (meson carrier_vec_dim_vec scalar_prod_append vec_first_carrier vec_last_carrier)
  then show ?thesis
    by (metis assms carrier_vec_dim_vec index_append_vec(2) vec_first_last_append)
qed

lemma append_dot_product_split:
  assumes "dim_vec (u @\<^sub>v w) = dim_vec x"
  shows "(u @\<^sub>v w) \<bullet> x = (\<Sum>i\<in>{0..< dim_vec u}. u$i * x$i) + (\<Sum>i\<in>{0..< dim_vec w}. w$i * x$(i + dim_vec u))"
proof -
  define ix where "ix = vec_first x (dim_vec u)"
  define lx where lx: "lx = vec_last x (dim_vec w)"
  have *: "(u @\<^sub>v w) \<bullet> x = u \<bullet> ix + w \<bullet> lx"
    using append_split_vec_distrib_scalar_prod ix_def lx assms by blast
  have "(u @\<^sub>v w) \<bullet> x = (\<Sum> i \<in> {0 ..< dim_vec x}. (u @\<^sub>v w) $ i * x $ i)"
    using scalar_prod_def[of "(u @\<^sub>v w)" x] by simp
  also have "... = (\<Sum> i \<in> {0 ..< dim_vec u}. (u @\<^sub>v w) $ i * x $ i) +
                   (\<Sum> i \<in> {dim_vec u ..< dim_vec (u @\<^sub>v w)}. (u @\<^sub>v w) $ i * x $ i)"
    using assms sum.atLeastLessThan_concat[of "0" "dim_vec u" "dim_vec (u @\<^sub>v w)"
        "(\<lambda>i. (u @\<^sub>v w) $ i * x $ i)", OF le0[of "dim_vec u"]]
      le_add1[of  "dim_vec u" "dim_vec w"] index_append_vec(2)[of u w] by simp
  also have *: "... =(\<Sum>i\<in>{0..<dim_vec u}. u$i * x$i) + w \<bullet> lx"
    using * calculation by (auto simp: ix_def scalar_prod_def vec_first_def)
  have "w \<bullet> lx = (\<Sum>i\<in>{0..< dim_vec w}. w$i * x$(i + dim_vec u))" unfolding lx vec_last_def
    unfolding scalar_prod_def using add_diff_cancel_right' index_append_vec(2)[of u w] by (auto)
      (metis \<open>dim_vec (u @\<^sub>v w) = dim_vec u + dim_vec w\<close> add.commute add_diff_cancel_right' assms)
  then show ?thesis
    using * calculation by auto
qed

section \<open> Vectors \<close>

abbreviation singletonV ("[_]\<^sub>v" ) where "singletonV e \<equiv> (vec 1 (\<lambda>i. e))"

lemma elem_in_singleton [simp]: "[a]\<^sub>v $ 0 = a"
  by simp

lemma elem_in_singleton_append [simp]: "(x @\<^sub>v [a]\<^sub>v) $ dim_vec x = a"
  by simp

lemma vector_cases_append:
  fixes x :: "'a vec"
  shows "x = vNil \<or> (\<exists>v a. x = v @\<^sub>v [a]\<^sub>v)"
proof -
  have "x \<noteq> vNil \<Longrightarrow> (\<exists>v a. x = v @\<^sub>v [a]\<^sub>v)"
  proof (rule ccontr)
    assume a1: "x \<noteq> vNil"
    assume na: "\<not> (\<exists>v a. x = v @\<^sub>v [a]\<^sub>v)"
    have "dim_vec x \<ge> 1"
      using a1 eq_vecI by auto
    define v where v: "v = vec (dim_vec x - 1) (\<lambda>i. x $ i)"
    have v': "\<forall>i < dim_vec v. v $ i = x $ i"
      using v by auto
    define a where a: "a = x $ (dim_vec x - 1)"
    have a': "[a]\<^sub>v $ 0 = a" by simp
    have ff1: "1 + dim_vec v = dim_vec x"
      by (metis (no_types) \<open>1 \<le> dim_vec x\<close> add_diff_cancel_left' dim_vec le_Suc_ex v)
    have "\<forall>i < dim_vec x. x$i = (v @\<^sub>v [a]\<^sub>v)$i"
    proof (standard,standard)
      fix i :: nat
      assume as: "i < dim_vec x"
      have "x $ dim_vec v = a"
        by (simp add: a v)
      then have "x $ i = (v @\<^sub>v [a]\<^sub>v) $ i"
        using ff1 as by (metis (no_types) One_nat_def a' add.left_neutral
            add_Suc_right add_diff_cancel_left' add_diff_cancel_right'
            dim_vec index_append_vec(1) less_Suc_eq v')
      then show "x$i = (v @\<^sub>v [a]\<^sub>v)$i"
        by blast
    qed
    then have "x = v @\<^sub>v [a]\<^sub>v"
      using a a' v v'
      by (metis dim_vec eq_vecI ff1 index_append_vec(2) semiring_normalization_rules(24))
    then show False using na by auto
  qed
  then show ?thesis
    by blast
qed

lemma vec_rev_induct [case_names vNil append, induct type: vec]:
  assumes "P vNil" and "\<And>a v. P v \<Longrightarrow> P (v @\<^sub>v [a]\<^sub>v)"
  shows "P v"
proof (induction "dim_vec v" arbitrary: v)
  case 0
  then have "v = vNil"
    by auto
  then show ?case
    using assms(1) by auto
next
  case (Suc l)
  obtain xs x where xs_x: "v = xs @\<^sub>v [x]\<^sub>v"
    using vector_cases_append[of v] Suc.hyps(2) dim_vec by (auto)
  have "l = dim_vec xs"
    using Suc.hyps(2) xs_x by auto
  then have "P xs"
    using Suc.hyps(1)[of xs] by auto
  then have "P (xs @\<^sub>v [x]\<^sub>v)"
    using assms(2)[of xs x] by auto
  then show ?case
    by (simp add: xs_x)
qed

lemma singleton_append_dotP:
  assumes "dim_vec z = dim_vec y + 1"
  shows "(y @\<^sub>v [x]\<^sub>v) \<bullet> z = (\<Sum>i\<in>{0..<dim_vec y}. y $ i * z $ i) + x * z $ dim_vec y"
proof -
  have "(y @\<^sub>v [x]\<^sub>v) \<bullet> z = (\<Sum>i\<in>{0..<dim_vec z}. (y @\<^sub>v [x]\<^sub>v) $ i * z $ i)"
    unfolding scalar_prod_def by blast
  also have "... = (\<Sum>i\<in>{0..<dim_vec z-1}. (y @\<^sub>v [x]\<^sub>v) $ i * z $ i) +
                   (y @\<^sub>v [x]\<^sub>v)$(dim_vec z-1) * z$(dim_vec z-1)"
    by (simp add: assms)
  also have "... = (\<Sum>i\<in>{0..<dim_vec y}. (y @\<^sub>v [x]\<^sub>v) $ i * z $ i) +
                   (y @\<^sub>v [x]\<^sub>v)$(dim_vec y)* z$(dim_vec y)"
    using assms by auto
  also have "... = (\<Sum>i\<in>{0..<dim_vec y}. y $ i * z $ i) +
                   x * z$(dim_vec y)"
    by simp
  finally show ?thesis .
qed

lemma map_vec_append: "map_vec f (a @\<^sub>v b) = map_vec f a @\<^sub>v map_vec f b"
  by (induction a arbitrary: b) (auto)

lemma map_mat_map_vec:
  assumes "i < dim_row P"
  shows "row (map_mat f P) i = map_vec f (row P i)"
  using assms by auto

lemma append_rows_access1 [simp]:
  assumes "i < dim_row A"
  assumes "dim_col A = dim_col B"
  shows "row (A @\<^sub>r B) i = row A i"
proof
  show "dim_vec (Matrix.row (A @\<^sub>r B) i) = dim_vec (Matrix.row A i)"
    by (simp add: append_rows_def)
  fix ia
  assume "ia < dim_vec (row A i)"
  have "row (A @\<^sub>r B) i = (row A i @\<^sub>v row (0\<^sub>m (dim_row A) 0) i)"
    unfolding append_rows_def using
      carrier_mat_triv[of A] row_four_block_mat(1)[of A "dim_row A"
        _ "0\<^sub>m (dim_row A) 0" 0 B "dim_row B" "0\<^sub>m (dim_row B) 0" i, OF _ _ _ _ assms(1)]
    by (metis assms(2) carrier_mat_triv zero_carrier_mat)
  also have "... = row A i @\<^sub>v vNil"
    by (simp add: assms(1))
  also have "... = row A i"
    by auto
  finally show "row (A @\<^sub>r B) i $ ia = row A i $ ia"
    by auto
qed

lemma append_rows_access2 [simp]:
  assumes "i \<ge> dim_row A"
  assumes "i < dim_row A + dim_row B"
  assumes "dim_col A = dim_col B"
  shows "row (A @\<^sub>r B) i = row B (i - dim_row A)"
proof
  show "dim_vec (row (A @\<^sub>r B) i) = dim_vec (row B (i - dim_row A))"
    by (simp add: append_rows_def assms(3))
  fix ia
  assume "ia < dim_vec (row B (i - dim_row A))"
  have "row (A @\<^sub>r B) i = (row B (i - dim_row A) @\<^sub>v row (0\<^sub>m (dim_row B) 0) (i - dim_row A))"
    unfolding append_rows_def using carrier_mat_triv[of A] row_four_block_mat(2)[of A "dim_row A"
        _ "0\<^sub>m (dim_row A) 0" 0 B "dim_row B" "0\<^sub>m (dim_row B) 0" i, OF _ _ _ _ _ assms(2)]
    by (metis assms(1) assms(3) carrier_mat_triv le_antisym less_imp_le_nat nat_less_le zero_carrier_mat)
  also have "... = row B (i - dim_row A) @\<^sub>v vNil"
    by fastforce
  also have "... = row B (i - dim_row A)"
    by auto
  finally show "row (A @\<^sub>r B) i $ ia = row B (i - dim_row A) $ ia"
    by auto
qed

lemma append_singleton_access [simp]: "(Matrix.vec n f @\<^sub>v [r]\<^sub>v) $ n = r"
  by simp

text \<open> Move to right place \<close>

fun mat_append_col where
  "mat_append_col A b = mat_of_cols (dim_row A) (cols A @ [b])"

fun mat_append_row where
  "mat_append_row A c = mat_of_rows (dim_col A) (rows A @ [c])"

lemma mat_append_col_dims:
  shows "mat_append_col A b \<in> carrier_mat (dim_row A) (dim_col A + 1)"
  by auto

lemma mat_append_row_dims:
  shows "mat_append_row A c \<in> carrier_mat (dim_row A + 1) (dim_col A)"
  by auto

lemma mat_append_col_col:
  assumes "dim_row A = dim_vec b"
  shows "col (mat_append_col A b) (dim_col A) = b"
proof (standard)
  let ?nA = "(mat_of_cols (dim_row A) (cols A @ [b]))"
  show "dim_vec (col (mat_append_col A b) (dim_col A)) = dim_vec b"
    by (simp add: assms)
  fix i
  assume "i < dim_vec b"
  have "col (mat_append_col A b) (dim_col A) $ i = vec_index (vec (dim_row ?nA) (\<lambda> i. ?nA $$ (i, (dim_col A)))) i"
    by (simp add: col_def)
  also have "... = vec_index (vec (dim_row A) (\<lambda> i. ?nA $$ (i, (dim_col A)))) i"
    by auto
  also have "... = vec_index ((cols A @ [b]) ! dim_col A) i"
    by (simp add: \<open>i < dim_vec b\<close> assms mat_of_cols_index)
  also have "... = vec_index b i"
    by (metis cols_length nth_append_length)
  finally show "col (mat_append_col A b) (dim_col A) $ i = b $ i" .
qed

lemma mat_append_col_vec_index:
  assumes "i < dim_row A"
    and "dim_row A = dim_vec b"
  shows "(row (mat_append_col A b) i) $ (dim_col A) = b $ i"
  using mat_append_col_col
  by (metis (no_types, lifting) One_nat_def add_Suc_right assms(1) assms(2) carrier_matD(2)
      col_def dim_row_mat(1) index_row(1) index_vec lessI mat_append_col.simps
      mat_append_col_dims mat_of_cols_def semiring_norm(51))

lemma mat_append_row_row:
  assumes "dim_col A = dim_vec c"
  shows "row (mat_append_row A c) (dim_row A) = c"
proof
  let ?nA = "(mat_of_rows (dim_col A) (Matrix.rows A @ [c]))"
  show "dim_vec (Matrix.row (mat_append_row A c) (dim_row A)) = dim_vec c"
    using assms by simp
  fix i assume "i < dim_vec c"
  from mat_append_row.simps[of A c]
  have "row (mat_append_row A c) (dim_row A) $ i = vec_index (row ?nA (dim_row A)) i"
    by auto
  also have "... = vec_index (vec (dim_col ?nA) (\<lambda> j. ?nA $$ (dim_row A,j))) i"
    by (simp add: Matrix.row_def)
  also have "... =  vec_index ((rows A @ [c]) ! dim_row A) i"
    by (metis (mono_tags, lifting) \<open>mat_append_row A c = mat_of_rows (dim_col A) (Matrix.rows A @ [c])\<close>
        add_Suc_right append_Nil2 assms calculation carrier_matD(1) col_transpose cols_transpose
        index_transpose_mat(2) index_transpose_mat(3) length_append length_rows lessI list.size(3)
        mat_append_col.elims mat_append_col_col mat_append_row_dims nth_append_length
        transpose_mat_of_rows One_nat_def)
  also have "... = vec_index c i"
    by (metis length_rows nth_append_length)
  finally show "Matrix.row (mat_append_row A c) (dim_row A) $ i = c $ i" .
qed

lemma mat_append_row_in_mat:
  assumes "i < dim_row A"
  shows "row (mat_append_row A r) i = row A i"
  by (auto) (metis assms le_imp_less_Suc length_append_singleton
      length_rows mat_of_rows_row nat_less_le nth_append nth_rows row_carrier)

lemma mat_append_row_vec_index:
  assumes "i < dim_col A"
    and "dim_col A = dim_vec b"
  shows "vec_index (col (mat_append_row A b) i) (dim_row A) = vec_index b i"
  by (metis One_nat_def add.right_neutral add_Suc_right assms(1) assms(2) carrier_matD(1)
      carrier_matD(2) index_col index_row(1) lessI mat_append_row_dims mat_append_row_row)

lemma mat_append_col_access_in_mat:
  assumes "dim_row A = dim_vec b"
   and "i < dim_row A"
    and "j < dim_col A"
  shows "(row (mat_append_col A b) i) $ j = (row A i) $ j"
  using Matrix.row_transpose[of j A, OF assms(3)]
    Matrix.transpose_transpose[of "(mat_append_col A b)"] assms carrier_matD(1)
    carrier_matD(2) cols_length cols_transpose index_col index_row(1)[of i "mat_append_col A b" j] index_transpose_mat(2)
    mat_append_col.simps mat_append_col_dims
    mat_of_cols_carrier(3) mat_of_rows_row
    nth_append nth_rows row_carrier trans_less_add1 transpose_mat_of_cols
    mat_of_cols_index
  by (smt cols_nth index_row(1))

lemma constructing_append_col_row:
  assumes "i < dim_row A"
    and "dim_row A = dim_vec b"
  shows "row (mat_append_col A b) i = row A i @\<^sub>v [vec_index b i]\<^sub>v"
proof
  show 1: "dim_vec (Matrix.row (mat_append_col A b) i) = dim_vec (Matrix.row A i @\<^sub>v [b $ i]\<^sub>v)"
    by simp
  fix ia
  assume a: "ia < dim_vec (Matrix.row A i @\<^sub>v [b $ i]\<^sub>v)"
  consider "ia = dim_col A" | "ia < dim_col A"
     using a less_SucE by auto
  then show "row (mat_append_col A b) i $ ia = (Matrix.row A i @\<^sub>v [b $ i]\<^sub>v) $ ia "
  proof (cases)
    case 1
    then show ?thesis
      using mat_append_col_vec_index[of i A b, OF assms] by auto
  next
    case 2
    have "row (mat_append_col A b) i $ ia = (mat_append_col A b) $$ (i, ia)"
      using a assms(1) by auto
    then show ?thesis using mat_append_col_access_in_mat[of A b i ia, OF assms(2) assms(1) 2]
      using "2" by auto
  qed
qed

definition one_element_vec where "one_element_vec n e = vec n (\<lambda>i. e)"

lemma one_element_vec_carrier: "one_element_vec n e \<in> carrier_vec n"
  unfolding one_element_vec_def by auto

lemma one_element_vec_dim [simp]: "dim_vec (one_element_vec n (r::rat)) = n"
  by (simp add: one_element_vec_def)

lemma one_element_vec_access [simp]: "\<And>i. i < n \<Longrightarrow> vec_index (one_element_vec n e) i = e"
  unfolding one_element_vec_def by (auto)

fun single_nz_val where "single_nz_val n i v = vec n (\<lambda>j. (if i = j then v else 0))"

lemma single_nz_val_carrier: "single_nz_val n i v \<in> carrier_vec n"
   by auto

lemma single_nz_val_access1 [simp]: "i < n \<Longrightarrow> single_nz_val n i v $ i = v"
   by auto

lemma single_nz_val_access2 [simp]: "i < n \<Longrightarrow> j < n \<Longrightarrow> i \<noteq> j\<Longrightarrow> single_nz_val n i v $ j = 0"
   by (auto)

lemma "i < n \<Longrightarrow> (v \<cdot>\<^sub>v unit_vec n i) $ i = (v::'a::{monoid_mult,times,zero_neq_one})"
  by(auto)

lemma single_nz_val_unit_vec:
  fixes v::"'a::{monoid_mult,times,zero_neq_one,mult_zero}"
  shows "v \<cdot>\<^sub>v (unit_vec n i) = single_nz_val n i v"
proof
  show *: "dim_vec (v \<cdot>\<^sub>v unit_vec n i) = dim_vec (single_nz_val n i v)"
    by (simp)
  fix ia
  assume "ia < dim_vec (single_nz_val n i v)"
  then show "(v \<cdot>\<^sub>v unit_vec n i) $ ia = single_nz_val n i v $ ia"
    using * by (simp add: unit_vec_def)
qed

lemma single_nz_valI [intro]:
  fixes v i val
  assumes "\<And>j. j < dim_vec v \<Longrightarrow> j \<noteq> i \<Longrightarrow> v$j = 0"
  assumes "v$i = val"
  shows "v = single_nz_val (dim_vec v) i val"
  using assms(1) assms(2) by auto

lemma single_nz_val_dotP:
  assumes "i < n"
  assumes "dim_vec x = n"
  shows "single_nz_val n i v \<bullet> x = v * x $ i"
proof -
  let ?y = "single_nz_val n i v"
  have "single_nz_val n i v \<bullet> x = (\<Sum>i\<in>{0 ..< dim_vec x}. ?y $ i * x $ i)"
    unfolding scalar_prod_def by auto
  also have "... = (\<Sum>i\<in>{0 ..< dim_vec x}-{i}. ?y $ i * x $ i) + ?y $ i * x $ i"
    by (metis (no_types, lifting) add.commute assms(1) assms(2) atLeast0LessThan
        finite_atLeastLessThan lessThan_iff sum.remove)
  also have "... = (\<Sum>i\<in>{0 ..< dim_vec x}-{i}. ?y $ i * x $ i) + v * x $ i"
    by (simp add: assms(1))
  also have "... = v * x $ i"
  proof -
    have "\<And>j. j \<in> {0 ..< dim_vec x}-{i} \<Longrightarrow> ?y $ j * x $ j = 0"
      by (simp add: assms(2))
    then have "(\<Sum>i\<in>{0 ..< dim_vec x}-{i}. ?y $ i * x $ i) = 0" by auto
    then show ?thesis by auto
  qed
  finally show ?thesis .
qed

lemma single_nz_zero_singleton: "single_nz_val 1 0 v = [v]\<^sub>v"
  by (auto)

lemma append_one_elem_zero_dotP:
  assumes "dim_vec u = m"
    and "dim_vec x = n"
  shows "(one_element_vec n e @\<^sub>v (0\<^sub>v m)) \<bullet> (x @\<^sub>v u) = (\<Sum>i\<in>{0 ..< dim_vec x}. e * x $ i)"
proof -
  let ?OEV = "one_element_vec n e"
  have "dim_vec (?OEV @\<^sub>v (0\<^sub>v m)) = dim_vec (x @\<^sub>v u)"
    by (simp add: assms(1) assms(2) one_element_vec_carrier)
  have "(one_element_vec n e @\<^sub>v 0\<^sub>v m) \<bullet> (x @\<^sub>v u) = one_element_vec n e \<bullet> x + 0\<^sub>v m \<bullet> u"
    using scalar_prod_append[of ?OEV _ "0\<^sub>v m" _ x u] assms
    by (meson carrier_vec_dim_vec one_element_vec_carrier zero_carrier_vec)
  also have "... = (\<Sum>i\<in>{0..<dim_vec x}. ?OEV $ i * x $ i) + (\<Sum>i\<in>{0..<dim_vec u}. (0\<^sub>v m)$i * u$i)"
    unfolding scalar_prod_def by blast
  also have "... = (\<Sum>i\<in>{0..<dim_vec x}. ?OEV $ i * x $ i)"
    using assms(1) by auto
  also have "... = (\<Sum>i\<in>{0..<dim_vec x}. e * x $ i)"
    using assms(2) by auto
  finally show ?thesis .
qed

lemma one_element_vec_dotP:
  assumes "dim_vec x = n"
  shows "(one_element_vec n e) \<bullet> x = (\<Sum>i\<in>{0 ..< dim_vec x}. e * x $ i)"
  by (metis (no_types, lifting) assms one_element_vec_access scalar_prod_def sum.ivl_cong)

lemma singleton_dotP [simp]: "dim_vec x = 1 \<Longrightarrow> [v]\<^sub>v \<bullet> x = v * x$0"
  by (metis dim_vec index_vec less_one single_nz_valI single_nz_val_dotP)

lemma singletons_dotP [simp]: "[v]\<^sub>v \<bullet> [w]\<^sub>v = v * w"
  by (metis dim_vec index_vec less_one singleton_dotP)

lemma singleton_appends_dotP [simp]: "dim_vec x = dim_vec y \<Longrightarrow> (x @\<^sub>v [v]\<^sub>v) \<bullet> (y @\<^sub>v [w]\<^sub>v) = x \<bullet> y + v * w"
  using scalar_prod_append[of x "dim_vec x" "[v]\<^sub>v" 1 y "[w]\<^sub>v"]
  by (metis carrier_dim_vec singletons_dotP vec_carrier)

end


(*  Author:     Tobias Nipkow, 2007  *)

section\<open>Quantifier elimination\<close>

theory QE
imports Logic
begin

text\<open>\noindent
The generic, i.e.\ theory-independent part of quantifier elimination.
Both DNF and an NNF-based procedures are defined and proved correct.\<close>

notation (input) Collect ("|_|")

subsection\<open>No Equality\<close>

context ATOM
begin

subsubsection\<open>DNF-based\<close>

text\<open>\noindent Taking care of atoms independent of variable 0:\<close>

definition
"qelim qe as =
 (let qf = qe [a\<leftarrow>as. depends\<^sub>0 a];
      indep = [Atom(decr a). a\<leftarrow>as, \<not> depends\<^sub>0 a]
  in and qf (list_conj indep))"

abbreviation is_dnf_qe :: "('a list \<Rightarrow> 'a fm) \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_dnf_qe qe as \<equiv> \<forall>xs. I(qe as) xs = (\<exists>x.\<forall>a\<in>set as. I\<^sub>a a (x#xs))"

text\<open>\noindent
Note that the exported abbreviation will have as a first parameter
the type @{typ"'b"} of values \<open>xs\<close> ranges over.\<close>

lemma I_qelim:
assumes qe: "\<And>as. (\<forall>a \<in> set as. depends\<^sub>0 a) \<Longrightarrow> is_dnf_qe qe as"
shows "is_dnf_qe (qelim qe) as" (is "\<forall>xs. ?P xs")
proof
  fix  xs
  let ?as0 = "filter depends\<^sub>0 as"
  let ?as1 = "filter (Not \<circ> depends\<^sub>0) as"
  have "I (qelim qe as) xs =
        (I (qe ?as0) xs \<and> (\<forall>a\<in>set(map decr ?as1). I\<^sub>a a xs))"
    (is "_ = (_ \<and> ?B)") by(force simp add:qelim_def)
  also have "\<dots> = ((\<exists>x. \<forall>a \<in> set ?as0. I\<^sub>a a (x#xs)) \<and> ?B)"
    by(simp add:qe not_dep_decr)
  also have "\<dots> = (\<exists>x. (\<forall>a \<in> set ?as0. I\<^sub>a a (x#xs)) \<and> ?B)" by blast
  also have "?B = (\<forall>a \<in> set ?as1. I\<^sub>a (decr a) xs)" by simp
  also have "(\<exists>x. (\<forall>a \<in> set ?as0. I\<^sub>a a (x#xs)) \<and> \<dots>) =
             (\<exists>x. (\<forall>a \<in> set ?as0. I\<^sub>a a (x#xs)) \<and>
                  (\<forall>a \<in> set ?as1. I\<^sub>a a (x#xs)))"
    by(simp add: not_dep_decr)
  also have "\<dots> = (\<exists>x. \<forall>a \<in> set(?as0 @ ?as1). I\<^sub>a a (x#xs))"
    by (simp add:ball_Un)
  also have "\<dots> = (\<exists>x. \<forall>a \<in> set(as). I\<^sub>a a (x#xs))"
    by simp blast
  finally show "?P xs" .
qed

text\<open>\noindent The generic DNF-based quantifier elimination procedure:\<close>

fun lift_dnf_qe :: "('a list \<Rightarrow> 'a fm) \<Rightarrow> 'a fm \<Rightarrow> 'a fm" where
"lift_dnf_qe qe (And \<phi>\<^sub>1 \<phi>\<^sub>2) = and (lift_dnf_qe qe \<phi>\<^sub>1) (lift_dnf_qe qe \<phi>\<^sub>2)" |
"lift_dnf_qe qe (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = or (lift_dnf_qe qe \<phi>\<^sub>1) (lift_dnf_qe qe \<phi>\<^sub>2)" |
"lift_dnf_qe qe (Neg \<phi>) = neg(lift_dnf_qe qe \<phi>)" |
"lift_dnf_qe qe (ExQ \<phi>) = Disj (dnf(nnf(lift_dnf_qe qe \<phi>))) (qelim qe)" |
"lift_dnf_qe qe \<phi> = \<phi>"

lemma qfree_lift_dnf_qe: "(\<And>as. (\<forall>a\<in>set as. depends\<^sub>0 a) \<Longrightarrow> qfree(qe as))
 \<Longrightarrow> qfree(lift_dnf_qe qe \<phi>)"
by (induct \<phi>) (simp_all add:qelim_def)

lemma qfree_lift_dnf_qe2: "qe \<in> lists |depends\<^sub>0| \<rightarrow> |qfree|
 \<Longrightarrow> qfree(lift_dnf_qe qe \<phi>)"
using in_lists_conv_set[where ?'a = 'a]
by (simp add:Pi_def qfree_lift_dnf_qe)

lemma lem: "\<forall>P A. (\<exists>x\<in>A. \<exists>y. P x y) = (\<exists>y. \<exists>x\<in>A. P x y)" by blast

lemma I_lift_dnf_qe:
assumes  "\<And>as. (\<forall>a \<in> set as. depends\<^sub>0 a) \<Longrightarrow> qfree(qe as)"
and "\<And>as. (\<forall>a \<in> set as. depends\<^sub>0 a) \<Longrightarrow> is_dnf_qe qe as"
shows "I (lift_dnf_qe qe \<phi>) xs = I \<phi> xs"
proof(induct \<phi> arbitrary:xs)
  case ExQ thus ?case
    by (simp add: assms I_qelim lem I_dnf nqfree_nnf qfree_lift_dnf_qe
                  I_nnf)
qed simp_all

lemma I_lift_dnf_qe2:
assumes  "qe \<in> lists |depends\<^sub>0| \<rightarrow> |qfree|"
and "\<forall>as \<in> lists |depends\<^sub>0|. is_dnf_qe qe as"
shows "I (lift_dnf_qe qe \<phi>) xs = I \<phi> xs"
using assms in_lists_conv_set[where ?'a = 'a]
by(simp add:Pi_def I_lift_dnf_qe)

text\<open>\noindent Quantifier elimination with invariant (needed for Presburger):\<close>

lemma I_qelim_anormal:
assumes qe: "\<And>xs as. \<forall>a \<in> set as. depends\<^sub>0 a \<and> anormal a \<Longrightarrow> is_dnf_qe qe as"
and nm: "\<forall>a \<in> set as. anormal a"
shows "I (qelim qe as) xs = (\<exists>x. \<forall>a\<in>set as. I\<^sub>a a (x#xs))"
proof -
  let ?as0 = "filter depends\<^sub>0 as"
  let ?as1 = "filter (Not \<circ> depends\<^sub>0) as"
  have "I (qelim qe as) xs =
        (I (qe ?as0) xs \<and> (\<forall>a\<in>set(map decr ?as1). I\<^sub>a a xs))"
    (is "_ = (_ \<and> ?B)") by(force simp add:qelim_def)
  also have "\<dots> = ((\<exists>x. \<forall>a \<in> set ?as0. I\<^sub>a a (x#xs)) \<and> ?B)"
    by(simp add:qe nm not_dep_decr)
  also have "\<dots> = (\<exists>x. (\<forall>a \<in> set ?as0. I\<^sub>a a (x#xs)) \<and> ?B)" by blast
  also have "?B = (\<forall>a \<in> set ?as1. I\<^sub>a (decr a) xs)" by simp
  also have "(\<exists>x. (\<forall>a \<in> set ?as0. I\<^sub>a a (x#xs)) \<and> \<dots>) =
             (\<exists>x. (\<forall>a \<in> set ?as0. I\<^sub>a a (x#xs)) \<and>
                  (\<forall>a \<in> set ?as1. I\<^sub>a a (x#xs)))"
    by(simp add: not_dep_decr)
  also have "\<dots> = (\<exists>x. \<forall>a \<in> set(?as0 @ ?as1). I\<^sub>a a (x#xs))"
    by (simp add:ball_Un)
  also have "\<dots> = (\<exists>x. \<forall>a \<in> set(as). I\<^sub>a a (x#xs))"
    by simp blast
  finally show ?thesis .
qed

context notes [[simp_depth_limit = 5]]
begin

lemma anormal_atoms_qelim:
  "(\<And>as. \<forall>a \<in> set as. depends\<^sub>0 a \<and> anormal a \<Longrightarrow> normal(qe as)) \<Longrightarrow>
   \<forall>a \<in> set as. anormal a \<Longrightarrow> a \<in> atoms(qelim qe as) \<Longrightarrow> anormal a"
apply(auto simp add:qelim_def and_def normal_def split:if_split_asm)
apply(auto simp add:anormal_decr dest!: atoms_list_conjE)
 apply(erule_tac x = "filter depends\<^sub>0 as" in meta_allE)
 apply(simp)
apply(erule_tac x = "filter depends\<^sub>0 as" in meta_allE)
apply(simp)
done

lemma normal_lift_dnf_qe:
assumes "\<And>as. \<forall>a \<in> set as. depends\<^sub>0 a \<Longrightarrow> qfree(qe as)"
and "\<And>as. \<forall>a \<in> set as. depends\<^sub>0 a \<and> anormal a \<Longrightarrow> normal(qe as)"
shows  "normal \<phi> \<Longrightarrow> normal(lift_dnf_qe qe \<phi>)"
proof(simp add:normal_def, induct \<phi>)
  case ExQ thus ?case
    apply (auto dest!: atoms_list_disjE)
    apply(rule anormal_atoms_qelim)
      prefer 3 apply assumption
     apply(simp add:assms)
    apply (simp add:normal_def qfree_lift_dnf_qe anormal_dnf_nnf assms)
    done
qed (simp_all add:and_def or_def neg_def Ball_def)

end

context notes [[simp_depth_limit = 9]]
begin

lemma I_lift_dnf_qe_anormal:
assumes "\<And>as. \<forall>a \<in> set as. depends\<^sub>0 a \<Longrightarrow> qfree(qe as)"
and "\<And>as. \<forall>a \<in> set as. depends\<^sub>0 a \<and> anormal a \<Longrightarrow> normal(qe as)"
and "\<And>xs as. \<forall>a \<in> set as. depends\<^sub>0 a \<and> anormal a \<Longrightarrow> is_dnf_qe qe as"
shows "normal f \<Longrightarrow> I (lift_dnf_qe qe f) xs = I f xs"
proof(induct f arbitrary:xs)
  case ExQ thus ?case using normal_lift_dnf_qe[of qe]
    by (simp add: assms[simplified normal_def] anormal_dnf_nnf I_qelim_anormal lem I_dnf nqfree_nnf qfree_lift_dnf_qe I_nnf normal_def)
qed (simp_all add:normal_def)

end

lemma I_lift_dnf_qe_anormal2:
assumes "qe \<in> lists |depends\<^sub>0| \<rightarrow> |qfree|"
and "qe \<in> lists ( |depends\<^sub>0| \<inter> |anormal| ) \<rightarrow> |normal|"
and "\<forall>as \<in> lists( |depends\<^sub>0| \<inter> |anormal| ). is_dnf_qe qe as"
shows "normal f \<Longrightarrow> I (lift_dnf_qe qe f) xs = I f xs"
using assms in_lists_conv_set[where ?'a = 'a]
by(simp add:Pi_def I_lift_dnf_qe_anormal Int_def)

subsubsection\<open>NNF-based\<close>

fun lift_nnf_qe :: "('a fm \<Rightarrow> 'a fm) \<Rightarrow> 'a fm \<Rightarrow> 'a fm" where
"lift_nnf_qe qe (And \<phi>\<^sub>1 \<phi>\<^sub>2) = and (lift_nnf_qe qe \<phi>\<^sub>1) (lift_nnf_qe qe \<phi>\<^sub>2)" |
"lift_nnf_qe qe (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = or (lift_nnf_qe qe \<phi>\<^sub>1) (lift_nnf_qe qe \<phi>\<^sub>2)" |
"lift_nnf_qe qe (Neg \<phi>) = neg(lift_nnf_qe qe \<phi>)" |
"lift_nnf_qe qe (ExQ \<phi>) = qe(nnf(lift_nnf_qe qe \<phi>))" |
"lift_nnf_qe qe \<phi> = \<phi>"

lemma qfree_lift_nnf_qe: "(\<And>\<phi>. nqfree \<phi> \<Longrightarrow> qfree(qe \<phi>))
 \<Longrightarrow> qfree(lift_nnf_qe qe \<phi>)"
by (induct \<phi>) (simp_all add:nqfree_nnf)

lemma qfree_lift_nnf_qe2:
  "qe \<in> |nqfree| \<rightarrow> |qfree| \<Longrightarrow> qfree(lift_nnf_qe qe \<phi>)"
by(simp add:Pi_def qfree_lift_nnf_qe)

lemma I_lift_nnf_qe:
assumes  "\<And>\<phi>. nqfree \<phi> \<Longrightarrow> qfree(qe \<phi>)"
and "\<And>xs \<phi>. nqfree \<phi> \<Longrightarrow> I (qe \<phi>) xs = (\<exists>x. I \<phi> (x#xs))"
shows "I (lift_nnf_qe qe \<phi>) xs = I \<phi> xs"
proof(induct "\<phi>" arbitrary:xs)
  case ExQ thus ?case
    by (simp add: assms nqfree_nnf qfree_lift_nnf_qe I_nnf)
qed simp_all

lemma I_lift_nnf_qe2:
assumes  "qe \<in> |nqfree| \<rightarrow> |qfree|"
and "\<forall>\<phi> \<in> |nqfree|. \<forall>xs. I (qe \<phi>) xs = (\<exists>x. I \<phi> (x#xs))"
shows "I (lift_nnf_qe qe \<phi>) xs = I \<phi> xs"
using assms by(simp add:Pi_def I_lift_nnf_qe)

lemma normal_lift_nnf_qe:
assumes "\<And>\<phi>. nqfree \<phi> \<Longrightarrow> qfree(qe \<phi>)"
and     "\<And>\<phi>. nqfree \<phi> \<Longrightarrow> normal \<phi> \<Longrightarrow> normal(qe \<phi>)"
shows "normal \<phi> \<Longrightarrow> normal(lift_nnf_qe qe \<phi>)"
by (induct \<phi>)
   (simp_all add: assms Logic.neg_def normal_nnf
                  nqfree_nnf qfree_lift_nnf_qe)

lemma I_lift_nnf_qe_normal:
assumes  "\<And>\<phi>. nqfree \<phi> \<Longrightarrow> qfree(qe \<phi>)"
and "\<And>\<phi>. nqfree \<phi> \<Longrightarrow> normal \<phi> \<Longrightarrow> normal(qe \<phi>)"
and "\<And>xs \<phi>. normal \<phi> \<Longrightarrow> nqfree \<phi> \<Longrightarrow> I (qe \<phi>) xs = (\<exists>x. I \<phi> (x#xs))"
shows "normal \<phi> \<Longrightarrow> I (lift_nnf_qe qe \<phi>) xs = I \<phi> xs"
proof(induct "\<phi>" arbitrary:xs)
  case ExQ thus ?case
    by (simp add: assms nqfree_nnf qfree_lift_nnf_qe I_nnf
                  normal_lift_nnf_qe normal_nnf)
qed auto

lemma I_lift_nnf_qe_normal2:
assumes  "qe \<in> |nqfree| \<rightarrow> |qfree|"
and "qe \<in> |nqfree| \<inter> |normal| \<rightarrow> |normal|"
and "\<forall>\<phi> \<in> |normal| \<inter> |nqfree|. \<forall>xs. I (qe \<phi>) xs = (\<exists>x. I \<phi> (x#xs))"
shows "normal \<phi> \<Longrightarrow> I (lift_nnf_qe qe \<phi>) xs = I \<phi> xs"
using assms by(simp add:Pi_def I_lift_nnf_qe_normal Int_def)

end

subsection\<open>With equality\<close>

text\<open>DNF-based quantifier elimination can accommodate equality atoms
in a generic fashion.\<close>

locale ATOM_EQ = ATOM +
fixes solvable\<^sub>0 :: "'a \<Rightarrow> bool"
and trivial :: "'a \<Rightarrow> bool"
and subst\<^sub>0 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
assumes subst\<^sub>0:
  "\<lbrakk> solvable\<^sub>0 eq;  \<not>trivial eq;  I\<^sub>a eq (x#xs);  depends\<^sub>0 a \<rbrakk>
   \<Longrightarrow> I\<^sub>a (subst\<^sub>0 eq a) xs = I\<^sub>a a (x#xs)"
and trivial: "trivial eq \<Longrightarrow> I\<^sub>a eq xs"
and solvable: "solvable\<^sub>0 eq \<Longrightarrow> \<exists>x. I\<^sub>a eq (x#xs)"
and is_triv_self_subst: "solvable\<^sub>0 eq \<Longrightarrow> trivial (subst\<^sub>0 eq eq)"

begin

definition lift_eq_qe :: "('a list \<Rightarrow> 'a fm) \<Rightarrow> 'a list \<Rightarrow> 'a fm" where
"lift_eq_qe qe as =
 (let as = [a\<leftarrow>as. \<not> trivial a]
  in case [a\<leftarrow>as. solvable\<^sub>0 a] of
    [] \<Rightarrow> qe as
  | eq # eqs \<Rightarrow>
        (let ineqs = [a\<leftarrow>as. \<not> solvable\<^sub>0 a]
         in list_conj (map (Atom \<circ> (subst\<^sub>0 eq)) (eqs @ ineqs))))"

theorem I_lift_eq_qe:
assumes dep: "\<forall>a\<in>set as. depends\<^sub>0 a"
assumes qe: "\<And>as. (\<forall>a \<in> set as. depends\<^sub>0 a \<and> \<not> solvable\<^sub>0 a) \<Longrightarrow>
   I (qe as) xs = (\<exists>x. \<forall>a \<in> set as. I\<^sub>a a (x#xs))"
shows "I (lift_eq_qe qe as) xs = (\<exists>x. \<forall>a \<in> set as. I\<^sub>a a (x#xs))"
  (is "?L = ?R")
proof -
  let ?as = "[a\<leftarrow>as. \<not> trivial a]"
  show ?thesis
  proof (cases "[a\<leftarrow>?as. solvable\<^sub>0 a]")
    case Nil
    hence "\<forall>a\<in>set as. \<not> trivial a \<longrightarrow> \<not> solvable\<^sub>0 a"
      by(auto simp: filter_empty_conv)
    thus "?L = ?R"
      by(simp add:lift_eq_qe_def dep qe cong:conj_cong) (metis trivial)
  next
    case (Cons eq _)
    then have "eq \<in> set as" "solvable\<^sub>0 eq" "\<not> trivial eq"
      by (auto simp: filter_eq_Cons_iff)
    then obtain e where "I\<^sub>a eq (e#xs)" by(metis solvable)
    have "\<forall>a \<in> set as. I\<^sub>a a (e # xs) = I\<^sub>a (subst\<^sub>0 eq a) xs"
      by(simp add: subst\<^sub>0[OF \<open>solvable\<^sub>0 eq\<close> \<open>\<not> trivial eq\<close> \<open>I\<^sub>a eq (e#xs)\<close>] dep)
    thus ?thesis using Cons dep
      apply(simp add: lift_eq_qe_def,
            clarsimp simp: filter_eq_Cons_iff ball_Un)
      apply(rule iffI)
      apply(fastforce intro!:exI[of _ e] simp: trivial is_triv_self_subst)
      apply (metis subst\<^sub>0)
      done
  qed
qed

definition "lift_dnfeq_qe = lift_dnf_qe \<circ> lift_eq_qe"

lemma qfree_lift_eq_qe:
  "(\<And>as. \<forall>a\<in>set as. depends\<^sub>0 a \<Longrightarrow> qfree (qe as)) \<Longrightarrow>
   \<forall>a\<in>set as. depends\<^sub>0 a \<Longrightarrow> qfree(lift_eq_qe qe as)"
by(simp add:lift_eq_qe_def ball_Un split:list.split)

lemma qfree_lift_dnfeq_qe: "(\<And>as. (\<forall>a\<in>set as. depends\<^sub>0 a) \<Longrightarrow> qfree(qe as))
  \<Longrightarrow> qfree(lift_dnfeq_qe qe \<phi>)"
by(simp add: lift_dnfeq_qe_def qfree_lift_dnf_qe qfree_lift_eq_qe)

lemma I_lift_dnfeq_qe:
  "(\<And>as. (\<forall>a \<in> set as. depends\<^sub>0 a) \<Longrightarrow> qfree(qe as)) \<Longrightarrow>
   (\<And>as. (\<forall>a \<in> set as. depends\<^sub>0 a \<and> \<not> solvable\<^sub>0 a) \<Longrightarrow> is_dnf_qe qe as) \<Longrightarrow>
   I (lift_dnfeq_qe qe \<phi>) xs = I \<phi> xs"
by(simp add:lift_dnfeq_qe_def I_lift_dnf_qe qfree_lift_eq_qe I_lift_eq_qe)

lemma I_lift_dnfeq_qe2:
  "qe \<in> lists |depends\<^sub>0| \<rightarrow> |qfree| \<Longrightarrow>
   (\<forall>as \<in> lists( |depends\<^sub>0| \<inter> - |solvable\<^sub>0| ). is_dnf_qe qe as) \<Longrightarrow>
   I (lift_dnfeq_qe qe \<phi>) xs = I \<phi> xs"
using in_lists_conv_set[where ?'a = 'a]
by(simp add:Pi_def I_lift_dnfeq_qe Int_def Compl_eq)

end

end


section \<open>Connecting Nondeterministic Generalized Büchi Automata to CAVA Automata Structures\<close>

theory NGBA_Graphs
imports
  NGBA
  CAVA_Automata.Automata_Impl
begin

  no_notation build (infixr "##" 65)

  subsection \<open>Regular Graphs\<close>

  definition ngba_g :: "('label, 'state) ngba \<Rightarrow> 'state graph_rec" where
    "ngba_g A \<equiv> \<lparr> g_V = UNIV, g_E = E_of_succ (successors A), g_V0 = initial A \<rparr>"

  lemma ngba_g_graph[simp]: "graph (ngba_g A)" unfolding ngba_g_def graph_def by simp

  lemma ngba_g_V0: "g_V0 (ngba_g A) = initial A" unfolding ngba_g_def by simp
  lemma ngba_g_E_rtrancl: "(g_E (ngba_g A))\<^sup>* = {(p, q). q \<in> reachable A p}"
  unfolding ngba_g_def graph_rec.simps E_of_succ_def
  proof safe
    show "(p, q) \<in> {(p, q). q \<in> successors A p}\<^sup>*" if "q \<in> reachable A p" for p q
      using that by (induct) (auto intro: rtrancl_into_rtrancl)
    show "q \<in> reachable A p" if "(p, q) \<in> {(p, q). q \<in> successors A p}\<^sup>*" for p q
      using that by induct auto
  qed

  lemma ngba_g_rtrancl_path: "(g_E (ngba_g A))\<^sup>* = {(p, target r p) |r p. NGBA.path A r p}"
    unfolding ngba_g_E_rtrancl by blast
  lemma ngba_g_trancl_path: "(g_E (ngba_g A))\<^sup>+ = {(p, target r p) |r p. NGBA.path A r p \<and> r \<noteq> []}"
  unfolding ngba_g_def graph_rec.simps E_of_succ_def
  proof safe
    show "\<exists> r p. (x, y) = (p, target r p) \<and> NGBA.path A r p \<and> r \<noteq> []"
      if "(x, y) \<in> {(p, q). q \<in> successors A p}\<^sup>+" for x y
    using that
    proof induct
      case (base y)
      obtain a where 1: "a \<in> alphabet A" "y \<in> transition A a x" using base by auto
      show ?case
      proof (intro exI conjI)
        show "(x, y) = (x, target [(a, y)] x)" by simp
        show "NGBA.path A [(a, y)] x" using 1 by auto
        show "[(a, y)] \<noteq> []" by simp
      qed
    next
      case (step y z)
      obtain r where 1: "y = target r x" "NGBA.path A r x" "r \<noteq> []" using step(3) by auto
      obtain a where 2: "a \<in> alphabet A" "z \<in> transition A a y" using step(2) by auto
      show ?case
      proof (intro exI conjI)
        show "(x, z) = (x, target (r @ [(a, z)]) x)" by simp
        show "NGBA.path A (r @ [(a, z)]) x" using 1 2 by auto
        show "r @ [(a, z)] \<noteq> []" by simp
      qed
    qed
    show "(p, target r p) \<in> {(u, v). v \<in> successors A u}\<^sup>+" if "NGBA.path A r p" "r \<noteq> []" for r p
      using that by (induct) (fastforce intro: trancl_into_trancl2)+
  qed

  lemma ngba_g_ipath_run:
    assumes "ipath (g_E (ngba_g A)) r"
    obtains w
    where "run A (w ||| smap (r \<circ> Suc) nats) (r 0)"
  proof -
    have 1: "\<exists> a \<in> alphabet A. r (Suc i) \<in> transition A a (r i)" for i
      using assms unfolding ipath_def ngba_g_def E_of_succ_def by auto
    obtain wr where 2: "run A wr (r 0)" "\<And> i. target (stake i wr) (r 0) = r i"
    proof (rule ngba.invariant_run_index)
      show "\<exists> aq. (fst aq \<in> alphabet A \<and> snd aq \<in> transition A (fst aq) p) \<and> snd aq = r (Suc i) \<and> True"
        if "p = r i" for i p using that 1 by auto
      show "r 0 = r 0" by rule
    qed auto
    have 3: "smap (r \<circ> Suc) nats = smap snd wr"
    proof (rule eqI_snth)
      fix i
      have "smap (r \<circ> Suc) nats !! i = r (Suc i)" by simp
      also have "\<dots> = target (stake (Suc i) wr) (r 0)" unfolding 2(2) by rule
      also have "\<dots> = (r 0 ## trace wr (r 0)) !! Suc i" by simp
      also have "\<dots> = smap snd wr !! i" unfolding ngba.trace_alt_def by simp
      finally show "smap (r \<circ> Suc) nats !! i = smap snd wr !! i" by this
    qed
    show ?thesis
    proof
      show "run A (smap fst wr ||| smap (r \<circ> Suc) nats) (r 0)" using 2(1) unfolding 3 by auto
    qed
  qed
  lemma ngba_g_run_ipath:
    assumes "run A (w ||| r) p"
    shows "ipath (g_E (ngba_g A)) (snth (p ## r))"
  proof
    fix i
    have 1: "w !! i \<in> alphabet A" "r !! i \<in> transition A (w !! i) (target (stake i (w ||| r)) p)"
      using assms by (auto dest: ngba.run_snth)
    have 2: "r !! i \<in> successors A ((p ## r) !! i)"
      using 1 unfolding sscan_scons_snth[symmetric] ngba.trace_alt_def by auto
    show "((p ## r) !! i, (p ## r) !! Suc i) \<in> g_E (ngba_g A)"
      using 2 unfolding ngba_g_def graph_rec.simps E_of_succ_def by simp
  qed

  subsection \<open>Indexed Generalized Büchi Graphs\<close>

  definition ngba_acc :: "'state pred gen \<Rightarrow> 'state \<Rightarrow> nat set" where
    "ngba_acc cs p \<equiv> {k \<in> {0 ..< length cs}. (cs ! k) p}"

  lemma ngba_acc_param[param]: "(ngba_acc, ngba_acc) \<in> \<langle>S \<rightarrow> bool_rel\<rangle> list_rel \<rightarrow> S \<rightarrow> \<langle>nat_rel\<rangle> set_rel"
    unfolding ngba_acc_def list_rel_def list_all2_conv_all_nth fun_rel_def by auto

  definition ngba_igbg :: "('label, 'state) ngba \<Rightarrow> 'state igb_graph_rec" where
    "ngba_igbg A \<equiv> graph_rec.extend (ngba_g A) \<lparr> igbg_num_acc = length (accepting A), igbg_acc = ngba_acc (accepting A) \<rparr>"

  lemma acc_run_language:
    assumes "igb_graph (ngba_igbg A)"
    shows "Ex (igb_graph.is_acc_run (ngba_igbg A)) \<longleftrightarrow> language A \<noteq> {}"
  proof
    interpret igb_graph "ngba_igbg A" using assms by this
    have [simp]: "V0 = g_V0 (ngba_g A)" "E = g_E (ngba_g A)" "num_acc = length (accepting A)"
      "k \<in> acc p \<longleftrightarrow> k < length (accepting A) \<and> (accepting A ! k) p" for p k
      unfolding ngba_igbg_def ngba_acc_def graph_rec.defs by simp+
    show "language A \<noteq> {}" if run: "Ex is_acc_run"
    proof -
      obtain r where 1: "is_acc_run r" using run by rule
      have 2: "r 0 \<in> V0" "ipath E r" "is_acc r"
        using 1 unfolding is_acc_run_def graph_defs.is_run_def by auto
      obtain w where 3: "run A (w ||| smap (r \<circ> Suc) nats) (r 0)" using ngba_g_ipath_run 2(2) by auto
      have 4: "r 0 ## smap (r \<circ> Suc) nats = smap r nats" by (simp) (metis stream.map_comp smap_siterate)
      have 5: "infs (accepting A ! k) (r 0 ## smap (r \<circ> Suc) nats)" if "k < length (accepting A)" for k
        using 2(3) that unfolding infs_infm is_acc_def 4 by simp
      have "w \<in> language A"
      proof
        show "r 0 \<in> initial A" using ngba_g_V0 2(1) by force
        show "run A (w ||| smap (r \<circ> Suc) nats) (r 0)" using 3 by this
        show "gen infs (accepting A) (r 0 ## smap (r \<circ> Suc) nats)"
          unfolding gen_def all_set_conv_all_nth using 5 by simp
      qed
      then show ?thesis by auto
    qed
    show "Ex is_acc_run" if language: "language A \<noteq> {}"
    proof -
      obtain w where 1: "w \<in> language A" using language by auto
      obtain r p where 2: "p \<in> initial A" "run A (w ||| r) p" "gen infs (accepting A) (p ## r)" using 1 by rule
      have "is_acc_run (snth (p ## r))"
      unfolding is_acc_run_def graph_defs.is_run_def
      proof safe
        show "(p ## r) !! 0 \<in> V0" using ngba_g_V0 2(1) by force
        show "ipath E (snth (p ## r))" using ngba_g_run_ipath 2(2) by force
        show "is_acc (snth (p ## r))" using 2(3) unfolding gen_def infs_infm is_acc_def by simp
      qed
      then show ?thesis by auto
    qed
  qed

end