chapter \<open>Instantiation for \<open>HOL-ex.Unification\<close> from session \<open>HOL-ex\<close>\<close>

theory Unification_Compat
imports
  "HOL-ex.Unification"
  Term_Class
begin

text \<open>
  The Isabelle library provides a unification algorithm on lambda-free terms. To illustrate
  flexibility of the term algebra, I instantiate my class with that term type. The major issue is
  that those terms are parameterized over the constant and variable type, which cannot easily be
  supported by the classy approach, where those types are fixed to @{typ name}. As a workaround, I
  introduce a class that requires the constant and variable type to be isomorphic to @{typ name}.
\<close>

hide_const (open) Unification.subst

class is_name =
  fixes of_name :: "name \<Rightarrow> 'a"
  assumes bij: "bij of_name"
begin

definition to_name :: "'a \<Rightarrow> name" where
"to_name = inv of_name"

lemma to_of_name[simp]: "to_name (of_name a) = a"
unfolding to_name_def using bij by (metis bij_inv_eq_iff)

lemma of_to_name[simp]: "of_name (to_name a) = a"
unfolding to_name_def using bij by (meson bij_inv_eq_iff)

lemma of_name_inj: "of_name name\<^sub>1 = of_name name\<^sub>2 \<Longrightarrow> name\<^sub>1 = name\<^sub>2"
using bij by (metis to_of_name)

end

instantiation name :: is_name begin

definition of_name_name :: "name \<Rightarrow> name" where
[code_unfold]: "of_name_name x = x"

instance by standard (auto simp: of_name_name_def bij_betw_def inj_on_def)

end

lemma [simp, code_unfold]: "(to_name :: name \<Rightarrow> name) = id"
unfolding to_name_def of_name_name_def by auto

instantiation trm :: (is_name) "pre_term" begin

definition app_trm where
"app_trm = Comb"

definition unapp_trm where
"unapp_trm t = (case t of Comb t u \<Rightarrow> Some (t, u) | _ \<Rightarrow> None)"

definition const_trm where
"const_trm n = trm.Const (of_name n)"

definition unconst_trm where
"unconst_trm t = (case t of trm.Const a \<Rightarrow> Some (to_name a) | _ \<Rightarrow> None)"

definition free_trm where
"free_trm n = Var (of_name n)"

definition unfree_trm where
"unfree_trm t = (case t of Var a \<Rightarrow> Some (to_name a) | _ \<Rightarrow> None)"

primrec consts_trm :: "'a trm \<Rightarrow> name fset" where
"consts_trm (Var _) = {||}" |
"consts_trm (trm.Const c) = {| to_name c |}" |
"consts_trm (M \<cdot> N) = consts_trm M |\<union>| consts_trm N"

context
  includes fset.lifting
begin

lift_definition frees_trm :: "'a trm \<Rightarrow> name fset" is "\<lambda>t. to_name ` vars_of t"
  by auto

end

lemma frees_trm[code, simp]:
  "frees (Var v) = {| to_name v |}"
  "frees (trm.Const c) = {||}"
  "frees (M \<cdot> N) = frees M |\<union>| frees N"
including fset.lifting
by (transfer; auto)+

primrec subst_trm :: "'a trm \<Rightarrow> (name, 'a trm) fmap \<Rightarrow> 'a trm" where
"subst_trm (Var v) env = (case fmlookup env (to_name v) of Some v' \<Rightarrow> v' | _ \<Rightarrow> Var v)" |
"subst_trm (trm.Const c) _ = trm.Const c" |
"subst_trm (M \<cdot> N) env = subst_trm M env \<cdot> subst_trm N env"

instance
by standard
   (auto
      simp: app_trm_def unapp_trm_def const_trm_def unconst_trm_def free_trm_def unfree_trm_def of_name_inj
      split: trm.splits option.splits)

end

instantiation trm :: (is_name) "term" begin

definition abs_pred_trm :: "('a trm \<Rightarrow> bool) \<Rightarrow> 'a trm \<Rightarrow> bool" where
"abs_pred_trm P t \<longleftrightarrow> True"

instance proof (standard, goal_cases)
  case (1 P t)
  then show ?case
    proof (induction t)
      case Var
      then show ?case
        unfolding free_trm_def
        by (metis of_to_name)
    next
      case Const
      then show ?case
        unfolding const_trm_def
        by (metis of_to_name)
    qed (auto simp: app_trm_def)
qed (auto simp: abs_pred_trm_def)

end

lemma assoc_alt_def[simp]:
  "assoc x y t = (case map_of t x of Some y' \<Rightarrow> y' | _ \<Rightarrow> y)"
by (induction t) auto

lemma subst_eq: "Unification.subst t s = subst t (fmap_of_list s)"
by (induction t) (auto split: option.splits simp: fmlookup_of_list)

end


(*  Title:      HOL/NanoJava/Example.thy
    Author:     David von Oheimb
    Copyright   2001 Technische Universitaet Muenchen
*)

section "Example"

theory Example
imports Equivalence
begin

text {*

\begin{verbatim}
class Nat {

  Nat pred;

  Nat suc()
    { Nat n = new Nat(); n.pred = this; return n; }

  Nat eq(Nat n)
    { if (this.pred != null) if (n.pred != null) return this.pred.eq(n.pred);
                             else return n.pred; // false
      else if (n.pred != null) return this.pred; // false
           else return this.suc(); // true
    }

  Nat add(Nat n)
    { if (this.pred != null) return this.pred.add(n.suc()); else return n; }

  public static void main(String[] args) // test x+1=1+x
    {
        Nat one = new Nat().suc();
        Nat x   = new Nat().suc().suc().suc().suc();
        Nat ok = x.suc().eq(x.add(one));
        System.out.println(ok != null);
    }
}
\end{verbatim}

*}

axiomatization where
  This_neq_Par [simp]: "This \<noteq> Par" and
  Res_neq_This [simp]: "Res  \<noteq> This"

subsection "Program representation"

axiomatization
  N    :: cname ("Nat") (* with mixfix because of clash with NatDef.Nat *)
  and pred :: fname
  and suc add :: mname
  and any  :: vname

abbreviation
  dummy :: expr ("<>")
  where "<> == LAcc any"

abbreviation
  one :: expr
  where "one == {Nat}new Nat..suc(<>)"

text {* The following properties could be derived from a more complete
        program model, which we leave out for laziness. *}

axiomatization where Nat_no_subclasses [simp]: "D \<preceq>C Nat = (D=Nat)"

axiomatization where method_Nat_add [simp]: "method Nat add = Some
  \<lparr> par=Class Nat, res=Class Nat, lcl=[],
   bdy= If((LAcc This..pred))
          (Res :== {Nat}(LAcc This..pred)..add({Nat}LAcc Par..suc(<>)))
        Else Res :== LAcc Par \<rparr>"

axiomatization where method_Nat_suc [simp]: "method Nat suc = Some
  \<lparr> par=NT, res=Class Nat, lcl=[],
   bdy= Res :== new Nat;; LAcc Res..pred :== LAcc This \<rparr>"

axiomatization where field_Nat [simp]: "field Nat = empty(pred\<mapsto>Class Nat)"

lemma init_locs_Nat_add [simp]: "init_locs Nat add s = s"
by (simp add: init_locs_def init_vars_def)

lemma init_locs_Nat_suc [simp]: "init_locs Nat suc s = s"
by (simp add: init_locs_def init_vars_def)

lemma upd_obj_new_obj_Nat [simp]:
  "upd_obj a pred v (new_obj a Nat s) = hupd(a\<mapsto>(Nat, empty(pred\<mapsto>v))) s"
by (simp add: new_obj_def init_vars_def upd_obj_def Let_def)

subsection "``atleast'' relation for interpretation of Nat ``values''"

primrec Nat_atleast :: "state \<Rightarrow> val \<Rightarrow> nat \<Rightarrow> bool" ("_:_ \<ge> _" [51, 51, 51] 50) where
  "s:x\<ge>0     = (x\<noteq>Null)"
| "s:x\<ge>Suc n = (\<exists>a. x=Addr a \<and> heap s a \<noteq> None \<and> s:get_field s a pred\<ge>n)"

lemma Nat_atleast_lupd [rule_format, simp]:
 "\<forall>s v::val. lupd(x\<mapsto>y) s:v \<ge> n = (s:v \<ge> n)"
apply (induct n)
by  auto

lemma Nat_atleast_set_locs [rule_format, simp]:
 "\<forall>s v::val. set_locs l s:v \<ge> n = (s:v \<ge> n)"
apply (induct n)
by auto

lemma Nat_atleast_del_locs [rule_format, simp]:
 "\<forall>s v::val. del_locs s:v \<ge> n = (s:v \<ge> n)"
apply (induct n)
by auto

lemma Nat_atleast_NullD [rule_format]: "s:Null \<ge> n \<longrightarrow> False"
apply (induct n)
by auto

lemma Nat_atleast_pred_NullD [rule_format]:
"Null = get_field s a pred \<Longrightarrow> s:Addr a \<ge> n \<longrightarrow> n = 0"
apply (induct n)
by (auto dest: Nat_atleast_NullD)

lemma Nat_atleast_mono [rule_format]:
"\<forall>a. s:get_field s a pred \<ge> n \<longrightarrow> heap s a \<noteq> None \<longrightarrow> s:Addr a \<ge> n"
apply (induct n)
by auto

lemma Nat_atleast_newC [rule_format]:
  "heap s aa = None \<Longrightarrow> \<forall>v::val. s:v \<ge> n \<longrightarrow> hupd(aa\<mapsto>obj) s:v \<ge> n"
apply (induct n)
apply  auto
apply  (case_tac "aa=a")
apply   auto
apply (tactic "smp_tac @{context} 1 1")
apply (case_tac "aa=a")
apply  auto
done

subsection "Proof(s) using the Hoare logic"

theorem add_homomorph_lb:
  "{} \<turnstile> {\<lambda>s. s:s<This> \<ge> X \<and> s:s<Par> \<ge> Y} Meth(Nat,add) {\<lambda>s. s:s<Res> \<ge> X+Y}"
apply (rule hoare_ehoare.Meth) (* 1 *)
apply clarsimp
apply (rule_tac P'= "\<lambda>Z s. (s:s<This> \<ge> fst Z \<and> s:s<Par> \<ge> snd Z) \<and> D=Nat" and
        Q'= "\<lambda>Z s. s:s<Res> \<ge> fst Z+snd Z" in AxSem.Conseq)
prefer 2
apply  (clarsimp simp add: init_locs_def init_vars_def)
apply rule
apply (case_tac "D = Nat", simp_all, rule_tac [2] cFalse)
apply (rule_tac P = "\<lambda>Z Cm s. s:s<This> \<ge> fst Z \<and> s:s<Par> \<ge> snd Z" in AxSem.Impl1)
apply (clarsimp simp add: body_def)  (* 4 *)
apply (rename_tac n m)
apply (rule_tac Q = "\<lambda>v s. (s:s<This> \<ge> n \<and> s:s<Par> \<ge> m) \<and>
        (\<exists>a. s<This> = Addr a \<and> v = get_field s a pred)" in hoare_ehoare.Cond)
apply  (rule hoare_ehoare.FAcc)
apply  (rule eConseq1)
apply   (rule hoare_ehoare.LAcc)
apply  fast
apply auto
prefer 2
apply  (rule hoare_ehoare.LAss)
apply  (rule eConseq1)
apply   (rule hoare_ehoare.LAcc)
apply  (auto dest: Nat_atleast_pred_NullD)
apply (rule hoare_ehoare.LAss)
apply (rule_tac
    Q = "\<lambda>v   s. (\<forall>m. n = Suc m \<longrightarrow> s:v \<ge> m) \<and> s:s<Par> \<ge> m" and
    R = "\<lambda>T P s. (\<forall>m. n = Suc m \<longrightarrow> s:T \<ge> m) \<and> s:P  \<ge> Suc m"
    in hoare_ehoare.Call) (* 13 *)
apply   (rule hoare_ehoare.FAcc)
apply   (rule eConseq1)
apply    (rule hoare_ehoare.LAcc)
apply   clarify
apply   (drule sym, rotate_tac -1, frule (1) trans)
apply   simp
prefer 2
apply  clarsimp
apply  (rule hoare_ehoare.Meth) (* 17 *)
apply  clarsimp
apply  (case_tac "D = Nat", simp_all, rule_tac [2] cFalse)
apply  (rule AxSem.Conseq)
apply   rule
apply   (rule hoare_ehoare.Asm) (* 20 *)
apply   (rule_tac a = "((case n of 0 \<Rightarrow> 0 | Suc m \<Rightarrow> m),m+1)" in UN_I, rule+)
apply  (clarsimp split add: nat.split_asm dest!: Nat_atleast_mono)
apply rule
apply (rule hoare_ehoare.Call) (* 21 *)
apply   (rule hoare_ehoare.LAcc)
apply  rule
apply  (rule hoare_ehoare.LAcc)
apply clarify
apply (rule hoare_ehoare.Meth) (* 24 *)
apply clarsimp
apply  (case_tac "D = Nat", simp_all, rule_tac [2] cFalse)
apply (rule AxSem.Impl1)
apply (clarsimp simp add: body_def)
apply (rule hoare_ehoare.Comp) (* 26 *)
prefer 2
apply  (rule hoare_ehoare.FAss)
prefer 2
apply   rule
apply   (rule hoare_ehoare.LAcc)
apply  (rule hoare_ehoare.LAcc)
apply (rule hoare_ehoare.LAss)
apply (rule eConseq1)
apply  (rule hoare_ehoare.NewC) (* 32 *)
apply (auto dest!: new_AddrD elim: Nat_atleast_newC)
done

end


(* Version: Isabelle2019 *)

theory OpenTheory
  imports Main
  keywords "art_file" :: thy_decl
begin

subsection \<open>OpenTheory package\<close>

text \<open>Lemmas used by the package\<close>

lemma type_definition_Collect_iff:
  assumes "type_definition Rep Abs (Collect P)"
  shows "P r \<longleftrightarrow> (Rep (Abs r) = r)"
proof
  assume "P r"
  hence "r \<in> Collect P" by simp
  thus "Rep (Abs r) = r"
    by (rule type_definition.Abs_inverse [OF assms])
next
  have "Rep (Abs r) \<in> Collect P"
    by (rule type_definition.Rep [OF assms])
  also assume "Rep (Abs r) = r"
  finally show "P r" by simp
qed

text \<open>Load opentheory package\<close>

ML_file "opentheory.ML"

setup OpenTheory.setup

subsection \<open>Load boolean theories\<close>

setup \<open>
  fold OpenTheory.add_tyop
  [("->", @{type_name "fun"}),
   ("bool", @{type_name "bool"})]
\<close>

setup \<open>
  fold OpenTheory.add_const
  [("=", @{const_name "HOL.eq"}),
   ("Data.Bool.!", @{const_name "All"}),
   ("Data.Bool.==>", @{const_name "HOL.implies"}),
   ("Data.Bool.\\\\/", @{const_name "HOL.disj"}),
   ("Data.Bool./\\\\", @{const_name "HOL.conj"}),
   ("Data.Bool.?", @{const_name "Ex"}),
   ("Data.Bool.T", @{const_name "True"}),
   ("Data.Bool.F", @{const_name "False"}),
   ("Data.Bool.~", @{const_name "Not"}),
   ("Data.Bool.?!", @{const_name "Ex1"})]
\<close>

lemma [opentheory]: "True = ((\<lambda>p::bool. p) = (\<lambda>p. p))"
  by auto

lemma [opentheory]: "All = (\<lambda>P. P = (\<lambda>x::'A. True))"
  unfolding fun_eq_iff by auto

lemma [opentheory]: "(\<longrightarrow>) = (\<lambda>p q. (p \<and> q) = p)"
  unfolding fun_eq_iff by auto

lemma [opentheory]: "(\<and>) = (\<lambda>p q. (\<lambda>f. f p q :: bool) = (\<lambda>f. f True True))"
apply (simp add: fun_eq_iff, safe, simp_all)
apply (drule_tac x="\<lambda>x y. x" in spec, simp)
apply (drule_tac x="\<lambda>x y. y" in spec, simp)
done

lemma [opentheory]: "(\<or>) = (\<lambda>p q. \<forall>r. (p \<longrightarrow> r) \<longrightarrow> (q \<longrightarrow> r) \<longrightarrow> r)"
  unfolding fun_eq_iff by auto

lemma [opentheory]: "Ex = (\<lambda>P. \<forall>q. (\<forall>x::'A. P x \<longrightarrow> q) \<longrightarrow> q)"
  unfolding fun_eq_iff by auto

lemma [opentheory]: "False = (\<forall>p. p)"
  by auto

lemma [opentheory]: "Not = (\<lambda>p. p \<longrightarrow> False)"
  by auto

lemma [opentheory]:
  "Ex1 = (\<lambda>P. Ex P \<and> (\<forall>x y::'A. P x \<and> P y \<longrightarrow> x = y))"
  unfolding fun_eq_iff by auto

art_file "bool-int-1.0.art"

setup \<open>
  fold OpenTheory.add_const
  [("Data.Bool.select", @{const_name "Eps"}),
   ("Data.Bool.cond", @{const_name "If"})]
\<close>

lemma [opentheory]:
  "\<forall>(t::'A \<Rightarrow> 'B). (\<lambda>(x::'A). t x) = t"
by auto

lemma [opentheory]: "\<forall>(P :: 'A \<Rightarrow> bool) (x :: 'A). P x \<longrightarrow> P (Eps P)"
by (auto intro: someI)

lemma [opentheory]:
  "\<forall>(f :: 'A \<Rightarrow> 'B)(g :: 'A \<Rightarrow> 'B). (\<forall>x :: 'A. f x = g x) \<longrightarrow> f = g"
  unfolding fun_eq_iff by auto

lemma [opentheory]:
  "If = (\<lambda>t t1 t2. SOME(x::'A). (t = True \<longrightarrow> x = t1) \<and> (t = False \<longrightarrow> x = t2))"
  unfolding fun_eq_iff by auto

lemma [opentheory]:
  "\<forall>(f::'A \<Rightarrow> 'B) g. (f = g) = (\<forall>x. f x = g x)"
  unfolding fun_eq_iff by auto

art_file "bool-choice-1.0.art"

subsection \<open>Load natural number theories\<close>

setup \<open>
  OpenTheory.add_tyop ("Number.Natural.natural", @{type_name "nat"})
\<close>

setup \<open>
  fold OpenTheory.add_const
  [("Number.Numeral.zero", @{const_name "Groups.zero"}),
   ("Number.Natural.suc", @{const_name "Suc"}),
   ("Number.Natural.+", @{const_name "plus"}),
   ("Number.Natural.*", @{const_name "times"}),
   ("Number.Natural.-", @{const_name "minus"}),
   ("Number.Natural.exp", @{const_name "power"}),
   ("Number.Natural.<=", @{const_name "less_eq"}),
   ("Number.Natural.<", @{const_name "less"})]
\<close>

ML \<open>Binding.qualified_name @{const_name power}\<close>

text \<open>Properties of constructors, induction and recursion:\<close>

lemma [opentheory]:
  "\<forall>n. Suc n \<noteq> 0"
  "\<forall>(m::nat) n::nat. (Suc m = Suc n) = (m = n)"
by simp_all

lemma [opentheory]:
  "\<forall>P::nat \<Rightarrow> bool. P (0::nat) \<and> (\<forall>n::nat. P n \<longrightarrow> P (Suc n)) \<longrightarrow> (\<forall>n::nat. P n)"
by (clarify, erule nat_induct, simp)

lemma [opentheory]: "\<forall>(e::'A) f::'A \<Rightarrow> nat \<Rightarrow> 'A.
   \<exists>(fn::nat \<Rightarrow> 'A). fn (0::nat) = e \<and> (\<forall>n::nat. fn (Suc n) = f (fn n) n)"
by (intro allI, rule_tac x="rec_nat e (\<lambda>n a. f a n)" in exI, simp)

text \<open>Binary numerals for natural numbers:\<close>

art_file "natural-numeral-1.0.art"

lemma bit_simps[simp]:
  "bit0 0 = 0 \<and> (\<forall>n. bit0 (Suc n) = Suc (Suc (bit0 n)))"
  "\<forall>n. bit1 n = Suc (bit0 n)"
by (rule opentheory)+

text \<open>Primitive recursion equations for constants:\<close>

lemma [opentheory]:
  "(\<forall>n. (0::nat) + n = n) \<and> (\<forall>m n. Suc m + n = Suc (m + n))"
  "(\<forall>n. (0::nat) * n = 0) \<and> (\<forall>m n. Suc m * n = m * n + n)"
  "(\<forall>m::nat. m ^ 0 = bit1 0) \<and> (\<forall>(m::nat) n. m ^ Suc n = m * m ^ n)"
(*
  "even (0::nat) = True \<and> (\<forall>n. even (Suc n) = (\<not> even n))"
  "odd (0::nat) = False \<and> (\<forall>n. odd (Suc n) = (\<not> odd n))"
*)
by (simp_all add: bit_simps)

lemma [opentheory]:
  "(\<forall>m. (m < (0::nat)) = False) \<and> (\<forall>m n. (m < Suc n) = (m = n \<or> m < n))"
by (simp add: less_Suc_eq disj_commute)

lemma [opentheory]:
  "(\<forall>m. (m \<le> (0::nat)) = (m = (0::nat))) \<and>
  (\<forall>m n. (m \<le> Suc n) = (m = Suc n \<or> m \<le> n))"
by (simp add: le_Suc_eq disj_commute)

art_file "natural-add-thm-1.0.art"
art_file "natural-add-numeral-1.0.art"
art_file "natural-mult-thm-1.0.art"
art_file "natural-exp-thm-1.0.art"
art_file "natural-order-thm-1.0.art"
art_file "natural-add-order-1.0.art"
art_file "natural-mult-order-1.0.art"
art_file "natural-set-1.0.art"
art_file "natural-even-odd-def-1.0.art"
art_file "natural-even-odd-thm-1.0.art"
art_file "natural-recursion-1.0.art"
art_file "natural-cases-1.0.art"

subsection \<open>Configure other datatypes\<close>

setup \<open>
  fold OpenTheory.add_tyop
  [("Data.Pair.*", @{type_name "prod"}),
   ("Data.Option.option", @{type_name "option"}),
   ("Data.List.list", @{type_name "list"})]
\<close>

setup \<open>
  fold OpenTheory.add_const
  [("Data.Pair.,", @{const_name "Pair"}),
   ("Data.Pair.fst", @{const_name "fst"}),
   ("Data.Pair.snd", @{const_name "snd"}),
   ("Data.Option.none", @{const_name "None"}),
   ("Data.Option.some", @{const_name "Some"}),
   ("Data.Option.case", @{const_name "case_option"}),
   ("Data.List.[]", @{const_name "Nil"}),
   ("Data.List.::", @{const_name "Cons"}),
   ("Data.List.@", @{const_name "append"}),
   ("Data.List.length", @{const_name "size"}),
   ("Data.List.concat", @{const_name "concat"}),
   ("Data.List.map", @{const_name "map"})]
\<close>

text \<open>Constructors, induction, and recursion for pairs:\<close>

lemma [opentheory]:
  "\<forall>(x::'A) (y::'B). fst (x, y) = x"
  "\<forall>(x::'A) (y::'B). snd (x, y) = y"
  "\<forall>p. \<exists>(x::'A) (y::'B). p = (x, y)"
  "\<forall>(x::'A) (y::'B) (a::'A) b::'B. ((x, y) = (a, b)) = (x = a \<and> y = b)"
by simp_all

art_file "pair-induct-1.0.art"
art_file "pair-abs-1.0.art"

text \<open>Constructors, induction, and recursion for options:\<close>

lemma [opentheory]:
  "\<forall>P::'A option \<Rightarrow> bool. P None \<and> (\<forall>a::'A. P (Some a)) \<longrightarrow> (\<forall>x::'A option. P x)"
by (clarify, induct_tac x, simp_all)

lemma [opentheory]:
  "\<forall>(NONE'::'Z) SOME'::'A \<Rightarrow> 'Z.
    \<exists>fn::'A option \<Rightarrow> 'Z. fn None = NONE' \<and> (\<forall>a::'A. fn (Some a) = SOME' a)"
by (clarify, rule_tac x="\<lambda>x. case x of None \<Rightarrow> NONE' | Some y \<Rightarrow> SOME' y" in exI, simp)

art_file "option-thm-1.0.art"

lemma [opentheory]:
  "(\<forall>(b::'B) f::'A \<Rightarrow> 'B. case_option b f None = b) \<and>
(\<forall>(b::'B) (f::'A \<Rightarrow> 'B) a::'A. case_option b f (Some a) = f a)"
by simp

lemma [opentheory]:
  "\<forall>x::'A option. case_option None Some x = x"
by (clarify, case_tac x, simp_all)

text \<open>Constructors, induction, and recursion for lists:\<close>

lemma [opentheory]: "\<forall>P::'A list \<Rightarrow> bool.
   P [] \<and> (\<forall>(a0::'A) a1::'A list. P a1 \<longrightarrow> P (a0 # a1)) \<longrightarrow> (\<forall>x::'A list. P x)"
by (clarify, erule list.induct, simp)

lemma [opentheory]:
  "\<forall>(NIL'::'Z) CONS'::'A \<Rightarrow> 'A list \<Rightarrow> 'Z \<Rightarrow> 'Z.
   \<exists>fn::'A list \<Rightarrow> 'Z.
      fn [] = NIL' \<and>
      (\<forall>(a0::'A) a1::'A list. fn (a0 # a1) = CONS' a0 a1 (fn a1))"
by (intro allI, rule_tac x="rec_list NIL' CONS'" in exI, simp)

text \<open>Primitive recursion equations for constants:\<close>

lemma [opentheory]:
  "(\<forall>l::'A list. [] @ l = l) \<and>
    (\<forall>(h::'A) (t::'A list) l::'A list. (h # t) @ l = h # t @ l)"
  "size ([]::'A list) = (0::nat) \<and>
    (\<forall>(h::'A) t::'A list. size (h # t) = Suc (size t))"
  "concat [] = ([]::'A list) \<and>
    (\<forall>(h::'A list) t::'A list list. concat (h # t) = h @ concat t)"
  by simp_all

lemma [opentheory]:
  "(\<forall>f::'A \<Rightarrow> 'B. map f [] = []) \<and>
    (\<forall>(f::'A \<Rightarrow> 'B) (h::'A) t::'A list. map f (h # t) = f h # map f t)"
  by simp

art_file "list-thm-1.0.art"

subsection \<open>Well-founded relations\<close>

setup \<open>OpenTheory.add_const ("Function.id", @{const_name "id"})\<close>

lemma [opentheory]: "\<forall>x::'A. id x = x"
  by simp

art_file "relation-1.0.art"

end


theory Assertion_Semantics
imports Assertion_Lang Assertion_Misc
begin

section \<open>Semantics\<close>
text \<open>Defines the syntax for the assertion language formulae.\<close>

subsection \<open>Satisfaction predicate\<close>
text \<open>Satisfactions describe the semantics of the assertion language.\<close>

fun eval :: "expr \<Rightarrow> stack \<Rightarrow> val" where
  "eval (nil) s = Nilval" |
  "eval (\<acute>x`) s = s x"
notation eval ("\<lbrakk>_\<rbrakk>_" [60, 61] 61)

text \<open>A satisfaction with a ls segment holds iff there exists a path of heap cells that
  point to each other and that form a super list of the given segment.\<close>
inductive ls_ind :: "state \<Rightarrow> nat \<Rightarrow> (expr \<times> expr) \<Rightarrow> bool" ("_\<Turnstile>ls\<^sup>__" 50) where
EmptyLs: "\<lbrakk>e1\<rbrakk>s = \<lbrakk>e2\<rbrakk>s \<Longrightarrow> dom h = {} \<Longrightarrow> (s,h)\<Turnstile>ls\<^sup>0(e1,e2)" |
ListSegment: "\<lbrakk>e1\<rbrakk>s = Val v' \<Longrightarrow> h1 = [v'\<mapsto>v] \<Longrightarrow> xs \<subseteq> -(fv e1 \<union> fv e2)
  \<Longrightarrow> (\<forall>x \<in> xs. ((s(x:=v),h2)\<Turnstile>ls\<^sup>m(\<acute>x`,e2))) \<Longrightarrow> h1 \<bottom> h2 \<Longrightarrow> h = h1++h2 \<Longrightarrow> n = Suc m
  \<Longrightarrow> \<lbrakk>e1\<rbrakk>s \<noteq> \<lbrakk>e2\<rbrakk>s \<Longrightarrow> (s,h)\<Turnstile>ls\<^sup>n(e1,e2)"
(* ListSegment: "\<lbrakk>e1\<rbrakk>s = Val v' \<Longrightarrow> h1 = [v'\<mapsto>v] \<Longrightarrow> x \<notin> fv e1 \<union> fv e2 \<Longrightarrow> (s(x:=v),h2)\<Turnstile>ls\<^sup>m(\<acute>x`,e2)
  \<Longrightarrow> h1 \<bottom> h2 \<Longrightarrow> h = h1++h2 \<Longrightarrow> n = Suc m \<Longrightarrow> \<lbrakk>e1\<rbrakk>s \<noteq> \<lbrakk>e2\<rbrakk>s \<Longrightarrow> (s,h)\<Turnstile>ls\<^sup>n(e1,e2)" *)

inductive satisfaction :: "state \<Rightarrow> formula \<Rightarrow> bool" (infix "\<Turnstile>" 50) where
EqSat: "\<lbrakk>e1\<rbrakk>s=\<lbrakk>e2\<rbrakk>s \<Longrightarrow> (s,h)\<Turnstile>Pure(e1=\<^sub>pe2)" |
NeqSat: "\<lbrakk>e1\<rbrakk>s\<noteq>\<lbrakk>e2\<rbrakk>s \<Longrightarrow> (s,h)\<Turnstile>Pure(e1\<noteq>\<^sub>pe2)" |
TrueSat: "(s,h)\<Turnstile>PureF []" |
ConjSat: "(s,h)\<Turnstile>Pure P \<Longrightarrow> (s,h)\<Turnstile>PureF \<Pi> \<Longrightarrow> (s,h)\<Turnstile>PureF(P \<and>\<^sub>p \<Pi>)" |
PointsToSat: "\<lbrakk>\<lbrakk>e1\<rbrakk>s = Val v; h = [v\<mapsto>\<lbrakk>e2\<rbrakk>s]\<rbrakk> \<Longrightarrow> (s,h)\<Turnstile>Spat(e1 \<longmapsto> e2)" |
EmpSat: "h = Map.empty \<Longrightarrow> (s,h)\<Turnstile>SpatF emp" |
SepConjSat: "h1 \<bottom> h2 \<Longrightarrow> h = h1++h2 \<Longrightarrow> (s,h1)\<Turnstile>Spat S \<Longrightarrow> (s,h2)\<Turnstile>SpatF \<Sigma>
   \<Longrightarrow> (s,h)\<Turnstile>SpatF(S * \<Sigma>)" |
FormSat: "(s,h)\<Turnstile>PureF \<Pi> \<Longrightarrow> (s,h)\<Turnstile>SpatF \<Sigma> \<Longrightarrow> (s,h)\<Turnstile>(\<Pi> \<bar> \<Sigma>)" |
LsSat: "(s,h)\<Turnstile>ls\<^sup>n(e1,e2) \<Longrightarrow> (s,h)\<Turnstile>Spat(ls(e1,e2))"

declare ls_ind.intros[intro]
declare satisfaction.intros[intro]
lemmas ls_induct = ls_ind.induct[split_format(complete)]
lemmas sat_induct = satisfaction.induct[split_format(complete)]

inductive_cases [elim]: "(s,h)\<Turnstile>ls\<^sup>0(e1,e2)" "(s,h)\<Turnstile>ls\<^sup>n(e1,e2)"
inductive_cases [elim]: "(s,h)\<Turnstile>Pure(e1=\<^sub>pe2)" "(s,h)\<Turnstile>Pure(e1\<noteq>\<^sub>pe2)" "(s,h)\<Turnstile>PureF []"
  "(s,f)\<Turnstile>PureF(P \<and>\<^sub>p \<Pi>)" "(s,h)\<Turnstile>Spat(e1 \<longmapsto> e2)" "(s,h)\<Turnstile>SpatF emp" "(s,h)\<Turnstile>SpatF(S * \<Sigma>)"
  "(s,h)\<Turnstile>(\<Pi> \<bar> \<Sigma>)" "(s,h)\<Turnstile>Spat(ls(e1,e2))"

subsection \<open>Satisfaction properties\<close>
text \<open>There are a number of helpful properties that follow from the satisfaction definition.\<close>

text \<open>Satisfaction is decidable, cf. Lemma 1 \cite{JoshBerdine.2004}.\<close>
corollary sat_decidable: "(s,h)\<Turnstile>F \<or> \<not> (s,h)\<Turnstile>F"
by simp

text \<open>Separating conjunctions are only allowed on distinct heap parts.\<close>
corollary sep_conj_ortho: "\<nexists>s h. (s,h) \<Turnstile> [\<acute>x`=\<^sub>p\<acute>y`] \<bar> [\<acute>x` \<longmapsto> xv, \<acute>y` \<longmapsto> yv]"
proof
  assume "\<exists>s h. (s, h) \<Turnstile> [\<acute>x` =\<^sub>p \<acute>y`] \<bar> [\<acute>x` \<longmapsto> xv, \<acute>y` \<longmapsto> yv]"
  then obtain s h where "(s,h) \<Turnstile> [\<acute>x`=\<^sub>p\<acute>y`] \<bar> [\<acute>x` \<longmapsto> xv, \<acute>y` \<longmapsto> yv]" by auto
  hence "(s,h)\<Turnstile>PureF [\<acute>x`=\<^sub>p\<acute>y`]" and spatf: "(s,h) \<Turnstile> SpatF [\<acute>x` \<longmapsto> xv, \<acute>y` \<longmapsto> yv]" by auto
  {
    hence "(s,h)\<Turnstile>Pure(\<acute>x`=\<^sub>p\<acute>y`)" by auto
    hence "\<lbrakk>\<acute>x`\<rbrakk>s = \<lbrakk>\<acute>y`\<rbrakk>s" by auto
  }
  from spatf obtain h1 h2 where "h1 \<bottom> h2" "h = h1++h2" "(s,h1)\<Turnstile>Spat (\<acute>x`\<longmapsto>xv)"
    "(s,h2)\<Turnstile>SpatF [\<acute>y`\<longmapsto>yv]" by blast
  from \<open>(s,h1)\<Turnstile>Spat (\<acute>x`\<longmapsto>xv)\<close> obtain v where "\<lbrakk>\<acute>x`\<rbrakk>s = Val v" "dom h1 = {v}" by auto
  from \<open>(s,h2)\<Turnstile>SpatF [\<acute>y`\<longmapsto>yv]\<close> obtain h3 h4 where "h3 \<bottom> h4" "h2 = h3++h4"
    "(s,h3)\<Turnstile>Spat(\<acute>y`\<longmapsto>yv)" by auto
  then obtain v' where "\<lbrakk>\<acute>y`\<rbrakk>s = Val v'" "dom h3 = {v'}" by auto
  with \<open>\<lbrakk>\<acute>x`\<rbrakk>s = Val v\<close> \<open>\<lbrakk>\<acute>x`\<rbrakk>s = \<lbrakk>\<acute>y`\<rbrakk>s\<close> have "v = v'" by simp
  with \<open>dom h3 = {v'}\<close> \<open>dom h1 = {v}\<close> have "\<not> h3 \<bottom> h1" by simp
  hence "\<not> (h3++h4) \<bottom> h1" using ortho_distr by auto
  with \<open>h2 = h3++h4\<close> have "\<not> h1 \<bottom> h2" using ortho_commut by metis
  with \<open>h1 \<bottom> h2\<close> show False by simp
qed

text \<open>Order in pure formulae does not matter.\<close>
corollary pure_commut: "(s,h)\<Turnstile>PureF(p1\<and>\<^sub>pp2\<and>\<^sub>p\<Pi>) \<longleftrightarrow> (s,h)\<Turnstile>PureF(p2\<and>\<^sub>pp1\<and>\<^sub>p\<Pi>)" by auto
corollary pure_commut_form: "(s,h)\<Turnstile>(p1\<and>\<^sub>pp2\<and>\<^sub>p\<Pi>)\<bar>\<Sigma> \<Longrightarrow> (s,h)\<Turnstile>(p2\<and>\<^sub>pp1\<and>\<^sub>p\<Pi>)\<bar>\<Sigma>"
using pure_commut by force

text \<open>Singular spatial formulae are only satisfied by singular heaps.\<close>
corollary sing_heap: "(s,h)\<Turnstile>SpatF[x\<longmapsto>y] \<longleftrightarrow> (s,h)\<Turnstile>Spat(x\<longmapsto>y) \<and> (\<exists> v v'. \<lbrakk>x\<rbrakk>s = Val v \<and>
   \<lbrakk>y\<rbrakk>s = v' \<and> h = [v\<mapsto>v'])" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume "?lhs"
  hence spat: "(s, h) \<Turnstile> Spat (x \<longmapsto> y)" by fastforce
  moreover then obtain v v' where "\<lbrakk>x\<rbrakk>s = Val v" "\<lbrakk>y\<rbrakk>s= v'" by blast
  moreover with spat have "h = [v\<mapsto>v']" by fastforce
  ultimately show "?rhs" by simp
next
  assume "?rhs"
  moreover have "h \<bottom> Map.empty" by simp
  ultimately have "(s,h++Map.empty)\<Turnstile>SpatF[x\<longmapsto>y]" by blast
  thus "?lhs" by simp
qed

text \<open>Order in spatial formulae does not matter.\<close>
corollary spatial_commut: "(s,h)\<Turnstile>SpatF(s1*s2*\<Sigma>) \<longleftrightarrow> (s,h)\<Turnstile>SpatF(s2*s1*\<Sigma>)" (is "?P s1 s2 \<longleftrightarrow> ?p s2 s1")
proof
  assume "?P s1 s2"
  then obtain h1 h2 where h:"h1 \<bottom> h2 \<and> h = h1++h2" and s1:"(s,h1)\<Turnstile>Spat s1" and "(s,h2)\<Turnstile>SpatF (s2*\<Sigma>)"
    by auto
  then obtain h3 h4 where h2:"h3 \<bottom> h4 \<and> h2 = h3++h4" and s2: "(s,h3)\<Turnstile>Spat s2" and \<sigma>: "(s,h4)\<Turnstile>SpatF \<Sigma>"
    by auto
  from h h2 have "h4 \<bottom> h1" by auto
  moreover then obtain h2' where h2': "h2' = h1++h4" by simp
  ultimately have "(s,h2')\<Turnstile>SpatF(s1*\<Sigma>)" using s1 \<sigma> by auto
  moreover from h h2 h2' have "h3 \<bottom> h2'" by auto
  moreover with h h2 h2' have "h=h3++h2'" by (metis map_add_assoc map_add_comm)
  ultimately show "?P s2 s1" using s2 by auto
next
  assume "?P s2 s1"
  then obtain h1 h2 where h:"h1 \<bottom> h2 \<and> h = h1++h2" and s2:"(s,h1)\<Turnstile>Spat s2" and "(s,h2)\<Turnstile>SpatF (s1*\<Sigma>)"
    by auto
  then obtain h3 h4 where h2:"h3 \<bottom> h4 \<and> h2 = h3++h4" and s1:"(s,h3)\<Turnstile>Spat s1" and \<sigma>: "(s,h4)\<Turnstile>SpatF \<Sigma>"
    by auto
  from h h2 have "h4 \<bottom> h1" by auto
  moreover then obtain h2' where h2': "h2' = h1++h4" by simp
  ultimately have "(s,h2')\<Turnstile>SpatF(s2*\<Sigma>)" using s2 \<sigma> by auto
  moreover from h h2 h2' have "h3 \<bottom> h2'" by auto
  moreover with h h2 h2' have "h=h3++h2'" by (metis map_add_assoc map_add_comm)
  ultimately show "?P s1 s2" using s1 by auto
qed
corollary spatial_commut_form: "(s,h)\<Turnstile>\<Pi>\<bar>(s1*s2*\<Sigma>) \<Longrightarrow> (s,h)\<Turnstile>\<Pi>\<bar>(s2*s1*\<Sigma>)"
using spatial_commut by force

text \<open>An empty list is equivalent to an empty heap.\<close>
corollary empty_ls: "(s,h)\<Turnstile>SpatF emp \<longleftrightarrow> (s,h)\<Turnstile>Spat(ls(x,x))"
proof
  assume "(s, h) \<Turnstile> SpatF emp"
  hence "dom h = {}" by blast
  hence "(s,h)\<Turnstile>ls\<^sup>0(x,x)" by blast
  thus "(s, h) \<Turnstile> Spat (ls(x, x))" by blast
next
  assume "(s, h) \<Turnstile> Spat (ls(x, x))"
  then obtain n where "(s,h)\<Turnstile>ls\<^sup>n(x,x)" by auto
  hence "n=0" "dom h = {}" by auto
  thus "(s, h) \<Turnstile> SpatF emp" by auto
  qed
text \<open>Due to this theorem circular list segements can only be formulated as follows:\<close>
term "\<acute>x`\<longmapsto>\<acute>y` * ls(\<acute>y`,\<acute>y`) * emp"

text \<open>The heap has no influence on the satisfaction of a pure formula.\<close>
corollary heap_pure: "(s,h)\<Turnstile>Pure P \<Longrightarrow>\<forall>h'. (s,h')\<Turnstile>Pure P"
  by (induction s h "Pure P" rule: sat_induct) auto
corollary heap_puref: "(s,h)\<Turnstile>PureF \<Pi> \<Longrightarrow>\<forall>h'. (s,h')\<Turnstile>PureF \<Pi>"
proof (induction s h "PureF \<Pi>" arbitrary: \<Pi> rule: sat_induct)
  case (TrueSat s h)
  then show ?case by fast
next
  case (ConjSat s h P \<Pi>')
  then show ?case using heap_pure by blast
qed

text \<open>Evaluation does not rely on unrelated variable values.\<close>
corollary eval_notin[simp]: "x \<notin> fv e \<Longrightarrow> \<lbrakk>e\<rbrakk>s=\<lbrakk>e\<rbrakk>s(x:=v)"
by (cases e) auto

text \<open>Only the two ls expressions are stack related.\<close>
corollary ls_stack_relation: "\<lbrakk>(s,h)\<Turnstile>ls\<^sup>n(e1,e2); \<lbrakk>e1\<rbrakk>s=\<lbrakk>e1\<rbrakk>t; \<lbrakk>e2\<rbrakk>s=\<lbrakk>e2\<rbrakk>t\<rbrakk> \<Longrightarrow> (t,h)\<Turnstile>ls\<^sup>n(e1,e2)"
proof (induction arbitrary: t rule: ls_induct)
  case (EmptyLs e1 s e2 h)
  then show ?case by auto
next
  case (ListSegment e1 s v' h1 v xs e2 h2 m h n)
  from ListSegment.hyps(1) ListSegment.prems(1) have e1: "\<lbrakk>e1\<rbrakk>t = Val v'" by simp
  from ListSegment.hyps(7) ListSegment.prems have neq: "\<lbrakk>e1\<rbrakk>t \<noteq> \<lbrakk>e2\<rbrakk>t" by simp
  have "\<forall>x \<in> xs. (t(x:=v),h2)\<Turnstile>ls\<^sup>m(\<acute>x`, e2)"
  proof
    fix x :: var
    assume assm: "x \<in> xs"
    with ListSegment.IH have aux:
      "\<lbrakk>\<acute>x`\<rbrakk>s(x := v) = \<lbrakk>\<acute>x`\<rbrakk>xa \<Longrightarrow> \<lbrakk>e2\<rbrakk>s(x := v) = \<lbrakk>e2\<rbrakk>xa \<Longrightarrow> (xa, h2)\<Turnstile>ls\<^sup>m(\<acute>x`, e2)" for xa
       by blast
    have "\<lbrakk>\<acute>x`\<rbrakk>s(x:=v) = \<lbrakk>\<acute>x`\<rbrakk>t(x:=v)" "\<lbrakk>e2\<rbrakk>s(x:=v) = \<lbrakk>e2\<rbrakk>t(x:=v)" using assm ListSegment.prems
      apply simp using assm ListSegment.prems ListSegment(3)
      by (metis ComplD UnCI eval_notin subsetD)
    from aux[OF this] show "(t(x:=v),h2)\<Turnstile>ls\<^sup>m(\<acute>x`, e2)" .
  qed
  from ls_ind.ListSegment[OF e1 ListSegment(2-3) this ListSegment(4-6) neq] show ?case .
qed

lemma ls_extend_lhs: "\<lbrakk>(s(x:=v),h)\<Turnstile>ls\<^sup>n(e1,e2); x \<notin> fv e1 \<union> fv e2\<rbrakk> \<Longrightarrow> (s,h)\<Turnstile>ls\<^sup>n(e1,e2)"
proof -
  assume assm1: "(s(x:=v),h)\<Turnstile>ls\<^sup>n(e1,e2)"
  assume assm2: "x \<notin> fv e1 \<union> fv e2"
  hence "\<lbrakk>e1\<rbrakk>s(x:=v) = \<lbrakk>e1\<rbrakk>s" "\<lbrakk>e2\<rbrakk>s(x:=v) = \<lbrakk>e2\<rbrakk>s" using eval_notin by fastforce+
  from ls_stack_relation[OF assm1 this] show ?thesis .
qed

lemma ls_extend_rhs: "\<lbrakk>(s,h)\<Turnstile>ls\<^sup>n(e1,e2); x \<notin> fv e1 \<union> fv e2\<rbrakk> \<Longrightarrow> (s(x:=v),h)\<Turnstile>ls\<^sup>n(e1,e2)"
proof -
  assume assm1: "(s,h)\<Turnstile>ls\<^sup>n(e1,e2)"
  assume assm2: "x \<notin> fv e1 \<union> fv e2"
  hence "\<lbrakk>e1\<rbrakk>s = \<lbrakk>e1\<rbrakk>s(x:=v) " "\<lbrakk>e2\<rbrakk>s = \<lbrakk>e2\<rbrakk>s(x:=v)" using eval_notin by fastforce+
  from ls_stack_relation[OF assm1 this] show ?thesis .
qed

corollary ls_extend: "x \<notin> fv e1 \<union> fv e2 \<Longrightarrow> ((s,h)\<Turnstile>ls\<^sup>n(e1,e2)) = ((s(x:=v),h)\<Turnstile>ls\<^sup>n(e1,e2))"
  using ls_extend_lhs ls_extend_rhs by metis

text \<open>The following lemmata are used to proof the substitution rule:\<close>
lemma subst_expr: "\<lbrakk>\<acute>x`\<rbrakk>s = \<lbrakk>E\<rbrakk>s \<Longrightarrow> \<lbrakk>subst x E e\<rbrakk>s = \<lbrakk>e\<rbrakk>s"
using subst_expr.elims by metis

lemma ls_change_fst: "\<lbrakk>(s,h)\<Turnstile>ls\<^sup>n(a,e); \<lbrakk>a\<rbrakk>s=\<lbrakk>b\<rbrakk>s\<rbrakk> \<Longrightarrow> (s,h)\<Turnstile>ls\<^sup>n(b,e)"
proof (induction rule: ls_induct)
  case (EmptyLs e1 s e2 h)
  then show ?case by auto
next
  case (ListSegment a s v h1 v' xs e h2 h m n)
  hence b: "\<lbrakk>b\<rbrakk>s = Val v" by metis
  define xs' where xs': "xs' =  xs - fv b"
  with ListSegment(3) have "xs' \<subseteq> - (fv a \<union> fv e) - fv b" by auto
  hence xs'_sub: "xs' \<subseteq> - (fv b \<union> fv e)" by auto
  have ih: "\<forall>x\<in> xs'. (s(x := v'), h2)\<Turnstile>ls\<^sup>h(\<acute>x`, e)"
  proof
    fix x
    assume "x \<in> xs'"
    with xs' have "x \<in> xs" by simp
    thus "(s(x := v'), h2)\<Turnstile>ls\<^sup>h(\<acute>x`, e)" using ListSegment.IH by simp
  qed
  from ListSegment.prems(1) ListSegment.hyps(7) have "\<lbrakk>b\<rbrakk>s \<noteq> \<lbrakk>e\<rbrakk>s" by simp
  from ls_ind.ListSegment[OF b ListSegment.hyps(2) xs'_sub ih ListSegment.hyps(4-6) this] show ?case .
qed

lemma ls_change_snd: "\<lbrakk>(s,h)\<Turnstile>ls\<^sup>n(e,a); \<lbrakk>a\<rbrakk>s = \<lbrakk>b\<rbrakk>s\<rbrakk> \<Longrightarrow> (s,h)\<Turnstile>ls\<^sup>n(e,b)"
proof (induction rule: ls_induct)
  case (EmptyLs e1' s e2' h)
  then show ?case by auto
next
  case (ListSegment e s v h1 v' xs a h2 h m n)
  define xs' where xs': "xs' = xs - fv b"
  with ListSegment(3) have "xs' \<subseteq> - (fv e \<union> fv a) - fv b" by auto
  hence xs'_sub: "xs' \<subseteq> - (fv e \<union> fv b)" by auto
  have ih: "\<forall>x\<in> xs'. (s(x := v'), h2)\<Turnstile>ls\<^sup>h(\<acute>x`, b)"
  proof
    fix x
    assume x: "x \<in> xs'"
    with xs' have "x \<notin> fv b" by simp
    moreover from x xs' ListSegment(3) have "x \<notin> fv a" by auto
    ultimately have "\<lbrakk>b\<rbrakk>s(x := v') = \<lbrakk>b\<rbrakk>s"  "\<lbrakk>a\<rbrakk>s(x := v') = \<lbrakk>a\<rbrakk>s" using eval_notin by metis+
    with ListSegment.prems have "\<lbrakk>a\<rbrakk>s(x := v') = \<lbrakk>b\<rbrakk>s(x := v')" by simp
    from x xs' have "x \<in> xs" by simp
    hence "\<lbrakk>a\<rbrakk>s(x := v') = \<lbrakk>b\<rbrakk>s(x := v') \<Longrightarrow> (s(x := v'), h2)\<Turnstile>ls\<^sup>h(\<acute>x`, b)" using ListSegment.IH
      by blast
    from this[OF \<open>\<lbrakk>a\<rbrakk>s(x := v') = \<lbrakk>b\<rbrakk>s(x := v')\<close>] show "(s(x := v'), h2)\<Turnstile>ls\<^sup>h(\<acute>x`, b)" .
  qed
  from ListSegment.prems ListSegment.hyps(7) have "\<lbrakk>e\<rbrakk>s \<noteq> \<lbrakk>b\<rbrakk>s" by simp
  from ls_ind.ListSegment[OF ListSegment(1-2) xs'_sub ih ListSegment(4-6) this] show ?case .
qed

lemma subst_sat_ls: "\<lbrakk>(s,h)\<Turnstile>ls\<^sup>n(e1',e2'); e1' = subst x E e1; e2' = subst x E e2; \<lbrakk>\<acute>x`\<rbrakk>s=\<lbrakk>E\<rbrakk>s\<rbrakk>
  \<Longrightarrow> (s,h)\<Turnstile>ls\<^sup>n(e1,e2)"
  using ls_change_snd ls_change_fst subst_expr by metis

lemma subst_sat:"\<lbrakk>(s,h)\<Turnstile>F'; F'=subst x E F; \<lbrakk>\<acute>x`\<rbrakk>s=\<lbrakk>E\<rbrakk>s\<rbrakk> \<Longrightarrow> (s,h)\<Turnstile>F"
proof (induction arbitrary: F rule: sat_induct)
  case (EqSat e1 s e2 h)
  from EqSat.prems(1) obtain e3 e4 where F: "F = Pure (e3=\<^sub>pe4)"
    using subst_distinct_pure1 subst_distinct_formula2
    by (metis formula.inject(1) subst_formula.simps(1))
  with EqSat.prems(1) have e1: "e1 = subst x E e3" and e2: "e2 = subst x E e4" by simp_all
  then show ?case proof (cases "\<acute>x`=e3")
    case True
    with e1 have "e1 = E" by auto
    then show ?thesis using EqSat by (metis F True e2 satisfaction.EqSat subst_not_eq_expr)
  next
    case False
    then show ?thesis proof (cases "\<acute>x`=e4")
      case True
      with e2 have "e2 = E" by auto
      then show ?thesis using EqSat F False True by auto
    next
      case False
      with \<open>\<acute>x`\<noteq>e3\<close> F have "x \<notin> fv F" by (metis Un_iff empty_iff fv_expr.simps(1) fv_expr.simps(2)
        fv_formula.simps(1) fv_pure.simps(1) insert_iff subst_expr.elims)
      then show ?thesis using subst_not_free_formula EqSat.hyps F e1 e2 by auto
    qed
  qed
next
  case (NeqSat e1 s e2 h)
  from NeqSat.prems(1) obtain e3 e4 where F: "F = Pure (e3\<noteq>\<^sub>pe4)"
    using subst_distinct_pure2 subst_distinct_formula2
    by (metis formula.inject(1) subst_formula.simps(1))
  with NeqSat.prems(1) have e1: "e1 = subst x E e3" and e2: "e2 = subst x E e4" by simp_all
  then show ?case proof (cases "\<acute>x`=e3")
    case True
    with e1 have "e1 = E" by auto
    then show ?thesis using NeqSat by (metis F True e1 e2 satisfaction.NeqSat subst_not_eq_expr)
  next
    case False
    then show ?thesis proof (cases "\<acute>x`=e4")
      case True
      with e2 have "e2 = E" by auto
      then show ?thesis using NeqSat F False True by auto
    next
      case False
      with \<open>\<acute>x`\<noteq>e3\<close> F have "x \<notin> fv F" by (smt Un_iff fv_expr.simps(1) fv_expr.simps(2)
        fv_formula.simps(1) fv_pure.simps(2) insert_absorb insert_iff insert_not_empty
        subst_expr.elims)
      then show ?thesis using subst_not_free_formula NeqSat.hyps F e1 e2 by auto
    qed
  qed
next
  case (TrueSat s h)
  then show ?case using subst_preserve_True satisfaction.TrueSat by metis
next
  case (ConjSat s h P \<Pi>)
  from ConjSat.prems(1) obtain P' \<Pi>' where F: "F = PureF (P'\<and>\<^sub>p\<Pi>')"
    using subst_distinct_formula1 subst_distinct_puref
    by (metis formula.inject(2) subst_formula.simps(2))
  with ConjSat.prems(1) have "Pure P = subst x E (Pure P')" "PureF \<Pi> = subst x E (PureF \<Pi>')"
    by simp_all
  from ConjSat.IH(1)[OF this(1) ConjSat.prems(2)] ConjSat.IH(2)[OF this(2) ConjSat.prems(2)] F
  show ?case by auto
next
  case (PointsToSat e1 s v h e2)
  then show ?case proof (cases "x \<in> fv F")
    case True
    then show ?thesis using PointsToSat
    by (smt formula.inject(3) satisfaction.PointsToSat spatial.inject(1) subst_distinct_formula4
      subst_distinct_spat1 subst_expr.simps(2) subst_formula.simps(3) subst_not_eq_expr
      subst_spatial.simps(1))
  next
    case False
    show ?thesis using subst_not_free_formula[OF False] PointsToSat by fastforce
  qed
next
  case (EmpSat h s)
  then show ?case using satisfaction.EmpSat subst_preserve_emp by metis
next
  case (SepConjSat h1 h2 h s S \<Sigma>)
  from SepConjSat.prems(1) obtain S' \<Sigma>' where F: "F = SpatF (S'*\<Sigma>')"
    using subst_distinct_spatf subst_distinct_formula3
    by (metis formula.inject(4) subst_formula.simps(4))
  with SepConjSat.prems(1) have "Spat S = subst x E (Spat S')" "SpatF \<Sigma> = subst x E (SpatF \<Sigma>')"
    by simp_all
  with SepConjSat.IH SepConjSat.prems(2) have "(s,h1)\<Turnstile>Spat S'" "(s,h2)\<Turnstile>SpatF \<Sigma>'" by simp_all
  then show ?case using F SepConjSat.hyps by blast
next
  case (FormSat s h \<Pi> \<Sigma>)
  from FormSat.prems(1) obtain \<Pi>' \<Sigma>' where F:"F = \<Pi>'\<bar>\<Sigma>'" using subst_distinct_formula5 by metis
  with FormSat.prems(1) have "substl x E \<Pi>' = \<Pi>" and "substl x E \<Sigma>' = \<Sigma>" by simp_all
  with FormSat.IH FormSat.prems(2) have "(s,h)\<Turnstile>PureF \<Pi>'" and "(s,h)\<Turnstile>SpatF \<Sigma>'" by simp_all
  with F show ?case by auto
next
  case (LsSat s h n e1 e2)
  from LsSat(2) obtain e1' e2' where F:"F = Spat (ls(e1', e2'))" using subst_distinct_formula4
    by (metis formula.inject(3) subst_distinct_spat2 subst_formula.simps(3))
  with LsSat(2) have "e1 = subst x E e1'" "e2 = subst x E e2'" by simp_all
  from subst_sat_ls[OF LsSat(1) this LsSat(3)] show ?case using F by auto
qed

lemma subst_sat_ls_rev: "\<lbrakk>(s,h)\<Turnstile>ls\<^sup>n(e1',e2'); e1 = subst x E e1'; e2 = subst x E e2'; \<lbrakk>\<acute>x`\<rbrakk>s=\<lbrakk>E\<rbrakk>s\<rbrakk>
  \<Longrightarrow> (s,h)\<Turnstile>ls\<^sup>n(e1,e2)"
  using ls_change_snd ls_change_fst subst_expr by metis

lemma subst_sat_rev:"\<lbrakk>(s,h)\<Turnstile>F; \<lbrakk>\<acute>x`\<rbrakk>s=\<lbrakk>E\<rbrakk>s\<rbrakk> \<Longrightarrow> (s,h)\<Turnstile>subst x E F"
proof (induction rule: sat_induct)
  case (EqSat e1 s e2 h)
  then show ?case by (metis satisfaction.EqSat subst_expr.simps(2) subst_formula.simps(1)
    subst_not_eq_expr subst_pure.simps(1))
next
  case (NeqSat e1 s e2 h)
  then show ?case by (metis satisfaction.NeqSat subst_expr.simps(2) subst_formula.simps(1)
    subst_not_eq_expr subst_pure.simps(2))
next
  case (PointsToSat e1 s v h e2)
  then show ?case by (smt satisfaction.PointsToSat subst_expr.simps(2) subst_formula.simps(3)
    subst_not_eq_expr subst_spatial.simps(1))
next
  case (LsSat s h n e1 e2)
  obtain e1' e2' where F: "subst x E (Spat (ls(e1, e2))) = Spat (ls(e1', e2'))" by simp
  hence  "e1' = subst x E e1" "e2' = subst x E e2" by simp_all
  from subst_sat_ls_rev[OF LsSat(1) this LsSat(2)] show ?case using F by auto
qed auto

lemma subst_sat_eq: "\<lbrakk>F'=subst x E F; \<lbrakk>\<acute>x`\<rbrakk>s=\<lbrakk>E\<rbrakk>s\<rbrakk> \<Longrightarrow> ((s,h)\<Turnstile>F') = ((s,h)\<Turnstile>F)"
using subst_sat subst_sat_rev by fast

end


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

chapter {* More bit operations on integers *}

theory More_Bits_Int
imports
  "HOL-Word.Bits_Bit"
  "HOL-Word.Bool_List_Representation"
begin

lemma last_rev' [simp]: "last (rev xs) = hd xs"
by(cases xs)(simp add: last_def hd_def, simp)

lemma butlast_rev [simp]: "butlast (rev xs) = rev (tl xs)"
by(cases xs) simp_all

lemma tl_upt [simp]: "tl [n..<m] = [Suc n..<m]"
by(cases "n < m")(simp_all add: upt_conv_Cons)

lemma nat_LEAST_True [simp]: "(LEAST _ :: nat. True) = 0"
by(auto intro: Least_equality)

lemma nat_less_numeral_unfold: fixes n :: nat shows
  "n < numeral w \<longleftrightarrow> n = pred_numeral w \<or> n < pred_numeral w"
by(auto simp add: numeral_eq_Suc)

section {* Lemmas about bit operations on @{typ int} *}

lemma twice_conv_BIT: "2 * x = x BIT False"
by(rule bin_rl_eqI)(simp_all, simp_all add: bin_rest_def bin_last_def)

lemma not_int_cmp_0 [simp]:
  fixes i :: int shows
  "0 < NOT i \<longleftrightarrow> i < -1"
  "0 \<le> NOT i \<longleftrightarrow> i < 0"
  "NOT i < 0 \<longleftrightarrow> i \<ge> 0"
  "NOT i \<le> 0 \<longleftrightarrow> i \<ge> -1"
by(simp_all add: int_not_def) arith+

lemma bbw_ao_dist2: "(x :: int) AND (y OR z) = x AND y OR x AND z"
by(metis int_and_comm bbw_ao_dist)

lemmas int_and_ac = bbw_lcs(1) int_and_comm int_and_assoc

lemma bit_nand_same [simp]: fixes x :: bit shows "x AND NOT x = 0"
by(cases x) simp_all

lemma int_nand_same [simp]: fixes x :: int shows "x AND NOT x = 0"
by(induct x y\<equiv>"NOT x" rule: bitAND_int.induct)(subst bitAND_int.simps, clarsimp)

lemma int_nand_same_middle: fixes x :: int shows "x AND y AND NOT x = 0"
by (metis bbw_lcs(1) int_and_0 int_nand_same)

lemma and_xor_dist: fixes x :: int shows
  "x AND (y XOR z) = (x AND y) XOR (x AND z)"
by(simp add: int_xor_def bbw_ao_dist2 bbw_ao_dist bbw_not_dist int_and_ac int_nand_same_middle)

lemma BIT_lt0 [simp]: "x BIT b < 0 \<longleftrightarrow> x < 0"
by(cases b)(auto simp add: Bit_def)

lemma BIT_ge0 [simp]: "x BIT b \<ge> 0 \<longleftrightarrow> x \<ge> 0"
by(cases b)(auto simp add: Bit_def)

lemma bin_rest_gt_0 [simp]: "bin_rest x > 0 \<longleftrightarrow> x > 1"
by(simp add: bin_rest_def add1_zle_eq pos_imp_zdiv_pos_iff) (metis add1_zle_eq one_add_one)

lemma int_and_lt0 [simp]: fixes x y :: int shows
  "x AND y < 0 \<longleftrightarrow> x < 0 \<and> y < 0"
by(induct x y rule: bitAND_int.induct)(subst bitAND_int.simps, simp)

lemma int_and_ge0 [simp]: fixes x y :: int shows
  "x AND y \<ge> 0 \<longleftrightarrow> x \<ge> 0 \<or> y \<ge> 0"
by (metis int_and_lt0 linorder_not_less)

lemma int_and_1: fixes x :: int shows "x AND 1 = x mod 2"
by(subst bitAND_int.simps)(simp add: Bit_def bin_last_def zmod_minus1)

lemma int_1_and: fixes x :: int shows "1 AND x = x mod 2"
by(subst int_and_comm)(simp add: int_and_1)

lemma int_or_lt0 [simp]: fixes x y :: int shows
  "x OR y < 0 \<longleftrightarrow> x < 0 \<or> y < 0"
by(simp add: int_or_def)

lemma int_xor_lt0 [simp]: fixes x y :: int shows
  "x XOR y < 0 \<longleftrightarrow> ((x < 0) \<noteq> (y < 0))"
by(auto simp add: int_xor_def)

lemma int_xor_ge0 [simp]: fixes x y :: int shows
  "x XOR y \<ge> 0 \<longleftrightarrow> ((x \<ge> 0) \<longleftrightarrow> (y \<ge> 0))"
by (metis int_xor_lt0 linorder_not_le)

lemma bin_last_conv_AND:
  "bin_last i \<longleftrightarrow> i AND 1 \<noteq> 0"
proof -
  obtain x b where "i = x BIT b" by(cases i rule: bin_exhaust)
  hence "i AND 1 = 0 BIT b"
    by(simp add: BIT_special_simps(2)[symmetric] del: BIT_special_simps(2))
  thus ?thesis using `i = x BIT b` by(cases b) simp_all
qed

lemma bitval_bin_last:
  "of_bool (bin_last i) = i AND 1"
proof -
  obtain x b where "i = x BIT b" by(cases i rule: bin_exhaust)
  hence "i AND 1 = 0 BIT b"
    by(simp add: BIT_special_simps(2)[symmetric] del: BIT_special_simps(2))
  thus ?thesis by(cases b)(simp_all add: bin_last_conv_AND)
qed

lemma bl_to_bin_BIT:
  "bl_to_bin bs BIT b = bl_to_bin (bs @ [b])"
by(simp add: bl_to_bin_append)

lemma bin_last_bl_to_bin: "bin_last (bl_to_bin bs) \<longleftrightarrow> bs \<noteq> [] \<and> last bs"
by(cases "bs = []")(auto simp add: bl_to_bin_def last_bin_last'[where w=0])

lemma bin_rest_bl_to_bin: "bin_rest (bl_to_bin bs) = bl_to_bin (butlast bs)"
by(cases "bs = []")(simp_all add: bl_to_bin_def butlast_rest_bl2bin_aux)

lemma bin_nth_numeral_unfold:
  "bin_nth (numeral (num.Bit0 x)) n \<longleftrightarrow> n > 0 \<and> bin_nth (numeral x) (n - 1)"
  "bin_nth (numeral (num.Bit1 x)) n \<longleftrightarrow> (n > 0 \<longrightarrow> bin_nth (numeral x) (n - 1))"
by(case_tac [!] n) simp_all

lemma bin_sign_and:
  "bin_sign (i AND j) = - (bin_sign i * bin_sign j)"
by(simp add: bin_sign_def)

lemma minus_BIT_0: fixes x y :: int shows "x BIT b - y BIT False = (x - y) BIT b"
by(simp add: Bit_def)

primrec bin_mask :: "nat \<Rightarrow> int"
where
  "bin_mask 0 = 0"
| "bin_mask (Suc n) = bin_mask n BIT True"

lemma bin_mask_conv_pow2:
  "bin_mask n = 2 ^ n - 1"
by(induct n)(simp_all add: Bit_def)

lemma bin_mask_ge0: "bin_mask n \<ge> 0"
by(induct n) simp_all

lemma and_bin_mask_conv_mod: "x AND bin_mask n = x mod 2 ^ n"
proof(induction n arbitrary: x)
  case 0 thus ?case by simp
next
  case (Suc n)
  obtain x' b where "x = x' BIT b" by(cases x rule: bin_exhaust)
  with Suc show ?case by(cases b)(simp_all, simp_all add: Bit_def p1mod22k)
qed

lemma bin_mask_numeral:
  "bin_mask (numeral n) = bin_mask (pred_numeral n) BIT True"
by(simp add: numeral_eq_Suc)

lemma bin_nth_mask [simp]: "bin_nth (bin_mask n) i \<longleftrightarrow> i < n"
proof(induction n arbitrary: i)
  case (Suc n)
  thus ?case by(cases i) simp_all
qed simp

section {* Symbolic bit operations on numerals and @{typ int}s *}

lemma int_not_neg_numeral: "NOT (- numeral n) = (Num.sub n num.One :: int)"
by(simp add: int_not_def)

lemma sub_inc_One: "Num.sub (Num.inc n) num.One = numeral n"
by (metis add_diff_cancel diff_minus_eq_add diff_numeral_special(2) diff_numeral_special(6))

lemma inc_BitM: "Num.inc (Num.BitM n) = num.Bit0 n"
by(simp add: BitM_plus_one[symmetric] add_One)

lemma int_neg_numeral_pOne_conv_not: "- numeral (n + num.One) = (NOT (numeral n) :: int)"
by(simp add: int_not_def)

fun bitOR_num :: "num \<Rightarrow> num \<Rightarrow> num"
where
  "bitOR_num num.One num.One = num.One"
| "bitOR_num num.One (num.Bit0 n) = num.Bit1 n"
| "bitOR_num num.One (num.Bit1 n) = num.Bit1 n"
| "bitOR_num (num.Bit0 m) num.One = num.Bit1 m"
| "bitOR_num (num.Bit0 m) (num.Bit0 n) = num.Bit0 (bitOR_num m n)"
| "bitOR_num (num.Bit0 m) (num.Bit1 n) = num.Bit1 (bitOR_num m n)"
| "bitOR_num (num.Bit1 m) num.One = num.Bit1 m"
| "bitOR_num (num.Bit1 m) (num.Bit0 n) = num.Bit1 (bitOR_num m n)"
| "bitOR_num (num.Bit1 m) (num.Bit1 n) = num.Bit1 (bitOR_num m n)"

fun bitAND_num :: "num \<Rightarrow> num \<Rightarrow> num option"
where
  "bitAND_num num.One num.One = Some num.One"
| "bitAND_num num.One (num.Bit0 n) = None"
| "bitAND_num num.One (num.Bit1 n) = Some num.One"
| "bitAND_num (num.Bit0 m) num.One = None"
| "bitAND_num (num.Bit0 m) (num.Bit0 n) = map_option num.Bit0 (bitAND_num m n)"
| "bitAND_num (num.Bit0 m) (num.Bit1 n) = map_option num.Bit0 (bitAND_num m n)"
| "bitAND_num (num.Bit1 m) num.One = Some num.One"
| "bitAND_num (num.Bit1 m) (num.Bit0 n) = map_option num.Bit0 (bitAND_num m n)"
| "bitAND_num (num.Bit1 m) (num.Bit1 n) = (case bitAND_num m n of None \<Rightarrow> Some num.One | Some n' \<Rightarrow> Some (num.Bit1 n'))"

fun bitXOR_num :: "num \<Rightarrow> num \<Rightarrow> num option"
where
  "bitXOR_num num.One num.One = None"
| "bitXOR_num num.One (num.Bit0 n) = Some (num.Bit1 n)"
| "bitXOR_num num.One (num.Bit1 n) = Some (num.Bit0 n)"
| "bitXOR_num (num.Bit0 m) num.One = Some (num.Bit1 m)"
| "bitXOR_num (num.Bit0 m) (num.Bit0 n) = map_option num.Bit0 (bitXOR_num m n)"
| "bitXOR_num (num.Bit0 m) (num.Bit1 n) = Some (case bitXOR_num m n of None \<Rightarrow> num.One | Some n' \<Rightarrow> num.Bit1 n')"
| "bitXOR_num (num.Bit1 m) num.One = Some (num.Bit0 m)"
| "bitXOR_num (num.Bit1 m) (num.Bit0 n) = Some (case bitXOR_num m n of None \<Rightarrow> num.One | Some n' \<Rightarrow> num.Bit1 n')"
| "bitXOR_num (num.Bit1 m) (num.Bit1 n) = map_option num.Bit0 (bitXOR_num m n)"

fun bitORN_num :: "num \<Rightarrow> num \<Rightarrow> num"
where
  "bitORN_num num.One num.One = num.One"
| "bitORN_num num.One (num.Bit0 m) = num.Bit1 m"
| "bitORN_num num.One (num.Bit1 m) = num.Bit1 m"
| "bitORN_num (num.Bit0 n) num.One = num.Bit0 num.One"
| "bitORN_num (num.Bit0 n) (num.Bit0 m) = Num.BitM (bitORN_num n m)"
| "bitORN_num (num.Bit0 n) (num.Bit1 m) = num.Bit0 (bitORN_num n m)"
| "bitORN_num (num.Bit1 n) num.One = num.One"
| "bitORN_num (num.Bit1 n) (num.Bit0 m) = Num.BitM (bitORN_num n m)"
| "bitORN_num (num.Bit1 n) (num.Bit1 m) = Num.BitM (bitORN_num n m)"

fun bitANDN_num :: "num \<Rightarrow> num \<Rightarrow> num option"
where
  "bitANDN_num num.One num.One = None"
| "bitANDN_num num.One (num.Bit0 n) = Some num.One"
| "bitANDN_num num.One (num.Bit1 n) = None"
| "bitANDN_num (num.Bit0 m) num.One = Some (num.Bit0 m)"
| "bitANDN_num (num.Bit0 m) (num.Bit0 n) = map_option num.Bit0 (bitANDN_num m n)"
| "bitANDN_num (num.Bit0 m) (num.Bit1 n) = map_option num.Bit0 (bitANDN_num m n)"
| "bitANDN_num (num.Bit1 m) num.One = Some (num.Bit0 m)"
| "bitANDN_num (num.Bit1 m) (num.Bit0 n) = (case bitANDN_num m n of None \<Rightarrow> Some num.One | Some n' \<Rightarrow> Some (num.Bit1 n'))"
| "bitANDN_num (num.Bit1 m) (num.Bit1 n) = map_option num.Bit0 (bitANDN_num m n)"

lemma int_numeral_bitOR_num: "numeral n OR numeral m = (numeral (bitOR_num n m) :: int)"
by(induct n m rule: bitOR_num.induct) simp_all

lemma int_numeral_bitAND_num: "numeral n AND numeral m = (case bitAND_num n m of None \<Rightarrow> 0 :: int | Some n' \<Rightarrow> numeral n')"
by(induct n m rule: bitAND_num.induct)(simp_all split: option.split)

lemma int_numeral_bitXOR_num:
  "numeral m XOR numeral n = (case bitXOR_num m n of None \<Rightarrow> 0 :: int | Some n' \<Rightarrow> numeral n')"
by(induct m n rule: bitXOR_num.induct)(simp_all split: option.split)

lemma int_or_not_bitORN_num:
  "numeral n OR NOT (numeral m) = (- numeral (bitORN_num n m) :: int)"
by(induct n m rule: bitORN_num.induct)(simp_all add: Num.add_One BitM_inc)

lemma int_and_not_bitANDN_num:
  "numeral n AND NOT (numeral m) = (case bitANDN_num n m of None \<Rightarrow> 0 :: int | Some n' \<Rightarrow> numeral n')"
by(induct n m rule: bitANDN_num.induct)(simp_all add: Num.add_One BitM_inc split: option.split)

lemma int_not_and_bitANDN_num:
  "NOT (numeral m) AND numeral n = (case bitANDN_num n m of None \<Rightarrow> 0 :: int | Some n' \<Rightarrow> numeral n')"
by(simp add: int_and_not_bitANDN_num[symmetric] int_and_comm)

lemma Bit_code [code]:
  "0 BIT b = of_bool b"
  "Int.Pos n BIT False = Int.Pos (num.Bit0 n)"
  "Int.Pos n BIT True = Int.Pos (num.Bit1 n)"
  "Int.Neg n BIT False = Int.Neg (num.Bit0 n)"
  "Int.Neg n BIT True = Int.Neg (Num.BitM n)"
by(cases b)(simp_all)

lemma bin_last_code [code]:
  "bin_last 0 \<longleftrightarrow> False"
  "bin_last (Int.Pos num.One) \<longleftrightarrow> True"
  "bin_last (Int.Pos (num.Bit0 n)) \<longleftrightarrow> False"
  "bin_last (Int.Pos (num.Bit1 n)) \<longleftrightarrow> True"
  "bin_last (Int.Neg num.One) \<longleftrightarrow> True"
  "bin_last (Int.Neg (num.Bit0 n)) \<longleftrightarrow> False"
  "bin_last (Int.Neg (num.Bit1 n)) \<longleftrightarrow> True"
by(simp_all)

lemma bin_nth_code [code]:
  "bin_nth 0                 n = False"
  "bin_nth (Int.Neg num.One) n = True"
  "bin_nth (Int.Pos num.One)      0 = True"
  "bin_nth (Int.Pos (num.Bit0 m)) 0 = False"
  "bin_nth (Int.Pos (num.Bit1 m)) 0 = True"
  "bin_nth (Int.Neg (num.Bit0 m)) 0 = False"
  "bin_nth (Int.Neg (num.Bit1 m)) 0 = True"
  "bin_nth (Int.Pos num.One)      (Suc n) = False"
  "bin_nth (Int.Pos (num.Bit0 m)) (Suc n) = bin_nth (Int.Pos m) n"
  "bin_nth (Int.Pos (num.Bit1 m)) (Suc n) = bin_nth (Int.Pos m) n"
  "bin_nth (Int.Neg (num.Bit0 m)) (Suc n) = bin_nth (Int.Neg m) n"
  "bin_nth (Int.Neg (num.Bit1 m)) (Suc n) = bin_nth (Int.Neg (Num.inc m)) n"
by(simp_all add: Num.add_One)

lemma int_not_code [code]:
  "NOT (0 :: int) = -1"
  "NOT (Int.Pos n) = Int.Neg (Num.inc n)"
  "NOT (Int.Neg n) = Num.sub n num.One"
by(simp_all add: Num.add_One int_not_def)

lemma int_and_code [code]: fixes i j :: int shows
  "0 AND j = 0"
  "i AND 0 = 0"
  "Int.Pos n AND Int.Pos m = (case bitAND_num n m of None \<Rightarrow> 0 | Some n' \<Rightarrow> Int.Pos n')"
  "Int.Neg n AND Int.Neg m = NOT (Num.sub n num.One OR Num.sub m num.One)"
  "Int.Pos n AND Int.Neg num.One = Int.Pos n"
  "Int.Pos n AND Int.Neg (num.Bit0 m) = Num.sub (bitORN_num (Num.BitM m) n) num.One"
  "Int.Pos n AND Int.Neg (num.Bit1 m) = Num.sub (bitORN_num (num.Bit0 m) n) num.One"
  "Int.Neg num.One AND Int.Pos m = Int.Pos m"
  "Int.Neg (num.Bit0 n) AND Int.Pos m = Num.sub (bitORN_num (Num.BitM n) m) num.One"
  "Int.Neg (num.Bit1 n) AND Int.Pos m = Num.sub (bitORN_num (num.Bit0 n) m) num.One"
apply(fold int_not_neg_numeral)
apply(simp_all add: int_numeral_bitAND_num int_or_not_bitORN_num[symmetric] bbw_not_dist Num.add_One int_not_neg_numeral sub_inc_One inc_BitM cong: option.case_cong)
apply(simp_all add: int_and_comm)
apply(metis int_not_neg_numeral int_not_not)
done

lemma int_or_code [code]: fixes i j :: int shows
  "0 OR j = j"
  "i OR 0 = i"
  "Int.Pos n OR Int.Pos m = Int.Pos (bitOR_num n m)"
  "Int.Neg n OR Int.Neg m = NOT (Num.sub n num.One AND Num.sub m num.One)"
  "Int.Pos n OR Int.Neg num.One = Int.Neg num.One"
  "Int.Pos n OR Int.Neg (num.Bit0 m) = (case bitANDN_num (Num.BitM m) n of None \<Rightarrow> -1 | Some n' \<Rightarrow> Int.Neg (Num.inc n'))"
  "Int.Pos n OR Int.Neg (num.Bit1 m) = (case bitANDN_num (num.Bit0 m) n of None \<Rightarrow> -1 | Some n' \<Rightarrow> Int.Neg (Num.inc n'))"
  "Int.Neg num.One OR Int.Pos m = Int.Neg num.One"
  "Int.Neg (num.Bit0 n) OR Int.Pos m = (case bitANDN_num (Num.BitM n) m of None \<Rightarrow> -1 | Some n' \<Rightarrow> Int.Neg (Num.inc n'))"
  "Int.Neg (num.Bit1 n) OR Int.Pos m = (case bitANDN_num (num.Bit0 n) m of None \<Rightarrow> -1 | Some n' \<Rightarrow> Int.Neg (Num.inc n'))"
apply(simp_all add: int_numeral_bitOR_num)
apply(simp_all add: int_or_def int_not_neg_numeral int_and_comm int_not_and_bitANDN_num del: int_not_simps(4) split: option.split)
apply(simp_all add: Num.add_One)
done

lemma int_xor_code [code]: fixes i j :: int shows
  "0 XOR j = j"
  "i XOR 0 = i"
  "Int.Pos n XOR Int.Pos m = (case bitXOR_num n m of None \<Rightarrow> 0 | Some n' \<Rightarrow> Int.Pos n')"
  "Int.Neg n XOR Int.Neg m = Num.sub n num.One XOR Num.sub m num.One"
  "Int.Neg n XOR Int.Pos m = NOT (Num.sub n num.One XOR Int.Pos m)"
  "Int.Pos n XOR Int.Neg m = NOT (Int.Pos n XOR Num.sub m num.One)"
by(fold int_not_neg_numeral)(simp_all add: int_numeral_bitXOR_num int_xor_not cong: option.case_cong)

section {* More on bits and bitss operations *}

inductive wf_set_bits_int :: "(nat \<Rightarrow> bool) \<Rightarrow> bool"
  for f :: "nat \<Rightarrow> bool"
where
  zeros: "\<forall>n' \<ge> n. \<not> f n' \<Longrightarrow> wf_set_bits_int f"
| ones: "\<forall>n' \<ge> n. f n' \<Longrightarrow> wf_set_bits_int f"

lemma wf_set_bits_int_simps: "wf_set_bits_int f \<longleftrightarrow> (\<exists>n. (\<forall>n'\<ge>n. \<not> f n') \<or> (\<forall>n'\<ge>n. f n'))"
by(auto simp add: wf_set_bits_int.simps)

lemma wf_set_bits_int_const [simp]: "wf_set_bits_int (\<lambda>_. b)"
by(cases b)(auto intro: wf_set_bits_int.intros)

lemma wf_set_bits_int_fun_upd [simp]:
  "wf_set_bits_int (f(n := b)) \<longleftrightarrow> wf_set_bits_int f" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then obtain n'
    where "(\<forall>n''\<ge>n'. \<not> (f(n := b)) n'') \<or> (\<forall>n''\<ge>n'. (f(n := b)) n'')"
    by(auto simp add: wf_set_bits_int_simps)
  hence "(\<forall>n''\<ge>max (Suc n) n'. \<not> f n'') \<or> (\<forall>n''\<ge>max (Suc n) n'. f n'')" by auto
  thus ?rhs by(auto simp only: wf_set_bits_int_simps)
next
  assume ?rhs
  then obtain n' where "(\<forall>n''\<ge>n'. \<not> f n'') \<or> (\<forall>n''\<ge>n'. f n'')" (is "?wf f n'")
    by(auto simp add: wf_set_bits_int_simps)
  hence "?wf (f(n := b)) (max (Suc n) n')" by auto
  thus ?lhs by(auto simp only: wf_set_bits_int_simps)
qed

lemma wf_set_bits_int_Suc [simp]:
  "wf_set_bits_int (\<lambda>n. f (Suc n)) \<longleftrightarrow> wf_set_bits_int f" (is "?lhs \<longleftrightarrow> ?rhs")
by(auto simp add: wf_set_bits_int_simps intro: le_SucI dest: Suc_le_D)

lemma int_lsb_BIT [simp]: fixes x :: int shows
  "lsb (x BIT b) \<longleftrightarrow> b"
by(simp add: lsb_int_def)

lemma bin_last_conv_lsb: "bin_last = lsb"
by(clarsimp simp add: lsb_int_def fun_eq_iff)

lemma int_lsb_numeral [simp]:
  "lsb (0 :: int) = False"
  "lsb (1 :: int) = True"
  "lsb (Numeral1 :: int) = True"
  "lsb (- 1 :: int) = True"
  "lsb (- Numeral1 :: int) = True"
  "lsb (numeral (num.Bit0 w) :: int) = False"
  "lsb (numeral (num.Bit1 w) :: int) = True"
  "lsb (- numeral (num.Bit0 w) :: int) = False"
  "lsb (- numeral (num.Bit1 w) :: int) = True"
by(simp_all add: lsb_int_def)

lemma int_lsb_code [code]:
  "lsb (0 :: int) = False"
  "lsb (Int.Pos num.One) = True"
  "lsb (Int.Pos (num.Bit0 w)) = False"
  "lsb (Int.Pos (num.Bit1 w)) = True"
  "lsb (Int.Neg num.One) = True"
  "lsb (Int.Neg (num.Bit0 w)) = False"
  "lsb (Int.Neg (num.Bit1 w)) = True"
by simp_all

lemma int_set_bit_0 [simp]: fixes x :: int shows
  "set_bit x 0 b = bin_rest x BIT b"
by(auto simp add: set_bit_int_def intro: bin_rl_eqI)

lemma int_set_bit_Suc: fixes x :: int shows
  "set_bit x (Suc n) b = set_bit (bin_rest x) n b BIT bin_last x"
by(auto simp add: set_bit_int_def twice_conv_BIT intro: bin_rl_eqI)

lemma bin_last_set_bit:
  "bin_last (set_bit x n b) = (if n > 0 then bin_last x else b)"
by(cases n)(simp_all add: int_set_bit_Suc)

lemma bin_rest_set_bit:
  "bin_rest (set_bit x n b) = (if n > 0 then set_bit (bin_rest x) (n - 1) b else bin_rest x)"
by(cases n)(simp_all add: int_set_bit_Suc)

lemma int_set_bit_numeral: fixes x :: int shows
  "set_bit x (numeral w) b = set_bit (bin_rest x) (pred_numeral w) b BIT bin_last x"
by(simp add: set_bit_int_def)

lemmas int_set_bit_numerals [simp] =
  int_set_bit_numeral[where x="numeral w'"]
  int_set_bit_numeral[where x="- numeral w'"]
  int_set_bit_numeral[where x="Numeral1"]
  int_set_bit_numeral[where x="1"]
  int_set_bit_numeral[where x="0"]
  int_set_bit_Suc[where x="numeral w'"]
  int_set_bit_Suc[where x="- numeral w'"]
  int_set_bit_Suc[where x="Numeral1"]
  int_set_bit_Suc[where x="1"]
  int_set_bit_Suc[where x="0"]
  for w'

lemma int_shiftl_BIT: fixes x :: int
  shows int_shiftl0 [simp]: "x << 0 = x"
  and int_shiftl_Suc [simp]: "x << Suc n = (x << n) BIT False"
by(auto simp add: shiftl_int_def Bit_def)

lemma int_0_shiftl [simp]: "0 << n = (0 :: int)"
by(induct n) simp_all

lemma bin_last_shiftl: "bin_last (x << n) \<longleftrightarrow> n = 0 \<and> bin_last x"
by(cases n)(simp_all)

lemma bin_rest_shiftl: "bin_rest (x << n) = (if n > 0 then x << (n - 1) else bin_rest x)"
by(cases n)(simp_all)

lemma bin_nth_shiftl [simp]: "bin_nth (x << n) m \<longleftrightarrow> n \<le> m \<and> bin_nth x (m - n)"
proof(induct n arbitrary: x m)
  case (Suc n)
  thus ?case by(cases m) simp_all
qed simp

lemma int_shiftr_BIT [simp]: fixes x :: int
  shows int_shiftr0: "x >> 0 = x"
  and int_shiftr_Suc: "x BIT b >> Suc n = x >> n"
proof -
  show "x >> 0 = x" by (simp add: shiftr_int_def)
  show "x BIT b >> Suc n = x >> n" by (cases b)
   (simp_all add: shiftr_int_def Bit_def add.commute pos_zdiv_mult_2)
qed

lemma bin_last_shiftr: "bin_last (x >> n) \<longleftrightarrow> x !! n"
proof(induct n arbitrary: x)
  case 0 thus ?case by simp
next
  case (Suc n)
  thus ?case by(cases x rule: bin_exhaust) simp
qed

lemma bin_rest_shiftr [simp]: "bin_rest (x >> n) = x >> Suc n"
proof(induct n arbitrary: x)
  case 0
  thus ?case by(cases x rule: bin_exhaust) auto
next
  case (Suc n)
  thus ?case by(cases x rule: bin_exhaust) auto
qed

lemma bin_nth_shiftr [simp]: "bin_nth (x >> n) m = bin_nth x (n + m)"
proof(induct n arbitrary: x m)
  case (Suc n)
  thus ?case by(cases x rule: bin_exhaust) simp_all
qed simp

lemma bin_nth_conv_AND:
  fixes x :: int shows
  "bin_nth x n \<longleftrightarrow> x AND (1 << n) \<noteq> 0"
proof(induct n arbitrary: x)
  case 0
  thus ?case by(simp add: int_and_1 bin_last_def)
next
  case (Suc n)
  thus ?case by(cases x rule: bin_exhaust)(simp_all add: bin_nth_ops Bit_eq_0_iff)
qed

lemma int_shiftl_numeral [simp]:
  "(numeral w :: int) << numeral w' = numeral (num.Bit0 w) << pred_numeral w'"
  "(- numeral w :: int) << numeral w' = - numeral (num.Bit0 w) << pred_numeral w'"
by(simp_all add: numeral_eq_Suc Bit_def shiftl_int_def)
  (metis add_One mult_inc semiring_norm(11) semiring_norm(13) semiring_norm(2) semiring_norm(6) semiring_norm(87))+

lemma int_shiftl_code [code]:
  "i << 0 = i"
  "i << Suc n = Int.dup i << n"
by(simp_all add: shiftl_int_def)

lemma int_shiftl_One_numeral [simp]: "(1 :: int) << numeral w = 2 << pred_numeral w"
by(metis int_shiftl_numeral numeral_One)

lemma shiftl_ge_0 [simp]: fixes i :: int shows "i << n \<ge> 0 \<longleftrightarrow> i \<ge> 0"
by(induct n) simp_all

lemma shiftl_lt_0 [simp]: fixes i :: int shows "i << n < 0 \<longleftrightarrow> i < 0"
by (metis not_le shiftl_ge_0)

lemma int_shiftl_test_bit: "(n << i :: int) !! m \<longleftrightarrow> m \<ge> i \<and> n !! (m - i)"
proof(induction i)
  case (Suc n)
  thus ?case by(cases m) simp_all
qed simp

lemma bin_mask_p1_conv_shift: "bin_mask n + 1 = 1 << n"
by(induct n) simp_all

lemma int_0shiftr [simp]: "(0 :: int) >> x = 0"
by(simp add: shiftr_int_def)

lemma int_minus1_shiftr [simp]: "(-1 :: int) >> x = -1"
by(simp add: shiftr_int_def div_eq_minus1)

lemma int_shiftr_ge_0 [simp]: fixes i :: int shows "i >> n \<ge> 0 \<longleftrightarrow> i \<ge> 0"
proof(induct n arbitrary: i)
  case (Suc n)
  thus ?case by(cases i rule: bin_exhaust) simp_all
qed simp

lemma int_shiftr_lt_0 [simp]: fixes i :: int shows "i >> n < 0 \<longleftrightarrow> i < 0"
by (metis int_shiftr_ge_0 not_less)

lemma uminus_Bit_eq:
  "- k BIT b = (- k - of_bool b) BIT b"
  by (cases b) (simp_all add: Bit_def)

lemma int_shiftr_numeral [simp]:
  "(1 :: int) >> numeral w' = 0"
  "(numeral num.One :: int) >> numeral w' = 0"
  "(numeral (num.Bit0 w) :: int) >> numeral w' = numeral w >> pred_numeral w'"
  "(numeral (num.Bit1 w) :: int) >> numeral w' = numeral w >> pred_numeral w'"
  "(- numeral (num.Bit0 w) :: int) >> numeral w' = - numeral w >> pred_numeral w'"
  "(- numeral (num.Bit1 w) :: int) >> numeral w' = - numeral (Num.inc w) >> pred_numeral w'"
  by (simp_all only: numeral_One expand_BIT numeral_eq_Suc int_shiftr_Suc BIT_special_simps(2)[symmetric] int_0shiftr add_One uminus_Bit_eq)
    (simp_all add: add_One)

lemma int_shiftr_numeral_Suc0 [simp]:
  "(1 :: int) >> Suc 0 = 0"
  "(numeral num.One :: int) >> Suc 0 = 0"
  "(numeral (num.Bit0 w) :: int) >> Suc 0 = numeral w"
  "(numeral (num.Bit1 w) :: int) >> Suc 0 = numeral w"
  "(- numeral (num.Bit0 w) :: int) >> Suc 0 = - numeral w"
  "(- numeral (num.Bit1 w) :: int) >> Suc 0 = - numeral (Num.inc w)"
by(simp_all only: One_nat_def[symmetric] numeral_One[symmetric] int_shiftr_numeral pred_numeral_simps int_shiftr0)

lemma int_shiftr_code [code]: fixes i :: int shows
  "i >> 0 = i"
  "0 >> Suc n = (0 :: int)"
  "Int.Pos num.One >> Suc n = 0"
  "Int.Pos (num.Bit0 m) >> Suc n = Int.Pos m >> n"
  "Int.Pos (num.Bit1 m) >> Suc n = Int.Pos m >> n"
  "Int.Neg num.One >> Suc n = -1"
  "Int.Neg (num.Bit0 m) >> Suc n = Int.Neg m >> n"
  "Int.Neg (num.Bit1 m) >> Suc n = Int.Neg (Num.inc m) >> n"
  by (simp_all only: int_shiftr_Suc BIT_special_simps(2)[symmetric] int_shiftr0 int_0shiftr numeral_One int_minus1_shiftr Int.Pos_def Int.Neg_def expand_BIT int_shiftr_Suc Num.add_One uminus_Bit_eq)
    (simp_all add: add_One)

lemma bin_nth_minus_p2:
  assumes sign: "bin_sign x = 0"
  and y: "y = 1 << n"
  and m: "m < n"
  and x: "x < y"
  shows "bin_nth (x - y) m = bin_nth x m"
using sign m x unfolding y
proof(induction m arbitrary: x y n)
  case 0
  thus ?case
    by(simp add: bin_last_def shiftl_int_def) (metis (hide_lams, no_types) mod_diff_right_eq mod_self neq0_conv numeral_One power_eq_0_iff power_mod diff_zero zero_neq_numeral)
next
  case (Suc m)
  from `Suc m < n` obtain n' where [simp]: "n = Suc n'" by(cases n) auto
  obtain x' b where [simp]: "x = x' BIT b" by(cases x rule: bin_exhaust)
  from `bin_sign x = 0` have "bin_sign x' = 0" by simp
  moreover from `x < 1 << n` have "x' < 1 << n'"
    by(cases b)(simp_all add: Bit_def shiftl_int_def)
  moreover have "(2 * x' + of_bool b - 2 * 2 ^ n') div 2 = x' + (- (2 ^ n') + of_bool b div 2)"
    by(simp only: add_diff_eq[symmetric] add.commute div_mult_self2[OF zero_neq_numeral[symmetric]])
  ultimately show ?case using Suc.IH[of x' n'] Suc.prems
    by(cases b)(simp_all add: Bit_def bin_rest_def shiftl_int_def)
qed

lemma bin_clr_conv_NAND:
  "bin_sc n False i = i AND NOT (1 << n)"
by(induct n arbitrary: i)(auto intro: bin_rl_eqI)

lemma bin_set_conv_OR:
  "bin_sc n True i = i OR (1 << n)"
by(induct n arbitrary: i)(auto intro: bin_rl_eqI)

lemma fixes i :: int
  shows int_set_bit_True_conv_OR [code]: "set_bit i n True = i OR (1 << n)"
  and int_set_bit_False_conv_NAND [code]: "set_bit i n False = i AND NOT (1 << n)"
  and int_set_bit_conv_ops: "set_bit i n b = (if b then i OR (1 << n) else i AND NOT (1 << n))"
by(simp_all add: set_bit_int_def bin_set_conv_OR bin_clr_conv_NAND)

lemma int_set_bits_K_True [simp]: "(BITS _. True) = (-1 :: int)"
by(auto simp add: set_bits_int_def bin_last_bl_to_bin)

lemma int_set_bits_K_False [simp]: "(BITS _. False) = (0 :: int)"
by(auto simp add: set_bits_int_def)

lemma int_set_bits_unfold_BIT:
  assumes "wf_set_bits_int f"
  shows "set_bits f = set_bits (f \<circ> Suc) BIT f 0"
using assms
proof cases
  case (zeros n)
  show ?thesis
  proof(cases "\<forall>n. \<not> f n")
    case True
    hence "f = (\<lambda>_. False)" by auto
    thus ?thesis using True by(simp add: o_def)
  next
    case False
    then obtain n' where "f n'" by blast
    with zeros have "(LEAST n. \<forall>n'\<ge>n. \<not> f n') = Suc (LEAST n. \<forall>n'\<ge>Suc n. \<not> f n')"
      by(auto intro: Least_Suc)
    also have "(\<lambda>n. \<forall>n'\<ge>Suc n. \<not> f n') = (\<lambda>n. \<forall>n'\<ge>n. \<not> f (Suc n'))" by(auto dest: Suc_le_D)
    also from zeros have "\<forall>n'\<ge>n. \<not> f (Suc n')" by auto
    ultimately show ?thesis using zeros
      by(simp (no_asm_simp) add: set_bits_int_def exI split del: if_split)(rule bin_rl_eqI, auto simp add: bin_last_bl_to_bin hd_map bin_rest_bl_to_bin map_tl[symmetric] map_map[symmetric] map_Suc_upt simp del: map_map)
  qed
next
  case (ones n)
  show ?thesis
  proof(cases "\<forall>n. f n")
    case True
    hence "f = (\<lambda>_. True)" by auto
    thus ?thesis using True by(simp add: o_def)
  next
    case False
    then obtain n' where "\<not> f n'" by blast
    with ones have "(LEAST n. \<forall>n'\<ge>n. f n') = Suc (LEAST n. \<forall>n'\<ge>Suc n. f n')"
      by(auto intro: Least_Suc)
    also have "(\<lambda>n. \<forall>n'\<ge>Suc n. f n') = (\<lambda>n. \<forall>n'\<ge>n. f (Suc n'))" by(auto dest: Suc_le_D)
    also from ones have "\<forall>n'\<ge>n. f (Suc n')" by auto
    moreover from ones have "(\<exists>n. \<forall>n'\<ge>n. \<not> f n') = False"
      by(auto intro!: exI[where x="max n m" for n m] simp add: max_def split: if_split_asm)
    moreover hence "(\<exists>n. \<forall>n'\<ge>n. \<not> f (Suc n')) = False"
      by(auto elim: allE[where x="Suc n" for n] dest: Suc_le_D)
    ultimately show ?thesis using ones
      by(simp (no_asm_simp) add: set_bits_int_def exI split del: if_split)(auto simp add: Let_def bin_last_bl_to_bin hd_map bin_rest_bl_to_bin map_tl[symmetric] map_map[symmetric] map_Suc_upt simp del: map_map)
  qed
qed

lemma bin_last_set_bits [simp]:
  "wf_set_bits_int f \<Longrightarrow> bin_last (set_bits f) = f 0"
by(subst int_set_bits_unfold_BIT) simp_all

lemma bin_rest_set_bits [simp]:
  "wf_set_bits_int f \<Longrightarrow> bin_rest (set_bits f) = set_bits (f \<circ> Suc)"
by(subst int_set_bits_unfold_BIT) simp_all

lemma bin_nth_set_bits [simp]:
  "wf_set_bits_int f \<Longrightarrow> bin_nth (set_bits f) m = f m"
proof(induction m arbitrary: f)
  case 0
  thus ?case by simp
next
  case Suc
  from Suc.IH[of "\<lambda>n. f (Suc n)"] Suc.prems show ?case
    by(simp add: o_def)
qed

lemma set_bits_code [code]:
  "set_bits = Code.abort (STR ''set_bits is unsupported on type int'') (\<lambda>_. set_bits :: _ \<Rightarrow> int)"
by simp

lemma msb_conv_bin_sign: "msb x \<longleftrightarrow> bin_sign x = -1"
by(simp add: bin_sign_def not_le msb_int_def)

lemma msb_BIT [simp]: "msb (x BIT b) = msb x"
by(simp add: msb_int_def)

lemma msb_bin_rest [simp]: "msb (bin_rest x) = msb x"
by(simp add: msb_int_def)

lemma int_msb_and [simp]: "msb ((x :: int) AND y) \<longleftrightarrow> msb x \<and> msb y"
by(simp add: msb_int_def)

lemma int_msb_or [simp]: "msb ((x :: int) OR y) \<longleftrightarrow> msb x \<or> msb y"
by(simp add: msb_int_def)

lemma int_msb_xor [simp]: "msb ((x :: int) XOR y) \<longleftrightarrow> msb x \<noteq> msb y"
by(simp add: msb_int_def)

lemma int_msb_not [simp]: "msb (NOT (x :: int)) \<longleftrightarrow> \<not> msb x"
by(simp add: msb_int_def not_less)

lemma msb_shiftl [simp]: "msb ((x :: int) << n) \<longleftrightarrow> msb x"
by(simp add: msb_int_def)

lemma msb_shiftr [simp]: "msb ((x :: int) >> r) \<longleftrightarrow> msb x"
by(simp add: msb_int_def)

lemma msb_bin_sc [simp]: "msb (bin_sc n b x) \<longleftrightarrow> msb x"
by(simp add: msb_conv_bin_sign)

lemma msb_set_bit [simp]: "msb (set_bit (x :: int) n b) \<longleftrightarrow> msb x"
by(simp add: msb_conv_bin_sign set_bit_int_def)

lemma msb_0 [simp]: "msb (0 :: int) = False"
by(simp add: msb_int_def)

lemma msb_1 [simp]: "msb (1 :: int) = False"
by(simp add: msb_int_def)

lemma msb_numeral [simp]:
  "msb (numeral n :: int) = False"
  "msb (- numeral n :: int) = True"
by(simp_all add: msb_int_def)

section {* Bit list operations implemented by bitwise operations *}

lemma bin_rest_code [code]: "bin_rest i = i >> 1"
by(simp add: bin_rest_def shiftr_int_def)

lemma sbintrunc_code [code]:
  "sbintrunc n bin =
  (let bin' = bin AND bin_mask (n + 1)
   in if bin' !! n then bin' - (2 << n) else bin')"
proof(induct n arbitrary: bin)
  case 0 thus ?case
    by (simp add: bitval_bin_last [symmetric])
next
  case (Suc n)
  thus ?case by(cases bin rule: bin_exhaust)(simp add: Let_def minus_BIT_0)
qed

text {*
  Use this function to convert numeral @{typ integer}s quickly into @{typ int}s.
  By default, it works only for symbolic evaluation; normally generated code raises
  an exception at run-time. If theory @{text Code_Target_Bits_Int} is imported,
  it works again, because then @{typ int} is implemented in terms of @{typ integer}
  even for symbolic evaluation.
*}

definition int_of_integer_symbolic :: "integer \<Rightarrow> int"
where "int_of_integer_symbolic = int_of_integer"

lemma int_of_integer_symbolic_aux_code [code nbe]:
  "int_of_integer_symbolic 0 = 0"
  "int_of_integer_symbolic (Code_Numeral.Pos n) = Int.Pos n"
  "int_of_integer_symbolic (Code_Numeral.Neg n) = Int.Neg n"
by(simp_all add: int_of_integer_symbolic_def)

code_identifier
  code_module More_Bits_Int \<rightharpoonup>
  (SML) Bit_Int and (OCaml) Bit_Int and (Haskell) Bit_Int and (Scala) Bit_Int
| code_module Bits_Int \<rightharpoonup>
  (SML) Bit_Int and (OCaml) Bit_Int and (Haskell) Bit_Int and (Scala) Bit_Int
| code_module Bits \<rightharpoonup>
  (SML) Bit_Int and (OCaml) Bit_Int and (Haskell) Bit_Int and (Scala) Bit_Int

end