section "Bisimilarity, abstractly"

theory Bisim
imports Interface
begin

type_synonym 'a rel = "('a * 'a) set"
type_synonym ('cmd,'state)config = "'cmd * 'state"

definition mono where
"mono Retr \<equiv>
 \<forall> theta theta'. theta \<le> theta' \<longrightarrow> Retr theta \<le> Retr theta'"

definition simul where
"simul Retr theta \<equiv> theta \<le> Retr theta"

definition bisim where
"bisim Retr theta \<equiv> sym theta \<and> simul Retr theta"

lemma mono_Union:
assumes "mono Retr"
shows "Union (Retr ` Theta) \<le> Retr (Union Theta)"
proof-
  have "\<forall> theta' \<in> Retr ` Theta. theta' \<subseteq> Retr (Union Theta)"
  using assms unfolding mono_def by blast
  thus ?thesis by blast
qed

lemma mono_Un:
assumes "mono Retr"
shows "Retr theta Un Retr theta' \<subseteq> Retr (theta Un theta')"
using assms unfolding mono_def
by (metis Un_least Un_upper1 Un_upper2)

lemma sym_Union:
assumes "\<And>theta. theta \<in> Theta \<Longrightarrow> sym theta"
shows "sym (Union Theta)"
using assms unfolding sym_def by blast

lemma sym_Un:
assumes "sym theta1" and "sym theta2"
shows "sym (theta1 Un theta2)"
using assms sym_Union[of "{theta1,theta2}"] by auto

lemma simul_Union:
assumes "mono Retr"
and "\<And>theta. theta \<in> Theta \<Longrightarrow> simul Retr theta"
shows "simul Retr (Union Theta)"
proof-
  have "\<forall> theta \<in> Theta. theta \<subseteq> Retr theta"
  using assms unfolding simul_def by blast
  hence "Union Theta \<subseteq> Union (Retr ` Theta)" by blast
  also have "... \<subseteq> Retr (Union Theta)" using mono_Union assms unfolding mono_def by auto
  finally have "Union Theta \<subseteq> Retr (Union Theta)" .
  thus ?thesis unfolding simul_def by simp
qed

lemma simul_Un:
assumes "mono Retr" and "simul Retr theta1" and "simul Retr theta2"
shows "simul Retr (theta1 Un theta2)"
using assms simul_Union[of Retr "{theta1,theta2}"] by auto

lemma bisim_Union:
assumes "mono Retr" and "\<And>theta. theta \<in> Theta \<Longrightarrow> bisim Retr theta"
shows "bisim Retr (Union Theta)"
using assms unfolding bisim_def
using sym_Union simul_Union by blast

lemma bisim_Un:
assumes "mono Retr" and "bisim Retr theta1" and "bisim Retr theta2"
shows "bisim Retr (theta1 Un theta2)"
using assms bisim_Union[of Retr "{theta1,theta2}"] by auto

definition bis where
"bis Retr \<equiv> Union {theta. bisim Retr theta}"

lemma bisim_bis[simp]:
assumes "mono Retr"
shows "bisim Retr (bis Retr)"
using assms unfolding mono_def
by (metis CollectD assms bis_def bisim_Union)

corollary sym_bis[simp]: "mono Retr \<Longrightarrow> sym (bis Retr)"
and simul_bis[simp]: "mono Retr \<Longrightarrow> simul Retr (bis Retr)"
using bisim_bis unfolding bisim_def by auto

lemma bis_raw_coind:
assumes "mono Retr" and "sym theta" and "theta \<subseteq> Retr theta"
shows "theta \<subseteq> bis Retr"
using assms unfolding mono_def bis_def bisim_def simul_def by blast

lemma bis_prefix[simp]:
assumes "mono Retr"
shows "bis Retr \<subseteq> Retr (bis Retr)"
by (metis assms bisim_bis bisim_def simul_def)

lemma bis_coind:
assumes *: "mono Retr" and "sym theta" and **: "theta \<subseteq> Retr (theta Un (bis Retr))"
shows "theta \<subseteq> bis Retr"
proof-
  let ?theta' = "theta Un (bis Retr)"
  have "sym ?theta'" by (metis Bisim.sym_Un sym_bis assms)
  moreover have "?theta' \<subseteq> Retr ?theta'"
  by (metis assms mono_Un Un_least bis_prefix le_supI2 subset_trans)
  ultimately show ?thesis using * bis_raw_coind by blast
qed

lemma bis_coind2:
assumes *: "mono Retr" and
**: "theta \<subseteq> Retr (theta Un (bis Retr))" and
***: "theta ^-1 \<subseteq> Retr ((theta ^-1) Un (bis Retr))"
shows "theta \<subseteq> bis Retr"
proof-
  let ?th = "theta Un theta ^-1"
  have "sym ?th" by (metis sym_Un_converse)
  moreover
  {have "?th \<subseteq> Retr (theta Un (bis Retr)) Un Retr (theta ^-1 Un (bis Retr))"
   using ** *** Un_mono by blast
   also have "... \<subseteq> Retr ((theta Un (bis Retr)) Un (theta ^-1 Un (bis Retr)))"
   using * mono_Un by blast
   also have "... = Retr (?th Un (bis Retr))" by (metis Un_assoc Un_commute Un_left_absorb)
   finally have "?th \<subseteq> Retr (?th Un (bis Retr))" .
  }
  ultimately have "?th \<subseteq> bis Retr" using assms bis_coind by blast
  thus ?thesis by blast
qed

lemma bis_raw_coind2:
assumes *: "mono Retr" and
**: "theta \<subseteq> Retr theta" and
***: "theta ^-1 \<subseteq> Retr (theta ^-1)"
shows "theta \<subseteq> bis Retr"
proof-
  have "theta \<subseteq> Retr (theta Un (bis Retr))" and
  "theta ^-1 \<subseteq> Retr ((theta ^-1) Un (bis Retr))"
  using assms by(metis mono_Un le_supI1 subset_trans)+
  thus ?thesis using * bis_coind2 by blast
qed

lemma mono_bis:
assumes "mono Retr1"  and "mono Retr2"
and "\<And> theta. Retr1 theta \<subseteq> Retr2 theta"
shows "bis Retr1 \<subseteq> bis Retr2"
by (metis assms bis_prefix bis_raw_coind subset_trans sym_bis)

end


(*  Title:      Cars.thy
    Author:     Sven Linker

A countably infinite type to denote cars in the model of HMLSL.
*)

section\<open>Cars\<close>

text \<open>
We define a type to refer to cars. For simplicity, we assume that (countably)
infinite cars exist.
\<close>

theory Cars
  imports Main
begin

text \<open>
The type of cars consists of the natural numbers. However, we do not
define or prove any additional structure about it.
\<close>

typedef cars = "{n::nat. True} " by blast

locale cars
begin

text \<open>
For the construction of possible counterexamples, it is beneficial to
prove that at least two cars exist. Furthermore, we show that there indeed
exist infinitely many cars.
\<close>

lemma at_least_two_cars_exists:"\<exists>c d ::cars . c\<noteq>d"
proof -
  have "(0::nat) \<noteq> 1" by simp
  then have "Abs_cars (0::nat) \<noteq> Abs_cars(1) " by (simp add:Abs_cars_inject)
  thus ?thesis by blast
qed

lemma infinite_cars:"infinite {c::cars . True}"
proof -
  have "infinite {n::nat. True}" by auto
  then show ?thesis
    by (metis UNIV_def finite_imageI type_definition.Rep_range type_definition_cars)
qed

end
end


theory TeslDenotationalExtensions
imports TeslDenotationalRelations
        TeslDenotationalStuttering

begin

definition ImpliesNot :: \<open>('\<AA>,'b)\<H> \<Rightarrow> ('\<AA>,'c)\<H> \<Rightarrow> ('\<AA>::orderedrank) runs\<close> (infixl "implies not" 55)
  where \<open>(H\<^sub>1 implies not H\<^sub>2) = {r. \<forall>n. ticks H\<^sub>1 (hamlet r n) \<longrightarrow> \<not>ticks H\<^sub>2 (hamlet r n)}\<close>

definition Precedes :: \<open>('\<AA>,'b)\<H> \<Rightarrow> ('\<AA>,'c)\<H> \<Rightarrow> ('\<AA>::orderedrank) runs\<close> (infixl "\<lessapprox>" 55)
  where \<open>(H\<^sub>1 \<lessapprox> H\<^sub>2) = {r. \<forall>n. tick_count H\<^sub>1 (hamlet r) n \<le> tick_count H\<^sub>2 (hamlet r) n}\<close>

lemma card0:\<open>card {i::nat. i = 0 \<and> P i} = card {i::nat. i = 0 \<and> P 0}\<close>
proof -
  have \<open>{i::nat. i = 0 \<and> P i} = (if P 0 then {0} else {})\<close> by (rule Collect_conv_if)
  thus ?thesis by simp
qed

lemma card_suc:\<open>card {i. i \<le> (Suc n) \<and> P i} = card {i. i \<le> n \<and> P i} + card {i. i = (Suc n) \<and> P i}\<close>
proof -
  have \<open>{i. i \<le> n \<and> P i} \<inter> {i. i = (Suc n) \<and> P i} = {}\<close> by auto
  moreover have \<open>{i. i \<le> n \<and> P i} \<union> {i. i = (Suc n) \<and> P i} = {i. i \<le> (Suc n) \<and> P i}\<close> by auto
  moreover have \<open>finite {i. i \<le> n \<and> P i}\<close> by simp
  moreover have \<open>finite {i. i = (Suc n) \<and> P i}\<close> by simp
  ultimately show ?thesis using card_Un_disjoint[of \<open>{i. i \<le> n \<and> P i}\<close> \<open>{i. i = Suc n \<and> P i}\<close>] by simp
qed

lemma if_equal_equal:
  assumes \<open>A \<noteq> B\<close>
      and \<open>(if P then A else B) = (if Q then A else B)\<close>
    shows \<open>P = Q\<close>
using assms by presburger

lemma ileq0:\<open>(card {i::nat. i \<le> 0 \<and> P i} = card {i::nat. i \<le> 0 \<and> Q i}) = (P 0 = Q 0)\<close>
proof
  { assume \<open>card {i. i \<le> 0 \<and> P i} = card {i. i \<le> 0 \<and> Q i}\<close>
    hence \<open>card {i. i = 0 \<and> P i} = card {i. i = 0 \<and> Q i}\<close> by auto
    hence \<open>card {i::nat. i = 0 \<and> P 0} = card {i::nat. i = 0 \<and> Q 0}\<close> using card0[symmetric] by simp
    hence \<open>(if P 0 then 1 else 0) = (if Q 0 then 1 else 0)\<close> by auto
    from if_equal_equal[OF one_neq_zero this] show \<open>P 0 = Q 0\<close> .
  }
  { assume \<open>P 0 = Q 0\<close>
    hence \<open>card {i::nat. i = 0 \<and> P 0} = card {i::nat. i = 0 \<and> Q 0}\<close> by auto
    hence \<open>card {i::nat. i = 0 \<and> P i} = card {i::nat. i = 0 \<and> Q i}\<close> using card0 by simp
    thus \<open>card {i::nat. i \<le> 0 \<and> P i} = card {i::nat. i \<le> 0 \<and> Q i}\<close> by simp
  }
qed

lemma tick_count_suc:\<open>tick_count C h (Suc n) = (if ticks C (h (Suc n)) then Suc (tick_count C h n) else tick_count C h n)\<close>
by (simp add: tick_count_is_fun)

text \<open>
  Clocks that always have the same tick count tick at the same instants.
\<close>
lemma same_tickcount_same_ticks:
  assumes \<open>\<forall>m. tick_count H\<^sub>1 (hamlet r) m = tick_count H\<^sub>2 (hamlet r) m\<close>
  shows \<open>ticks H\<^sub>1 (hamlet r n) = ticks H\<^sub>2 (hamlet r n)\<close>
proof (cases n)
  case 0
    from assms have \<open>tick_count H\<^sub>1 (hamlet r) 0 = tick_count H\<^sub>2 (hamlet r) 0\<close> by simp
    hence \<open>card {i. i \<le> 0 \<and> ticks H\<^sub>1 (hamlet r i)} = card {i. i \<le> 0 \<and> ticks H\<^sub>2 (hamlet r i)}\<close>
      unfolding tick_count_def .
    with ileq0 and 0 show ?thesis by simp
next
  case (Suc n)
    from tick_count_suc have
      \<open>tick_count H\<^sub>1 (hamlet r) (Suc n) = (if ticks H\<^sub>1 (hamlet r (Suc n)) then Suc (tick_count H\<^sub>1 (hamlet r) n) else tick_count H\<^sub>1 (hamlet r) n)\<close> .
    moreover from tick_count_suc have
      \<open>tick_count H\<^sub>2 (hamlet r) (Suc n) = (if ticks H\<^sub>2 (hamlet r (Suc n)) then Suc (tick_count H\<^sub>2 (hamlet r) n) else tick_count H\<^sub>2 (hamlet r) n)\<close> .
    ultimately have \<open>(if ticks H\<^sub>1 (hamlet r (Suc n)) then Suc (tick_count H\<^sub>1 (hamlet r) n) else tick_count H\<^sub>1 (hamlet r) n)
                    = (if ticks H\<^sub>2 (hamlet r (Suc n)) then Suc (tick_count H\<^sub>2 (hamlet r) n) else tick_count H\<^sub>2 (hamlet r) n)\<close> using assms by simp
    also have \<open>... = (if ticks H\<^sub>2 (hamlet r (Suc n)) then Suc (tick_count H\<^sub>1 (hamlet r) n) else tick_count H\<^sub>1 (hamlet r) n)\<close> using assms by simp
    finally have \<open>(if ticks H\<^sub>1 (hamlet r (Suc n)) then Suc (tick_count H\<^sub>1 (hamlet r) n) else tick_count H\<^sub>1 (hamlet r) n)
                = (if ticks H\<^sub>2 (hamlet r (Suc n)) then Suc (tick_count H\<^sub>1 (hamlet r) n) else tick_count H\<^sub>1 (hamlet r) n)\<close> .
  from if_equal_equal[OF n_not_Suc_n[symmetric] this] show ?thesis using Suc by simp
qed

text \<open>
  If two clocks precede one another, they tick at the same instants.
\<close>

lemma prec_prec_sameticks:
  assumes \<open>r \<in> H\<^sub>1 \<lessapprox> H\<^sub>2\<close>
      and \<open>r \<in> H\<^sub>2 \<lessapprox> H\<^sub>1\<close>
    shows \<open>ticks H\<^sub>1 (hamlet r n) = ticks H\<^sub>2 (hamlet r n)\<close>
  using assms unfolding Precedes_def
  by (simp add: same_tickcount_same_ticks dual_order.antisym)

text \<open>
  The never ticking clock can be build using implies and implies not.
\<close>
lemma \<open>(a implies b) \<otimes> (a implies not b) = {r. \<forall>n. \<not>ticks a (hamlet r n)}\<close>
proof
  { fix w assume \<open>w \<in> a implies b \<otimes> (a implies not b)\<close>
    hence \<open>w \<in> {r. \<forall>n. ticks a (hamlet r n) \<longrightarrow> ticks b (hamlet r n)}
             \<inter> {r. \<forall>n. ticks a (hamlet r n) \<longrightarrow> \<not>ticks b (hamlet r n)}\<close>
      unfolding TeslComp_def Implies_def ImpliesNot_def .
    hence \<open>w \<in> {r. \<forall>n. ticks a (hamlet r n) \<longrightarrow> (ticks b (hamlet r n) \<and> \<not>ticks b (hamlet r n))}\<close> by auto
    hence \<open>w \<in> {r. \<forall>n. \<not>ticks a (hamlet r n)}\<close> by simp
  } thus \<open>a implies b \<otimes> (a implies not b) \<subseteq> {r. \<forall>n. \<not> ticks a (hamlet r n)}\<close> ..
  { fix w::\<open>'a run\<close> assume \<open>w \<in> {r. \<forall>n. \<not>ticks a (hamlet r n)}\<close>
    hence \<open>w \<in> {r. \<forall>n. ticks a (hamlet r n) \<longrightarrow> False}\<close> by simp
    hence \<open>w \<in> {r. \<forall>n. ticks a (hamlet r n) \<longrightarrow> (ticks b (hamlet r n) \<and> \<not>ticks b (hamlet r n))}\<close> by simp
    hence \<open>w \<in> (a implies b) \<otimes> (a implies not b)\<close> unfolding TeslComp_def Implies_def ImpliesNot_def by simp
  } thus \<open>{r. \<forall>n. \<not> ticks a (hamlet r n)} \<subseteq> a implies b \<otimes> (a implies not b)\<close> ..
qed

text \<open>
  A simpler definition of never.
\<close>
definition never
  where \<open>never a = a implies not a\<close>

lemma \<open>never a = {r. \<forall>n. \<not>ticks a (hamlet r n)}\<close>
proof -
  from never_def have \<open>never a = a implies not a\<close> .
  also from ImpliesNot_def have \<open>... = {r. \<forall>n. ticks a (hamlet r n) \<longrightarrow> \<not>ticks a (hamlet r n)}\<close> .
  also have \<open>... = {r. \<forall>n. \<not>ticks a (hamlet r n)}\<close> by simp
  finally show ?thesis .
qed

text \<open>
  Implies not implications are preserved by dilation.
\<close>
lemma impliesnot_sub:
  assumes \<open>sub \<lless> r\<close>
      and \<open>sub \<in> (a implies not b)\<close>
    shows \<open>r \<in> (a implies not b)\<close>
  by (smt ImpliesNot_def assms is_subrun_def mem_Collect_eq ticks_imp_ticks_subk ticks_sub)

text \<open>
  Precedence relations are preserved by dilation.
\<close>
lemma dil_tick_count:
  assumes \<open>dilating f sub r\<close>
      and \<open>\<forall>n. tick_count a (hamlet r) (f n) \<le> tick_count b (hamlet r) (f n)\<close>
    shows \<open>tick_count a (hamlet r) n \<le> tick_count b (hamlet r) n\<close>
proof (induction n)
  case 0
  then show ?case using assms dilating_def dilating_fun_def
    by (smt Collect_cong empty_dilated_prefix le_neq_trans order_refl tick_count_def zero_order(2))
next
  case (Suc n)
  then show ?case using assms
    by (smt tick_count_suc ticks_imp_ticks_subk)
qed

lemma precedes_sub:
  assumes \<open>sub \<lless> r\<close>
      and \<open>sub \<in> (a \<lessapprox> b)\<close>
    shows \<open>r \<in> (a \<lessapprox> b)\<close>
proof -
  from assms(1) is_subrun_def obtain f where dil:\<open>dilating f sub r\<close> by blast
  from assms(2) Precedes_def have \<open>sub \<in> {r. \<forall>n. tick_count a (hamlet r) n \<le> tick_count b (hamlet r) n}\<close> by blast
  hence \<open>r \<in> {r. \<forall>n. tick_count a (hamlet r) (f n) \<le> tick_count b (hamlet r) (f n)}\<close> by (simp add: tick_count_sub[OF dil])
  hence \<open>\<forall>n. tick_count a (hamlet r) (f n) \<le> tick_count b (hamlet r) (f n)\<close> ..
  from dil_tick_count[OF dil this] show ?thesis using Precedes_def by blast
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_weird_nat_add3acc_assoc1
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

theorem property0 :
  "((add3acc (add3acc x1 x2 x3) x4 x5) =
      (add3acc x1 x2 (add3acc x3 x4 x5)))"
  oops

end


theory T143
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


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

chapter \<open>Symbolic implementation of bit operations on int\<close>

theory Code_Symbolic_Bits_Int
imports
  More_Bits_Int
begin

section \<open>Implementations of bit operations on \<^typ>\<open>int\<close> operating on symbolic representation\<close>

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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)
 *)

theory WordAbstract
imports L2Defs ExecConcrete
begin

definition "WORD_MAX x \<equiv> ((2 ^ (len_of x - 1) - 1) :: int)"
definition "WORD_MIN x \<equiv> (- (2 ^ (len_of x - 1)) :: int)"
definition "UWORD_MAX x \<equiv> ((2 ^ (len_of x)) - 1 :: nat)"

lemma WORD_values [simplified]:
  "WORD_MAX (TYPE( 8 signed)) = (2 ^  7 - 1)"
  "WORD_MAX (TYPE(16 signed)) = (2 ^ 15 - 1)"
  "WORD_MAX (TYPE(32 signed)) = (2 ^ 31 - 1)"
  "WORD_MAX (TYPE(64 signed)) = (2 ^ 63 - 1)"

  "WORD_MIN (TYPE( 8 signed)) = - (2 ^  7)"
  "WORD_MIN (TYPE(16 signed)) = - (2 ^ 15)"
  "WORD_MIN (TYPE(32 signed)) = - (2 ^ 31)"
  "WORD_MIN (TYPE(64 signed)) = - (2 ^ 63)"

  "UWORD_MAX (TYPE( 8)) = (2 ^  8 - 1)"
  "UWORD_MAX (TYPE(16)) = (2 ^ 16 - 1)"
  "UWORD_MAX (TYPE(32)) = (2 ^ 32 - 1)"
  "UWORD_MAX (TYPE(64)) = (2 ^ 64 - 1)"
  by (auto simp: WORD_MAX_def WORD_MIN_def UWORD_MAX_def)

lemmas WORD_values_add1 =
   WORD_values [THEN arg_cong [where f="\<lambda>x. x + 1"],
    simplified semiring_norm, simplified numeral_One]

lemmas WORD_values_minus1 =
   WORD_values [THEN arg_cong [where f="\<lambda>x. x - 1"],
    simplified semiring_norm, simplified numeral_One nat_numeral]

lemmas [L1unfold] =
  WORD_values [symmetric]
  WORD_values_add1 [symmetric]
  WORD_values_minus1 [symmetric]

lemma WORD_signed_to_unsigned [simp]:
   "WORD_MAX TYPE('a signed) = WORD_MAX TYPE('a::len)"
   "WORD_MIN TYPE('a signed) = WORD_MIN TYPE('a::len)"
   "UWORD_MAX TYPE('a signed) = UWORD_MAX TYPE('a::len)"
  by (auto simp: WORD_MAX_def WORD_MIN_def UWORD_MAX_def)

(*
 * The following set of theorems allow us to discharge simple
 * equalities involving INT_MIN, INT_MAX and UINT_MAX without
 * the constants being unfolded in the final output.
 *
 * For example:
 *
 *    (4 < INT_MAX)  becomes  True
 *    (x < INT_MAX)  remains  (x < INT_MAX)
 *)

lemma INT_MIN_comparisons [simp]:
  "\<lbrakk> a \<le> - (2 ^ (len_of TYPE('a) - 1)) \<rbrakk> \<Longrightarrow> a \<le> WORD_MIN (TYPE('a::len))"
  "a < - (2 ^ (len_of TYPE('a) - 1)) \<Longrightarrow> a < WORD_MIN (TYPE('a::len))"
  "a \<ge> - (2 ^ (len_of TYPE('a) - 1)) \<Longrightarrow> a \<ge> WORD_MIN (TYPE('a::len))"
  "a > - (2 ^ (len_of TYPE('a) - 1)) \<Longrightarrow> a \<ge> WORD_MIN (TYPE('a::len))"
  by (auto simp: WORD_MIN_def)

lemma INT_MAX_comparisons [simp]:
  "a \<le> (2 ^ (len_of TYPE('a) - 1)) - 1 \<Longrightarrow> a \<le> WORD_MAX (TYPE('a::len))"
  "a < (2 ^ (len_of TYPE('a) - 1)) - 1 \<Longrightarrow> a < WORD_MAX (TYPE('a::len))"
  "a \<ge> (2 ^ (len_of TYPE('a) - 1)) - 1 \<Longrightarrow> a \<ge> WORD_MAX (TYPE('a::len))"
  "a > (2 ^ (len_of TYPE('a) - 1)) - 1 \<Longrightarrow> a \<ge> WORD_MAX (TYPE('a::len))"
  by (auto simp: WORD_MAX_def)

lemma UINT_MAX_comparisons [simp]:
  "x \<le> (2 ^ (len_of TYPE('a))) - 1 \<Longrightarrow> x \<le> UWORD_MAX (TYPE('a::len))"
  "x < (2 ^ (len_of TYPE('a))) - 1 \<Longrightarrow> x \<le> UWORD_MAX (TYPE('a::len))"
  "x \<ge> (2 ^ (len_of TYPE('a))) - 1 \<Longrightarrow> x \<ge> UWORD_MAX (TYPE('a::len))"
  "x > (2 ^ (len_of TYPE('a))) - 1 \<Longrightarrow> x > UWORD_MAX (TYPE('a::len))"
  by (auto simp: UWORD_MAX_def)

(*
 * This definition is used when we are trying to introduce a new type
 * in the program text: it simply states that introducing a given
 * abstraction is desired in the current context.
 *)
definition "introduce_typ_abs_fn f \<equiv> True"

declare introduce_typ_abs_fn_def [simp]

lemma introduce_typ_abs_fn:
  "introduce_typ_abs_fn f"
  by simp

(*
 * Show that a binary operator "X" (of type "'a \<Rightarrow> 'a \<Rightarrow> bool") is an
 * abstraction (over function f) of "X'".
 *
 * For example, (a \<le>\<^sub>i\<^sub>n\<^sub>t b) could be an abstraction of (a \<le>\<^sub>w\<^sub>3\<^sub>2 b)
 * over the abstraction function "unat".
 *)
definition
  abstract_bool_binop :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'a)
               \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> bool"
where
  "abstract_bool_binop P f X X' \<equiv> \<forall>a b. P (f a) (f b) \<longrightarrow> (X' a b = X (f a) (f b))"

(* Show that a binary operator "X" (of type "'a \<Rightarrow> 'a \<Rightarrow> 'b") abstracts "X'". *)
definition
  abstract_binop :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'a)
               \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> bool"
where
   "abstract_binop P f X X' \<equiv> \<forall>a b. P (f a) (f b) \<longrightarrow> (f (X' a b) = X (f a) (f b))"

(* The value "a" is the abstract version of "b" under precondition "P". *)
definition "abstract_val P a f b \<equiv> P \<longrightarrow> (a = f b)"

(* The variable "a" is the abstracted version of the variable "b". *)
definition "abs_var a f b \<equiv> abstract_val True a f b"

declare abstract_bool_binop_def [simp]
declare abstract_binop_def [simp]
declare abstract_val_def [simp]
declare abs_var_def [simp]

lemma abstract_val_trivial:
  "abstract_val True (f b) f b"
  by simp

lemma abstract_binop_is_abstract_val:
    "abstract_binop P f X X' = (\<forall>a b. abstract_val (P (f a) (f b)) (X (f a) (f b)) f (X' a b))"
  by auto

lemma abstract_expr_bool_binop:
  "\<lbrakk> abstract_bool_binop E f X X';
     introduce_typ_abs_fn f;
     abstract_val P a f a';
     abstract_val Q b f b' \<rbrakk> \<Longrightarrow>
           abstract_val (P \<and> Q \<and> E a b) (X a b) id (X' a' b')"
  by clarsimp

lemma abstract_expr_binop:
  "\<lbrakk> abstract_binop E f X X';
     abstract_val P a f a';
     abstract_val Q b f b' \<rbrakk> \<Longrightarrow>
           abstract_val (P \<and> Q \<and> E a b) (X a b) f (X' a' b')"
  by clarsimp

lemma unat_abstract_bool_binops:
    "abstract_bool_binop (\<lambda>_ _. True) (unat :: ('a::len) word \<Rightarrow> nat) (op <) (op <)"
    "abstract_bool_binop (\<lambda>_ _. True) (unat :: ('a::len) word \<Rightarrow> nat) (op \<le>) (op \<le>)"
    "abstract_bool_binop (\<lambda>_ _. True) (unat :: ('a::len) word \<Rightarrow> nat) (op =) (op =)"
  by (auto simp:  word_less_nat_alt word_le_nat_alt eq_iff)

lemmas unat_mult_simple = iffD1 [OF unat_mult_lem [unfolded word_bits_len_of]]

lemma le_to_less_plus_one:
    "((a::nat) \<le> b) = (a < b + 1)"
  by arith

lemma unat_abstract_binops:
  "abstract_binop (\<lambda>a b. a + b \<le> UWORD_MAX TYPE('a::len)) (unat :: 'a word \<Rightarrow> nat) (op +) (op +)"
  "abstract_binop (\<lambda>a b. a * b \<le> UWORD_MAX TYPE('a)) (unat :: 'a word \<Rightarrow> nat) (op * ) (op * )"
  "abstract_binop (\<lambda>a b. a \<ge> b) (unat :: 'a word \<Rightarrow> nat) (op -) (op -)"
  "abstract_binop (\<lambda>a b. True) (unat :: 'a word \<Rightarrow> nat) (op div) (op div)"
  "abstract_binop (\<lambda>a b. True) (unat :: 'a word \<Rightarrow> nat) (op mod) (op mod)"
  by (auto simp: unat_plus_if' unat_div unat_mod UWORD_MAX_def le_to_less_plus_one
              WordAbstract.unat_mult_simple word_bits_def unat_sub word_le_nat_alt)

lemma snat_abstract_bool_binops:
    "abstract_bool_binop (\<lambda>_ _. True) (sint :: ('a::len) signed word \<Rightarrow> int) (op <) (word_sless)"
    "abstract_bool_binop (\<lambda>_ _. True) (sint :: 'a signed word \<Rightarrow> int) (op \<le>) (word_sle)"
    "abstract_bool_binop (\<lambda>_ _. True) (sint :: 'a signed word \<Rightarrow> int) (op =) (op =)"
  by (auto simp: word_sless_def word_sle_def less_le)

lemma snat_abstract_binops:
  "abstract_binop (\<lambda>a b. WORD_MIN TYPE('a::len) \<le> a + b \<and> a + b \<le> WORD_MAX TYPE('a)) (sint :: 'a signed word \<Rightarrow> int) (op +) (op +)"
  "abstract_binop (\<lambda>a b. WORD_MIN TYPE('a) \<le> a * b \<and> a * b \<le> WORD_MAX TYPE('a)) (sint :: 'a signed word \<Rightarrow> int) (op *) (op *)"
  "abstract_binop (\<lambda>a b. WORD_MIN TYPE('a) \<le> a - b \<and> a - b \<le> WORD_MAX TYPE('a)) (sint :: 'a signed word \<Rightarrow> int) (op -) (op -)"
  "abstract_binop (\<lambda>a b. WORD_MIN TYPE('a) \<le> a sdiv b \<and> a sdiv b \<le> WORD_MAX TYPE('a)) (sint :: 'a signed word \<Rightarrow> int) (op sdiv) (op sdiv)"
  "abstract_binop (\<lambda>a b. WORD_MIN TYPE('a) \<le> a smod b \<and> a smod b \<le> WORD_MAX TYPE('a)) (sint :: 'a signed word \<Rightarrow> int) (op smod) (op smod)"
  by (auto simp: signed_arith_sint word_size WORD_MIN_def WORD_MAX_def)

lemma abstract_val_signed_unary_minus:
  "\<lbrakk> abstract_val P r sint r' \<rbrakk> \<Longrightarrow>
       abstract_val (P \<and> (- r) \<le> WORD_MAX TYPE('a)) (- r) sint ( - (r' :: ('a :: len) signed word))"
  apply clarsimp
  using sint_range_size [where w=r']
  apply -
  apply (subst signed_arith_sint)
   apply (clarsimp simp: word_size WORD_MAX_def)
  apply simp
  done

lemma abstract_val_unsigned_unary_minus:
  "\<lbrakk> abstract_val P r unat r' \<rbrakk> \<Longrightarrow>
       abstract_val P (if r = 0 then 0 else UWORD_MAX TYPE('a::len) + 1 - r) unat ( - (r' :: 'a word))"
  by (clarsimp simp: unat_minus' word_size unat_eq_zero UWORD_MAX_def)

lemmas abstract_val_signed_ops [simplified simp_thms] =
  abstract_expr_bool_binop [OF snat_abstract_bool_binops(1)]
  abstract_expr_bool_binop [OF snat_abstract_bool_binops(2)]
  abstract_expr_bool_binop [OF snat_abstract_bool_binops(3)]
  abstract_expr_binop [OF snat_abstract_binops(1)]
  abstract_expr_binop [OF snat_abstract_binops(2)]
  abstract_expr_binop [OF snat_abstract_binops(3)]
  abstract_expr_binop [OF snat_abstract_binops(4)]
  abstract_expr_binop [OF snat_abstract_binops(5)]
  abstract_val_signed_unary_minus

lemmas abstract_val_unsigned_ops [simplified simp_thms] =
  abstract_expr_bool_binop [OF unat_abstract_bool_binops(1)]
  abstract_expr_bool_binop [OF unat_abstract_bool_binops(2)]
  abstract_expr_bool_binop [OF unat_abstract_bool_binops(3)]
  abstract_expr_binop [OF unat_abstract_binops(1)]
  abstract_expr_binop [OF unat_abstract_binops(2)]
  abstract_expr_binop [OF unat_abstract_binops(3)]
  abstract_expr_binop [OF unat_abstract_binops(4)]
  abstract_expr_binop [OF unat_abstract_binops(5)]
  abstract_val_unsigned_unary_minus

lemma mod_less:
  "(a :: nat) < c \<Longrightarrow> a mod b < c"
  by (metis less_trans mod_less_eq_dividend order_leE)

lemma abstract_val_ucast:
    "\<lbrakk> introduce_typ_abs_fn (unat :: ('a::len) word \<Rightarrow> nat);
       abstract_val P v unat v' \<rbrakk>
       \<Longrightarrow>  abstract_val (P \<and> v \<le> nat (WORD_MAX TYPE('a)))
                  (int v) sint (ucast (v' :: 'a word) :: 'a signed word)"
  apply (clarsimp simp: uint_nat [symmetric])
  apply (subst sint_eq_uint)
   apply (rule not_msb_from_less)
   apply (clarsimp simp: word_less_nat_alt unat_ucast WORD_MAX_def le_to_less_plus_one)
   apply (subst (asm) nat_diff_distrib)
     apply simp
    apply clarsimp
   apply clarsimp
   apply (metis of_nat_numeral nat_numeral nat_power_eq of_nat_0_le_iff)
  apply (clarsimp simp: uint_up_ucast is_up)
  done

lemma abstract_val_scast:
    "\<lbrakk> introduce_typ_abs_fn (sint :: ('a::len) signed word \<Rightarrow> int);
       abstract_val P C' sint C \<rbrakk>
            \<Longrightarrow>  abstract_val (P \<and> 0 \<le> C') (nat C') unat (scast (C :: ('a::len) signed word) :: ('a::len) word)"
  apply (clarsimp simp: down_cast_same [symmetric] is_down unat_ucast)
  apply (subst sint_eq_uint)
   apply (clarsimp simp: word_msb_sint)
  apply (clarsimp simp: unat_def [symmetric])
  apply (subst word_unat.norm_Rep [symmetric])
  apply clarsimp
  done

lemma abstract_val_scast_upcast:
    "\<lbrakk> len_of TYPE('a::len) \<le> len_of TYPE('b::len);
       abstract_val P C' sint C \<rbrakk>
            \<Longrightarrow>  abstract_val P (C') sint (scast (C :: 'a signed word) :: 'b signed word)"
  by (clarsimp simp: down_cast_same [symmetric] sint_up_scast is_up)

lemma abstract_val_scast_downcast:
    "\<lbrakk> len_of TYPE('b) < len_of TYPE('a::len);
       abstract_val P C' sint C \<rbrakk>
            \<Longrightarrow>  abstract_val P (sbintrunc ((len_of TYPE('b::len) - 1)) C') sint (scast (C :: 'a signed word) :: 'b signed word)"
  apply (clarsimp simp: scast_def word_of_int_def sint_uint bintrunc_mod2p [symmetric])
  apply (subst bintrunc_sbintrunc_le)
   apply clarsimp
  apply (subst Abs_word_inverse)
   apply (metis len_signed uint word_ubin.eq_norm)
  apply clarsimp
  done

lemma abstract_val_ucast_upcast:
    "\<lbrakk> len_of TYPE('a::len) \<le> len_of TYPE('b::len);
       abstract_val P C' unat C \<rbrakk>
            \<Longrightarrow>  abstract_val P (C') unat (ucast (C :: 'a word) :: 'b word)"
  by (clarsimp simp: is_up unat_ucast_upcast)

lemma abstract_val_ucast_downcast:
    "\<lbrakk> len_of TYPE('b::len) < len_of TYPE('a::len);
       abstract_val P C' unat C \<rbrakk>
            \<Longrightarrow>  abstract_val P (C' mod (UWORD_MAX TYPE('b) + 1)) unat (ucast (C :: 'a word) :: 'b word)"
  apply (clarsimp simp: scast_def word_of_int_def sint_uint UWORD_MAX_def)
  unfolding ucast_def unat_def
  apply (subst int_word_uint)
  apply (metis (hide_lams, mono_tags) uint_mod uint_power_lower
      unat_def unat_mod unat_power_lower)
  done

(*
 * The pair A/C are a valid abstraction/concrete-isation function pair,
 * under the precondition's P and Q.
 *)
definition
 "valid_typ_abs_fn (P :: 'a \<Rightarrow> bool) (Q :: 'a \<Rightarrow> bool) (A :: 'c \<Rightarrow> 'a) (C :: 'a \<Rightarrow> 'c) \<equiv>
     (\<forall>v. P v \<longrightarrow> A (C v) = v) \<and> (\<forall>v. Q (A v) \<longrightarrow> C (A v) = v)"

declare valid_typ_abs_fn_def [simp]

lemma valid_typ_abs_fn_id:
  "valid_typ_abs_fn \<top> \<top> id id"
  by clarsimp

lemma valid_typ_abs_fn_unit:
  "valid_typ_abs_fn \<top> \<top> id (id :: unit \<Rightarrow> unit)"
  by clarsimp

lemma valid_typ_abs_fn_unat:
  "valid_typ_abs_fn (\<lambda>v. v \<le> UWORD_MAX TYPE('a::len)) \<top> (unat :: 'a word \<Rightarrow> nat) (of_nat :: nat \<Rightarrow> 'a word)"
  by (clarsimp simp: unat_of_nat_eq UWORD_MAX_def le_to_less_plus_one)

lemma valid_typ_abs_fn_sint:
  "valid_typ_abs_fn (\<lambda>v. WORD_MIN TYPE('a::len) \<le> v \<and> v \<le> WORD_MAX TYPE('a)) \<top> (sint :: 'a signed word \<Rightarrow> int) (of_int :: int \<Rightarrow> 'a signed word)"
  by (clarsimp simp: sint_of_int_eq WORD_MIN_def WORD_MAX_def)

lemma valid_typ_abs_fn_tuple:
  "\<lbrakk> valid_typ_abs_fn P_a Q_a abs_a conc_a; valid_typ_abs_fn P_b Q_b abs_b conc_b \<rbrakk> \<Longrightarrow>
          valid_typ_abs_fn (\<lambda>(a, b). P_a a \<and> P_b b) (\<lambda>(a, b). Q_a a \<and> Q_b b) (map_prod abs_a abs_b) (map_prod conc_a conc_b)"
  by clarsimp

lemma introduce_typ_abs_fn_tuple:
  "\<lbrakk> introduce_typ_abs_fn abs_a; introduce_typ_abs_fn abs_b \<rbrakk> \<Longrightarrow>
         introduce_typ_abs_fn (map_prod abs_a abs_b)"
  by clarsimp

definition [simp]:
  "corresTA P rx ex A C \<equiv> corresXF (\<lambda>s. s) (\<lambda>r s. rx r) (\<lambda>r s. ex r) P A C"

lemma corresTA_L2_gets:
  "\<lbrakk> \<And>s. abstract_val (Q s) (C s) rx (C' s) \<rbrakk> \<Longrightarrow>
     corresTA Q rx ex (L2_gets (\<lambda>s. C s) n) (L2_gets (\<lambda>s. C' s) n)"
  apply (monad_eq simp: L2_defs corresXF_def)
  done

lemma corresTA_L2_modify:
    "\<lbrakk> \<And>s. abstract_val (P s) (m s) id (m' s) \<rbrakk> \<Longrightarrow>
            corresTA P rx ex (L2_modify (\<lambda>s. m s)) (L2_modify (\<lambda>s. m' s))"
  by (monad_eq simp: L2_modify_def corresXF_def)

lemma corresTA_L2_throw:
  "\<lbrakk> abstract_val Q C ex C' \<rbrakk> \<Longrightarrow>
     corresTA (\<lambda>_. Q) rx ex (L2_throw C n) (L2_throw C' n)"
  apply (monad_eq simp: L2_defs corresXF_def)
  done

lemma corresTA_L2_skip:
  "corresTA \<top> rx ex L2_skip L2_skip"
  apply (monad_eq simp: L2_defs corresXF_def)
  done

lemma corresTA_L2_fail:
  "corresTA \<top> rx ex L2_fail L2_fail"
  by (clarsimp simp: L2_defs corresXF_def)

lemma corresTA_L2_seq':
  fixes L' :: "('s, 'e + 'c1) nondet_monad"
  fixes R' :: "'c1 \<Rightarrow> ('s, 'e + 'c2) nondet_monad"
  fixes L :: "('s, 'ea + 'a1) nondet_monad"
  fixes R :: "'a1 \<Rightarrow> ('s, 'ea + 'a2) nondet_monad"
  shows
  "\<lbrakk> corresTA P rx1 ex L L';
     \<And>r. corresTA (Q (rx1 r)) rx2 ex (R (rx1 r)) (R' r) \<rbrakk> \<Longrightarrow>
    corresTA P rx2 ex
       (L2_seq L (\<lambda>r. L2_seq (L2_guard (\<lambda>s. Q r s)) (\<lambda>_. R r)))
       (L2_seq L' (\<lambda>r. R' r))"
  apply atomize
  apply (clarsimp simp: L2_seq_def L2_guard_def)
  apply (erule corresXF_join [where P'="\<lambda>x y s. rx1 y = x"])
    apply (monad_eq simp: corresXF_def split: sum.splits)
   apply clarsimp
   apply (rule hoareE_TrueI)
  apply simp
  done

lemma corresTA_L2_seq:
  "\<lbrakk> introduce_typ_abs_fn rx1;
    corresTA P (rx1 :: 'a \<Rightarrow> 'b) ex L L';
     \<And>r r'. abs_var r rx1 r' \<Longrightarrow> corresTA (\<lambda>s. Q r s) rx2 ex (\<lambda>s. R r s) (\<lambda>s. R' r' s) \<rbrakk> \<Longrightarrow>
       corresTA P rx2 ex (L2_seq L (\<lambda>r. L2_seq (L2_guard (\<lambda>s. Q r s)) (\<lambda>_ s. R r s))) (L2_seq L' (\<lambda>r s. R' r s))"
  by (rule corresTA_L2_seq', simp+)

lemma corresTA_L2_seq_unit:
  fixes L' :: "('s, 'e + unit) nondet_monad"
  fixes R' :: "unit \<Rightarrow> ('s, 'e + 'r) nondet_monad"
  fixes L :: "('s, 'ea + unit) nondet_monad"
  fixes R :: "('s, 'ea + 'ra) nondet_monad"
  shows
  "\<lbrakk> corresTA P id ex L L';
     corresTA Q rx ex (\<lambda>s. R s) (\<lambda>s. R' () s) \<rbrakk> \<Longrightarrow>
    corresTA P rx ex
       (L2_seq L (\<lambda>r. L2_seq (L2_guard Q) (\<lambda>r s. R s)))
       (L2_seq L' (\<lambda>r s. R' r s))"
  by (rule corresTA_L2_seq', simp+)

lemma corresTA_L2_catch':
  fixes L' :: "('s, 'e1 + 'c) nondet_monad"
  fixes R' :: "'e1 \<Rightarrow> ('s, 'e2 + 'c) nondet_monad"
  fixes L :: "('s, 'e1a + 'ca) nondet_monad"
  fixes R :: "'e1a \<Rightarrow> ('s, 'e2a + 'ca) nondet_monad"
  shows
  "\<lbrakk> corresTA P rx ex1 L L';
     \<And>r. corresTA (Q (ex1 r)) rx ex2 (R (ex1 r)) (R' r) \<rbrakk> \<Longrightarrow>
    corresTA P rx ex2 (L2_catch L (\<lambda>r. L2_seq (L2_guard (\<lambda>s. Q r s)) (\<lambda>_. R r))) (L2_catch L' (\<lambda>r. R' r))"
  apply atomize
  apply (clarsimp simp: L2_seq_def L2_catch_def L2_guard_def)
  apply (erule corresXF_except [where P'="\<lambda>x y s. ex1 y = x"])
    apply (monad_eq simp: corresXF_def split: sum.splits cong: rev_conj_cong)
   apply clarsimp
   apply (rule hoareE_TrueI)
  apply simp
  done

lemma corresTA_L2_catch:
  "\<lbrakk> introduce_typ_abs_fn ex1;
     corresTA P rx ex1 L L';
     \<And>r r'. abs_var r ex1 r' \<Longrightarrow> corresTA (Q r) rx ex2 (R r) (R' r') \<rbrakk> \<Longrightarrow>
       corresTA P rx ex2 (L2_catch L (\<lambda>r. L2_seq (L2_guard (\<lambda>s. Q r s)) (\<lambda>_. R r))) (L2_catch L' (\<lambda>r. R' r))"
  by (rule corresTA_L2_catch', simp+)

lemma corresTA_L2_while:
  assumes init_corres: "abstract_val Q i rx i'"
  and cond_corres: "\<And>r r' s. abs_var r rx r'
                           \<Longrightarrow> abstract_val (G r s) (C r s) id (C' r' s)"
  and body_corres: "\<And>r r'. abs_var r rx r'
                           \<Longrightarrow> corresTA (P r) rx ex (B r) (B' r')"
  shows "corresTA (\<lambda>_. Q) rx ex
       (L2_guarded_while (\<lambda>r s. G r s) (\<lambda>r s. C r s) (\<lambda>r. L2_seq (L2_guard (\<lambda>s. P r s)) (\<lambda>_. B r)) i x)
       (L2_while (\<lambda>r s. C' r s) B' i' x)"
proof -
  note body_corres' =
       corresXF_guarded_while_body [OF body_corres [unfolded corresTA_def]]

  have init_corres':
    "Q \<Longrightarrow> i = rx i'"
    using init_corres
    by simp

  show ?thesis
    apply (clarsimp simp: L2_defs guardE_def [symmetric] returnOk_liftE [symmetric])
    apply (rule corresXF_assume_pre)
    apply (rule corresXF_guarded_while [where P="\<lambda>r s. G (rx r) s"])
        apply (cut_tac r'=x in body_corres, simp)
        apply (monad_eq simp: guardE_def corresXF_def split: sum.splits)
       apply (insert cond_corres)[1]
       apply clarsimp
      apply clarsimp
      apply (rule hoareE_TrueI)
     apply (clarsimp simp: init_corres)
     apply (insert init_corres)[1]
     apply (clarsimp)
    apply (clarsimp simp: init_corres')
  done
qed

lemma corresTA_L2_guard:
  "\<lbrakk> \<And>s. abstract_val (Q s) (G s) id (G' s) \<rbrakk>
           \<Longrightarrow> corresTA \<top> rx ex (L2_guard (\<lambda>s. G s \<and> Q s)) (L2_guard (\<lambda>s. G' s))"
  apply (monad_eq simp: L2_defs corresXF_def)
  done

lemma corresTA_L2_spec:
  "(\<And>s t. abstract_val (Q s) (P s t) id (P' s t)) \<Longrightarrow>
   corresTA Q rx ex (L2_spec {(s, t). P s t}) (L2_spec {(s, t). P' s t})"
  apply (monad_eq simp: L2_defs corresXF_def in_liftE split: sum.splits)
  apply (erule exI)
  done

lemma corresTA_L2_condition:
  "\<lbrakk> corresTA P rx ex L L';
     corresTA Q rx ex R R';
     \<And>s. abstract_val (T s) (C s) id (C' s)  \<rbrakk>
   \<Longrightarrow> corresTA T rx ex
          (L2_condition (\<lambda>s. C s)
            (L2_seq (L2_guard P) (\<lambda>_. L))
            (L2_seq (L2_guard Q) (\<lambda>_. R))
           ) (L2_condition (\<lambda>s. C' s) L' R')"
  apply atomize
  apply (monad_eq simp: L2_defs corresXF_def Ball_def split: sum.splits)
  apply force
  done

(* Backup rule to corresTA_L2_call. Converts the return type of the function call. *)
lemma corresTA_L2_call':
  "\<lbrakk> corresTA P f1 x1 A B;
     valid_typ_abs_fn Q1 Q1' f1 f1';
     valid_typ_abs_fn Q2 Q2' f2 f2'
   \<rbrakk> \<Longrightarrow>
   corresTA (\<lambda>s. P s) f2 x2
       (L2_seq (L2_call A) (\<lambda>ret. (L2_seq (L2_guard (\<lambda>_. Q1' ret)) (\<lambda>_. L2_gets (\<lambda>_. f2 (f1' ret)) [''ret'']))))
       (L2_call B)"
  apply (clarsimp simp: L2_defs L2_call_def corresXF_def)
  apply (monad_eq split: sum.splits)
  apply (rule conjI)
   apply metis
  apply clarsimp
  apply blast
  done

lemma corresTA_L2_call:
  "\<lbrakk> corresTA P rx ex A B \<rbrakk> \<Longrightarrow>
        corresTA P rx ex' (L2_call A) (L2_call B)"
  apply (clarsimp simp: L2_defs L2_call_def corresXF_def)
  apply (monad_eq split: sum.splits)
  apply fastforce
  done

lemma corresTA_measure_call:
  "\<lbrakk> monad_mono B; \<And>m. corresTA P rx id (A m) (B m) \<rbrakk> \<Longrightarrow>
        corresTA P rx id (measure_call A) (measure_call B)"
  by (simp add: corresXF_measure_call)

lemma corresTA_L2_unknown:
  "corresTA \<top> rx ex (L2_unknown x) (L2_unknown x)"
  apply (monad_eq simp: L2_defs corresXF_def)
  done

lemma corresTA_L2_call_exec_concrete:
  "\<lbrakk> corresTA P rx id A B \<rbrakk> \<Longrightarrow>
        corresTA (\<lambda>s. \<forall>s'. s = st s' \<longrightarrow> P s') rx id
               (exec_concrete st (L2_call A))
               (exec_concrete st (L2_call B))"
  apply (clarsimp simp: L2_defs L2_call_def corresXF_def)
  apply (monad_eq split: sum.splits)
  apply fastforce
  done

lemma corresTA_L2_call_exec_abstract:
  "\<lbrakk> corresTA P rx id A B \<rbrakk> \<Longrightarrow>
        corresTA (\<lambda>s. P (st s)) rx id
               (exec_abstract st (L2_call A))
               (exec_abstract st (L2_call B))"
  apply (clarsimp simp: L2_defs L2_call_def corresXF_def)
  apply (monad_eq split: sum.splits)
  apply fastforce
  done

(* More backup rules for calls. *)
lemma corresTA_L2_call_exec_concrete':
  "\<lbrakk> corresTA P f1 x1 A B;
     valid_typ_abs_fn Q1 Q1' f1 f1';
     valid_typ_abs_fn Q2 Q2' f2 f2'
   \<rbrakk> \<Longrightarrow>
   corresTA (\<lambda>s. \<forall>s'. s = st s' \<longrightarrow> P s') f2 x2
       (L2_seq (exec_concrete st (L2_call A)) (\<lambda>ret. (L2_seq (L2_guard (\<lambda>_. Q1' ret)) (\<lambda>_. L2_gets (\<lambda>_. f2 (f1' ret)) [''ret'']))))
       (exec_concrete st (L2_call B))"
  apply (clarsimp simp: L2_defs L2_call_def corresXF_def)
  apply (monad_eq split: sum.splits)
  apply (rule conjI)
   apply clarsimp
   apply metis
  apply clarsimp
  apply blast
  done

lemma corresTA_L2_call_exec_abstract':
  "\<lbrakk> corresTA P f1 x1 A B;
     valid_typ_abs_fn Q1 Q1' f1 f1';
     valid_typ_abs_fn Q2 Q2' f2 f2'
   \<rbrakk> \<Longrightarrow>
   corresTA (\<lambda>s. P (st s)) f2 x2
       (L2_seq (exec_abstract st (L2_call A)) (\<lambda>ret. (L2_seq (L2_guard (\<lambda>_. Q1' ret)) (\<lambda>_. L2_gets (\<lambda>_. f2 (f1' ret)) [''ret'']))))
       (exec_abstract st (L2_call B))"
  apply (clarsimp simp: L2_defs L2_call_def corresXF_def)
  apply (monad_eq split: sum.splits)
  apply (rule conjI)
   apply metis
  apply clarsimp
  apply blast
  done

lemma abstract_val_fun_app:
   "\<lbrakk> abstract_val Q b id b'; abstract_val P a id a' \<rbrakk> \<Longrightarrow>
           abstract_val (P \<and> Q) (f $ (a $ b)) f (a' $ b')"
  by simp

lemma corresTA_precond_to_guard:
  "corresTA (\<lambda>s. P s) rx ex A A' \<Longrightarrow> corresTA \<top> rx ex (L2_seq (L2_guard (\<lambda>s. P s)) (\<lambda>_. A)) A'"
  apply (monad_eq simp: corresXF_def L2_defs split: sum.splits)
  done

lemma corresTA_precond_to_asm:
  "\<lbrakk> \<And>s. P s \<Longrightarrow> corresTA \<top> rx ex A A' \<rbrakk> \<Longrightarrow> corresTA P rx ex A A'"
  by (clarsimp simp: corresXF_def)

lemma L2_guard_true: "L2_seq (L2_guard \<top>) A = A ()"
  by (monad_eq simp: L2_defs)
lemma corresTA_simp_trivial_guard:
  "corresTA P rx ex (L2_seq (L2_guard \<top>) A) C \<equiv> corresTA P rx ex (A ()) C"
  by (simp add: L2_guard_true)

definition "L2_assume P \<equiv> condition P (returnOk ()) (selectE {})"

lemma L2_assume_alt_def:
  "L2_assume P = (\<lambda>s. (if P s then {(Inr (), s)} else {}, False))"
  by (monad_eq simp: L2_assume_def selectE_def)

lemma corresTA_assume_values:
  "\<lbrakk> abstract_val P a f a'; corresTA \<top> rx ex X X' \<rbrakk>
              \<Longrightarrow> corresTA \<top> rx ex (L2_seq (L2_assume (\<lambda>s. P \<longrightarrow> (\<exists>a'. a = f a'))) (\<lambda>_. X)) X'"
  apply (monad_eq simp: corresXF_def L2_defs L2_assume_alt_def split: sum.splits)
  apply force
  done

lemma corresTA_extract_preconds_of_call_init:
  "\<lbrakk> corresTA (\<lambda>s. P) rx ex A A' \<rbrakk> \<Longrightarrow> corresTA (\<lambda>s. P \<and> True) rx ex A A'"
  by simp

lemma corresTA_extract_preconds_of_call_step:
  "\<lbrakk> corresTA (\<lambda>s. (abs_var a f a' \<and> R) \<and> C) rx ex A A'; abstract_val Y a f a' \<rbrakk>
           \<Longrightarrow> corresTA (\<lambda>s. R \<and> (Y \<and> C)) rx ex A A'"
  by (clarsimp simp: corresXF_def)

lemma corresTA_extract_preconds_of_call_final:
  "\<lbrakk> corresTA (\<lambda>s. (abs_var a f a') \<and> C) rx ex A A'; abstract_val Y a f a' \<rbrakk>
           \<Longrightarrow> corresTA (\<lambda>s. (Y \<and> C)) rx ex A A'"
  by (clarsimp simp: corresXF_def)

lemma corresTA_extract_preconds_of_call_final':
  "\<lbrakk> corresTA (\<lambda>s. True \<and> C) rx ex A A' \<rbrakk>
           \<Longrightarrow> corresTA (\<lambda>s. C) rx ex A A'"
  by (clarsimp simp: corresXF_def)

lemma corresTA_case_prod:
 "\<lbrakk> introduce_typ_abs_fn rx1;
    introduce_typ_abs_fn rx2;
    abstract_val (Q x) x (map_prod rx1 rx2) x';
      \<And>a b a' b'. \<lbrakk> abs_var a rx1 a'; abs_var  b rx2 b' \<rbrakk>
                      \<Longrightarrow>  corresTA (P a b) rx ex (M a b) (M' a' b') \<rbrakk>  \<Longrightarrow>
    corresTA (\<lambda>s. case x of (a, b) \<Rightarrow> P a b s \<and> Q (a, b)) rx ex (case x of (a, b) \<Rightarrow> M a b) (case x' of (a, b) \<Rightarrow> M' a b)"
  apply clarsimp
  apply (rule corresXF_assume_pre)
  apply (clarsimp simp: split_def map_prod_def)
  done

lemma abstract_val_case_prod:
  "\<lbrakk> abstract_val True r (map_prod f g) r';
       \<And>a b a' b'. \<lbrakk>  abs_var a f a'; abs_var  b g b' \<rbrakk>
                     \<Longrightarrow> abstract_val (P a b) (M a b) h (M' a' b') \<rbrakk>
       \<Longrightarrow> abstract_val (P (fst r) (snd r))
            (case r of (a, b) \<Rightarrow> M a b) h
            (case r' of (a, b) \<Rightarrow> M' a b)"
  apply (case_tac r, case_tac r')
  apply (clarsimp simp: map_prod_def)
  done

lemma abstract_val_case_prod_fun_app:
  "\<lbrakk> abstract_val True r (map_prod f g) r';
       \<And>a b a' b'. \<lbrakk>  abs_var a f a'; abs_var b g b' \<rbrakk>
                     \<Longrightarrow> abstract_val (P a b) (M a b s) h (M' a' b' s) \<rbrakk>
       \<Longrightarrow> abstract_val (P (fst r) (snd r))
            ((case r of (a, b) \<Rightarrow> M a b) s) h
            ((case r' of (a, b) \<Rightarrow> M' a b) s)"
  apply (case_tac r, case_tac r')
  apply (clarsimp simp: map_prod_def)
  done

lemma abstract_val_of_nat:
  "abstract_val (r \<le> UWORD_MAX TYPE('a::len)) r unat (of_nat r :: 'a word)"
  by (clarsimp simp: unat_of_nat_eq UWORD_MAX_def le_to_less_plus_one)

lemma abstract_val_of_int:
  "abstract_val (WORD_MIN TYPE('a::len) \<le> r \<and> r \<le> WORD_MAX TYPE('a)) r sint (of_int r :: 'a signed word)"
  by (clarsimp simp: sint_of_int_eq WORD_MIN_def WORD_MAX_def)

lemma abstract_val_tuple:
  "\<lbrakk> abstract_val P a absL a';
     abstract_val Q b absR b' \<rbrakk> \<Longrightarrow>
         abstract_val (P \<and> Q) (a, b) (map_prod absL absR) (a', b')"
  by clarsimp

lemma abstract_val_func:
   "\<lbrakk> abstract_val P a id a'; abstract_val Q b id b' \<rbrakk>
        \<Longrightarrow>  abstract_val (P \<and> Q) (f a b) id (f a' b')"
  by simp

lemma abstract_val_conj:
  "\<lbrakk> abstract_val P a id a';
        abstract_val Q b id b' \<rbrakk> \<Longrightarrow>
     abstract_val (P \<and> (a \<longrightarrow> Q)) (a \<and> b) id (a' \<and> b')"
  apply clarsimp
  apply blast
  done

lemma abstract_val_disj:
  "\<lbrakk> abstract_val P a id a';
        abstract_val Q b id b' \<rbrakk> \<Longrightarrow>
     abstract_val (P \<and> (\<not> a \<longrightarrow> Q)) (a \<or> b) id (a' \<or> b')"
  apply clarsimp
  apply blast
  done

lemma abstract_val_unwrap:
  "\<lbrakk> introduce_typ_abs_fn f; abstract_val P a f b \<rbrakk>
        \<Longrightarrow> abstract_val P a id (f b)"
  by simp

lemma abstract_val_uint:
  "\<lbrakk> introduce_typ_abs_fn unat; abstract_val P x unat x' \<rbrakk>
      \<Longrightarrow> abstract_val P (int x) id (uint x')"
  by (clarsimp simp: uint_nat)

lemma corresTA_L2_recguard:
  "corresTA (\<lambda>s. P s) rx ex A A' \<Longrightarrow>
        corresTA \<top> rx ex (L2_recguard m (L2_seq (L2_guard (\<lambda>s. P s)) (\<lambda>_. A))) (L2_recguard m A')"
  by (monad_eq simp: corresXF_def L2_defs split: sum.splits)

lemma corresTA_recguard_0:
    "corresTA st rx ex (L2_recguard 0 A) C"
  by (clarsimp simp: L2_recguard_def corresXF_def)

lemma abstract_val_lambda:
   "\<lbrakk> \<And>v. abstract_val (P v) (a v) id (a' v) \<rbrakk> \<Longrightarrow>
           abstract_val (\<forall>v. P v) (\<lambda>v. a v) id (\<lambda>v. a' v)"
  by auto

(* Rules for translating simpl wrappers. *)
lemma corresTA_call_L1:
  "abstract_val True arg_xf id arg_xf' \<Longrightarrow>
   corresTA \<top> id id
     (L2_call_L1 arg_xf gs ret_xf l1body)
     (L2_call_L1 arg_xf' gs ret_xf l1body)"
  apply (unfold corresTA_def abstract_val_def id_def)
  apply (subst (asm) simp_thms)
  apply (erule subst)
  apply (rule corresXF_id[simplified id_def])
  done

lemma abstract_val_call_L1_args:
  "abstract_val P x id x' \<Longrightarrow> abstract_val P y id y' \<Longrightarrow>
   abstract_val P (x and y) id (x' and y')"
  by simp

lemma abstract_val_call_L1_arg:
  "abs_var x id x' \<Longrightarrow> abstract_val P (\<lambda>s. f s = x) id (\<lambda>s. f s = x')"
  by simp

(* Variable abstraction *)

lemma abstract_val_abs_var [consumes 1]:
  "\<lbrakk> abs_var a f a' \<rbrakk> \<Longrightarrow> abstract_val True a f a'"
  by (clarsimp simp: fun_upd_def split: if_splits)

lemma abstract_val_abs_var_concretise [consumes 1]:
  "\<lbrakk> abs_var a A a'; introduce_typ_abs_fn A; valid_typ_abs_fn PA PC A (C :: 'a \<Rightarrow> 'c)  \<rbrakk>
      \<Longrightarrow> abstract_val (PC a) (C a) id a'"
  by (clarsimp simp: fun_upd_def split: if_splits)

lemma abstract_val_abs_var_give_up [consumes 1]:
  "\<lbrakk> abs_var a id a' \<rbrakk> \<Longrightarrow> abstract_val True (A a) A a'"
  by (clarsimp simp: fun_upd_def split: if_splits)

(* Misc *)

lemma len_of_word_comparisons [L2opt]:
  "len_of TYPE(64) \<le> len_of TYPE(64)"
  "len_of TYPE(32) \<le> len_of TYPE(64)"
  "len_of TYPE(16) \<le> len_of TYPE(64)"
  "len_of TYPE( 8) \<le> len_of TYPE(64)"
  "len_of TYPE(32) \<le> len_of TYPE(32)"
  "len_of TYPE(16) \<le> len_of TYPE(32)"
  "len_of TYPE( 8) \<le> len_of TYPE(32)"
  "len_of TYPE(16) \<le> len_of TYPE(16)"
  "len_of TYPE( 8) \<le> len_of TYPE(16)"
  "len_of TYPE( 8) \<le> len_of TYPE( 8)"

  "len_of TYPE(32) < len_of TYPE(64)"
  "len_of TYPE(16) < len_of TYPE(64)"
  "len_of TYPE( 8) < len_of TYPE(64)"
  "len_of TYPE(16) < len_of TYPE(32)"
  "len_of TYPE( 8) < len_of TYPE(32)"
  "len_of TYPE( 8) < len_of TYPE(16)"

  "len_of TYPE('a::len signed) = len_of TYPE('a)"
  "(len_of TYPE('a) = len_of TYPE('a)) = True"
  by auto

lemma scast_ucast_simps [simp, L2opt]:
  "\<lbrakk> len_of TYPE('b) \<le> len_of TYPE('a); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
         (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
  "\<lbrakk> len_of TYPE('c) \<le> len_of TYPE('a); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
         (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
  "\<lbrakk> len_of TYPE('a) \<le> len_of TYPE('b); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
         (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
  "\<lbrakk> len_of TYPE('a) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
     (scast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
  "\<lbrakk> len_of TYPE('b) \<le> len_of TYPE('a); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
            (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
  "\<lbrakk> len_of TYPE('c) \<le> len_of TYPE('a); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
     (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
  "\<lbrakk> len_of TYPE('a) \<le> len_of TYPE('b); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
     (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
  "\<lbrakk> len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
        (ucast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
  "\<lbrakk> len_of TYPE('a) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
     (ucast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
  "\<lbrakk> len_of TYPE('a) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
            (scast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
  by (auto simp: is_up is_down
      scast_ucast_1 scast_ucast_3 scast_ucast_4
      ucast_scast_1 ucast_scast_3 ucast_scast_4
      scast_scast_a scast_scast_b
      ucast_ucast_a ucast_ucast_b)

declare len_signed [L2opt]

lemmas [L2opt] = zero_sle_ucast_up

lemma zero_sle_ucast_WORD_MAX [L2opt]:
  "(0 <=s ((ucast (b::('a::len) word)) :: ('a::len) signed word))
                = (uint b \<le> WORD_MAX (TYPE('a)))"
  by (clarsimp simp: WORD_MAX_def zero_sle_ucast)

lemmas [L2opt] =
    is_up is_down unat_ucast_upcast sint_ucast_eq_uint

lemmas [L2opt] =
    ucast_down_add scast_down_add
    ucast_down_minus scast_down_minus
    ucast_down_mult scast_down_mult

(*
 * Setup word abstraction rules.
 *)

named_theorems word_abs

(* Common word abstraction rules. *)

lemmas [word_abs] =
  corresTA_L2_gets
  corresTA_L2_modify
  corresTA_L2_throw
  corresTA_L2_skip
  corresTA_L2_fail
  corresTA_L2_seq
  corresTA_L2_seq_unit
  corresTA_L2_catch
  corresTA_L2_while
  corresTA_L2_guard
  corresTA_L2_spec
  corresTA_L2_condition
  corresTA_L2_unknown
  corresTA_L2_recguard
  corresTA_case_prod
  corresTA_L2_call_exec_concrete'
  corresTA_L2_call_exec_concrete
  corresTA_L2_call_exec_abstract'
  corresTA_L2_call_exec_abstract
  corresTA_L2_call'
  corresTA_L2_call
  corresTA_measure_call
  corresTA_call_L1

lemmas [word_abs] =
  abstract_val_tuple
  abstract_val_conj
  abstract_val_disj
  abstract_val_case_prod
  abstract_val_trivial
  abstract_val_of_int
  abstract_val_of_nat

  abstract_val_call_L1_arg
  abstract_val_call_L1_args

  abstract_val_abs_var_give_up
  abstract_val_abs_var_concretise
  abstract_val_abs_var

lemmas word_abs_base [word_abs] =
  valid_typ_abs_fn_id [where 'a="'a::c_type"]
  valid_typ_abs_fn_id [where 'a="bool"]
  valid_typ_abs_fn_id [where 'a="c_exntype"]
  valid_typ_abs_fn_tuple
  valid_typ_abs_fn_unit
  valid_typ_abs_fn_sint
  valid_typ_abs_fn_unat
  len_of_word_comparisons

(*
 * Signed word abstraction rules: 'a sword \<rightarrow> int
 *)

lemmas word_abs_sword =
  abstract_val_signed_ops
  abstract_val_scast
  abstract_val_scast_upcast
  abstract_val_scast_downcast
  abstract_val_unwrap [where f=sint]
  introduce_typ_abs_fn [where f="sint :: (sword64 \<Rightarrow> int)"]
  introduce_typ_abs_fn [where f="sint :: (sword32 \<Rightarrow> int)"]
  introduce_typ_abs_fn [where f="sint :: (sword16 \<Rightarrow> int)"]
  introduce_typ_abs_fn [where f="sint :: (sword8 \<Rightarrow> int)"]

(*
 * Unsigned word abstraction rules: 'a word \<rightarrow> nat
 *)

lemmas word_abs_word =
  abstract_val_unsigned_ops
  abstract_val_uint
  abstract_val_ucast
  abstract_val_ucast_upcast
  abstract_val_ucast_downcast
  abstract_val_unwrap [where f=unat]
  introduce_typ_abs_fn [where f="unat :: (word64 \<Rightarrow> nat)"]
  introduce_typ_abs_fn [where f="unat :: (word32 \<Rightarrow> nat)"]
  introduce_typ_abs_fn [where f="unat :: (word16 \<Rightarrow> nat)"]
  introduce_typ_abs_fn [where f="unat :: (word8 \<Rightarrow> nat)"]

(* 'a \<rightarrow> 'a *)
lemmas word_abs_default =
  introduce_typ_abs_fn [where f="id :: ('a::c_type \<Rightarrow> 'a)"]
  introduce_typ_abs_fn [where f="id :: (bool \<Rightarrow> bool)"]
  introduce_typ_abs_fn [where f="id :: (c_exntype \<Rightarrow> c_exntype)"]
  introduce_typ_abs_fn [where f="id :: (unit \<Rightarrow> unit)"]
  introduce_typ_abs_fn_tuple

end


(*  Title:      HOL/Algebra/Order.thy
    Author:     Clemens Ballarin, started 7 November 2003
    Copyright:  Clemens Ballarin

Most congruence rules by Stephan Hohe.
With additional contributions from Alasdair Armstrong and Simon Foster.
*)

theory Order
imports
  "~~/src/HOL/Library/FuncSet"
  Congruence
begin

section \<open>Orders\<close>

subsection \<open>Partial Orders\<close>

record 'a gorder = "'a eq_object" +
  le :: "['a, 'a] => bool" (infixl "\<sqsubseteq>\<index>" 50)

abbreviation inv_gorder :: "_ \<Rightarrow> 'a gorder" where
  "inv_gorder L \<equiv>
   \<lparr> carrier = carrier L,
     eq = op .=\<^bsub>L\<^esub>,
     le = (\<lambda> x y. y \<sqsubseteq>\<^bsub>L \<^esub>x) \<rparr>"

lemma inv_gorder_inv:
  "inv_gorder (inv_gorder L) = L"
  by simp

locale weak_partial_order = equivalence L for L (structure) +
  assumes le_refl [intro, simp]:
      "x \<in> carrier L ==> x \<sqsubseteq> x"
    and weak_le_antisym [intro]:
      "[| x \<sqsubseteq> y; y \<sqsubseteq> x; x \<in> carrier L; y \<in> carrier L |] ==> x .= y"
    and le_trans [trans]:
      "[| x \<sqsubseteq> y; y \<sqsubseteq> z; x \<in> carrier L; y \<in> carrier L; z \<in> carrier L |] ==> x \<sqsubseteq> z"
    and le_cong:
      "\<lbrakk> x .= y; z .= w; x \<in> carrier L; y \<in> carrier L; z \<in> carrier L; w \<in> carrier L \<rbrakk> \<Longrightarrow>
      x \<sqsubseteq> z \<longleftrightarrow> y \<sqsubseteq> w"

definition
  lless :: "[_, 'a, 'a] => bool" (infixl "\<sqsubset>\<index>" 50)
  where "x \<sqsubset>\<^bsub>L\<^esub> y \<longleftrightarrow> x \<sqsubseteq>\<^bsub>L\<^esub> y & x .\<noteq>\<^bsub>L\<^esub> y"

subsubsection \<open>The order relation\<close>

context weak_partial_order
begin

lemma le_cong_l [intro, trans]:
  "\<lbrakk> x .= y; y \<sqsubseteq> z; x \<in> carrier L; y \<in> carrier L; z \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
  by (auto intro: le_cong [THEN iffD2])

lemma le_cong_r [intro, trans]:
  "\<lbrakk> x \<sqsubseteq> y; y .= z; x \<in> carrier L; y \<in> carrier L; z \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
  by (auto intro: le_cong [THEN iffD1])

lemma weak_refl [intro, simp]: "\<lbrakk> x .= y; x \<in> carrier L; y \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> y"
  by (simp add: le_cong_l)

end

lemma weak_llessI:
  fixes R (structure)
  assumes "x \<sqsubseteq> y" and "~(x .= y)"
  shows "x \<sqsubset> y"
  using assms unfolding lless_def by simp

lemma lless_imp_le:
  fixes R (structure)
  assumes "x \<sqsubset> y"
  shows "x \<sqsubseteq> y"
  using assms unfolding lless_def by simp

lemma weak_lless_imp_not_eq:
  fixes R (structure)
  assumes "x \<sqsubset> y"
  shows "\<not> (x .= y)"
  using assms unfolding lless_def by simp

lemma weak_llessE:
  fixes R (structure)
  assumes p: "x \<sqsubset> y" and e: "\<lbrakk>x \<sqsubseteq> y; \<not> (x .= y)\<rbrakk> \<Longrightarrow> P"
  shows "P"
  using p by (blast dest: lless_imp_le weak_lless_imp_not_eq e)

lemma (in weak_partial_order) lless_cong_l [trans]:
  assumes xx': "x .= x'"
    and xy: "x' \<sqsubset> y"
    and carr: "x \<in> carrier L" "x' \<in> carrier L" "y \<in> carrier L"
  shows "x \<sqsubset> y"
  using assms unfolding lless_def by (auto intro: trans sym)

lemma (in weak_partial_order) lless_cong_r [trans]:
  assumes xy: "x \<sqsubset> y"
    and  yy': "y .= y'"
    and carr: "x \<in> carrier L" "y \<in> carrier L" "y' \<in> carrier L"
  shows "x \<sqsubset> y'"
  using assms unfolding lless_def by (auto intro: trans sym)  (*slow*)

lemma (in weak_partial_order) lless_antisym:
  assumes "a \<in> carrier L" "b \<in> carrier L"
    and "a \<sqsubset> b" "b \<sqsubset> a"
  shows "P"
  using assms
  by (elim weak_llessE) auto

lemma (in weak_partial_order) lless_trans [trans]:
  assumes "a \<sqsubset> b" "b \<sqsubset> c"
    and carr[simp]: "a \<in> carrier L" "b \<in> carrier L" "c \<in> carrier L"
  shows "a \<sqsubset> c"
  using assms unfolding lless_def by (blast dest: le_trans intro: sym)

lemma weak_partial_order_subset:
  assumes "weak_partial_order L" "A \<subseteq> carrier L"
  shows "weak_partial_order (L\<lparr> carrier := A \<rparr>)"
proof -
  interpret L: weak_partial_order L
    by (simp add: assms)
  interpret equivalence "(L\<lparr> carrier := A \<rparr>)"
    by (simp add: L.equivalence_axioms assms(2) equivalence_subset)
  show ?thesis
    apply (unfold_locales, simp_all)
    using assms(2) apply auto[1]
    using assms(2) apply auto[1]
    apply (meson L.le_trans assms(2) contra_subsetD)
    apply (meson L.le_cong assms(2) subsetCE)
  done
qed

subsubsection \<open>Upper and lower bounds of a set\<close>

definition
  Upper :: "[_, 'a set] => 'a set"
  where "Upper L A = {u. (ALL x. x \<in> A \<inter> carrier L --> x \<sqsubseteq>\<^bsub>L\<^esub> u)} \<inter> carrier L"

definition
  Lower :: "[_, 'a set] => 'a set"
  where "Lower L A = {l. (ALL x. x \<in> A \<inter> carrier L --> l \<sqsubseteq>\<^bsub>L\<^esub> x)} \<inter> carrier L"

lemma Upper_closed [intro!, simp]:
  "Upper L A \<subseteq> carrier L"
  by (unfold Upper_def) clarify

lemma Upper_memD [dest]:
  fixes L (structure)
  shows "[| u \<in> Upper L A; x \<in> A; A \<subseteq> carrier L |] ==> x \<sqsubseteq> u \<and> u \<in> carrier L"
  by (unfold Upper_def) blast

lemma (in weak_partial_order) Upper_elemD [dest]:
  "[| u .\<in> Upper L A; u \<in> carrier L; x \<in> A; A \<subseteq> carrier L |] ==> x \<sqsubseteq> u"
  unfolding Upper_def elem_def
  by (blast dest: sym)

lemma Upper_memI:
  fixes L (structure)
  shows "[| !! y. y \<in> A ==> y \<sqsubseteq> x; x \<in> carrier L |] ==> x \<in> Upper L A"
  by (unfold Upper_def) blast

lemma (in weak_partial_order) Upper_elemI:
  "[| !! y. y \<in> A ==> y \<sqsubseteq> x; x \<in> carrier L |] ==> x .\<in> Upper L A"
  unfolding Upper_def by blast

lemma Upper_antimono:
  "A \<subseteq> B ==> Upper L B \<subseteq> Upper L A"
  by (unfold Upper_def) blast

lemma (in weak_partial_order) Upper_is_closed [simp]:
  "A \<subseteq> carrier L ==> is_closed (Upper L A)"
  by (rule is_closedI) (blast intro: Upper_memI)+

lemma (in weak_partial_order) Upper_mem_cong:
  assumes a'carr: "a' \<in> carrier L" and Acarr: "A \<subseteq> carrier L"
    and aa': "a .= a'"
    and aelem: "a \<in> Upper L A"
  shows "a' \<in> Upper L A"
proof (rule Upper_memI[OF _ a'carr])
  fix y
  assume yA: "y \<in> A"
  hence "y \<sqsubseteq> a" by (intro Upper_memD[OF aelem, THEN conjunct1] Acarr)
  also note aa'
  finally
      show "y \<sqsubseteq> a'"
      by (simp add: a'carr subsetD[OF Acarr yA] subsetD[OF Upper_closed aelem])
qed

lemma (in weak_partial_order) Upper_cong:
  assumes Acarr: "A \<subseteq> carrier L" and A'carr: "A' \<subseteq> carrier L"
    and AA': "A {.=} A'"
  shows "Upper L A = Upper L A'"
unfolding Upper_def
apply rule
 apply (rule, clarsimp) defer 1
 apply (rule, clarsimp) defer 1
proof -
  fix x a'
  assume carr: "x \<in> carrier L" "a' \<in> carrier L"
    and a'A': "a' \<in> A'"
  assume aLxCond[rule_format]: "\<forall>a. a \<in> A \<and> a \<in> carrier L \<longrightarrow> a \<sqsubseteq> x"

  from AA' and a'A' have "\<exists>a\<in>A. a' .= a" by (rule set_eqD2)
  from this obtain a
      where aA: "a \<in> A"
      and a'a: "a' .= a"
      by auto
  note [simp] = subsetD[OF Acarr aA] carr

  note a'a
  also have "a \<sqsubseteq> x" by (simp add: aLxCond aA)
  finally show "a' \<sqsubseteq> x" by simp
next
  fix x a
  assume carr: "x \<in> carrier L" "a \<in> carrier L"
    and aA: "a \<in> A"
  assume a'LxCond[rule_format]: "\<forall>a'. a' \<in> A' \<and> a' \<in> carrier L \<longrightarrow> a' \<sqsubseteq> x"

  from AA' and aA have "\<exists>a'\<in>A'. a .= a'" by (rule set_eqD1)
  from this obtain a'
      where a'A': "a' \<in> A'"
      and aa': "a .= a'"
      by auto
  note [simp] = subsetD[OF A'carr a'A'] carr

  note aa'
  also have "a' \<sqsubseteq> x" by (simp add: a'LxCond a'A')
  finally show "a \<sqsubseteq> x" by simp
qed

lemma Lower_closed [intro!, simp]:
  "Lower L A \<subseteq> carrier L"
  by (unfold Lower_def) clarify

lemma Lower_memD [dest]:
  fixes L (structure)
  shows "[| l \<in> Lower L A; x \<in> A; A \<subseteq> carrier L |] ==> l \<sqsubseteq> x \<and> l \<in> carrier L"
  by (unfold Lower_def) blast

lemma Lower_memI:
  fixes L (structure)
  shows "[| !! y. y \<in> A ==> x \<sqsubseteq> y; x \<in> carrier L |] ==> x \<in> Lower L A"
  by (unfold Lower_def) blast

lemma Lower_antimono:
  "A \<subseteq> B ==> Lower L B \<subseteq> Lower L A"
  by (unfold Lower_def) blast

lemma (in weak_partial_order) Lower_is_closed [simp]:
  "A \<subseteq> carrier L \<Longrightarrow> is_closed (Lower L A)"
  by (rule is_closedI) (blast intro: Lower_memI dest: sym)+

lemma (in weak_partial_order) Lower_mem_cong:
  assumes a'carr: "a' \<in> carrier L" and Acarr: "A \<subseteq> carrier L"
    and aa': "a .= a'"
    and aelem: "a \<in> Lower L A"
  shows "a' \<in> Lower L A"
using assms Lower_closed[of L A]
by (intro Lower_memI) (blast intro: le_cong_l[OF aa'[symmetric]])

lemma (in weak_partial_order) Lower_cong:
  assumes Acarr: "A \<subseteq> carrier L" and A'carr: "A' \<subseteq> carrier L"
    and AA': "A {.=} A'"
  shows "Lower L A = Lower L A'"
unfolding Lower_def
apply rule
 apply clarsimp defer 1
 apply clarsimp defer 1
proof -
  fix x a'
  assume carr: "x \<in> carrier L" "a' \<in> carrier L"
    and a'A': "a' \<in> A'"
  assume "\<forall>a. a \<in> A \<and> a \<in> carrier L \<longrightarrow> x \<sqsubseteq> a"
  hence aLxCond: "\<And>a. \<lbrakk>a \<in> A; a \<in> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> a" by fast

  from AA' and a'A' have "\<exists>a\<in>A. a' .= a" by (rule set_eqD2)
  from this obtain a
      where aA: "a \<in> A"
      and a'a: "a' .= a"
      by auto

  from aA and subsetD[OF Acarr aA]
      have "x \<sqsubseteq> a" by (rule aLxCond)
  also note a'a[symmetric]
  finally
      show "x \<sqsubseteq> a'" by (simp add: carr subsetD[OF Acarr aA])
next
  fix x a
  assume carr: "x \<in> carrier L" "a \<in> carrier L"
    and aA: "a \<in> A"
  assume "\<forall>a'. a' \<in> A' \<and> a' \<in> carrier L \<longrightarrow> x \<sqsubseteq> a'"
  hence a'LxCond: "\<And>a'. \<lbrakk>a' \<in> A'; a' \<in> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> a'" by fast+

  from AA' and aA have "\<exists>a'\<in>A'. a .= a'" by (rule set_eqD1)
  from this obtain a'
      where a'A': "a' \<in> A'"
      and aa': "a .= a'"
      by auto
  from a'A' and subsetD[OF A'carr a'A']
      have "x \<sqsubseteq> a'" by (rule a'LxCond)
  also note aa'[symmetric]
  finally show "x \<sqsubseteq> a" by (simp add: carr subsetD[OF A'carr a'A'])
qed

text \<open>Jacobson: Theorem 8.1\<close>

lemma Lower_empty [simp]:
  "Lower L {} = carrier L"
  by (unfold Lower_def) simp

lemma Upper_empty [simp]:
  "Upper L {} = carrier L"
  by (unfold Upper_def) simp

subsubsection \<open>Least and greatest, as predicate\<close>

definition
  least :: "[_, 'a, 'a set] => bool"
  where "least L l A \<longleftrightarrow> A \<subseteq> carrier L & l \<in> A & (ALL x : A. l \<sqsubseteq>\<^bsub>L\<^esub> x)"

definition
  greatest :: "[_, 'a, 'a set] => bool"
  where "greatest L g A \<longleftrightarrow> A \<subseteq> carrier L & g \<in> A & (ALL x : A. x \<sqsubseteq>\<^bsub>L\<^esub> g)"

text (in weak_partial_order) \<open>Could weaken these to @{term "l \<in> carrier L \<and> l
  .\<in> A"} and @{term "g \<in> carrier L \<and> g .\<in> A"}.\<close>

lemma least_closed [intro, simp]:
  "least L l A ==> l \<in> carrier L"
  by (unfold least_def) fast

lemma least_mem:
  "least L l A ==> l \<in> A"
  by (unfold least_def) fast

lemma (in weak_partial_order) weak_least_unique:
  "[| least L x A; least L y A |] ==> x .= y"
  by (unfold least_def) blast

lemma least_le:
  fixes L (structure)
  shows "[| least L x A; a \<in> A |] ==> x \<sqsubseteq> a"
  by (unfold least_def) fast

lemma (in weak_partial_order) least_cong:
  "[| x .= x'; x \<in> carrier L; x' \<in> carrier L; is_closed A |] ==> least L x A = least L x' A"
  by (unfold least_def) (auto dest: sym)

abbreviation is_lub :: "[_, 'a, 'a set] => bool"
where "is_lub L x A \<equiv> least L x (Upper L A)"

text (in weak_partial_order) \<open>@{const least} is not congruent in the second parameter for
  @{term "A {.=} A'"}\<close>

lemma (in weak_partial_order) least_Upper_cong_l:
  assumes "x .= x'"
    and "x \<in> carrier L" "x' \<in> carrier L"
    and "A \<subseteq> carrier L"
  shows "least L x (Upper L A) = least L x' (Upper L A)"
  apply (rule least_cong) using assms by auto

lemma (in weak_partial_order) least_Upper_cong_r:
  assumes Acarrs: "A \<subseteq> carrier L" "A' \<subseteq> carrier L" (* unneccessary with current Upper? *)
    and AA': "A {.=} A'"
  shows "least L x (Upper L A) = least L x (Upper L A')"
apply (subgoal_tac "Upper L A = Upper L A'", simp)
by (rule Upper_cong) fact+

lemma least_UpperI:
  fixes L (structure)
  assumes above: "!! x. x \<in> A ==> x \<sqsubseteq> s"
    and below: "!! y. y \<in> Upper L A ==> s \<sqsubseteq> y"
    and L: "A \<subseteq> carrier L"  "s \<in> carrier L"
  shows "least L s (Upper L A)"
proof -
  have "Upper L A \<subseteq> carrier L" by simp
  moreover from above L have "s \<in> Upper L A" by (simp add: Upper_def)
  moreover from below have "ALL x : Upper L A. s \<sqsubseteq> x" by fast
  ultimately show ?thesis by (simp add: least_def)
qed

lemma least_Upper_above:
  fixes L (structure)
  shows "[| least L s (Upper L A); x \<in> A; A \<subseteq> carrier L |] ==> x \<sqsubseteq> s"
  by (unfold least_def) blast

lemma greatest_closed [intro, simp]:
  "greatest L l A ==> l \<in> carrier L"
  by (unfold greatest_def) fast

lemma greatest_mem:
  "greatest L l A ==> l \<in> A"
  by (unfold greatest_def) fast

lemma (in weak_partial_order) weak_greatest_unique:
  "[| greatest L x A; greatest L y A |] ==> x .= y"
  by (unfold greatest_def) blast

lemma greatest_le:
  fixes L (structure)
  shows "[| greatest L x A; a \<in> A |] ==> a \<sqsubseteq> x"
  by (unfold greatest_def) fast

lemma (in weak_partial_order) greatest_cong:
  "[| x .= x'; x \<in> carrier L; x' \<in> carrier L; is_closed A |] ==>
  greatest L x A = greatest L x' A"
  by (unfold greatest_def) (auto dest: sym)

abbreviation is_glb :: "[_, 'a, 'a set] => bool"
where "is_glb L x A \<equiv> greatest L x (Lower L A)"

text (in weak_partial_order) \<open>@{const greatest} is not congruent in the second parameter for
  @{term "A {.=} A'"} \<close>

lemma (in weak_partial_order) greatest_Lower_cong_l:
  assumes "x .= x'"
    and "x \<in> carrier L" "x' \<in> carrier L"
    and "A \<subseteq> carrier L" (* unneccessary with current Lower *)
  shows "greatest L x (Lower L A) = greatest L x' (Lower L A)"
  apply (rule greatest_cong) using assms by auto

lemma (in weak_partial_order) greatest_Lower_cong_r:
  assumes Acarrs: "A \<subseteq> carrier L" "A' \<subseteq> carrier L"
    and AA': "A {.=} A'"
  shows "greatest L x (Lower L A) = greatest L x (Lower L A')"
apply (subgoal_tac "Lower L A = Lower L A'", simp)
by (rule Lower_cong) fact+

lemma greatest_LowerI:
  fixes L (structure)
  assumes below: "!! x. x \<in> A ==> i \<sqsubseteq> x"
    and above: "!! y. y \<in> Lower L A ==> y \<sqsubseteq> i"
    and L: "A \<subseteq> carrier L"  "i \<in> carrier L"
  shows "greatest L i (Lower L A)"
proof -
  have "Lower L A \<subseteq> carrier L" by simp
  moreover from below L have "i \<in> Lower L A" by (simp add: Lower_def)
  moreover from above have "ALL x : Lower L A. x \<sqsubseteq> i" by fast
  ultimately show ?thesis by (simp add: greatest_def)
qed

lemma greatest_Lower_below:
  fixes L (structure)
  shows "[| greatest L i (Lower L A); x \<in> A; A \<subseteq> carrier L |] ==> i \<sqsubseteq> x"
  by (unfold greatest_def) blast

lemma Lower_dual [simp]:
  "Lower (inv_gorder L) A = Upper L A"
  by (simp add:Upper_def Lower_def)

lemma Upper_dual [simp]:
  "Upper (inv_gorder L) A = Lower L A"
  by (simp add:Upper_def Lower_def)

lemma least_dual [simp]:
  "least (inv_gorder L) x A = greatest L x A"
  by (simp add:least_def greatest_def)

lemma greatest_dual [simp]:
  "greatest (inv_gorder L) x A = least L x A"
  by (simp add:least_def greatest_def)

lemma (in weak_partial_order) dual_weak_order:
  "weak_partial_order (inv_gorder L)"
  apply (unfold_locales)
  apply (simp_all)
  apply (metis sym)
  apply (metis trans)
  apply (metis weak_le_antisym)
  apply (metis le_trans)
  apply (metis le_cong_l le_cong_r sym)
done

lemma dual_weak_order_iff:
  "weak_partial_order (inv_gorder A) \<longleftrightarrow> weak_partial_order A"
proof
  assume "weak_partial_order (inv_gorder A)"
  then interpret dpo: weak_partial_order "inv_gorder A"
  rewrites "carrier (inv_gorder A) = carrier A"
  and   "le (inv_gorder A)      = (\<lambda> x y. le A y x)"
  and   "eq (inv_gorder A)      = eq A"
    by (simp_all)
  show "weak_partial_order A"
    by (unfold_locales, auto intro: dpo.sym dpo.trans dpo.le_trans)
next
  assume "weak_partial_order A"
  thus "weak_partial_order (inv_gorder A)"
    by (metis weak_partial_order.dual_weak_order)
qed

subsubsection \<open>Intervals\<close>

definition
  at_least_at_most :: "('a, 'c) gorder_scheme \<Rightarrow> 'a => 'a => 'a set" ("(1\<lbrace>_.._\<rbrace>\<index>)")
  where "\<lbrace>l..u\<rbrace>\<^bsub>A\<^esub> = {x \<in> carrier A. l \<sqsubseteq>\<^bsub>A\<^esub> x \<and> x \<sqsubseteq>\<^bsub>A\<^esub> u}"

context weak_partial_order
begin

  lemma at_least_at_most_upper [dest]:
    "x \<in> \<lbrace>a..b\<rbrace> \<Longrightarrow> x \<sqsubseteq> b"
    by (simp add: at_least_at_most_def)

  lemma at_least_at_most_lower [dest]:
    "x \<in> \<lbrace>a..b\<rbrace> \<Longrightarrow> a \<sqsubseteq> x"
    by (simp add: at_least_at_most_def)

  lemma at_least_at_most_closed: "\<lbrace>a..b\<rbrace> \<subseteq> carrier L"
    by (auto simp add: at_least_at_most_def)

  lemma at_least_at_most_member [intro]:
    "\<lbrakk> x \<in> carrier L; a \<sqsubseteq> x; x \<sqsubseteq> b \<rbrakk> \<Longrightarrow> x \<in> \<lbrace>a..b\<rbrace>"
    by (simp add: at_least_at_most_def)

end

subsubsection \<open>Isotone functions\<close>

definition isotone :: "('a, 'c) gorder_scheme \<Rightarrow> ('b, 'd) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where
  "isotone A B f \<equiv>
   weak_partial_order A \<and> weak_partial_order B \<and>
   (\<forall>x\<in>carrier A. \<forall>y\<in>carrier A. x \<sqsubseteq>\<^bsub>A\<^esub> y \<longrightarrow> f x \<sqsubseteq>\<^bsub>B\<^esub> f y)"

lemma isotoneI [intro?]:
  fixes f :: "'a \<Rightarrow> 'b"
  assumes "weak_partial_order L1"
          "weak_partial_order L2"
          "(\<And>x y. \<lbrakk> x \<in> carrier L1; y \<in> carrier L1; x \<sqsubseteq>\<^bsub>L1\<^esub> y \<rbrakk>
                   \<Longrightarrow> f x \<sqsubseteq>\<^bsub>L2\<^esub> f y)"
  shows "isotone L1 L2 f"
  using assms by (auto simp add:isotone_def)

abbreviation Monotone :: "('a, 'b) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" ("Mono\<index>")
  where "Monotone L f \<equiv> isotone L L f"

lemma use_iso1:
  "\<lbrakk>isotone A A f; x \<in> carrier A; y \<in> carrier A; x \<sqsubseteq>\<^bsub>A\<^esub> y\<rbrakk> \<Longrightarrow>
   f x \<sqsubseteq>\<^bsub>A\<^esub> f y"
  by (simp add: isotone_def)

lemma use_iso2:
  "\<lbrakk>isotone A B f; x \<in> carrier A; y \<in> carrier A; x \<sqsubseteq>\<^bsub>A\<^esub> y\<rbrakk> \<Longrightarrow>
   f x \<sqsubseteq>\<^bsub>B\<^esub> f y"
  by (simp add: isotone_def)

lemma iso_compose:
  "\<lbrakk>f \<in> carrier A \<rightarrow> carrier B; isotone A B f; g \<in> carrier B \<rightarrow> carrier C; isotone B C g\<rbrakk> \<Longrightarrow>
   isotone A C (g \<circ> f)"
  by (simp add: isotone_def, safe, metis Pi_iff)

lemma (in weak_partial_order) inv_isotone [simp]:
  "isotone (inv_gorder A) (inv_gorder B) f = isotone A B f"
  by (auto simp add:isotone_def dual_weak_order dual_weak_order_iff)

subsubsection \<open>Idempotent functions\<close>

definition idempotent ::
  "('a, 'b) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" ("Idem\<index>") where
  "idempotent L f \<equiv> \<forall>x\<in>carrier L. f (f x) .=\<^bsub>L\<^esub> f x"

lemma (in weak_partial_order) idempotent:
  "\<lbrakk> Idem f; x \<in> carrier L \<rbrakk> \<Longrightarrow> f (f x) .= f x"
  by (auto simp add: idempotent_def)

subsubsection \<open>Order embeddings\<close>

definition order_emb :: "('a, 'c) gorder_scheme \<Rightarrow> ('b, 'd) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where
  "order_emb A B f \<equiv> weak_partial_order A
                   \<and> weak_partial_order B
                   \<and> (\<forall>x\<in>carrier A. \<forall>y\<in>carrier A. f x \<sqsubseteq>\<^bsub>B\<^esub> f y \<longleftrightarrow> x \<sqsubseteq>\<^bsub>A\<^esub> y )"

lemma order_emb_isotone: "order_emb A B f \<Longrightarrow> isotone A B f"
  by (auto simp add: isotone_def order_emb_def)

subsubsection \<open>Commuting functions\<close>

definition commuting :: "('a, 'c) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
"commuting A f g = (\<forall>x\<in>carrier A. (f \<circ> g) x .=\<^bsub>A\<^esub> (g \<circ> f) x)"

subsection \<open>Partial orders where \<open>eq\<close> is the Equality\<close>

locale partial_order = weak_partial_order +
  assumes eq_is_equal: "op .= = op ="
begin

declare weak_le_antisym [rule del]

lemma le_antisym [intro]:
  "[| x \<sqsubseteq> y; y \<sqsubseteq> x; x \<in> carrier L; y \<in> carrier L |] ==> x = y"
  using weak_le_antisym unfolding eq_is_equal .

lemma lless_eq:
  "x \<sqsubset> y \<longleftrightarrow> x \<sqsubseteq> y & x \<noteq> y"
  unfolding lless_def by (simp add: eq_is_equal)

lemma set_eq_is_eq: "A {.=} B \<longleftrightarrow> A = B"
  by (auto simp add: set_eq_def elem_def eq_is_equal)

end

lemma (in partial_order) dual_order:
  "partial_order (inv_gorder L)"
proof -
  interpret dwo: weak_partial_order "inv_gorder L"
    by (metis dual_weak_order)
  show ?thesis
    by (unfold_locales, simp add:eq_is_equal)
qed

lemma dual_order_iff:
  "partial_order (inv_gorder A) \<longleftrightarrow> partial_order A"
proof
  assume assm:"partial_order (inv_gorder A)"
  then interpret po: partial_order "inv_gorder A"
  rewrites "carrier (inv_gorder A) = carrier A"
  and   "le (inv_gorder A)      = (\<lambda> x y. le A y x)"
  and   "eq (inv_gorder A)      = eq A"
    by (simp_all)
  show "partial_order A"
    apply (unfold_locales, simp_all)
    apply (metis po.sym, metis po.trans)
    apply (metis po.weak_le_antisym, metis po.le_trans)
    apply (metis (full_types) po.eq_is_equal, metis po.eq_is_equal)
  done
next
  assume "partial_order A"
  thus "partial_order (inv_gorder A)"
    by (metis partial_order.dual_order)
qed

text \<open>Least and greatest, as predicate\<close>

lemma (in partial_order) least_unique:
  "[| least L x A; least L y A |] ==> x = y"
  using weak_least_unique unfolding eq_is_equal .

lemma (in partial_order) greatest_unique:
  "[| greatest L x A; greatest L y A |] ==> x = y"
  using weak_greatest_unique unfolding eq_is_equal .

subsection \<open>Bounded Orders\<close>

definition
  top :: "_ => 'a" ("\<top>\<index>") where
  "\<top>\<^bsub>L\<^esub> = (SOME x. greatest L x (carrier L))"

definition
  bottom :: "_ => 'a" ("\<bottom>\<index>") where
  "\<bottom>\<^bsub>L\<^esub> = (SOME x. least L x (carrier L))"

locale weak_partial_order_bottom = weak_partial_order L for L (structure) +
  assumes bottom_exists: "\<exists> x. least L x (carrier L)"
begin

lemma bottom_least: "least L \<bottom> (carrier L)"
proof -
  obtain x where "least L x (carrier L)"
    by (metis bottom_exists)

  thus ?thesis
    by (auto intro:someI2 simp add: bottom_def)
qed

lemma bottom_closed [simp, intro]:
  "\<bottom> \<in> carrier L"
  by (metis bottom_least least_mem)

lemma bottom_lower [simp, intro]:
  "x \<in> carrier L \<Longrightarrow> \<bottom> \<sqsubseteq> x"
  by (metis bottom_least least_le)

end

locale weak_partial_order_top = weak_partial_order L for L (structure) +
  assumes top_exists: "\<exists> x. greatest L x (carrier L)"
begin

lemma top_greatest: "greatest L \<top> (carrier L)"
proof -
  obtain x where "greatest L x (carrier L)"
    by (metis top_exists)

  thus ?thesis
    by (auto intro:someI2 simp add: top_def)
qed

lemma top_closed [simp, intro]:
  "\<top> \<in> carrier L"
  by (metis greatest_mem top_greatest)

lemma top_higher [simp, intro]:
  "x \<in> carrier L \<Longrightarrow> x \<sqsubseteq> \<top>"
  by (metis greatest_le top_greatest)

end

subsection \<open>Total Orders\<close>

locale weak_total_order = weak_partial_order +
  assumes total: "\<lbrakk> x \<in> carrier L; y \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x"

text \<open>Introduction rule: the usual definition of total order\<close>

lemma (in weak_partial_order) weak_total_orderI:
  assumes total: "!!x y. \<lbrakk> x \<in> carrier L; y \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x"
  shows "weak_total_order L"
  by unfold_locales (rule total)

subsection \<open>Total orders where \<open>eq\<close> is the Equality\<close>

locale total_order = partial_order +
  assumes total_order_total: "\<lbrakk> x \<in> carrier L; y \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x"

sublocale total_order < weak?: weak_total_order
  by unfold_locales (rule total_order_total)

text \<open>Introduction rule: the usual definition of total order\<close>

lemma (in partial_order) total_orderI:
  assumes total: "!!x y. \<lbrakk> x \<in> carrier L; y \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x"
  shows "total_order L"
  by unfold_locales (rule total)

end