theory Float_Tests_Fixed
imports Main
        IEEE_Floating_Point.IEEE
begin

(*half precision*)
type_synonym floatT = "(5,10) float"

(*single precision*)
(*type_synonym floatT = "(8,23) float"*)

(*double precision*)
(*type_synonym floatT = "(11,52) float"*)

(*quadruple precision*)
(*type_synonym floatT = "(15,112) float"*)

(* CLASSIFICATION *)
(*from IEEE_Floating_point/IEEE_properties.thy*)

lemma float_cases:
  "is_nan x \<or> is_infinity x \<or> is_normal x \<or>
    is_denormal x \<or> is_zero x"
  for x :: floatT
  oops

lemma float_cases_finite: "is_nan x \<or> is_infinity x \<or> is_finite x"
  for x :: floatT
  oops

lemma float_zero1: "is_zero (0::floatT)"
  oops

lemma float_zero2: "is_zero (- x) \<longleftrightarrow> is_zero x"
  for x :: floatT
  oops

lemma float_distinct1: "\<not> (is_nan x \<and> is_infinity x)"
  for x :: floatT
  oops

lemma float_distinct2: "\<not> (is_nan x \<and> is_normal x)"
  for x :: floatT
  oops

lemma float_distinct3: "\<not> (is_nan x \<and> is_denormal x)"
  for x :: floatT
  oops

lemma float_distinct4: "\<not> (is_nan x \<and> is_zero x)"
  for x :: floatT
  oops

lemma float_distinct5: "\<not> (is_infinity x \<and> is_normal x)"
  for x :: floatT
  oops

lemma float_distinct6: "\<not> (is_infinity x \<and> is_denormal x)"
  for x :: floatT
  oops

lemma float_distinct7: "\<not> (is_infinity x \<and> is_zero x)"
  for x :: floatT
  oops

lemma float_distinct8: "\<not> (is_normal x \<and> is_denormal x)"
  for x :: floatT
  oops

lemma float_distinct9: "\<not> (is_denormal x \<and> is_zero x)"
  for x :: floatT
  oops

lemma denormal_imp_not_zero: "is_denormal x \<Longrightarrow> \<not>is_zero x"
  for x :: floatT
  oops

lemma normal_imp_not_zero: "is_normal x \<Longrightarrow> \<not>is_zero x"
  for x :: floatT
  oops

lemma normal_imp_not_denormal:
  "is_normal x \<Longrightarrow> \<not>is_denormal x"
  for x :: floatT
  oops

lemma denormal_zero: "\<not>is_denormal (0::floatT)"
  oops

lemma denormal_mzero: "\<not>is_denormal (minus_zero::floatT)"
  oops

lemma normal_zero: "\<not>is_normal (0::floatT)"
  oops

lemma normal_mzero: "\<not>is_normal (minus_zero::floatT)"
  oops

lemma float_distinct_finite1: "\<not> (is_nan x \<and> is_finite x)"
  for x :: floatT
  oops

lemma float_distinct_finite2: "\<not>(is_infinity x \<and> is_finite x)"
  for x :: floatT
  oops

lemma finite_infinity: "is_finite x \<Longrightarrow> \<not> is_infinity x"
  for x :: floatT
  oops

lemma is_infinity_cases:
  "is_infinity x \<Longrightarrow> x = plus_infinity \<or> x = minus_infinity"
  for x :: floatT
  oops

lemma is_zero_cases: "is_zero x \<Longrightarrow> x = 0 \<or> x = - 0"
  for x :: floatT
  oops

lemma infinite_infinity: "\<not> is_finite (plus_infinity::floatT)"
  oops

lemma infinite_minfinity: "\<not> is_finite (minus_infinity::floatT)"
  oops

lemma nan_not_finite: "is_nan x \<Longrightarrow> \<not> is_finite x"
  for x :: floatT
  oops

(* COMPARISON *)
(*from IEEE_Floating_Point/IEEE_properties.thy*)

lemma float_lt:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    x < y \<longleftrightarrow> valof x < valof y"
  for x y :: floatT
  oops

lemma float_eq:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    x \<doteq> y \<longleftrightarrow> valof x = valof y"
  for x y :: floatT
  oops

lemma float_le:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    x \<le> y \<longleftrightarrow> valof x \<le> valof y"
  for x y :: floatT
  oops

lemma float_eq_refl: "x \<doteq> x \<longleftrightarrow> \<not> is_nan x"
  for x :: floatT
  oops

lemma float_lt_trans:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    is_finite z \<Longrightarrow> x < y \<Longrightarrow>
      y < z \<Longrightarrow> x < z"
  for x y z :: floatT
  oops

lemma float_le_less_trans:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    is_finite z \<Longrightarrow> x \<le> y \<Longrightarrow>
      y < z \<Longrightarrow> x < z"
  for x y z :: floatT
  oops

lemma float_le_trans:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    is_finite z \<Longrightarrow> x \<le> y \<Longrightarrow>
      y \<le> z \<Longrightarrow> x \<le> z"
  for x y z :: floatT
  oops

lemma float_le_neg:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    \<not> x < y \<longleftrightarrow> y \<le> x"
  for x y :: floatT
  oops

lemma float_le_infinity:
  "\<not> is_nan x \<Longrightarrow> x \<le> plus_infinity"
  for x :: floatT
  oops

(* ARITHMETIC *)
(*from IEEE_Floating_point/IEEE_properties.thy*)

lemma minus_minus_float: "- (-x) = x"
  for x :: floatT
  oops

lemma is_normal_minus_float: "is_normal (-x) = is_normal x"
  for x :: floatT
  oops

lemma is_denormal_minus_float: "is_denormal (-x) = is_denormal x"
  for x :: floatT
  oops

lemma float_plus_comm_eq:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow> x + y = y + x"
  for x y :: floatT
  oops

lemma float_plus_comm:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    is_finite (x + y) \<Longrightarrow> (x + y) \<doteq> (y + x)"
  for x y :: floatT
  oops

lemma is_zero_uminus: "is_zero (- x) \<longleftrightarrow> is_zero x"
  for x :: floatT
  oops

lemma is_infinity_uminus: "is_infinity (- x) = is_infinity x"
  for x :: floatT
  oops

lemma is_finite_uminus: "is_finite (- x) \<longleftrightarrow> is_finite x"
  for x :: floatT
  oops

lemma is_nan_uminus: "is_nan (- x) \<longleftrightarrow> is_nan x"
  for x :: floatT
  oops

lemma valof_uminus: "is_finite x \<Longrightarrow> valof (- x) = - valof x"
  for x :: floatT
  oops

lemma float_neg_add:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    is_finite (x - y) \<Longrightarrow>
      valof x + valof (- y) = valof x - valof y"
  for x y :: floatT
  oops

lemma float_plus_minus:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    is_finite (x - y) \<Longrightarrow> (x + - y) \<doteq> (x - y)"
  for x y :: floatT
  oops

lemma float_abs: "\<not> is_nan x \<Longrightarrow> abs (- x) = abs x"
  for x :: floatT
  oops

lemma valof_zero: "valof (0::floatT) = 0"
  oops

lemma valof_mzero: "valof (minus_zero::floatT) = 0"
  oops

lemma val_zero: "is_zero x \<Longrightarrow> valof x = 0"
  for x :: floatT
  oops

(* SPECIAL INPUTS *)
(*from the IEEE 754-2019 standard*)

lemma rem_fin_inf: "is_finite x \<Longrightarrow> float_rem x \<infinity> = x"
  for x :: floatT
  oops

lemma sqrt_mzero: "float_sqrt (minus_zero::floatT) = minus_zero"
  oops

lemma compare_cases:
  "flt x y \<or> feq x y \<or> fgt x y \<longleftrightarrow>
    \<not>(is_nan x \<or> is_nan y)"
  for x y :: floatT
  oops

lemma compare_unique1: "\<not> (flt x y \<and> feq x y)"
  for x y :: floatT
  oops

lemma compare_unique2: "\<not> (flt x y \<and> fgt x y)"
  for x y :: floatT
  oops

lemma compare_unique3: "\<not> (flt x y \<and> (is_nan x \<or> is_nan y))"
  for x y :: floatT
  oops

lemma compare_unique4: "\<not> (feq x y \<and> fgt x y)"
  for x y :: floatT
  oops

lemma compare_unique5: "\<not> (feq x y \<and> (is_nan x \<or> is_nan y))"
  for x y :: floatT
  oops

lemma compare_unique6: "\<not> (fgt x y \<and> (is_nan x \<or> is_nan y))"
  for x y :: floatT
  oops

lemma zero_eq_mzero: "(0::floatT) \<doteq> minus_zero"
  oops

lemma float_id: "\<not> is_nan x \<Longrightarrow> x \<doteq> x"
  for x :: floatT
  oops

lemma fadd_inf1:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_infinity (fadd rm x y)"
  for x y ::floatT
  oops

lemma fadd_inf2:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_infinity (fadd rm y x)"
  for x y ::floatT
  oops

lemma fsub_inf1:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_infinity (fsub rm x y)"
  for x y :: floatT
  oops

lemma fsub_inf2:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_infinity (fsub rm y x)"
  for x y :: floatT
  oops

lemma fmul_inf1:
  "\<not> is_nan x \<Longrightarrow> \<not> is_zero x \<Longrightarrow>
    is_infinity y \<Longrightarrow> is_infinity (fmul rm x y)"
  for x y :: floatT
  oops

lemma fmul_inf2:
  "\<not> is_nan x \<Longrightarrow> \<not> is_zero x \<Longrightarrow>
    is_infinity y \<Longrightarrow> is_infinity (fmul rm y x)"
  for x y :: floatT
  oops

lemma fdiv_inf1:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_zero (fdiv rm x y)"
  for x y :: floatT
  oops

lemma fdiv_inf2:
  "is_finite x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_infinity (fdiv rm y x)"
  for x y :: floatT
  oops

lemma fsqrt_inf: "fsqrt rm (plus_infinity::floatT) = plus_infinity"
  oops

lemma abs_nan: "is_nan x \<Longrightarrow> is_nan \<bar>x\<bar>"
  for x :: floatT
  oops

lemma neg_nan: "is_nan x \<Longrightarrow> is_nan (uminus x)"
  for x :: floatT
  oops

lemma fadd_nan1: "is_nan x \<Longrightarrow> is_nan (fadd rm x y)"
  for x y :: floatT
  oops

lemma fadd_nan2: "is_nan y \<Longrightarrow> is_nan (fadd rm x y)"
  for x y :: floatT
  oops

lemma fsub_nan1: "is_nan x \<Longrightarrow> is_nan (fsub rm x y)"
  for x y :: floatT
  oops

lemma fsub_nan2: "is_nan y \<Longrightarrow> is_nan (fsub rm x y)"
  for x y :: floatT
  oops

lemma fmul_nan1: "is_nan x \<Longrightarrow> is_nan (fmul rm x y)"
  for x y :: floatT
  oops

lemma fmul_nan2: "is_nan y \<Longrightarrow> is_nan (fmul rm x y)"
  for x y :: floatT
  oops

lemma fdiv_nan1: "is_nan x \<Longrightarrow> is_nan (fdiv rm x y)"
  for x y :: floatT
  oops

lemma fdiv_nan2: "is_nan y \<Longrightarrow> is_nan (fdiv rm x y)"
  for x y :: floatT
  oops

lemma fma_nan1: "is_nan x \<Longrightarrow> is_nan (fmul_add rm x y z)"
  for x y z :: floatT
  oops

lemma fma_nan2: "is_nan y \<Longrightarrow> is_nan (fmul_add rm x y z)"
  for x y z :: floatT
  oops

lemma fma_nan3: "is_nan z \<Longrightarrow> is_nan (fmul_add rm x y z)"
  for x y z :: floatT
  oops

lemma frem_nan1: "is_nan x \<Longrightarrow> is_nan (frem rm x y)"
  for x y :: floatT
  oops

lemma frem_nan2: "is_nan y \<Longrightarrow> is_nan (frem rm x y)"
  for x y :: floatT
  oops

lemma fsqrt_nan: "is_nan x \<Longrightarrow> is_nan (fsqrt rm x)"
  for x :: floatT
  oops

lemma fintrnd_nan: "is_nan x \<Longrightarrow> is_nan (fintrnd rm x)"
  for x :: floatT
 oops

lemma zero_plus_zero: "fadd rm (0::floatT) 0 = 0"
  oops

lemma mzero_plus_mzero: "fadd rm (minus_zero::floatT) minus_zero = minus_zero"
  oops

lemma fmul_inf_zero1:
  "is_zero x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_nan (fmul rm x y)"
  for x y :: floatT
  oops

lemma fmul_inf_zero2:
  "is_zero x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_nan (fmul rm y x)"
  for x y :: floatT
  oops

lemma fma_inf_zero1:
  "is_zero x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_nan (fmul_add rm x y z)"
  for x y z :: floatT
  oops

lemma fma_inf_zero2:
  "is_zero x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_nan (fmul_add rm y x z)"
  for x y z :: floatT
  oops

lemma inf_plus_minf1: "is_nan (fadd rm (plus_infinity::floatT) minus_infinity)"
  oops

lemma inf_plus_minf2: "is_nan (fadd rm (minus_infinity::floatT) plus_infinity)"
  oops

lemma inf_minus_inf1: "is_nan (fsub rm (plus_infinity::floatT) plus_infinity)"
  oops

lemma inf_minus_inf2: "is_nan (fsub rm (minus_infinity::floatT) minus_infinity)"
  oops

lemma zero_div_zero:
  "is_zero x \<Longrightarrow> is_zero y \<Longrightarrow> is_nan (fdiv rm x y)"
  for x y :: floatT
  oops

lemma inf_div_inf:
  "is_infinity x \<Longrightarrow> is_infinity y \<Longrightarrow>
    is_nan (fdiv rm x y)"
  for x y :: floatT
  oops

lemma frem_inf: "is_infinity x \<Longrightarrow> is_nan (frem rm x y)"
  for x y :: floatT
  oops

lemma frem_zero: "is_zero y \<Longrightarrow> is_nan (frem rm x y)"
  for x y :: floatT
  oops

lemma fsqrt_neg: "x < 0 \<Longrightarrow> is_nan (fsqrt rm x)"
  for x :: floatT
  oops

lemma div_zero:
  "\<not> is_nan x \<Longrightarrow> is_zero y \<Longrightarrow>
    \<not> is_zero x \<Longrightarrow> is_infinity (x div y)"
  for x y :: floatT
  oops

(* ROUNDING *)
(*from "Handbook of Floating-Point Arithmetic" by J-M Muller*)

lemma leq_round:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    x \<le> y \<Longrightarrow>
      (round rm (valof x) :: floatT) \<le> round rm (valof y)"
  for x y :: floatT
  oops

lemma round_id: "is_finite x \<Longrightarrow> feq (round rm (valof x)) x"
  for x :: floatT
  oops

lemma round_sym_nearest_even:
  "(round To_nearest (-x) :: floatT) = - (round To_nearest x)"
  oops

lemma round_sym_nearest_away:
  "(round To_nearest_away (-x) :: floatT) = - (round To_nearest_away x)"
  oops

lemma round_sym_zero:
  "(round float_To_zero (-x) :: floatT) = - (round float_To_zero x)"
  oops

lemma round_sym_updown:
  "(round To_pinfinity (-x) :: floatT) = - (round To_ninfinity x)"
  oops

lemma round_add_eq_sub:
  "\<not> is_nan x \<Longrightarrow> \<not> is_nan y \<Longrightarrow>
    feq (fadd To_pinfinity x y) (- (fsub To_ninfinity (-x) y))"
  for x y :: floatT
  oops

lemma round_mul_eq:
  "\<not> is_nan x \<Longrightarrow> \<not> is_nan y \<Longrightarrow>
    feq (fmul To_ninfinity x y) (- (fmul To_pinfinity (-x) y))"
  for x y :: floatT
  oops

lemma round_zero: "ROUNDFLOAT 0 = (0::floatT)"
  oops

lemma sterbenz:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    (valof y)/2 \<le> valof x \<and> valof x \<le> 2*(valof y) \<Longrightarrow>
      valof x - valof y = valof (fsub rm x y)"
  for x y :: floatT
  oops

lemma hauser:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow>
    is_denormal (x+y) \<Longrightarrow> valof (x+y) = valof x + valof y"
  for x y :: floatT
  oops

(* VARIOUS *)

lemma triple_zero: "is_zero (Abs_float (s, 0 , 0) :: floatT)"
  oops

lemma some_nan_neq: "\<not> some_nan \<doteq> x"
  for x :: floatT
  oops

lemma float_mul_comm_eq:
  "is_finite x \<Longrightarrow> is_finite y \<Longrightarrow> x * y = y * x"
  for x y :: floatT
  oops

lemma less_greater_equal:
  "fle x y \<Longrightarrow> fge x y \<Longrightarrow> feq x y"
  for x y :: floatT
  oops

end


theory T176
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(meet(x, y), z) = meet(mult(x, z), mult(y, 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. over(join(x, y), z) = join(over(x, z), over(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. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T179
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. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, 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. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory WordAbstract
imports
  L2Defs
  ExecConcrete
  NatBitwise
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) (<) (<)"
    "abstract_bool_binop (\<lambda>_ _. True) (unat :: ('a::len) word \<Rightarrow> nat) (\<le>) (\<le>)"
    "abstract_bool_binop (\<lambda>_ _. True) (unat :: ('a::len) word \<Rightarrow> nat) (=) (=)"
  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) (+) (+)"
  "abstract_binop (\<lambda>a b. a * b \<le> UWORD_MAX TYPE('a)) (unat :: 'a word \<Rightarrow> nat) (*) (*)"
  "abstract_binop (\<lambda>a b. a \<ge> b) (unat :: 'a word \<Rightarrow> nat) (-) (-)"
  "abstract_binop (\<lambda>a b. True) (unat :: 'a word \<Rightarrow> nat) (div) (div)"
  "abstract_binop (\<lambda>a b. True) (unat :: 'a word \<Rightarrow> nat) (mod) (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)

(* FIXME: move to Word_Lib *)
lemma unat_of_int:
  "\<lbrakk>i \<ge> 0; i < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow> unat (of_int i :: 'a::len word) = nat i"
  by (metis nat_less_numeral_power_cancel_iff of_nat_nat unat_of_nat_len)

(* FIXME: move to Word_Lib *)
(* FIXME generalises Word_Lemmas_32.unat_of_int_32 *)
lemma unat_of_int_signed:
  "\<lbrakk>i \<ge> 0; i < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow> unat (of_int i :: 'a::len signed word) = nat i"
  by (simp add: unat_of_int)

(* FIXME: move to Word_Lib *)
lemma nat_sint:
  "0 <=s (x :: 'a::len signed word) \<Longrightarrow> nat (sint x) = unat x"
  apply (subst unat_of_int_signed[where 'a='a, symmetric])
    apply (simp add: word_sle_def)
   apply (rule less_trans[OF sint_lt])
   apply simp
  apply simp
  done

lemma int_unat_nonneg:
  "0 <=s (x :: 'a::len signed word) \<Longrightarrow> int (unat x) = sint x"
  by (simp add: int_unat word_sle_msb_le sint_eq_uint)

lemma uint_xor:
  \<open>uint (x xor y) = uint x XOR uint y\<close>
  by (fact uint_xor)

lemma unat_bitwise_abstract_binops:
  "abstract_binop (\<lambda>a b. True) (unat :: 'a::len word \<Rightarrow> nat) (AND) (AND)"
  "abstract_binop (\<lambda>a b. True) (unat :: 'a::len word \<Rightarrow> nat) (OR) (OR)"
  "abstract_binop (\<lambda>a b. True) (unat :: 'a::len word \<Rightarrow> nat) (XOR) (XOR)"
  by (simp_all add: and_nat_def or_nat_def xor_nat_def int_unat flip: uint_and uint_or uint_xor unat_def)

lemma unat_max_word:
  "unat (max_word :: 'a::len word) = 2^LENGTH('a) - 1"
  by (fact unat_minus_one_word)

lemma abstract_val_unsigned_bitNOT:
  "abstract_val P x unat (x' :: 'a::len word) \<Longrightarrow>
   abstract_val P (UWORD_MAX TYPE('a) - x) unat (NOT x')"
  apply (clarsimp simp: UWORD_MAX_def NOT_eq)
  apply (rule subst[where t="-x' - 1" and s="-(x' + 1)"])
   apply simp
  apply (case_tac "x' + 1 = 0")
   apply (simp only:)
   apply (drule max_word_wrap)
   apply (simp add: unat_max_word)
  apply (subst unat_minus')
   apply assumption
  apply (simp add: unatSuc2)
  done

lemma snat_abstract_bool_binops:
    "abstract_bool_binop (\<lambda>_ _. True) (sint :: ('a::len) signed word \<Rightarrow> int) (<) (word_sless)"
    "abstract_bool_binop (\<lambda>_ _. True) (sint :: 'a signed word \<Rightarrow> int) (\<le>) (word_sle)"
    "abstract_bool_binop (\<lambda>_ _. True) (sint :: 'a signed word \<Rightarrow> int) (=) (=)"
  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) (+) (+)"
  "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) (*) (*)"
  "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) (-) (-)"
  "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) (sdiv) (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) (smod) (smod)"
  by (auto simp: signed_arith_sint word_size WORD_MIN_def WORD_MAX_def)

lemma sint_bitwise_abstract_binops:
  "abstract_binop (\<lambda>a b. True) (sint :: 'a::len signed word \<Rightarrow> int) (AND) (AND)"
  "abstract_binop (\<lambda>a b. True) (sint :: 'a::len signed word \<Rightarrow> int) (OR) (OR)"
  "abstract_binop (\<lambda>a b. True) (sint :: 'a::len signed word \<Rightarrow> int) (XOR) (XOR)"
  by (fastforce intro: int_eq_test_bitI
                simp: bin_nth_ops nth_sint word_ao_nth  word_xor_nth)+

lemma abstract_val_signed_bitNOT:
  "abstract_val P x sint (x' :: 'a::len signed word) \<Longrightarrow>
   abstract_val P (NOT x) sint (NOT x')"
  by (fastforce intro: int_eq_test_bitI
                simp: nth_sint bin_nth_ops word_nth_neq test_bit_def'[symmetric] test_bit_wi[where 'a="'a signed"])

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))"
  using sint_range_size [where w=r']
  by (clarsimp simp: word_size WORD_MAX_def signed_arith_sint)

lemma bang_big_nonneg:
  "\<lbrakk> 0 <=s (x::'a::len signed word); n \<ge> size x - 1 \<rbrakk> \<Longrightarrow> (x !! n) = False"
  apply (case_tac "n = size x - 1")
   apply (simp add: word_size msb_nth[where 'a="'a signed", symmetric, simplified] word_sle_msb_le)
  apply (simp add: test_bit_bl)
  apply arith
  done

lemma int_shiftr_nth[simp]:
  "(i >> n) !! m = i !! (n + m)" for i :: int
  by (simp add: shiftr_def bin_nth_shiftr)

lemma int_shiftl_nth[simp]:
  "(i << n) !! m = (n \<le> m \<and> i !! (m - n))" for i :: int
  by (simp add: shiftl_def bin_nth_shiftl)

lemma sint_shiftr_nonneg:
  "\<lbrakk> 0 <=s (x :: 'a::len signed word); 0 \<le> n; n < LENGTH('a) \<rbrakk> \<Longrightarrow> sint (x >> n) = sint x >> n"
  by (word_eqI simp: min_def bang_big_nonneg[simplified word_size])

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)

(* Rules for shifts *)
lemma abstract_val_signed_shiftr_signed:
  "\<lbrakk> abstract_val Px x sint (x' :: ('a :: len) signed word);
     abstract_val Pn n sint (n' :: ('b :: len) signed word) \<rbrakk> \<Longrightarrow>
   abstract_val (Px \<and> Pn \<and> 0 \<le> x \<and> 0 \<le> n \<and> n < int LENGTH('a))
                (x >> nat n) sint (x' >> unat n')"
  apply (clarsimp simp only: abstract_val_def)
  apply (subst nat_sint, simp add: word_sle_def)
  apply (subst sint_shiftr_nonneg)
     apply (simp add: word_sle_def)
    apply simp
   apply (subst SMT.nat_int_comparison(2))
   apply (subst int_unat_nonneg)
    apply (simp add: word_sle_def)

   apply assumption
  apply (rule refl)
  done

lemma abstract_val_signed_shiftr_unsigned:
  "\<lbrakk> abstract_val Px x sint (x' :: ('a :: len) signed word);
     abstract_val Pn n unat (n' :: ('b :: len) word) \<rbrakk> \<Longrightarrow>
   abstract_val (Px \<and> Pn \<and> 0 \<le> x \<and> n < LENGTH('a))
                (x >> n) sint (x' >> unat n')"
  apply (clarsimp simp: shiftr_int_def)
  apply (subst sint_shiftr_nonneg)
     apply (simp add: word_sle_def)
    apply simp
   apply assumption
  apply (clarsimp simp: shiftr_int_def)
  done

lemma sint_shiftl_nonneg:
  "\<lbrakk> 0 <=s (x :: 'a::len signed word); n < LENGTH('a); sint x << n < 2^(LENGTH('a) - 1) \<rbrakk> \<Longrightarrow>
   sint (x << n) = sint x << n"
  apply (word_eqI simp_del: shiftl_1 simp: int_2p_eq_shiftl int_shiftl_less_cancel word_sle_def)
  apply (drule (1) int_shiftl_lt_2p_bits[rotated])
  apply (clarsimp simp: min_def split: if_split_asm)
  apply (rule conjI; clarsimp)
   apply (smt (verit) One_nat_def bot_nat_0.extremum_uniqueI diff_Suc_eq_diff_pred
                      le_diff_iff le_diff_iff' len_gt_0 len_of_finite_1_def less_eq_Suc_le
                      nat_le_Suc_less_imp)
  using less_eq_decr_length_iff nat_le_linear by blast

lemma abstract_val_signed_shiftl_signed:
  "\<lbrakk> abstract_val Px x sint (x' :: ('a :: len) signed word);
     abstract_val Pn n sint (n' :: ('b :: len) signed word) \<rbrakk> \<Longrightarrow>
   abstract_val (Px \<and> Pn \<and> 0 \<le> x \<and> 0 \<le> n \<and> n < int LENGTH('a) \<and> x << nat n < 2^(LENGTH('a) - 1))
                (x << nat n) sint (x' << unat n')"
  apply clarsimp
  apply (subst sint_shiftl_nonneg)
     apply (simp add: word_sle_def)
    apply (subst nat_sint[symmetric], simp add: word_sle_def)
    apply (simp add: nat_less_eq_zless[where z="int LENGTH('a)", simplified])
   apply (simp add: nat_sint word_sle_def)
  apply (simp add: nat_sint word_sle_def)
  done

lemma abstract_val_signed_shiftl_unsigned:
  "\<lbrakk> abstract_val Px x sint (x' :: ('a :: len) signed word);
     abstract_val Pn n unat (n' :: ('b :: len) word) \<rbrakk> \<Longrightarrow>
   abstract_val (Px \<and> Pn \<and> 0 \<le> x \<and> n < LENGTH('a) \<and> x << n < 2^(LENGTH('a) - 1))
                (x << n) sint (x' << unat n')"
  by (clarsimp simp: sint_shiftl_nonneg word_sle_def
                     nat_less_eq_zless[where z="int LENGTH('a)", simplified])

lemma abstract_val_unsigned_shiftr_unsigned:
  "\<lbrakk> abstract_val Px x unat (x' :: ('a :: len) word);
     abstract_val Pn n unat (n' :: ('a :: len) word) \<rbrakk> \<Longrightarrow>
   abstract_val (Px \<and> Pn) (x >> n) unat (x' >> unat n')"
  by (simp add: shiftr_def unat_drop_bit_eq)

lemma abstract_val_unsigned_shiftr_signed:
  "\<lbrakk> abstract_val Px x unat (x' :: ('a :: len) word);
     abstract_val Pn n sint (n' :: ('b :: len) signed word) \<rbrakk> \<Longrightarrow>
   abstract_val (Px \<and> Pn \<and> 0 \<le> n) (x >> nat n) unat (x' >> unat n')"
  by (clarsimp simp: shiftr_def word_sle_def nat_sint unat_drop_bit_eq)

lemma abstract_val_unsigned_shiftl_unsigned:
  "\<lbrakk> abstract_val Px x unat (x' :: ('a :: len) word);
     abstract_val Pn n unat (n' :: ('b :: len) word) \<rbrakk> \<Longrightarrow>
   abstract_val (Px \<and> Pn \<and> n < LENGTH('a) \<and> x << n < 2^LENGTH('a))
                (x << n) unat (x' << unat n')"
  by (clarsimp simp: shiftl_t2n shiftl_nat_alt_def unat_mult_simple field_simps)

lemma abstract_val_unsigned_shiftl_signed:
  "\<lbrakk> abstract_val Px x unat (x' :: ('a :: len) word);
     abstract_val Pn n sint (n' :: ('b :: len) signed word) \<rbrakk> \<Longrightarrow>
   abstract_val (Px \<and> Pn \<and> 0 \<le> n \<and> n < int (LENGTH('a)) \<and> x << nat n < 2^LENGTH('a))
                (x << nat n) unat (x' << unat n')"
  apply (clarsimp simp: shiftl_t2n shiftl_nat_alt_def unat_mult_simple field_simps)
  apply (simp add: sint_eq_uint word_msb_sint)
  by (metis nat_less_iff uint_ge_0 unat_def unat_of_nat_len unat_power_lower word_arith_nat_mult)

(* TODO: this would be useful for simplifying signed left shift c_guards,
   which are already implied by the generated word abs guard (premise #2).

   However, the c_guard is translated before the new word abs guards,
   thus L2Opt (which only propagates guards forwards) is unable to
   make use of this rule at present. *)
lemma signed_shiftl_c_guard_simp (* [L2flow] *):
  "\<lbrakk> int bound < 2^LENGTH('a); a * 2^b < int bound; 0 \<le> a \<rbrakk> \<Longrightarrow>
   unat (of_int a :: 'a::len word) * 2 ^ b < bound"
  apply (subst unat_of_int)
    apply assumption
   apply (drule(1) less_trans)
   apply (subgoal_tac "a * 2^b < 2^LENGTH('a) * 2^b")
    apply simp
   apply (erule less_le_trans)
   apply simp
  apply (subgoal_tac "nat (a * 2^b) < nat (int bound)")
   apply (simp add: nat_power_eq nat_mult_distrib)
  apply (subst nat_mono_iff)
   apply (rule le_less_trans, assumption)
   apply (erule le_less_trans[rotated])
   apply (simp add: mult_left_mono[where a="1::int", simplified])
  apply simp
  done

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_expr_binop [OF sint_bitwise_abstract_binops(1)]
  abstract_expr_binop [OF sint_bitwise_abstract_binops(2)]
  abstract_expr_binop [OF sint_bitwise_abstract_binops(3)]
  abstract_val_signed_bitNOT
  abstract_val_signed_unary_minus
  abstract_val_signed_shiftr_signed
  abstract_val_signed_shiftr_unsigned
  abstract_val_signed_shiftl_signed
  abstract_val_signed_shiftl_unsigned

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_expr_binop [OF unat_bitwise_abstract_binops(1)]
  abstract_expr_binop [OF unat_bitwise_abstract_binops(2)]
  abstract_expr_binop [OF unat_bitwise_abstract_binops(3)]
  abstract_val_unsigned_bitNOT
  abstract_val_unsigned_unary_minus
  abstract_val_unsigned_shiftr_signed
  abstract_val_unsigned_shiftr_unsigned
  abstract_val_unsigned_shiftl_signed
  abstract_val_unsigned_shiftl_unsigned

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

(* Base rule for heap-lifted signed words. See the function mk_sword_heap_get_rule. *)
lemma abstract_val_heap_sword_template:
  "\<lbrakk> introduce_typ_abs_fn (sint :: ('a::len) signed word \<Rightarrow> int);
     abstract_val P p' id p \<rbrakk>
   \<Longrightarrow> abstract_val P (sint (ucast (heap_get s p' :: 'a word) :: 'a signed word))
                      sint (ucast (heap_get s p) :: 'a signed word)"
  by simp

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
  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)"
  by (metis Word.of_int_sint abstract_val_def len_signed word_sbin.inverse_norm)

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 sint_uint UWORD_MAX_def)
  unfolding ucast_def unat_def
  apply (subst int_word_uint)
  apply (metis (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 (fact valid_typ_abs_fn_id)

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 (metis (no_types, lifting) UWORD_MAX_def unat_le unat_max_word valid_typ_abs_fn_def
                                word_unat.Abs_inverse' word_unat.Rep_inverse)

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

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_3 scast_ucast_4 ucast_scast_3 ucast_scast_4
                 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


(******************************************************************************)
(* Submission: "The Interchange Law: A Principle of Concurrent Programming"   *)
(* Authors: Tony Hoare, Bernard Möller, Georg Struth, and Frank Zeyda         *)
(* File: Overflow_Monad.thy                                                   *)
(******************************************************************************)
(* LAST REVIEWED: 11 July 2017 *)

section {* The Overflow Monad *}

theory Overflow_Monad
imports Machine_Number
begin

subsection {* Type Definition *}

text \<open>Any type with a linear order can be lifted into a type that includes \<open>\<top>\<close>.\<close>

datatype 'a::linorder overflow =
  Value "'a" | Overflow

text \<open>The notation \<open>\<top>\<close> is introduced for the constructor @{const Overflow}.\<close>

adhoc_overloading global_top Overflow

subsection {* Proof Support *}

text \<open>Attribute used to collect definitional laws for operators.\<close>

named_theorems overflow_ops "definitional laws for operators on overflow values"

text \<open>Tactic that facilitates proofs about @{type overflow} values.\<close>

lemma split_overflow_all:
"(\<forall>x. P x) = (P Overflow \<and> (\<forall>x. P (Value x)))"
apply (safe)
-- {* Subgoal 1 *}
apply (clarsimp)
-- {* Subgoal 2 *}
apply (clarsimp)
-- {* Subgoal 3 *}
apply (case_tac x)
apply (simp_all)
done

lemma split_overflow_ex:
"(\<exists>x. P x) = (P Overflow \<or> (\<exists>x. P (Value x)))"
apply (safe)
-- {* Subgoal 1 *}
apply (case_tac x)
apply (simp_all) [2]
-- {* Subgoal 2 *}
apply (auto) [1]
-- {* Subgoal 3 *}
apply (auto) [1]
done

lemmas split_overflow =
  split_overflow_all
  split_overflow_ex

method overflow_tac = (
  (atomize (full))?,
  (simp add: split_overflow overflow_ops),
  (clarsimp; simp?)?)

subsection {* Ordering Relation *}

text \<open>Overflow (\<open>\<top>\<close>) resides above any other value in the order.\<close>

instantiation overflow :: (linorder) linorder
begin
fun less_eq_overflow :: "'a overflow \<Rightarrow> 'a overflow \<Rightarrow> bool" where
"Value x \<le> Value y \<longleftrightarrow> x \<le> y" |
"Value x \<le> Overflow \<longleftrightarrow> True" |
"Overflow \<le> Value x \<longleftrightarrow> False" |
"Overflow \<le> Overflow \<longleftrightarrow> True"

fun less_overflow :: "'a overflow \<Rightarrow> 'a overflow \<Rightarrow> bool" where
"Value x < Value y \<longleftrightarrow> x < y" |
"Value x < Overflow \<longleftrightarrow> True" |
"Overflow < Value x \<longleftrightarrow> False" |
"Overflow < Overflow \<longleftrightarrow> False"
instance
apply (intro_classes)
-- {* Subgoal 1 *}
apply (overflow_tac)
apply (rule less_le_not_le)
-- {* Subgoal 2 *}
apply (overflow_tac)
-- {* Subgoal 3 *}
apply (overflow_tac)
-- {* Subgoal 4 *}
apply (overflow_tac)
-- {* Subgoal 5 *}
apply (overflow_tac)
done
end

text \<open>More instantiations can be added here as we desire.\<close>

instantiation overflow :: ("{linorder, zero}") zero
begin
definition zero_overflow :: "'a overflow" where
[simp]: "zero_overflow = Value 0"
instance ..
end

instantiation overflow :: ("{linorder, one}") one
begin
definition one_overflow :: "'a overflow" where
[simp]: "one_overflow = Value 1"
instance ..
end

subsection {* Monadic Constructors *}

text \<open>To support monadic syntax, we define the bind and return functions below.\<close>

primrec overflow_bind ::
  "'a::linorder overflow \<Rightarrow> ('a \<Rightarrow> 'b::linorder overflow) \<Rightarrow> 'b overflow" where
"overflow_bind (Overflow) f = Overflow" |
"overflow_bind (Value x)  f = f x"

adhoc_overloading bind overflow_bind

definition overflow_return :: "'a::linorder \<Rightarrow> 'a overflow" where
[simp]: "overflow_return x = Value x"

adhoc_overloading return overflow_return

subsection \<open>Generic Lifting\<close>

text \<open>Extended machine numbers are machine numbers that record an overflow.\<close>

type_synonym 'a machine_number_ext = "'a machine_number overflow"

translations
  (type) "'a machine_number_ext" \<leftharpoondown> (type) "'a machine_number overflow"

text \<open>We use the constant below for ad hoc overloading to avoid ambiguities.\<close>

consts lift_overflow :: "'a \<Rightarrow> 'b" ("_\<up>\<^sub>\<infinity>" [1000] 1000)

default_sort machine_number

definition ulift_overflow ::
  "('a \<Rightarrow> 'b) \<Rightarrow>
   ('a machine_number_ext \<Rightarrow> 'b machine_number_ext)" where
"ulift_overflow f x =
  do {x' \<leftarrow> x; if (f \<lbrakk>x'\<rbrakk>) \<in> number_range then return MN(f \<lbrakk>x'\<rbrakk>) else \<top>}"

definition blift_overflow ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow>
   ('a machine_number_ext \<Rightarrow> 'b machine_number_ext \<Rightarrow> 'c machine_number_ext)" where
"blift_overflow f x y = do {x' \<leftarrow> x; y' \<leftarrow> y;
  if (f \<lbrakk>x'\<rbrakk> \<lbrakk>y'\<rbrakk>) \<in> number_range then return MN(f \<lbrakk>x'\<rbrakk> \<lbrakk>y'\<rbrakk>) else \<top>}"

default_sort type

adhoc_overloading lift_overflow ulift_overflow
adhoc_overloading lift_overflow blift_overflow

text \<open>Note that we do not add the above operators to @{attribute overflow_ops}.\<close>

lemma ulift_overflow_simps [simp]:
"ulift_overflow f \<top> = \<top>"
"ulift_overflow f (Value x) =
  (if (f \<lbrakk>x\<rbrakk>) \<le> max_number then Value MN(f \<lbrakk>x\<rbrakk>) else \<top>)"
apply (unfold ulift_overflow_def)
apply (simp_all)
done

lemma blift_overflow_simps [simp]:
"blift_overflow f x \<top> = \<top>"
"blift_overflow f \<top> y = \<top>"
"blift_overflow f (Value x') (Value y') =
  (if (f \<lbrakk>x'\<rbrakk> \<lbrakk>y'\<rbrakk>) \<le> max_number then Value MN(f \<lbrakk>x'\<rbrakk> \<lbrakk>y'\<rbrakk>) else \<top>)"
apply (unfold blift_overflow_def)
apply (simp_all)
apply (case_tac x; simp)
done

subsection \<open>Lifted Operators\<close>

definition plus_overflow::
  "'a::{plus, machine_number} machine_number_ext binop" (infixl "+\<^sub>\<infinity>" 70) where
"plus_overflow = (op +)\<up>\<^sub>\<infinity>"

definition minus_overflow ::
  "'a::{minus, machine_number} machine_number_ext binop" (infixl "-\<^sub>\<infinity>" 70) where
"minus_overflow = (op -)\<up>\<^sub>\<infinity>"

definition times_overflow::
  "'a::{times, machine_number} machine_number_ext binop" (infixl "*\<^sub>\<infinity>" 70) where
"times_overflow = (op *)\<up>\<^sub>\<infinity>"

definition divide_overflow ::
  "'a::{divide, machine_number} machine_number_ext binop" (infixl "div\<^sub>\<infinity>" 70) where
"divide_overflow = (op div)\<up>\<^sub>\<infinity>"

paragraph {* Proof Support *}

declare plus_overflow_def [overflow_ops]
declare minus_overflow_def [overflow_ops]
declare times_overflow_def [overflow_ops]
declare divide_overflow_def [overflow_ops]

subsection {* Instantiation Example *}

text \<open>We give an instantiation for natural numbers.\<close>

instantiation nat :: machine_number
begin
definition max_number_nat :: "nat" where
"max_number_nat = 2 ^^ 32 - 1"
instance ..
end

subsection {* Proof Experiments *}

lemma
fixes x :: "nat machine_number_ext"
fixes y :: "nat machine_number_ext"
shows "x *\<^sub>\<infinity> y = y *\<^sub>\<infinity> x"
-- \<open>Is there another way to turn free variables in meta-quantified ones?\<close>
apply (transfer)
apply (overflow_tac)
apply (simp add: mult.commute)
done

text \<open>Yes, using the below. Turn this into a tactic command! [TODO]\<close>

ML {* Induct.arbitrary_tac *}
end


theory Chapter11
imports "HOL-IMP.Denotational" "HOL-IMP.Vars"
begin

text\<open>
\section*{Chapter 11}

\begin{exercise}
Building on Exercise~\ref{exe:IMP:REPEAT}, extend the denotational
semantics and the equivalence proof with the big-step semantics
with a @{text REPEAT} loop.
\end{exercise}

\exercise
Consider Example~11.14 and prove the following equation by induction on @{text n}:
\<close>
lemma "(W (\<lambda>s. s ''x'' \<noteq> 0) {(s,t). t = s(''x'' := s ''x'' - 1)} ^^ n) {} =
  {(s,t). 0 \<le> s ''x'' \<and> s ''x'' < int n \<and> t = s(''x'' := 0)}" (is "(W ?b ?c ^^ n) {} = ?S n")
proof (induct n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  let "?W n" = "W ?b ?c ^^ n"
  have "?W (Suc n) {} = W ?b ?c (?W n {})" by simp
  also from Suc have "\<dots> = W ?b ?c (?S n)" by (rule arg_cong)
  also have "\<dots> = ?S (Suc n)" by (force simp add: W_def)
  finally show ?case .
qed

text\<open>
\endexercise

\exercise
Consider Example~11.14 but with the loop condition
@{prop"b = Less (N 0) (V ''x'')"}. Find a closed expression @{text M}
(containing @{text n})
for @{prop"(f ^^ n) {}"} and prove @{prop"(f ^^ n) {} = M"}.
\<close>
lemma "(W (bval (Less (N 0) (V ''x''))) {(s,t). t = s(''x'' := s ''x'' - 1)} ^^ n) {} =
  {(s,t). 0 < n \<and> s ''x'' < int n \<and> t = (if 0 < s ''x'' then s(''x'' := 0) else s)}" (is "(W ?b ?c ^^ n) {} = ?S n")
proof (induct n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  let "?W n" = "W ?b ?c ^^ n"
  let ?S2 = "{(s, t). 0 < n \<and> s ''x'' < int n \<and> t = (if 0 < s ''x'' then s(''x'' := 0) else s)}"
  have "?W (Suc n) {} = W ?b ?c (?W n {})" by simp
  also from Suc have "\<dots> = W ?b ?c (?S n)" by (rule arg_cong)
  also have "\<dots> = {(s, t). if ?b s then (s,t) \<in> ?c O (?S n) else s=t}" by (simp add: W_def)
  also have "\<dots> = ?S (Suc n)"
  proof (cases "0 < n")
    case npos: True
    then show ?thesis
    proof (intro equalityI subsetI, fastforce split: if_split_asm)
      fix x
      assume H1: "0 < n" "x \<in> ?S (Suc n)"
      then obtain s t where H2: "x = (s, t)" "0 < Suc n" "s ''x'' < int (Suc n)" "t = (if 0 < s ''x'' then s(''x'' := 0) else s)" by auto
      let ?s' = "s(''x'' := s ''x'' - 1)"
      have "if ?b s then (s, t) \<in> ?c O ?S n else s = t"
      proof (cases "0 < s ''x''")
        case sxpos: True
        have "(s, ?s') \<in> ?c" by auto
        moreover have "(?s', t) \<in> ?S n"
        proof -
          from H1(1) have "0 < n" .
          moreover from H2(3) have "?s' ''x'' < int n" by simp
          moreover from H2(4) sxpos have "t = (if 0 < ?s' ''x'' then ?s'(''x'' := 0) else ?s')" by (auto split: if_split_asm)
          ultimately show ?thesis by simp
        qed
        ultimately have "(s, t) \<in> ?c O ?S n" by fastforce
        with sxpos show ?thesis by fastforce
      qed (simp add: H2(4))
      with H2(1) show "x \<in> {(s, t). if ?b s then (s, t) \<in> ?c O ?S n else s = t}" by auto
    qed
  next
    case npos: False
    then show ?thesis
    proof (intro equalityI subsetI, fastforce split: if_split_asm)
      fix x
      assume H1: "\<not>0 < n" "x \<in> ?S (Suc n)"
      then obtain s t where H2: "x = (s, t)" "n = 0" "s ''x'' < int (Suc n)" "t = (if 0 < s ''x'' then s(''x'' := 0) else s)" by auto
      then show "x \<in> {(s, t). if ?b s then (s, t) \<in> ?c O ?S n else s = t}" by fastforce
    qed
  qed
  finally show "?W (Suc n) {} = ?S (Suc n)" .
qed

text \<open>
\endexercise

\exercise
Define an operator @{text B} such that you
can express the equation for @{term "D (IF b THEN c1 ELSE c2)"}
in a point free way.
\<close>
definition B :: "bexp \<Rightarrow> (state \<times> state) set" where
  "B b = {(s, t). bval b s \<and> s = t}"

lemma "D (IF b THEN c1 ELSE c2) = (B b O D c1) \<union> (B (Not b) O D c2)"
  unfolding B_def by auto

text \<open>
  Similarly, find a point free equation for @{term "W (bval b) dc"}
  and use it to write down a point free version of
  @{term "D (WHILE b DO c)"} (still using @{text lfp}).
  Prove that your equations are equivalent to the old ones.
\<close>

lemma Wpf: "W (bval b) dc = (\<lambda>dw. B b O dc O dw \<union> B (Not b))"
  unfolding W_def B_def by auto

lemma "D (WHILE b DO c) = lfp (\<lambda>dw. B b O D c O dw \<union> B (Not b))"
  by (simp add: Wpf)

text\<open>
\endexercise

\exercise
Let the `thin' part of a relation be its single-valued subset:
\<close>

definition thin :: "'a rel \<Rightarrow> 'a rel" where
"thin R = {(a,b) . (a,b) \<in> R \<and> (\<forall> c. (a,c) \<in> R \<longrightarrow> c = b)}"

lemma single_valued_thin: "single_valued (thin R)"
  unfolding single_valued_def thin_def by auto

text\<open> Prove \<close>

lemma fixes f :: "'a rel \<Rightarrow> 'a rel"
assumes "mono f" and thin_f: "\<And> R. f (thin R) \<subseteq> thin (f R)"
shows "single_valued (lfp f)"
proof -
  from thin_f have "f (thin (lfp f)) \<subseteq> thin (f (lfp f))" .
  also from \<open>mono f\<close> have "thin (f (lfp f)) = thin (lfp f)" by (simp add: lfp_fixpoint)
  finally have "lfp f \<subseteq> thin (lfp f)" by (simp add: lfp_lowerbound)
  with single_valued_thin show "single_valued (lfp f)" by (blast intro: single_valued_subset)
qed

text\<open>
\endexercise

\exercise
Generalise our set-theoretic treatment of continuity and least fixpoints to
\concept{chain-complete partial order}s (\concept{cpo}s),
i.e.\ partial orders @{text"\<le>"} that have a least element @{text "\<bottom>"} and
where every chain @{text"c 0 \<le> c 1 \<le> \<dots>"} has a least upper bound
@{term"lub c"} where \noquotes{@{term[source]"c :: nat \<Rightarrow> 'a"}}.
This setting is described by the following type class @{text cpo}
which is an extension of the type class @{class order} of partial orders.
For details see the decription of type classes in Chapter~13.
\<close>

context order
begin
definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
"chain c = (\<forall>n. c n \<le> c (Suc n))"
end

class cpo = order +
fixes bot :: 'a and lub :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a"
assumes bot_least: "bot \<le> x"
and lub_ub: "chain c \<Longrightarrow> c n \<le> lub c"
and lub_least: "chain c \<Longrightarrow> (\<And>n. c n \<le> u) \<Longrightarrow> lub c \<le> u"

text\<open>
A function \noquotes{@{term[source] "f :: 'a \<Rightarrow> 'b"}}
between two cpos @{typ 'a} and @{typ 'b}
is called \concept{continuous} if @{prop"f(lub c) = lub (f o c)"}.
Prove that if @{text f} is monotone and continuous then
\ \mbox{@{text"lub (\<lambda>n. (f ^^ n) \<bottom>)"}} \ is the least (pre)fixpoint of @{text f}:
\<close>

definition cont :: "('a::cpo \<Rightarrow> 'b::cpo) \<Rightarrow> bool" where
"cont f = (\<forall>c. chain c \<longrightarrow> f (lub c) = lub (f o c))"

abbreviation "fix f \<equiv> lub (\<lambda>n. (f^^n) bot)"

lemma bot_mono: fixes f :: "'a::cpo \<Rightarrow> 'a" assumes "mono f" shows "(f ^^ n) bot \<le> (f ^^ Suc n) bot"
proof (induct n)
  case (Suc n)
  with assms show ?case unfolding mono_def by simp
qed (simp add: bot_least)

lemma fix_lpfp: assumes "mono f" and "f p \<le> p" shows "fix f \<le> p"
proof (intro lub_least, simp add: chain_def, intro allI)
  from bot_mono [OF assms(1)] show "(f ^^ n) cpo_class.bot \<le> f ((f ^^ n) cpo_class.bot)" for n by simp
  show "(f ^^ n) cpo_class.bot \<le> p" for n
  proof (induct n)
    case (Suc n)
    with assms show ?case unfolding mono_def by fastforce
  qed (simp add: bot_least)
qed

theorem fix_fp: assumes "mono f" and "cont f" shows "f(fix f) = fix f"
proof -
  let ?c = "(\<lambda>n. (f^^n) bot)"
  let ?cS = "(\<lambda>n. (f^^Suc n) bot)"
  from bot_mono [OF assms(1)] have cc: "chain ?c" unfolding chain_def by simp
  then have ccS: "chain ?cS" unfolding chain_def by fastforce
  with assms(2) cc have "f (lub ?c) = lub (f \<circ> ?c)" unfolding cont_def by blast
  also have "f \<circ> ?c = ?cS" by (rule ext, auto)
  then have "lub (f \<circ> ?c) = lub ?cS" by simp
  also have "lub ?cS = fix f"
  proof (rule antisym)
    from ccS show "lub ?cS \<le> fix f"
    proof (elim lub_least)
      fix n
      from lub_ub [OF cc, of "Suc n"] show "(f ^^ Suc n) bot \<le> fix f" .
    qed
    from cc show "fix f \<le> lub (\<lambda>n. (f ^^ Suc n) bot)"
    proof (elim lub_least)
      fix n
      from cc have "(f ^^ n) bot \<le> (f ^^ Suc n) bot" unfolding chain_def by simp
      also from lub_ub [OF ccS] have "\<dots> \<le> lub (\<lambda>n. (f ^^ Suc n) bot)" .
      finally show "(f ^^ n) bot \<le> lub (\<lambda>n. (f ^^ Suc n) bot)" .
    qed
  qed
  finally show ?thesis .
qed

text\<open>
\endexercise

\exercise
We define a dependency analysis @{text Dep} that maps commands to relations
between variables such that @{term "(x,y) : Dep c"} means that in
the execution of @{text c}
the initial value of @{text x} can influence the final value of @{text y}:
\<close>

fun Dep :: "com \<Rightarrow> (vname * vname) set" where
"Dep SKIP = Id" |
"Dep (x::=a) = {(u,v). if v = x then u \<in> vars a else u = v}" |
"Dep (c1;;c2) = Dep c1 O Dep c2" |
"Dep (IF b THEN c1 ELSE c2) = Dep c1 \<union> Dep c2 \<union> vars b \<times> UNIV" |
"Dep (WHILE b DO c) = lfp(\<lambda>R. Id \<union> vars b \<times> UNIV \<union> Dep c O R)"

text\<open>
where @{text"\<times>"} is the cross product of two sets.
Prove monotonicity of the function @{const lfp} is applied to.
\<close>

text\<open> For the correctness statement define \<close>

abbreviation Deps :: "com \<Rightarrow> vname set \<Rightarrow> vname set" where
"Deps c X \<equiv> (\<Union> x\<in>X. {y. (y,x) : Dep c})"

text\<open> and prove \<close>

lemma "\<lbrakk> (c,s) \<Rightarrow> s';  (c,t) \<Rightarrow> t';  s = t on Deps c X \<rbrakk> \<Longrightarrow> s' = t' on X"
proof (induct arbitrary: t t' X rule: big_step_induct)
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  from Seq(5) obtain ti where Hti: "(c\<^sub>1, t) \<Rightarrow> ti" "(c\<^sub>2, ti) \<Rightarrow> t'" by auto
  from Seq(6) have "s\<^sub>1 = t on Deps c\<^sub>1 (Deps c\<^sub>2 X)" by auto
  from Seq(2) [OF Hti(1) this] have "s\<^sub>2 = ti on Deps c\<^sub>2 X" .
  from Seq(4) [OF Hti(2) this] show ?case .
next
  case (IfTrue b s c\<^sub>1 s' c\<^sub>2)
  show ?case
  proof (cases "X = {}")
    case False
    with IfTrue(5) have Heq: "s = t on vars b" "s = t on Deps c\<^sub>1 X" by auto
    from bval_eq_if_eq_on_vars [OF Heq(1)] IfTrue(1) have "bval b t" by simp
    with IfTrue(4) have "(c\<^sub>1, t) \<Rightarrow> t'" by auto
    from IfTrue(3) [OF this Heq(2)] show ?thesis .
  qed simp
next
  case (IfFalse b s c\<^sub>2 s' c\<^sub>1)
  then show ?case
  proof (cases "X = {}")
    case False
    with IfFalse(5) have Heq: "s = t on vars b" "s = t on Deps c\<^sub>2 X" by auto
    from bval_eq_if_eq_on_vars [OF Heq(1)] IfFalse(1) have "\<not>bval b t" by simp
    with IfFalse(4) have "(c\<^sub>2, t) \<Rightarrow> t'" by auto
    from IfFalse(3) [OF this Heq(2)] show ?thesis .
  qed simp
next
  case (WhileFalse b s c)
  let ?f = "\<lambda>R. Id \<union> vars b \<times> UNIV \<union> Dep c O R"
  have monof: "mono ?f" unfolding mono_def by auto
  from lfp_fixpoint [OF this] have fpf: "?f (lfp ?f) = lfp ?f" .
  show ?case
  proof (cases "X = {}")
    case False
    then have "vars b \<subseteq> (\<Union> x\<in>X. {y. (y,x) \<in> ?f (lfp ?f)})" by auto
    also from fpf have "\<dots> \<subseteq> Deps (WHILE b DO c) X" by simp
    finally have "vars b \<subseteq> Deps (WHILE b DO c) X" .
    with WhileFalse(3) have Heq1: "s = t on vars b" by auto
    from bval_eq_if_eq_on_vars [OF Heq1] WhileFalse(1) have "\<not>bval b t" by simp
    with WhileFalse(2) have Htt': "t' = t" by auto
    from False have "X \<subseteq> (\<Union> x\<in>X. {y. (y,x) \<in> ?f (lfp ?f)})" by auto
    also from fpf have "\<dots> \<subseteq> Deps (WHILE b DO c) X" by simp
    finally have Heq2: "X \<subseteq> Deps (WHILE b DO c) X" .
    with WhileFalse(3) Htt' show ?thesis by auto
  qed simp
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  let ?f = "\<lambda>R. Id \<union> vars b \<times> UNIV \<union> Dep c O R"
  have monof: "mono ?f" unfolding mono_def by auto
  from lfp_fixpoint [OF this] have fpf: "?f (lfp ?f) = lfp ?f" .
  show ?case
  proof (cases "X = {}")
    case False
    then have "vars b \<subseteq> (\<Union> x\<in>X. {y. (y,x) \<in> ?f (lfp ?f)})" by auto
    also from fpf have "\<dots> \<subseteq> Deps (WHILE b DO c) X" by simp
    finally have "vars b \<subseteq> Deps (WHILE b DO c) X" .
    with WhileTrue(7) have Heq1: "s\<^sub>1 = t on vars b" by auto
    from bval_eq_if_eq_on_vars [OF Heq1] WhileTrue(1) have "bval b t" by simp
    with WhileTrue(6) obtain ti where Htw: "(c, t) \<Rightarrow> ti" "(WHILE b DO c, ti) \<Rightarrow> t'" by auto
    have "Deps c (Deps (WHILE b DO c) X) \<subseteq> Deps (WHILE b DO c) X" using lfp_fixpoint [OF monof] by auto
    with WhileTrue(7) have "s\<^sub>1 = t on Deps c (Deps (WHILE b DO c) X)" by blast
    from WhileTrue(3) [OF Htw(1) this] have "s\<^sub>2 = ti on Deps (WHILE b DO c) X" .
    from WhileTrue(5) [OF Htw(2) this] show ?thesis .
  qed simp
qed auto

text\<open>

Give an example that the following stronger termination-sensitive property
@{prop[display] "\<lbrakk> (c,s) \<Rightarrow> s'; s = t on Deps c X \<rbrakk>
  \<Longrightarrow> \<exists>t'. (c,t) \<Rightarrow> t' \<and> s' = t' on X"}
does not hold. Hint: @{prop"X = {}"}.
\<close>

lemma "\<exists> c s s' t X. (c, s) \<Rightarrow> s' \<and> s = t on Deps c X \<and> (\<nexists>t'. (c, t) \<Rightarrow> t')"
proof -
  let ?b = "Less (N 0) (V ''x'')"
  let ?c = "SKIP"
  let ?w = "WHILE ?b DO ?c"
  let ?s = "<> :: vname \<Rightarrow> val"
  let ?t = "<''x'' := 1> :: vname \<Rightarrow> val"
  have H1: "(?w, ?s) \<Rightarrow> ?s" unfolding null_state_def by auto
  have H2: "?s = ?t on Deps ?w {}" by simp
  have Hbt: "bval ?b ?t" by simp
  have H3: "\<nexists>t'. (?w, ?t) \<Rightarrow> t'"
  proof
    assume "\<exists>t'. (?w, ?t) \<Rightarrow> t'"
    then obtain t' where "(?w, ?t) \<Rightarrow> t'" by auto
    then show "False"
      using Hbt by (induct "?w" "?t" t' rule: big_step_induct) auto
  qed
  from H1 H2 H3 show ?thesis by blast
qed

text\<open>

In the definition of @{term"Dep(IF b THEN c1 ELSE c2)"} the variables
in @{text b} can influence all variables (@{text UNIV}). However,
if a variable is not assigned to in @{text c1} and @{text c2}
it is not influenced by @{text b} (ignoring termination).
Theory @{theory "HOL-IMP.Vars"} defines a function @{const lvars} such
that @{term"lvars c"} is the set of variables on the left-hand side
of an assignment in @{text c}.
Modify the definition of @{const Dep} as follows:
replace @{const UNIV} by @{term"lvars c1 \<union> lvars c2"}
(in the case @{term"IF b THEN c1 ELSE c2"}) and by \mbox{@{term"lvars c"}}
(in the case @{term"WHILE b DO c"}).
Adjust the proof of the above correctness statement.
\<close>

text\<open>
\endexercise
\<close>

end