(* Authors: Jeremy Avigad and Amine Chaieb *)

section {* Generic transfer machinery;  specific transfer from nats to ints and back. *}

theory Nat_Transfer
imports Int
begin

subsection {* Generic transfer machinery *}

definition transfer_morphism:: "('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> bool"
  where "transfer_morphism f A \<longleftrightarrow> True"

lemma transfer_morphismI[intro]: "transfer_morphism f A"
  by (simp add: transfer_morphism_def)

ML_file "Tools/legacy_transfer.ML"

subsection {* Set up transfer from nat to int *}

text {* set up transfer direction *}

lemma transfer_morphism_nat_int: "transfer_morphism nat (op <= (0::int))" ..

declare transfer_morphism_nat_int [transfer add
  mode: manual
  return: nat_0_le
  labels: nat_int
]

text {* basic functions and relations *}

lemma transfer_nat_int_numerals [transfer key: transfer_morphism_nat_int]:
    "(0::nat) = nat 0"
    "(1::nat) = nat 1"
    "(2::nat) = nat 2"
    "(3::nat) = nat 3"
  by auto

definition
  tsub :: "int \<Rightarrow> int \<Rightarrow> int"
where
  "tsub x y = (if x >= y then x - y else 0)"

lemma tsub_eq: "x >= y \<Longrightarrow> tsub x y = x - y"
  by (simp add: tsub_def)

lemma transfer_nat_int_functions [transfer key: transfer_morphism_nat_int]:
    "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> (nat x) + (nat y) = nat (x + y)"
    "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> (nat x) * (nat y) = nat (x * y)"
    "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> (nat x) - (nat y) = nat (tsub x y)"
    "(x::int) >= 0 \<Longrightarrow> (nat x)^n = nat (x^n)"
  by (auto simp add: eq_nat_nat_iff nat_mult_distrib
      nat_power_eq tsub_def)

lemma transfer_nat_int_function_closures [transfer key: transfer_morphism_nat_int]:
    "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> x + y >= 0"
    "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> x * y >= 0"
    "(x::int) >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow> tsub x y >= 0"
    "(x::int) >= 0 \<Longrightarrow> x^n >= 0"
    "(0::int) >= 0"
    "(1::int) >= 0"
    "(2::int) >= 0"
    "(3::int) >= 0"
    "int z >= 0"
  by (auto simp add: zero_le_mult_iff tsub_def)

lemma transfer_nat_int_relations [transfer key: transfer_morphism_nat_int]:
    "x >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow>
      (nat (x::int) = nat y) = (x = y)"
    "x >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow>
      (nat (x::int) < nat y) = (x < y)"
    "x >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow>
      (nat (x::int) <= nat y) = (x <= y)"
    "x >= 0 \<Longrightarrow> y >= 0 \<Longrightarrow>
      (nat (x::int) dvd nat y) = (x dvd y)"
  by (auto simp add: zdvd_int)

text {* first-order quantifiers *}

lemma all_nat: "(\<forall>x. P x) \<longleftrightarrow> (\<forall>x\<ge>0. P (nat x))"
  by (simp split add: split_nat)

lemma ex_nat: "(\<exists>x. P x) \<longleftrightarrow> (\<exists>x. 0 \<le> x \<and> P (nat x))"
proof
  assume "\<exists>x. P x"
  then obtain x where "P x" ..
  then have "int x \<ge> 0 \<and> P (nat (int x))" by simp
  then show "\<exists>x\<ge>0. P (nat x)" ..
next
  assume "\<exists>x\<ge>0. P (nat x)"
  then show "\<exists>x. P x" by auto
qed

lemma transfer_nat_int_quantifiers [transfer key: transfer_morphism_nat_int]:
    "(ALL (x::nat). P x) = (ALL (x::int). x >= 0 \<longrightarrow> P (nat x))"
    "(EX (x::nat). P x) = (EX (x::int). x >= 0 & P (nat x))"
  by (rule all_nat, rule ex_nat)

(* should we restrict these? *)
lemma all_cong: "(\<And>x. Q x \<Longrightarrow> P x = P' x) \<Longrightarrow>
    (ALL x. Q x \<longrightarrow> P x) = (ALL x. Q x \<longrightarrow> P' x)"
  by auto

lemma ex_cong: "(\<And>x. Q x \<Longrightarrow> P x = P' x) \<Longrightarrow>
    (EX x. Q x \<and> P x) = (EX x. Q x \<and> P' x)"
  by auto

declare transfer_morphism_nat_int [transfer add
  cong: all_cong ex_cong]

text {* if *}

lemma nat_if_cong [transfer key: transfer_morphism_nat_int]:
  "(if P then (nat x) else (nat y)) = nat (if P then x else y)"
  by auto

text {* operations with sets *}

definition
  nat_set :: "int set \<Rightarrow> bool"
where
  "nat_set S = (ALL x:S. x >= 0)"

lemma transfer_nat_int_set_functions:
    "card A = card (int ` A)"
    "{} = nat ` ({}::int set)"
    "A Un B = nat ` (int ` A Un int ` B)"
    "A Int B = nat ` (int ` A Int int ` B)"
    "{x. P x} = nat ` {x. x >= 0 & P(nat x)}"
  apply (rule card_image [symmetric])
  apply (auto simp add: inj_on_def image_def)
  apply (rule_tac x = "int x" in bexI)
  apply auto
  apply (rule_tac x = "int x" in bexI)
  apply auto
  apply (rule_tac x = "int x" in bexI)
  apply auto
  apply (rule_tac x = "int x" in exI)
  apply auto
done

lemma transfer_nat_int_set_function_closures:
    "nat_set {}"
    "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> nat_set (A Un B)"
    "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> nat_set (A Int B)"
    "nat_set {x. x >= 0 & P x}"
    "nat_set (int ` C)"
    "nat_set A \<Longrightarrow> x : A \<Longrightarrow> x >= 0" (* does it hurt to turn this on? *)
  unfolding nat_set_def apply auto
done

lemma transfer_nat_int_set_relations:
    "(finite A) = (finite (int ` A))"
    "(x : A) = (int x : int ` A)"
    "(A = B) = (int ` A = int ` B)"
    "(A < B) = (int ` A < int ` B)"
    "(A <= B) = (int ` A <= int ` B)"
  apply (rule iffI)
  apply (erule finite_imageI)
  apply (erule finite_imageD)
  apply (auto simp add: image_def set_eq_iff inj_on_def)
  apply (drule_tac x = "int x" in spec, auto)
  apply (drule_tac x = "int x" in spec, auto)
  apply (drule_tac x = "int x" in spec, auto)
done

lemma transfer_nat_int_set_return_embed: "nat_set A \<Longrightarrow>
    (int ` nat ` A = A)"
  by (auto simp add: nat_set_def image_def)

lemma transfer_nat_int_set_cong: "(!!x. x >= 0 \<Longrightarrow> P x = P' x) \<Longrightarrow>
    {(x::int). x >= 0 & P x} = {x. x >= 0 & P' x}"
  by auto

declare transfer_morphism_nat_int [transfer add
  return: transfer_nat_int_set_functions
    transfer_nat_int_set_function_closures
    transfer_nat_int_set_relations
    transfer_nat_int_set_return_embed
  cong: transfer_nat_int_set_cong
]

text {* setsum and setprod *}

(* this handles the case where the *domain* of f is nat *)
lemma transfer_nat_int_sum_prod:
    "setsum f A = setsum (%x. f (nat x)) (int ` A)"
    "setprod f A = setprod (%x. f (nat x)) (int ` A)"
  apply (subst setsum.reindex)
  apply (unfold inj_on_def, auto)
  apply (subst setprod.reindex)
  apply (unfold inj_on_def o_def, auto)
done

(* this handles the case where the *range* of f is nat *)
lemma transfer_nat_int_sum_prod2:
    "setsum f A = nat(setsum (%x. int (f x)) A)"
    "setprod f A = nat(setprod (%x. int (f x)) A)"
  apply (subst int_setsum [symmetric])
  apply auto
  apply (subst int_setprod [symmetric])
  apply auto
done

lemma transfer_nat_int_sum_prod_closure:
    "nat_set A \<Longrightarrow> (!!x. x >= 0 \<Longrightarrow> f x >= (0::int)) \<Longrightarrow> setsum f A >= 0"
    "nat_set A \<Longrightarrow> (!!x. x >= 0 \<Longrightarrow> f x >= (0::int)) \<Longrightarrow> setprod f A >= 0"
  unfolding nat_set_def
  apply (rule setsum_nonneg)
  apply auto
  apply (rule setprod_nonneg)
  apply auto
done

(* this version doesn't work, even with nat_set A \<Longrightarrow>
      x : A \<Longrightarrow> x >= 0 turned on. Why not?

  also: what does =simp=> do?

lemma transfer_nat_int_sum_prod_closure:
    "(!!x. x : A  ==> f x >= (0::int)) \<Longrightarrow> setsum f A >= 0"
    "(!!x. x : A  ==> f x >= (0::int)) \<Longrightarrow> setprod f A >= 0"
  unfolding nat_set_def simp_implies_def
  apply (rule setsum_nonneg)
  apply auto
  apply (rule setprod_nonneg)
  apply auto
done
*)

(* Making A = B in this lemma doesn't work. Why not?
   Also, why aren't setsum.cong and setprod.cong enough,
   with the previously mentioned rule turned on? *)

lemma transfer_nat_int_sum_prod_cong:
    "A = B \<Longrightarrow> nat_set B \<Longrightarrow> (!!x. x >= 0 \<Longrightarrow> f x = g x) \<Longrightarrow>
      setsum f A = setsum g B"
    "A = B \<Longrightarrow> nat_set B \<Longrightarrow> (!!x. x >= 0 \<Longrightarrow> f x = g x) \<Longrightarrow>
      setprod f A = setprod g B"
  unfolding nat_set_def
  apply (subst setsum.cong, assumption)
  apply auto [2]
  apply (subst setprod.cong, assumption, auto)
done

declare transfer_morphism_nat_int [transfer add
  return: transfer_nat_int_sum_prod transfer_nat_int_sum_prod2
    transfer_nat_int_sum_prod_closure
  cong: transfer_nat_int_sum_prod_cong]

subsection {* Set up transfer from int to nat *}

text {* set up transfer direction *}

lemma transfer_morphism_int_nat: "transfer_morphism int (\<lambda>n. True)" ..

declare transfer_morphism_int_nat [transfer add
  mode: manual
  return: nat_int
  labels: int_nat
]

text {* basic functions and relations *}

definition
  is_nat :: "int \<Rightarrow> bool"
where
  "is_nat x = (x >= 0)"

lemma transfer_int_nat_numerals:
    "0 = int 0"
    "1 = int 1"
    "2 = int 2"
    "3 = int 3"
  by auto

lemma transfer_int_nat_functions:
    "(int x) + (int y) = int (x + y)"
    "(int x) * (int y) = int (x * y)"
    "tsub (int x) (int y) = int (x - y)"
    "(int x)^n = int (x^n)"
  by (auto simp add: int_mult tsub_def int_power)

lemma transfer_int_nat_function_closures:
    "is_nat x \<Longrightarrow> is_nat y \<Longrightarrow> is_nat (x + y)"
    "is_nat x \<Longrightarrow> is_nat y \<Longrightarrow> is_nat (x * y)"
    "is_nat x \<Longrightarrow> is_nat y \<Longrightarrow> is_nat (tsub x y)"
    "is_nat x \<Longrightarrow> is_nat (x^n)"
    "is_nat 0"
    "is_nat 1"
    "is_nat 2"
    "is_nat 3"
    "is_nat (int z)"
  by (simp_all only: is_nat_def transfer_nat_int_function_closures)

lemma transfer_int_nat_relations:
    "(int x = int y) = (x = y)"
    "(int x < int y) = (x < y)"
    "(int x <= int y) = (x <= y)"
    "(int x dvd int y) = (x dvd y)"
  by (auto simp add: zdvd_int)

declare transfer_morphism_int_nat [transfer add return:
  transfer_int_nat_numerals
  transfer_int_nat_functions
  transfer_int_nat_function_closures
  transfer_int_nat_relations
]

text {* first-order quantifiers *}

lemma transfer_int_nat_quantifiers:
    "(ALL (x::int) >= 0. P x) = (ALL (x::nat). P (int x))"
    "(EX (x::int) >= 0. P x) = (EX (x::nat). P (int x))"
  apply (subst all_nat)
  apply auto [1]
  apply (subst ex_nat)
  apply auto
done

declare transfer_morphism_int_nat [transfer add
  return: transfer_int_nat_quantifiers]

text {* if *}

lemma int_if_cong: "(if P then (int x) else (int y)) =
    int (if P then x else y)"
  by auto

declare transfer_morphism_int_nat [transfer add return: int_if_cong]

text {* operations with sets *}

lemma transfer_int_nat_set_functions:
    "nat_set A \<Longrightarrow> card A = card (nat ` A)"
    "{} = int ` ({}::nat set)"
    "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> A Un B = int ` (nat ` A Un nat ` B)"
    "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> A Int B = int ` (nat ` A Int nat ` B)"
    "{x. x >= 0 & P x} = int ` {x. P(int x)}"
       (* need all variants of these! *)
  by (simp_all only: is_nat_def transfer_nat_int_set_functions
          transfer_nat_int_set_function_closures
          transfer_nat_int_set_return_embed nat_0_le
          cong: transfer_nat_int_set_cong)

lemma transfer_int_nat_set_function_closures:
    "nat_set {}"
    "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> nat_set (A Un B)"
    "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> nat_set (A Int B)"
    "nat_set {x. x >= 0 & P x}"
    "nat_set (int ` C)"
    "nat_set A \<Longrightarrow> x : A \<Longrightarrow> is_nat x"
  by (simp_all only: transfer_nat_int_set_function_closures is_nat_def)

lemma transfer_int_nat_set_relations:
    "nat_set A \<Longrightarrow> finite A = finite (nat ` A)"
    "is_nat x \<Longrightarrow> nat_set A \<Longrightarrow> (x : A) = (nat x : nat ` A)"
    "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> (A = B) = (nat ` A = nat ` B)"
    "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> (A < B) = (nat ` A < nat ` B)"
    "nat_set A \<Longrightarrow> nat_set B \<Longrightarrow> (A <= B) = (nat ` A <= nat ` B)"
  by (simp_all only: is_nat_def transfer_nat_int_set_relations
    transfer_nat_int_set_return_embed nat_0_le)

lemma transfer_int_nat_set_return_embed: "nat ` int ` A = A"
  by (simp only: transfer_nat_int_set_relations
    transfer_nat_int_set_function_closures
    transfer_nat_int_set_return_embed nat_0_le)

lemma transfer_int_nat_set_cong: "(!!x. P x = P' x) \<Longrightarrow>
    {(x::nat). P x} = {x. P' x}"
  by auto

declare transfer_morphism_int_nat [transfer add
  return: transfer_int_nat_set_functions
    transfer_int_nat_set_function_closures
    transfer_int_nat_set_relations
    transfer_int_nat_set_return_embed
  cong: transfer_int_nat_set_cong
]

text {* setsum and setprod *}

(* this handles the case where the *domain* of f is int *)
lemma transfer_int_nat_sum_prod:
    "nat_set A \<Longrightarrow> setsum f A = setsum (%x. f (int x)) (nat ` A)"
    "nat_set A \<Longrightarrow> setprod f A = setprod (%x. f (int x)) (nat ` A)"
  apply (subst setsum.reindex)
  apply (unfold inj_on_def nat_set_def, auto simp add: eq_nat_nat_iff)
  apply (subst setprod.reindex)
  apply (unfold inj_on_def nat_set_def o_def, auto simp add: eq_nat_nat_iff
            cong: setprod.cong)
done

(* this handles the case where the *range* of f is int *)
lemma transfer_int_nat_sum_prod2:
    "(!!x. x:A \<Longrightarrow> is_nat (f x)) \<Longrightarrow> setsum f A = int(setsum (%x. nat (f x)) A)"
    "(!!x. x:A \<Longrightarrow> is_nat (f x)) \<Longrightarrow>
      setprod f A = int(setprod (%x. nat (f x)) A)"
  unfolding is_nat_def
  apply (subst int_setsum, auto)
  apply (subst int_setprod, auto simp add: cong: setprod.cong)
done

declare transfer_morphism_int_nat [transfer add
  return: transfer_int_nat_sum_prod transfer_int_nat_sum_prod2
  cong: setsum.cong setprod.cong]

end


theory Simp_Lemmas
  imports  TLB

begin

(* lookup' Lemmas *)

lemma Incon_top [iff]: "e \<le> Incon"
  by (simp add: less_eq_lookup_type)

lemma Incon_leq [simp]: "(Incon \<le> e) = (e = Incon)"
  by (auto simp add: less_eq_lookup_type)

lemma Miss_bottom [iff]: "Miss \<le> e"
  by (simp add: less_eq_lookup_type)

lemma leq_Miss [simp]: "(e \<le> Miss) = (e = Miss)"
  by (auto simp add: less_eq_lookup_type)

lemma Hits_le [simp]:
  "(Hit e \<le> Hit e') = (e = e')"
  by (auto simp add: less_eq_lookup_type)

lemma tlb_mono_entry_set:
  "t \<subseteq> t' \<Longrightarrow> entry_set t v \<subseteq> entry_set t' v"
  by (simp add: entry_set_def) blast

abbreviation "lookup' t \<equiv> lookup (entry_set t)"

lemma tlb_mono:
  "t \<subseteq> t' \<Longrightarrow> lookup' t v \<le> lookup' t' v"
  by (drule tlb_mono_entry_set) (fastforce simp: lookup_def)

lemma lookup_in_tlb:
  "lookup' t v = Hit e \<Longrightarrow> e \<in> t"
  by (auto simp: lookup_def entry_set_def split: if_split_asm)

lemma lookup_incon_subset [simp]:
  "\<lbrakk> s \<subseteq> t ;  lookup' s v = Incon \<rbrakk> \<Longrightarrow>  lookup' t v = Incon"
  by (metis less_eq_lookup_type lookup_type.simps(3) tlb_mono)

lemma entry_set_insert:
  "\<lbrakk> entry_set t v = {}; v \<in> range_of e \<rbrakk> \<Longrightarrow>
               entry_set (insert e t) v = {e}"
  by (auto simp add: entry_set_def)

lemma lookup_miss_union:
  " lookup'  (t \<union> t') v = Miss  \<Longrightarrow>
      (lookup' t v = Miss \<and> lookup' t' v = Miss)"
  by (auto simp: lookup_def entry_set_def split: if_split_asm)

lemma lookup_hit_miss_or_hit' :
  " lookup' (t \<union> t') v = Hit e  \<Longrightarrow>
              lookup' t' v = Miss \<or> (lookup' t' v = Hit e)"
  apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm)
  by force+

lemma  lookup_hit_entry_range:
  "lookup' t v = Hit e \<Longrightarrow> v \<in> range_of e"
  apply (clarsimp simp: lookup_def  entry_set_def  split:if_split_asm)
  by force

lemma lookup_union_hit_miss_hit :
  "\<lbrakk>lookup' (t \<union> t') v = Hit e ; lookup' t' v \<noteq> Miss \<rbrakk> \<Longrightarrow> lookup' t' v = Hit e"
  apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm)
  by force+

lemma  lookup_not_hit_miss:
  "\<lbrakk>lookup' (t \<union> t') v = Hit e;   lookup' t v \<noteq> Hit e\<rbrakk> \<Longrightarrow> lookup' t v = Miss   "
  apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm)
   apply safe
  by force+

lemma lookup_union_hit_miss_hit' :
  "\<lbrakk>lookup' (t \<union> t') v = Hit e; lookup' t v \<noteq> Miss \<rbrakk> \<Longrightarrow> lookup' t v = Hit e"
  apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm)
   by force+

lemma  lookup_not_hit_false:
  "\<lbrakk>lookup' (t \<union> t') v = Hit e; lookup' t v \<noteq> Hit e; lookup' t' v \<noteq> Hit e\<rbrakk> \<Longrightarrow> False"
  apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm)
  apply safe by blast+

lemma lookup_not_hit_hit:
  "\<lbrakk>lookup' (t \<union> t') v = Hit e; lookup' t v \<noteq> Hit e\<rbrakk> \<Longrightarrow> lookup' t' v = Hit e"
  apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm , (safe ; force) , force)
  apply auto [1]
  apply (rule_tac x = e in exI)
  by (safe ; force)

lemma lookup_hit_union_cases':
  " lookup' (t \<union> t') v = Hit e  \<Longrightarrow>
      (lookup' t v  = Hit e \<and> lookup' t' v = Miss)  \<or>
      (lookup' t' v = Hit e \<and> lookup' t v  = Miss)  \<or>
      (lookup' t v  = Hit e \<and> lookup' t' v = Hit e)"
  apply (safe , clarsimp)
         apply (drule lookup_not_hit_hit; clarsimp)
        apply (drule lookup_not_hit_miss; clarsimp)
       apply (drule lookup_not_hit_false ; clarsimp)
      apply (drule lookup_not_hit_false ; clarsimp)
     apply (drule lookup_union_hit_miss_hit ; clarsimp)
    apply (drule lookup_not_hit_miss ; clarsimp)
   apply (drule lookup_union_hit_miss_hit ; clarsimp)
  by (drule lookup_hit_miss_or_hit' ; clarsimp)

lemma  union_incon_cases:
  "lookup' (t \<union> t') v = Incon \<Longrightarrow>
      (lookup' t v = Incon \<and> lookup' t' v = Incon)  \<or>
      ((\<exists>x\<in>t. lookup' t v = Hit x)  \<and> (\<exists>x\<in>t'. lookup' t' v = Hit x) \<and>  lookup' t v \<noteq>  lookup' t' v)  \<or>
      (lookup' t' v = Incon \<and> (\<exists>x\<in>t. lookup' t v = Hit x) ) \<or>
      ((\<exists>x\<in>t'. lookup' t' v = Hit x)  \<and> lookup' t v = Incon)\<or>
      (lookup' t v = Miss \<and> lookup' t' v = Incon)  \<or>
      (lookup' t v = Incon \<and> lookup' t' v = Miss) "
  apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm)
  apply auto
   by force+

lemma entry_set_hit_entry_range:
  "entry_set t v = {e} \<Longrightarrow> v \<in> range_of e"
  apply (clarsimp simp: entry_set_def split:if_split_asm)
   apply force
done

lemma addr_val_eqD [dest!]:
  "addr_val a = addr_val b \<Longrightarrow> a = b"
  apply (cases a, cases b)
  by simp

theorem entry_range_single_elementI:
  "\<lbrakk>x\<in> t ; v \<in> range_of x ; (\<forall>y\<in>t. y\<noteq>x \<longrightarrow> v \<notin> range_of y) \<rbrakk> \<Longrightarrow>
         {E \<in> t. v \<in> range_of E} = {x}"
   by force

lemma lookup_hit_mis_hit:
  "\<lbrakk>lookup' (t \<union> t') v = Hit e ; lookup' t' v = Miss \<rbrakk> \<Longrightarrow> lookup' t v = Hit e"
  apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm)
  apply auto
  by force

lemma   lookup_union_hit_hit_miss :
  "\<lbrakk>lookup' (t \<union> t') v = Hit e ;  \<forall>x\<in>t. lookup' t v \<noteq> Hit x\<rbrakk> \<Longrightarrow> lookup' t v = Miss"
 apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm)
  by force+

lemma lookup_hit_miss_or_hit :
  " lookup' (t \<union> t') v = Hit e \<and> e \<in> t  \<Longrightarrow>
              lookup' t' v = Miss \<or> (lookup' t' v = Hit e)"
  apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm)
  by force+

lemma not_miss_incon_hit:
  "lookup' t v \<noteq> Miss \<Longrightarrow> lookup' t v = Incon \<or> (\<exists>x\<in>t. lookup' t v = Hit x)"
 apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm)
  by auto

lemma  lookup_hit_union_cases:
  "(\<exists>x\<in>(t \<union> t'). lookup' (t \<union> t') va = Hit x)  \<Longrightarrow>
      ((\<exists>x\<in>t. lookup' t va = Hit x) \<and> lookup' t' va = Miss)       \<or>
      ((\<exists>x\<in>t'. lookup' t' va = Hit x)  \<and> lookup' t va = Miss)      \<or>
      ((\<exists>x\<in>t. \<exists>x'\<in>t'.  lookup' t va = Hit x  \<and> lookup' t' va = Hit x' \<and>  x = x')) "
  apply (safe ; clarsimp)
         apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm ,force , force, ((safe ; force) [1]))
        apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm , force, force)
       apply (drule_tac x = "x" in bspec , clarsimp)
       apply (drule_tac not_miss_incon_hit , erule disjE ; clarsimp )
       using lookup_hit_miss_or_hit apply force
      apply (frule lookup_union_hit_miss_hit , clarsimp)
      apply (drule_tac x = "x" in bspec ,clarsimp)
      apply (subgoal_tac "x \<in> t'" , clarsimp)
       apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm ; force)
      using lookup_in_tlb apply force
     apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm ;  (safe ; force))
    using lookup_union_hit_hit_miss apply blast
   apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm ; (safe ; force))
  apply (cases " lookup' t va = Miss" ; clarsimp)
  apply (frule_tac lookup_union_hit_miss_hit ; clarsimp)
  apply (frule_tac lookup_union_hit_miss_hit' ; clarsimp)
  apply (subgoal_tac "x\<in>t")
   apply (drule_tac x = "x" in bspec ; clarsimp)
  using lookup_in_tlb by force

lemma lookup_miss_union_equal:
  " lookup' t' v = Miss \<Longrightarrow> lookup' (t \<union> t') v = lookup' t v "
  apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm)
  apply safe
  by force+

lemma lookup_miss_union_miss_miss:
  "\<lbrakk>lookup' t v = Miss;  lookup' t' v = Miss\<rbrakk> \<Longrightarrow>
           lookup' (t \<union> t') v = Miss"
  apply (clarsimp simp: lookup_def entry_set_def  split: if_split_asm)
  apply safe
     by auto

lemma  lookup_incon_not_miss:
   "\<lbrakk> lookup' (t \<union> t') v = Incon ; lookup' t' v = Miss\<rbrakk> \<Longrightarrow> lookup' t v = Incon"
  apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm)
  apply safe
  by force+

lemma lookup_hit_diff_union_incon:
  "\<lbrakk>lookup' t v = Hit e ; lookup' t' v = Hit e' ; e \<noteq> e'\<rbrakk> \<Longrightarrow> lookup' (t \<union> t') v = Incon"
  apply (clarsimp simp: lookup_def entry_set_def   split: if_split_asm)
  apply safe
     apply force
    apply (metis (no_types, lifting) mem_Collect_eq singletonD)
   apply (metis (no_types, lifting) mem_Collect_eq singletonD)
  apply force
  done

lemma lookup_miss_union_hit_intro:
  "\<lbrakk>lookup' t v = Miss;  lookup' t' v = Hit e\<rbrakk> \<Longrightarrow>
           lookup' (t \<union> t') v = Hit e"
  apply (clarsimp simp: lookup_def entry_set_def   split: if_split_asm)
  apply safe
  by (auto, force)

lemma lookup_miss_union_hit_intro':
  "\<lbrakk> lookup' t v = Hit e ; lookup' t' v = Miss\<rbrakk> \<Longrightarrow>
           lookup' (t \<union> t') v = Hit e"
  apply (clarsimp simp: lookup_def entry_set_def   split: if_split_asm)
  apply safe
  apply auto
  by blast

lemma lookup_union_hit_hit:
  "\<lbrakk> lookup' t v = Hit e ; lookup' t' v = Hit e\<rbrakk> \<Longrightarrow>
           lookup' (t \<union> t') v = Hit e"
  apply (clarsimp simp: lookup_def entry_set_def   split: if_split_asm)
  apply safe
  apply auto
  by blast+

lemma
  "\<lbrakk> lookup' t v \<noteq> Incon; lookup' t v \<noteq> Miss\<rbrakk>
         \<Longrightarrow> \<exists>e\<in>t. lookup' t v = Hit e"
  apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm)
  by blast

lemma not_miss_incon_hit':
  "lookup' t v = Incon \<or> (\<exists>e\<in>t. lookup' t v = Hit e) \<Longrightarrow> lookup' t v \<noteq> Miss "
  by (clarsimp simp: lookup_def entry_set_def split: if_split_asm)

lemma lookup_incon_minus:
  "lookup' (t - t') v  = Incon  \<Longrightarrow> lookup' t v = Incon"
  apply (subgoal_tac "t - t' \<subseteq> t")
   apply (frule_tac v = v in tlb_mono)
   apply clarsimp
  by blast

lemma  lookup_hit_entry_range_asid_tags:
  "lookup' t v = Hit e \<Longrightarrow> v \<in> range_of e"
  apply (clarsimp simp: lookup_def  entry_set_def    split:if_split_asm)
  by force

lemma  lookup_hit_incon_minus:
  "\<lbrakk>lookup' (t - t') v = Hit e\<rbrakk>
                \<Longrightarrow> lookup' t v = Hit e \<or> lookup' t v = Incon"
  apply (clarsimp simp: lookup_def  entry_set_def    split:if_split_asm)
  by force

lemma  lookup_not_miss_varange:
  "lookup' (t - (\<Union>v\<in>vset. {e \<in> t. v \<in> range_of e})) v \<noteq> Miss \<Longrightarrow>
      v \<notin> vset"
  by (clarsimp simp: lookup_def entry_set_def   split:if_split_asm)

lemma  lookup_minus_union:
  "\<lbrakk>lookup' t' v = Miss; lookup'  t'' v = Miss \<rbrakk> \<Longrightarrow>
      lookup' (t - t' \<union> t'') v = lookup' t v"
  apply (clarsimp simp: lookup_def entry_set_def   the_elem_def image_iff split: lookup_type.splits if_split_asm cong: Collect_cong)
  apply safe
                   apply blast
                  apply blast
                 apply blast
                apply (clarsimp simp: the_elem_def) by blast+

lemma  lookup_minus_same:
  "\<lbrakk>lookup' t' v = Miss \<rbrakk> \<Longrightarrow> lookup' (t - t') v = lookup' t v"
  apply (clarsimp simp: lookup_def  entry_set_def    split: lookup_type.splits if_split_asm)
    by (auto; blast+)

lemma  lookup_minus_hit':
  "\<lbrakk>lookup' (t - t') v = Hit e ; lookup' t' v = Miss \<rbrakk> \<Longrightarrow> lookup' t v = Hit e"
  apply (clarsimp simp: lookup_def  entry_set_def    split:if_split_asm)
   by (auto; blast+)

lemma  lookup_not_miss_asidvarange:
  "lookup' (t - (\<Union>v\<in>vset. {e \<in> t. v \<in> range_of e})) v \<noteq> Miss \<Longrightarrow> v \<notin> vset"
  by (clarsimp simp: lookup_def entry_set_def   split:if_split_asm)

lemma  lookup_minus_union':
  "\<lbrakk>lookup' t' v = Miss \<rbrakk> \<Longrightarrow>
      lookup' (t - t' \<union> t'') v = lookup' (t \<union> t'') v"
  apply (case_tac "lookup' (t \<union> t'') v" ; clarsimp simp: lookup_def  entry_set_def    split:if_split_asm)
    apply auto
  by blast+

(* bit lemmas *)

lemma va_20_left [simp]:
  fixes va :: "32 word"
  shows "ucast (ucast (va >> 20) :: 12 word) << 20 \<le> va"
  by word_bitwise

lemma va_12_left [simp]:
  fixes va :: "32 word"
  shows "ucast (ucast (va >> 12) :: 20 word) << 12 \<le> va"
  by word_bitwise

lemma va_20_right [simp]:
  fixes va :: "32 word"
  shows "va \<le> (ucast (ucast (va >> 20) :: 12 word) << 20) + 0x000FFFFF"
  by word_bitwise

lemma va_12_right [simp]:
  fixes va :: "32 word"
  shows "va \<le> (ucast (ucast (va >> 12) :: 20 word) << 12) + 0x00000FFF"
  by word_bitwise

lemma va_offset_add:
  " (va::32 word) : {ucast (ucast ((x:: 32 word) >> 12):: 20 word) << 12  ..
    (ucast (ucast (x >> 12):: 20 word) << 12) + mask 12 } \<Longrightarrow>
      \<exists>a.  (0 \<le> a \<and> a \<le> mask 12) \<and>
  va = (ucast (ucast ((x:: 32 word) >> 12):: 20 word) << 12)  + a"
  apply (rule_tac x = "va - (ucast (ucast ((x:: 32 word) >> 12):: 20 word) << 12) " in exI)
  apply (clarsimp simp: mask_def)
  apply uint_arith
done

lemma shift_to_mask:
  "x AND NOT mask 12 = (ucast (ucast ((x::32 word) >> 12):: 20 word)::32 word) << 12"
  apply (rule word_eqI)
  apply (simp add : word_ops_nth_size word_size)
  apply (simp add : nth_shiftr nth_shiftl nth_ucast)
  apply auto
  done

lemma nth_bits_false:
  "\<lbrakk>(n::nat) < 20; (a::32 word) \<le> 0xFFF\<rbrakk> \<Longrightarrow> \<not>(a !! (n + 12))"
  apply word_bitwise
  apply clarsimp
  apply (case_tac "n = 0")
   apply clarsimp
  apply (case_tac "n = 1")
   apply clarsimp
  apply (case_tac "n = 2")
   apply clarsimp
  apply (case_tac "n = 3")
   apply clarsimp
  apply (case_tac "n = 4")
   apply clarsimp
  apply (case_tac "n = 5")
   apply clarsimp
  apply (case_tac "n = 6")
   apply clarsimp
  apply (case_tac "n = 7")
   apply clarsimp
  apply (case_tac "n = 8")
   apply clarsimp
  apply (case_tac "n = 9")
   apply clarsimp
  apply (case_tac "n = 10")
   apply clarsimp
  apply (case_tac "n = 11")
   apply clarsimp
  apply (case_tac "n = 12")
   apply clarsimp
  apply (case_tac "n = 13")
   apply clarsimp
  apply (case_tac "n = 14")
   apply clarsimp
  apply (case_tac "n = 15")
   apply clarsimp
  apply (case_tac "n = 16")
   apply clarsimp
  apply (case_tac "n = 17")
   apply clarsimp
  apply (case_tac "n = 18")
   apply clarsimp
  apply (case_tac "n = 19")
   apply clarsimp
  apply (thin_tac "\<not> a !! P" for P)+
  apply arith
done

lemma nth_bits_offset_equal: "\<lbrakk>n < 20 ; (a::32 word) \<le> 0x00000FFF \<rbrakk> \<Longrightarrow>
        (((x::32 word) && 0xFFFFF000) || a) !!  (n + 12) = x !! (n + 12)"
  apply clarsimp
  apply (rule iffI)
   apply (erule disjE)
    apply clarsimp
   apply (clarsimp simp: nth_bits_false)
  apply clarsimp
  apply (simp only: test_bit_int_def [symmetric])
  apply (case_tac "n = 0")
   apply clarsimp
  apply (case_tac "n = 1")
   apply clarsimp
  apply (case_tac "n = 2")
   apply clarsimp
  apply (case_tac "n = 3")
   apply clarsimp
  apply (case_tac "n = 4")
   apply clarsimp
  apply (case_tac "n = 5")
   apply clarsimp
  apply (case_tac "n = 6")
   apply clarsimp
  apply (case_tac "n = 7")
   apply clarsimp
  apply (case_tac "n = 8")
   apply clarsimp
  apply (case_tac "n = 9")
   apply clarsimp
  apply (case_tac "n = 10")
   apply clarsimp
  apply (case_tac "n = 11")
   apply clarsimp
  apply (case_tac "n = 12")
   apply clarsimp
  apply (case_tac "n = 13")
   apply clarsimp
  apply (case_tac "n = 14")
   apply clarsimp
  apply (case_tac "n = 15")
   apply clarsimp
  apply (case_tac "n = 16")
   apply clarsimp
  apply (case_tac "n = 17")
   apply clarsimp
  apply (case_tac "n = 18")
   apply clarsimp
  apply (case_tac "n = 19")
   apply clarsimp
  by presburger

lemma add_to_or:
  "(a::32 word) \<le> 0xFFF \<Longrightarrow>
     ((x::32 word) && 0xFFFFF000) + a =  (x && 0xFFFFF000) || a"
  apply word_bitwise
  apply clarsimp
  using xor3_simps carry_simps apply auto
 done

lemma va_offset_higher_bits:
   " \<lbrakk>ucast (ucast ((x:: 32 word) >> 12):: 20 word) << 12 \<le> va ;
      va \<le> (ucast (ucast (x >> 12):: 20 word) << 12) + 0x00000FFF \<rbrakk> \<Longrightarrow>
        (ucast (x >> 12)::20 word) = (ucast ((va:: 32 word) >> 12)::20 word)"
  apply (subgoal_tac "(va::32 word) : {ucast (ucast ((x:: 32 word) >> 12):: 20 word) << 12  ..
   (ucast (ucast (x >> 12):: 20 word) << 12) + mask 12 }")
   prefer 2
   apply (clarsimp simp: mask_def)
  apply (frule va_offset_add)
  apply simp
  apply (erule exE)
  apply (erule conjE)
  apply (simp add: mask_def)
  apply (subgoal_tac "(ucast ((((ucast (ucast ((x:: 32 word) >> 12):: 20 word) << 12)::32 word)  + a) >> 12):: 20 word) =
                       (ucast (((ucast (ucast ((x:: 32 word) >> 12):: 20 word) << 12)::32 word)   >> 12):: 20 word) ")
   apply clarsimp
   apply (word_bitwise) [1]
  apply (subgoal_tac "ucast ((ucast (ucast ((x::32 word) >> 12):: 20 word)::32 word) << 12 >> 12) =
                      (ucast (x >> 12) :: 20 word)")
   prefer 2
   apply (word_bitwise) [1]
  apply simp
  apply (clarsimp simp: shift_to_mask [symmetric])
  apply (rule word_eqI)
  apply (simp only: nth_ucast)
  apply clarsimp
  apply (subgoal_tac "n < 20")
   prefer 2
   apply word_bitwise [1]
  apply clarsimp
  apply (clarsimp simp: nth_shiftr)
  apply (clarsimp simp: mask_def)
  apply (frule_tac a = a in nth_bits_offset_equal) apply clarsimp
  apply (drule_tac x= x in add_to_or)
  apply (simp only: )
 done

lemma n_bit_shift:
  "\<lbrakk> \<forall>n::nat. n \<in> {12 .. 31} \<longrightarrow>(a::32 word) !! n = (b::32 word) !! n  \<rbrakk>  \<Longrightarrow> a >> 12 = b >> 12"
  apply word_bitwise
  by auto
 lemma nth_bits_offset: "\<lbrakk> n \<in> {12..31} ; (a::32 word) \<le> 0x00000FFF \<rbrakk> \<Longrightarrow>
        (x::32 word) !! n = (x && 0xFFFFF000 || a) !! n"
  apply (rule iffI)
   apply (case_tac "n = 12")
    apply clarsimp
   apply (case_tac "n = 13")
    apply clarsimp
   apply (case_tac "n = 14")
    apply clarsimp
   apply (case_tac "n = 15")
    apply clarsimp
   apply (case_tac "n = 16")
    apply clarsimp
   apply (case_tac "n = 17")
    apply clarsimp
   apply (case_tac "n = 18")
    apply clarsimp
   apply (case_tac "n = 19")
    apply clarsimp
   apply (case_tac "n = 20")
    apply clarsimp
   apply (case_tac "n = 21")
    apply clarsimp
   apply (case_tac "n = 22")
    apply clarsimp
   apply (case_tac "n = 23")
    apply clarsimp
   apply (case_tac "n = 24")
    apply clarsimp
   apply (case_tac "n = 25")
    apply clarsimp
   apply (case_tac "n = 26")
    apply clarsimp
   apply (case_tac "n = 27")
    apply clarsimp
   apply (case_tac "n = 28")
    apply clarsimp
   apply (case_tac "n = 29")
    apply clarsimp
   apply (case_tac "n = 30")
    apply clarsimp
   apply (case_tac "n = 31")
    apply clarsimp
   prefer 2
   apply (case_tac "n = 12")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 13")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 14")
    apply word_bitwise [1]  apply clarsimp
   apply (case_tac "n = 15")
    apply word_bitwise [1]  apply clarsimp
   apply (case_tac "n = 16")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 17")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 18")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 19")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 20")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 21")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 22")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 23")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 24")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 25")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 26")
    apply word_bitwise [1]  apply clarsimp
   apply (case_tac "n = 27")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 28")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 29")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 30")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 31")
    apply word_bitwise [1] apply clarsimp
   apply clarsimp
   apply arith
  apply clarsimp
  apply arith
done

lemma offset_mask_eq:
 "\<lbrakk>ucast (ucast ((x:: 32 word) >> 12):: 20 word) << 12 \<le> va ;
      va \<le> (ucast (ucast (x >> 12):: 20 word) << 12) + 0x00000FFF\<rbrakk>
          \<Longrightarrow> (( x >> 12) && mask 8 << 2) =  ((va >> 12) && mask 8 << 2)"
  apply (subgoal_tac "(va::32 word) : {ucast (ucast ((x:: 32 word) >> 12):: 20 word) << 12  ..
                      (ucast (ucast (x >> 12):: 20 word) << 12) + mask 12 }")
   prefer 2
   apply (clarsimp simp: mask_def)
  apply (frule va_offset_add)
  apply simp
  apply (erule exE)
  apply (erule conjE)
  apply (simp add: mask_def)
  apply (rule_tac f = "(\<lambda>x. x && 0xFF << 2)" in  arg_cong)
  apply (clarsimp simp: shift_to_mask [symmetric])
  apply (simp add: mask_def)
  apply (rule n_bit_shift)
  apply (rule allI)
  apply (rule impI)
  apply (frule_tac x= x in add_to_or)
  apply (frule_tac x= x in nth_bits_offset)
   apply (simp only:)+
done

lemma n_bit_shift_1:
  "\<lbrakk> \<forall>n::nat. n \<in> {12 .. 31} \<longrightarrow>(a::32 word) !! n = (b::32 word) !! n  \<rbrakk>  \<Longrightarrow>  a >> 20 = b >> 20"
  apply word_bitwise
  by auto

lemma offset_mask_eq_1:
  "\<lbrakk>ucast (ucast ((x:: 32 word) >> 12):: 20 word) << 12 \<le> va ;
      va \<le> (ucast (ucast (x >> 12):: 20 word) << 12) + 0x00000FFF\<rbrakk>
          \<Longrightarrow>((x >> 20) && mask 12 << 2) =  ((va >> 20) && mask 12 << 2)"
  apply (subgoal_tac "(va::32 word) : {ucast (ucast ((x:: 32 word) >> 12):: 20 word) << 12  ..
   (ucast (ucast (x >> 12):: 20 word) << 12) + mask 12 }")
   prefer 2
   apply (clarsimp simp: mask_def)
  apply (frule va_offset_add)
  apply simp
  apply (erule exE)
  apply (erule conjE)
  apply (simp add: mask_def)
  apply (rule_tac f = "(\<lambda>x. x && 0xFFF << 2)" in  arg_cong)
  apply (clarsimp simp: shift_to_mask [symmetric])
  apply (simp add: mask_def)
  apply (rule n_bit_shift_1)
  apply (rule allI)
  apply (rule impI)
  apply (frule_tac x= x in add_to_or)
  apply (frule_tac x= x in nth_bits_offset)
   apply (simp only:)+
  done

lemma va_offset_add_1:
  " (va::32 word) : {ucast (ucast ((x:: 32 word) >> 20):: 12 word) << 20  ..
    (ucast (ucast (x >> 20):: 12 word) << 20) + mask 20 } \<Longrightarrow>
      \<exists>a.  (0 \<le> a \<and> a \<le> mask 20) \<and>
      va = (ucast (ucast ((x:: 32 word) >> 20):: 12 word) << 20)  + a"
  apply (rule_tac x = "va - (ucast (ucast ((x:: 32 word) >> 20):: 12 word) << 20) " in exI)
  apply (clarsimp simp: mask_def)
  apply uint_arith
done

lemma shift_to_mask_1:
  "x AND NOT mask 20 = (ucast (ucast ((x::32 word) >> 20):: 12 word)::32 word) << 20"
  apply (rule word_eqI)
  apply (simp add : word_ops_nth_size word_size)
  apply (simp add : nth_shiftr nth_shiftl nth_ucast)
  apply auto
done

lemma nth_bits_false_1:
  "\<lbrakk>(n::nat) < 12; (a::32 word) \<le> 0xFFFFF\<rbrakk> \<Longrightarrow> \<not>(a !! (n + 20))"
  apply word_bitwise
  apply clarsimp
  apply (case_tac "n = 0")
   apply clarsimp
  apply (case_tac "n = 1")
   apply clarsimp
  apply (case_tac "n = 2")
   apply clarsimp
  apply (case_tac "n = 3")
   apply clarsimp
  apply (case_tac "n = 4")
   apply clarsimp
  apply (case_tac "n = 5")
   apply clarsimp
  apply (case_tac "n = 6")
   apply clarsimp
  apply (case_tac "n = 7")
   apply clarsimp
  apply (case_tac "n = 8")
   apply clarsimp
  apply (case_tac "n = 9")
   apply clarsimp
  apply (case_tac "n = 10")
   apply clarsimp
  apply (case_tac "n = 11")
   apply clarsimp
  apply (thin_tac "\<not> a !! P" for P)+
  apply arith
  done

lemma nth_bits_offset_equal_1: "\<lbrakk>n < 12 ; (a::32 word) \<le> 0x000FFFFF \<rbrakk> \<Longrightarrow>
        (((x::32 word) && 0xFFF00000) || a) !!  (n + 20) = x !! (n + 20)"
  apply clarsimp
  apply (rule iffI)
   apply (erule disjE)
    apply clarsimp
   apply (clarsimp simp: nth_bits_false_1)
  apply clarsimp
  apply (simp only: test_bit_int_def [symmetric])
  apply (case_tac "n = 0")
   apply clarsimp
  apply (case_tac "n = 1")
   apply clarsimp
  apply (case_tac "n = 2")
   apply clarsimp
  apply (case_tac "n = 3")
   apply clarsimp
  apply (case_tac "n = 4")
   apply clarsimp
  apply (case_tac "n = 5")
   apply clarsimp
  apply (case_tac "n = 6")
   apply clarsimp
  apply (case_tac "n = 7")
   apply clarsimp
  apply (case_tac "n = 8")
   apply clarsimp
  apply (case_tac "n = 9")
   apply clarsimp
  apply (case_tac "n = 10")
   apply clarsimp
  apply (case_tac "n = 11")
   apply clarsimp
  by presburger

lemma add_to_or_1:
  "(a::32 word) \<le> 0xFFFFF \<Longrightarrow>
     ((x::32 word) && 0xFFF00000) + a =  (x && 0xFFF00000) || a"
  apply word_bitwise
  apply clarsimp
  using xor3_simps carry_simps apply auto
  done

lemma va_offset_higher_bits_1:
   " \<lbrakk>ucast (ucast ((x:: 32 word) >> 20):: 12 word) << 20 \<le> va ;
      va \<le> (ucast (ucast (x >> 20):: 12 word) << 20) + 0x000FFFFF \<rbrakk> \<Longrightarrow>
        (ucast (x >> 20):: 12 word) = (ucast ((va:: 32 word) >> 20)::12 word)"
  apply (subgoal_tac "(va::32 word) : {ucast (ucast ((x:: 32 word) >> 20):: 12 word) << 20 ..
                      (ucast (ucast (x >> 20):: 12 word) << 20) + mask 20 }")
   prefer 2
   apply (clarsimp simp: mask_def)
  apply (frule va_offset_add_1)
  apply simp
  apply (erule exE)
  apply (erule conjE)
  apply (simp add: mask_def)
  apply (subgoal_tac "(ucast ((((ucast (ucast ((x:: 32 word) >> 20):: 12 word) << 20)::32 word)  + a) >> 20):: 12 word) =
                      (ucast (((ucast (ucast ((x:: 32 word) >> 20):: 12 word) << 20)::32 word)   >> 20):: 12 word) ")
   apply clarsimp
   apply (word_bitwise) [1]
  apply (subgoal_tac "ucast ((ucast (ucast ((x::32 word) >> 20):: 12 word)::32 word) << 20 >> 20) =
   (ucast (x >> 20) :: 12 word)")
   prefer 2
   apply (word_bitwise) [1]
  apply simp
  apply (clarsimp simp: shift_to_mask_1 [symmetric])
  apply (rule word_eqI)
  apply (simp only: nth_ucast)
  apply clarsimp
  apply (subgoal_tac "n < 12")
   prefer 2
   apply word_bitwise [1]
  apply clarsimp
  apply (clarsimp simp: nth_shiftr)
  apply (clarsimp simp: mask_def)
  apply (frule_tac a = a in nth_bits_offset_equal_1) apply clarsimp
  apply (drule_tac x= x in add_to_or_1)
  apply (simp only: )
  done

lemma n_bit_shift_2:
  "\<lbrakk> \<forall>n::nat. n \<in> {20 .. 31} \<longrightarrow>(a::32 word) !! n = (b::32 word) !! n  \<rbrakk>  \<Longrightarrow>  a >> 20 = b >> 20"
  apply word_bitwise
  by auto

lemma nth_bits_offset_1: "\<lbrakk> n \<in> {20..31} ; (a::32 word) \<le> 0x000FFFFF \<rbrakk> \<Longrightarrow>
        (x::32 word) !! n = (x && 0xFFF00000 || a) !! n"
  apply (rule iffI)
   apply (case_tac "n = 20")
    apply clarsimp
   apply (case_tac "n = 21")
    apply clarsimp
   apply (case_tac "n = 22")
    apply clarsimp
   apply (case_tac "n = 23")
    apply clarsimp
   apply (case_tac "n = 24")
    apply clarsimp
   apply (case_tac "n = 25")
    apply clarsimp
   apply (case_tac "n = 26")
    apply clarsimp
   apply (case_tac "n = 27")
    apply clarsimp
   apply (case_tac "n = 28")
    apply clarsimp
   apply (case_tac "n = 29")
    apply clarsimp
   apply (case_tac "n = 30")
    apply clarsimp
   apply (case_tac "n = 31")
    apply clarsimp
   prefer 2
   apply (case_tac "n = 20")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 21")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 22")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 23")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 24")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 25")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 26")
    apply word_bitwise [1]  apply clarsimp
   apply (case_tac "n = 27")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 28")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 29")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 30")
    apply word_bitwise [1] apply clarsimp
   apply (case_tac "n = 31")
    apply word_bitwise [1] apply clarsimp
   apply clarsimp
   apply arith
  apply clarsimp
  apply arith
done

lemma  shfit_mask_eq:
  "\<lbrakk>ucast (ucast ((x:: 32 word) >> 20):: 12 word) << 20 \<le> va ;
      va \<le> (ucast (ucast (x >> 20):: 12 word) << 20) + 0x000FFFFF \<rbrakk>
    \<Longrightarrow>   ((x >> 20) && mask 12 << 2) = ((va >> 20) && mask 12 << 2)"
  apply (subgoal_tac "(va::32 word) : {ucast (ucast ((x:: 32 word) >> 20):: 12 word) << 20 ..
   (ucast (ucast (x >> 20):: 12 word) << 20) + mask 20 }")
   prefer 2
   apply (clarsimp simp: mask_def)
  apply (frule va_offset_add_1)
  apply simp
  apply (erule exE)
  apply (erule conjE)
  apply (simp add: mask_def)
  apply (rule_tac f = "(\<lambda>x. x && 0xFFF << 2)" in  arg_cong)
  apply (clarsimp simp: shift_to_mask_1 [symmetric])
  apply (simp add: mask_def)
  apply (rule n_bit_shift_2)
  apply (rule allI)
  apply (rule impI)
  apply (frule_tac x= x in add_to_or_1)
  apply (frule_tac x= x and a = a in nth_bits_offset_1)
   apply (simp only:)+
  done

(* page table walk simplification lemmas *)

lemma asid_entry_range [simp, intro!]:
  "pt_walk a m r v \<noteq> None \<Longrightarrow> v \<in> range_of (the (pt_walk a m r v))"
  apply (clarsimp simp: range_of_tlb_entry_def pt_walk_def Let_def  split: option.splits )
  apply (case_tac x2; clarsimp split:  option.splits)
  apply (case_tac x2a; clarsimp split:  option.splits)
  apply (metis (no_types, hide_lams) Addr_addr_val atLeastAtMost_iff image_iff va_12_left va_12_right)
  by (metis (no_types, hide_lams) Addr_addr_val atLeastAtMost_iff image_iff va_20_left va_20_right)

lemma asid_va_entry_range_pt_entry:
  "\<not>is_fault(pt_walk a m r v) \<Longrightarrow>
      v \<in> range_of (the(pt_walk a m r v))"
  by (clarsimp simp:   is_fault_def)

lemma  va_entry_set_pt_palk_same:
  "\<lbrakk>\<not>is_fault (pt_walk asid m r x) ;
           va \<in> range_of (the (pt_walk asid m r x))\<rbrakk> \<Longrightarrow>
              the(pt_walk asid m r x) = the(pt_walk asid m r va)"
  apply (subgoal_tac "x \<in> range_of (the(pt_walk asid m r x))")
   prefer 2
   apply (clarsimp simp: asid_va_entry_range_pt_entry is_fault_def)
  apply (cases "the (pt_walk asid m r x)")
   apply (clarsimp simp:   range_of_tlb_entry_def  is_fault_def image_iff)
   apply (cases "get_pde m r x" ; clarsimp)
    apply (clarsimp simp: pt_walk_def)
   apply (case_tac a ; clarsimp simp: pt_walk_def)
   apply (case_tac "get_pte m x3 x " ; clarsimp)
   apply (subgoal_tac "get_pde m r (Addr xaa) = get_pde m r  (Addr xa)" ; clarsimp)
    apply (subgoal_tac "get_pte m x3 (Addr xaa) = get_pte m x3  (Addr xa)" ; clarsimp)
     apply (case_tac a ; clarsimp)
  using va_offset_higher_bits apply blast
    apply (case_tac a ; clarsimp)
    apply (clarsimp simp:  get_pte_def vaddr_pt_index_def)
    apply (subgoal_tac "(( xaa >> 12) && mask 8 << 2) =
                          (( xa >> 12) && mask 8 << 2) ")
     prefer 2
  using offset_mask_eq apply force
    apply force
   apply (case_tac a ; clarsimp)
   apply (clarsimp simp: get_pde_def vaddr_pd_index_def)
   apply (subgoal_tac "((xaa >> 20) && mask 12 << 2) =
                         ((xa >> 20) && mask 12 << 2) ")
    prefer 2
  using offset_mask_eq_1 apply force
   apply force
  apply (simp only: )
  apply (clarsimp simp:   range_of_tlb_entry_def  is_fault_def)
  apply (cases "get_pde m r x" ; clarsimp simp: pt_walk_def)
  apply (case_tac a ; clarsimp)
   apply (case_tac "get_pte m x3 x" ; clarsimp)
   apply (subgoal_tac "get_pde m r (Addr xaa) = get_pde m r (Addr xa)" ; clarsimp)
    apply (subgoal_tac "get_pte m x3 (Addr xaa) = get_pte m x3 (Addr xa)" ; clarsimp)
     apply (case_tac a ; clarsimp)
    apply (case_tac a ; clarsimp simp: get_pte_def vaddr_pt_index_def)
   apply (case_tac a ; clarsimp simp: get_pde_def vaddr_pd_index_def)
  apply (cases "get_pde m r x" ; clarsimp)
  apply (subgoal_tac "get_pde m r (Addr xaa) = get_pde m r (Addr xa)" ; clarsimp)
  using va_offset_higher_bits_1 apply blast
  apply (clarsimp simp: get_pde_def vaddr_pd_index_def)
  apply (subgoal_tac "((xaa >> 20) && mask 12 << 2) = ((xa >> 20) && mask 12 << 2)")
   apply force
  using shfit_mask_eq by force

lemma  va_entry_set_pt_palk_same':
  "\<lbrakk>\<not>is_fault (pt_walk asid m r x) ;
           va \<in> range_of (the (pt_walk asid m r x))\<rbrakk> \<Longrightarrow>
              pt_walk asid m r x = pt_walk asid m r va"
 apply (subgoal_tac "x \<in> range_of (the(pt_walk asid m r x))")
   prefer 2
   apply (clarsimp simp: asid_va_entry_range_pt_entry is_fault_def)
  apply (cases "the (pt_walk asid m r x)")
     apply (simp only: )
   apply (clarsimp simp:   range_of_tlb_entry_def  is_fault_def)
   apply (cases "get_pde m r x" ; clarsimp simp: pt_walk_def)
   apply (case_tac a ; clarsimp)
   apply (case_tac "get_pte m x3 x " ; clarsimp)
   apply (subgoal_tac "get_pde m r (Addr xaa) = get_pde m r  (Addr xa)" ; clarsimp)
    apply (subgoal_tac "get_pte m x3 (Addr xaa) = get_pte m x3  (Addr xa)" ; clarsimp)
     apply (case_tac a ; clarsimp)
  using va_offset_higher_bits apply blast
    apply (case_tac a ; clarsimp)
    apply (clarsimp simp:  get_pte_def vaddr_pt_index_def)
    apply (subgoal_tac "(( xaa >> 12) && mask 8 << 2) =
                          (( xa >> 12) && mask 8 << 2) ")
     prefer 2
  using offset_mask_eq apply force
    apply force
   apply (case_tac a ; clarsimp)
   apply (clarsimp simp: get_pde_def vaddr_pd_index_def)
   apply (subgoal_tac "((xaa >> 20) && mask 12 << 2) =
                         ((xa >> 20) && mask 12 << 2) ")
    prefer 2
  using offset_mask_eq_1 apply force
   apply force
  apply (simp only: )
  apply (clarsimp simp:   range_of_tlb_entry_def  is_fault_def)
  apply (cases "get_pde m r x" ; clarsimp simp: pt_walk_def)
  apply (case_tac a ; clarsimp)
   apply (case_tac "get_pte m x3 x" ; clarsimp)
   apply (subgoal_tac "get_pde m r (Addr xaa) = get_pde m r (Addr xa)" ; clarsimp)
    apply (subgoal_tac "get_pte m x3 (Addr xaa) = get_pte m x3 (Addr xa)" ; clarsimp)
     apply (case_tac a ; clarsimp)
    apply (case_tac a ; clarsimp simp: get_pte_def vaddr_pt_index_def)
   apply (case_tac a ; clarsimp simp: get_pde_def vaddr_pd_index_def)
  apply (cases "get_pde m r x" ; clarsimp)
  apply (subgoal_tac "get_pde m r (Addr xaa) = get_pde m r (Addr xa)" ; clarsimp)
  using va_offset_higher_bits_1 apply blast
  apply (clarsimp simp: get_pde_def vaddr_pd_index_def)
  apply (subgoal_tac "((xaa >> 20) && mask 12 << 2) = ((xa >> 20) && mask 12 << 2)")
   apply force
  using shfit_mask_eq by force

theorem entry_range_single_element':
  " {E \<in> the ` {e \<in> t. \<not> is_fault e}. v \<in> range_of E} = {x} \<Longrightarrow>
       v \<in> range_of x \<and> \<not> is_fault (Some x)
         \<and> (\<forall>y\<in>the ` {e \<in> t. \<not> is_fault e}. y\<noteq>x \<and>
               \<not> is_fault (Some y) \<longrightarrow> v \<notin> range_of y)"
  apply safe
    apply force
   apply (clarsimp simp: is_fault_def)
  by force

lemma lookup_range_pt_walk_hit:
  "\<not> is_fault (pt_walk a mem ttbr0  va) \<Longrightarrow>
        lookup' (the ` {e \<in> range (pt_walk a mem ttbr0). \<not> is_fault e}) va = Hit (the (pt_walk a mem ttbr0  va)) "
  apply (clarsimp simp: lookup_def)
  apply safe
    apply simp
   apply (subgoal_tac "x = the (pt_walk a mem ttbr0 va)" , force)
   apply (clarsimp simp: entry_set_def)
   apply (drule entry_range_single_element')
   apply safe
   apply (unfold Ball_def) [1]
   apply (erule_tac x = "the (pt_walk a mem ttbr0  va)" in allE)
   apply (clarsimp simp: asid_va_entry_range_pt_entry is_fault_def)
  apply (rule_tac x = "the (pt_walk a mem ttbr0 va)" in exI)
  apply (clarsimp simp: entry_set_def)
  apply (rule entry_range_single_elementI)
     apply force
    apply (clarsimp simp: asid_va_entry_range_pt_entry is_fault_def)
  apply (clarsimp simp: asid_va_entry_range_pt_entry is_fault_def)
  by (metis is_fault_def option.sel option.simps(3) va_entry_set_pt_palk_same')

lemma lookup_range_fault_pt_walk:
  "\<lbrakk>lookup' (the ` {e \<in> range (pt_walk a m r). \<not> is_fault e}) v = Hit x\<rbrakk>  \<Longrightarrow>
          \<forall>va\<in> range_of x. x = the (pt_walk a m r va)"
  apply (subgoal_tac "x \<in> the ` {e \<in> range (pt_walk a m r). \<not> is_fault e}")
   prefer 2
   using  lookup_in_tlb apply force
  apply clarsimp
  apply (rule va_entry_set_pt_palk_same, simp)
   by (clarsimp simp:  )

lemma  lookup_miss_is_fault_intro:
  "is_fault (pt_walk a m r v) \<Longrightarrow> lookup' (the ` {e \<in> range (pt_walk a m r). \<not> is_fault e}) v = Miss"
  apply (subgoal_tac  "entry_set (the ` {e \<in> range (pt_walk a m r). \<not> is_fault e}) v = {}")
   apply (clarsimp simp: lookup_def)
  apply (clarsimp simp: entry_set_def)
  apply (subgoal_tac "pt_walk a m r xb = pt_walk a m r v", simp)
  using va_entry_set_pt_palk_same' by blast

lemma lookup_range_pt_walk_not_incon:
  "lookup' (the ` {e \<in> range (pt_walk a mem ttbr0). \<not> is_fault e}) va \<noteq> Incon"
  apply (case_tac "\<not>is_fault (pt_walk a mem ttbr0 va)")
   apply (clarsimp simp: lookup_range_pt_walk_hit)
  apply clarsimp
  apply (subgoal_tac " lookup' (the ` {e \<in> pt_walk a mem ttbr0 ` top. \<not> is_fault e}) va = Miss")
   apply (clarsimp simp: lookup_def entry_set_def split: if_split_asm)
  by (clarsimp simp: lookup_miss_is_fault_intro)

end


theory Inductive_Predicate
imports Setup
begin

(*<*)
hide_const %invisible append

inductive %invisible append where
  "append [] ys ys"
| "append xs ys zs \<Longrightarrow> append (x # xs) ys (x # zs)"

lemma %invisible append: "append xs ys zs = (xs @ ys = zs)"
  by (induct xs arbitrary: ys zs) (auto elim: append.cases intro: append.intros)

lemmas lexordp_def =
  lexordp_def [unfolded lexord_def mem_Collect_eq split]
(*>*)

section \<open>Inductive Predicates \label{sec:inductive}\<close>

text \<open>
  The \<open>predicate compiler\<close> is an extension of the code generator
  which turns inductive specifications into equational ones, from
  which in turn executable code can be generated.  The mechanisms of
  this compiler are described in detail in
  @{cite "Berghofer-Bulwahn-Haftmann:2009:TPHOL"}.

  Consider the simple predicate \<^const>\<open>append\<close> given by these two
  introduction rules:
\<close>

text %quote \<open>
  @{thm append.intros(1)[of ys]} \\
  @{thm append.intros(2)[of xs ys zs x]}
\<close>

text \<open>
  \noindent To invoke the compiler, simply use @{command_def "code_pred"}:
\<close>

code_pred %quote append .

text \<open>
  \noindent The @{command "code_pred"} command takes the name of the
  inductive predicate and then you put a period to discharge a trivial
  correctness proof.  The compiler infers possible modes for the
  predicate and produces the derived code equations.  Modes annotate
  which (parts of the) arguments are to be taken as input, and which
  output. Modes are similar to types, but use the notation \<open>i\<close>
  for input and \<open>o\<close> for output.

  For \<^term>\<open>append\<close>, the compiler can infer the following modes:
  \begin{itemize}
    \item \<open>i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool\<close>
    \item \<open>i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool\<close>
    \item \<open>o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool\<close>
  \end{itemize}
  You can compute sets of predicates using @{command_def "values"}:
\<close>

values %quote "{zs. append [(1::nat),2,3] [4,5] zs}"

text \<open>\noindent outputs \<open>{[1, 2, 3, 4, 5]}\<close>, and\<close>

values %quote "{(xs, ys). append xs ys [(2::nat),3]}"

text \<open>\noindent outputs \<open>{([], [2, 3]), ([2], [3]), ([2, 3], [])}\<close>.\<close>

text \<open>
  \noindent If you are only interested in the first elements of the
  set comprehension (with respect to a depth-first search on the
  introduction rules), you can pass an argument to @{command "values"}
  to specify the number of elements you want:
\<close>

values %quote 1 "{(xs, ys). append xs ys [(1::nat), 2, 3, 4]}"
values %quote 3 "{(xs, ys). append xs ys [(1::nat), 2, 3, 4]}"

text \<open>
  \noindent The @{command "values"} command can only compute set
  comprehensions for which a mode has been inferred.

  The code equations for a predicate are made available as theorems with
  the suffix \<open>equation\<close>, and can be inspected with:
\<close>

thm %quote append.equation

text \<open>
  \noindent More advanced options are described in the following subsections.
\<close>

subsection \<open>Alternative names for functions\<close>

text \<open>
  By default, the functions generated from a predicate are named after
  the predicate with the mode mangled into the name (e.g., \<open>append_i_i_o\<close>).  You can specify your own names as follows:
\<close>

code_pred %quote (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool as concat,
  o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool as split,
  i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool as suffix) append .

subsection \<open>Alternative introduction rules\<close>

text \<open>
  Sometimes the introduction rules of an predicate are not executable
  because they contain non-executable constants or specific modes
  could not be inferred.  It is also possible that the introduction
  rules yield a function that loops forever due to the execution in a
  depth-first search manner.  Therefore, you can declare alternative
  introduction rules for predicates with the attribute @{attribute
  "code_pred_intro"}.  For example, the transitive closure is defined
  by:
\<close>

text %quote \<open>
  @{lemma [source] "r a b \<Longrightarrow> tranclp r a b" by (fact tranclp.intros(1))}\\
  @{lemma [source] "tranclp r a b \<Longrightarrow> r b c \<Longrightarrow> tranclp r a c" by (fact tranclp.intros(2))}
\<close>

text \<open>
  \noindent These rules do not suit well for executing the transitive
  closure with the mode \<open>(i \<Rightarrow> o \<Rightarrow> bool) \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool\<close>, as
  the second rule will cause an infinite loop in the recursive call.
  This can be avoided using the following alternative rules which are
  declared to the predicate compiler by the attribute @{attribute
  "code_pred_intro"}:
\<close>

lemma %quote [code_pred_intro]:
  "r a b \<Longrightarrow> tranclp r a b"
  "r a b \<Longrightarrow> tranclp r b c \<Longrightarrow> tranclp r a c"
by auto

text \<open>
  \noindent After declaring all alternative rules for the transitive
  closure, you invoke @{command "code_pred"} as usual.  As you have
  declared alternative rules for the predicate, you are urged to prove
  that these introduction rules are complete, i.e., that you can
  derive an elimination rule for the alternative rules:
\<close>

code_pred %quote tranclp
proof -
  case tranclp
  from this converse_tranclpE [OF tranclp.prems] show thesis by metis
qed

text \<open>
  \noindent Alternative rules can also be used for constants that have
  not been defined inductively. For example, the lexicographic order
  which is defined as:
\<close>

text %quote \<open>
  @{thm [display] lexordp_def [of r]}
\<close>

text \<open>
  \noindent To make it executable, you can derive the following two
  rules and prove the elimination rule:
\<close>

lemma %quote [code_pred_intro]:
  "append xs (a # v) ys \<Longrightarrow> lexordp r xs ys"
(*<*)unfolding lexordp_def by (auto simp add: append)(*>*)

lemma %quote [code_pred_intro]:
  "append u (a # v) xs \<Longrightarrow> append u (b # w) ys \<Longrightarrow> r a b
  \<Longrightarrow> lexordp r xs ys"
(*<*)unfolding lexordp_def append apply simp
apply (rule disjI2) by auto(*>*)

code_pred %quote lexordp
(*<*)proof -
  fix r xs ys
  assume lexord: "lexordp r xs ys"
  assume 1: "\<And>r' xs' ys' a v. r = r' \<Longrightarrow> xs = xs' \<Longrightarrow> ys = ys'
    \<Longrightarrow> append xs' (a # v) ys' \<Longrightarrow> thesis"
  assume 2: "\<And>r' xs' ys' u a v b w. r = r' \<Longrightarrow> xs = xs' \<Longrightarrow> ys = ys'
    \<Longrightarrow> append u (a # v) xs' \<Longrightarrow> append u (b # w) ys' \<Longrightarrow> r' a b \<Longrightarrow> thesis"
  {
    assume "\<exists>a v. ys = xs @ a # v"
    from this 1 have thesis
        by (fastforce simp add: append)
  } moreover
  {
    assume "\<exists>u a b v w. r a b \<and> xs = u @ a # v \<and> ys = u @ b # w"
    from this 2 have thesis by (fastforce simp add: append)
  } moreover
  note lexord
  ultimately show thesis
    unfolding lexordp_def
    by fastforce
qed(*>*)

subsection \<open>Options for values\<close>

text \<open>
  In the presence of higher-order predicates, multiple modes for some
  predicate could be inferred that are not disambiguated by the
  pattern of the set comprehension.  To disambiguate the modes for the
  arguments of a predicate, you can state the modes explicitly in the
  @{command "values"} command.  Consider the simple predicate \<^term>\<open>succ\<close>:
\<close>

inductive %quote succ :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
  "succ 0 (Suc 0)"
| "succ x y \<Longrightarrow> succ (Suc x) (Suc y)"

code_pred %quote succ .

text \<open>
  \noindent For this, the predicate compiler can infer modes \<open>o
  \<Rightarrow> o \<Rightarrow> bool\<close>, \<open>i \<Rightarrow> o \<Rightarrow> bool\<close>, \<open>o \<Rightarrow> i \<Rightarrow> bool\<close> and
  \<open>i \<Rightarrow> i \<Rightarrow> bool\<close>.  The invocation of @{command "values"}
  \<open>{n. tranclp succ 10 n}\<close> loops, as multiple modes for the
  predicate \<open>succ\<close> are possible and here the first mode \<open>o \<Rightarrow> o \<Rightarrow> bool\<close> is chosen. To choose another mode for the argument,
  you can declare the mode for the argument between the @{command
  "values"} and the number of elements.
\<close>

values %quote [mode: i \<Rightarrow> o \<Rightarrow> bool] 1 "{n. tranclp succ 10 n}" (*FIXME does not terminate for n\<ge>1*)
values %quote [mode: o \<Rightarrow> i \<Rightarrow> bool] 1 "{n. tranclp succ n 10}"

subsection \<open>Embedding into functional code within Isabelle/HOL\<close>

text \<open>
  To embed the computation of an inductive predicate into functions
  that are defined in Isabelle/HOL, you have a number of options:

  \begin{itemize}

  \item You want to use the first-order predicate with the mode
    where all arguments are input. Then you can use the predicate directly, e.g.

    @{text [display]
\<open>valid_suffix ys zs =
  (if append [Suc 0, 2] ys zs then Some ys else None)\<close>}

  \item If you know that the execution returns only one value (it is
    deterministic), then you can use the combinator \<^term>\<open>Predicate.the\<close>, e.g., a functional concatenation of lists is
    defined with

    @{term [display] "functional_concat xs ys = Predicate.the (append_i_i_o xs ys)"}

    Note that if the evaluation does not return a unique value, it
    raises a run-time error \<^term>\<open>not_unique\<close>.

  \end{itemize}
\<close>

subsection \<open>Further Examples\<close>

text \<open>
  Further examples for compiling inductive predicates can be found in
  \<^file>\<open>~~/src/HOL/Predicate_Compile_Examples/Examples.thy\<close>.  There are
  also some examples in the Archive of Formal Proofs, notably in the
  \<open>POPLmark-deBruijn\<close> and the \<open>FeatherweightJava\<close>
  sessions.
\<close>

end


section \<open>Generic Recursion Combinator for Complete Lattice Structured Domains\<close>
theory RefineG_Recursion
imports "../Refine_Misc" RefineG_Transfer RefineG_Domain
begin

text \<open>
  We define a recursion combinator that asserts monotonicity.
\<close>

(* TODO: Move to Domain.*)
text \<open>
  The following lemma allows to compare least fixed points wrt.\ different flat
  orderings. At any point, the fixed points are either equal or have their
  orderings bottom values.
\<close>
lemma fp_compare:
  \<comment> \<open>At any point, fixed points wrt.\ different orderings are either equal,
    or both bottom.\<close>
  assumes M1: "flatf_mono b1 B" and M2: "flatf_mono b2 B"
  shows "flatf_fp b1 B x = flatf_fp b2 B x
    \<or> (flatf_fp b1 B x = b1 \<and> flatf_fp b2 B x = b2)"
proof -
  note UNF1 = flatf_ord.fixp_unfold[OF M1, symmetric]
  note UNF2 = flatf_ord.fixp_unfold[OF M2, symmetric]

  from UNF1 have 1: "flatf_ord b2 (B (flatf_fp b1 B)) (flatf_fp b1 B)" by simp
  from UNF2 have 2: "flatf_ord b1 (B (flatf_fp b2 B)) (flatf_fp b2 B)" by simp

  from flatf_ord.fixp_lowerbound[OF M2 1] flatf_ord.fixp_lowerbound[OF M1 2]
    show ?thesis unfolding fun_ord_def flat_ord_def by auto
qed

(* TODO: Move *)
lemma flat_ord_top[simp]: "flat_ord b b x" by (simp add: flat_ord_def)

(* TODO: Move to Domain.*)
lemma lfp_gfp_compare:
  \<comment> \<open>Least and greatest fixed point are either equal, or bot and top\<close>
  assumes MLE: "flatf_mono_le B" and MGE: "flatf_mono_ge B"
  shows "flatf_lfp B x = flatf_gfp B x
    \<or> (flatf_lfp B x = bot \<and> flatf_gfp B x = top)"
  using fp_compare[OF MLE MGE] .

(* TODO: Move to Domain *)
definition trimono :: "(('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> ('b::{bot,order,top})) \<Rightarrow> bool"
  where "trimono B \<equiv> \<^cancel>\<open>flatf_mono_le B \<and>\<close> flatf_mono_ge B \<and> mono B"
lemma trimonoI[refine_mono]:
  "\<lbrakk>flatf_mono_ge B; mono B\<rbrakk> \<Longrightarrow> trimono B"
  unfolding trimono_def by auto

lemma trimono_trigger: "trimono B \<Longrightarrow> trimono B" .

declaration \<open>Refine_Mono_Prover.declare_mono_triggers @{thms trimono_trigger}\<close>

(*lemma trimonoD_flatf_le: "trimono B \<Longrightarrow> flatf_mono_le B"
  unfolding trimono_def by auto*)

lemma trimonoD_flatf_ge: "trimono B \<Longrightarrow> flatf_mono_ge B"
  unfolding trimono_def by auto

lemma trimonoD_mono: "trimono B \<Longrightarrow> mono B"
  unfolding trimono_def by auto

lemmas trimonoD = trimonoD_flatf_ge trimonoD_mono

(* TODO: Optimize mono-prover to only do derivations once.
  Will cause problem with higher-order unification on ord - variable! *)
definition "triords \<equiv> {flat_ge,(\<le>)}"

lemma trimonoI':
  assumes "\<And>ord. ord\<in>triords \<Longrightarrow> monotone (fun_ord ord) (fun_ord ord) B"
  shows "trimono B"
  unfolding trimono_alt using assms by blast

(* TODO: Once complete_lattice and ccpo typeclass are unified,
  we should also define a REC-combinator for ccpos! *)

definition REC where "REC B x \<equiv>
  if (trimono B) then (lfp B x) else (top::'a::complete_lattice)"
definition RECT ("REC\<^sub>T") where "RECT B x \<equiv>
  if (trimono B) then (flatf_gfp B x) else (top::'a::complete_lattice)"

lemma RECT_gfp_def: "RECT B x =
  (if (trimono B) then (gfp B x) else (top::'a::complete_lattice))"
  unfolding RECT_def
  by (auto simp: gfp_eq_flatf_gfp[OF trimonoD_flatf_ge trimonoD_mono])

lemma RECT_unfold: "\<lbrakk>trimono B\<rbrakk> \<Longrightarrow> RECT B = B (RECT B)"
  unfolding RECT_def [abs_def]
  by (simp add: flatf_ord.fixp_unfold[OF trimonoD_flatf_ge, symmetric])

lemma REC_mono[refine_mono]:
  assumes [simp]: "trimono B"
  assumes LE: "\<And>F x. (B F x) \<le> (B' F x)"
  shows "(REC B x) \<le> (REC B' x)"
  unfolding REC_def
  apply clarsimp
  apply (rule lfp_mono[THEN le_funD])
  apply (rule LE[THEN le_funI])
  done

lemma RECT_mono[refine_mono]:
  assumes [simp]: "trimono B'"
  assumes LE: "\<And>F x. flat_ge (B F x) (B' F x)"
  shows "flat_ge (RECT B x) (RECT B' x)"
  unfolding RECT_def
  apply clarsimp
  apply (rule flatf_fp_mono, (simp_all add: trimonoD) [2])
  apply (rule LE)
  done

lemma REC_le_RECT: "REC body x \<le> RECT body x"
  unfolding REC_def RECT_gfp_def
  apply (cases "trimono body")
  apply clarsimp
  apply (rule lfp_le_gfp[THEN le_funD])
  apply (simp add: trimonoD)
  apply simp
  done

print_statement flatf_fp_induct_pointwise
theorem lfp_induct_pointwise:
  fixes a::'a
  assumes ADM1: "\<And>a x. chain_admissible (\<lambda>b. \<forall>a x. pre a x \<longrightarrow> post a x (b x))"
  assumes ADM2: "\<And>a x. pre a x \<longrightarrow> post a x bot"
  assumes MONO: "mono B"
  assumes P0: "pre a x"
  assumes IS:
    "\<And>f a x.
        \<lbrakk>\<And>a' x'. pre a' x' \<Longrightarrow> post a' x' (f x'); pre a x;
         f \<le> (lfp B)\<rbrakk>
        \<Longrightarrow> post a x (B f x)"
  shows "post a x (lfp B x)"
proof -
  define u where "u = lfp B"

  have [simp]: "\<And>f. f\<le>lfp B \<Longrightarrow> B f \<le> lfp B"
    by (metis (poly_guards_query) MONO lfp_unfold monoD)

  have "(\<forall>a x. pre a x \<longrightarrow> post a x (lfp B x)) \<and> lfp B \<le> u"
    apply (rule lfp_cadm_induct[where f=B])
    apply (rule admissible_conj)
    apply (rule ADM1)
    apply (rule)
    apply (blast intro: Sup_least)
    apply (simp add: le_fun_def ADM2) []
    apply fact
    apply (intro conjI allI impI)
    unfolding u_def
    apply (blast intro: IS)
    apply simp
    done
  with P0 show ?thesis by blast
qed

lemma REC_rule_arb:
  fixes x::"'x" and arb::'arb
  assumes M: "trimono body"
  assumes I0: "pre arb x"
  assumes IS: "\<And>f arb x. \<lbrakk>
    \<And>arb' x. pre arb' x \<Longrightarrow> f x \<le> M arb' x; pre arb x; f \<le> REC body
  \<rbrakk> \<Longrightarrow> body f x \<le> M arb x"
  shows "REC body x \<le> M arb x"
  unfolding REC_def
  apply (clarsimp simp: M)
  apply (rule lfp_induct_pointwise[where pre=pre])
  apply (auto intro!: chain_admissibleI SUP_least) [2]
  apply (simp add: trimonoD[OF M])
  apply (rule I0)
  apply (rule IS, assumption+)
  apply (auto simp: REC_def[abs_def] intro!: le_funI dest: le_funD) []
  done

lemma RECT_rule_arb:
  assumes M: "trimono body"
  assumes WF: "wf (V::('x\<times>'x) set)"
  assumes I0: "pre (arb::'arb) (x::'x)"
  assumes IS: "\<And>f arb x. \<lbrakk>
      \<And>arb' x'. \<lbrakk>pre arb' x'; (x',x)\<in>V\<rbrakk> \<Longrightarrow> f x' \<le> M arb' x';
      pre arb x;
      RECT body = f
    \<rbrakk>  \<Longrightarrow> body f x \<le> M arb x"
  shows "RECT body x \<le> M arb x"
  apply (rule wf_fixp_induct[where fp=RECT and pre=pre and B=body])
  apply (rule RECT_unfold)
  apply (simp_all add: M) [2]
  apply (rule WF)
  apply fact
  apply (rule IS)
  apply assumption
  apply assumption
  apply assumption
  done

lemma REC_rule:
  fixes x::"'x"
  assumes M: "trimono body"
  assumes I0: "pre x"
  assumes IS: "\<And>f x. \<lbrakk> \<And>x. pre x \<Longrightarrow> f x \<le> M x; pre x; f \<le> REC body \<rbrakk>
    \<Longrightarrow> body f x \<le> M x"
  shows "REC body x \<le> M x"
  by (rule REC_rule_arb[where pre="\<lambda>_. pre" and M="\<lambda>_. M", OF assms])

lemma RECT_rule:
  assumes M: "trimono body"
  assumes WF: "wf (V::('x\<times>'x) set)"
  assumes I0: "pre (x::'x)"
  assumes IS: "\<And>f x. \<lbrakk> \<And>x'. \<lbrakk>pre x'; (x',x)\<in>V\<rbrakk> \<Longrightarrow> f x' \<le> M x'; pre x;
                        RECT body = f
    \<rbrakk> \<Longrightarrow> body f x \<le> M x"
  shows "RECT body x \<le> M x"
  by (rule RECT_rule_arb[where pre="\<lambda>_. pre" and M="\<lambda>_. M", OF assms])

(* TODO: Can we set-up induction method to work with such goals? *)
lemma REC_rule_arb2:
  assumes M: "trimono body"
  assumes I0: "pre (arb::'arb) (arc::'arc) (x::'x)"
  assumes IS: "\<And>f arb arc x. \<lbrakk>
      \<And>arb' arc' x'. \<lbrakk>pre arb' arc' x' \<rbrakk> \<Longrightarrow> f x' \<le> M arb' arc' x';
      pre arb arc x
    \<rbrakk>  \<Longrightarrow> body f x \<le> M arb arc x"
  shows "REC body x \<le> M arb arc x"
  apply (rule order_trans)
  apply (rule REC_rule_arb[
    where pre="case_prod pre" and M="case_prod M" and arb="(arb, arc)",
    OF M])
  by (auto intro: assms)

lemma REC_rule_arb3:
  assumes M: "trimono body"
  assumes I0: "pre (arb::'arb) (arc::'arc) (ard::'ard) (x::'x)"
  assumes IS: "\<And>f arb arc ard x. \<lbrakk>
      \<And>arb' arc' ard' x'. \<lbrakk>pre arb' arc' ard' x'\<rbrakk> \<Longrightarrow> f x' \<le> M arb' arc' ard' x';
      pre arb arc ard x
    \<rbrakk>  \<Longrightarrow> body f x \<le> M arb arc ard x"
  shows "REC body x \<le> M arb arc ard x"
  apply (rule order_trans)
  apply (rule REC_rule_arb2[
    where pre="case_prod pre" and M="case_prod M" and arb="(arb, arc)" and arc="ard",
    OF M])
  by (auto intro: assms)

lemma RECT_rule_arb2:
  assumes M: "trimono body"
  assumes WF: "wf (V::'x rel)"
  assumes I0: "pre (arb::'arb) (arc::'arc) (x::'x)"
  assumes IS: "\<And>f arb arc x. \<lbrakk>
      \<And>arb' arc' x'. \<lbrakk>pre arb' arc' x'; (x',x)\<in>V\<rbrakk> \<Longrightarrow> f x' \<le> M arb' arc' x';
      pre arb arc x;
      f \<le> RECT body
    \<rbrakk>  \<Longrightarrow> body f x \<le> M arb arc x"
  shows "RECT body x \<le> M arb arc x"
  apply (rule order_trans)
  apply (rule RECT_rule_arb[
    where pre="case_prod pre" and M="case_prod M" and arb="(arb, arc)",
    OF M WF])
  by (auto intro: assms)

lemma RECT_rule_arb3:
  assumes M: "trimono body"
  assumes WF: "wf (V::'x rel)"
  assumes I0: "pre (arb::'arb) (arc::'arc) (ard::'ard) (x::'x)"
  assumes IS: "\<And>f arb arc ard x. \<lbrakk>
      \<And>arb' arc' ard' x'. \<lbrakk>pre arb' arc' ard' x'; (x',x)\<in>V\<rbrakk> \<Longrightarrow> f x' \<le> M arb' arc' ard' x';
    pre arb arc ard x;
    f \<le> RECT body
  \<rbrakk>  \<Longrightarrow> body f x \<le> M arb arc ard x"
  shows "RECT body x \<le> M arb arc ard x"
  apply (rule order_trans)
  apply (rule RECT_rule_arb2[
    where pre="case_prod pre" and M="case_prod M" and arb="(arb, arc)" and arc="ard",
    OF M WF])
  by (auto intro: assms)

(* Obsolete, provide a variant to show nofail.
text {* The following lemma shows that greatest and least fixed point are equal,
  if we can provide a variant. *}
lemma RECT_eq_REC:
  assumes MONO: "flatf_mono_le body"
  assumes MONO_GE: "flatf_mono_ge body"
  assumes WF: "wf V"
  assumes I0: "I x"
  assumes IS: "\<And>f x. I x \<Longrightarrow>
    body (\<lambda>x'. if (I x' \<and> (x',x)\<in>V) then f x' else top) x \<le> body f x"
  shows "RECT body x = REC body x"
  unfolding RECT_def REC_def
proof (simp add: MONO MONO_GE)
  have "I x \<longrightarrow> flatf_gfp body x \<le> flatf_lfp body x"
    using WF
    apply (induct rule: wf_induct_rule)
    apply (rule impI)
    apply (subst flatf_ord.fixp_unfold[OF MONO])
    apply (subst flatf_ord.fixp_unfold[OF MONO_GE])
    apply (rule order_trans[OF _ IS])
    apply (rule monoD[OF MONO,THEN le_funD])
    apply (rule le_funI)
    apply simp
    apply simp
    done

  from lfp_le_gfp' MONO have "lfp body x \<le> gfp body x" .
  moreover have "I x \<longrightarrow> gfp body x \<le> lfp body x"
    using WF
    apply (induct rule: wf_induct[consumes 1])
    apply (rule impI)
    apply (subst lfp_unfold[OF MONO])
    apply (subst gfp_unfold[OF MONO])
    apply (rule order_trans[OF _ IS])
    apply (rule monoD[OF MONO,THEN le_funD])
    apply (rule le_funI)
    apply simp
    apply simp
    done
  ultimately show ?thesis
    unfolding REC_def RECT_def gfp_eq_flatf_gfp[OF MONO_GE MONO, symmetric]
    apply (rule_tac antisym)
    using I0 MONO MONO_GE by auto
qed
*)

lemma RECT_eq_REC:
  \<comment> \<open>Partial and total correct recursion are equal if total
    recursion does not fail.\<close>
  assumes NT: "RECT body x \<noteq> top"
  shows "RECT body x = REC body x"
proof (cases "trimono body")
  case M: True
  show ?thesis
    using NT M
    unfolding RECT_def REC_def
  proof clarsimp
    from lfp_unfold[OF trimonoD_mono[OF M], symmetric]
    have "flatf_ge (body (lfp body)) (lfp body)" by simp
    note flatf_ord.fixp_lowerbound[
      OF trimonoD_flatf_ge[OF M], of "lfp body", OF this]
    moreover assume "flatf_gfp body x \<noteq> top"
    ultimately show "flatf_gfp body x = lfp body x"
      by (auto simp add: fun_ord_def flat_ord_def)
  qed
next
  case False thus ?thesis unfolding RECT_def REC_def by auto
qed

subsection \<open>Transfer\<close>

lemma (in transfer) transfer_RECT'[refine_transfer]:
  assumes REC_EQ: "\<And>x. fr x = b fr x"
  assumes REF: "\<And>F f x. \<lbrakk>\<And>x. \<alpha> (f x) \<le> F x \<rbrakk> \<Longrightarrow> \<alpha> (b f x) \<le> B F x"
  shows "\<alpha> (fr x) \<le> RECT B x"
  unfolding RECT_def
proof clarsimp
  assume MONO: "trimono B"
  show "\<alpha> (fr x) \<le> flatf_gfp B x"
    apply (rule flatf_fixp_transfer[where B=B and fp'=fr and P="(=)",
        OF _ trimonoD_flatf_ge[OF MONO]])
    apply simp
    apply (rule ext, fact)
    apply (simp)
    apply (simp,rule REF, blast)
    done
qed

lemma (in ordered_transfer) transfer_RECT[refine_transfer]:
  assumes REF: "\<And>F f x. \<lbrakk>\<And>x. \<alpha> (f x) \<le> F x \<rbrakk> \<Longrightarrow> \<alpha> (b f x) \<le> B F x"
  assumes M: "trimono b"
  shows "\<alpha> (RECT b x) \<le> RECT B x"
  apply (rule transfer_RECT')
  apply (rule RECT_unfold[OF M, THEN fun_cong])
  by fact

lemma (in dist_transfer) transfer_REC[refine_transfer]:
  assumes REF: "\<And>F f x. \<lbrakk>\<And>x. \<alpha> (f x) \<le> F x \<rbrakk> \<Longrightarrow> \<alpha> (b f x) \<le> B F x"
  assumes M: "trimono b"
  shows "\<alpha> (REC b x) \<le> REC B x"
  unfolding REC_def
  (* TODO: Clean up *)
  apply (clarsimp simp: M)
  apply (rule lfp_induct_pointwise[where B=b and pre="(=)"])
  apply (rule)
  apply clarsimp
  apply (subst \<alpha>_dist)
  apply (auto simp add: chain_def le_fun_def) []
  apply (rule Sup_least)
  apply auto []
  apply simp
  apply (simp add: trimonoD[OF M])
  apply (rule refl)
  apply (subst lfp_unfold)
  apply (simp add: trimonoD)
  apply (rule REF)
  apply blast
  done

(* TODO: Could we base the whole refine_transfer-stuff on arbitrary relations *)
(* TODO: For enres-breakdown, we had to do antisymmetry, in order to get TR_top.
  What is the general shape of tr-relations for that, such that we could show equality directly?
*)
lemma RECT_transfer_rel:
  assumes [simp]: "trimono F" "trimono F'"
  assumes TR_top[simp]: "\<And>x. tr x top"
  assumes P_start[simp]: "P x x'"
  assumes IS: "\<And>D D' x x'. \<lbrakk> \<And>x x'. P x x' \<Longrightarrow> tr (D x) (D' x'); P x x'; RECT F = D \<rbrakk> \<Longrightarrow> tr (F D x) (F' D' x')"
  shows "tr (RECT F x) (RECT F' x')"
  unfolding RECT_def
  apply auto
  apply (rule flatf_gfp_transfer[where tr=tr and P=P])
  apply (auto simp: trimonoD_flatf_ge)
  apply (rule IS)
  apply (auto simp: RECT_def)
  done

lemma RECT_transfer_rel':
  assumes [simp]: "trimono F" "trimono F'"
  assumes TR_top[simp]: "\<And>x. tr x top"
  assumes P_start[simp]: "P x x'"
  assumes IS: "\<And>D D' x x'. \<lbrakk> \<And>x x'. P x x' \<Longrightarrow> tr (D x) (D' x'); P x x' \<rbrakk> \<Longrightarrow> tr (F D x) (F' D' x')"
  shows "tr (RECT F x) (RECT F' x')"
  using RECT_transfer_rel[where tr=tr and P=P,OF assms(1,2,3,4)] IS by blast

end