theory IMP_Minus_To_SAT_Nat
  imports IMP_Minus_To_SAS_Plus_Nat IMP_Minus_To_SAT SAT_Plan_Base_Nat SAS_Plus_Strips_Nat
          Cook_Levin.Primitives
begin

fun poly_of :: "nat*nat \<Rightarrow> nat \<Rightarrow> nat" where
"poly_of (a,0) x = a"|
"poly_of (a,Suc n) x = x * poly_of (a,n) x"

lemma mono_poly_of: "mono (poly_of p)"
  apply (auto simp add:incseq_def)
  apply (cases p)
  subgoal for m n a b
    apply auto
    apply(induct b arbitrary: p)
     apply auto
    using mult_le_mono by presburger
  done

lemma make_mono_mono_apply:"mono f \<Longrightarrow> make_mono f x = f x"
  apply(induct x)
   apply (auto simp add:incseq_def make_mono_def)
  by (simp add: antisym)

lemma make_mono_mono: "mono f \<Longrightarrow> make_mono f =f"
  using make_mono_mono_apply by blast

lemma sub_make_mono: "make_mono (poly_of p) = poly_of p"
  using mono_poly_of  make_mono_mono
  by presburger

definition t'_pair :: "(nat*nat) \<Rightarrow> (nat*nat) \<Rightarrow> nat \<Rightarrow> nat" where
"t'_pair pt p_cer x = poly_of pt (bit_length x + poly_of p_cer (bit_length x)) + 1"

lemma subpair_t':
"t'_pair pt p_cer x = t' (poly_of pt) (poly_of p_cer) x"
  apply (auto simp add: t'_pair_def t'_def sub_make_mono)
  done
lemma [termination_simp]: "0 < snd_nat p \<Longrightarrow> prod_encode (fst_nat p, snd_nat p - Suc 0) < p"
proof-
  assume asm: "0 < snd_nat p"
  obtain a b where "p = prod_encode(a,b)"
    by (metis prod_decode_aux.cases prod_decode_inverse)
  thus ?thesis using asm apply (auto simp add:sub_fst sub_snd) apply (auto simp add: prod_encode_def)
    by (metis Groups.add_ac(2) Suc_pred add_diff_cancel_left' le_add1 linorder_not_less not_less_eq_eq plus_nat.simps(2) triangle_Suc)
qed

fun poly_of_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"poly_of_nat p x = (if snd_nat p = 0 then fst_nat p else x * poly_of_nat (prod_encode (fst_nat p,snd_nat p -1)) x)"

fun poly_of_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"poly_of_acc acc p x = (if snd_nat p = 0 then acc else poly_of_acc  (x *acc) (prod_encode (fst_nat p,snd_nat p -1)) x)"

lemma sub_poly_of: "poly_of_nat (prod_encode p) x = poly_of p x"
  apply (cases p)
  apply (auto simp only:)
  subgoal for a b
    apply (induct b arbitrary:p)
     apply (subst poly_of_nat.simps)
    apply (auto simp add: sub_fst sub_snd simp del:poly_of_nat.simps)
     apply (subst poly_of_nat.simps)
    apply (auto simp add: sub_fst sub_snd simp del:poly_of_nat.simps)
    done
  done

lemma poly_of_induct:
"poly_of_acc acc p x = poly_of_nat (prod_encode (acc,snd_nat p)) x"
proof -

  obtain a n where p_def:"p = prod_encode (a,n)"
    by (metis prod_decode_inverse surj_pair)
   have helper:"\<forall>m acc. poly_of (x * acc,m) x = x * poly_of (acc,m) x"
     apply auto subgoal for m acc
        apply(induct m) apply auto done done
   from p_def show ?thesis apply(auto simp only: sub_snd snd_conv sub_poly_of)
    apply (induct n arbitrary: p  acc a)
     apply(subst poly_of_acc.simps)
     apply(auto simp add: sub_snd simp del: poly_of_acc.simps)
     apply(subst poly_of_acc.simps)
    apply(auto simp add: helper sub_fst sub_snd simp del: poly_of_acc.simps)
     done

qed

definition poly_of_tail :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"poly_of_tail p x = poly_of_acc (fst_nat p) p x"

lemma subtail_poly_of:
"poly_of_tail p x = poly_of_nat p x"
  by (metis add.right_neutral add_eq_if poly_of.simps(1)
 poly_of.simps(2) poly_of_induct poly_of_nat.simps poly_of_tail_def sub_poly_of)

definition t'_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"t'_nat pt p_cer x = poly_of_nat pt (bit_length x + poly_of_nat p_cer (bit_length x)) + 1"

definition t'_tail :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"t'_tail pt p_cer x = poly_of_tail pt (bit_length x + poly_of_tail p_cer (bit_length x)) + 1"

lemma subtail_t':
"t'_tail pt p_cer x = t'_nat pt p_cer x"
  using subtail_poly_of t'_nat_def t'_tail_def by presburger

lemma subnat_t':
"t'_nat (prod_encode pt) (prod_encode p_cer) x = t'_pair pt p_cer x"
  apply (auto simp only:t'_nat_def t'_pair_def sub_poly_of)
  done

definition "empty_sasp_action_nat \<equiv> (0 ## 0 ## 0)"
lemma sub_empty_sasp_action: "empty_sasp_action_nat = operator_plus_encode empty_sasp_action"
  apply (auto simp only:cons0 sub_cons
        empty_sasp_action_nat_def empty_sasp_action_def operator_plus_encode_def list_encode_eq
            sas_plus_assignment_list_encode_def
        simp flip: list_encode.simps)
   apply auto
  done
definition "empty_sasp_action_tail \<equiv> (0 ## 0 ## 0)"
lemma subtail_empty_sasp_action:
"empty_sasp_action_tail =empty_sasp_action_nat"
  using empty_sasp_action_nat_def empty_sasp_action_tail_def by force

definition
  "prob_with_noop_list \<Pi> \<equiv>
     \<lparr> variables_ofl = variables_ofl \<Pi>,
      operators_ofl = empty_sasp_action # operators_ofl \<Pi>,
      initial_ofl = initial_ofl \<Pi>,
      goal_ofl = goal_ofl \<Pi>,
      range_ofl = range_ofl \<Pi>\<rparr>"

lemma sublist_prob_with_noop:
"list_problem_to_problem (prob_with_noop_list \<Pi>) = prob_with_noop  (list_problem_to_problem \<Pi>)"
  apply (auto simp add: prob_with_noop_list_def prob_with_noop_def)
  done

definition prob_with_noop_nat :: "nat \<Rightarrow> nat" where
  "prob_with_noop_nat p = (nth_nat 0 p) ## ( empty_sasp_action_nat ##  (nth_nat (Suc 0) p))
## (tl_nat (tl_nat p))"

definition prob_with_noop_tail :: "nat \<Rightarrow> nat" where
  "prob_with_noop_tail p = (nth_nat 0 p) ## ( empty_sasp_action_tail ##  (nth_nat (Suc 0) p))
## (tl_nat (tl_nat p))"

lemma subtail_prob_with_noop:
"prob_with_noop_tail p =prob_with_noop_nat p"
  using prob_with_noop_nat_def prob_with_noop_tail_def subtail_empty_sasp_action by presburger

lemma subnat_prob_with_noop:
"prob_with_noop_nat (list_problem_plus_encode p) =
 list_problem_plus_encode (prob_with_noop_list p)"
  apply (auto simp only: prob_with_noop_nat_def sub_cons list_problem_plus_encode_def
            sub_tl tail.simps sub_nth nth.simps prob_with_noop_list_def sas_plus_list_problem.simps
            sub_empty_sasp_action)
  apply auto
  done

definition encode_interfering_operator_pair_exclusion_list
  :: "'variable strips_list_problem
    \<Rightarrow> nat
    \<Rightarrow> 'variable strips_operator
    \<Rightarrow> 'variable strips_operator
    \<Rightarrow> sat_plan_variable formula"
  where "encode_interfering_operator_pair_exclusion_list \<Pi> k op\<^sub>1 op\<^sub>2
    \<equiv> let ops = operators_of \<Pi> in
      \<^bold>\<not>(Atom (Operator k (index ops op\<^sub>1)))
      \<^bold>\<or> \<^bold>\<not>(Atom (Operator k (index ops op\<^sub>2)))"

lemma sublist_encode_interfering_operator_pair_exclusion:
"encode_interfering_operator_pair_exclusion_list \<Pi> k op\<^sub>1 op\<^sub>2
= encode_interfering_operator_pair_exclusion (strips_list_problem_to_problem \<Pi>) k op\<^sub>1 op\<^sub>2
"
  apply (auto simp add:encode_interfering_operator_pair_exclusion_list_def
encode_interfering_operator_pair_exclusion_def)
  done

definition encode_interfering_operator_pair_exclusion_nat
  :: "nat
    \<Rightarrow> nat
    \<Rightarrow> nat
    \<Rightarrow> nat
    \<Rightarrow> nat"
  where "encode_interfering_operator_pair_exclusion_nat p k o1 o2
    \<equiv> let ops = nth_nat (Suc 0)  p in
     4 ## (2 ## (1 ## (1 ## k ## (index_nat ops o1)## 0) ## 0) ## 0)
      ## (2 ## (1 ## (1  ## k ## (index_nat ops o2) ## 0) ## 0) ## 0) ## 0"
definition encode_interfering_operator_pair_exclusion_tail :: "nat
    \<Rightarrow> nat
    \<Rightarrow> nat
    \<Rightarrow> nat
    \<Rightarrow> nat" where
"encode_interfering_operator_pair_exclusion_tail p k o1 o2 =
encode_interfering_operator_pair_exclusion_nat p k o1 o2 "

lemma subtail_encode_interfering_operator_pair_exclusion:
"encode_interfering_operator_pair_exclusion_tail p k o1 o2 =
encode_interfering_operator_pair_exclusion_nat p k o1 o2 "
  using encode_interfering_operator_pair_exclusion_tail_def by presburger

lemma subnat_encode_interfering_operator_pair_exclusion:
"encode_interfering_operator_pair_exclusion_nat (strips_list_problem_encode p) k
 (strips_operator_encode o1) (strips_operator_encode o2) =
sat_formula_encode (encode_interfering_operator_pair_exclusion_list p k o1 o2)"
  using inj_strips_op
  apply(auto simp only: encode_interfering_operator_pair_exclusion_nat_def
    strips_list_problem_encode.simps sub_nth nth.simps strips_operator_list_encode_def
      sub_index Let_def sub_cons cons0 encode_interfering_operator_pair_exclusion_list_def
 simp flip: sat_variable_encode.simps sat_formula_encode.simps
)
  done

declare elemof.simps [simp del]
fun list_inter :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"list_inter xs ys = (if xs = 0 then 0
else if elemof (hd_nat xs) ys \<noteq> 0 then 1 else list_inter (tl_nat xs) ys)"

definition list_inter_tail ::  "nat \<Rightarrow> nat \<Rightarrow> nat" where
"list_inter_tail xs ys = list_inter xs ys"

lemma subtail_list_inter:
"list_inter_tail xs ys = list_inter xs ys"
  using list_inter_tail_def by presburger

lemma list_encode_pos:"(list_encode xs > 0) = (xs \<noteq> []) "
  using list_encode_empty by force

lemma sub_list_inter:
"inj f \<Longrightarrow> list_inter (list_encode (map f xs)) (list_encode (map f ys)) \<noteq> 0
= list_ex (\<lambda>v. list_ex ((=) v) xs ) ys"
  apply (induct xs)
   apply (simp)
   apply (induct ys)
    apply simp
   apply simp
  apply (subst list_inter.simps)
  apply (simp add: sub_hd sub_tl tail.simps  head.simps list.simps list_encode_empty list_encode_pos
      del:list_encode.simps list_inter.simps)
  using sub_elem_of_inj[of f] apply (auto simp  del:list_encode.simps list_inter.simps)
  apply (metis (no_types, lifting) Bex_set)
    apply (metis (no_types, lifting) Bex_set)
  using Bex_set apply fastforce
 using sub_elem_of_inj[of f]
  by (smt (z3) Bex_set)

definition are_operators_interfering_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"are_operators_interfering_nat o1 o2 \<equiv>
if list_inter (nth_nat (Suc (Suc 0)) o1) (nth_nat 0 o2) \<noteq> 0  \<or>
    list_inter (nth_nat 0 o1) (nth_nat (Suc (Suc 0)) o2) \<noteq> 0 then 1 else 0 "

definition are_operators_interfering_tail :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"are_operators_interfering_tail o1 o2 \<equiv>
if list_inter_tail (nth_nat (Suc (Suc 0)) o1) (nth_nat 0 o2) \<noteq> 0  \<or>
    list_inter_tail (nth_nat 0 o1) (nth_nat (Suc (Suc 0)) o2) \<noteq> 0 then 1 else 0 "
lemma subtail_are_operators_interfering:
"are_operators_interfering_tail o1 o2 = are_operators_interfering_nat o1 o2"
  using are_operators_interfering_nat_def are_operators_interfering_tail_def
list_inter_tail_def by presburger

lemma sub_are_operators_interfering:
"(are_operators_interfering_nat (strips_operator_encode o1) (strips_operator_encode o2) > 0) =
 (are_operators_interfering o1 o2)"
  using inj_sasp
  apply (auto simp only: are_operators_interfering_nat_def strips_operator_encode.simps
          sub_nth nth.simps sas_plus_assignment_list_encode_def
            sub_list_inter are_operators_interfering_def)
    apply auto
  apply presburger
  done

definition encode_interfering_operator_exclusion_list
  :: "'variable strips_list_problem \<Rightarrow> nat \<Rightarrow> sat_plan_variable formula"
  where "encode_interfering_operator_exclusion_list \<Pi> t \<equiv> let
      ops = operators_of \<Pi>
      ; interfering = filter (\<lambda>(op\<^sub>1, op\<^sub>2). index ops op\<^sub>1 \<noteq> index ops op\<^sub>2
        \<and> are_operators_interfering op\<^sub>1 op\<^sub>2) (List.product ops ops)
    in BigAnd (concat (map (\<lambda>(op\<^sub>1, op\<^sub>2). map (\<lambda>k. encode_interfering_operator_pair_exclusion_list \<Pi> k op\<^sub>1 op\<^sub>2)
      [0..<t]) interfering ))"

lemma sublist_encode_interfering_operator_exclusion:
"encode_interfering_operator_exclusion_list \<Pi> t
= encode_interfering_operator_exclusion (strips_list_problem_to_problem \<Pi>) t "
  apply (auto simp add:encode_interfering_operator_exclusion_list_def
encode_interfering_operator_exclusion_def
    sub_foldr sublist_encode_interfering_operator_pair_exclusion
)
  done
fun filter_interfering:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"filter_interfering ops xs = (if xs = 0 then 0 else if index_nat ops (fst_nat (hd_nat xs)) \<noteq> index_nat ops (snd_nat (hd_nat xs))
        \<and> are_operators_interfering_nat (fst_nat (hd_nat xs)) (snd_nat (hd_nat xs)) \<noteq> 0 then (hd_nat xs) ## filter_interfering ops (tl_nat xs) else  filter_interfering ops (tl_nat xs))"

fun filter_interfering_acc:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"filter_interfering_acc acc ops xs = (if xs = 0 then acc else if index_nat ops (fst_nat (hd_nat xs)) \<noteq> index_nat ops (snd_nat (hd_nat xs))
        \<and> are_operators_interfering_tail (fst_nat (hd_nat xs)) (snd_nat (hd_nat xs)) \<noteq> 0 then filter_interfering_acc ((hd_nat xs) ## acc) ops (tl_nat xs) else  filter_interfering_acc acc ops (tl_nat xs))"

lemma filter_interfering_induct:
"filter_interfering_acc acc ops xs  = filter_acc  (\<lambda>n. index_nat ops (fst_nat n) \<noteq> index_nat ops (snd_nat n)
        \<and> are_operators_interfering_nat (fst_nat n) (snd_nat n) \<noteq> 0 ) acc xs "
  apply(induct acc ops xs rule:filter_interfering_acc.induct)
  apply (auto simp add:subtail_are_operators_interfering)
  done

lemma subfilter_interfering:
"filter_interfering ops xs = filter_nat (\<lambda>n. index_nat ops (fst_nat n) \<noteq> index_nat ops (snd_nat n)
        \<and> are_operators_interfering_nat (fst_nat n) (snd_nat n) \<noteq> 0 ) xs"
  apply (induct ops xs rule:filter_interfering.induct)
  apply (auto simp del:index_nat.simps)
  done

definition filter_interfering_tail :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"filter_interfering_tail ops xs = reverse_nat (filter_interfering_acc 0 ops xs )  "

lemma subtail_filter_interfering:
"filter_interfering_tail ops xs = filter_interfering ops xs "
  using filter_interfering_induct filter_interfering_tail_def subfilter_interfering subtail_filter
  by presburger

fun map_encode_interfering :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_encode_interfering p n xs = (if xs = 0 then 0 else (encode_interfering_operator_pair_exclusion_nat p (hd_nat xs) (fst_nat n) (snd_nat n))
## map_encode_interfering p n (tl_nat xs))"
lemma submap_encode_interfering:
"map_encode_interfering p n xs = map_nat (\<lambda>k. encode_interfering_operator_pair_exclusion_nat p k (fst_nat n) (snd_nat n)) xs "
  apply (induct p n xs rule: map_encode_interfering.induct)
  apply auto
  done
fun map_encode_interfering_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_encode_interfering_acc acc  p n xs = (if xs = 0 then acc else
map_encode_interfering_acc ((encode_interfering_operator_pair_exclusion_nat p (hd_nat xs) (fst_nat n) (snd_nat n))
## acc) p n (tl_nat xs))"

lemma map_encode_interfering_induct:
"map_encode_interfering_acc acc  p n xs = map_acc
(\<lambda>k. encode_interfering_operator_pair_exclusion_tail p k (fst_nat n) (snd_nat n)) acc xs"
  apply(induct acc p n xs rule:map_encode_interfering_acc.induct)
  apply (auto simp add:subtail_encode_interfering_operator_pair_exclusion)
  done

fun map_map_encode_interfering :: "nat \<Rightarrow>nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_map_encode_interfering \<Pi> t xs = (if xs = 0 then 0 else
(map_encode_interfering  \<Pi> (hd_nat xs) (list_less_nat t)) ## map_map_encode_interfering \<Pi> t (tl_nat xs)
) "

fun map_map_encode_interfering_acc :: "nat \<Rightarrow> nat \<Rightarrow>nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_map_encode_interfering_acc acc \<Pi> t xs = (if xs = 0 then acc else  map_map_encode_interfering_acc(
(map_encode_interfering  \<Pi> (hd_nat xs) (list_less_nat t)) ## acc) \<Pi> t (tl_nat xs)
) "

lemma map_map_encode_interfering_induct:
"map_map_encode_interfering_acc acc \<Pi> t xs = map_acc (\<lambda>n. map_encode_interfering  \<Pi> n
      (list_less_nat t) ) acc xs "
  apply(induct acc \<Pi> t xs rule: map_map_encode_interfering_acc.induct)
  apply auto
  done

lemma submap_map_encode_interfering:
"map_map_encode_interfering \<Pi> t xs = map_nat (\<lambda>n. map_encode_interfering  \<Pi> n
      (list_less_nat t) ) xs "
  apply (induct  \<Pi> t xs rule: map_map_encode_interfering.induct)
  apply auto
  done

definition map_map_encode_interfering_tail :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_map_encode_interfering_tail \<Pi> t xs = reverse_nat (map_map_encode_interfering_acc 0 \<Pi> t xs)"

lemma subtail_map_map_encode_interfering:
"map_map_encode_interfering_tail \<Pi> t xs = map_map_encode_interfering \<Pi> t xs "
  using map_map_encode_interfering_induct map_map_encode_interfering_tail_def
 submap_map_encode_interfering subtail_map by presburger

definition encode_interfering_operator_exclusion_nat
  :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "encode_interfering_operator_exclusion_nat \<Pi> t \<equiv> let
      ops = nth_nat (Suc 0) \<Pi>
      ; interfering = filter_interfering ops (product_nat ops ops)
    in BigAnd_nat (concat_nat (map_map_encode_interfering \<Pi> t interfering ))"

definition encode_interfering_operator_exclusion_tail
  :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "encode_interfering_operator_exclusion_tail \<Pi> t \<equiv> let
      ops = nth_nat (Suc 0) \<Pi>
      ; interfering = filter_interfering_tail ops (product_tail ops ops)
    in BigAnd_tail (concat_tail (map_map_encode_interfering_tail \<Pi> t interfering ))"

lemma subtail_encode_interfering_operator_exclusion:
"encode_interfering_operator_exclusion_tail p t = encode_interfering_operator_exclusion_nat p t "
  using encode_interfering_operator_exclusion_nat_def encode_interfering_operator_exclusion_tail_def
 subtail_BigAnd subtail_concat subtail_filter_interfering subtail_map_map_encode_interfering
subtail_product by presburger

lemma subnat_encode_interfering_operator_exclusion :
"encode_interfering_operator_exclusion_nat (strips_list_problem_encode p) t =
sat_formula_encode (encode_interfering_operator_exclusion_list p t)"
  using inj_strips_op
  apply (auto simp only: encode_interfering_operator_exclusion_nat_def
subfilter_interfering submap_encode_interfering submap_map_encode_interfering
strips_list_problem_encode.simps sub_nth nth.simps Let_def strips_operator_list_encode_def
sub_product sub_filter filter_map
         )
  apply (auto simp add: Fun.comp_def prod.case_eq_if sub_fst sub_snd simp del: list_encode.simps
          BigAnd_nat.simps concat_nat.simps index_nat.simps strips_operator_encode.simps
        map_nat.simps simp flip: strips_operator_list_encode_def  strips_list_problem_encode.simps)
  apply (auto simp only:  strips_operator_list_encode_def sub_index sub_are_operators_interfering
      sub_map map_map Fun.comp_def  prod.case_eq_if  sub_fst sub_snd fst_conv snd_conv sub_list_less
            subnat_encode_interfering_operator_pair_exclusion
            )
  apply (auto simp only: sub_concat  simp flip: Fun.comp_def[of list_encode "\<lambda>x.
    (map (\<lambda>k. sat_formula_encode
                (encode_interfering_operator_pair_exclusion_list p k (fst x) (snd x)))
                       [0..<t])" ] map_map map_concat)
  apply (auto simp only: simp flip: Fun.comp_def[of sat_formula_encode
            "\<lambda>k. encode_interfering_operator_pair_exclusion_list p k (fst _) (snd _)"] map_map
)
  apply (auto simp only: case_prod_beta' sub_BigAnd encode_interfering_operator_exclusion_list_def split_comp_eq
      Let_def simp flip: Fun.comp_def[of "map sat_formula_encode"
"\<lambda>x. (map (\<lambda>k. encode_interfering_operator_pair_exclusion_list p k (fst x) (snd x))
                       [0..<t])"] map_map map_concat sat_formula_list_encode_def split_comp_eq)
  done

definition encode_problem_with_operator_interference_exclusion_list
  :: "'variable strips_list_problem \<Rightarrow> nat \<Rightarrow> sat_plan_variable formula"
  where "encode_problem_with_operator_interference_exclusion_list \<Pi> t
    \<equiv> encode_initial_state_list \<Pi>
      \<^bold>\<and> (encode_operators_list \<Pi> t
      \<^bold>\<and> (encode_all_frame_axioms_list \<Pi> t
      \<^bold>\<and> (encode_interfering_operator_exclusion_list \<Pi> t
      \<^bold>\<and> (encode_goal_state_list \<Pi> t))))"

definition encode_problem_with_operator_interference_exclusion_nat
  :: "nat\<Rightarrow> nat \<Rightarrow> nat"
  where "encode_problem_with_operator_interference_exclusion_nat \<Pi> t
    \<equiv> 3 ## (encode_initial_state_nat \<Pi>)
      ## (3 ## (encode_operators_nat \<Pi> t)
      ## (3 ## (encode_all_frame_axioms_nat \<Pi> t)
      ## (3 ## (encode_interfering_operator_exclusion_nat \<Pi> t)
      ## (encode_goal_state_nat \<Pi> t) ## 0) ## 0 )## 0) ## 0"

definition encode_problem_with_operator_interference_exclusion_tail
  :: "nat\<Rightarrow> nat \<Rightarrow> nat"
  where "encode_problem_with_operator_interference_exclusion_tail \<Pi> t
    \<equiv> 3 ## (encode_initial_state_tail \<Pi>)
      ## (3 ## (encode_operators_tail \<Pi> t)
      ## (3 ## (encode_all_frame_axioms_tail \<Pi> t)
      ## (3 ## (encode_interfering_operator_exclusion_tail \<Pi> t)
      ## (encode_goal_state_tail \<Pi> t) ## 0) ## 0 )## 0) ## 0"

lemma subtail_encode_problem_with_operator_interference_exclusion:
"encode_problem_with_operator_interference_exclusion_tail \<Pi> t =
 encode_problem_with_operator_interference_exclusion_nat \<Pi> t"
  using encode_problem_with_operator_interference_exclusion_nat_def
 encode_problem_with_operator_interference_exclusion_tail_def subtail_encode_all_frame_axioms
 subtail_encode_goal_state subtail_encode_initial_state subtail_encode_interfering_operator_exclusion
subtail_encode_operators by presburger

lemma subnat_encode_problem_with_operator_interference_exclusion:
"encode_problem_with_operator_interference_exclusion_nat (strips_list_problem_encode \<Pi>) t =
sat_formula_encode (encode_problem_with_operator_interference_exclusion_list \<Pi> t)"
  apply (auto simp only:encode_problem_with_operator_interference_exclusion_nat_def
    sub_cons cons0 subnat_encode_initial_state subnat_encode_operators subnat_encode_all_frame_axioms
subnat_encode_interfering_operator_exclusion subnat_encode_goal_state simp flip: sat_formula_encode.simps
    encode_problem_with_operator_interference_exclusion_list_def
)
  done

lemma sublist_encode_problem_with_operator_interference_exclusion:
"encode_problem_with_operator_interference_exclusion_list \<Pi> t
= encode_problem_with_operator_interference_exclusion (strips_list_problem_to_problem \<Pi>) t"
  apply (auto simp only: encode_problem_with_operator_interference_exclusion_list_def
encode_problem_with_operator_interference_exclusion_def
    sublist_encode_initial_state sublist_encode_operators sublist_encode_all_frame_axioms
    sublist_encode_interfering_operator_exclusion
    sublist_encode_goal_state
)
  done

 definition imp_to_sat_list :: "Com.com \<Rightarrow> (nat*nat) \<Rightarrow> (nat*nat) \<Rightarrow> nat \<Rightarrow> sat_plan_formula" where
    "imp_to_sat_list c pt p_cer x =
      (let I = [(''input'', x)];
          G = [(''input'',0)];
          guess_range = x + 1 + 2 * 2 ^ (poly_of p_cer (bit_length x));
          max_bits = max_input_bits_list c I guess_range
      in
        encode_problem_with_operator_interference_exclusion_list
        (sas_plus_problem_to_strips_problem_list (prob_with_noop_list (IMP_Minus_to_SAS_Plus_list c I guess_range G (t'_pair pt p_cer x))))
           (100 * (max_bits + (t'_pair pt p_cer x) + 1) * ((t'_pair pt p_cer x) - 1) +
             (max_bits + (t'_pair pt p_cer x) + 2) * (num_variables c + 2) + 52))"

lemma sublist_imp_to_sat:
"imp_to_sat_list c pt p_cer x
= imp_to_sat c (poly_of pt) (poly_of p_cer) x"
  apply (auto simp only: imp_to_sat_list_def sublist_encode_problem_with_operator_interference_exclusion
              sublist_sas_plus_problem_to_strips_problem sublist_prob_with_noop  sublist_max_input_bits
                  subpair_t' imp_to_sat_def Let_def)
  using sublist_IMP_Minus_to_SAS_Plus[of " [(''input'', x)]"] sublist_max_input_bits[of " [(''input'', x)]"]
  apply (auto)
  done

lemma poly_poly_of:"poly (poly_of p)"
  apply(cases p)
  subgoal for a b
  proof (induct b arbitrary:p)
    case 0
    then have "poly_of p = (\<lambda>_.a)" using poly_of.simps(1) by presburger
    then show ?case by auto
  next
    case (Suc b)
    then obtain p' where p'_def: "p' = poly_of (a,b)" by blast
    then have "poly p'" using Suc by simp
    moreover have "poly_of p = (\<lambda>x. (p' x *x))" using Suc p'_def by force
    ultimately show ?case apply auto
      using poly_linear poly_mult by presburger
  qed
  done

lemma main_lemma_hol_list:
  fixes c pt p_cer in_lang
  assumes verifier_tbounded:
  (*Mohammad: I don't think we need the time to bounded by the cert length since the cert length
              is bounded by input length.*)
    "\<And>s. \<exists>t s'. (c, s) \<Rightarrow>\<^bsup> t \<^esup> s' \<and>
                   t \<le> poly_of pt (bit_length (s ''input''))"
  assumes verifier_terminates:
          (*"\<And>x z. \<forall>s. s ''input'' = x \<and> s ''certificate'' = z \<longrightarrow>
                         (\<exists>t s'. (c, s) \<Rightarrow>\<^bsup> t \<^esup> s' \<and> s' ''input'' = in_lang x)"*)
          (*Mohammad: The TM needs no access to the certificate since it is non-deterministic, i.e. it can
            assume it is guessed.*)
          (*Mohammad: The computation output should depend on the state, otherwise the theorem
                      statement does not hold*)
          (*Mohammad: We need to specify what it means for c to be a verifier for the certificates*)
          "\<And>x s. \<lbrakk>in_lang x = 0 ; s ''input'' = x\<rbrakk> \<Longrightarrow>
                    (\<exists>z t s'. bit_length z \<le> poly_of p_cer (bit_length x) \<and>
                              (c, s(''certificate'' := z)) \<Rightarrow>\<^bsup> t \<^esup> s' \<and>
                              s' ''input'' = in_lang x)"
          "\<And>x s s' t. \<lbrakk>in_lang x \<noteq> 0; s ''input'' = x; (c, s) \<Rightarrow>\<^bsup> t \<^esup> s'\<rbrakk> \<Longrightarrow>
                         s' ''input'' = in_lang x"
  assumes verifier_has_registers:
    "''input'' \<in> set (Max_Constant.all_variables c)"
  shows "\<exists>t_red s_red.
         poly t_red
       \<and> poly s_red
       \<and> (\<forall>x. \<exists>f.  bit_length (encode_sat f) \<le> s_red ( bit_length x ) \<and> imp_to_sat_list c pt p_cer x = f
                   \<and> (Sema.sat {f}  \<longleftrightarrow> in_lang x = 0))"
  using main_lemma_hol poly_poly_of assms  by (auto simp add: sublist_imp_to_sat)

 definition imp_to_sat_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
    "imp_to_sat_nat c pt p_cer x =
      (let I = (prod_encode (vname_encode ''input'', x)) ## 0;
          G = (prod_encode (vname_encode ''input'', 0)) ## 0;
          guess_range = x + 1 + 2 * 2 ^ (poly_of_nat p_cer (bit_length x));
          max_bits = max_input_bits_nat c I guess_range
      in
        encode_problem_with_operator_interference_exclusion_nat
        (sas_plus_problem_to_strips_problem_nat (prob_with_noop_nat (IMP_Minus_to_SAS_Plus_nat c I guess_range G (t'_nat pt p_cer x))))
           (100 * (max_bits + (t'_nat pt p_cer x) + 1) * ((t'_nat pt p_cer x) - 1) +
             (max_bits + (t'_nat pt p_cer x) + 2) * (num_variables_nat c + 2) + 52))"

definition imp_to_sat_tail :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
    "imp_to_sat_tail c pt p_cer x =
      (let I = (prod_encode (vname_encode ''input'', x)) ## 0;
          G = (prod_encode (vname_encode ''input'', 0)) ## 0;
          guess_range = x + 1 + 2 * 2 ^ (poly_of_tail p_cer (bit_length x));
          max_bits = max_input_bits_tail c I guess_range
      in
        encode_problem_with_operator_interference_exclusion_tail
        (sas_plus_problem_to_strips_problem_tail (prob_with_noop_tail (IMP_Minus_to_SAS_Plus_tail c I guess_range G (t'_tail pt p_cer x))))
           (100 * (max_bits + (t'_tail pt p_cer x) + 1) * ((t'_tail pt p_cer x) - 1) +
             (max_bits + (t'_tail pt p_cer x) + 2) * (num_variables_tail c + 2) + 52))"

lemma subtail_imp_to_sat :
"imp_to_sat_tail c pt p_cer x = imp_to_sat_nat c pt p_cer x"
  apply(auto simp only: imp_to_sat_tail_def imp_to_sat_nat_def
subtail_poly_of subtail_max_input_bits subtail_encode_problem_with_operator_interference_exclusion
subtail_sas_plus_problem_to_strips_problem subtail_prob_with_noop subtail_IMP_Minus_to_SAS_Plus
subtail_t' subtail_num_variables
)
  done

lemma unfold_map_signleton:"[f x] = map f [x]"
  apply auto
  done

lemma subnat_imp_to_sat:
"imp_to_sat_nat (com_encode c) (prod_encode pt) (prod_encode p_cer) x =
sat_formula_encode (imp_to_sat_list c pt p_cer x)  "
  apply (auto simp only: imp_to_sat_nat_def Let_def
    cons0 sub_cons  unfold_map_signleton[of impm_assignment_encode]
sub_poly_of subnat_max_input_bits subnat_t' sub_num_variables subnat_IMP_Minus_to_SAS_Plus
subnat_prob_with_noop subnat_encode_problem_with_operator_interference_exclusion
simp flip: impm_assignment_encode.simps  impm_assignment_list_encode_def
)
proof -
  let ?P = "IMP_Minus_to_SAS_Plus_list c [(''input'', x)]
              (x + 1 + 2 * 2 ^ poly_of p_cer (Bit_Length.bit_length x)) [(''input'', 0)]
              (t'_pair pt p_cer x)"
  let ?P'= "IMP_Minus_to_SAS_Plus c (map_of [(''input'', x)])
              (x + 1 + 2 * 2 ^ poly_of p_cer (Bit_Length.bit_length x)) (map_of [(''input'', 0)])
              (t'_pair pt p_cer x)"
  have "list_problem_to_problem ?P = ?P'" using sublist_IMP_Minus_to_SAS_Plus by blast
  hence "is_valid_problem_sas_plus (list_problem_to_problem ?P)" using valid_problem by presburger
  hence "is_valid_problem_sas_plus (prob_with_noop (list_problem_to_problem ?P))" using noops_valid
    by fast
  hence "is_valid_problem_sas_plus (list_problem_to_problem (prob_with_noop_list ?P))"
    using sublist_prob_with_noop by metis
  thus "encode_problem_with_operator_interference_exclusion_nat
     (sas_plus_problem_to_strips_problem_nat
       (list_problem_plus_encode
         (prob_with_noop_list
           (IMP_Minus_to_SAS_Plus_list c [(''input'', x)]
             (x + 1 + 2 * 2 ^ poly_of p_cer (Bit_Length.bit_length x)) [(''input'', 0)]
             (t'_pair pt p_cer x)))))
     (100 *
      (max_input_bits_list c [(''input'', x)]
        (x + 1 + 2 * 2 ^ poly_of p_cer (Bit_Length.bit_length x)) +
       t'_pair pt p_cer x +
       1) *
      (t'_pair pt p_cer x - 1) +
      (max_input_bits_list c [(''input'', x)]
        (x + 1 + 2 * 2 ^ poly_of p_cer (Bit_Length.bit_length x)) +
       t'_pair pt p_cer x +
       2) *
      (num_variables c + 2) +
      52) =
    sat_formula_encode (imp_to_sat_list c pt p_cer x)"
    apply (auto simp only: subnat_sas_plus_problem_to_strips_problem Let_def
          subnat_encode_problem_with_operator_interference_exclusion imp_to_sat_list_def )
    done

qed

lemma inj_formula : "inj sat_formula_encode"
  apply (auto simp add: inj_def)
  using sat_formula_id by metis

lemma inj_formula_simp : "(sat_formula_encode x = sat_formula_encode y) = (x=y)"
  using inj_formula by (auto simp add:inj_def)
lemma main_lemma_hol_nat:
  fixes c and pt::"nat*nat" and p_cer::"nat*nat" and in_lang
  assumes verifier_tbounded:
    "\<And>s. \<exists>t s'. (c, s) \<Rightarrow>\<^bsup> t \<^esup> s' \<and>
                   t \<le> poly_of pt (bit_length (s ''input''))"
  assumes verifier_terminates:
          "\<And>x s. \<lbrakk>in_lang x = 0 ; s ''input'' = x\<rbrakk> \<Longrightarrow>
                    (\<exists>z t s'. bit_length z \<le> poly_of p_cer (bit_length x) \<and>
                              (c, s(''certificate'' := z)) \<Rightarrow>\<^bsup> t \<^esup> s' \<and>
                              s' ''input'' = in_lang x)"
          "\<And>x s s' t. \<lbrakk>in_lang x \<noteq> 0; s ''input'' = x; (c, s) \<Rightarrow>\<^bsup> t \<^esup> s'\<rbrakk> \<Longrightarrow>
                         s' ''input'' = in_lang x"
  assumes verifier_has_registers:
    "''input'' \<in> set (Max_Constant.all_variables c)"
  shows "\<exists>t_red s_red.
         poly t_red
       \<and> poly s_red
       \<and> (\<forall>x. \<exists>f.  bit_length (encode_sat f) \<le> s_red ( bit_length x ) \<and> imp_to_sat_nat (com_encode c) (prod_encode pt) (prod_encode p_cer) x = sat_formula_encode f
                   \<and> (Sema.sat {f}  \<longleftrightarrow> in_lang x = 0))"
  using assms main_lemma_hol_list by (auto simp add:subnat_imp_to_sat inj_formula_simp)

lemma main_lemma_hol_tail:
  fixes c and pt::"nat*nat" and p_cer::"nat*nat" and in_lang
  assumes verifier_tbounded:
    "\<And>s. \<exists>t s'. (c, s) \<Rightarrow>\<^bsup> t \<^esup> s' \<and>
                   t \<le> poly_of pt (bit_length (s ''input''))"
  assumes verifier_terminates:
          "\<And>x s. \<lbrakk>in_lang x = 0 ; s ''input'' = x\<rbrakk> \<Longrightarrow>
                    (\<exists>z t s'. bit_length z \<le> poly_of p_cer (bit_length x) \<and>
                              (c, s(''certificate'' := z)) \<Rightarrow>\<^bsup> t \<^esup> s' \<and>
                              s' ''input'' = in_lang x)"
          "\<And>x s s' t. \<lbrakk>in_lang x \<noteq> 0; s ''input'' = x; (c, s) \<Rightarrow>\<^bsup> t \<^esup> s'\<rbrakk> \<Longrightarrow>
                         s' ''input'' = in_lang x"
  assumes verifier_has_registers:
    "''input'' \<in> set (Max_Constant.all_variables c)"
  shows "\<exists>t_red s_red.
         poly t_red
       \<and> poly s_red
       \<and> (\<forall>x. \<exists>f.  bit_length (encode_sat f) \<le> s_red ( bit_length x ) \<and> imp_to_sat_tail(com_encode c) (prod_encode pt) (prod_encode p_cer) x = sat_formula_encode f
                   \<and> (Sema.sat {f}  \<longleftrightarrow> in_lang x = 0))"
  using assms main_lemma_hol_nat by (auto simp add:subtail_imp_to_sat inj_formula_simp)

end


theory Single_Step_Demo
imports Main
begin

text{* "thm" is a command that displays one or more named theorems: *}
thm conjI impI iffI notI

text{* Instantiation of theorems: "of" *}

text{* Positional: *}
thm conjI[of "A" "B"]
thm conjI[of "A"]
thm conjI[of _ "B"]

text{* By name: *}
thm conjI[where ?Q = "B"]
thm conjI[where Q = "B"]   (* May omit ? *)

(* If variable name ends with number, ? and ".0" must be written! (Idiosyncrasy of Isabelle) *)
lemma my_rev_append: "rev (a1@a2) = rev a2 @ rev a1" by (rule rev_append)
thm my_rev_append
thm my_rev_append[where ?a1.0 = "[]"]

text{* Composition of theorems: OF *}

thm refl[of "a"]
thm conjI[OF refl[of "a"] refl[of "b"]]
thm conjI[OF refl[of "a"]]
thm conjI[OF _ refl[of "b"]]

text{* A simple backward proof: *}
lemma "\<lbrakk> A; B \<rbrakk> \<Longrightarrow> A \<and> B"
apply(rule conjI)
apply assumption
apply assumption
done

end


(*  Title:      HOL/Library/Code_Target_Nat.thy
    Author:     Florian Haftmann, TU Muenchen
*)

section \<open>Implementation of natural numbers by target-language integers\<close>

theory Code_Target_Nat
imports Code_Abstract_Nat
begin

subsection \<open>Implementation for \<^typ>\<open>nat\<close>\<close>

context
includes natural.lifting integer.lifting
begin

lift_definition Nat :: "integer \<Rightarrow> nat"
  is nat
  .

lemma [code_post]:
  "Nat 0 = 0"
  "Nat 1 = 1"
  "Nat (numeral k) = numeral k"
  by (transfer, simp)+

lemma [code_abbrev]:
  "integer_of_nat = of_nat"
  by transfer rule

lemma [code_unfold]:
  "Int.nat (int_of_integer k) = nat_of_integer k"
  by transfer rule

lemma [code abstype]:
  "Code_Target_Nat.Nat (integer_of_nat n) = n"
  by transfer simp

lemma [code abstract]:
  "integer_of_nat (nat_of_integer k) = max 0 k"
  by transfer auto

lemma [code_abbrev]:
  "nat_of_integer (numeral k) = nat_of_num k"
  by transfer (simp add: nat_of_num_numeral)

context
begin

qualified definition natural :: "num \<Rightarrow> nat"
  where [simp]: "natural = nat_of_num"

lemma [code_computation_unfold]:
  "numeral = natural"
  "nat_of_num = natural"
  by (simp_all add: nat_of_num_numeral)

end

lemma [code abstract]:
  "integer_of_nat (nat_of_num n) = integer_of_num n"
  by (simp add: nat_of_num_numeral integer_of_nat_numeral)

lemma [code abstract]:
  "integer_of_nat 0 = 0"
  by transfer simp

lemma [code abstract]:
  "integer_of_nat 1 = 1"
  by transfer simp

lemma [code abstract]:
  "integer_of_nat (m + n) = of_nat m + of_nat n"
  by transfer simp

lemma [code abstract]:
  "integer_of_nat (m - n) = max 0 (of_nat m - of_nat n)"
  by transfer simp

lemma [code abstract]:
  "integer_of_nat (m * n) = of_nat m * of_nat n"
  by transfer (simp add: of_nat_mult)

lemma [code abstract]:
  "integer_of_nat (m div n) = of_nat m div of_nat n"
  by transfer (simp add: zdiv_int)

lemma [code abstract]:
  "integer_of_nat (m mod n) = of_nat m mod of_nat n"
  by transfer (simp add: zmod_int)

context
  includes integer.lifting
begin

lemma divmod_nat_code [code]: \<^marker>\<open>contributor \<open>René Thiemann\<close>\<close> \<^marker>\<open>contributor \<open>Akihisa Yamada\<close>\<close>
  "Euclidean_Rings.divmod_nat m n = (
     let k = integer_of_nat m; l = integer_of_nat n
     in map_prod nat_of_integer nat_of_integer
       (if k = 0 then (0, 0)
        else if l = 0 then (0, k) else
          Code_Numeral.divmod_abs k l))"
  by (simp add: prod_eq_iff Let_def Euclidean_Rings.divmod_nat_def; transfer)
    (simp add: nat_div_distrib nat_mod_distrib)

end

lemma [code]:
  "divmod m n = map_prod nat_of_integer nat_of_integer (divmod m n)"
  by (simp only: prod_eq_iff divmod_def map_prod_def case_prod_beta fst_conv snd_conv; transfer)
    (simp_all only: nat_div_distrib nat_mod_distrib
        zero_le_numeral nat_numeral)

lemma [code]:
  "HOL.equal m n = HOL.equal (of_nat m :: integer) (of_nat n)"
  by transfer (simp add: equal)

lemma [code]:
  "m \<le> n \<longleftrightarrow> (of_nat m :: integer) \<le> of_nat n"
  by simp

lemma [code]:
  "m < n \<longleftrightarrow> (of_nat m :: integer) < of_nat n"
  by simp

lemma num_of_nat_code [code]:
  "num_of_nat = num_of_integer \<circ> of_nat"
  by transfer (simp add: fun_eq_iff)

end

lemma (in semiring_1) of_nat_code_if:
  "of_nat n = (if n = 0 then 0
     else let
       (m, q) = Euclidean_Rings.divmod_nat n 2;
       m' = 2 * of_nat m
     in if q = 0 then m' else m' + 1)"
  by (cases n)
    (simp_all add: Let_def Euclidean_Rings.divmod_nat_def ac_simps
      flip: of_nat_numeral of_nat_mult minus_mod_eq_mult_div)

declare of_nat_code_if [code]

definition int_of_nat :: "nat \<Rightarrow> int" where
  [code_abbrev]: "int_of_nat = of_nat"

lemma [code]:
  "int_of_nat n = int_of_integer (of_nat n)"
  by (simp add: int_of_nat_def)

lemma [code abstract]:
  "integer_of_nat (nat k) = max 0 (integer_of_int k)"
  including integer.lifting by transfer auto

definition char_of_nat :: "nat \<Rightarrow> char"
  where [code_abbrev]: "char_of_nat = char_of"

definition nat_of_char :: "char \<Rightarrow> nat"
  where [code_abbrev]: "nat_of_char = of_char"

lemma [code]:
  "char_of_nat = char_of_integer \<circ> integer_of_nat"
  including integer.lifting unfolding char_of_integer_def char_of_nat_def
  by transfer (simp add: fun_eq_iff)

lemma [code abstract]:
  "integer_of_nat (nat_of_char c) = integer_of_char c"
  by (cases c) (simp add: nat_of_char_def integer_of_char_def integer_of_nat_eq_of_nat)

lemma term_of_nat_code [code]:
  \<comment> \<open>Use \<^term>\<open>Code_Numeral.nat_of_integer\<close> in term reconstruction
        instead of \<^term>\<open>Code_Target_Nat.Nat\<close> such that reconstructed
        terms can be fed back to the code generator\<close>
  "term_of_class.term_of n =
   Code_Evaluation.App
     (Code_Evaluation.Const (STR ''Code_Numeral.nat_of_integer'')
        (typerep.Typerep (STR ''fun'')
           [typerep.Typerep (STR ''Code_Numeral.integer'') [],
         typerep.Typerep (STR ''Nat.nat'') []]))
     (term_of_class.term_of (integer_of_nat n))"
  by (simp add: term_of_anything)

lemma nat_of_integer_code_post [code_post]:
  "nat_of_integer 0 = 0"
  "nat_of_integer 1 = 1"
  "nat_of_integer (numeral k) = numeral k"
  including integer.lifting by (transfer, simp)+

code_identifier
  code_module Code_Target_Nat \<rightharpoonup>
    (SML) Arith and (OCaml) Arith and (Haskell) Arith

end


chapter SeCaV_Propositional

(*
  Author: Jørgen Villadsen, DTU Compute, 2021
  Contributors: Asta Halkjær From & Alexander Birch Jensen
*)

section \<open>Sequent Calculus Verifier (SeCaV)\<close>

theory SeCaV_Propositional imports SeCaV begin

section \<open>Examples\<close>

subsection \<open>Example 1\<close>

proposition \<open>p \<or> \<not> p\<close> by metis

lemma \<open>\<tturnstile>
  [
    Dis (Pre 0 []) (Neg (Pre 0 []))
  ]
  \<close>
proof -
  from AlphaDis have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [],
      Neg (Pre 0 [])
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

subsection \<open>Example 2\<close>

proposition \<open>p \<longrightarrow> \<not> \<not> p\<close> by metis

lemma \<open>\<tturnstile>
  [
    Imp (Pre 0 []) (Neg (Neg (Pre 0 [])))
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Pre 0 []),
      Neg (Neg (Pre 0 []))
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

subsection \<open>Example 3\<close>

proposition \<open>\<not> \<not> p \<longrightarrow> p\<close> by metis

lemma \<open>\<tturnstile>
  [
    Imp (Neg (Neg (Pre 0 []))) (Pre 0 [])
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Neg (Neg (Pre 0 []))),
      Pre 0 []
    ]
    \<close>
    using that by simp
  with NegNeg have ?thesis if \<open>\<tturnstile>
    [
      Neg (Pre 0 []),
      Pre 0 []
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [],
      Neg (Pre 0 [])
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

subsection \<open>Example 4\<close>

proposition \<open>p \<or> (p \<longrightarrow> q)\<close> by metis

lemma \<open>\<tturnstile>
  [
    Dis (Pre 0 []) (Imp (Pre 0 []) (Pre 1 []))
  ]
  \<close>
proof -
  from AlphaDis have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [],
      Imp (Pre 0 []) (Pre 1 [])
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Imp (Pre 0 []) (Pre 1 []),
      Pre 0 []
    ]
    \<close>
    using that by simp
  with AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Pre 0 []),
      Pre 1 [],
      Pre 0 []
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [],
      Neg (Pre 0 [])
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

subsection \<open>Example 5\<close>

proposition \<open>p \<and> q \<longrightarrow> r \<longrightarrow> p \<and> r\<close> by metis

lemma \<open>\<tturnstile>
  [
    Imp (Con (Pre 0 []) (Pre 1 [])) (Imp (Pre 2 []) (Con (Pre 0 []) (Pre 2 [])))
  ]
  \<close>
proof -
  from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Con (Pre 0 []) (Pre 1 [])),
      Imp (Pre 2 []) (Con (Pre 0 []) (Pre 2 []))
    ]
    \<close>
    using that by simp
  with AlphaCon have ?thesis if \<open>\<tturnstile>
    [
      Neg (Pre 0 []),
      Neg (Pre 1 []),
      Imp (Pre 2 []) (Con (Pre 0 []) (Pre 2 []))
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Imp (Pre 2 []) (Con (Pre 0 []) (Pre 2 [])),
      Neg (Pre 0 [])
    ]
    \<close>
    using that by simp
  with AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Pre 2 []),
      Con (Pre 0 []) (Pre 2 []),
      Neg (Pre 0 [])
    ]
    \<close>
    using that by simp
  with Ext have ?thesis if \<open>\<tturnstile>
    [
      Con (Pre 0 []) (Pre 2 []),
      Neg (Pre 2 []),
      Neg (Pre 0 [])
    ]
    \<close>
    using that by simp
  with BetaCon have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [],
      Neg (Pre 2 []),
      Neg (Pre 0 [])
    ]
    \<close> and \<open>\<tturnstile>
    [
      Pre 2 [],
      Neg (Pre 2 []),
      Neg (Pre 0 [])
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

end


(*  Title:      Uint64.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter \<open>Unsigned words of 64 bits\<close>

theory Uint64 imports
  Code_Target_Word_Base
begin

text \<open>
  PolyML (in version 5.7) provides a Word64 structure only when run in 64-bit mode.
  Therefore, we by default provide an implementation of 64-bit words using \verb$IntInf.int$ and
  masking. The code target \texttt{SML\_word} replaces this implementation and maps the operations
  directly to the \verb$Word64$ structure provided by the Standard ML implementations.

  The \verb$Eval$ target used by @{command value} and @{method eval} dynamically tests at
  runtime for the version of PolyML and uses PolyML's Word64 structure if it detects a 64-bit
  version which does not suffer from a division bug found in PolyML 5.6.
\<close>

declare prod.Quotient[transfer_rule]

section \<open>Type definition and primitive operations\<close>

typedef uint64 = "UNIV :: 64 word set" ..

setup_lifting type_definition_uint64

text \<open>Use an abstract type for code generation to disable pattern matching on @{term Abs_uint64}.\<close>
declare Rep_uint64_inverse[code abstype]

declare Quotient_uint64[transfer_rule]

instantiation uint64 :: comm_ring_1
begin
lift_definition zero_uint64 :: uint64 is "0 :: 64 word" .
lift_definition one_uint64 :: uint64 is "1" .
lift_definition plus_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" is "(+) :: 64 word \<Rightarrow> _" .
lift_definition minus_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" is "(-)" .
lift_definition uminus_uint64 :: "uint64 \<Rightarrow> uint64" is uminus .
lift_definition times_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" is "(*)" .
instance by (standard; transfer) (simp_all add: algebra_simps)
end

instantiation uint64 :: semiring_modulo
begin
lift_definition divide_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" is "(div)" .
lift_definition modulo_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" is "(mod)" .
instance by (standard; transfer) (fact word_mod_div_equality)
end

instantiation uint64 :: linorder begin
lift_definition less_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> bool" is "(<)" .
lift_definition less_eq_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> bool" is "(\<le>)" .
instance by (standard; transfer) (simp_all add: less_le_not_le linear)
end

lemmas [code] = less_uint64.rep_eq less_eq_uint64.rep_eq

context
  includes lifting_syntax
  notes
    transfer_rule_of_bool [transfer_rule]
    transfer_rule_numeral [transfer_rule]
begin

lemma transfer_rule_numeral_uint [transfer_rule]:
  "((=) ===> cr_uint64) numeral numeral"
  by transfer_prover

lemma [transfer_rule]:
  \<open>(cr_uint64 ===> (\<longleftrightarrow>)) even ((dvd) 2 :: uint64 \<Rightarrow> bool)\<close>
  by (unfold dvd_def) transfer_prover

end

instantiation uint64 :: semiring_bits
begin

lift_definition bit_uint64 :: \<open>uint64 \<Rightarrow> nat \<Rightarrow> bool\<close> is bit .

instance
  by (standard; transfer)
    (fact bit_iff_odd even_iff_mod_2_eq_zero odd_iff_mod_2_eq_one odd_one bits_induct
       bits_div_0 bits_div_by_1 bits_mod_div_trivial even_succ_div_2
       even_mask_div_iff exp_div_exp_eq div_exp_eq mod_exp_eq mult_exp_mod_exp_eq
       div_exp_mod_exp_eq even_mult_exp_div_exp_iff)+

end

instantiation uint64 :: semiring_bit_shifts
begin
lift_definition push_bit_uint64 :: \<open>nat \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is push_bit .
lift_definition drop_bit_uint64 :: \<open>nat \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is drop_bit .
lift_definition take_bit_uint64 :: \<open>nat \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is take_bit .
instance by (standard; transfer)
  (fact push_bit_eq_mult drop_bit_eq_div take_bit_eq_mod)+
end

instantiation uint64 :: ring_bit_operations
begin
lift_definition not_uint64 :: \<open>uint64 \<Rightarrow> uint64\<close> is NOT .
lift_definition and_uint64 :: \<open>uint64 \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is \<open>(AND)\<close> .
lift_definition or_uint64 :: \<open>uint64 \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is \<open>(OR)\<close> .
lift_definition xor_uint64 :: \<open>uint64 \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is \<open>(XOR)\<close> .
lift_definition mask_uint64 :: \<open>nat \<Rightarrow> uint64\<close> is mask .
lift_definition set_bit_uint64 :: \<open>nat \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is \<open>Bit_Operations.set_bit\<close> .
lift_definition unset_bit_uint64 :: \<open>nat \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is \<open>unset_bit\<close> .
lift_definition flip_bit_uint64 :: \<open>nat \<Rightarrow> uint64 \<Rightarrow> uint64\<close> is \<open>flip_bit\<close> .
instance by (standard; transfer)
  (simp_all add: bit_simps mask_eq_decr_exp minus_eq_not_minus_1 set_bit_def flip_bit_def)
end

lemma [code]:
  \<open>mask (Suc n) = push_bit n (1 :: uint64) OR mask n\<close>
  \<open>mask 0 = (0 :: uint64)\<close>
  by (simp_all add: mask_Suc_exp push_bit_of_1)

lemma [code]:
  \<open>Bit_Operations.set_bit n w = w OR push_bit n 1\<close> for w :: uint64
  by (fact set_bit_eq_or)

lemma [code]:
  \<open>unset_bit n w = w AND NOT (push_bit n 1)\<close> for w :: uint64
  by (fact unset_bit_eq_and_not)

lemma [code]:
  \<open>flip_bit n w = w XOR push_bit n 1\<close> for w :: uint64
  by (fact flip_bit_eq_xor)

instantiation uint64 :: lsb
begin
lift_definition lsb_uint64 :: \<open>uint64 \<Rightarrow> bool\<close> is lsb .
instance by (standard; transfer)
  (fact lsb_odd)
end

instantiation uint64 :: msb
begin
lift_definition msb_uint64 :: \<open>uint64 \<Rightarrow> bool\<close> is msb .
instance ..
end

setup \<open>Context.theory_map (Name_Space.map_naming (Name_Space.qualified_path true \<^binding>\<open>Generic\<close>))\<close>

instantiation uint64 :: set_bit
begin
lift_definition set_bit_uint64 :: \<open>uint64 \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint64\<close> is set_bit .
instance
  apply standard
  apply transfer
  apply (simp add: bit_simps)
  done
end

setup \<open>Context.theory_map (Name_Space.map_naming (Name_Space.parent_path))\<close>

instantiation uint64 :: bit_comprehension begin
lift_definition set_bits_uint64 :: "(nat \<Rightarrow> bool) \<Rightarrow> uint64" is "set_bits" .
instance by (standard; transfer) (fact set_bits_bit_eq)
end

lemmas [code] = bit_uint64.rep_eq lsb_uint64.rep_eq msb_uint64.rep_eq

instantiation uint64 :: equal begin
lift_definition equal_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> bool" is "equal_class.equal" .
instance by standard (transfer, simp add: equal_eq)
end

lemmas [code] = equal_uint64.rep_eq

instantiation uint64 :: size begin
lift_definition size_uint64 :: "uint64 \<Rightarrow> nat" is "size" .
instance ..
end

lemmas [code] = size_uint64.rep_eq

lift_definition sshiftr_uint64 :: "uint64 \<Rightarrow> nat \<Rightarrow> uint64" (infixl ">>>" 55) is \<open>\<lambda>w n. signed_drop_bit n w\<close> .

lift_definition uint64_of_int :: "int \<Rightarrow> uint64" is "word_of_int" .

definition uint64_of_nat :: "nat \<Rightarrow> uint64"
where "uint64_of_nat = uint64_of_int \<circ> int"

lift_definition int_of_uint64 :: "uint64 \<Rightarrow> int" is "uint" .
lift_definition nat_of_uint64 :: "uint64 \<Rightarrow> nat" is "unat" .

definition integer_of_uint64 :: "uint64 \<Rightarrow> integer"
where "integer_of_uint64 = integer_of_int o int_of_uint64"

text \<open>Use pretty numerals from integer for pretty printing\<close>

context includes integer.lifting begin

lift_definition Uint64 :: "integer \<Rightarrow> uint64" is "word_of_int" .

lemma Rep_uint64_numeral [simp]: "Rep_uint64 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint64_def Abs_uint64_inverse numeral.simps plus_uint64_def)

lemma numeral_uint64_transfer [transfer_rule]:
  "(rel_fun (=) cr_uint64) numeral numeral"
by(auto simp add: cr_uint64_def)

lemma numeral_uint64 [code_unfold]: "numeral n = Uint64 (numeral n)"
by transfer simp

lemma Rep_uint64_neg_numeral [simp]: "Rep_uint64 (- numeral n) = - numeral n"
by(simp only: uminus_uint64_def)(simp add: Abs_uint64_inverse)

lemma neg_numeral_uint64 [code_unfold]: "- numeral n = Uint64 (- numeral n)"
by transfer(simp add: cr_uint64_def)

end

lemma Abs_uint64_numeral [code_post]: "Abs_uint64 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint64_def numeral.simps plus_uint64_def Abs_uint64_inverse)

lemma Abs_uint64_0 [code_post]: "Abs_uint64 0 = 0"
by(simp add: zero_uint64_def)

lemma Abs_uint64_1 [code_post]: "Abs_uint64 1 = 1"
by(simp add: one_uint64_def)

section \<open>Code setup\<close>

text \<open> For SML, we generate an implementation of unsigned 64-bit words using \verb$IntInf.int$.
  If @{ML "LargeWord.wordSize > 63"} of the Isabelle/ML runtime environment holds, then we assume
  that there is also a \<open>Word64\<close> structure available and accordingly replace the implementation
  for the target \verb$Eval$.
\<close>
code_printing code_module "Uint64" \<rightharpoonup> (SML) \<open>(* Test that words can handle numbers between 0 and 63 *)
val _ = if 6 <= Word.wordSize then () else raise (Fail ("wordSize less than 6"));

structure Uint64 : sig
  eqtype uint64;
  val zero : uint64;
  val one : uint64;
  val fromInt : IntInf.int -> uint64;
  val toInt : uint64 -> IntInf.int;
  val toLarge : uint64 -> LargeWord.word;
  val fromLarge : LargeWord.word -> uint64
  val plus : uint64 -> uint64 -> uint64;
  val minus : uint64 -> uint64 -> uint64;
  val times : uint64 -> uint64 -> uint64;
  val divide : uint64 -> uint64 -> uint64;
  val modulus : uint64 -> uint64 -> uint64;
  val negate : uint64 -> uint64;
  val less_eq : uint64 -> uint64 -> bool;
  val less : uint64 -> uint64 -> bool;
  val notb : uint64 -> uint64;
  val andb : uint64 -> uint64 -> uint64;
  val orb : uint64 -> uint64 -> uint64;
  val xorb : uint64 -> uint64 -> uint64;
  val shiftl : uint64 -> IntInf.int -> uint64;
  val shiftr : uint64 -> IntInf.int -> uint64;
  val shiftr_signed : uint64 -> IntInf.int -> uint64;
  val set_bit : uint64 -> IntInf.int -> bool -> uint64;
  val test_bit : uint64 -> IntInf.int -> bool;
end = struct

type uint64 = IntInf.int;

val mask = 0xFFFFFFFFFFFFFFFF : IntInf.int;

val zero = 0 : IntInf.int;

val one = 1 : IntInf.int;

fun fromInt x = IntInf.andb(x, mask);

fun toInt x = x

fun toLarge x = LargeWord.fromLargeInt (IntInf.toLarge x);

fun fromLarge x = IntInf.fromLarge (LargeWord.toLargeInt x);

fun plus x y = IntInf.andb(IntInf.+(x, y), mask);

fun minus x y = IntInf.andb(IntInf.-(x, y), mask);

fun negate x = IntInf.andb(IntInf.~(x), mask);

fun times x y = IntInf.andb(IntInf.*(x, y), mask);

fun divide x y = IntInf.div(x, y);

fun modulus x y = IntInf.mod(x, y);

fun less_eq x y = IntInf.<=(x, y);

fun less x y = IntInf.<(x, y);

fun notb x = IntInf.andb(IntInf.notb(x), mask);

fun orb x y = IntInf.orb(x, y);

fun andb x y = IntInf.andb(x, y);

fun xorb x y = IntInf.xorb(x, y);

val maxWord = IntInf.pow (2, Word.wordSize);

fun shiftl x n =
  if n < maxWord then IntInf.andb(IntInf.<< (x, Word.fromLargeInt (IntInf.toLarge n)), mask)
  else 0;

fun shiftr x n =
  if n < maxWord then IntInf.~>> (x, Word.fromLargeInt (IntInf.toLarge n))
  else 0;

val msb_mask = 0x8000000000000000 : IntInf.int;

fun shiftr_signed x i =
  if IntInf.andb(x, msb_mask) = 0 then shiftr x i
  else if i >= 64 then 0xFFFFFFFFFFFFFFFF
  else let
    val x' = shiftr x i
    val m' = IntInf.andb(IntInf.<<(mask, Word.max(0w64 - Word.fromLargeInt (IntInf.toLarge i), 0w0)), mask)
  in IntInf.orb(x', m') end;

fun test_bit x n =
  if n < maxWord then IntInf.andb (x, IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n))) <> 0
  else false;

fun set_bit x n b =
  if n < 64 then
    if b then IntInf.orb (x, IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n)))
    else IntInf.andb (x, IntInf.notb (IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n))))
  else x;

end
\<close>
code_reserved SML Uint64

setup \<open>
let
  val polyml64 = LargeWord.wordSize > 63;
  (* PolyML 5.6 has bugs in its Word64 implementation. We test for one such bug and refrain
     from using Word64 in that case. Testing is done with dynamic code evaluation such that
     the compiler does not choke on the Word64 structure, which need not be present in a 32bit
     environment. *)
  val error_msg = "Buggy Word64 structure";
  val test_code =
   "val _ = if Word64.div (0w18446744073709551611 : Word64.word, 0w3) = 0w6148914691236517203 then ()\n" ^
   "else raise (Fail \"" ^ error_msg ^ "\");";
  val f = Exn.interruptible_capture (fn () => ML_Compiler.eval ML_Compiler.flags Position.none (ML_Lex.tokenize test_code))
  val use_Word64 = polyml64 andalso
    (case f () of
       Exn.Res _ => true
     | Exn.Exn (e as ERROR m) => if String.isSuffix error_msg m then false else Exn.reraise e
     | Exn.Exn e => Exn.reraise e)
    ;

  val newline = "\n";
  val content =
    "structure Uint64 : sig" ^ newline ^
    "  eqtype uint64;" ^ newline ^
    "  val zero : uint64;" ^ newline ^
    "  val one : uint64;" ^ newline ^
    "  val fromInt : IntInf.int -> uint64;" ^ newline ^
    "  val toInt : uint64 -> IntInf.int;" ^ newline ^
    "  val toLarge : uint64 -> LargeWord.word;" ^ newline ^
    "  val fromLarge : LargeWord.word -> uint64" ^ newline ^
    "  val plus : uint64 -> uint64 -> uint64;" ^ newline ^
    "  val minus : uint64 -> uint64 -> uint64;" ^ newline ^
    "  val times : uint64 -> uint64 -> uint64;" ^ newline ^
    "  val divide : uint64 -> uint64 -> uint64;" ^ newline ^
    "  val modulus : uint64 -> uint64 -> uint64;" ^ newline ^
    "  val negate : uint64 -> uint64;" ^ newline ^
    "  val less_eq : uint64 -> uint64 -> bool;" ^ newline ^
    "  val less : uint64 -> uint64 -> bool;" ^ newline ^
    "  val notb : uint64 -> uint64;" ^ newline ^
    "  val andb : uint64 -> uint64 -> uint64;" ^ newline ^
    "  val orb : uint64 -> uint64 -> uint64;" ^ newline ^
    "  val xorb : uint64 -> uint64 -> uint64;" ^ newline ^
    "  val shiftl : uint64 -> IntInf.int -> uint64;" ^ newline ^
    "  val shiftr : uint64 -> IntInf.int -> uint64;" ^ newline ^
    "  val shiftr_signed : uint64 -> IntInf.int -> uint64;" ^ newline ^
    "  val set_bit : uint64 -> IntInf.int -> bool -> uint64;" ^ newline ^
    "  val test_bit : uint64 -> IntInf.int -> bool;" ^ newline ^
    "end = struct" ^ newline ^
    "" ^ newline ^
    "type uint64 = Word64.word;" ^ newline ^
    "" ^ newline ^
    "val zero = (0wx0 : uint64);" ^ newline ^
    "" ^ newline ^
    "val one = (0wx1 : uint64);" ^ newline ^
    "" ^ newline ^
    "fun fromInt x = Word64.fromLargeInt (IntInf.toLarge x);" ^ newline ^
    "" ^ newline ^
    "fun toInt x = IntInf.fromLarge (Word64.toLargeInt x);"  ^ newline ^
    "" ^ newline ^
    "fun fromLarge x = Word64.fromLarge x;" ^ newline ^
    "" ^ newline ^
    "fun toLarge x = Word64.toLarge x;"  ^ newline ^
    "" ^ newline ^
    "fun plus x y = Word64.+(x, y);" ^ newline ^
    "" ^ newline ^
    "fun minus x y = Word64.-(x, y);" ^ newline ^
    "" ^ newline ^
    "fun negate x = Word64.~(x);" ^ newline ^
    "" ^ newline ^
    "fun times x y = Word64.*(x, y);" ^ newline ^
    "" ^ newline ^
    "fun divide x y = Word64.div(x, y);" ^ newline ^
    "" ^ newline ^
    "fun modulus x y = Word64.mod(x, y);" ^ newline ^
    "" ^ newline ^
    "fun less_eq x y = Word64.<=(x, y);" ^ newline ^
    "" ^ newline ^
    "fun less x y = Word64.<(x, y);" ^ newline ^
    "" ^ newline ^
    "fun set_bit x n b =" ^ newline ^
    "  let val mask = Word64.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))" ^ newline ^
    "  in if b then Word64.orb (x, mask)" ^ newline ^
    "     else Word64.andb (x, Word64.notb mask)" ^ newline ^
    "  end" ^ newline ^
    "" ^ newline ^
    "fun shiftl x n =" ^ newline ^
    "  Word64.<< (x, Word.fromLargeInt (IntInf.toLarge n))" ^ newline ^
    "" ^ newline ^
    "fun shiftr x n =" ^ newline ^
    "  Word64.>> (x, Word.fromLargeInt (IntInf.toLarge n))" ^ newline ^
    "" ^ newline ^
    "fun shiftr_signed x n =" ^ newline ^
    "  Word64.~>> (x, Word.fromLargeInt (IntInf.toLarge n))" ^ newline ^
    "" ^ newline ^
    "fun test_bit x n =" ^ newline ^
    "  Word64.andb (x, Word64.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))) <> Word64.fromInt 0" ^ newline ^
    "" ^ newline ^
    "val notb = Word64.notb" ^ newline ^
    "" ^ newline ^
    "fun andb x y = Word64.andb(x, y);" ^ newline ^
    "" ^ newline ^
    "fun orb x y = Word64.orb(x, y);" ^ newline ^
    "" ^ newline ^
    "fun xorb x y = Word64.xorb(x, y);" ^ newline ^
    "" ^ newline ^
    "end (*struct Uint64*)"
  val target_SML64 = "SML_word";
in
  (if use_Word64 then Code_Target.set_printings (Code_Symbol.Module ("Uint64", [(Code_Runtime.target, SOME (content, []))])) else I)
  #> Code_Target.set_printings (Code_Symbol.Module ("Uint64", [(target_SML64, SOME (content, []))]))
end
\<close>

code_printing code_module Uint64 \<rightharpoonup> (Haskell)
 \<open>module Uint64(Int64, Word64) where

  import Data.Int(Int64)
  import Data.Word(Word64)\<close>
code_reserved Haskell Uint64

text \<open>
  OCaml and Scala provide only signed 64bit numbers, so we use these and
  implement sign-sensitive operations like comparisons manually.
\<close>
code_printing code_module "Uint64" \<rightharpoonup> (OCaml)
\<open>module Uint64 : sig
  val less : int64 -> int64 -> bool
  val less_eq : int64 -> int64 -> bool
  val set_bit : int64 -> Z.t -> bool -> int64
  val shiftl : int64 -> Z.t -> int64
  val shiftr : int64 -> Z.t -> int64
  val shiftr_signed : int64 -> Z.t -> int64
  val test_bit : int64 -> Z.t -> bool
end = struct

(* negative numbers have their highest bit set,
   so they are greater than positive ones *)
let less x y =
  if Int64.compare x Int64.zero < 0 then
    Int64.compare y Int64.zero < 0 && Int64.compare x y < 0
  else Int64.compare y Int64.zero < 0 || Int64.compare x y < 0;;

let less_eq x y =
  if Int64.compare x Int64.zero < 0 then
    Int64.compare y Int64.zero < 0 && Int64.compare x y <= 0
  else Int64.compare y Int64.zero < 0 || Int64.compare x y <= 0;;

let set_bit x n b =
  let mask = Int64.shift_left Int64.one (Z.to_int n)
  in if b then Int64.logor x mask
     else Int64.logand x (Int64.lognot mask);;

let shiftl x n = Int64.shift_left x (Z.to_int n);;

let shiftr x n = Int64.shift_right_logical x (Z.to_int n);;

let shiftr_signed x n = Int64.shift_right x (Z.to_int n);;

let test_bit x n =
  Int64.compare
    (Int64.logand x (Int64.shift_left Int64.one (Z.to_int n)))
    Int64.zero
  <> 0;;

end;; (*struct Uint64*)\<close>
code_reserved OCaml Uint64

code_printing code_module Uint64 \<rightharpoonup> (Scala)
\<open>object Uint64 {

def less(x: Long, y: Long) : Boolean =
  if (x < 0) y < 0 && x < y
  else y < 0 || x < y

def less_eq(x: Long, y: Long) : Boolean =
  if (x < 0) y < 0 && x <= y
  else y < 0 || x <= y

def set_bit(x: Long, n: BigInt, b: Boolean) : Long =
  if (b)
    x | (1L << n.intValue)
  else
    x & (1L << n.intValue).unary_~

def shiftl(x: Long, n: BigInt) : Long = x << n.intValue

def shiftr(x: Long, n: BigInt) : Long = x >>> n.intValue

def shiftr_signed(x: Long, n: BigInt) : Long = x >> n.intValue

def test_bit(x: Long, n: BigInt) : Boolean =
  (x & (1L << n.intValue)) != 0

} /* object Uint64 */\<close>
code_reserved Scala Uint64

text \<open>
  OCaml's conversion from Big\_int to int64 demands that the value fits int a signed 64-bit integer.
  The following justifies the implementation.
\<close>

definition Uint64_signed :: "integer \<Rightarrow> uint64"
where "Uint64_signed i = (if i < -(0x8000000000000000) \<or> i \<ge> 0x8000000000000000 then undefined Uint64 i else Uint64 i)"

lemma Uint64_code [code]:
  "Uint64 i =
  (let i' = i AND 0xFFFFFFFFFFFFFFFF
   in if bit i' 63 then Uint64_signed (i' - 0x10000000000000000) else Uint64_signed i')"
  including undefined_transfer integer.lifting unfolding Uint64_signed_def
  apply transfer
  apply (subst word_of_int_via_signed)
     apply (auto simp add: push_bit_of_1 mask_eq_exp_minus_1 word_of_int_via_signed cong del: if_cong)
  done

lemma Uint64_signed_code [code abstract]:
  "Rep_uint64 (Uint64_signed i) =
  (if i < -(0x8000000000000000) \<or> i \<ge> 0x8000000000000000 then Rep_uint64 (undefined Uint64 i) else word_of_int (int_of_integer_symbolic i))"
unfolding Uint64_signed_def Uint64_def int_of_integer_symbolic_def word_of_integer_def
by(simp add: Abs_uint64_inverse)

text \<open>
  Avoid @{term Abs_uint64} in generated code, use @{term Rep_uint64'} instead.
  The symbolic implementations for code\_simp use @{term Rep_uint64}.

  The new destructor @{term Rep_uint64'} is executable.
  As the simplifier is given the [code abstract] equations literally,
  we cannot implement @{term Rep_uint64} directly, because that makes code\_simp loop.

  If code generation raises Match, some equation probably contains @{term Rep_uint64}
  ([code abstract] equations for @{typ uint64} may use @{term Rep_uint64} because
  these instances will be folded away.)

  To convert @{typ "64 word"} values into @{typ uint64}, use @{term "Abs_uint64'"}.
\<close>

definition Rep_uint64' where [simp]: "Rep_uint64' = Rep_uint64"

lemma Rep_uint64'_transfer [transfer_rule]:
  "rel_fun cr_uint64 (=) (\<lambda>x. x) Rep_uint64'"
unfolding Rep_uint64'_def by(rule uint64.rep_transfer)

lemma Rep_uint64'_code [code]: "Rep_uint64' x = (BITS n. bit x n)"
  by transfer (simp add: set_bits_bit_eq)

lift_definition Abs_uint64' :: "64 word \<Rightarrow> uint64" is "\<lambda>x :: 64 word. x" .

lemma Abs_uint64'_code [code]:
  "Abs_uint64' x = Uint64 (integer_of_int (uint x))"
including integer.lifting by transfer simp

declare [[code drop: "term_of_class.term_of :: uint64 \<Rightarrow> _"]]

lemma term_of_uint64_code [code]:
  defines "TR \<equiv> typerep.Typerep" and "bit0 \<equiv> STR ''Numeral_Type.bit0''"
  shows
  "term_of_class.term_of x =
   Code_Evaluation.App (Code_Evaluation.Const (STR ''Uint64.uint64.Abs_uint64'') (TR (STR ''fun'') [TR (STR ''Word.word'') [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR (STR ''Numeral_Type.num1'') []]]]]]]], TR (STR ''Uint64.uint64'') []]))
       (term_of_class.term_of (Rep_uint64' x))"
by(simp add: term_of_anything)

code_printing
  type_constructor uint64 \<rightharpoonup>
  (SML) "Uint64.uint64" and
  (Haskell) "Uint64.Word64" and
  (OCaml) "int64" and
  (Scala) "Long"
| constant Uint64 \<rightharpoonup>
  (SML) "Uint64.fromInt" and
  (Haskell) "(Prelude.fromInteger _ :: Uint64.Word64)" and
  (Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint64.Word64)" and
  (Scala) "_.longValue"
| constant Uint64_signed \<rightharpoonup>
  (OCaml) "Z.to'_int64"
| constant "0 :: uint64" \<rightharpoonup>
  (SML) "Uint64.zero" and
  (Haskell) "(0 :: Uint64.Word64)" and
  (OCaml) "Int64.zero" and
  (Scala) "0"
| constant "1 :: uint64" \<rightharpoonup>
  (SML) "Uint64.one" and
  (Haskell) "(1 :: Uint64.Word64)" and
  (OCaml) "Int64.one" and
  (Scala) "1"
| constant "plus :: uint64 \<Rightarrow> _ " \<rightharpoonup>
  (SML) "Uint64.plus" and
  (Haskell) infixl 6 "+" and
  (OCaml) "Int64.add" and
  (Scala) infixl 7 "+"
| constant "uminus :: uint64 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Uint64.negate" and
  (Haskell) "negate" and
  (OCaml) "Int64.neg" and
  (Scala) "!(- _)"
| constant "minus :: uint64 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Uint64.minus" and
  (Haskell) infixl 6 "-" and
  (OCaml) "Int64.sub" and
  (Scala) infixl 7 "-"
| constant "times :: uint64 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML) "Uint64.times" and
  (Haskell) infixl 7 "*" and
  (OCaml) "Int64.mul" and
  (Scala) infixl 8 "*"
| constant "HOL.equal :: uint64 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "!((_ : Uint64.uint64) = _)" and
  (Haskell) infix 4 "==" and
  (OCaml) "(Int64.compare _ _ = 0)" and
  (Scala) infixl 5 "=="
| class_instance uint64 :: equal \<rightharpoonup>
  (Haskell) -
| constant "less_eq :: uint64 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Uint64.less'_eq" and
  (Haskell) infix 4 "<=" and
  (OCaml) "Uint64.less'_eq" and
  (Scala) "Uint64.less'_eq"
| constant "less :: uint64 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Uint64.less" and
  (Haskell) infix 4 "<" and
  (OCaml) "Uint64.less" and
  (Scala) "Uint64.less"
| constant "NOT :: uint64 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Uint64.notb" and
  (Haskell) "Data'_Bits.complement" and
  (OCaml) "Int64.lognot" and
  (Scala) "_.unary'_~"
| constant "(AND) :: uint64 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Uint64.andb" and
  (Haskell) infixl 7 "Data_Bits..&." and
  (OCaml) "Int64.logand" and
  (Scala) infixl 3 "&"
| constant "(OR) :: uint64 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Uint64.orb" and
  (Haskell) infixl 5 "Data_Bits..|." and
  (OCaml) "Int64.logor" and
  (Scala) infixl 1 "|"
| constant "(XOR) :: uint64 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Uint64.xorb" and
  (Haskell) "Data'_Bits.xor" and
  (OCaml) "Int64.logxor" and
  (Scala) infixl 2 "^"

definition uint64_divmod :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64 \<times> uint64" where
  "uint64_divmod x y =
  (if y = 0 then (undefined ((div) :: uint64 \<Rightarrow> _) x (0 :: uint64), undefined ((mod) :: uint64 \<Rightarrow> _) x (0 :: uint64))
  else (x div y, x mod y))"

definition uint64_div :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64"
where "uint64_div x y = fst (uint64_divmod x y)"

definition uint64_mod :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64"
where "uint64_mod x y = snd (uint64_divmod x y)"

lemma div_uint64_code [code]: "x div y = (if y = 0 then 0 else uint64_div x y)"
including undefined_transfer unfolding uint64_divmod_def uint64_div_def
by transfer (simp add: word_div_def)

lemma mod_uint64_code [code]: "x mod y = (if y = 0 then x else uint64_mod x y)"
including undefined_transfer unfolding uint64_mod_def uint64_divmod_def
by transfer (simp add: word_mod_def)

definition uint64_sdiv :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64"
where [code del]:
  "uint64_sdiv x y =
   (if y = 0 then undefined ((div) :: uint64 \<Rightarrow> _) x (0 :: uint64)
    else Abs_uint64 (Rep_uint64 x sdiv Rep_uint64 y))"

definition div0_uint64 :: "uint64 \<Rightarrow> uint64"
where [code del]: "div0_uint64 x = undefined ((div) :: uint64 \<Rightarrow> _) x (0 :: uint64)"
declare [[code abort: div0_uint64]]

definition mod0_uint64 :: "uint64 \<Rightarrow> uint64"
where [code del]: "mod0_uint64 x = undefined ((mod) :: uint64 \<Rightarrow> _) x (0 :: uint64)"
declare [[code abort: mod0_uint64]]

lemma uint64_divmod_code [code]:
  "uint64_divmod x y =
  (if 0x8000000000000000 \<le> y then if x < y then (0, x) else (1, x - y)
   else if y = 0 then (div0_uint64 x, mod0_uint64 x)
   else let q = push_bit 1 (uint64_sdiv (drop_bit 1 x) y);
            r = x - q * y
        in if r \<ge> y then (q + 1, r - y) else (q, r))"
  including undefined_transfer unfolding uint64_divmod_def uint64_sdiv_def div0_uint64_def mod0_uint64_def
  by transfer (simp add: divmod_via_sdivmod ac_simps)

lemma uint64_sdiv_code [code abstract]:
  "Rep_uint64 (uint64_sdiv x y) =
   (if y = 0 then Rep_uint64 (undefined ((div) :: uint64 \<Rightarrow> _) x (0 :: uint64))
    else Rep_uint64 x sdiv Rep_uint64 y)"
unfolding uint64_sdiv_def by(simp add: Abs_uint64_inverse)

text \<open>
  Note that we only need a translation for signed division, but not for the remainder
  because @{thm uint64_divmod_code} computes both with division only.
\<close>

code_printing
  constant uint64_div \<rightharpoonup>
  (SML) "Uint64.divide" and
  (Haskell) "Prelude.div"
| constant uint64_mod \<rightharpoonup>
  (SML) "Uint64.modulus" and
  (Haskell) "Prelude.mod"
| constant uint64_divmod \<rightharpoonup>
  (Haskell) "divmod"
| constant uint64_sdiv \<rightharpoonup>
  (OCaml) "Int64.div" and
  (Scala) "_ '/ _"

definition uint64_test_bit :: "uint64 \<Rightarrow> integer \<Rightarrow> bool"
where [code del]:
  "uint64_test_bit x n =
  (if n < 0 \<or> 63 < n then undefined (bit :: uint64 \<Rightarrow> _) x n
   else bit x (nat_of_integer n))"

lemma bit_uint64_code [code]:
  "bit x n \<longleftrightarrow> n < 64 \<and> uint64_test_bit x (integer_of_nat n)"
  including undefined_transfer integer.lifting unfolding uint64_test_bit_def
  by (transfer, simp, transfer, simp)

lemma uint64_test_bit_code [code]:
  "uint64_test_bit w n =
  (if n < 0 \<or> 63 < n then undefined (bit :: uint64 \<Rightarrow> _) w n else bit (Rep_uint64 w) (nat_of_integer n))"
  unfolding uint64_test_bit_def by(simp add: bit_uint64.rep_eq)

code_printing constant uint64_test_bit \<rightharpoonup>
  (SML) "Uint64.test'_bit" and
  (Haskell) "Data'_Bits.testBitBounded" and
  (OCaml) "Uint64.test'_bit" and
  (Scala) "Uint64.test'_bit" and
  (Eval) "(fn x => fn i => if i < 0 orelse i >= 64 then raise (Fail \"argument to uint64'_test'_bit out of bounds\") else Uint64.test'_bit x i)"

definition uint64_set_bit :: "uint64 \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> uint64"
where [code del]:
  "uint64_set_bit x n b =
  (if n < 0 \<or> 63 < n then undefined (set_bit :: uint64 \<Rightarrow> _) x n b
   else set_bit x (nat_of_integer n) b)"

lemma set_bit_uint64_code [code]:
  "set_bit x n b = (if n < 64 then uint64_set_bit x (integer_of_nat n) b else x)"
including undefined_transfer integer.lifting unfolding uint64_set_bit_def
by(transfer)(auto cong: conj_cong simp add: not_less set_bit_beyond word_size)

lemma uint64_set_bit_code [code abstract]:
  "Rep_uint64 (uint64_set_bit w n b) =
  (if n < 0 \<or> 63 < n then Rep_uint64 (undefined (set_bit :: uint64 \<Rightarrow> _) w n b)
   else set_bit (Rep_uint64 w) (nat_of_integer n) b)"
including undefined_transfer unfolding uint64_set_bit_def by transfer simp

code_printing constant uint64_set_bit \<rightharpoonup>
  (SML) "Uint64.set'_bit" and
  (Haskell) "Data'_Bits.setBitBounded" and
  (OCaml) "Uint64.set'_bit" and
  (Scala) "Uint64.set'_bit" and
  (Eval) "(fn x => fn i => fn b => if i < 0 orelse i >= 64 then raise (Fail \"argument to uint64'_set'_bit out of bounds\") else Uint64.set'_bit x i b)"

lift_definition uint64_set_bits :: "(nat \<Rightarrow> bool) \<Rightarrow> uint64 \<Rightarrow> nat \<Rightarrow> uint64" is set_bits_aux .

lemma uint64_set_bits_code [code]:
  "uint64_set_bits f w n =
  (if n = 0 then w
   else let n' = n - 1 in uint64_set_bits f (push_bit 1 w OR (if f n' then 1 else 0)) n')"
  apply (transfer fixing: n)
  apply (cases n)
   apply simp_all
  done

lemma set_bits_uint64 [code]:
  "(BITS n. f n) = uint64_set_bits f 0 64"
by transfer(simp add: set_bits_conv_set_bits_aux)

lemma lsb_code [code]: fixes x :: uint64 shows "lsb x = bit x 0"
  by transfer (simp add: lsb_word_eq)

definition uint64_shiftl :: "uint64 \<Rightarrow> integer \<Rightarrow> uint64"
where [code del]:
  "uint64_shiftl x n = (if n < 0 \<or> 64 \<le> n then undefined (push_bit :: nat \<Rightarrow> uint64 \<Rightarrow> _) x n else push_bit (nat_of_integer n) x)"

lemma shiftl_uint64_code [code]: "push_bit n x = (if n < 64 then uint64_shiftl x (integer_of_nat n) else 0)"
  including undefined_transfer integer.lifting unfolding uint64_shiftl_def
  by transfer simp

lemma uint64_shiftl_code [code abstract]:
  "Rep_uint64 (uint64_shiftl w n) =
  (if n < 0 \<or> 64 \<le> n then Rep_uint64 (undefined (push_bit :: nat \<Rightarrow> uint64 \<Rightarrow> _) w n) else push_bit (nat_of_integer n) (Rep_uint64 w))"
including undefined_transfer unfolding uint64_shiftl_def by transfer simp

code_printing constant uint64_shiftl \<rightharpoonup>
  (SML) "Uint64.shiftl" and
  (Haskell) "Data'_Bits.shiftlBounded" and
  (OCaml) "Uint64.shiftl" and
  (Scala) "Uint64.shiftl" and
  (Eval) "(fn x => fn i => if i < 0 orelse i >= 64 then raise (Fail \"argument to uint64'_shiftl out of bounds\") else Uint64.shiftl x i)"

definition uint64_shiftr :: "uint64 \<Rightarrow> integer \<Rightarrow> uint64"
where [code del]:
  "uint64_shiftr x n = (if n < 0 \<or> 64 \<le> n then undefined (drop_bit :: nat \<Rightarrow> uint64 \<Rightarrow> _) x n else drop_bit (nat_of_integer n) x)"

lemma shiftr_uint64_code [code]: "drop_bit n x = (if n < 64 then uint64_shiftr x (integer_of_nat n) else 0)"
  including undefined_transfer integer.lifting unfolding uint64_shiftr_def
  by transfer simp

lemma uint64_shiftr_code [code abstract]:
  "Rep_uint64 (uint64_shiftr w n) =
  (if n < 0 \<or> 64 \<le> n then Rep_uint64 (undefined (drop_bit :: nat \<Rightarrow> uint64 \<Rightarrow> _) w n) else drop_bit (nat_of_integer n) (Rep_uint64 w))"
  including undefined_transfer unfolding uint64_shiftr_def by transfer simp

code_printing constant uint64_shiftr \<rightharpoonup>
  (SML) "Uint64.shiftr" and
  (Haskell) "Data'_Bits.shiftrBounded" and
  (OCaml) "Uint64.shiftr" and
  (Scala) "Uint64.shiftr" and
  (Eval) "(fn x => fn i => if i < 0 orelse i >= 64 then raise (Fail \"argument to uint64'_shiftr out of bounds\") else Uint64.shiftr x i)"

definition uint64_sshiftr :: "uint64 \<Rightarrow> integer \<Rightarrow> uint64"
where [code del]:
  "uint64_sshiftr x n =
  (if n < 0 \<or> 64 \<le> n then undefined sshiftr_uint64 x n else sshiftr_uint64 x (nat_of_integer n))"

lemma sshiftr_uint64_code [code]:
  "x >>> n =
  (if n < 64 then uint64_sshiftr x (integer_of_nat n) else if bit x 63 then - 1 else 0)"
  including undefined_transfer integer.lifting unfolding uint64_sshiftr_def
  by transfer (simp add: not_less signed_drop_bit_beyond)

lemma uint64_sshiftr_code [code abstract]:
  "Rep_uint64 (uint64_sshiftr w n) =
  (if n < 0 \<or> 64 \<le> n then Rep_uint64 (undefined sshiftr_uint64 w n) else signed_drop_bit (nat_of_integer n) (Rep_uint64 w))"
including undefined_transfer unfolding uint64_sshiftr_def by transfer simp

code_printing constant uint64_sshiftr \<rightharpoonup>
  (SML) "Uint64.shiftr'_signed" and
  (Haskell)
    "(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint64.Int64) _)) :: Uint64.Word64)" and
  (OCaml) "Uint64.shiftr'_signed" and
  (Scala) "Uint64.shiftr'_signed" and
  (Eval) "(fn x => fn i => if i < 0 orelse i >= 64 then raise (Fail \"argument to uint64'_shiftr'_signed out of bounds\") else Uint64.shiftr'_signed x i)"

lemma uint64_msb_test_bit: "msb x \<longleftrightarrow> bit (x :: uint64) 63"
  by transfer (simp add: msb_word_iff_bit)

lemma msb_uint64_code [code]: "msb x \<longleftrightarrow> uint64_test_bit x 63"
  by (simp add: uint64_test_bit_def uint64_msb_test_bit)

lemma uint64_of_int_code [code]: "uint64_of_int i = Uint64 (integer_of_int i)"
including integer.lifting by transfer simp

lemma int_of_uint64_code [code]:
  "int_of_uint64 x = int_of_integer (integer_of_uint64 x)"
by(simp add: integer_of_uint64_def)

lemma nat_of_uint64_code [code]:
  "nat_of_uint64 x = nat_of_integer (integer_of_uint64 x)"
unfolding integer_of_uint64_def including integer.lifting by transfer simp

definition integer_of_uint64_signed :: "uint64 \<Rightarrow> integer"
where
  "integer_of_uint64_signed n = (if bit n 63 then undefined integer_of_uint64 n else integer_of_uint64 n)"

lemma integer_of_uint64_signed_code [code]:
  "integer_of_uint64_signed n =
  (if bit n 63 then undefined integer_of_uint64 n else integer_of_int (uint (Rep_uint64' n)))"
unfolding integer_of_uint64_signed_def integer_of_uint64_def
including undefined_transfer by transfer simp

lemma integer_of_uint64_code [code]:
  "integer_of_uint64 n =
  (if bit n 63 then integer_of_uint64_signed (n AND 0x7FFFFFFFFFFFFFFF) OR 0x8000000000000000 else integer_of_uint64_signed n)"
proof -
  have \<open>(0x7FFFFFFFFFFFFFFF :: uint64) = mask 63\<close>
    by (simp add: mask_eq_exp_minus_1)
  then have *: \<open>n AND 0x7FFFFFFFFFFFFFFF = take_bit 63 n\<close>
    by (simp add: take_bit_eq_mask)
  have **: \<open>(0x8000000000000000 :: int) = 2 ^ 63\<close>
    by simp
  show ?thesis
    unfolding integer_of_uint64_def integer_of_uint64_signed_def o_def *
    including undefined_transfer integer.lifting
    apply transfer
    apply (rule bit_eqI)
    apply (simp add: bit_or_iff bit_take_bit_iff bit_uint_iff)
    apply (simp only: bit_exp_iff bit_or_iff **)
    apply auto
    done
qed

code_printing
  constant "integer_of_uint64" \<rightharpoonup>
  (SML) "Uint64.toInt" and
  (Haskell) "Prelude.toInteger"
| constant "integer_of_uint64_signed" \<rightharpoonup>
  (OCaml) "Z.of'_int64" and
  (Scala) "BigInt"

section \<open>Quickcheck setup\<close>

definition uint64_of_natural :: "natural \<Rightarrow> uint64"
where "uint64_of_natural x \<equiv> Uint64 (integer_of_natural x)"

instantiation uint64 :: "{random, exhaustive, full_exhaustive}" begin
definition "random_uint64 \<equiv> qc_random_cnv uint64_of_natural"
definition "exhaustive_uint64 \<equiv> qc_exhaustive_cnv uint64_of_natural"
definition "full_exhaustive_uint64 \<equiv> qc_full_exhaustive_cnv uint64_of_natural"
instance ..
end

instantiation uint64 :: narrowing begin

interpretation quickcheck_narrowing_samples
  "\<lambda>i. let x = Uint64 i in (x, 0xFFFFFFFFFFFFFFFF - x)" "0"
  "Typerep.Typerep (STR ''Uint64.uint64'') []" .

definition "narrowing_uint64 d = qc_narrowing_drawn_from (narrowing_samples d) d"
declare [[code drop: "partial_term_of :: uint64 itself \<Rightarrow> _"]]
lemmas partial_term_of_uint64 [code] = partial_term_of_code

instance ..
end

no_notation sshiftr_uint64 (infixl ">>>" 55)

end


(* Author: Gerwin Klein, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

section "Standard Heaps as an Instance of Separation Algebra"

theory Sep_Heap_Instance
imports Separation_Algebra
begin

text \<open>
  Example instantiation of a the separation algebra to a map, i.e.\ a
  function from any type to @{typ "'a option"}.
\<close>

class opt =
  fixes none :: 'a
begin
  definition "domain f \<equiv> {x. f x \<noteq> none}"
end

instantiation option :: (type) opt
begin
  definition none_def [simp]: "none \<equiv> None"
  instance ..
end

instantiation "fun" :: (type, opt) zero
begin
  definition zero_fun_def: "0 \<equiv> \<lambda>s. none"
  instance ..
end

instantiation "fun" :: (type, opt) sep_algebra
begin

definition
  plus_fun_def: "m1 + m2 \<equiv> \<lambda>x. if m2 x = none then m1 x else m2 x"

definition
  sep_disj_fun_def: "sep_disj m1 m2 \<equiv> domain m1 \<inter> domain m2 = {}"

instance
  apply standard
        apply (simp add: sep_disj_fun_def domain_def zero_fun_def)
       apply (fastforce simp: sep_disj_fun_def)
      apply (simp add: plus_fun_def zero_fun_def)
     apply (simp add: plus_fun_def sep_disj_fun_def domain_def)
     apply (rule ext)
     apply fastforce
    apply (rule ext)
    apply (simp add: plus_fun_def)
   apply (simp add: sep_disj_fun_def domain_def plus_fun_def)
   apply fastforce
  apply (simp add: sep_disj_fun_def domain_def plus_fun_def)
  apply fastforce
  done

end

text \<open>
  For the actual option type @{const domain} and \<open>+\<close> are
  just @{const dom} and \<open>++\<close>:
\<close>

lemma domain_conv: "domain = dom"
  by (rule ext) (simp add: domain_def dom_def)

lemma plus_fun_conv: "a + b = a ++ b"
  by (auto simp: plus_fun_def map_add_def split: option.splits)

lemmas map_convs = domain_conv plus_fun_conv

text \<open>
  Any map can now act as a separation heap without further work:
\<close>
lemma
  fixes h :: "(nat => nat) => 'foo option"
  shows "(P ** Q ** H) h = (Q ** H ** P) h"
  by (simp add: sep_conj_ac)

end