section \<open>LLVM like Integer Types with Flexible Bit-Width\<close>
theory LLVM_Integer
imports LLVM_More_Word
begin

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.Bits_Int"}. 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_operations
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 (simp add: mod_mult_right_eq semiring_normalization_rules(7) shiftl_int_def)

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


theory Nat_monadic
imports "$HETS_LIB/Isabelle/MainHC" "Primes" "Parity"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"ga_selector_pre\", \"ga_injective_suc\", \"ga_disjoint_0_suc\",
     \"ga_selector_undef_pre_0\", \"X1_def_Nat\", \"X2_def_Nat\",
     \"X3_def_Nat\", \"X4_def_Nat\", \"X5_def_Nat\", \"X6_def_Nat\",
     \"X7_def_Nat\", \"X8_def_Nat\", \"X9_def_Nat\", \"decimal_def\",
     \"ga_comm___XPlus__\", \"ga_assoc___XPlus__\",
     \"ga_right_unit___XPlus__\", \"ga_left_unit___XPlus__\",
     \"ga_left_comm___XPlus__\", \"ga_comm___Xx__\",
     \"ga_assoc___Xx__\", \"ga_right_unit___Xx__\",
     \"ga_left_unit___Xx__\", \"ga_left_comm___Xx__\", \"ga_comm_min\",
     \"ga_assoc_min\", \"ga_left_comm_min\", \"ga_comm_max\",
     \"ga_assoc_max\", \"ga_right_unit_max\", \"ga_left_unit_max\",
     \"ga_left_comm_max\", \"leq_def1_Nat\", \"dvd_def_Nat\",
     \"leq_def2_Nat\", \"leq_def3_Nat\", \"geq_def_Nat\",
     \"less_def_Nat\", \"greater_def_Nat\", \"even_0_Nat\",
     \"even_suc_Nat\", \"odd_def_Nat\", \"factorial_0\",
     \"factorial_suc\", \"add_0_Nat\", \"add_suc_Nat\", \"mult_0_Nat\",
     \"mult_suc_Nat\", \"power_0_Nat\", \"power_suc_Nat\",
     \"min_def_Nat\", \"max_def_Nat\", \"subTotal_def1_Nat\",
     \"subTotal_def2_Nat\", \"sub_dom_Nat\", \"sub_def_Nat\",
     \"divide_dom_Nat\", \"divide_0_Nat\", \"divide_Nat_Nat\",
     \"div_dom_Nat\", \"div_Nat\", \"mod_dom_Nat\", \"mod_Nat\",
     \"distr1_Nat\", \"distr2_Nat\", \"min_0\", \"div_mod_Nat\",
     \"power_Nat\"]"

datatype X_Nat = X0 ("0''") | X_suc "X_Nat" ("suc/'(_')" [3] 999)

consts
X1 :: "X_Nat" ("1''")
X2 :: "X_Nat" ("2''")
X3 :: "X_Nat" ("3''")
X4 :: "X_Nat" ("4''")
X5 :: "X_Nat" ("5''")
X6 :: "X_Nat" ("6''")
X7 :: "X_Nat" ("7''")
X8 :: "X_Nat" ("8''")
X9 :: "X_Nat" ("9''")
X__XAtXAt__X :: "X_Nat => X_Nat => X_Nat" ("(_/ @@/ _)" [54,54] 52)
X__XCaret__X :: "X_Nat => X_Nat => X_Nat" ("(_/ ^''/ _)" [54,54] 52)
X__XExclam :: "X_Nat => X_Nat" ("(_/ !'')" [58] 58)
X__XGtXEq__X :: "X_Nat => X_Nat => bool" ("(_/ >=''/ _)" [44,44] 42)
X__XGt__X :: "X_Nat => X_Nat => bool" ("(_/ >''/ _)" [44,44] 42)
X__XLtXEq__X :: "X_Nat => X_Nat => bool" ("(_/ <=''/ _)" [44,44] 42)
X__XLt__X :: "X_Nat => X_Nat => bool" ("(_/ <''/ _)" [44,44] 42)
X__XMinusXExclam__X :: "X_Nat => X_Nat => X_Nat" ("(_/ -!/ _)" [54,54] 52)
X__XMinusXQuest__X :: "X_Nat => X_Nat => X_Nat partial" ("(_/ -?/ _)" [54,54] 52)
X__XPlus__X :: "X_Nat => X_Nat => X_Nat" ("(_/ +''/ _)" [54,54] 52)
X__XSlashXQuest__X :: "X_Nat => X_Nat => X_Nat partial" ("(_/ '/?/ _)" [54,54] 52)
X__Xx__X :: "X_Nat => X_Nat => X_Nat" ("(_/ *''/ _)" [54,54] 52)
X__div__X :: "X_Nat => X_Nat => X_Nat partial" ("(_/ div''/ _)" [54,54] 52)
X__dvd__X :: "X_Nat => X_Nat => bool" ("(_/ dvd''/ _)" [44,44] 42)
X__mod__X :: "X_Nat => X_Nat => X_Nat partial" ("(_/ mod''/ _)" [54,54] 52)
X_even :: "X_Nat => bool" ("even''/'(_')" [3] 999)
X_max :: "X_Nat => X_Nat => X_Nat" ("max''/'(_,/ _')" [3,3] 999)
X_min :: "X_Nat => X_Nat => X_Nat" ("min''/'(_,/ _')" [3,3] 999)
X_odd :: "X_Nat => bool" ("odd''/'(_')" [3] 999)
X_pre :: "X_Nat => X_Nat partial" ("pre/'(_')" [3] 999)

section "Extension of Naturals"
(* we introduce some new symbols *)
consts combine_nat :: "nat => nat => nat" ("(_/ @@@/ _)" [54,54] 52)
consts part_div :: "nat => nat => nat partial" ("(_/ '/??/ _)" [54,54] 52)
consts part_minus :: "nat => nat => nat partial" ("(_/ '-??/ _)" [54,54] 52)

primrec pre_nat
where
  pre_nat_0: "pre_nat 0 = noneOp"
  | pre_nat_suc: "pre_nat (Suc n) = makePartial n"

axioms
ga_selector_pre [rule_format] :
"ALL XX1. pre(suc(XX1)) = makePartial XX1"

ga_injective_suc [rule_format] :
"ALL XX1. ALL Y1. suc(XX1) = suc(Y1) = (XX1 = Y1)"

ga_disjoint_0_suc [rule_format] : "ALL Y1. ~ 0' = suc(Y1)"

ga_selector_undef_pre_0 [rule_format] : "~ defOp (pre(0'))"

X1_def_Nat [rule_format] : "1' = suc(0')"

X2_def_Nat [rule_format] : "2' = suc(1')"

X3_def_Nat [rule_format] : "3' = suc(2')"

X4_def_Nat [rule_format] : "4' = suc(3')"

X5_def_Nat [rule_format] : "5' = suc(4')"

X6_def_Nat [rule_format] : "6' = suc(5')"

X7_def_Nat [rule_format] : "7' = suc(6')"

X8_def_Nat [rule_format] : "8' = suc(7')"

X9_def_Nat [rule_format] : "9' = suc(8')"

decimal_def [rule_format] :
"ALL m. ALL X_n. m @@ X_n = (m *' suc(9')) +' X_n"

ga_comm___XPlus__ [rule_format] : "ALL x. ALL y. x +' y = y +' x"

ga_assoc___XPlus__ [rule_format] :
"ALL x. ALL y. ALL z. (x +' y) +' z = x +' (y +' z)"

ga_right_unit___XPlus__ [rule_format] : "ALL x. x +' 0' = x"

ga_left_unit___XPlus__ [rule_format] : "ALL x. 0' +' x = x"

ga_left_comm___XPlus__ [rule_format] :
"ALL x. ALL y. ALL z. x +' (y +' z) = y +' (x +' z)"

ga_comm___Xx__ [rule_format] : "ALL x. ALL y. x *' y = y *' x"

ga_assoc___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. (x *' y) *' z = x *' (y *' z)"

ga_right_unit___Xx__ [rule_format] : "ALL x. x *' 1' = x"

ga_left_unit___Xx__ [rule_format] : "ALL x. 1' *' x = x"

ga_left_comm___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. x *' (y *' z) = y *' (x *' z)"

ga_comm_min [rule_format] : "ALL x. ALL y. min'(x, y) = min'(y, x)"

ga_assoc_min [rule_format] :
"ALL x. ALL y. ALL z. min'(min'(x, y), z) = min'(x, min'(y, z))"

ga_left_comm_min [rule_format] :
"ALL x. ALL y. ALL z. min'(x, min'(y, z)) = min'(y, min'(x, z))"

ga_comm_max [rule_format] : "ALL x. ALL y. max'(x, y) = max'(y, x)"

ga_assoc_max [rule_format] :
"ALL x. ALL y. ALL z. max'(max'(x, y), z) = max'(x, max'(y, z))"

ga_right_unit_max [rule_format] : "ALL x. max'(x, 0') = x"

ga_left_unit_max [rule_format] : "ALL x. max'(0', x) = x"

ga_left_comm_max [rule_format] :
"ALL x. ALL y. ALL z. max'(x, max'(y, z)) = max'(y, max'(x, z))"

leq_def1_Nat [rule_format] : "ALL X_n. 0' <=' X_n"

dvd_def_Nat [rule_format] :
"ALL m. ALL X_n. (m dvd' X_n) = (EX k. X_n = m *' k)"

leq_def2_Nat [rule_format] : "ALL X_n. ~ suc(X_n) <=' 0'"

leq_def3_Nat [rule_format] :
"ALL m. ALL X_n. (suc(m) <=' suc(X_n)) = (m <=' X_n)"

geq_def_Nat [rule_format] :
"ALL m. ALL X_n. (m >=' X_n) = (X_n <=' m)"

less_def_Nat [rule_format] :
"ALL m. ALL X_n. (m <' X_n) = (m <=' X_n & ~ m = X_n)"

greater_def_Nat [rule_format] :
"ALL m. ALL X_n. (m >' X_n) = (X_n <' m)"

even_0_Nat [rule_format] : "even'(0')"

even_suc_Nat [rule_format] : "ALL m. even'(suc(m)) = odd'(m)"

odd_def_Nat [rule_format] : "ALL m. odd'(m) = (~ even'(m))"

factorial_0 [rule_format] : "0' !' = 1'"

factorial_suc [rule_format] :
"ALL X_n. suc(X_n) !' = suc(X_n) *' X_n !'"

add_0_Nat [rule_format] : "ALL m. 0' +' m = m"

add_suc_Nat [rule_format] :
"ALL m. ALL X_n. suc(X_n) +' m = suc(X_n +' m)"

mult_0_Nat [rule_format] : "ALL m. 0' *' m = 0'"

mult_suc_Nat [rule_format] :
"ALL m. ALL X_n. suc(X_n) *' m = (X_n *' m) +' m"

power_0_Nat [rule_format] : "ALL m. m ^' 0' = 1'"

power_suc_Nat [rule_format] :
"ALL m. ALL X_n. m ^' suc(X_n) = m *' (m ^' X_n)"

min_def_Nat [rule_format] :
"ALL m. ALL X_n. min'(m, X_n) = (if m <=' X_n then m else X_n)"

max_def_Nat [rule_format] :
"ALL m. ALL X_n. max'(m, X_n) = (if m <=' X_n then X_n else m)"

subTotal_def1_Nat [rule_format] :
"ALL m. ALL X_n. m >' X_n --> X_n -! m = 0'"

subTotal_def2_Nat [rule_format] :
"ALL m. ALL X_n. m <=' X_n --> makePartial (X_n -! m) = X_n -? m"

sub_dom_Nat [rule_format] :
"ALL m. ALL X_n. defOp (m -? X_n) = (m >=' X_n)"

sub_def_Nat [rule_format] :
"ALL m. ALL X_n. ALL r. m -? X_n = makePartial r = (m = r +' X_n)"

divide_dom_Nat [rule_format] :
"ALL m.
 ALL X_n.
 defOp (m /? X_n) = (~ X_n = 0' & m mod' X_n = makePartial 0')"

divide_0_Nat [rule_format] : "ALL m. ~ defOp (m /? 0')"

divide_Nat_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL r. X_n >' 0' --> m /? X_n = makePartial r = (m = r *' X_n)"

div_dom_Nat [rule_format] :
"ALL m. ALL X_n. defOp (m div' X_n) = (~ X_n = 0')"

div_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL r.
 m div' X_n = makePartial r =
 (EX s. m = (X_n *' r) +' s & s <' X_n)"

mod_dom_Nat [rule_format] :
"ALL m. ALL X_n. defOp (m mod' X_n) = (~ X_n = 0')"

mod_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ALL s.
 m mod' X_n = makePartial s =
 (EX r. m = (X_n *' r) +' s & s <' X_n)"

distr1_Nat [rule_format] :
"ALL r. ALL s. ALL t. (r +' s) *' t = (r *' t) +' (s *' t)"

distr2_Nat [rule_format] :
"ALL r. ALL s. ALL t. t *' (r +' s) = (t *' r) +' (t *' s)"

min_0 [rule_format] : "ALL m. min'(m, 0') = 0'"

div_mod_Nat [rule_format] :
"ALL m.
 ALL X_n.
 ~ X_n = 0' -->
 makePartial m =
 lift2partial (flip (mapPartial o X__XPlus__X) (m mod' X_n))
 (mapPartial (flip X__Xx__X X_n) (m div' X_n))"

power_Nat [rule_format] :
"ALL m. ALL r. ALL s. m ^' (r +' s) = (m ^' r) *' (m ^' s)"

decimal_def_nat [rule_format] :
"ALL m. ALL X_n. m @@@ X_n = (m * Suc(9)) + X_n"

divide_Pos_nat [rule_format] :
"ALL m. ALL X_n. ALL r. X_n > 0 --> m /?? X_n = makePartial r = (m = r * X_n)"

part_div_def : "x /??y = (if (x mod y = 0) then makePartial(x div y) else noneOp)"
part_minus_def : "x -?? y = (if (x>=y) then makePartial(x-y) else noneOp)"

declare ga_selector_pre [simp]
declare ga_selector_undef_pre_0 [simp]
declare ga_comm___XPlus__ [simp]
declare ga_assoc___XPlus__ [simp]
declare ga_right_unit___XPlus__ [simp]
declare ga_left_unit___XPlus__ [simp]
declare ga_left_comm___XPlus__ [simp]
declare ga_comm___Xx__ [simp]
declare ga_assoc___Xx__ [simp]
declare ga_right_unit___Xx__ [simp]
declare ga_left_unit___Xx__ [simp]
declare ga_left_comm___Xx__ [simp]
declare ga_comm_min [simp]
declare ga_assoc_min [simp]
declare ga_left_comm_min [simp]
declare ga_comm_max [simp]
declare ga_assoc_max [simp]
declare ga_right_unit_max [simp]
declare ga_left_unit_max [simp]
declare ga_left_comm_max [simp]
declare leq_def1_Nat [simp]
declare dvd_def_Nat [simp]
declare leq_def2_Nat [simp]
declare leq_def3_Nat [simp]
declare geq_def_Nat [simp]
declare less_def_Nat [simp]
declare greater_def_Nat [simp]
declare even_0_Nat [simp]
declare even_suc_Nat [simp]
declare odd_def_Nat [simp]
declare factorial_0 [simp]
declare factorial_suc [simp]
declare add_0_Nat [simp]
declare add_suc_Nat [simp]
declare mult_0_Nat [simp]
declare mult_suc_Nat [simp]
declare power_0_Nat [simp]
declare power_suc_Nat [simp]
declare subTotal_def1_Nat [simp]
declare subTotal_def2_Nat [simp]
declare sub_dom_Nat [simp]
declare divide_0_Nat [simp]
declare min_0 [simp]

lemma makePartialproj[simp]: "makeTotal(makePartial x)=x"
apply (subst makeTotal_def)
apply (subst makePartial_def)
apply (auto)
done

primrec Nat2nat
where
  Nat2nat_0: "Nat2nat  0' = 0 "
  | Nat2nat_suc: "Nat2nat  (X_suc x) = Suc (Nat2nat x)"

primrec nat2Nat
where
  nat2Nat_0: "nat2Nat 0 = 0'"
| nat2Nat_Suc: "nat2Nat (Suc x) = X_suc (nat2Nat x)"

lemma iso1 [simp] : "! x . nat2Nat(Nat2nat x) = x"
apply (auto)
apply (induct_tac x)
apply (auto)
done

lemma iso2 [simp] : "! x. Nat2nat(nat2Nat x) = x"
apply (auto)
apply (induct_tac x)
apply (auto)
done

lemma nat2Nat_injectivity : "nat2Nat(x) = nat2Nat(y) ==> x = y"
apply (drule_tac f="%x. Nat2nat(x)" in arg_cong)
apply (simp)
done

lemma Nat2nat_injectivity : "Nat2nat(x) = Nat2nat(y) ==>  x = y"
apply (drule_tac f="%x. nat2Nat(x)" in arg_cong)
apply (simp)
done

lemma nat2Nat_injectivity_negated : "nat2Nat(x) ~= nat2Nat(y) ==> x ~= y"
apply (auto)
done

lemma Nat2nat_injectivity_negated : "Nat2nat(x) ~= Nat2nat(y) ==>  x ~= y"
apply (auto)
done

(* ask Lutz which version to use *)
lemma inj_predefined : "inj Nat2nat"
apply (simp add: inj_on_def)
apply (auto)
apply (drule_tac f="%x. nat2Nat(x)" in arg_cong)
apply (simp)
done

section "Simple Definitions"

(* the numbers need special treatment. we use the following strategy: 1' is manually proved
   for subsequent numbers: apply definition for n' -> suc( [n-1]'), use theorem for [n-1]', ripple out via nat2Nat_Suc *)

(* ============================== 1 ============================== *)

(*by (auto simp add: X1_def_Nat)*)
theorem nat2Nat_1_def_Nat[simp] : "nat2Nat(1) = 1'"
apply (simp)
apply (subst X1_def_Nat)
apply (auto)
done

(* get backwards direction via the iso (already in the simplifier) and the other direction *)
theorem Nat2nat_1_def_Nat[simp] : "Nat2nat(1')=1"
apply (simp add: nat2Nat_1_def_Nat[THEN sym])
done

(* ============================== 2 ============================== *)

theorem nat2Nat_2_def_Nat[simp] : "nat2Nat(2) =2'"
apply (subst X2_def_Nat)
apply (subst nat2Nat_1_def_Nat[THEN sym])
apply (subst nat2Nat_Suc [rule_format, THEN sym])
apply (subgoal_tac "Suc 1 = 2")
apply (drule_tac f="%x. nat2Nat(x)" in arg_cong)
apply (auto)
done

theorem two_2[simp]  : "Nat2nat(2') = 2"
apply (subst nat2Nat_2_def_Nat[THEN sym])
apply (simp only: iso2)
done

(* ============================== 3 ============================== *)

theorem nat2Nat_3_def_Nat[simp] : "nat2Nat(3) = 3'"
apply (subst X3_def_Nat)
apply (subst nat2Nat_2_def_Nat[THEN sym])
apply (subst nat2Nat_Suc [rule_format, THEN sym])
apply (simp)
done

theorem nat2Nat_3_def_nat[simp] : "Nat2nat(3') = 3"
apply (subst nat2Nat_3_def_Nat[THEN sym])
apply (simp only: iso2)
done

(* ============================== 4 ============================== *)

theorem nat2Nat_4_def_Nat[simp] : "nat2Nat(4) = 4'"
apply (subst X4_def_Nat)
apply (subst nat2Nat_3_def_Nat[THEN sym])
apply (subst nat2Nat_Suc [rule_format, THEN sym])
apply (simp)
done

theorem Nat2nat_4_def_Nat : "Nat2nat(4') = 4"
apply (subst nat2Nat_4_def_Nat[THEN sym])
apply (simp only: iso2)
done

(* ============================== 5 ============================== *)

theorem nat2Nat_5_def_Nat[simp] : "nat2Nat(5) = 5'"
apply (subst X5_def_Nat)
apply (subst nat2Nat_4_def_Nat[THEN sym])
apply (subst nat2Nat_Suc [rule_format, THEN sym])
apply (simp)
done

theorem Nat2nat_5_def_Nat[simp] : "Nat2nat(5') = 5"
apply (subst nat2Nat_5_def_Nat[THEN sym])
apply (simp only: iso2)
done

(* ============================== 6 ============================== *)

theorem nat2Nat_6_def_Nat[simp] : "nat2Nat(6) = 6'"
apply (subst X6_def_Nat)
apply (subst nat2Nat_5_def_Nat[THEN sym])
apply (subst nat2Nat_Suc [rule_format, THEN sym])
apply (simp)
done

theorem Nat2nat_6_def_Nat[simp] : "Nat2nat(6') = 6"
apply (subst nat2Nat_6_def_Nat[THEN sym])
apply (simp only: iso2)
done

(* ============================== 7 ============================== *)

theorem nat2Nat_7_def_Nat[simp] : "nat2Nat(7)=7'"
apply (subst X7_def_Nat)
apply (subst nat2Nat_6_def_Nat[THEN sym])
apply (subst nat2Nat_Suc [rule_format, THEN sym])
apply (simp)
done

theorem Nat2nat_7_def_Nat[simp] : "Nat2nat(7') = 7"
apply (subst nat2Nat_7_def_Nat[THEN sym])
apply (simp only: iso2)
done

(* ============================== 8 ============================== *)

theorem nat2Nat_8_def_Nat[simp] : "nat2Nat(8) = 8'"
apply (subst X8_def_Nat)
apply (subst nat2Nat_7_def_Nat[THEN sym])
apply (subst nat2Nat_Suc [rule_format, THEN sym])
apply (simp)
done

theorem Nat2nat_8_def_Nat[simp] : "Nat2nat(8') = 8 "
apply (subst nat2Nat_8_def_Nat[THEN sym])
apply (simp only: iso2)
done

(* ============================== 9 ============================== *)

theorem nat2Nat_9_def_Nat[simp] : "nat2Nat(9) = 9'"
apply (subst X9_def_Nat)
apply (subst nat2Nat_8_def_Nat[THEN sym])
apply (subst nat2Nat_Suc [rule_format, THEN sym])
apply (simp)
done

theorem Nat2nat_9_def_Nat[simp] : "Nat2nat(9') = 9"
apply (subst nat2Nat_9_def_Nat[THEN sym])
apply (simp only: iso2)
done

section "Recursive Definitions"

theorem nat2Nat_add [simp] : "nat2Nat (x + y) = (nat2Nat x) +' (nat2Nat y)"
apply (induct_tac x)
apply (auto simp only: nat2Nat_Suc nat2Nat_0 add_Suc add_0 add_suc_Nat add_0_Nat)
done

theorem Nat2nat_add[simp] : "Nat2nat (x +' y) = (Nat2nat x) + (Nat2nat y)"
apply (rule nat2Nat_injectivity)
apply (auto)
done

theorem nat2Nat_mul [simp] : "nat2Nat (x * y) = (nat2Nat x) *' (nat2Nat y)"
apply (induct_tac x)
apply (auto simp only: nat2Nat_Suc nat2Nat_0 nat2Nat_add mult_Suc mult_0 mult_suc_Nat mult_0_Nat)
apply (auto)
done

theorem Nat2nat_mul [simp] : "Nat2nat (x *' y) = (Nat2nat x) * (Nat2nat y)"
apply (rule nat2Nat_injectivity)
apply (auto)
done

theorem nat2Nat_power [simp] : "nat2Nat(x ^ y) = nat2Nat(x) ^' nat2Nat(y)"
apply (induct_tac y)
apply (auto)
apply (simp add: X1_def_Nat)
done

theorem Nat2nat_power [simp]: "Nat2nat(x ^' y) = Nat2nat(x) ^ Nat2nat(y)"
apply (rule nat2Nat_injectivity)
apply (auto)
done

theorem nat2Nat_fac [simp] : "nat2Nat(fact(x)) = nat2Nat(x)!'"
apply (induct_tac x)
apply (simp add: X1_def_Nat)
apply (subst fact.simps)
apply (simp only: nat2Nat_mul nat2Nat_Suc factorial_suc)
done

theorem Nat2nat_fac [simp] : "Nat2nat(x!') = fact(Nat2nat(x))"
apply (rule nat2Nat_injectivity)
apply auto
done

section "Predicates"

subsection "ordering"

lemma no_le_zero [simp] : "(x <=' 0') = (x = 0')"
apply (case_tac x)
by (auto)

lemma no_nat2Nat_zero [simp] : "!!x. nat2Nat x = 0' ==> x = 0"
apply (rule nat2Nat_injectivity)
apply simp
done

theorem nat2Nat_lt_equal [simp] : "nat2Nat(x) <=' nat2Nat(y) <->x <= y "
apply (rule diff_induct)
apply (auto)
done

theorem Nat2nat_lt_equal [simp] : "(Nat2nat(x) <= Nat2nat(y)) <-> (x <=' y)"
apply (subst nat2Nat_lt_equal[THEN sym])
apply (simp only: iso1)
done

theorem nat2Nat_lt [simp] : "nat2Nat(x) <' nat2Nat(y) <-> x < y"
apply (rule diff_induct)
apply (auto)
done

theorem Nat2nat_lt [simp] : "Nat2nat(x) < Nat2nat(y) <-> x <' y"
apply (subst nat2Nat_lt[THEN sym])
apply (simp only: iso1)
done

theorem nat2Nat_gt [simp] : " nat2Nat(x) >' nat2Nat(y) <-> x > y"
apply (rule diff_induct)
apply (auto)
done

theorem Nat2nat_gt [simp] : "Nat2nat(x) > Nat2nat(y) <-> x >' y "
apply (subst nat2Nat_gt[THEN sym])
apply (simp)
done

theorem nat2Nat_gt_equal [simp] : "nat2Nat(x) >=' nat2Nat(y) <-> x >= y"
apply (rule diff_induct)
apply (auto)
done

theorem Nat2nat_gt_equal [simp] : "Nat2nat(x) >= Nat2nat(y) <-> x >=' y"
apply (subst nat2Nat_gt_equal[THEN sym])
apply(auto)
done

subsection "Even and Odd"

lemma suc_even_nat: "even(x) ==> even(Suc(Suc(x)))"
apply (auto)
done

theorem nat2Nat_even [simp] : "((even(Nat2nat(x)) <-> even'(x)) & (odd(Nat2nat(x)) <-> odd'(x)))"
apply (induct x)
apply (simp)
apply (rule conjI)
apply (simp)
apply (simp)
done

theorem Nat2nat_even [simp] : "(even'(nat2Nat(x)) <-> (even(x)) & (odd'(nat2Nat(x)) <-> odd(x)))"
apply (insert nat2Nat_even [of "nat2Nat(x)"])
apply (auto)
done

theorem nat2Nat_dvd [simp] : "(nat2Nat(x) dvd' nat2Nat(y)) <-> (x dvd y)"
apply (subst dvd_def_Nat)
apply (subst dvd_def)
apply (rule iffI)
apply (simp)
apply (erule exE)
apply (drule_tac f="%x. Nat2nat(x)" in arg_cong)
apply (simp (no_asm_use) only: Nat2nat_mul iso2)
apply (auto)
done

theorem Nat2nat_dvd : "(Nat2nat(x) dvd Nat2nat(y)) = (x dvd' y)"
apply (auto)
apply (subst (asm) nat2Nat_dvd [THEN sym])
apply (auto)
done

section "Simple Functions"

theorem nat2Nat_max [simp]: "nat2Nat(max x y) = max'(nat2Nat(x),nat2Nat(y))"
apply (simp add: max_def_Nat max_def)
done

theorem Nat2nat_max : "Nat2nat(max'(x,y)) = (max (Nat2nat(x)) (Nat2nat(y)))"
apply (simp add: max_def_Nat max_def)
done

theorem nat2Nat_min : "nat2Nat(min x y) = min' (nat2Nat(x), nat2Nat(y))"
apply (simp add: min_def_Nat min_def)
done

theorem Nat2nat_min : "Nat2nat(min'(x,y)) = (min (Nat2nat(x)) (Nat2nat(y)))"
apply (simp add: min_def_Nat min_def)
done

(* ============================================================================= *)
(* ============================== cut off minus ================================ *)
(* ============================================================================= *)

lemma anything_part_minus_zero [simp] : "x -? 0' = makePartial x"
apply (simp add: sub_def_Nat)
done

lemma add_partiality  : "x=y <-> makePartial x = makePartial y"
apply (simp add: makePartial_def)
done

lemma anything_minus_zero [simp] : "x -! 0' = x"
(* here the problem is that the defined rewrite rule is only applicable for makePartial x-!y *)
apply (subst add_partiality)
apply (subst subTotal_def2_Nat)
apply (simp)
apply (subst anything_part_minus_zero)
apply (simp)
done

lemma not_greater_zero : "~ x>'0' <-> x <=' 0'"
apply (simp)
apply (auto)
done

lemma zero_minus_anything [simp] : "0' -! x = 0'"
apply (case_tac "x>'0'")
apply (simp only: subTotal_def1_Nat)
apply (subst (asm) not_greater_zero)
apply (subst add_partiality)
apply (subst subTotal_def2_Nat)
apply (auto)
done

lemma not_iff : "(A<->B) <-> (~A <-> ~B)"
apply (auto)
done

lemma not_greater_suc : "~ (x>'y) <-> x <' X_suc(y)"
apply (insert Nat2nat_gt)
apply (subst (asm) not_iff)
apply (subst (asm) not_less_eq)
apply (subst (asm) Nat2nat_suc [rule_format, THEN sym])
apply (subst (asm) Nat2nat_lt )
apply (auto)
done

lemma not_greater_isa : "~((x::nat) > (y::nat)) <-> x<=y"
apply (arith)
done

lemma minus_Suc : "(Suc(x) - Suc(y))=(x-y)"
apply (auto)
done

lemma not_greater : " ~ (x>'y) <-> x<='y"
sorry

lemma minus_neutral : "(x <=' y) ==> y = (y -! x) +' x"
apply (drule subTotal_def2_Nat)
apply (drule sym)
apply (subst (asm) sub_def_Nat)
apply (auto)
done

(*forward reasoning anstatt makePartial einfügen ist hilfreich*)

lemma minus_suc : "(X_suc(x) -! X_suc(y))=(x-!y)"
apply (case_tac "y>'x")
apply (simp)
apply (subst (asm) not_greater)
apply (subst add_partiality)
apply (subst subTotal_def2_Nat)
apply (simp)
apply (subst sub_def_Nat)
apply (subst ga_comm___XPlus__)
apply (subst add_suc_Nat)
apply (subst ga_injective_suc)
apply (subst ga_comm___XPlus__)
apply (rule minus_neutral)
apply (simp)
done

theorem nat2Nat_minus: "nat2Nat (x - y) = (nat2Nat(x) -! nat2Nat (y))"
apply (rule diff_induct)
apply (simp)
apply (simp only: nat2Nat_0 nat2Nat_Suc diff_0_eq_0 zero_minus_anything)
apply (subst minus_Suc)
apply (simp)
apply (subst minus_suc)
apply (auto)
done

theorem Nat2nat_minus: "Nat2nat (x -! y) = (Nat2nat (x) - Nat2nat(y))"
apply (rule nat2Nat_injectivity)
apply (subst nat2Nat_minus)
apply (auto)
done

section "Partial Functions"

theorem iso2_negated: "~(nat2Nat(x)=nat2Nat(y)) ==> ~(x=y)"
apply (auto)
done

theorem iso1_negated1: "x~=y ==> ~(Nat2nat(x)=Nat2nat(y))"
apply (auto)
apply (drule Nat2nat_injectivity)
apply (auto)
done

section "Non-canonical Mappings"

theorem nat2Nat_at : "nat2Nat(x @@@ y) = nat2Nat(x) @@ nat2Nat(y)"
apply (auto simp add: decimal_def decimal_def_nat)
apply (rule Nat2nat_injectivity)
apply (simp only: Nat2nat_mul Nat2nat_add Nat2nat_9_def_Nat[rule_format, THEN sym])
by (auto)

theorem Nat2nat_at  : "Nat2nat( x @@ y) = Nat2nat(x) @@@ Nat2nat(y)"
apply (simp only: decimal_def decimal_def_nat)
apply (simp only: Nat2nat_mul Nat2nat_suc Nat2nat_add Nat2nat_9_def_Nat[rule_format, THEN sym])
done

theorem Nat2nat_pre : "!!x. x > 0 ==> nat2Nat(makeTotal(pre_nat(x))) = makeTotal(pre(nat2Nat(x)))"
(* moeglichst schnell definition von pre einsetzen *)
apply (case_tac x)
apply (simp)
apply (simp add: ga_selector_pre nat2Nat_Suc)
done

theorem nat2Nat_pre : "x >' 0' ==> Nat2nat(makeTotal(pre(x))) = makeTotal(pre_nat(Nat2nat(x)))"
apply (subst (asm) Nat2nat_gt[THEN sym])
apply (simp only: Nat2nat_0)
apply (rule nat2Nat_injectivity)
apply (subst Nat2nat_pre)
apply (simp)
apply (simp add: iso2)
done

lemma makepartial_intro_weak: "(s=makePartial t) ==> (makeTotal(s)=t)"
apply (simp add: makePartial_def makeTotal_def)
done

theorem nat2Nat_div [simp]: "y ~= 0 ==> nat2Nat(x div y) = makeTotal(nat2Nat(x) div' nat2Nat(y))"
apply (rule sym)
apply (rule makepartial_intro_weak)
apply (subst div_Nat)
apply (rule_tac x="nat2Nat (x mod y)" in exI)
apply (rule conjI)
apply (rule Nat2nat_injectivity)
apply (simp only: iso2 Nat2nat_add Nat2nat_mul)
apply (arith)
apply (subst nat2Nat_lt)
apply (rule mod_less_divisor)
apply (arith)
done

theorem Nat2nat_div : " y ~= 0' ==> Nat2nat(makeTotal (x div' y)) = Nat2nat(x) div Nat2nat(y)"
apply (frule iso1_negated1)
apply (subst (asm) Nat2nat_0)
apply (rule nat2Nat_injectivity)
apply (simp)
done

theorem nat2Nat_mod [simp] : "~(y = 0) ==> nat2Nat(x mod y) =makeTotal (nat2Nat(x) mod' nat2Nat(y))"
apply (rule sym)
apply (rule makepartial_intro_weak)
(*apply (subst nat2Nat_mod_mp[rule_format,THEN sym])*)
apply (simp)
apply (subst mod_Nat)
apply (rule_tac x="nat2Nat (x div y)" in exI)
apply (rule conjI)
apply (subst nat2Nat_mul[rule_format,THEN sym])
apply (subst nat2Nat_add[rule_format,THEN sym])
apply (rule_tac f="nat2Nat" in arg_cong)
apply (simp)
apply (subst Nat2nat_lt[THEN sym])
apply (simp only: iso2)
apply (rule mod_less_divisor)
apply (auto)
done

theorem Nat2nat_mod : "~(y = 0') ==>  Nat2nat (makeTotal (x mod' y)) = (Nat2nat(x) mod Nat2nat(y))"
apply (frule iso1_negated1)
apply (subst (asm) Nat2nat_0)
apply (rule nat2Nat_injectivity)
apply (simp)
done

theorem nat2Nat_pdiv : "[|~ y = 0 ; x mod y = 0|] ==> nat2Nat(makeTotal(x /?? y)) =makeTotal(nat2Nat(x) /? nat2Nat(y))"
apply (rule sym)
apply (rule makepartial_intro_weak)
apply (subst divide_Nat_Nat)
apply (subst Nat2nat_gt[THEN sym])
apply (simp)
apply (rule Nat2nat_injectivity)
apply (simp only: Nat2nat_mul iso2)
apply (subst part_div_def)
apply (simp)
apply (auto)
done

theorem Nat2nat_pdiv : "[|~ y = 0' ; x mod' y = makePartial 0'|] ==> Nat2nat(makeTotal(x /? y)) =makeTotal(Nat2nat(x) /?? Nat2nat(y))"
apply (drule iso1_negated1)
apply (subst (asm) Nat2nat_0)
apply (drule_tac f="%x. makeTotal(x)" in arg_cong)
apply (drule_tac f="%x. Nat2nat(x)" in arg_cong)
apply (simp only: makePartialproj)
apply (subst (asm) Nat2nat_mod)
apply (rule Nat2nat_injectivity_negated)
apply (simp)
apply (simp  only: makePartialproj Nat2nat_0 Nat2nat_mod)
apply (rule nat2Nat_injectivity)
apply (drule nat2Nat_pdiv)
apply (simp)
apply (simp)
done

theorem nat2Nat_pminus : "(x >= y) ==> nat2Nat(makeTotal (x -?? y)) = makeTotal(nat2Nat(x) -? nat2Nat(y))"
apply (rule sym)
apply (rule makepartial_intro_weak)
apply (subst sub_def_Nat)
apply (rule Nat2nat_injectivity)
apply (simp only: Nat2nat_add iso2)
apply (subst part_minus_def)
apply (simp add: makePartialproj)
done

theorem Nat2nat_pminus : "(x >=' y) ==> Nat2nat(makeTotal(x -? y)) = makeTotal(Nat2nat(x) -?? Nat2nat(y))"
apply (subst (asm) Nat2nat_gt_equal[THEN sym])
apply (rule nat2Nat_injectivity)
apply (subst nat2Nat_pminus)
apply (simp)
apply (simp)
done

end


(*<*)
theory SPRView
imports
  KBPsAuto
begin
(*>*)

subsection{* The Synchronous Perfect-Recall View *}

text{*

\label{sec:kbps-theory-pr-view}

The synchronous perfect-recall (SPR) view records all observations the
agent has made on a given trace. This is the canonical
full-information synchronous view; all others are functions of this
one.

Intuitively it maintains a list of all observations made on the trace,
with the length of the list recording the time:

*}

definition (in Environment) spr_jview :: "('a, 's, 'obs Trace) JointView" where
  "spr_jview a = tMap (envObs a)"
(*<*)

context Environment
begin

lemma spr_jview_length_eq:
  "tLength (spr_jview a t) = tLength t"
  by (simp add: spr_jview_def)

lemma spr_jview_tInit_inv[simp]:
  "spr_jview a t = tInit obs \<longleftrightarrow> (\<exists>s. t = tInit s \<and> envObs a s = obs)"
  by (cases t) (simp_all add: spr_jview_def)

lemma spr_jview_tStep_eq_inv:
  "spr_jview a t' = spr_jview a (t \<leadsto> s) \<Longrightarrow> \<exists>t'' s'. t' = t'' \<leadsto> s'"
  by (cases t') (simp_all add: spr_jview_def)

lemma spr_jview_prefix_closed[dest]:
  "spr_jview a (t \<leadsto> s) = spr_jview a (t' \<leadsto> s') \<Longrightarrow> spr_jview a t = spr_jview a t'"
  by (simp add: spr_jview_def)

end

(*>*)
text{*

The corresponding incremental view appends a new observation to the
existing ones:

*}

definition (in Environment) spr_jviewInit :: "'a \<Rightarrow> 'obs \<Rightarrow> 'obs Trace" where
  "spr_jviewInit \<equiv> \<lambda>a obs. tInit obs"

definition (in Environment)
  spr_jviewIncr :: "'a \<Rightarrow> 'obs \<Rightarrow> 'obs Trace \<Rightarrow> 'obs Trace"
where
  "spr_jviewIncr \<equiv> \<lambda>a obs' tobs. tobs \<leadsto> obs'"

sublocale Environment
        < SPR!: IncrEnvironment jkbp envInit envAction envTrans envVal
                spr_jview envObs spr_jviewInit spr_jviewIncr
(*<*)
proof
  { fix a t t' assume "spr_jview a t = spr_jview a t'"
    hence "tLength t = tLength t'"
      using spr_jview_length_eq[where a=a, symmetric] by simp }
  thus "\<forall>a t t'. spr_jview a t = spr_jview a t' \<longrightarrow> tLength t = tLength t'"
    by blast
next
  show "\<forall>a s. spr_jviewInit a (envObs a s) = spr_jview a (tInit s)"
    unfolding spr_jviewInit_def by (simp add: spr_jview_def)
next
  show "\<forall>a t s. spr_jview a (t \<leadsto> s) = spr_jviewIncr a (envObs a s) (spr_jview a t)"
    unfolding spr_jviewIncr_def by (simp add: spr_jview_def)
qed

(* These need to follow the locale instantiation as we appeal to
sync. *)

lemma (in Environment) spr_tFirst[dest]:
  assumes v: "spr_jview a t = spr_jview a t'"
  shows "envObs a (tFirst t) = envObs a (tFirst t')"
  using SPR.sync[rule_format, OF v] v
  apply (induct rule: trace_induct2)
  apply (simp_all add: spr_jview_def)
  done

lemma (in Environment) spr_tLast[dest]:
  assumes v: "spr_jview a t = spr_jview a t'"
  shows "envObs a (tLast t) = envObs a (tLast t')"
  using SPR.sync[rule_format, OF v] v
  apply (induct rule: trace_induct2)
  apply (simp_all add: spr_jview_def)
  done

(*>*)

text{*

\citet[Theorem~5]{Ron:1996} showed that it is not the case that
finite-state implementations always exist with respect to the SPR
view, and so we consider three special cases:
\begin{itemize}

\item[\S\ref{sec:kbps-spr-single-agent}] where there is a single
agent;

\item[\S\ref{sec:kbps-theory-spr-deterministic-protocols}] when the
protocols of the agents are deterministic and communication is by
broadcast; and

\item[\S\ref{sec:kbps-theory-spr-non-deterministic-protocols}] when
the agents use non-deterministic protocols and again use broadcast to
communicate.

\end{itemize}
Note that these cases do overlap but none is wholly
contained in another.

*}

(*<*)
end
(*>*)