(*
 * Copyright 2016, NTU
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * Author: Zhe Hou.
 *)

theory VHDL_Hoare
imports Main VHDL_Component VHDL_Syntax_Complex
begin

text {* Definition of an assertion about the state. *}

type_synonym asst = "vhdl_state \<Rightarrow> bool"

text {* Logical operations on assertions. *}

definition asst_not:: "asst \<Rightarrow> asst" (infixl "\<sim>" 60) where
"asst_not a1 \<equiv> \<lambda>x. \<not> (a1 x)"

definition asst_and:: "asst \<Rightarrow> asst \<Rightarrow> asst" (infixl "\<sqinter>" 60) where
"asst_and a1 a2 \<equiv> \<lambda>x. (a1 x) \<and> (a2 x)"

definition asst_or:: "asst \<Rightarrow> asst \<Rightarrow> asst" (infixl "\<squnion>" 60) where
"asst_or a1 a2 \<equiv> \<lambda>x. (a1 x) \<or> (a2 x)"

definition asst_imp:: "asst \<Rightarrow> asst \<Rightarrow> asst" (infixl "\<sqsupset>" 60) where
"asst_imp a1 a2 \<equiv> \<lambda>x. (a1 x) \<longrightarrow> (a2 x)"

text {* Definition of a Hoare tuple.
In addition to the triple, we need to keep records of
the current process (conc_stmt) and the list of subprograms. *}

type_synonym hoare_tuple =
"(conc_stmt \<times> subprogram list \<times> asst \<times> seq_stmt list \<times> asst)"

definition proc_of_tuple:: "hoare_tuple \<Rightarrow> conc_stmt" where
"proc_of_tuple ht \<equiv> fst ht"

definition sp_of_tuple:: "hoare_tuple \<Rightarrow> subprogram list" where
"sp_of_tuple ht \<equiv> fst (snd ht)"

definition pre_of_tuple:: "hoare_tuple \<Rightarrow> asst" where
"pre_of_tuple ht \<equiv> fst (snd (snd ht))"

definition cmd_of_tuple:: "hoare_tuple \<Rightarrow> seq_stmt list" where
"cmd_of_tuple ht \<equiv> fst (snd (snd (snd ht)))"

definition post_of_tuple:: "hoare_tuple \<Rightarrow> asst" where
"post_of_tuple ht \<equiv> snd (snd (snd (snd ht)))"

text {* Define if a Hoare tuple is valid at a pre-state. *}

definition valid_hoare_tuple:: "hoare_tuple \<Rightarrow> bool" where
"valid_hoare_tuple ht \<equiv> \<forall>x y. ((((pre_of_tuple ht) x) \<and>
  y = (fst (exec_seq_stmt_list (proc_of_tuple ht) (cmd_of_tuple ht)
  (sp_of_tuple ht) x))) \<longrightarrow>
  ((post_of_tuple ht) y))"

text {* Hoare logic rule for skip. *}

lemma skip: "valid_hoare_tuple (p,sp,P,[],P)"
unfolding valid_hoare_tuple_def pre_of_tuple_def proc_of_tuple_def
cmd_of_tuple_def sp_of_tuple_def post_of_tuple_def
by auto

text {* Hoare logic rule for variable assignment
where the variable is not a vector nor a record.
We assume that the flags for next and exit are both false,
otherwise the statement won't be executed.
Note that the flags are independent from the variable assignment
so we can separate this condition in pre and post condition. *}

lemma var_asmt: "valid_hoare_tuple (p,sp,
  ((\<lambda>x. Q(x\<lparr>state_var := (state_var x)(v := state_val_exp_t e x)\<rparr>))
    \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))),
  [sst_va n (clhs_v (lhs_v v)) (rhs_e e)],
  (Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))))"
unfolding valid_hoare_tuple_def
apply auto
proof -
def "pre" \<equiv> "((\<lambda>x. Q(x\<lparr>state_var := (state_var x)(v := state_val_exp_t e x)\<rparr>))
              \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))"
def "post" \<equiv> "(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))"
def "tuple" \<equiv> "(p, sp, pre, [sst_va n (clhs_v (lhs_v v)) (rhs_e e)], post)"
fix s::vhdl_state
assume a1: "pre_of_tuple tuple s"
from a1 show "post_of_tuple tuple (fst (exec_seq_stmt_list
  (proc_of_tuple tuple) (cmd_of_tuple tuple) (sp_of_tuple tuple) s))"
  proof -
    from a1 have "pre s"
      unfolding pre_of_tuple_def tuple_def by auto
    then have f0: "(Q (s\<lparr>state_var := (state_var s)(v := state_val_exp_t e s)\<rparr>)
              \<and> (\<not> (snd (next_flag s))) \<and> (\<not>(snd (exit_flag s))))"
      unfolding pre_def asst_and_def by auto
    then have f1: "post_of_tuple tuple (s\<lparr>state_var := (state_var s)(v := state_val_exp_t e s)\<rparr>)"
      unfolding post_of_tuple_def tuple_def post_def asst_and_def by auto
    have f2: "\<not> (snd (next_flag s)) \<and> \<not> (snd (exit_flag s))" using f0 by auto
    have "(exec_var_asmt (sst_va n (clhs_v (lhs_v v)) (rhs_e e)) s) =
              (s\<lparr>state_var := (state_var s)(v := state_val_exp_t e s)\<rparr>)"
      unfolding exec_var_asmt_def by auto
    then have f3: "\<forall>proc sp. (fst (exec_seq_stmt_list proc [] sp (exec_var_asmt (sst_va n (clhs_v (lhs_v v)) (rhs_e e)) s))) =
              (s\<lparr>state_var := (state_var s)(v := state_val_exp_t e s)\<rparr>)"
      by auto
    have "\<forall>proc sp. (fst (exec_seq_stmt_list proc [sst_va n (clhs_v (lhs_v v)) (rhs_e e)] sp s)) =
         (fst (exec_seq_stmt_list proc [] sp (exec_var_asmt (sst_va n (clhs_v (lhs_v v)) (rhs_e e)) s)))"
      using f2 by simp
    then have "\<forall>proc sp. (fst (exec_seq_stmt_list proc [sst_va n (clhs_v (lhs_v v)) (rhs_e e)] sp s)) =
              (s\<lparr>state_var := (state_var s)(v := state_val_exp_t e s)\<rparr>)"
      using f3 by auto
    then have "\<forall>proc sp. (fst (exec_seq_stmt_list proc (cmd_of_tuple tuple) sp s)) =
              (s\<lparr>state_var := (state_var s)(v := state_val_exp_t e s)\<rparr>)"
      unfolding cmd_of_tuple_def tuple_def by auto
    then show ?thesis using f1 by auto
  qed
qed

text {* Sequential rule in the case of simple variable assignment. *}

lemma var_asmt_seq:
assumes a1: "valid_hoare_tuple (p,sp,
(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))),
[sst_va n (clhs_v (lhs_v v)) (rhs_e e)],
(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))))"
and a2: "valid_hoare_tuple (p,sp,
(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))),
l,
(R\<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))))"
shows "valid_hoare_tuple (p,sp,
(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))),
(sst_va n (clhs_v (lhs_v v)) (rhs_e e))#l,
(R \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))))"
unfolding valid_hoare_tuple_def
apply auto
proof -
def "c" \<equiv> "sst_va n (clhs_v (lhs_v v)) (rhs_e e)"
def "pre" \<equiv> "(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))"
def "post" \<equiv> "(R \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))"
def "tuple" \<equiv> "(p, sp, pre, c#l, post)"
fix s::vhdl_state
assume a3: "pre_of_tuple tuple s"
then have "(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))) s"
  unfolding pre_of_tuple_def tuple_def pre_def post_def by auto
then show "post_of_tuple tuple (fst (exec_seq_stmt_list
            (proc_of_tuple tuple) (cmd_of_tuple tuple) (sp_of_tuple tuple) s))"
  proof -
    from a3 have f1: "P s \<and> \<not> (snd (next_flag s)) \<and> \<not> (snd (exit_flag s))"
      unfolding pre_of_tuple_def tuple_def pre_def asst_and_def
      by auto
    from a1 a3 have "(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))
      (fst (exec_seq_stmt_list p [c] sp s))"
      unfolding valid_hoare_tuple_def proc_of_tuple_def cmd_of_tuple_def
      sp_of_tuple_def tuple_def pre_of_tuple_def post_of_tuple_def
      post_def pre_def c_def
      by auto
    then have "post (fst (exec_seq_stmt_list p l sp (fst (exec_seq_stmt_list p [c] sp s))))"
      using a2 unfolding valid_hoare_tuple_def proc_of_tuple_def cmd_of_tuple_def
      sp_of_tuple_def tuple_def pre_of_tuple_def post_of_tuple_def post_def
      by auto
    then have "post (fst (exec_seq_stmt_list p (c#l) sp s))"
      unfolding post_def c_def using f1
      by auto
    then show ?thesis
      unfolding proc_of_tuple_def cmd_of_tuple_def sp_of_tuple_def
      tuple_def post_of_tuple_def pre_def post_def
      by auto
  qed
qed

text {* Hoare logic rule for signal assignment
where the signal/port is not a vector nor a record.
We assume that the flags for next and exit are both false,
otherwise the statement won't be executed.
Note that the flags are independent from the signal assignment
so we can separate this condition in pre and post condition.
Note also that we only update the driving value of the signal/port. *}

lemma sig_asmt: "valid_hoare_tuple (p,sp,
  ((\<lambda>x. Q(x\<lparr>state_dr_val := (state_dr_val x)
        (sg := ((state_dr_val x) sg)(p := state_val_exp_t e x))\<rparr>))
    \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))),
  [sst_sa n (clhs_sp (lhs_s sg)) (rhs_e e)],
  (Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))))"
unfolding valid_hoare_tuple_def
apply auto
proof -
def "pre" \<equiv> "((\<lambda>x. Q(x\<lparr>state_dr_val := (state_dr_val x)
            (sg := ((state_dr_val x) sg)(p := state_val_exp_t e x))\<rparr>))
            \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))"
def "post" \<equiv> "(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))"
def "tuple" \<equiv> "(p, sp, pre, [sst_sa n (clhs_sp (lhs_s sg)) (rhs_e e)], post)"
fix s::vhdl_state
assume a1: "pre_of_tuple tuple s"
then show "post_of_tuple tuple (fst (exec_seq_stmt_list
            (proc_of_tuple tuple) (cmd_of_tuple tuple) (sp_of_tuple tuple) s))"
  proof -
    from a1 have "pre s"
      unfolding pre_of_tuple_def tuple_def by auto
    then have f0: "(Q (s\<lparr>state_dr_val := (state_dr_val s)
            (sg := ((state_dr_val s) sg)(p := state_val_exp_t e s))\<rparr>))
            \<and> (\<not> (snd (next_flag s))) \<and> (\<not>(snd (exit_flag s)))"
      unfolding pre_def asst_and_def by auto
    then have f1: "post_of_tuple tuple (s\<lparr>state_dr_val := (state_dr_val s)
            (sg := ((state_dr_val s) sg)(p := state_val_exp_t e s))\<rparr>)"
      unfolding post_of_tuple_def tuple_def post_def asst_and_def by auto
    have f2: "\<not> (snd (next_flag s)) \<and> \<not> (snd (exit_flag s))" using f0 by auto
    have "(exec_sig_asmt p (sst_sa n (clhs_sp (lhs_s sg)) (rhs_e e)) s) =
              (s\<lparr>state_dr_val := (state_dr_val s)
              (sg := ((state_dr_val s) sg)(p := state_val_exp_t e s))\<rparr>)"
      unfolding exec_sig_asmt_def by auto
    then have f3: "\<forall>sp. (fst (exec_seq_stmt_list p [] sp (exec_sig_asmt p (sst_sa n (clhs_sp (lhs_s sg)) (rhs_e e)) s))) =
              (s\<lparr>state_dr_val := (state_dr_val s)
              (sg := ((state_dr_val s) sg)(p := state_val_exp_t e s))\<rparr>)"
      by auto
    have "\<forall>sp. (fst (exec_seq_stmt_list p [sst_sa n (clhs_sp (lhs_s sg)) (rhs_e e)] sp s)) =
         (fst (exec_seq_stmt_list p [] sp (exec_sig_asmt p (sst_sa n (clhs_sp (lhs_s sg)) (rhs_e e)) s)))"
      using f2 by simp
    then have "\<forall>sp. (fst (exec_seq_stmt_list p [sst_sa n (clhs_sp (lhs_s sg)) (rhs_e e)] sp s)) =
              (s\<lparr>state_dr_val := (state_dr_val s)
              (sg := ((state_dr_val s) sg)(p := state_val_exp_t e s))\<rparr>)"
      using f3 by auto
    then have "\<forall>sp. (fst (exec_seq_stmt_list p (cmd_of_tuple tuple) sp s)) =
              (s\<lparr>state_dr_val := (state_dr_val s)
              (sg := ((state_dr_val s) sg)(p := state_val_exp_t e s))\<rparr>)"
      unfolding cmd_of_tuple_def tuple_def by auto
    then show ?thesis unfolding proc_of_tuple_def using f1 tuple_def
      by auto
  qed
qed

text {* Sequential rule in the case of (simple) signal assignment. *}

lemma sig_asmt_seq:
assumes a1: "valid_hoare_tuple (p,sp,
(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))),
[sst_sa n (clhs_sp (lhs_s sg)) (rhs_e e)],
(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))))"
and a2: "valid_hoare_tuple (p,sp,
(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))),
l,
(R\<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))))"
shows "valid_hoare_tuple (p,sp,
(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))),
(sst_sa n (clhs_sp (lhs_s sg)) (rhs_e e))#l,
(R \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))))"
unfolding valid_hoare_tuple_def
apply auto
proof -
def "c" \<equiv> "sst_sa n (clhs_sp (lhs_s sg)) (rhs_e e)"
def "pre" \<equiv> "(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))"
def "post" \<equiv> "(R \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))"
def "tuple" \<equiv> "(p, sp, pre, c#l, post)"
fix s::vhdl_state
assume a3: "pre_of_tuple tuple s"
then have "(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))) s"
  unfolding pre_of_tuple_def tuple_def pre_def post_def by auto
then show "post_of_tuple tuple (fst (exec_seq_stmt_list
            (proc_of_tuple tuple) (cmd_of_tuple tuple) (sp_of_tuple tuple) s))"
  proof -
    from a3 have f1: "P s \<and> \<not> (snd (next_flag s)) \<and> \<not> (snd (exit_flag s))"
      unfolding pre_of_tuple_def tuple_def pre_def asst_and_def
      by auto
    from a1 a3 have "(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))
      (fst (exec_seq_stmt_list p [c] sp s))"
      unfolding valid_hoare_tuple_def proc_of_tuple_def cmd_of_tuple_def
      sp_of_tuple_def tuple_def pre_of_tuple_def post_of_tuple_def
      post_def pre_def c_def
      by auto
    then have "post (fst (exec_seq_stmt_list p l sp (fst (exec_seq_stmt_list p [c] sp s))))"
      using a2 unfolding valid_hoare_tuple_def proc_of_tuple_def cmd_of_tuple_def
      sp_of_tuple_def tuple_def pre_of_tuple_def post_of_tuple_def post_def
      by auto
    then have "post (fst (exec_seq_stmt_list p (c#l) sp s))"
      unfolding post_def c_def using f1
      by auto
    then show ?thesis
      unfolding proc_of_tuple_def cmd_of_tuple_def sp_of_tuple_def
      tuple_def post_of_tuple_def pre_def post_def
      by auto
  qed
qed

text {* Hoare logical rule for if statement.
We assume that the flags for next and exit are both false,
otherwise the statement won't be executed. *}

lemma if_stmt:
assumes a1: "valid_hoare_tuple (p,sp,
(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))) \<sqinter>
  (\<lambda>x. (state_val_exp_t c x = Some (val_b True)))),
l1,
(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))))"
and a2: "valid_hoare_tuple (p,sp,
(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))) \<sqinter>
  (\<lambda>x. (state_val_exp_t c x \<noteq> Some (val_b True)))),
l2,
(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))))"
shows "valid_hoare_tuple (p,sp,
(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))),
[sst_if n c l1 l2],
(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))))"
unfolding valid_hoare_tuple_def
apply auto
proof -
def "pre" \<equiv> "P \<sqinter> (\<lambda>x. \<not> snd (next_flag x)) \<sqinter> (\<lambda>x. \<not> snd (exit_flag x))"
def "post" \<equiv> "Q \<sqinter> (\<lambda>x. \<not> snd (next_flag x)) \<sqinter> (\<lambda>x. \<not> snd (exit_flag x))"
def "tuple" \<equiv> "(p, sp, pre, [sst_if n c l1 l2], post)"
fix s::vhdl_state
assume a3: "pre_of_tuple tuple s"
then have "pre s" unfolding pre_of_tuple_def tuple_def by auto
then have f2: "P s \<and> \<not> snd (next_flag s) \<and> \<not> snd (exit_flag s)"
unfolding pre_def asst_and_def by auto
then show "post_of_tuple tuple (fst (exec_seq_stmt_list
            (proc_of_tuple tuple) (cmd_of_tuple tuple) (sp_of_tuple tuple) s))"
  proof (cases "(state_val_exp_t c s = Some (val_b True))")
    case True
    then have f1: "(state_val_exp_t c s = Some (val_b True))" by auto
    then have "(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))) \<sqinter>
      (\<lambda>x. (state_val_exp_t c x = Some (val_b True)))) s"
      using f2 unfolding asst_and_def by auto
    then have "(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))
      (fst (exec_seq_stmt_list p l1 sp s))"
      using a1 unfolding valid_hoare_tuple_def pre_of_tuple_def post_of_tuple_def
      proc_of_tuple_def cmd_of_tuple_def sp_of_tuple_def by auto
    then have "(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))
      (fst (exec_seq_stmt_list p [sst_if n c l1 l2] sp s))"
      using f1 f2 by auto
    then show ?thesis
      unfolding cmd_of_tuple_def tuple_def post_of_tuple_def post_def
      proc_of_tuple_def sp_of_tuple_def by auto
  next
    case False
    then have f1: "(state_val_exp_t c s \<noteq> Some (val_b True))" by auto
    then have "(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))) \<sqinter>
      (\<lambda>x. (state_val_exp_t c x \<noteq> Some (val_b True)))) s"
      using f2 unfolding asst_and_def by auto
    then have "(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))
      (fst (exec_seq_stmt_list p l2 sp s))"
      using a2 unfolding valid_hoare_tuple_def pre_of_tuple_def post_of_tuple_def
      proc_of_tuple_def cmd_of_tuple_def sp_of_tuple_def by auto
    then have "(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))
      (fst (exec_seq_stmt_list p [sst_if n c l1 l2] sp s))"
      using f1 f2
      apply auto
      apply (cases "state_val_exp_t c s")
       apply auto
      apply (case_tac "a")
            by auto
    then show ?thesis
      unfolding cmd_of_tuple_def tuple_def post_of_tuple_def post_def
      proc_of_tuple_def sp_of_tuple_def by auto
  qed
qed

text {* Sequential rule in the case of if statement. *}

lemma if_stmt_seq:
assumes a1: "valid_hoare_tuple (p,sp,
(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))),
[sst_if n c l1 l2],
(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))))"
and a2: "valid_hoare_tuple (p,sp,
(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))),
l,
(R\<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))))"
shows "valid_hoare_tuple (p,sp,
(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))),
(sst_if n c l1 l2)#l,
(R \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))))"
unfolding valid_hoare_tuple_def
apply auto
proof -
def "c" \<equiv> "sst_if n c l1 l2"
def "pre" \<equiv> "(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))"
def "post" \<equiv> "(R \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))"
def "tuple" \<equiv> "(p, sp, pre, c#l, post)"
fix s::vhdl_state
assume a3: "pre_of_tuple tuple s"
then have "(P \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x)))) s"
  unfolding pre_of_tuple_def tuple_def pre_def post_def by auto
then show "post_of_tuple tuple (fst (exec_seq_stmt_list
            (proc_of_tuple tuple) (cmd_of_tuple tuple) (sp_of_tuple tuple) s))"
  proof -
    from a3 have f1: "P s \<and> \<not> (snd (next_flag s)) \<and> \<not> (snd (exit_flag s))"
      unfolding pre_of_tuple_def tuple_def pre_def asst_and_def
      by auto
    from a1 a3 have "(Q \<sqinter> (\<lambda>x. \<not> (snd (next_flag x))) \<sqinter> (\<lambda>x. \<not>(snd (exit_flag x))))
      (fst (exec_seq_stmt_list p [c] sp s))"
      unfolding valid_hoare_tuple_def proc_of_tuple_def cmd_of_tuple_def
      sp_of_tuple_def tuple_def pre_of_tuple_def post_of_tuple_def
      post_def pre_def c_def
      by auto
    then have "post (fst (exec_seq_stmt_list p l sp (fst (exec_seq_stmt_list p [c] sp s))))"
      using a2 unfolding valid_hoare_tuple_def proc_of_tuple_def cmd_of_tuple_def
      sp_of_tuple_def tuple_def pre_of_tuple_def post_of_tuple_def post_def
      by auto
    then have "post (fst (exec_seq_stmt_list p (c#l) sp s))"
      unfolding post_def c_def using f1
      by auto
    then show ?thesis
      unfolding proc_of_tuple_def cmd_of_tuple_def sp_of_tuple_def
      tuple_def post_of_tuple_def pre_def post_def
      by auto
  qed
qed

text {* The consequence rule. *}

lemma consequence:
assumes a1: "\<forall>x. P' x \<longrightarrow> P x"
assumes a2: "valid_hoare_tuple (p,sp,P,l,Q)"
assumes a3: "\<forall>x. Q x \<longrightarrow> Q' x"
shows "valid_hoare_tuple (p,sp,P',l,Q')"
proof -
  show ?thesis using a1 a2 a3
    unfolding valid_hoare_tuple_def pre_of_tuple_def post_of_tuple_def
    cmd_of_tuple_def proc_of_tuple_def sp_of_tuple_def
    by auto
qed

text {* Hoare-style semantics for update_sigprt. *}

definition valid_update_sigprt:: "sigprt list \<Rightarrow> asst \<Rightarrow> asst \<Rightarrow> bool" where
"valid_update_sigprt spl P Q \<equiv>
  \<forall>x y. ((P x \<and> y = update_sigprt spl x) \<longrightarrow> Q y)"

lemma update_sigprt_base: "valid_update_sigprt [sp]
(\<lambda>w. Q(w\<lparr>state_sp := (state_sp w)(sp := (state_eff_val w sp))\<rparr>))
Q"
unfolding valid_update_sigprt_def
by auto

lemma update_sigprt_step:
assumes a1: "valid_update_sigprt [sp] P Q"
assumes a2: "valid_update_sigprt spl Q R"
shows "valid_update_sigprt (sp#spl) P R"
unfolding valid_update_sigprt_def
apply auto
proof -
fix s::vhdl_state
def "s'" \<equiv> "(s\<lparr>state_sp := (state_sp s)(sp := state_eff_val s sp)\<rparr>)"
assume a3: "P s"
then show "R (update_sigprt spl s')"
  proof -
    from a1 a3 have "Q s'" unfolding valid_update_sigprt_def s'_def
      by auto
    then show ?thesis using a2 unfolding valid_update_sigprt_def
      by auto
  qed
qed

text {* Hoare-style semantics for comp_eff_val. *}

definition valid_comp_eff_val:: "sigprt list \<Rightarrow> vhdl_desc\<Rightarrow> asst \<Rightarrow> asst \<Rightarrow> bool" where
"valid_comp_eff_val spl desc P Q \<equiv>
  \<forall>x y. ((P x \<and> y = comp_eff_val spl desc x) \<longrightarrow> Q y)"

lemma comp_eff_val_base: "valid_comp_eff_val [sp] desc
  (\<lambda>w. Q(w\<lparr>state_eff_val := (state_eff_val w)(sp := (get_eff_val sp desc w))\<rparr>)) Q"
unfolding valid_comp_eff_val_def
by auto

lemma comp_eff_val_step:
assumes a1: "valid_comp_eff_val [sp] desc P Q"
assumes a2: "valid_comp_eff_val spl desc Q R"
shows "valid_comp_eff_val (sp#spl) desc P R"
unfolding valid_comp_eff_val_def
apply auto
proof -
fix s::vhdl_state
def "s'" \<equiv> "(s\<lparr>state_eff_val := (state_eff_val s)(sp := get_eff_val sp desc s)\<rparr>)"
assume a3: "P s"
then show "R (comp_eff_val spl desc s')"
  proof -
    from a1 a3 have "Q s'" unfolding valid_comp_eff_val_def s'_def
      by auto
    then show ?thesis using a2 unfolding valid_comp_eff_val_def
      by auto
  qed
qed

text {* Hoare style semantics for exec_proc_all. *}

definition valid_exec_proc_all:: "conc_stmt_list \<Rightarrow> sigprt list \<Rightarrow> subprogram list \<Rightarrow>
  asst \<Rightarrow> asst \<Rightarrow> bool" where
"valid_exec_proc_all csl spl spgl P Q \<equiv>
  \<forall>x y. ((P x \<and> y = exec_proc_all csl spl spgl x) \<longrightarrow> Q y)"

lemma exec_proc_all_base:
assumes a1: "valid_hoare_tuple ((cst_ps n sensl ssl),spgl,P,ssl,Q)"
assumes a2: "has_active_sigprt sensl spl"
shows "valid_exec_proc_all [cst_ps n sensl ssl] spl spgl P Q"
unfolding valid_exec_proc_all_def
apply (simp add: a2)
using a1 unfolding valid_hoare_tuple_def pre_of_tuple_def proc_of_tuple_def
cmd_of_tuple_def sp_of_tuple_def post_of_tuple_def
by auto

lemma exec_proc_all_base2:
assumes a1: "\<not> (has_active_sigprt sensl spl)"
shows "valid_exec_proc_all [cst_ps n sensl ssl] spl spgl P P"
unfolding valid_exec_proc_all_def
using a1 by auto

lemma exec_proc_all_step:
assumes a1: "valid_exec_proc_all [cst_ps n sensl ssl] spl spgl P Q"
assumes a2: "valid_exec_proc_all cs spl spgl Q R"
shows "valid_exec_proc_all ((cst_ps n sensl ssl)#cs) spl spgl P R"
unfolding valid_exec_proc_all_def
apply auto
 proof -
 fix s::vhdl_state
 def "s'" \<equiv> "(fst (exec_seq_stmt_list (cst_ps n sensl ssl) ssl spgl s))"
 assume a3: "P s"
 assume a4: "has_active_sigprt sensl spl"
 from a3 a4 show "R (exec_proc_all cs spl spgl (fst (exec_seq_stmt_list (cst_ps n sensl ssl) ssl spgl s)))"
   proof -
    from a1 a3 a4 have "Q s'" unfolding valid_exec_proc_all_def s'_def
      by auto
    then show ?thesis using a2 unfolding valid_exec_proc_all_def s'_def
      by auto
   qed
 next
 fix s::vhdl_state
 def "s'" \<equiv> "(fst (exec_seq_stmt_list (cst_ps n sensl ssl) ssl spgl s))"
 assume a5: "P s"
 assume a6: "\<not> (has_active_sigprt sensl spl)"
 from a5 a6 show "R (exec_proc_all cs spl spgl s)"
  proof -
    from a1 a5 a6 have "Q s" unfolding valid_exec_proc_all_def s'_def
      by auto
    then show ?thesis using a2 unfolding valid_exec_proc_all_def
      by auto
  qed
 qed

text {* Hoare style semantics for resume_processes. *}

definition valid_resume_processes:: "vhdl_desc \<Rightarrow> sigprt list \<Rightarrow> asst \<Rightarrow> asst \<Rightarrow> bool" where
"valid_resume_processes desc spl P Q \<equiv>
  \<forall>x y. ((P x \<and> y = resume_processes desc spl x) \<longrightarrow> (Q y))"

text {* Auxiliary lemmas in the case of act_sp1 = []. *}

lemma emp_spl_has_active_sigprt: "has_active_sigprt sl [] = False"
apply (induction "sl")
 apply auto
by (simp add: List.member_def)

lemma emp_spl_find_active_process: "find_active_process cs [] = False"
apply (induction "cs")
 apply auto
using emp_spl_has_active_sigprt
by (metis (no_types, lifting) conc_stmt.case conc_stmt.exhaust)

lemma emp_no_active_proc: "has_active_processes desc [] = False"
unfolding has_active_processes_def
using emp_spl_find_active_process by auto

text {* Here we prove a simplified version: when signals in any processes'
sensitivity list are unchanged, the act_sp1 in resume_processes will be empty.
Assuming this is true, then resume_processes will not do recursive calls. *}

lemma resume_processes_no_rec:
assumes a1: "valid_exec_proc_all (fst (snd (snd desc))) spl (snd (snd (snd desc))) P Q"
assumes a2: "valid_comp_eff_val (env_sp (fst desc)) desc Q (R \<sqinter> (\<lambda>x. active_sigprts desc x = []))"
assumes a3: "valid_update_sigprt (env_sp (fst desc)) (R \<sqinter> (\<lambda>x. active_sigprts desc x = [])) S"
shows "valid_resume_processes desc spl P S"
unfolding valid_resume_processes_def
apply auto
proof -
fix s::vhdl_state
def "exe" \<equiv> "exec_proc_all (fst (snd (snd desc))) spl (snd (snd (snd desc))) s"
def "eff" \<equiv> "comp_eff_val (env_sp (fst desc)) desc exe"
def "up" \<equiv> "update_sigprt (env_sp (fst desc)) eff"
assume a4: "P s"
then show "S (let state2 = eff;
                  act_sp1 = active_sigprts desc state2;
                  state3 = update_sigprt (env_sp (fst desc)) state2
              in
              if has_active_processes desc act_sp1 then resume_processes desc act_sp1 state3
              else state3)"
  proof -
    from a1 a4 have "Q exe"
      unfolding valid_exec_proc_all_def exe_def
      by auto
    then have a5: "(R \<sqinter> (\<lambda>x. active_sigprts desc x = [])) eff"
      using a2 unfolding valid_comp_eff_val_def exe_def eff_def
      by auto
    then have "S (update_sigprt (env_sp (fst desc)) eff)"
      using a3 unfolding valid_update_sigprt_def eff_def exe_def
      by auto
    then have "S (let state2 = eff;
                  act_sp1 = active_sigprts desc state2;
                  state3 = update_sigprt (env_sp (fst desc)) state2
              in state3)"
      by auto
    then have "S (let state2 = eff;
                  act_sp1 = [];
                  state3 = update_sigprt (env_sp (fst desc)) state2
              in state3)"
      using a5 by auto
    then have "S (let state2 = eff;
                  act_sp1 = [];
                  state3 = update_sigprt (env_sp (fst desc)) state2
              in
              if has_active_processes desc act_sp1 then resume_processes desc act_sp1 state3
              else state3)"
      using emp_no_active_proc by auto
    then show ?thesis using a5 unfolding eff_def exe_def
      by (simp add: asst_and_def)
  qed
qed

text {* Hoare style rules for exec_sim_cyc. *}

definition valid_exec_sim_cyc:: "vhdl_desc \<Rightarrow> vhdl_state \<Rightarrow> asst \<Rightarrow> asst \<Rightarrow> bool" where
"valid_exec_sim_cyc desc s P Q \<equiv>
\<forall>y. (P s \<and> y = exec_sim_cyc desc s) \<longrightarrow> Q y"

lemma exec_sim_cyc_no_act:
"valid_exec_sim_cyc desc state
(P \<sqinter> (\<lambda>x. \<not> (has_active_processes desc (active_sigprts desc x))))
(P \<sqinter> (\<lambda>x. \<not> (has_active_processes desc (active_sigprts desc x))))"
unfolding valid_exec_sim_cyc_def asst_and_def
by (simp add: exec_sim_cyc_def)

lemma exec_sim_cyc_act:
assumes a1: "valid_resume_processes desc (active_sigprts desc state)
(P \<sqinter> (\<lambda>x. (has_active_processes desc (active_sigprts desc x)))) Q"
shows "valid_exec_sim_cyc desc state
(P \<sqinter> (\<lambda>x. (has_active_processes desc (active_sigprts desc x)))) Q"
unfolding valid_exec_sim_cyc_def
apply auto
proof -
assume "(P \<sqinter> (\<lambda>x. has_active_processes desc (active_sigprts desc x))) state"
then show "Q (exec_sim_cyc desc state)" using a1 unfolding valid_resume_processes_def
  by (auto simp add: exec_sim_cyc_def asst_and_def)
qed

end


(*  Title:       Deriving class instances for datatypes
    Author:      Christian Sternagel and René Thiemann  <christian.sternagel|rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)
subsection \<open>Compare Generator\<close>

theory Compare_Generator
imports
  Comparator_Generator
  Compare
begin

text \<open>We provide a generator which takes the comparators of the comparator generator
  to synthesize suitable @{const compare}-functions from the @{class compare}-class.

One can further also use these comparison functions to derive an instance of the
@{class compare_order}-class, and therefore also for @{class linorder}. In total, we provide the three
@{text derive}-methods where the example type @{type prod} can be replaced by any other datatype.

\begin{itemize}
\item @{text "derive compare prod"} creates an instance @{type prod} :: (@{class compare}, @{class compare}) @{class compare}.
\item @{text "derive compare_order prod"} creates an instance @{type prod} :: (@{class compare}, @{class compare}) @{class compare_order}.
\item @{text "derive linorder prod"} creates an instance @{type prod} :: (@{class linorder}, @{class linorder}) @{class linorder}.
\end{itemize}

Usually, the use of @{text "derive linorder"} is not recommended if there are comparators available:
Internally, the linear orders will directly be converted into comparators, so a direct use of the
comparators will result in more efficient generated code. This command is mainly provided as a convenience method
where comparators are not yet present. For example, at the time of writing, the Container Framework
has partly been adapted to internally use comparators, whereas in other AFP-entries, we did not
integrate comparators.
\<close>

lemma linorder_axiomsD: assumes "class.linorder le lt"
  shows
  "lt x y = (le x y \<and> \<not> le y x)" (is ?a)
  "le x x" (is ?b)
  "le x y \<Longrightarrow> le y z \<Longrightarrow> le x z" (is "?c1 \<Longrightarrow> ?c2 \<Longrightarrow> ?c3")
  "le x y \<Longrightarrow> le y x \<Longrightarrow> x = y" (is "?d1 \<Longrightarrow> ?d2 \<Longrightarrow> ?d3")
  "le x y \<or> le y x" (is ?e)
proof -
  interpret linorder le lt by fact
  show ?a ?b "?c1 \<Longrightarrow> ?c2 \<Longrightarrow> ?c3" "?d1 \<Longrightarrow> ?d2 \<Longrightarrow> ?d3" ?e by auto
qed

named_theorems compare_simps "simp theorems to derive \"compare = comparator_of\""

ML_file "compare_generator.ML"

end


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

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

theory Uint32 imports
  Code_Target_Word_Base
begin

declare prod.Quotient[transfer_rule]

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

typedef uint32 = "UNIV :: 32 word set" ..

setup_lifting type_definition_uint32

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

declare Quotient_uint32[transfer_rule]

instantiation uint32 :: comm_ring_1
begin
lift_definition zero_uint32 :: uint32 is "0 :: 32 word" .
lift_definition one_uint32 :: uint32 is "1" .
lift_definition plus_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" is "(+) :: 32 word \<Rightarrow> _" .
lift_definition minus_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" is "(-)" .
lift_definition uminus_uint32 :: "uint32 \<Rightarrow> uint32" is uminus .
lift_definition times_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" is "(*)" .
instance by (standard; transfer) (simp_all add: algebra_simps)
end

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

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

lemmas [code] = less_uint32.rep_eq less_eq_uint32.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_uint32) numeral numeral"
  by transfer_prover

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

end

instantiation uint32:: semiring_bits
begin

lift_definition bit_uint32 :: \<open>uint32 \<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 uint32 :: semiring_bit_shifts
begin
lift_definition push_bit_uint32 :: \<open>nat \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is push_bit .
lift_definition drop_bit_uint32 :: \<open>nat \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is drop_bit .
lift_definition take_bit_uint32 :: \<open>nat \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is take_bit .
instance by (standard; transfer)
  (fact push_bit_eq_mult drop_bit_eq_div take_bit_eq_mod)+
end

instantiation uint32 :: ring_bit_operations
begin
lift_definition not_uint32 :: \<open>uint32 \<Rightarrow> uint32\<close> is NOT .
lift_definition and_uint32 :: \<open>uint32 \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is \<open>(AND)\<close> .
lift_definition or_uint32 :: \<open>uint32 \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is \<open>(OR)\<close> .
lift_definition xor_uint32 :: \<open>uint32 \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is \<open>(XOR)\<close> .
lift_definition mask_uint32 :: \<open>nat \<Rightarrow> uint32\<close> is mask .
lift_definition set_bit_uint32 :: \<open>nat \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is \<open>Bit_Operations.set_bit\<close> .
lift_definition unset_bit_uint32 :: \<open>nat \<Rightarrow> uint32 \<Rightarrow> uint32\<close> is \<open>unset_bit\<close> .
lift_definition flip_bit_uint32 :: \<open>nat \<Rightarrow> uint32 \<Rightarrow> uint32\<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 :: uint32) OR mask n\<close>
  \<open>mask 0 = (0 :: uint32)\<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 :: uint32
  by (fact set_bit_eq_or)

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

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

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

instantiation uint32 :: msb
begin
lift_definition msb_uint32 :: \<open>uint32 \<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 uint32 :: set_bit
begin
lift_definition set_bit_uint32 :: \<open>uint32 \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint32\<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 uint32 :: bit_comprehension begin
lift_definition set_bits_uint32 :: "(nat \<Rightarrow> bool) \<Rightarrow> uint32" is "set_bits" .
instance by (standard; transfer) (fact set_bits_bit_eq)
end

lemmas [code] = bit_uint32.rep_eq lsb_uint32.rep_eq msb_uint32.rep_eq

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

lemmas [code] = equal_uint32.rep_eq

instantiation uint32 :: size begin
lift_definition size_uint32 :: "uint32 \<Rightarrow> nat" is "size" .
instance ..
end

lemmas [code] = size_uint32.rep_eq

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

lift_definition uint32_of_int :: "int \<Rightarrow> uint32" is "word_of_int" .

definition uint32_of_nat :: "nat \<Rightarrow> uint32"
where "uint32_of_nat = uint32_of_int \<circ> int"

lift_definition int_of_uint32 :: "uint32 \<Rightarrow> int" is "uint" .
lift_definition nat_of_uint32 :: "uint32 \<Rightarrow> nat" is "unat" .

definition integer_of_uint32 :: "uint32 \<Rightarrow> integer"
where "integer_of_uint32 = integer_of_int o int_of_uint32"

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

context includes integer.lifting begin

lift_definition Uint32 :: "integer \<Rightarrow> uint32" is "word_of_int" .

lemma Rep_uint32_numeral [simp]: "Rep_uint32 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint32_def Abs_uint32_inverse numeral.simps plus_uint32_def)

lemma numeral_uint32_transfer [transfer_rule]:
  "(rel_fun (=) cr_uint32) numeral numeral"
by(auto simp add: cr_uint32_def)

lemma numeral_uint32 [code_unfold]: "numeral n = Uint32 (numeral n)"
by transfer simp

lemma Rep_uint32_neg_numeral [simp]: "Rep_uint32 (- numeral n) = - numeral n"
by(simp only: uminus_uint32_def)(simp add: Abs_uint32_inverse)

lemma neg_numeral_uint32 [code_unfold]: "- numeral n = Uint32 (- numeral n)"
by transfer(simp add: cr_uint32_def)

end

lemma Abs_uint32_numeral [code_post]: "Abs_uint32 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint32_def numeral.simps plus_uint32_def Abs_uint32_inverse)

lemma Abs_uint32_0 [code_post]: "Abs_uint32 0 = 0"
by(simp add: zero_uint32_def)

lemma Abs_uint32_1 [code_post]: "Abs_uint32 1 = 1"
by(simp add: one_uint32_def)

section \<open>Code setup\<close>

code_printing code_module Uint32 \<rightharpoonup> (SML)
\<open>(* Test that words can handle numbers between 0 and 31 *)
val _ = if 5 <= Word.wordSize then () else raise (Fail ("wordSize less than 5"));

structure Uint32 : sig
  val set_bit : Word32.word -> IntInf.int -> bool -> Word32.word
  val shiftl : Word32.word -> IntInf.int -> Word32.word
  val shiftr : Word32.word -> IntInf.int -> Word32.word
  val shiftr_signed : Word32.word -> IntInf.int -> Word32.word
  val test_bit : Word32.word -> IntInf.int -> bool
end = struct

fun set_bit x n b =
  let val mask = Word32.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))
  in if b then Word32.orb (x, mask)
     else Word32.andb (x, Word32.notb mask)
  end

fun shiftl x n =
  Word32.<< (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr x n =
  Word32.>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr_signed x n =
  Word32.~>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun test_bit x n =
  Word32.andb (x, Word32.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))) <> Word32.fromInt 0

end; (* struct Uint32 *)\<close>
code_reserved SML Uint32

code_printing code_module Uint32 \<rightharpoonup> (Haskell)
 \<open>module Uint32(Int32, Word32) where

  import Data.Int(Int32)
  import Data.Word(Word32)\<close>
code_reserved Haskell Uint32

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

definition Uint32_signed :: "integer \<Rightarrow> uint32"
where "Uint32_signed i = (if i < -(0x80000000) \<or> i \<ge> 0x80000000 then undefined Uint32 i else Uint32 i)"

lemma Uint32_code [code]:
  "Uint32 i =
  (let i' = i AND 0xFFFFFFFF
   in if bit i' 31 then Uint32_signed (i' - 0x100000000) else Uint32_signed i')"
  including undefined_transfer integer.lifting unfolding Uint32_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 Uint32_signed_code [code abstract]:
  "Rep_uint32 (Uint32_signed i) =
  (if i < -(0x80000000) \<or> i \<ge> 0x80000000 then Rep_uint32 (undefined Uint32 i) else word_of_int (int_of_integer_symbolic i))"
unfolding Uint32_signed_def Uint32_def int_of_integer_symbolic_def word_of_integer_def
by(simp add: Abs_uint32_inverse)

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

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

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

  To convert @{typ "32 word"} values into @{typ uint32}, use @{term "Abs_uint32'"}.
\<close>

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

lemma Rep_uint32'_transfer [transfer_rule]:
  "rel_fun cr_uint32 (=) (\<lambda>x. x) Rep_uint32'"
unfolding Rep_uint32'_def by(rule uint32.rep_transfer)

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

lift_definition Abs_uint32' :: "32 word \<Rightarrow> uint32" is "\<lambda>x :: 32 word. x" .

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

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

lemma term_of_uint32_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 ''Uint32.uint32.Abs_uint32'') (TR (STR ''fun'') [TR (STR ''Word.word'') [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR (STR ''Numeral_Type.num1'') []]]]]]], TR (STR ''Uint32.uint32'') []]))
       (term_of_class.term_of (Rep_uint32' x))"
by(simp add: term_of_anything)

code_printing
  type_constructor uint32 \<rightharpoonup>
  (SML) "Word32.word" and
  (Haskell) "Uint32.Word32" and
  (OCaml) "int32" and
  (Scala) "Int" and
  (Eval) "Word32.word"
| constant Uint32 \<rightharpoonup>
  (SML) "Word32.fromLargeInt (IntInf.toLarge _)" and
  (Haskell) "(Prelude.fromInteger _ :: Uint32.Word32)" and
  (Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint32.Word32)" and
  (Scala) "_.intValue"
| constant Uint32_signed \<rightharpoonup>
  (OCaml) "Z.to'_int32"
| constant "0 :: uint32" \<rightharpoonup>
  (SML) "(Word32.fromInt 0)" and
  (Haskell) "(0 :: Uint32.Word32)" and
  (OCaml) "Int32.zero" and
  (Scala) "0"
| constant "1 :: uint32" \<rightharpoonup>
  (SML) "(Word32.fromInt 1)" and
  (Haskell) "(1 :: Uint32.Word32)" and
  (OCaml) "Int32.one" and
  (Scala) "1"
| constant "plus :: uint32 \<Rightarrow> _ " \<rightharpoonup>
  (SML) "Word32.+ ((_), (_))" and
  (Haskell) infixl 6 "+" and
  (OCaml) "Int32.add" and
  (Scala) infixl 7 "+"
| constant "uminus :: uint32 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word32.~" and
  (Haskell) "negate" and
  (OCaml) "Int32.neg" and
  (Scala) "!(- _)"
| constant "minus :: uint32 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word32.- ((_), (_))" and
  (Haskell) infixl 6 "-" and
  (OCaml) "Int32.sub" and
  (Scala) infixl 7 "-"
| constant "times :: uint32 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word32.* ((_), (_))" and
  (Haskell) infixl 7 "*" and
  (OCaml) "Int32.mul" and
  (Scala) infixl 8 "*"
| constant "HOL.equal :: uint32 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "!((_ : Word32.word) = _)" and
  (Haskell) infix 4 "==" and
  (OCaml) "(Int32.compare _ _ = 0)" and
  (Scala) infixl 5 "=="
| class_instance uint32 :: equal \<rightharpoonup>
  (Haskell) -
| constant "less_eq :: uint32 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Word32.<= ((_), (_))" and
  (Haskell) infix 4 "<=" and
  (OCaml) "Uint32.less'_eq" and
  (Scala) "Uint32.less'_eq"
| constant "less :: uint32 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Word32.< ((_), (_))" and
  (Haskell) infix 4 "<" and
  (OCaml) "Uint32.less" and
  (Scala) "Uint32.less"
| constant "NOT :: uint32 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word32.notb" and
  (Haskell) "Data'_Bits.complement" and
  (OCaml) "Int32.lognot" and
  (Scala) "_.unary'_~"
| constant "(AND) :: uint32 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word32.andb ((_),/ (_))" and
  (Haskell) infixl 7 "Data_Bits..&." and
  (OCaml) "Int32.logand" and
  (Scala) infixl 3 "&"
| constant "(OR) :: uint32 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word32.orb ((_),/ (_))" and
  (Haskell) infixl 5 "Data_Bits..|." and
  (OCaml) "Int32.logor" and
  (Scala) infixl 1 "|"
| constant "(XOR) :: uint32 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word32.xorb ((_),/ (_))" and
  (Haskell) "Data'_Bits.xor" and
  (OCaml) "Int32.logxor" and
  (Scala) infixl 2 "^"

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

definition uint32_div :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32"
where "uint32_div x y = fst (uint32_divmod x y)"

definition uint32_mod :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32"
where "uint32_mod x y = snd (uint32_divmod x y)"

lemma div_uint32_code [code]: "x div y = (if y = 0 then 0 else uint32_div x y)"
including undefined_transfer unfolding uint32_divmod_def uint32_div_def
by transfer (simp add: word_div_def)

lemma mod_uint32_code [code]: "x mod y = (if y = 0 then x else uint32_mod x y)"
including undefined_transfer unfolding uint32_mod_def uint32_divmod_def
by transfer (simp add: word_mod_def)

definition uint32_sdiv :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32"
where [code del]:
  "uint32_sdiv x y =
   (if y = 0 then undefined ((div) :: uint32 \<Rightarrow> _) x (0 :: uint32)
    else Abs_uint32 (Rep_uint32 x sdiv Rep_uint32 y))"

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

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

lemma uint32_divmod_code [code]:
  "uint32_divmod x y =
  (if 0x80000000 \<le> y then if x < y then (0, x) else (1, x - y)
   else if y = 0 then (div0_uint32 x, mod0_uint32 x)
   else let q = push_bit 1 (uint32_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 uint32_divmod_def uint32_sdiv_def div0_uint32_def mod0_uint32_def
  by transfer (simp add: divmod_via_sdivmod ac_simps)

lemma uint32_sdiv_code [code abstract]:
  "Rep_uint32 (uint32_sdiv x y) =
   (if y = 0 then Rep_uint32 (undefined ((div) :: uint32 \<Rightarrow> _) x (0 :: uint32))
    else Rep_uint32 x sdiv Rep_uint32 y)"
unfolding uint32_sdiv_def by(simp add: Abs_uint32_inverse)

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

code_printing
  constant uint32_div \<rightharpoonup>
  (SML) "Word32.div ((_), (_))" and
  (Haskell) "Prelude.div"
| constant uint32_mod \<rightharpoonup>
  (SML) "Word32.mod ((_), (_))" and
  (Haskell) "Prelude.mod"
| constant uint32_divmod \<rightharpoonup>
  (Haskell) "divmod"
| constant uint32_sdiv \<rightharpoonup>
  (OCaml) "Int32.div" and
  (Scala) "_ '/ _"

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

lemma test_bit_uint32_code [code]:
  "bit x n \<longleftrightarrow> n < 32 \<and> uint32_test_bit x (integer_of_nat n)"
  including undefined_transfer integer.lifting unfolding uint32_test_bit_def
  by (transfer, simp, transfer, simp)

lemma uint32_test_bit_code [code]:
  "uint32_test_bit w n =
  (if n < 0 \<or> 31 < n then undefined (bit :: uint32 \<Rightarrow> _) w n else bit (Rep_uint32 w) (nat_of_integer n))"
  unfolding uint32_test_bit_def by(simp add: bit_uint32.rep_eq)

code_printing constant uint32_test_bit \<rightharpoonup>
  (SML) "Uint32.test'_bit" and
  (Haskell) "Data'_Bits.testBitBounded" and
  (OCaml) "Uint32.test'_bit" and
  (Scala) "Uint32.test'_bit" and
  (Eval) "(fn w => fn n => if n < 0 orelse 32 <= n then raise (Fail \"argument to uint32'_test'_bit out of bounds\") else Uint32.test'_bit w n)"

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

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

lemma uint32_set_bit_code [code abstract]:
  "Rep_uint32 (uint32_set_bit w n b) =
  (if n < 0 \<or> 31 < n then Rep_uint32 (undefined (set_bit :: uint32 \<Rightarrow> _) w n b)
   else set_bit (Rep_uint32 w) (nat_of_integer n) b)"
including undefined_transfer unfolding uint32_set_bit_def by transfer simp

code_printing constant uint32_set_bit \<rightharpoonup>
  (SML) "Uint32.set'_bit" and
  (Haskell) "Data'_Bits.setBitBounded" and
  (OCaml) "Uint32.set'_bit" and
  (Scala) "Uint32.set'_bit" and
  (Eval) "(fn w => fn n => fn b => if n < 0 orelse 32 <= n then raise (Fail \"argument to uint32'_set'_bit out of bounds\") else Uint32.set'_bit x n b)"

lift_definition uint32_set_bits :: "(nat \<Rightarrow> bool) \<Rightarrow> uint32 \<Rightarrow> nat \<Rightarrow> uint32" is set_bits_aux .

lemma uint32_set_bits_code [code]:
  "uint32_set_bits f w n =
  (if n = 0 then w
   else let n' = n - 1 in uint32_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_uint32 [code]:
  "(BITS n. f n) = uint32_set_bits f 0 32"
by transfer(simp add: set_bits_conv_set_bits_aux)

lemma lsb_code [code]: fixes x :: uint32 shows "lsb x \<longleftrightarrow> bit x 0"
  by transfer (simp add: lsb_word_eq)

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

lemma shiftl_uint32_code [code]: "push_bit n x = (if n < 32 then uint32_shiftl x (integer_of_nat n) else 0)"
  including undefined_transfer integer.lifting unfolding uint32_shiftl_def
  by transfer simp

lemma uint32_shiftl_code [code abstract]:
  "Rep_uint32 (uint32_shiftl w n) =
  (if n < 0 \<or> 32 \<le> n then Rep_uint32 (undefined (push_bit :: nat \<Rightarrow> uint32 \<Rightarrow> _) w n) else push_bit (nat_of_integer n) (Rep_uint32 w))"
  including undefined_transfer unfolding uint32_shiftl_def
  by transfer simp

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

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

lemma shiftr_uint32_code [code]: "drop_bit n x = (if n < 32 then uint32_shiftr x (integer_of_nat n) else 0)"
  including undefined_transfer integer.lifting unfolding uint32_shiftr_def
  by transfer simp

lemma uint32_shiftr_code [code abstract]:
  "Rep_uint32 (uint32_shiftr w n) =
  (if n < 0 \<or> 32 \<le> n then Rep_uint32 (undefined (drop_bit :: nat \<Rightarrow> uint32 \<Rightarrow> _) w n) else drop_bit (nat_of_integer n) (Rep_uint32 w))"
  including undefined_transfer unfolding uint32_shiftr_def by transfer simp

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

definition uint32_sshiftr :: "uint32 \<Rightarrow> integer \<Rightarrow> uint32"
where [code del]:
  "uint32_sshiftr x n =
  (if n < 0 \<or> 32 \<le> n then undefined sshiftr_uint32 x n else sshiftr_uint32 x (nat_of_integer n))"

lemma sshiftr_uint32_code [code]:
  "x >>> n =
  (if n < 32 then uint32_sshiftr x (integer_of_nat n) else if bit x 31 then - 1 else 0)"
  including undefined_transfer integer.lifting unfolding uint32_sshiftr_def
  by transfer (simp add: not_less signed_drop_bit_beyond)

lemma uint32_sshiftr_code [code abstract]:
  "Rep_uint32 (uint32_sshiftr w n) =
  (if n < 0 \<or> 32 \<le> n then Rep_uint32 (undefined sshiftr_uint32 w n) else signed_drop_bit (nat_of_integer n) (Rep_uint32 w))"
including undefined_transfer unfolding uint32_sshiftr_def by transfer simp

code_printing constant uint32_sshiftr \<rightharpoonup>
  (SML) "Uint32.shiftr'_signed" and
  (Haskell)
    "(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint32.Int32) _)) :: Uint32.Word32)" and
  (OCaml) "Uint32.shiftr'_signed" and
  (Scala) "Uint32.shiftr'_signed" and
  (Eval) "(fn x => fn i => if i < 0 orelse i >= 32 then raise Fail \"argument to uint32'_shiftr'_signed out of bounds\" else Uint32.shiftr'_signed x i)"

lemma uint32_msb_test_bit: "msb x \<longleftrightarrow> bit (x :: uint32) 31"
  by transfer (simp add: msb_word_iff_bit)

lemma msb_uint32_code [code]: "msb x \<longleftrightarrow> uint32_test_bit x 31"
  by (simp add: uint32_test_bit_def uint32_msb_test_bit)

lemma uint32_of_int_code [code]: "uint32_of_int i = Uint32 (integer_of_int i)"
including integer.lifting by transfer simp

lemma int_of_uint32_code [code]:
  "int_of_uint32 x = int_of_integer (integer_of_uint32 x)"
by(simp add: integer_of_uint32_def)

lemma nat_of_uint32_code [code]:
  "nat_of_uint32 x = nat_of_integer (integer_of_uint32 x)"
unfolding integer_of_uint32_def including integer.lifting by transfer simp

definition integer_of_uint32_signed :: "uint32 \<Rightarrow> integer"
where
  "integer_of_uint32_signed n = (if bit n 31 then undefined integer_of_uint32 n else integer_of_uint32 n)"

lemma integer_of_uint32_signed_code [code]:
  "integer_of_uint32_signed n =
  (if bit n 31 then undefined integer_of_uint32 n else integer_of_int (uint (Rep_uint32' n)))"
unfolding integer_of_uint32_signed_def integer_of_uint32_def
including undefined_transfer by transfer simp

lemma integer_of_uint32_code [code]:
  "integer_of_uint32 n =
  (if bit n 31 then integer_of_uint32_signed (n AND 0x7FFFFFFF) OR 0x80000000 else integer_of_uint32_signed n)"
proof -
  have \<open>(0x7FFFFFFF :: uint32) = mask 31\<close>
    by (simp add: mask_eq_exp_minus_1)
  then have *: \<open>n AND 0x7FFFFFFF = take_bit 31 n\<close>
    by (simp add: take_bit_eq_mask)
  have **: \<open>(0x80000000 :: int) = 2 ^ 31\<close>
    by simp
  show ?thesis
    unfolding integer_of_uint32_def integer_of_uint32_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_uint32" \<rightharpoonup>
  (SML) "IntInf.fromLarge (Word32.toLargeInt _) : IntInf.int" and
  (Haskell) "Prelude.toInteger"
| constant "integer_of_uint32_signed" \<rightharpoonup>
  (OCaml) "Z.of'_int32" and
  (Scala) "BigInt"

section \<open>Quickcheck setup\<close>

definition uint32_of_natural :: "natural \<Rightarrow> uint32"
where "uint32_of_natural x \<equiv> Uint32 (integer_of_natural x)"

instantiation uint32 :: "{random, exhaustive, full_exhaustive}" begin
definition "random_uint32 \<equiv> qc_random_cnv uint32_of_natural"
definition "exhaustive_uint32 \<equiv> qc_exhaustive_cnv uint32_of_natural"
definition "full_exhaustive_uint32 \<equiv> qc_full_exhaustive_cnv uint32_of_natural"
instance ..
end

instantiation uint32 :: narrowing begin

interpretation quickcheck_narrowing_samples
  "\<lambda>i. let x = Uint32 i in (x, 0xFFFFFFFF - x)" "0"
  "Typerep.Typerep (STR ''Uint32.uint32'') []" .

definition "narrowing_uint32 d = qc_narrowing_drawn_from (narrowing_samples d) d"
declare [[code drop: "partial_term_of :: uint32 itself \<Rightarrow> _"]]
lemmas partial_term_of_uint32 [code] = partial_term_of_code

instance ..
end

no_notation sshiftr_uint32 (infixl ">>>" 55)

end


(*  Title:       Utilities for Knuth-Bendix Orders for Lambda-Free Higher-Order Terms
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2016
    Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
*)

section \<open>Utilities for Knuth--Bendix Orders for Lambda-Free Higher-Order Terms\<close>

theory Lambda_Free_KBO_Util
imports Lambda_Free_RPOs.Lambda_Free_Term Lambda_Free_RPOs.Extension_Orders Polynomials.Polynomials
begin

locale kbo_basic_basis = gt_sym "(>\<^sub>s)"
    for gt_sym :: "'s \<Rightarrow> 's \<Rightarrow> bool" (infix ">\<^sub>s" 50) +
  fixes
    wt_sym :: "'s \<Rightarrow> nat" and
    \<epsilon> :: nat and
    ground_heads_var :: "'v \<Rightarrow> 's set" and
    extf :: "'s \<Rightarrow> (('s, 'v) tm \<Rightarrow> ('s, 'v) tm \<Rightarrow> bool) \<Rightarrow> ('s, 'v) tm list \<Rightarrow> ('s, 'v) tm list \<Rightarrow>
      bool"
  assumes
    \<epsilon>_gt_0: "\<epsilon> > 0" and
    wt_sym_ge_\<epsilon>: "wt_sym f \<ge> \<epsilon>" and
    ground_heads_var_nonempty: "ground_heads_var x \<noteq> {}" and
    extf_ext_irrefl_before_trans: "ext_irrefl_before_trans (extf f)" and
    extf_ext_compat_list_strong: "ext_compat_list_strong (extf f)" and
    extf_ext_hd_or_tl: "ext_hd_or_tl (extf f)"
begin

lemma wt_sym_gt_0: "wt_sym f > 0"
  by (rule less_le_trans[OF \<epsilon>_gt_0 wt_sym_ge_\<epsilon>])

end

locale kbo_std_basis = ground_heads "(>\<^sub>s)" arity_sym arity_var
    for
      gt_sym :: "'s \<Rightarrow> 's \<Rightarrow> bool" (infix ">\<^sub>s" 50) and
      arity_sym :: "'s \<Rightarrow> enat" and
      arity_var :: "'v \<Rightarrow> enat" +
  fixes
    wt_sym :: "'s \<Rightarrow> 'n::{ord,semiring_1}" and
    \<epsilon> :: nat and
    \<delta> :: nat and
    extf :: "'s \<Rightarrow> (('s, 'v) tm \<Rightarrow> ('s, 'v) tm \<Rightarrow> bool) \<Rightarrow> ('s, 'v) tm list \<Rightarrow> ('s, 'v) tm list \<Rightarrow>
      bool"
  assumes
    \<epsilon>_gt_0: "\<epsilon> > 0" and
    \<delta>_le_\<epsilon>: "\<delta> \<le> \<epsilon>" and
    arity_hd_ne_infinity_if_\<delta>_gt_0: "\<delta> > 0 \<Longrightarrow> arity_hd \<zeta> \<noteq> \<infinity>" and
    wt_sym_ge: "wt_sym f \<ge> of_nat (\<epsilon> - the_enat (of_nat \<delta> * arity_sym f))" and
    unary_wt_sym_0_gt: "arity_sym f = 1 \<Longrightarrow> wt_sym f = 0 \<Longrightarrow> f >\<^sub>s g \<or> g = f" and
    unary_wt_sym_0_imp_\<delta>_eq_\<epsilon>: "arity_sym f = 1 \<Longrightarrow> wt_sym f = 0 \<Longrightarrow> \<delta> = \<epsilon>" and
    extf_ext_irrefl_before_trans: "ext_irrefl_before_trans (extf f)" and
    extf_ext_compat_list_strong: "ext_compat_list_strong (extf f)" and
    extf_ext_hd_or_tl: "ext_hd_or_tl (extf f)" and
    extf_ext_snoc_if_\<delta>_eq_\<epsilon>: "\<delta> = \<epsilon> \<Longrightarrow> ext_snoc (extf f)"
begin

lemma arity_sym_ne_infinity_if_\<delta>_gt_0: "\<delta> > 0 \<Longrightarrow> arity_sym f \<noteq> \<infinity>"
  by (metis arity_hd.simps(2) arity_hd_ne_infinity_if_\<delta>_gt_0)

lemma arity_var_ne_infinity_if_\<delta>_gt_0: "\<delta> > 0 \<Longrightarrow> arity_var x \<noteq> \<infinity>"
  by (metis arity_hd.simps(1) arity_hd_ne_infinity_if_\<delta>_gt_0)

lemma arity_ne_infinity_if_\<delta>_gt_0: "\<delta> > 0 \<Longrightarrow> arity s \<noteq> \<infinity>"
  unfolding arity_def
  by (induct s rule: tm_induct_apps)
    (metis arity_hd_ne_infinity_if_\<delta>_gt_0 enat.distinct(2) enat.exhaust idiff_enat_enat)

lemma extf_ext_irrefl: "ext_irrefl (extf f)"
  by (rule ext_irrefl_before_trans.axioms(1)[OF extf_ext_irrefl_before_trans])

lemma extf_ext: "ext (extf f)"
  by (rule ext_irrefl.axioms(1)[OF extf_ext_irrefl])

lemma
  extf_ext_compat_cons: "ext_compat_cons (extf f)" and
  extf_ext_compat_snoc: "ext_compat_snoc (extf f)" and
  extf_ext_singleton: "ext_singleton (extf f)"
  by (rule ext_compat_list_strong.axioms[OF extf_ext_compat_list_strong])+

lemma extf_ext_compat_list: "ext_compat_list (extf f)"
  using extf_ext_compat_list_strong
  by (simp add: ext_compat_list_axioms_def ext_compat_list_def ext_compat_list_strong.compat_list
    ext_compat_list_strong_def ext_singleton.axioms(1))

lemma extf_ext_wf_bounded: "ext_wf_bounded (extf f)"
  unfolding ext_wf_bounded_def using extf_ext_irrefl_before_trans extf_ext_hd_or_tl by simp

lemmas extf_mono_strong = ext.mono_strong[OF extf_ext]
lemmas extf_mono = ext.mono[OF extf_ext, mono]
lemmas extf_map = ext.map[OF extf_ext]
lemmas extf_irrefl = ext_irrefl.irrefl[OF extf_ext_irrefl]
lemmas extf_trans_from_irrefl =
  ext_irrefl_before_trans.trans_from_irrefl[OF extf_ext_irrefl_before_trans]
lemmas extf_compat_cons = ext_compat_cons.compat_cons[OF extf_ext_compat_cons]
lemmas extf_compat_append_left = ext_compat_cons.compat_append_left[OF extf_ext_compat_cons]
lemmas extf_compat_append_right = ext_compat_snoc.compat_append_right[OF extf_ext_compat_snoc]
lemmas extf_compat_list = ext_compat_list.compat_list[OF extf_ext_compat_list]
lemmas extf_singleton = ext_singleton.singleton[OF extf_ext_singleton]
lemmas extf_wf_bounded = ext_wf_bounded.wf_bounded[OF extf_ext_wf_bounded]

lemmas extf_snoc_if_\<delta>_eq_\<epsilon> = ext_snoc.snoc[OF extf_ext_snoc_if_\<delta>_eq_\<epsilon>]

lemma extf_singleton_nil_if_\<delta>_eq_\<epsilon>: "\<delta> = \<epsilon> \<Longrightarrow> extf f gt [s] []"
  by (rule extf_snoc_if_\<delta>_eq_\<epsilon>[of _ _ "[]", simplified])

end

sublocale kbo_basic_basis < kbo_std_basis _ _ "\<lambda>_. \<infinity>" "\<lambda>_. \<infinity>" _ _ 0
  unfolding kbo_std_basis_def kbo_std_basis_axioms_def
  by (auto simp: wt_sym_gt_0 \<epsilon>_gt_0 wt_sym_ge_\<epsilon> less_not_refl2 ground_heads_var_nonempty
    gt_sym_axioms ground_heads_def ground_heads_axioms_def extf_ext_irrefl_before_trans
    extf_ext_compat_list_strong extf_ext_hd_or_tl)

end