(*
 *
 * Copyright 2016, Data61, CSIRO
 *
 * 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.
 *
 * @TAG(DATA61_BSD)
 *)

theory String_Compare
imports Main
begin

(* Speed up string comparisons in Isabelle2016-1.
   We replace simp rule Char_eq_Char_iff with one which normalises in fewer steps. *)

(* Beware that this might reappear during theory merges. *)
declare Char_eq_Char_iff [simp del]

lemma pos_divmod_nat_rel_mult_2:
  assumes "0 \<le> b"
  assumes "divmod_nat_rel a b (q, r)"
  shows "divmod_nat_rel (1 + 2*a) (2*b) (q, 1 + 2*r)"
  using assms unfolding divmod_nat_rel_def by auto

lemma pos_nat_mod_mult_2:
  fixes a b :: nat
  assumes "0 \<le> a"
  shows "(1 + 2 * b) mod (2 * a) = 1 + 2 * (b mod a)"
  using pos_divmod_nat_rel_mult_2 [OF assms divmod_nat_rel]
  by (rule mod_nat_unique)

lemma pos_nat_mod_mult_2_r:
  fixes a b :: nat
  assumes "0 \<le> a"
  shows "(2 * b + 1) mod (2 * a) = 2 * (b mod a) + 1"
  using pos_nat_mod_mult_2 by simp

lemma num_double: "num.Bit0 num.One * n = num.Bit0 n"
  by (metis (no_types, lifting) mult_2 numeral_Bit0 numeral_eq_iff
                                numeral_times_numeral)

lemma num_Bit0_mod_pow2_Suc:
  "numeral (num.Bit0 n) mod (2::nat) ^ Suc i = 2 * (numeral n mod 2 ^ i)"
  by (metis mod_mult_mult1 mult_2 numeral_Bit0 power_Suc)

lemma num_Bit1_mod_pow2_Suc:
  "numeral (num.Bit1 n) mod (2::nat) ^ Suc i = 2 * (numeral n mod 2 ^ i) + 1"
  unfolding power_Suc numeral_Bit1 mult_2[symmetric]
  by (rule pos_nat_mod_mult_2_r) simp

datatype peano = Peano_Z | Peano_S peano

primrec
  peano_of_nat :: "nat \<Rightarrow> peano"
where
  "peano_of_nat 0 = Peano_Z"
| "peano_of_nat (Suc n) = Peano_S (peano_of_nat n)"

fun
  truncate_num :: "peano \<Rightarrow> num \<Rightarrow> num option"
where
  "truncate_num Peano_Z n = None"
| "truncate_num (Peano_S p) num.One = Some num.One"
| "truncate_num (Peano_S p) (num.Bit0 n') = map_option num.Bit0 (truncate_num p n')"
| "truncate_num (Peano_S p) (num.Bit1 n') = Some (case_option num.One num.Bit1 (truncate_num p n'))"

lemma truncate_num:
  "(numeral n :: nat) mod 2 ^ d = case_option 0 numeral (truncate_num (peano_of_nat d) n)"
  proof (induct d arbitrary: n)
    case 0 show ?case by (cases n) auto
  next
    case (Suc d) show ?case
    proof (cases n)
      case One thus ?thesis
        apply simp
        apply (rule mod_less)
        using less_2_cases not_less_eq by fastforce
    next
      case (Bit0 m) thus ?thesis
        unfolding Bit0 Suc num_Bit0_mod_pow2_Suc
        by (clarsimp simp: num_double split: option.splits)
    next
      case (Bit1 m) show ?thesis
        unfolding Bit1 Suc num_Bit1_mod_pow2_Suc
        by (clarsimp simp: num_double split: option.splits)
    qed
  qed

fun
  truncate_num_all_zero :: "peano \<Rightarrow> num \<Rightarrow> bool"
where
  "truncate_num_all_zero Peano_Z n = True"
| "truncate_num_all_zero (Peano_S d) (num.Bit0 n) = truncate_num_all_zero d n"
| "truncate_num_all_zero (Peano_S d) _ = False"

lemma truncate_num_all_zero: "truncate_num_all_zero d n \<longleftrightarrow> truncate_num d n = None"
  by (induct n arbitrary: d; case_tac d; simp)

fun
  truncate_num_compare :: "peano \<Rightarrow> num \<Rightarrow> num \<Rightarrow> bool"
where
  "truncate_num_compare Peano_Z m n = True"
| "truncate_num_compare (Peano_S d) num.One num.One = True"
| "truncate_num_compare (Peano_S d) num.One (num.Bit1 n) = truncate_num_all_zero d n"
| "truncate_num_compare (Peano_S d) (num.Bit1 m) num.One = truncate_num_all_zero d m"
| "truncate_num_compare (Peano_S d) (num.Bit0 m) (num.Bit0 n) = truncate_num_compare d m n"
| "truncate_num_compare (Peano_S d) (num.Bit1 m) (num.Bit1 n) = truncate_num_compare d m n"
| "truncate_num_compare (Peano_S d) num.One (num.Bit0 _) = False"
| "truncate_num_compare (Peano_S d) (num.Bit0 _) num.One = False"
| "truncate_num_compare (Peano_S d) (num.Bit0 _) (num.Bit1 _) = False"
| "truncate_num_compare (Peano_S d) (num.Bit1 _) (num.Bit0 _) = False"

lemma truncate_num_compare:
  "truncate_num_compare d m n \<longleftrightarrow> truncate_num d m = truncate_num d n"
  proof -
    have inj_Bit0: "inj num.Bit0" by (auto intro: injI)
    show ?thesis
      by (induction d m n rule: truncate_num_compare.induct;
          clarsimp simp: truncate_num_all_zero map_option_case
                         inj_eq[OF option.inj_map, OF inj_Bit0]
                  split: option.splits)
  qed

abbreviation
  "peano_8 \<equiv> Peano_S (Peano_S (Peano_S (Peano_S (Peano_S (Peano_S (Peano_S (Peano_S Peano_Z)))))))"

lemma numeral_mod_256:
  "(numeral n :: nat) mod 256 = case_option 0 numeral (truncate_num peano_8 n)"
  proof -
    have "peano_of_nat 8 \<equiv> peano_8" by (simp add: eval_nat_numeral)
    thus ?thesis using truncate_num[where d=8] by simp
  qed

lemma Char_eq_iff_truncate_num_compare [simp]:
  "Char k = Char l \<longleftrightarrow> truncate_num_compare peano_8 k l"
  unfolding Char_eq_Char_iff numeral_mod_256 truncate_num_compare
  by (simp split: option.splits)

end


(*
Title: Strong-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory Up_To_Technique
imports Strong_Security
begin

context Strong_Security
begin

-- "define d-bisimulation 'up to' union of strong d-Bisimulations"
definition d_Bisimulation_Up_To_USdB ::
"'d \<Rightarrow> 'com Bisimulation_type \<Rightarrow> bool"
where
"d_Bisimulation_Up_To_USdB d R \<equiv>
  (sym R) \<and> (\<forall>(V,V') \<in> R. length V = length V') \<and>
  (\<forall>(V,V') \<in> R. \<forall>i < length V. \<forall>m1 m1' W m2.
  \<langle>V!i,m1\<rangle> \<rightarrow> \<langle>W,m2\<rangle> \<and> (m1 =\<^bsub>d\<^esub> m1')
  \<longrightarrow> (\<exists>W' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle>
    \<and> (W,W') \<in> (R \<union> (\<approx>\<^bsub>d\<^esub>)) \<and> (m2 =\<^bsub>d\<^esub> m2')))"

lemma UpTo_aux: "\<And>V V' m1 m1' m2 W i. \<lbrakk> d_Bisimulation_Up_To_USdB d R;
  i < length V; (V,V') \<in> R; \<langle>V!i,m1\<rangle> \<rightarrow> \<langle>W,m2\<rangle>; m1 =\<^bsub>d\<^esub> m1' \<rbrakk>
  \<Longrightarrow> (\<exists>W' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle>
  \<and> (W,W') \<in> (R \<union> (\<approx>\<^bsub>d\<^esub>)) \<and> (m2 =\<^bsub>d\<^esub> m2'))"
  by (simp add: d_Bisimulation_Up_To_USdB_def, fastforce)

lemma RuUSdBeqlen:
"\<lbrakk> d_Bisimulation_Up_To_USdB d R;
  (V,V') \<in> (R \<union> (\<approx>\<^bsub>d\<^esub>)) \<rbrakk>
  \<Longrightarrow> length V = length V'"
by (auto, simp add: d_Bisimulation_Up_To_USdB_def, auto,
  rule USdBeqlen, auto)

lemma Up_To_Technique:
  assumes upToR: "d_Bisimulation_Up_To_USdB d R"
  shows "R \<subseteq> \<approx>\<^bsub>d\<^esub>"
proof -
  def S \<equiv> "R \<union> (\<approx>\<^bsub>d\<^esub>)"
  from S_def have "R \<subseteq> S"
    by auto
  moreover
  have "S \<subseteq> (\<approx>\<^bsub>d\<^esub>)"
  proof (simp add: USdB_def, auto, rule_tac x="S" in exI, auto,
      simp add: Strong_d_Bisimulation_def, auto)
      -- "show symmetry"
    show symS: "sym S"
    proof -
      from upToR
      have Rsym: "sym R"
        by (simp add: d_Bisimulation_Up_To_USdB_def)
      with USdBsym have Usym:
        "sym (R \<union> (\<approx>\<^bsub>d\<^esub>))"
        by (metis sym_Un)
      with S_def show ?thesis
        by simp
    qed
  next
    fix V V'
    assume inS: "(V,V') \<in> S"
      -- "show equal length (by definition)"
    from inS S_def upToR RuUSdBeqlen
    show eqlen: "length V = length V'"
      by simp
  next
      -- "show general bisimulation property"
    fix V V' W m1 m1' m2 i
    assume inS: "(V,V') \<in> S"
    assume irange: "i < length V"
    assume stepV: "\<langle>V!i,m1\<rangle> \<rightarrow> \<langle>W,m2\<rangle>"
    assume dequal: "m1 =\<^bsub>d\<^esub> m1'"

    from inS show "\<exists>W' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle> \<and>
      (W,W') \<in> S \<and> m2 =\<^bsub>d\<^esub> m2'"
    proof (simp add: S_def, auto)
      assume firstcase: "(V,V') \<in> R"

      with upToR dequal irange stepV
        UpTo_aux[of "d" "R" "i" "V" "V'" "m1" "W" "m2" "m1'"]
      show "\<exists>W' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle> \<and>
        ((W,W') \<in> R \<or> W \<approx>\<^bsub>d\<^esub> W') \<and> m2 =\<^bsub>d\<^esub> m2'"
        by (auto simp add: S_def)
    next
      assume secondcase: "V \<approx>\<^bsub>d\<^esub> V'"

      from USdB_Strong_d_Bisimulation upToR
        secondcase dequal irange stepV
        strongdB_aux[of "d" "\<approx>\<^bsub>d\<^esub>" "i" "V" "V'" "m1" "W" "m2" "m1'"]
      show "\<exists>W' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle> \<and>
        ((W,W') \<in> R \<or> W \<approx>\<^bsub>d\<^esub> W') \<and> m2 =\<^bsub>d\<^esub> m2'"
        by auto
    qed
  qed

  ultimately show ?thesis by auto
qed

end

end


(*  Title:      ZF/UNITY/Increasing.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge

Increasing's parameters are a state function f, a domain A and an order
relation r over the domain A.
*)

section\<open>Charpentier's "Increasing" Relation\<close>

theory Increasing imports Constrains Monotonicity begin

definition
  increasing :: "[i, i, i=>i] => i" (\<open>increasing[_]'(_, _')\<close>)  where
  "increasing[A](r, f) ==
    {F \<in> program. (\<forall>k \<in> A. F \<in> stable({s \<in> state. <k, f(s)> \<in> r})) &
                (\<forall>x \<in> state. f(x):A)}"

definition
  Increasing :: "[i, i, i=>i] => i" (\<open>Increasing[_]'(_, _')\<close>)  where
  "Increasing[A](r, f) ==
    {F \<in> program. (\<forall>k \<in> A. F \<in> Stable({s \<in> state. <k, f(s)> \<in> r})) &
                (\<forall>x \<in> state. f(x):A)}"

abbreviation (input)
  IncWrt ::  "[i=>i, i, i] => i" (\<open>(_ IncreasingWrt _ '/ _)\<close> [60, 0, 60] 60)  where
  "f IncreasingWrt r/A == Increasing[A](r,f)"

(** increasing **)

lemma increasing_type: "increasing[A](r, f) \<subseteq> program"
by (unfold increasing_def, blast)

lemma increasing_into_program: "F \<in> increasing[A](r, f) ==> F \<in> program"
by (unfold increasing_def, blast)

lemma increasing_imp_stable:
"[| F \<in> increasing[A](r, f); x \<in> A |] ==>F \<in> stable({s \<in> state. <x, f(s)>:r})"
by (unfold increasing_def, blast)

lemma increasingD:
"F \<in> increasing[A](r,f) ==> F \<in> program & (\<exists>a. a \<in> A) & (\<forall>s \<in> state. f(s):A)"
apply (unfold increasing_def)
apply (subgoal_tac "\<exists>x. x \<in> state")
apply (auto dest: stable_type [THEN subsetD] intro: st0_in_state)
done

lemma increasing_constant [simp]:
 "F \<in> increasing[A](r, %s. c) \<longleftrightarrow> F \<in> program & c \<in> A"
apply (unfold increasing_def stable_def)
apply (subgoal_tac "\<exists>x. x \<in> state")
apply (auto dest: stable_type [THEN subsetD] intro: st0_in_state)
done

lemma subset_increasing_comp:
"[| mono1(A, r, B, s, g); refl(A, r); trans[B](s)  |] ==>
   increasing[A](r, f) \<subseteq> increasing[B](s, g comp f)"
apply (unfold increasing_def stable_def part_order_def
       constrains_def mono1_def metacomp_def, clarify, simp)
apply clarify
apply (subgoal_tac "xa \<in> state")
prefer 2 apply (blast dest!: ActsD)
apply (subgoal_tac "<f (xb), f (xb) >:r")
prefer 2 apply (force simp add: refl_def)
apply (rotate_tac 5)
apply (drule_tac x = "f (xb) " in bspec)
apply (rotate_tac [2] -1)
apply (drule_tac [2] x = act in bspec, simp_all)
apply (drule_tac A = "act``u" and c = xa for u in subsetD, blast)
apply (drule_tac x = "f(xa) " and x1 = "f(xb)" in bspec [THEN bspec])
apply (rule_tac [3] b = "g (f (xb))" and A = B in trans_onD)
apply simp_all
done

lemma imp_increasing_comp:
     "[| F \<in> increasing[A](r, f); mono1(A, r, B, s, g);
         refl(A, r); trans[B](s) |] ==> F \<in> increasing[B](s, g comp f)"
by (rule subset_increasing_comp [THEN subsetD], auto)

lemma strict_increasing:
   "increasing[nat](Le, f) \<subseteq> increasing[nat](Lt, f)"
by (unfold increasing_def Lt_def, auto)

lemma strict_gt_increasing:
   "increasing[nat](Ge, f) \<subseteq> increasing[nat](Gt, f)"
apply (unfold increasing_def Gt_def Ge_def, auto)
apply (erule natE)
apply (auto simp add: stable_def)
done

(** Increasing **)

lemma increasing_imp_Increasing:
     "F \<in> increasing[A](r, f) ==> F \<in> Increasing[A](r, f)"

apply (unfold increasing_def Increasing_def)
apply (auto intro: stable_imp_Stable)
done

lemma Increasing_type: "Increasing[A](r, f) \<subseteq> program"
by (unfold Increasing_def, auto)

lemma Increasing_into_program: "F \<in> Increasing[A](r, f) ==> F \<in> program"
by (unfold Increasing_def, auto)

lemma Increasing_imp_Stable:
"[| F \<in> Increasing[A](r, f); a \<in> A |] ==> F \<in> Stable({s \<in> state. <a,f(s)>:r})"
by (unfold Increasing_def, blast)

lemma IncreasingD:
"F \<in> Increasing[A](r, f) ==> F \<in> program & (\<exists>a. a \<in> A) & (\<forall>s \<in> state. f(s):A)"
apply (unfold Increasing_def)
apply (subgoal_tac "\<exists>x. x \<in> state")
apply (auto intro: st0_in_state)
done

lemma Increasing_constant [simp]:
     "F \<in> Increasing[A](r, %s. c) \<longleftrightarrow> F \<in> program & (c \<in> A)"
apply (subgoal_tac "\<exists>x. x \<in> state")
apply (auto dest!: IncreasingD intro: st0_in_state increasing_imp_Increasing)
done

lemma subset_Increasing_comp:
"[| mono1(A, r, B, s, g); refl(A, r); trans[B](s) |] ==>
   Increasing[A](r, f) \<subseteq> Increasing[B](s, g comp f)"
apply (unfold Increasing_def Stable_def Constrains_def part_order_def
       constrains_def mono1_def metacomp_def, safe)
apply (simp_all add: ActsD)
apply (subgoal_tac "xb \<in> state & xa \<in> state")
 prefer 2 apply (simp add: ActsD)
apply (subgoal_tac "<f (xb), f (xb) >:r")
prefer 2 apply (force simp add: refl_def)
apply (rotate_tac 5)
apply (drule_tac x = "f (xb) " in bspec)
apply simp_all
apply clarify
apply (rotate_tac -2)
apply (drule_tac x = act in bspec)
apply (drule_tac [2] A = "act``u" and c = xa for u in subsetD, simp_all, blast)
apply (drule_tac x = "f(xa)" and x1 = "f(xb)" in bspec [THEN bspec])
apply (rule_tac [3] b = "g (f (xb))" and A = B in trans_onD)
apply simp_all
done

lemma imp_Increasing_comp:
 "[| F \<in> Increasing[A](r, f); mono1(A, r, B, s, g); refl(A, r); trans[B](s) |]
  ==> F \<in> Increasing[B](s, g comp f)"
apply (rule subset_Increasing_comp [THEN subsetD], auto)
done

lemma strict_Increasing: "Increasing[nat](Le, f) \<subseteq> Increasing[nat](Lt, f)"
by (unfold Increasing_def Lt_def, auto)

lemma strict_gt_Increasing: "Increasing[nat](Ge, f)<= Increasing[nat](Gt, f)"
apply (unfold Increasing_def Ge_def Gt_def, auto)
apply (erule natE)
apply (auto simp add: Stable_def)
done

(** Two-place monotone operations **)

lemma imp_increasing_comp2:
"[| F \<in> increasing[A](r, f); F \<in> increasing[B](s, g);
    mono2(A, r, B, s, C, t, h); refl(A, r); refl(B, s); trans[C](t) |]
 ==> F \<in> increasing[C](t, %x. h(f(x), g(x)))"
apply (unfold increasing_def stable_def
       part_order_def constrains_def mono2_def, clarify, simp)
apply clarify
apply (rename_tac xa xb)
apply (subgoal_tac "xb \<in> state & xa \<in> state")
 prefer 2 apply (blast dest!: ActsD)
apply (subgoal_tac "<f (xb), f (xb) >:r & <g (xb), g (xb) >:s")
prefer 2 apply (force simp add: refl_def)
apply (rotate_tac 6)
apply (drule_tac x = "f (xb) " in bspec)
apply (rotate_tac [2] 1)
apply (drule_tac [2] x = "g (xb) " in bspec)
apply simp_all
apply (rotate_tac -1)
apply (drule_tac x = act in bspec)
apply (rotate_tac [2] -3)
apply (drule_tac [2] x = act in bspec, simp_all)
apply (drule_tac A = "act``u" and c = xa for u in subsetD)
apply (drule_tac [2] A = "act``u" and c = xa for u in subsetD, blast, blast)
apply (rotate_tac -4)
apply (drule_tac x = "f (xa) " and x1 = "f (xb) " in bspec [THEN bspec])
apply (rotate_tac [3] -1)
apply (drule_tac [3] x = "g (xa) " and x1 = "g (xb) " in bspec [THEN bspec])
apply simp_all
apply (rule_tac b = "h (f (xb), g (xb))" and A = C in trans_onD)
apply simp_all
done

lemma imp_Increasing_comp2:
"[| F \<in> Increasing[A](r, f); F \<in> Increasing[B](s, g);
  mono2(A, r, B, s, C, t, h); refl(A, r); refl(B, s); trans[C](t) |] ==>
  F \<in> Increasing[C](t, %x. h(f(x), g(x)))"
apply (unfold Increasing_def stable_def
       part_order_def constrains_def mono2_def Stable_def Constrains_def, safe)
apply (simp_all add: ActsD)
apply (subgoal_tac "xa \<in> state & x \<in> state")
prefer 2 apply (blast dest!: ActsD)
apply (subgoal_tac "<f (xa), f (xa) >:r & <g (xa), g (xa) >:s")
prefer 2 apply (force simp add: refl_def)
apply (rotate_tac 6)
apply (drule_tac x = "f (xa) " in bspec)
apply (rotate_tac [2] 1)
apply (drule_tac [2] x = "g (xa) " in bspec)
apply simp_all
apply clarify
apply (rotate_tac -2)
apply (drule_tac x = act in bspec)
apply (rotate_tac [2] -3)
apply (drule_tac [2] x = act in bspec, simp_all)
apply (drule_tac A = "act``u" and c = x for u in subsetD)
apply (drule_tac [2] A = "act``u" and c = x for u in subsetD, blast, blast)
apply (rotate_tac -9)
apply (drule_tac x = "f (x) " and x1 = "f (xa) " in bspec [THEN bspec])
apply (rotate_tac [3] -1)
apply (drule_tac [3] x = "g (x) " and x1 = "g (xa) " in bspec [THEN bspec])
apply simp_all
apply (rule_tac b = "h (f (xa), g (xa))" and A = C in trans_onD)
apply simp_all
done

end


(*
 * Copyright 2014, NICTA
 *
 * 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.
 *
 * @TAG(NICTA_BSD)
 *)

(* Miscellaneous additional library definitions and lemmas for the word type.
   Builds on WORD image.
*)

theory WordLib
imports NICTACompat SignedWords
begin

(* stuff to move to word/* *)

lemma shiftl_power:
  "(shiftl1 ^^ x) (y::'a::len word) = 2 ^ x * y"
  apply (induct x)
   apply simp
  apply (simp add: shiftl1_2t)
  done

lemmas of_bl_reasoning = to_bl_use_of_bl of_bl_append

lemma uint_of_bl_is_bl_to_bin:
  "length l\<le>len_of TYPE('a) \<Longrightarrow>
   uint ((of_bl::bool list\<Rightarrow> ('a :: len) word) l) = bl_to_bin l"
  apply (simp add: of_bl_def)
  apply (rule word_uint.Abs_inverse)
  apply (simp add: uints_num bl_to_bin_ge0)
  apply (rule order_less_le_trans, rule bl_to_bin_lt2p)
  apply (rule order_trans, erule power_increasing)
   apply simp_all
  done

lemma bin_to_bl_or:
  "bin_to_bl n (a OR b) = map2 (op \<or>) (bin_to_bl n a) (bin_to_bl n b)"
  using bl_or_aux_bin[where n=n and v=a and w=b and bs="[]" and cs="[]"]
  by simp

lemma word_ops_nth [simp]:
  shows
  word_or_nth:  "(x || y) !! n = (x !! n \<or> y !! n)" and
  word_and_nth: "(x && y) !! n = (x !! n \<and> y !! n)" and
  word_xor_nth: "(x xor y) !! n = (x !! n \<noteq> y !! n)"
  by ((cases "n < size x",
      auto dest: test_bit_size simp: word_ops_nth_size word_size)[1])+

(* simp del to avoid warning on the simp add in iff *)
declare test_bit_1 [simp del, iff]

(* test: *)
lemma "1 < (1024::32 word) \<and> 1 \<le> (1024::32 word)" by simp

lemma and_not_mask: "w AND NOT mask n = (w >> n) << n"
  apply (rule word_eqI)
  apply (simp add : word_ops_nth_size word_size)
  apply (simp add : nth_shiftr nth_shiftl)
  by auto

lemma and_mask: "w AND mask n = (w << (size w - n)) >> (size w - n)"
  apply (rule word_eqI)
  apply (simp add : word_ops_nth_size word_size)
  apply (simp add : nth_shiftr nth_shiftl)
  by auto

lemma AND_twice:
  "(w && m) && m = w && m"
by (simp add: word_eqI)

lemma nth_w2p_same: "(2^n :: 'a :: len word) !! n = (n < len_of TYPE('a::len))"
  by (simp add : nth_w2p)

lemma p2_gt_0: "(0 < (2 ^ n :: 'a :: len word)) = (n < len_of TYPE('a))"
  apply (simp add : word_gt_0)
  apply safe
   apply (erule swap)
   apply (rule word_eqI)
   apply (simp add : nth_w2p)
  apply (drule word_eqD)
  apply simp
  apply (erule notE)
  apply (erule nth_w2p_same [THEN iffD2])
  done

lemmas uint_2p_alt = uint_2p [unfolded p2_gt_0]

lemma shiftr_div_2n_w: "n < size w \<Longrightarrow> w >> n = w div (2^n :: 'a :: len word)"
  apply (unfold word_div_def)
  apply (simp add : uint_2p_alt word_size)
  apply (rule word_uint.Rep_inverse' [THEN sym])
  apply (rule shiftr_div_2n)
  done

lemmas less_def = less_eq [symmetric]
lemmas le_def = not_less [symmetric, where ?'a = nat]

lemmas p2_eq_0 = trans [OF eq_commute
  iffD2 [OF Not_eq_iff p2_gt_0, folded le_def, unfolded word_gt_0 not_not]]

lemma neg_mask_is_div':
  "n < size w \<Longrightarrow> w AND NOT mask n = ((w div (2 ^ n)) * (2 ^ n))"
  apply (simp add : and_not_mask)
  apply (simp add : shiftr_div_2n_w shiftl_t2n word_size)
  done

lemma neg_mask_is_div: "w AND NOT mask n = ((w div (2 ^ n)) * (2 ^ n))"
  apply (cases "n < size w")
  apply (erule neg_mask_is_div')
  apply (simp add : word_size)
  apply (frule p2_gt_0 [THEN Not_eq_iff [THEN iffD2], THEN iffD2])
  apply (simp add : word_gt_0)
  apply (rule word_eqI)
  apply (simp add : word_ops_nth_size word_size)
  done

lemma and_mask_arith':
  "0 < n \<Longrightarrow> w AND mask n = ((w * (2 ^ (size w - n))) div (2 ^ (size w - n)))"
  apply (simp add : and_mask)
  apply (simp add : shiftr_div_2n_w shiftl_t2n word_size)
  apply (simp add : mult.commute)
  done

lemma mask_0 [simp]: "mask 0 = 0"
  apply (unfold mask_def)
  by simp

lemmas p2len = iffD2 [OF p2_eq_0 order_refl]

lemma mask_2pm1: "mask n = 2 ^ n - 1"
  apply (simp add : mask_def)
  done

lemma is_aligned_AND_less_0:
  "u && mask n = 0 \<Longrightarrow> v < 2^n \<Longrightarrow> u && v = 0"
  apply (drule less_mask_eq)
  apply (simp add: mask_2pm1)
  apply (rule word_eqI)
  apply (clarsimp simp add: word_size)
  apply (drule_tac x=na in word_eqD)
  apply (drule_tac x=na in word_eqD)
  apply simp
  done

lemma len_0_eq: "len_of (TYPE('a :: len0)) = 0 ==> (x :: 'a :: len0 word) = y"
  by (rule size_0_same)

lemma le_shiftr1: "u <= v ==> shiftr1 u <= shiftr1 v"
  apply (unfold word_le_def shiftr1_def word_ubin.eq_norm)
  apply (unfold bin_rest_trunc_i
                trans [OF bintrunc_bintrunc_l word_ubin.norm_Rep,
                          unfolded word_ubin.norm_Rep,
                       OF order_refl [THEN le_SucI]])
  apply (case_tac "uint u" rule: bin_exhaust)
  apply (rename_tac bs bit)
  apply (case_tac "uint v" rule: bin_exhaust)
  apply (rename_tac bs' bit')
  apply (case_tac "bit")
   apply (case_tac "bit'", auto simp: less_eq_int_code le_Bits)[1]
  apply (case_tac bit')
   apply (simp add: le_Bits less_eq_int_code)
  apply (auto simp: le_Bits less_eq_int_code)
  done

lemma le_shiftr: "u \<le> v \<Longrightarrow> u >> (n :: nat) \<le> (v :: 'a :: len0 word) >> n"
  apply (unfold shiftr_def)
  apply (induct_tac "n")
   apply auto
  apply (erule le_shiftr1)
  done

lemma shiftr_mask_le: "n <= m ==> mask n >> m = 0"
  apply (rule word_eqI)
  apply (simp add: word_size nth_shiftr)
  done

lemmas shiftr_mask = order_refl [THEN shiftr_mask_le, simp]

lemma word_leI: "(!!n::nat.  n < size (u::'a::len0 word)
   ==> u !! n ==> (v::'a::len0 word) !! n) ==> u <= v"
  apply (rule xtr4)
   apply (rule word_and_le2)
  apply (rule word_eqI)
  apply (simp add: word_ao_nth)
  apply safe
    apply assumption
   apply (erule_tac [2] asm_rl)
  apply (unfold word_size)
  by auto

lemma le_mask_iff: "(w \<le> mask n) = (w >> n = 0)"
  apply safe
   apply (rule word_le_0_iff [THEN iffD1])
   apply (rule xtr3)
    apply (erule_tac [2] le_shiftr)
   apply simp
  apply (rule word_leI)
  apply (drule_tac x = "na - n" in word_eqD)
  apply (simp add : nth_shiftr word_size)
  apply (case_tac "n <= na")
   by auto

lemma and_mask_eq_iff_shiftr_0: "(w AND mask n = w) = (w >> n = 0)"
  apply (unfold test_bit_eq_iff [THEN sym])
  apply (rule iffI)
   apply (rule ext)
   apply (rule_tac [2] ext)
   apply (auto simp add : word_ao_nth nth_shiftr)
    apply (drule arg_cong)
    apply (drule iffD2)
     apply assumption
    apply (simp add : word_ao_nth)
   prefer 2
   apply (simp add : word_size test_bit_bin)
  apply (drule_tac f = "%u. u !! (x - n)" in arg_cong)
  apply (simp add : nth_shiftr)
  apply (case_tac "n <= x")
   apply auto
  done

lemmas and_mask_eq_iff_le_mask = trans
  [OF and_mask_eq_iff_shiftr_0 le_mask_iff [THEN sym]]

lemma one_bit_shiftl: "set_bit 0 n True = (1 :: 'a :: len word) << n"
  apply (rule word_eqI)
  apply (auto simp add: test_bit_set_gen nth_shiftl word_size
              simp del: word_set_bit_0 shiftl_1)
  done

lemmas one_bit_pow = trans [OF one_bit_shiftl shiftl_1]

lemma bin_sc_minus: "0 < n ==> bin_sc (Suc (n - 1)) b i = bin_sc n b i"
  by auto

lemmas bin_sc_minus_simps =
  bin_sc_simps (2,3,4) [THEN [2] trans, OF bin_sc_minus [THEN sym]]

lemma NOT_eq: "NOT (x :: 'a :: len word) = - x - 1"
  apply (cut_tac x = "x" in word_add_not)
  apply (drule add.commute [THEN trans])
  apply (drule eq_diff_eq [THEN iffD2])
  by simp

lemma NOT_mask: "NOT (mask n :: 'a :: len word) = - (2 ^ n)"
  apply (simp add : NOT_eq mask_2pm1)
  done

(* should be valid for len0 as well *)
lemma power_2_pos_iff:
  "(2 ^ n > (0 :: 'a :: len word)) = (n < len_of TYPE ('a))"
  apply (unfold word_gt_0)
  apply safe
   apply (erule swap)
   apply (rule word_eqI)
   apply (simp add : nth_w2p word_size)
  apply (drule_tac x = "n" in word_eqD)
  apply (simp add : nth_w2p)
  done

lemma le_m1_iff_lt: "(x > (0 :: 'a :: len word)) = ((y \<le> x - 1) = (y < x))"
  apply uint_arith
  done

lemmas gt0_iff_gem1 =
  iffD1 [OF iffD1 [OF iff_left_commute le_m1_iff_lt] order_refl]

lemmas power_2_ge_iff = trans [OF gt0_iff_gem1 [THEN sym] power_2_pos_iff]

lemma le_mask_iff_lt_2n:
  "n < len_of TYPE ('a) = (((w :: 'a :: len word) \<le> mask n) = (w < 2 ^ n))"
  apply (unfold mask_2pm1)
  apply (rule trans [OF power_2_pos_iff [THEN sym] le_m1_iff_lt])
  done

lemmas mask_lt_2pn =
  le_mask_iff_lt_2n [THEN iffD1, THEN iffD1, OF _ order_refl]

lemma mask_eq_iff_w2p_alt:
  "n < size (w::'a::len word) ==> (w AND mask n = w) = (w < 2 ^ n)"
  apply (unfold and_mask_eq_iff_le_mask word_size)
  apply (simp add : le_mask_iff_lt_2n [THEN iffD1])
  done

lemma and_mask_less_size_alt:  "n < size x ==> x AND mask n < 2 ^ n"
  apply (rule xtr7)
   apply (rule_tac [2] word_and_le1)
  apply (unfold word_size)
  apply (erule mask_lt_2pn)
  done

lemma bang_eq:
  fixes x :: "'a::len0 word"
  shows "(x = y) = (\<forall>n. x !! n = y !! n)"
  apply (subst test_bit_eq_iff[symmetric])
  apply (rule iffI)
   apply simp
  apply (rule ext)
  apply simp
  done

declare of_nat_power [simp]
declare of_nat_mult [simp]

lemma word_unat_power:
  "(2 :: ('a :: len) word) ^ n = of_nat (2 ^ n)"
  by (induct n) simp+

(*
lemmas no_power_simps =
  power_int.simps power_nat.simps
  power_nat_number_of_number_of power_Suc_no power_pred_simp_no
*)

lemma of_nat_mono_maybe:
  fixes Y :: "nat"
  assumes xlt: "X < 2 ^ len_of TYPE ('a :: len)"
  shows   "(Y < X) \<Longrightarrow> of_nat Y < (of_nat X :: 'a :: len word)"
  apply (subst word_less_nat_alt)
  apply (subst unat_of_nat)+
  apply (subst mod_less)
    apply (erule order_less_trans [OF _ xlt])
    apply (subst mod_less [OF xlt])
   apply assumption
   done

lemma shiftl_over_and_dist:
  fixes a::"'a::len word"
  shows "(a AND b) << c = (a << c) AND (b << c)"
  apply(rule word_eqI)
  apply(simp add: word_ao_nth nth_shiftl, safe)
done

lemma shiftr_over_and_dist:
  fixes a::"'a::len word"
  shows "a AND b >> c = (a >> c) AND (b >> c)"
  apply(rule word_eqI)
  apply(simp add:nth_shiftr word_ao_nth)
done

lemma sshiftr_over_and_dist:
  fixes a::"'a::len word"
  shows "a AND b >>> c = (a >>> c) AND (b >>> c)"
  apply(rule word_eqI)
  apply(simp add:nth_sshiftr word_ao_nth word_size)
done

lemma shiftl_over_or_dist:
  fixes a::"'a::len word"
  shows "a OR b << c = (a << c) OR (b << c)"
  apply(rule word_eqI)
  apply(simp add:nth_shiftl word_ao_nth, safe)
done

lemma shiftr_over_or_dist:
  fixes a::"'a::len word"
  shows "a OR b >> c = (a >> c) OR (b >> c)"
  apply(rule word_eqI)
  apply(simp add:nth_shiftr word_ao_nth)
done

lemma sshiftr_over_or_dist:
  fixes a::"'a::len word"
  shows "a OR b >>> c = (a >>> c) OR (b >>> c)"
  apply(rule word_eqI)
  apply(simp add:nth_sshiftr word_ao_nth word_size)
done

lemmas shift_over_ao_dists =
  shiftl_over_or_dist shiftr_over_or_dist
  sshiftr_over_or_dist shiftl_over_and_dist
  shiftr_over_and_dist sshiftr_over_and_dist

lemma shiftl_shiftl:
  fixes a::"'a::len word"
  shows "a << b << c = a << (b + c)"
 apply(rule word_eqI)
 apply(auto simp:word_size nth_shiftl
                 add.commute add.left_commute)
done

lemma shiftr_shiftr:
  fixes a::"'a::len word"
  shows "a >> b >> c = a >> (b + c)"
 apply(rule word_eqI)
 apply(simp add:word_size nth_shiftr
                add.left_commute add.commute)
done

lemma shiftl_shiftr1:
  fixes a::"'a::len word"
  shows "c \<le> b \<Longrightarrow>
    a << b >> c =
    a AND (mask (size a - b)) << (b - c)"
 apply(rule word_eqI)
 apply(auto simp:nth_shiftr nth_shiftl
                 word_size word_ao_nth)
done

lemma shiftl_shiftr2:
  fixes a::"'a::len word"
  shows "b < c \<Longrightarrow>
    a << b >> c =
    (a >> (c - b)) AND (mask (size a - c))"
 apply(rule word_eqI)
 apply(auto simp:nth_shiftr nth_shiftl
                 word_size word_ao_nth)
done

lemma shiftr_shiftl1:
  fixes a::"'a::len word"
  shows "c \<le> b \<Longrightarrow>
         a >> b << c = (a >> (b - c)) AND
                       (NOT mask c)"
 apply(rule word_eqI)
 apply(auto simp:nth_shiftr nth_shiftl
                 word_size word_ops_nth_size)
done

lemma shiftr_shiftl2:
  fixes a::"'a::len word"
  shows "b < c \<Longrightarrow>
         a >> b << c = (a << (c - b)) AND
                       (NOT mask c)"
 apply(rule word_eqI)
 apply(auto simp:nth_shiftr nth_shiftl
                 word_size word_ops_nth_size)
done

lemmas multi_shift_simps =
  shiftl_shiftl shiftr_shiftr
  shiftl_shiftr1 shiftl_shiftr2
  shiftr_shiftl1 shiftr_shiftl2

lemma word_and_max_word:
  fixes a::"'a::len word"
  shows "x = max_word \<Longrightarrow> a AND x = a"
 apply(simp)
done

lemma word_and_1:
  fixes x::"'a::len word"
  shows "(x AND 1) = (if x!!0 then 1 else 0)"
 apply(rule word_eqI)
 apply(simp add:word_ao_nth)
 apply(rule conjI)
  apply(auto)[1]
 apply clarsimp
 apply (case_tac n)
  apply simp
 apply simp
 done

lemma word_and_1_bl:
  fixes x::"'a::len word"
  shows "(x AND 1) = of_bl [x !! 0]"
  by (simp add: word_and_1)

lemma word_1_and_bl:
  fixes x::"'a::len word"
  shows "(1 AND x) = of_bl [x !! 0]"
  by (subst word_bw_comms)
     (simp add: word_and_1)

(* can stay here: *)
(* some Haskellish syntax *)

notation (input)
  test_bit ("testBit")

definition
  w2byte :: "'a :: len word \<Rightarrow> 8 word" where
  "w2byte \<equiv> ucast"

lemma scast_scast_id':
  fixes x :: "('a::len) word"
  assumes is_up: "is_up (scast :: 'a word \<Rightarrow> ('b::len) word)"
  shows "scast (scast x :: 'b word) = (x :: 'a word)"
  using assms by (rule scast_up_scast_id)

lemma scast_scast_id [simp]:
  "scast (scast x :: ('a::len) signed word) = (x :: 'a word)"
  "scast (scast y :: ('a::len) word) = (y :: 'a signed word)"
  by (auto simp: is_up scast_scast_id')

lemma scast_ucast_id [simp]:
    "scast (ucast (x :: 'a::len word) :: 'a signed word) = x"
  by (metis down_cast_same is_down len_signed order_refl scast_scast_id(1))

lemma ucast_scast_id [simp]:
    "ucast (scast (x :: 'a::len signed word) :: 'a word) = x"
  by (metis scast_scast_id(2) scast_ucast_id)

lemma scast_of_nat [simp]:
    "scast (of_nat x :: 'a::len signed word) = (of_nat x :: 'a word)"
  by (metis (hide_lams, no_types) len_signed scast_def uint_sint
         word_of_nat word_ubin.Abs_norm word_ubin.eq_norm)

lemma ucast_of_nat:
  "is_down (ucast :: ('a :: len) word \<Rightarrow> ('b :: len) word)
    \<Longrightarrow> ucast (of_nat n :: 'a word) = (of_nat n :: 'b word)"
  apply (rule sym)
  apply (subst word_unat.inverse_norm)
  apply (simp add: ucast_def word_of_int[symmetric]
                   of_nat_nat[symmetric] unat_def[symmetric])
  apply (simp add: unat_of_nat)
  apply (rule nat_int.Rep_eqD)
  apply (simp only: zmod_int)
  apply (rule mod_mod_cancel)
  apply (subst zdvd_int[symmetric])
  apply (rule le_imp_power_dvd)
  apply (simp add: is_down_def target_size_def source_size_def word_size)
  done

lemma word32_sint_1[simp]:
 "sint (1::word32) = 1"
  by (simp add: sint_word_ariths)

lemma sint_1 [simp]:
  "sint (1::'a::len word) = (if len_of TYPE('a) = 1 then -1 else 1)"
  apply (case_tac "len_of TYPE('a) \<le> 1")
   apply (metis diff_is_0_eq sbintrunc_0_numeral(1) sint_n1 word_1_wi
           word_m1_wi word_msb_1 word_msb_n1 word_sbin.Abs_norm)
  apply (metis bin_nth_1 diff_is_0_eq neq0_conv sbintrunc_minus_simps(4)
            sint_word_ariths(8) uint_1 word_msb_1 word_msb_nth)
  done

lemma scast_1':
  "(scast (1::'a::len word) :: 'b::len word) =
   (word_of_int (sbintrunc (len_of TYPE('a::len) - Suc 0) (1::int)))"
  by (metis One_nat_def scast_def sint_word_ariths(8))

lemma scast_1 [simp]:
  "(scast (1::'a::len word) :: 'b::len word) =
      (if len_of TYPE('a) = 1 then -1 else 1)"
  apply (clarsimp simp: scast_1')
  apply (metis Suc_pred len_gt_0 nat.exhaust sbintrunc_Suc_numeral(1)
           uint_1 word_uint.Rep_inverse')
  done

lemma scast_eq_scast_id [simp]:
    "((scast (a :: 'a::len signed word) :: 'a word) = scast b) = (a = b)"
  by (metis ucast_scast_id)

lemma ucast_eq_ucast_id [simp]:
    "((ucast (a :: 'a::len word) :: 'a signed word) = ucast b) = (a = b)"
  by (metis scast_ucast_id)

lemma scast_ucast_norm [simp]:
  "(ucast (a :: 'a::len word) = (b :: 'a signed word)) = (a = scast b)"
  "((b :: 'a signed word) = ucast (a :: 'a::len word)) = (a = scast b)"
  by (metis scast_ucast_id ucast_scast_id)+

lemma of_bl_drop:
  "of_bl (drop n xs) = (of_bl xs && mask (length xs - n))"
  apply (clarsimp simp: bang_eq test_bit_of_bl rev_nth
                  cong: rev_conj_cong)
  apply (safe, simp_all add: word_size to_bl_nth)
  done

lemma of_int_uint [simp]:
    "of_int (uint x) = x"
  by (metis word_of_int word_uint.Rep_inverse')

lemma shiftr_mask2:
  "n \<le> len_of TYPE('a) \<Longrightarrow> (mask n >> m :: ('a :: len) word) = mask (n - m)"
  apply (rule word_eqI)
  apply (simp add: nth_shiftr word_size)
  apply arith
  done

corollary word_plus_and_or_coroll:
  "x && y = 0 \<Longrightarrow> x + y = x || y"
  using word_plus_and_or[where x=x and y=y]
  by simp

corollary word_plus_and_or_coroll2:
  "(x && w) + (x && ~~ w) = x"
  apply (subst word_plus_and_or_coroll)
   apply (rule word_eqI, simp add: word_size word_ops_nth_size)
  apply (rule word_eqI, simp add: word_size word_ops_nth_size)
  apply blast
  done

(* FIXME: The two lemmas below are not exactly word-related but they
     correspond to the lemmas less_le_mult' and less_le_mult from the theory
     isabelle/src/HOL/Word/Num_Lemmas.
 *)
lemma less_le_mult_nat':
  "w * c < b * c ==> 0 \<le> c ==> Suc w * c \<le> b * (c::nat)"
  apply (rule mult_right_mono)
   apply (rule Suc_leI)
   apply (erule (1) mult_right_less_imp_less)
  apply assumption
  done

lemmas less_le_mult_nat = less_le_mult_nat'[simplified distrib_right, simplified]

(* FIXME: these should be moved to Word and declared [simp]
   but that will probably break everything. *)
lemmas extra_sle_sless_unfolds
    = word_sle_def[where a=0 and b=1]
    word_sle_def[where a=0 and b="numeral n"]
    word_sle_def[where a=1 and b=0]
    word_sle_def[where a=1 and b="numeral n"]
    word_sle_def[where a="numeral n" and b=0]
    word_sle_def[where a="numeral n" and b=1]
    word_sless_alt[where a=0 and b=1]
    word_sless_alt[where a=0 and b="numeral n"]
    word_sless_alt[where a=1 and b=0]
    word_sless_alt[where a=1 and b="numeral n"]
    word_sless_alt[where a="numeral n" and b=0]
    word_sless_alt[where a="numeral n" and b=1]
  for n

(*
 * Signed division: when the result of a division is negative,
 * we will round towards zero instead of towards minus infinity.
 *)
class signed_div =
  fixes sdiv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "sdiv" 70)
  fixes smod :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "smod" 70)

instantiation int :: signed_div
begin
definition "(a :: int) sdiv b \<equiv> sgn (a * b) * (abs a div abs b)"
definition "(a :: int) smod b \<equiv> a - (a sdiv b) * b"
instance ..
end

instantiation word :: (len) signed_div
begin
definition "(a :: ('a::len) word) sdiv b = word_of_int (sint a sdiv sint b)"
definition "(a :: ('a::len) word) smod b = word_of_int (sint a smod sint b)"
instance ..
end

(* Tests *)
lemma
  "( 4 :: word32) sdiv  4 =  1"
  "(-4 :: word32) sdiv  4 = -1"
  "(-3 :: word32) sdiv  4 =  0"
  "( 3 :: word32) sdiv -4 =  0"
  "(-3 :: word32) sdiv -4 =  0"
  "(-5 :: word32) sdiv -4 =  1"
  "( 5 :: word32) sdiv -4 = -1"
  by (simp_all add: sdiv_word_def sdiv_int_def)

lemma
  "( 4 :: word32) smod  4 =   0"
  "( 3 :: word32) smod  4 =   3"
  "(-3 :: word32) smod  4 =  -3"
  "( 3 :: word32) smod -4 =   3"
  "(-3 :: word32) smod -4 =  -3"
  "(-5 :: word32) smod -4 =  -1"
  "( 5 :: word32) smod -4 =   1"
  by (simp_all add: smod_word_def smod_int_def sdiv_int_def)

end