(*
 * 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 [simplified]: "INT_MAX \<equiv> (2 :: int) ^ 31 - 1"
definition [simplified]: "INT_MIN \<equiv> - ((2 :: int) ^ 31)"
definition [simplified]: "UINT_MAX \<equiv> (2 :: nat) ^ 32 - 1"

definition [simplified]: "SHORT_MAX \<equiv> (2 :: int) ^ 15 - 1"
definition [simplified]: "SHORT_MIN \<equiv> - ((2 :: int) ^ 15)"
definition [simplified]: "USHORT_MAX \<equiv> (2 :: nat) ^ 16 - 1"

definition [simplified]: "CHAR_MAX \<equiv> (2 :: int) ^ 7 - 1"
definition [simplified]: "CHAR_MIN \<equiv> - ((2 :: int) ^ 7)"
definition [simplified]: "UCHAR_MAX \<equiv> (2 :: nat) ^ 8 - 1"

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_MIN (TYPE(8 signed)) = - (2 ^ 7)"
  "WORD_MIN (TYPE(16 signed)) = - (2 ^ 15)"
  "WORD_MIN (TYPE(32 signed)) = - (2 ^ 31)"

  "UWORD_MAX (TYPE(8)) = (2 ^ 8 - 1)"
  "UWORD_MAX (TYPE(16)) = (2 ^ 16 - 1)"
  "UWORD_MAX (TYPE(32)) = (2 ^ 32 - 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]

(* These are added to the Polish simps after translation *)
lemma WORD_MAX_simps:
   "WORD_MAX TYPE(32) = INT_MAX"
   "WORD_MAX TYPE(16) = SHORT_MAX"
   "WORD_MAX TYPE(8) = CHAR_MAX"
  by (auto simp: INT_MAX_def SHORT_MAX_def CHAR_MAX_def WORD_MAX_def)

lemma WORD_MIN_simps:
   "WORD_MIN TYPE(32) = INT_MIN"
   "WORD_MIN TYPE(16) = SHORT_MIN"
   "WORD_MIN TYPE(8) = CHAR_MIN"
  by (auto simp: INT_MIN_def SHORT_MIN_def CHAR_MIN_def WORD_MIN_def)

lemma UWORD_MAX_simps:
   "UWORD_MAX TYPE(32) = UINT_MAX"
   "UWORD_MAX TYPE(16) = USHORT_MAX"
   "UWORD_MAX TYPE(8) = UCHAR_MAX"
  by (auto simp: UINT_MAX_def USHORT_MAX_def UCHAR_MAX_def UWORD_MAX_def)

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)

lemma INT_MIN_MAX_lemmas [simp]:
  "unat (u :: word32) \<le> UINT_MAX"
  "sint (s :: sword32) \<le> INT_MAX"
  "INT_MIN \<le> sint (s :: sword32)"
  "INT_MIN \<le> INT_MAX"
  "INT_MIN \<le> sint (s :: sword32)"
  "INT_MIN \<le> INT_MAX"
  "INT_MIN \<le> 0"
  "0 \<le> INT_MAX"

  "\<not> (sint (s :: sword32) > INT_MAX)"
  "\<not> (INT_MIN > sint (s :: sword32))"
  "\<not> (unat (u :: word32) > UINT_MAX)"

  unfolding UINT_MAX_def INT_MAX_def INT_MIN_def
  using sint_range_size [where w=s, simplified word_size, simplified]
        unat_lt2p [where 'a=32, simplified]
        zle_add1_eq_le [where z=INT_MAX, symmetric]
        less_eq_Suc_le not_less_eq_eq
        unat_lt2p [where x=u]
  by auto

(*
 * 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(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(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: sword32 \<rightarrow> int
 *)

lemmas word_abs_sword32 =
  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 :: (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: word32 \<rightarrow> nat
 *)

lemmas word_abs_word32 =
  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 :: (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


theory maximum
  imports "~~/src/HOL/Hoare/Hoare_Logic"
    "~~/src/HOL/Hoare/Arith2"
    "~~/src/HOL/Hoare/List"
begin

(* ******************* *)
(* ******************* *)
(* ******************* *)

definition maximum :: "nat list \<Rightarrow> nat" where
  "maximum l = foldr max l 0"

value "maximum [1,3,5,4,2]"    (* 5 *)
value "maximum []"             (* 0 *)

lemma max_hdtl_eq [simp] : "l \<noteq> [] \<Longrightarrow> max (hd l) (maximum (tl l)) = maximum l"
  apply (induct l)
  apply (auto)
  apply (simp add: hd_def tl_def maximum_def)
  done

(* ******* *)
(* ******* *)
(* ******* *)

lemma l1 : "max (maximum x) y = maximum l \<Longrightarrow>
       x \<noteq> [] \<Longrightarrow> y \<le> hd x \<Longrightarrow> max (maximum (tl x)) (hd x) = maximum l"
  by (metis max.assoc max.commute max_def max_hdtl_eq)
(*
proof -
  fix x y l
  assume 1 : "max (maximum x) y = maximum l" and
    2 : "x \<noteq> []" and
    3 : "y \<le> hd x"
  show "max (maximum (tl x)) (hd x) = maximum l"
    by (metis "1" "2" "3" max.assoc max.commute max_def max_hdtl_eq)
qed
*)

lemma l2 : "max (maximum x) y = maximum l \<Longrightarrow>
       x \<noteq> [] \<Longrightarrow> \<not> y \<le> hd x \<Longrightarrow> max (maximum (tl x)) y = maximum l"
  by (metis max.assoc max.commute max_def max_hdtl_eq)
(*
proof -
  fix x y l
  assume 1 : "max (maximum x) y = maximum l" and
    2 : "x \<noteq> []" and
    3 : "\<not> y \<le> hd x"
  show "max (maximum (tl x)) y = maximum l"
    by (metis "1" "2" "3" max.assoc max.commute max_def max_hdtl_eq)
qed
*)

lemma l3 : "max (maximum []) y = maximum l \<Longrightarrow> y = maximum l"
  by (simp add: maximum_def)
(*
proof -
  fix y l
  assume "max (maximum []) y = maximum l"
  thus "y = maximum l" using maximum_def by auto
qed
*)

(* ******* *)
(* ******* *)
(* ******* *)

theorem "TRUE
  \<Longrightarrow>
  VARS x y l
  {x = l \<and> y = 0}
  y := 0;
  WHILE x \<noteq> []
  INV {max (maximum x) y = maximum l}
  DO
    IF y \<le> hd x THEN
      y := hd x
    ELSE
      SKIP
    FI;
    x := tl x
  OD
  {y = maximum l}"
  apply vcg
  apply auto
  apply (simp_all add: l1 l2 l3)
  done

end

(* END *)


section "Encoding"

theory Derive_Encode
imports Main "../Derive" Derive_Datatypes
begin

class encodeable =
  fixes encode :: "'a \<Rightarrow> bool list"

(* Manual instances for nat, unit, prod, and sum *)
instantiation nat and unit:: encodeable
begin
  fun encode_nat :: "nat \<Rightarrow> bool list" where
  "encode_nat 0 = []" |
  "encode_nat (Suc n) = True # (encode n)"

  definition encode_unit: "encode (x::unit) = []"
  instance ..
end

instantiation prod and sum :: (encodeable, encodeable) encodeable
begin
  definition encode_prod_def: "encode x = append (encode (fst x)) (encode (snd x))"
  definition encode_sum_def:  "encode x = (case x of Inl a \<Rightarrow> False # encode a
                                                   | Inr a \<Rightarrow> True # encode a)"
  instance ..
end

derive_generic encodeable simple .
derive_generic encodeable either .

lemma "encode (B 3 4) = [True, False, True, True, True, True, True, True, True]" by eval
lemma "encode C = [True, True]" by eval
lemma "encode (R (3::nat)) = [True, True, True, True]" by code_simp

(* recursive types *)

derive_generic encodeable list .
derive_generic encodeable tree .

lemma "encode [1,2,3,4::nat]
  = [True, True, True, True, True, True, True, True, True, True, True, True, True, True, False]" by eval
lemma "encode (Node (3::nat) (Node 1 Leaf Leaf) (Node 2 Leaf Leaf))
  = [True, True, True, True, True, True, False, False, True, True, True, False, False]" by eval

(* mutually recursive types *)

derive_generic encodeable even_nat .
derive_generic encodeable exp .

lemma "encode (Odd_Succ (Even_Succ (Odd_Succ Even_Zero)))
  = [True, False, True, True, False, False]" by eval
lemma "encode (Term (Prod (Const (1::nat)) (Factor (Const (2::nat)))))
  = [False, False, True, False, True, True, True, False, True, True, False, False, True, True, False, True, True]"
  by code_simp

end


theory Ex17
imports Main
begin

(*associativity of and *)
lemma "(A \<and> B)\<and> C \<longleftrightarrow> A \<and> (B \<and> C)"
proof -
{
  assume "(A \<and> B) \<and> C"
  hence "A \<and> B" by (rule conjE)
  hence A by (rule conjE)
  from \<open>A \<and> B\<close> have B by (rule conjE)
  from \<open>(A \<and> B) \<and> C\<close> have C by (rule conjE)
  with \<open>B\<close> have "B \<and> C" by (rule conjI)
  with \<open>A\<close> have "A \<and> (B \<and> C)" by (rule conjI)
}
moreover
{
  assume " A \<and> (B \<and> C)"
  hence "B \<and> C" by (rule conjE)
  hence B by (rule conjE)
  from \<open>B \<and> C\<close> have C by (rule conjE)
  from \<open>A \<and> (B \<and> C)\<close> have A by (rule conjE)
  from \<open>A\<close> and \<open>B\<close> have "A \<and> B" by (rule conjI)
  from this and \<open>C\<close> have "(A \<and> B) \<and> C" by (rule conjI)
}

thm iffI
ultimately show ?thesis by (rule iffI)
qed


(*  Author: Stefan Berghofer, Lukas Bulwahn, TU Muenchen  *)

section \<open>A table-based implementation of the reflexive transitive closure\<close>

theory Transitive_Closure_Table
imports Main
begin

inductive rtrancl_path :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool"
  for r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  base: "rtrancl_path r x [] x"
| step: "r x y \<Longrightarrow> rtrancl_path r y ys z \<Longrightarrow> rtrancl_path r x (y # ys) z"

lemma rtranclp_eq_rtrancl_path: "r\<^sup>*\<^sup>* x y \<longleftrightarrow> (\<exists>xs. rtrancl_path r x xs y)"
proof
  show "\<exists>xs. rtrancl_path r x xs y" if "r\<^sup>*\<^sup>* x y"
    using that
  proof (induct rule: converse_rtranclp_induct)
    case base
    have "rtrancl_path r y [] y" by (rule rtrancl_path.base)
    then show ?case ..
  next
    case (step x z)
    from \<open>\<exists>xs. rtrancl_path r z xs y\<close>
    obtain xs where "rtrancl_path r z xs y" ..
    with \<open>r x z\<close> have "rtrancl_path r x (z # xs) y"
      by (rule rtrancl_path.step)
    then show ?case ..
  qed
  show "r\<^sup>*\<^sup>* x y" if "\<exists>xs. rtrancl_path r x xs y"
  proof -
    from that obtain xs where "rtrancl_path r x xs y" ..
    then show ?thesis
    proof induct
      case (base x)
      show ?case
        by (rule rtranclp.rtrancl_refl)
    next
      case (step x y ys z)
      from \<open>r x y\<close> \<open>r\<^sup>*\<^sup>* y z\<close> show ?case
        by (rule converse_rtranclp_into_rtranclp)
    qed
  qed
qed

lemma rtrancl_path_trans:
  assumes xy: "rtrancl_path r x xs y"
    and yz: "rtrancl_path r y ys z"
  shows "rtrancl_path r x (xs @ ys) z" using xy yz
proof (induct arbitrary: z)
  case (base x)
  then show ?case by simp
next
  case (step x y xs)
  then have "rtrancl_path r y (xs @ ys) z"
    by simp
  with \<open>r x y\<close> have "rtrancl_path r x (y # (xs @ ys)) z"
    by (rule rtrancl_path.step)
  then show ?case by simp
qed

lemma rtrancl_path_appendE:
  assumes xz: "rtrancl_path r x (xs @ y # ys) z"
  obtains "rtrancl_path r x (xs @ [y]) y" and "rtrancl_path r y ys z"
  using xz
proof (induct xs arbitrary: x)
  case Nil
  then have "rtrancl_path r x (y # ys) z" by simp
  then obtain xy: "r x y" and yz: "rtrancl_path r y ys z"
    by cases auto
  from xy have "rtrancl_path r x [y] y"
    by (rule rtrancl_path.step [OF _ rtrancl_path.base])
  then have "rtrancl_path r x ([] @ [y]) y" by simp
  then show thesis using yz by (rule Nil)
next
  case (Cons a as)
  then have "rtrancl_path r x (a # (as @ y # ys)) z" by simp
  then obtain xa: "r x a" and az: "rtrancl_path r a (as @ y # ys) z"
    by cases auto
  show thesis
  proof (rule Cons(1) [OF _ az])
    assume "rtrancl_path r y ys z"
    assume "rtrancl_path r a (as @ [y]) y"
    with xa have "rtrancl_path r x (a # (as @ [y])) y"
      by (rule rtrancl_path.step)
    then have "rtrancl_path r x ((a # as) @ [y]) y"
      by simp
    then show thesis using \<open>rtrancl_path r y ys z\<close>
      by (rule Cons(2))
  qed
qed

lemma rtrancl_path_distinct:
  assumes xy: "rtrancl_path r x xs y"
  obtains xs' where "rtrancl_path r x xs' y" and "distinct (x # xs')" and "set xs' \<subseteq> set xs"
  using xy
proof (induct xs rule: measure_induct_rule [of length])
  case (less xs)
  show ?case
  proof (cases "distinct (x # xs)")
    case True
    with \<open>rtrancl_path r x xs y\<close> show ?thesis by (rule less) simp
  next
    case False
    then have "\<exists>as bs cs a. x # xs = as @ [a] @ bs @ [a] @ cs"
      by (rule not_distinct_decomp)
    then obtain as bs cs a where xxs: "x # xs = as @ [a] @ bs @ [a] @ cs"
      by iprover
    show ?thesis
    proof (cases as)
      case Nil
      with xxs have x: "x = a" and xs: "xs = bs @ a # cs"
        by auto
      from x xs \<open>rtrancl_path r x xs y\<close> have cs: "rtrancl_path r x cs y" "set cs \<subseteq> set xs"
        by (auto elim: rtrancl_path_appendE)
      from xs have "length cs < length xs" by simp
      then show ?thesis
        by (rule less(1))(blast intro: cs less(2) order_trans del: subsetI)+
    next
      case (Cons d ds)
      with xxs have xs: "xs = ds @ a # (bs @ [a] @ cs)"
        by auto
      with \<open>rtrancl_path r x xs y\<close> obtain xa: "rtrancl_path r x (ds @ [a]) a"
        and ay: "rtrancl_path r a (bs @ a # cs) y"
        by (auto elim: rtrancl_path_appendE)
      from ay have "rtrancl_path r a cs y" by (auto elim: rtrancl_path_appendE)
      with xa have xy: "rtrancl_path r x ((ds @ [a]) @ cs) y"
        by (rule rtrancl_path_trans)
      from xs have set: "set ((ds @ [a]) @ cs) \<subseteq> set xs" by auto
      from xs have "length ((ds @ [a]) @ cs) < length xs" by simp
      then show ?thesis
        by (rule less(1))(blast intro: xy less(2) set[THEN subsetD])+
    qed
  qed
qed

inductive rtrancl_tab :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
  for r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  base: "rtrancl_tab r xs x x"
| step: "x \<notin> set xs \<Longrightarrow> r x y \<Longrightarrow> rtrancl_tab r (x # xs) y z \<Longrightarrow> rtrancl_tab r xs x z"

lemma rtrancl_path_imp_rtrancl_tab:
  assumes path: "rtrancl_path r x xs y"
    and x: "distinct (x # xs)"
    and ys: "({x} \<union> set xs) \<inter> set ys = {}"
  shows "rtrancl_tab r ys x y"
  using path x ys
proof (induct arbitrary: ys)
  case base
  show ?case
    by (rule rtrancl_tab.base)
next
  case (step x y zs z)
  then have "x \<notin> set ys"
    by auto
  from step have "distinct (y # zs)"
    by simp
  moreover from step have "({y} \<union> set zs) \<inter> set (x # ys) = {}"
    by auto
  ultimately have "rtrancl_tab r (x # ys) y z"
    by (rule step)
  with \<open>x \<notin> set ys\<close> \<open>r x y\<close> show ?case
    by (rule rtrancl_tab.step)
qed

lemma rtrancl_tab_imp_rtrancl_path:
  assumes tab: "rtrancl_tab r ys x y"
  obtains xs where "rtrancl_path r x xs y"
  using tab
proof induct
  case base
  from rtrancl_path.base show ?case
    by (rule base)
next
  case step
  show ?case
    by (iprover intro: step rtrancl_path.step)
qed

lemma rtranclp_eq_rtrancl_tab_nil: "r\<^sup>*\<^sup>* x y \<longleftrightarrow> rtrancl_tab r [] x y"
proof
  show "rtrancl_tab r [] x y" if "r\<^sup>*\<^sup>* x y"
  proof -
    from that obtain xs where "rtrancl_path r x xs y"
      by (auto simp add: rtranclp_eq_rtrancl_path)
    then obtain xs' where xs': "rtrancl_path r x xs' y" and distinct: "distinct (x # xs')"
      by (rule rtrancl_path_distinct)
    have "({x} \<union> set xs') \<inter> set [] = {}"
      by simp
    with xs' distinct show ?thesis
      by (rule rtrancl_path_imp_rtrancl_tab)
  qed
  show "r\<^sup>*\<^sup>* x y" if "rtrancl_tab r [] x y"
  proof -
    from that obtain xs where "rtrancl_path r x xs y"
      by (rule rtrancl_tab_imp_rtrancl_path)
    then show ?thesis
      by (auto simp add: rtranclp_eq_rtrancl_path)
  qed
qed

declare rtranclp_rtrancl_eq [code del]
declare rtranclp_eq_rtrancl_tab_nil [THEN iffD2, code_pred_intro]

code_pred rtranclp
  using rtranclp_eq_rtrancl_tab_nil [THEN iffD1] by fastforce

lemma rtrancl_path_Range: "\<lbrakk> rtrancl_path R x xs y; z \<in> set xs \<rbrakk> \<Longrightarrow> Rangep R z"
by(induction rule: rtrancl_path.induct) auto

lemma rtrancl_path_Range_end: "\<lbrakk> rtrancl_path R x xs y; xs \<noteq> [] \<rbrakk> \<Longrightarrow> Rangep R y"
by(induction rule: rtrancl_path.induct)(auto elim: rtrancl_path.cases)

lemma rtrancl_path_nth:
  "\<lbrakk> rtrancl_path R x xs y; i < length xs \<rbrakk> \<Longrightarrow> R ((x # xs) ! i) (xs ! i)"
proof(induction arbitrary: i rule: rtrancl_path.induct)
  case step thus ?case by(cases i) simp_all
qed simp

lemma rtrancl_path_last: "\<lbrakk> rtrancl_path R x xs y; xs \<noteq> [] \<rbrakk> \<Longrightarrow> last xs = y"
by(induction rule: rtrancl_path.induct)(auto elim: rtrancl_path.cases)

lemma rtrancl_path_mono:
  "\<lbrakk> rtrancl_path R x p y; \<And>x y. R x y \<Longrightarrow> S x y \<rbrakk> \<Longrightarrow> rtrancl_path S x p y"
by(induction rule: rtrancl_path.induct)(auto intro: rtrancl_path.intros)

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 IsPrime
imports
  "../../AutoCorres"
  "~~/src/HOL/Number_Theory/Number_Theory"
begin

(* Parse the input file. *)
install_C_file "is_prime.c"

(* Abstract the input file. *)
autocorres [ ts_rules = nondet, unsigned_word_abs = is_prime_linear is_prime ] "is_prime.c"

context is_prime begin

definition
  "partial_prime p (n :: nat) \<equiv>
        (1 < p \<and> (\<forall>i \<in> {2 ..< min p n}. \<not> i dvd p))"

lemma partial_prime_ge [simp]:
     "\<lbrakk> p' \<ge> p \<rbrakk> \<Longrightarrow> partial_prime p p' = prime p"
  by (clarsimp simp: partial_prime_def prime_nat_simp min_def)

lemma divide_self_plus_one [simp]: "(x dvd Suc x) = (x = 1)"
  apply (case_tac "x = 0", simp)
  apply (case_tac "x = 1", simp)
  apply (clarsimp simp: dvd_def)
  apply (case_tac "k = 0", simp)
  apply (case_tac "k = 1", simp)
  apply (subgoal_tac "x * 2 \<le> x * k")
   apply (subgoal_tac "Suc x < x * 2")
    apply simp
   apply clarsimp
  apply clarsimp
  done

lemma partial_prime_Suc [simp]:
  "partial_prime p (Suc n)
              = (partial_prime p n \<and> (1 < n \<and> Suc n < p \<longrightarrow> \<not> n dvd p))"
   apply (clarsimp simp: partial_prime_def min_def atLeastLessThanSuc not_le)
  apply (case_tac "p = Suc n")
   apply (clarsimp simp: atLeastLessThanSuc)
  apply fastforce
  done

lemma mod_to_dvd:
   "(n mod i \<noteq> 0) = (\<not> i dvd (n :: nat))"
  by (clarsimp simp: dvd_eq_mod_eq_0)

lemma prime_of_product [simp]: "prime ((a::nat) * b) = ((a = 1 \<and> prime b) \<or> (prime a \<and> b = 1))"
  apply (case_tac "a=0", clarsimp)
  apply (case_tac "a=1", clarsimp)
  apply (case_tac "b=0", clarsimp)
  apply (case_tac "b=1", clarsimp)
  apply (metis gcd_lcm_complete_lattice_nat.bot.extremum
      monoid_mult_class.mult.right_neutral mult_eq_self_implies_10
      nat_mult_dvd_cancel_disj prime_nat_def)
  done

lemma partial_prime_2 [simp]: "(partial_prime a 2) = (a > 1)"
  by (clarsimp simp: partial_prime_def)

definition [simp]:
  "is_prime_linear_inv n i s \<equiv> (1 < i \<and> 1 < n \<and> i \<le> n \<and> partial_prime n i)"

theorem is_prime_correct:
    "\<lbrace> \<lambda>s. n \<le> UINT_MAX \<rbrace> is_prime_linear' n \<lbrace> \<lambda>r s. (r \<noteq> 0) \<longleftrightarrow> prime n \<rbrace>!"
  apply (rule validNF_assume_pre)
  apply (case_tac "n = 0")
   apply (clarsimp simp: is_prime_linear'_def, wp, simp)[1]
  apply (case_tac "n = 1")
   apply (clarsimp simp: is_prime_linear'_def, wp, simp)[1]
  apply (unfold is_prime_linear'_def)
  apply (subst whileLoopE_add_inv [
      where I="\<lambda>r s. is_prime_linear_inv n r s"
                  and M="(\<lambda>(r, s). n - r)"])
  apply (wp, auto simp: mod_to_dvd [simplified])
  done

lemma not_prime:
    "\<lbrakk> \<not> prime (a :: nat); a > 1 \<rbrakk> \<Longrightarrow> \<exists>x y. x * y = a \<and> 1 < x \<and> 1 < y \<and> x * x \<le> a"
  apply (clarsimp simp: prime_nat_def dvd_def)
  apply (case_tac "m > k")
   apply (rule_tac x=k in exI)
   apply (rule_tac x=m in exI)
   apply (clarsimp)
   apply (metis Suc_lessD Suc_lessI nat_0_less_mult_iff)
  apply (rule_tac x=m in exI)
  apply (rule_tac x=k in exI)
  apply clarsimp
  done

lemma sqrt_prime:
  "\<lbrakk> a * a > n; \<forall>x<a. (x dvd n) = (x = Suc 0 \<or> x = n); 1 < n \<rbrakk> \<Longrightarrow> prime n"
  apply (rule ccontr)
  apply (drule not_prime)
   apply clarsimp
  apply (metis dvd_triv_right less_le_trans mult.commute mult_le_cancel2
           One_nat_def less_eq_nat.simps(1) less_not_refl2
           mult_eq_self_implies_10 not_less)
  done

lemma partial_prime_sqr:
     "\<lbrakk> n * n > p \<rbrakk> \<Longrightarrow> partial_prime p n = prime p"
  apply (case_tac "n \<ge> p")
   apply (clarsimp simp: partial_prime_ge)
  apply (case_tac "partial_prime p n")
   apply clarsimp
   apply (erule sqrt_prime)
    apply (clarsimp simp: partial_prime_def)
    apply (case_tac "x = 0", simp)
    apply (case_tac "x = 1", simp)
    apply (frule_tac x=x in bspec)
     apply (clarsimp simp: min_def)
    apply clarsimp
   apply (clarsimp simp: not_le partial_prime_def)
  apply (case_tac "p = 0", simp)
  apply (case_tac "p = 1", simp)
  apply (auto simp: not_le partial_prime_def min_def prime_nat_simp)
  done

definition "SQRT_UINT_MAX \<equiv> 65536 :: nat"

lemma uint_max_factor [simp]:
  "UINT_MAX = SQRT_UINT_MAX * SQRT_UINT_MAX - 1"
  by (clarsimp simp: UINT_MAX_def SQRT_UINT_MAX_def)

lemma prime_dvd:
    "\<lbrakk> prime (p::nat) \<rbrakk> \<Longrightarrow> (r dvd p) = (r = 1 \<or> r = p)"
  by (fastforce simp: prime_nat_def)

definition is_prime_inv
  where [simp]: "is_prime_inv n i s \<equiv> (1 < i \<and> i \<le> n \<and> i \<le> SQRT_UINT_MAX \<and> i * i \<le> SQRT_UINT_MAX * SQRT_UINT_MAX \<and> partial_prime n i)"

lemma nat_leE: "\<lbrakk> (a::nat) \<le> b; a < b \<Longrightarrow> R; a = b \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  apply atomize_elim
    apply clarsimp
  done

lemma sqr_less_mono [simp]:
    "((i::nat) * i < j * j) = (i < j)"
  by (metis (full_types) le0 less_not_refl3 linorder_neqE_nat
        mult_strict_mono' order.strict_trans)

declare mult_le_mono [intro]

lemma sqr_le_sqr_minus_1 [simp]:
    "\<lbrakk> b \<noteq> 0 \<rbrakk> \<Longrightarrow> (a * a \<le> b * b - Suc 0) = (a < b)"
  by (metis gr0I is_prime.sqr_less_mono nat_0_less_mult_iff nat_le_Suc_less)

theorem is_prime_faster_correct:
  notes times_nat.simps(2) [simp del] mult_Suc_right [simp del]
  shows "\<lbrace> \<lambda>s. n \<le> UINT_MAX \<rbrace> is_prime' n \<lbrace> \<lambda>r s. (r \<noteq> 0) \<longleftrightarrow> prime n \<rbrace>!"
  apply (rule validNF_assume_pre)
  apply (case_tac "n = 0")
   apply (clarsimp simp: is_prime'_def, wp, simp)[1]
  apply (case_tac "n = 1")
   apply (clarsimp simp: is_prime'_def, wp, simp)[1]
  apply (unfold is_prime'_def dvd_eq_mod_eq_0 [symmetric] SQRT_UINT_MAX_def [symmetric])
  apply (subst whileLoopE_add_inv [
      where I="\<lambda>r s. is_prime_inv n r s"
      and M="(\<lambda>(r, s). (Suc n) * (Suc n) - r * r)"])
   apply wp
  apply (fastforce elim: nat_leE simp: partial_prime_sqr prime_dvd)+
  apply (clarsimp simp: SQRT_UINT_MAX_def)
  done

end

end


(*  Title:      Depth-First Search
    Author:     Toshiaki Nishihara and Yasuhiko Minamide
    Maintainer: Yasuhiko Minamide <minamide at cs.tsukuba.ac.jp>
*)

header "Depth-First Search"

theory DFS
imports Main
begin

subsection "Definition of Graphs"

typedecl node
type_synonym graph = "(node * node) list"

primrec nexts :: "[graph, node] \<Rightarrow> node list"
where
  "nexts [] n = []"
| "nexts (e#es) n = (if fst e = n then snd e # nexts es n else nexts es n)"

definition nextss :: "[graph, node list] \<Rightarrow> node set"
  where "nextss g xs = set g `` set xs"

lemma nextss_Cons: "nextss g (x#xs) = set (nexts g x) \<union> nextss g xs"
  unfolding nextss_def by (auto simp add:Image_def nexts_set)

definition reachable :: "[graph, node list] \<Rightarrow> node set"
  where "reachable g xs = (set g)\<^sup>* `` set xs"

subsection "Depth-First Search with Stack"

definition nodes_of :: "graph \<Rightarrow> node set"
  where "nodes_of g = set (map fst g @ map snd g)"

lemma [simp]: "finite (nodes_of g - set ys)"
proof(rule finite_subset)
  show "finite (nodes_of g)"
    by (auto simp add: nodes_of_def)
qed (auto)

function
  dfs :: "graph \<Rightarrow> node list \<Rightarrow> node list \<Rightarrow> node list"
where
  dfs_base: "dfs g [] ys = ys"
| dfs_inductive: "dfs g (x#xs) ys = (if List.member ys x then dfs g xs ys
                        else dfs g (nexts g x@xs) (x#ys))"
by pat_completeness auto

termination
apply (relation "inv_image (finite_psubset <*lex*> less_than)
                   (\<lambda>(g,xs,ys). (nodes_of g - set ys, size xs))")
apply auto[1]
apply (simp_all add: finite_psubset_def)
by (case_tac  "x \<in> nodes_of g") (auto simp add: List.member_def)

text {*
  \begin{itemize}
  \item The second argument of \isatext{\isastyle{dfs}} is a stack of nodes that will be
  visited.
  \item The third argument of \isatext{\isastyle{dfs}} is a list of nodes that have
  been visited already.
  \end{itemize}
*}

subsection "Depth-First Search with Nested-Recursion"

function
  dfs2 :: "graph \<Rightarrow> node list \<Rightarrow> node list \<Rightarrow> node list"
where
  "dfs2 g [] ys = ys"
|  dfs2_inductive:
          "dfs2 g (x#xs) ys = (if List.member ys x then dfs2 g xs ys
                               else dfs2 g xs (dfs2 g (nexts g x) (x#ys)))"
by pat_completeness auto

lemma dfs2_invariant: "dfs2_dom (g, xs, ys) \<Longrightarrow> set ys \<subseteq> set (dfs2 g xs ys)"
by (induct g xs ys rule: dfs2.pinduct) (force simp add: dfs2.psimps)+

termination dfs2
apply (relation "inv_image (finite_psubset <*lex*> less_than)
                   (\<lambda>(g,xs,ys). (nodes_of g - set ys, size xs))")
apply auto[1]
apply (simp_all add: finite_psubset_def)
apply (case_tac  "x \<in> nodes_of g")
apply (auto simp add: List.member_def)[2]
by (insert dfs2_invariant) force

(*lemma dfs2_induct[induct type]:
  assumes B: "\<And>g ys. P g [] ys" and
  H: "\<And>g x xs ys.
        \<lbrakk>\<not> x mem ys \<longrightarrow> P g xs (dfs2 (g, nexts g x, x # ys));
         \<not> x mem ys \<longrightarrow> P g (nexts g x) (x # ys); x mem ys \<longrightarrow> P g xs ys\<rbrakk>
         \<Longrightarrow> P g (x # xs) ys"
  shows "P u v w"

proof (induct u v w rule: dfs2.induct)
  case 1 show ?case by (rule B)
next
  case (2 g x xs ys)
  show ?case
  proof (rule H)
    show "\<not> x mem ys \<longrightarrow> P g xs (dfs2 (g, nexts g x, x # ys))"
    proof
      assume *: "\<not> x mem ys"
      have "set (x#ys) \<subseteq> set (dfs2 (g, nexts g x, x # ys))"
        by (rule dfs2_inv)
      with 2 * show "P g xs (dfs2 (g, nexts g x, x # ys))"
        by auto
    qed
  qed (rule 2)+
qed
*)

lemma dfs_app: "dfs g (xs@ys) zs = dfs g ys (dfs g xs zs)"
  by (induct g xs zs rule: dfs.induct) auto

lemma "dfs2 g xs ys = dfs g xs ys"
  by (induct g xs ys rule: dfs2.induct) (auto simp add: dfs_app)

subsection "Basic Properties"

lemma visit_subset_dfs: "set ys \<subseteq> set (dfs g xs ys)"
  by (induct g xs ys rule: dfs.induct) auto

lemma next_subset_dfs: "set xs \<subseteq> set (dfs g xs ys)"
proof(induct g xs ys rule:dfs.induct)
  case(2 g x xs ys)
  show ?case
  proof(cases "x \<in> set ys")
    case True
    have "set ys \<subseteq> set (dfs g xs ys)"
      by (rule visit_subset_dfs)
    with 2 and True show ?thesis
      by (auto simp add: List.member_def)
  next
    case False
    have "set (x#ys) \<subseteq> set (dfs g (nexts g x @ xs) (x#ys))"
      by(rule visit_subset_dfs)
    with 2 and False show ?thesis
      by (auto simp add: List.member_def)
  qed
qed(simp)

lemma nextss_closed_dfs'[rule_format]:
 "nextss g ys \<subseteq> set xs \<union> set ys \<longrightarrow> nextss g (dfs g xs ys) \<subseteq> set (dfs g xs ys)"
  by (induct g xs ys rule:dfs.induct, auto simp add:nextss_Cons List.member_def)

lemma nextss_closed_dfs: "nextss g (dfs g xs []) \<subseteq> set (dfs g xs [])"
  by (rule nextss_closed_dfs', simp add: nextss_def)

lemma Image_closed_trancl: assumes "r `` X \<subseteq> X" shows "r\<^sup>* `` X = X"
proof
  show "r\<^sup>* `` X \<subseteq> X"
  proof -
    {
      fix x y
      assume y: "y \<in> X"
      assume "(y,x) \<in> r\<^sup>*"
      then have "x \<in> X"
        by (induct) (insert assms y, auto simp add: Image_def)
    }
    then show ?thesis unfolding Image_def by auto
  qed
qed auto

lemma reachable_closed_dfs: "reachable g xs \<subseteq> set(dfs g xs [])"
proof -
  have "reachable g xs \<subseteq> reachable g (dfs g xs [])"
    unfolding reachable_def by (rule Image_mono) (auto simp add: next_subset_dfs)
  also have "\<dots> = set(dfs g xs [])"
    unfolding reachable_def
  proof (rule Image_closed_trancl)
    from nextss_closed_dfs
    show "set g `` set (dfs g xs []) \<subseteq> set (dfs g xs [])"
      by (simp add: nextss_def)
  qed
  finally show ?thesis .
qed

lemma reachable_nexts: "reachable g (nexts g x) \<subseteq> reachable g [x]"
  unfolding reachable_def
  by (auto intro: converse_rtrancl_into_rtrancl simp: nexts_set)

lemma reachable_append: "reachable g (xs @ ys) = reachable g xs \<union> reachable g ys"
  unfolding reachable_def by auto

lemma dfs_subset_reachable_visit_nodes: "set (dfs g xs ys) \<subseteq> reachable g xs \<union> set ys"
proof(induct g xs ys rule: dfs.induct)
  case 1
  then show ?case by simp
next
  case (2 g x xs ys)
  show ?case
  proof (cases "x \<in> set ys")
    case True
    with 2 show "set (dfs g (x#xs) ys) \<subseteq> reachable g (x#xs) \<union> set ys"
      by (auto simp add: reachable_def List.member_def)
  next
    case False
    have "reachable g (nexts g x) \<subseteq> reachable g [x]"
      by (rule reachable_nexts)
    hence a: "reachable g (nexts g x @ xs) \<subseteq> reachable g (x#xs)"
      by(simp add: reachable_append, auto simp add: reachable_def)
    with False 2
    show "set (dfs g (x#xs) ys) \<subseteq> reachable g (x#xs) \<union> set ys"
      by (auto simp add: reachable_def List.member_def) blast
  qed
qed

subsection "Correctness"

theorem dfs_eq_reachable: "set (dfs g xs []) = reachable g xs"
proof
  have "set (dfs g xs []) \<subseteq> reachable g xs \<union> set []"
    by (rule dfs_subset_reachable_visit_nodes[of g xs "[]"])
 thus "set (dfs g xs []) \<subseteq> reachable g xs"
   by simp
qed(rule reachable_closed_dfs)

theorem "y \<in> set (dfs g [x] []) = ((x,y) \<in> (set g)\<^sup>*)"
  by(simp only:dfs_eq_reachable reachable_def, auto)

subsection "Executable Code"

consts Node :: "int \<Rightarrow> node"

code_datatype Node

instantiation node :: equal
begin

definition equal_node :: "node \<Rightarrow> node \<Rightarrow> bool"
where
  [code del]: "equal_node = HOL.eq"

instance proof
qed (simp add: equal_node_def)

end

declare [[code abort: "HOL.equal :: node \<Rightarrow> node \<Rightarrow> bool"]]

export_code dfs dfs2 in SML file "dfs.ML"

end


(*<*)
theory mp3_sol
imports Hoare_ann_SIMP lifted_int_data
begin
(*>*)

section{*Problems*}
text{* The problems below are designed to step you through some of the
pieces of reasoning about Hoare Logic proofs in Isabelle.  The first set
give you practice using a combination of ``lifted'' rules and facts from
propositional logic, and the definitions of ``lifted'' operators to
reduce the problem to tractable problems in basic HOL.  The second set
extend this exercise to reasoning about ``lifted'' arithmetic facts, and
the third set ask you to prove certain Hoare triples.
*}

subsection{*Lifted Propositional Logic*}
text{*
In the first three problems below you will prove the ``lifted'' versions of
three problems from  MP1.  You are free to use any and all theorem
proving methods in Isabelle to prove them.  You may wish to refer to the
definitions and theorems in \texttt{lifted\_basic} and
\texttt{lifted\_predicate\_logic}.  For an example, here is the
``lifted'' version of the first problem from MP1:
*}

lemma Mp1_problem1: "|\<Turnstile>((A [\<and>] B) [\<longrightarrow>] (B [\<and>] A))"
  apply (rule bvalid_imp_bI)
  by (simp add: and_b_def)

text{*
Remove the \texttt{oops} from each problem and put in your own proof.

\begin{problem}(5 pts)
\end{problem}\vspace*{-2em}
*}
lemma problem1: "|\<Turnstile>((A [\<and>] B) [\<longrightarrow>] (([\<not>]B) [\<longrightarrow>] ([\<not>]A)))"
  apply (rule bvalid_imp_bI)
  by (simp add: and_b_def imp_b_def not_b_def)

lemma problem1_isar: "|\<Turnstile>((A [\<and>] B) [\<longrightarrow>] (([\<not>]B) [\<longrightarrow>] ([\<not>]A)))"
proof (rule bvalid_imp_bI)
  show "\<forall>s. (A [\<and>] B) s \<longrightarrow> ([\<not>]B [\<longrightarrow>] [\<not>]A) s"
  by (simp add: and_b_def imp_b_def not_b_def)
qed

text{*
\begin{problem}(5 pts)
\end{problem}\vspace*{-2em}
*}
lemma problem2: "|\<Turnstile>((A [\<longrightarrow>] B) [\<longrightarrow>] (([\<not>] B) [\<longrightarrow>] ([\<not>] A)))"
  apply (rule bvalid_imp_bI)
  by (auto simp add: imp_b_def not_b_def)

lemma problem2_isar: "|\<Turnstile>((A [\<longrightarrow>] B) [\<longrightarrow>] (([\<not>] B) [\<longrightarrow>] ([\<not>] A)))"
proof (rule bvalid_imp_bI)
  show "\<forall>s. (A [\<longrightarrow>] B) s \<longrightarrow> ([\<not>]B [\<longrightarrow>] [\<not>]A) s "
  by (auto simp add: imp_b_def not_b_def)
qed

text{*
\begin{problem}(5 pts)
\end{problem}\vspace*{-2em}
*}
lemma problem3: "|\<Turnstile>(([\<not>]A [\<or>] [\<not>]B) [\<longrightarrow>] ([\<not>](A [\<and>] B)))"
  apply (rule bvalid_imp_bI)
  by (simp add: and_b_def imp_b_def not_b_def or_b_def)

lemma problem3_isar: "|\<Turnstile>(([\<not>]A [\<or>] [\<not>]B) [\<longrightarrow>] ([\<not>](A [\<and>] B)))"
proof (rule bvalid_imp_bI)
  show "\<forall>s. ([\<not>]A [\<or>] [\<not>]B) s \<longrightarrow> ([\<not>](A [\<and>] B)) s"
  by (simp add: and_b_def imp_b_def not_b_def or_b_def)
qed

subsection{*Lifted Arithmetic Facts\label{laf}*}
text{*
For the next three problems, you may additionally wish to use definitions and
theorems in \texttt{lifted\_int\_data} as well as those in
\texttt{lifted\_predicate\_logic}.  In addition to \texttt{simp},
\texttt{clarsimp}, and \texttt{auto}, you may find \texttt{arith} sometimes
useful, once you have reduced the problem to ``ordinary'' arithmetic.  It
solves problems in linear arithmetic (no multiplying variables together).
Alternately, if you have reduced your problem to ``ordinary'' arithmetic,
you will probably find that Sledgehammer (the third tab in the list at the
bottom) generally can find a proof for you.  If you get stuck, don't waste
time thrashing; ask for help on piazza or in my office.

Depending on how you attack these problems, you may be faced with showing
two functions taking states as arguments are equal.  You can turn this into
a ``ground'' equality between to values with\\\\
\texttt{apply (rule ext)}\\\\
The following is an example that was worked in class as a part of a larger
Hoare Logic Problem:
*}
lemma arith_example:
"|\<Turnstile> (($ ''p'' [=] $ ''i'' [\<times>] $ ''y'' [\<and>] $ ''i'' [\<le>] ($ ''x'') [\<and>]
          $ ''i'' [<] $ ''x'') [\<longrightarrow>]
     ($ ''p'' [+] $ ''y'' [=] ($ ''i'' [+] k 1) [\<times>] $ ''y'' [\<and>]
      $ ''i'' [+] k 1 [\<le>] $ ''x''))"
  apply (simp add: eq_b_def imp_b_def plus_e_def and_b_def  less_b_def
                   less_eq_b_def times_e_def k_def rev_app_def bvalid_def)
  by (simp add: distrib_right)

text{*
\begin{problem}(7 pts)
\end{problem}\vspace*{-2em}*}
lemma problem4:
"|\<Turnstile>($''x'' [\<times>] ($''y'' [+] $''z'') [=] (($''x'' [\<times>] $''y'') [+] ($''x'' [\<times>]$''z'')))"
  apply (simp add: bvalid_def rev_app_def times_e_def plus_e_def eq_b_def)
by (simp add: int_distrib(2))

thm int_distrib(2)

lemma problem4_isar:
"|\<Turnstile>($''x'' [\<times>] ($''y'' [+] $''z'') [=] (($''x'' [\<times>] $''y'') [+] ($''x'' [\<times>]$''z'')))"
proof (simp add: bvalid_def rev_app_def times_e_def plus_e_def eq_b_def)
  show "\<forall>s::string \<Rightarrow> int. s ''x'' * (s ''y'' + s ''z'') = s ''x'' * s ''y'' + s ''x'' * s ''z''"
    by (simp add: int_distrib(2))
qed

text{*
\begin{problem}(6 pts)
\end{problem}\vspace*{-2em}
*}
lemma problem5:
"|\<Turnstile> ((($ ''y'' [+] $ ''x'' [=] k (a + b)) [\<and>]
       ($ ''x'' [\<ge>] k 0) [\<and>] ([\<not>]($ ''x'' [>] k 0))) [\<longrightarrow>]
         ($ ''y'' [=] k (a + b)))"
   by (simp add: bvalid_def rev_app_def plus_e_def greater_eq_b_def eq_b_def
                    k_def greater_b_def not_b_def and_b_def imp_b_def)

text{*
\begin{problem}(8 pts)
\end{problem}\vspace*{-2em}
*}
lemma problem6:
"|\<Turnstile> ((($ ''y'' [=] $ ''a'') [\<and>] ([\<not>]($ ''y'' [mod] k 2 [=] k 0))) [\<longrightarrow>]
 (($ ''y'' [+] k 1 [\<ge>] $ ''a'') [\<and>] ($ ''y'' [+] k 1 [\<le>] $ ''a'' [+] k 1) [\<and>]
          (($ ''y'' [+] k 1) [mod] k 2 [=] k 0)))"
   apply (simp add: eq_b_def imp_b_def and_b_def less_eq_b_def greater_eq_b_def
                    not_b_def plus_e_def mod_e_def k_def rev_app_def bvalid_def)
  by (smt mod_add_cong mod_self one_mod_two_eq_one)

lemma problem6_iasr:
"|\<Turnstile> ((($ ''y'' [=] $ ''a'') [\<and>] ([\<not>]($ ''y'' [mod] k 2 [=] k 0))) [\<longrightarrow>]
 (($ ''y'' [+] k 1 [\<ge>] $ ''a'') [\<and>] ($ ''y'' [+] k 1 [\<le>] $ ''a'' [+] k 1) [\<and>]
          (($ ''y'' [+] k 1) [mod] k 2 [=] k 0)))"
proof (simp add: eq_b_def imp_b_def and_b_def less_eq_b_def greater_eq_b_def
                    not_b_def plus_e_def mod_e_def k_def rev_app_def bvalid_def)
  show "\<forall>s::string \<Rightarrow> int.
         s ''y'' = s ''a'' \<and> s ''y'' mod 2 = 1 \<longrightarrow> (s ''a'' + 1) mod 2 = 0 "
    by (smt mod_add_cong mod_self one_mod_two_eq_one)
qed

subsection{*Hoare Logic Proofs*}
text{*
In the next set of problems, you will want to rely upon the rules in
\texttt{Hoare\_SIMP} that define the relation \texttt{hprovable} describing
which Hoare triples are provable.  If you want Isabelle to figure out some of
the missing pieces for you, you may wish to alter the order in which you solve
the subgoals.  You may use \texttt{prefer} $n$ to select the $n^{th}$ subgoal
as the next one you will work on.

\begin{problem}(15 pts)
\end{problem}\vspace*{-2em}
*}
lemma problem7:
"{{$''y'' [=] $''a'' }}
IF $''y'' [mod] (k 2) [=] (k 0) THEN (''y'' ::= $''y'') ELSE (''y'' ::= $''y'' [+] (k 1)) FI
{{($''y'' [\<ge>] $''a'') [\<and>]
  ($''y'' [\<le>] ($''a'' [+] (k 1))) [\<and>]
  ($''y'' [mod] (k 2) [=] k 0)}}"
  apply (rule IfThenElseRule)
   apply (rule PreconditionStrengthening)
  defer
    apply (rule AssignmentAxiom)
   apply (rule PreconditionStrengthening)
    defer
    apply (rule AssignmentAxiom)
  apply simp
   apply (simp add: eq_b_def imp_b_def and_b_def less_eq_b_def greater_eq_b_def
                    plus_e_def k_def rev_app_def bvalid_def)
  apply simp
   apply (simp add: eq_b_def imp_b_def and_b_def less_eq_b_def greater_eq_b_def
                    not_b_def plus_e_def mod_e_def k_def rev_app_def bvalid_def)
  by (smt mod_add_cong mod_self one_mod_two_eq_one)

lemma problem7_isar:
"{{$''y'' [=] $''a'' }}
IF $''y'' [mod] (k 2) [=] (k 0) THEN (''y'' ::= $''y'') ELSE (''y'' ::= $''y'' [+] (k 1)) FI
{{($''y'' [\<ge>] $''a'') [\<and>]
  ($''y'' [\<le>] ($''a'' [+] (k 1))) [\<and>]
  ($''y'' [mod] (k 2) [=] k 0)}}"
proof (rule IfThenElseRule)
  show "{{$ ''y'' [=] $ ''a'' [\<and>]
      $ ''y'' [mod] k 2 [=]
      k 0}}''y'' ::= $ ''y''{{$ ''y'' [\<ge>] $ ''a'' [\<and>]
                              $ ''y'' [\<le>] $ ''a'' [+] k 1 [\<and>]
                              $ ''y'' [mod] k 2 [=] k 0}}"
  proof (rule PreconditionStrengthening)
--{*Isar won't help us out with figuring out what P is, so sometimes it is *}
--{*helpful to mix in a little apply style.  Here I used the proof above. *}
    show "{{(($ ''y'' [\<ge>] $ ''a'' [\<and>] $ ''y'' [\<le>] $ ''a'' [+] k 1 [\<and>]
           $ ''y'' [mod] k 2 [=] k 0)
          [''y''\<Leftarrow>$ ''y''])}}''y'' ::= $ ''y''{{$ ''y'' [\<ge>] $ ''a'' [\<and>]
                               $ ''y'' [\<le>] $ ''a'' [+] k 1 [\<and>]
                               $ ''y'' [mod] k 2 [=] k 0}}"
      by (rule AssignmentAxiom)
  next
    show "|\<Turnstile> (($ ''y'' [=] $ ''a'' [\<and>] $ ''y'' [mod] k 2 [=] k 0) [\<longrightarrow>]
         (($ ''y'' [\<ge>] $ ''a'' [\<and>] $ ''y'' [\<le>] $ ''a'' [+] k 1 [\<and>]
           $ ''y'' [mod] k 2 [=] k 0)
          [''y''\<Leftarrow>$ ''y'']))"
    proof simp
      show "|\<Turnstile> (($ ''y'' [=] $ ''a'' [\<and>] $ ''y'' [mod] k 2 [=] k 0) [\<longrightarrow>]
         ($ ''y'' [\<ge>] $ ''a'' [\<and>] $ ''y'' [\<le>] $ ''a'' [+] k 1 [\<and>]
          $ ''y'' [mod] k 2 [=] k 0))"
        by (simp add: eq_b_def imp_b_def and_b_def less_eq_b_def greater_eq_b_def
                    plus_e_def k_def rev_app_def bvalid_def)
    qed
  qed
next
  show "{{$ ''y'' [=] $ ''a'' [\<and>] [\<not>]($ ''y'' [mod] k 2 [=] k 0)}}
        ''y'' ::= $ ''y'' [+] k 1
        {{$ ''y'' [\<ge>] $ ''a'' [\<and>] $ ''y'' [\<le>] $ ''a'' [+] k 1 [\<and>]
                       $ ''y'' [mod] k 2 [=] k 0}}"
  proof (rule PreconditionStrengthening)
    show "{{(($ ''y'' [\<ge>] $ ''a'' [\<and>] $ ''y'' [\<le>] $ ''a'' [+] k 1 [\<and>]
           $ ''y'' [mod] k 2 [=] k 0)
          [''y''\<Leftarrow>$ ''y'' [+] k 1])}}''y'' ::= $ ''y'' [+]
                     k 1{{$ ''y'' [\<ge>] $ ''a'' [\<and>] $ ''y'' [\<le>] $ ''a'' [+] k 1 [\<and>]
                          $ ''y'' [mod] k 2 [=] k 0}}"
      by (rule AssignmentAxiom)
  next
    show "|\<Turnstile> (($ ''y'' [=] $ ''a'' [\<and>] [\<not>]($ ''y'' [mod] k 2 [=] k 0)) [\<longrightarrow>]
         (($ ''y'' [\<ge>] $ ''a'' [\<and>] $ ''y'' [\<le>] $ ''a'' [+] k 1 [\<and>]
           $ ''y'' [mod] k 2 [=] k 0)
          [''y''\<Leftarrow>$ ''y'' [+] k 1]))"
    proof simp
      show "|\<Turnstile> (($ ''y'' [=] $ ''a'' [\<and>] [\<not>]($ ''y'' [mod] k 2 [=] k 0)) [\<longrightarrow>]
         ($ ''y'' [+] k 1 [\<ge>] $ ''a'' [\<and>] $ ''y'' [+] k 1 [\<le>] $ ''a'' [+] k 1 [\<and>]
         ($ ''y'' [+] k 1) [mod] k 2 [=] k 0)) "
      proof (simp add: eq_b_def imp_b_def and_b_def less_eq_b_def greater_eq_b_def
                    not_b_def plus_e_def mod_e_def k_def rev_app_def bvalid_def)
        show "\<forall>s::string \<Rightarrow> int.
               s ''y'' = s ''a'' \<and> s ''y'' mod 2 = 1 \<longrightarrow> (s ''a'' + 1) mod 2 = 0"
          by (smt mod_add_cong mod_self one_mod_two_eq_one)
      qed
    qed
  qed
qed

(*declare [[show_types = true]] *)
text{*
\begin{problem}(21 pts)
\end{problem}\vspace*{-2em}
*}
lemma problem8:
"{{$ ''y'' [=] k a [\<and>] $ ''x'' [=] k b [\<and>] k b [>] k 0}}
WHILE $ ''x'' [>] k 0 DO
(''y'' ::= $ ''y'' [+] k 1;;
 ''x'' ::= $ ''x'' [-] k 1)
OD
{{$ ''y'' [=] k (a + b)}}"

  apply (rule_tac Q' = "(($ ''y'' [+] $ ''x'' [=] k(a + b)) [\<and>]
                         ($ ''x'' [\<ge>] k 0)) [\<and>]
                        ([\<not>] ($ ''x'' [>] k 0))" in PostconditionWeakening)
   apply (simp add: bvalid_def rev_app_def plus_e_def greater_eq_b_def eq_b_def
                    k_def greater_b_def not_b_def and_b_def imp_b_def)
  apply (rule_tac P' = "(($ ''y'' [+] $ ''x'' [=] k(a + b)) [\<and>]
                         ($ ''x'' [\<ge>] k 0))" in PreconditionStrengthening)
   apply (simp add: bvalid_def rev_app_def plus_e_def greater_eq_b_def eq_b_def
                    k_def greater_b_def and_b_def imp_b_def)
  apply (rule WhileRule)
  apply (rule SequenceRule)
   prefer 2
   apply (rule AssignmentAxiom)
  apply simp
  apply (rule PreconditionStrengthening)
  prefer 2
   apply (rule AssignmentAxiom)
  apply simp
  by (simp add: bvalid_def rev_app_def plus_e_def minus_e_def greater_eq_b_def eq_b_def
                   k_def greater_b_def and_b_def imp_b_def)

lemma problem8_isar:
"{{$ ''y'' [=] k a [\<and>] $ ''x'' [=] k b [\<and>] k b [>] k 0}}
WHILE $ ''x'' [>] k 0 DO
(''y'' ::= $ ''y'' [+] k 1;;
 ''x'' ::= $ ''x'' [-] k 1)
OD
{{$ ''y'' [=] k (a + b)}}"
proof (rule_tac Q' = "(($ ''y'' [+] $ ''x'' [=] k(a + b)) [\<and>]
                         ($ ''x'' [\<ge>] k 0)) [\<and>]
                        ([\<not>] ($ ''x'' [>] k 0))" in PostconditionWeakening)
  show "|\<Turnstile> (($ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0 [\<and>]
          [\<not>]($ ''x'' [>] k 0)) [\<longrightarrow>]
         $ ''y'' [=] k (a + b))"
    by (simp add: bvalid_def rev_app_def plus_e_def greater_eq_b_def eq_b_def
                    k_def greater_b_def not_b_def and_b_def imp_b_def)
next
  show "{{$ ''y'' [=] k a [\<and>] $ ''x'' [=] k b [\<and>] k b [>] k 0}}WHILE $ ''x'' [>] k 0
    DO ''y'' ::= $ ''y'' [+] k 1;; ''x'' ::= $ ''x'' [-] k 1 OD
   {{$ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0 [\<and>] [\<not>]($ ''x'' [>] k 0)}}"
  proof (rule_tac P' = "(($ ''y'' [+] $ ''x'' [=] k(a + b)) [\<and>]
                         ($ ''x'' [\<ge>] k 0))" in PreconditionStrengthening)
    show "|\<Turnstile> (($ ''y'' [=] k a [\<and>] $ ''x'' [=] k b [\<and>] k b [>] k 0) [\<longrightarrow>]
         ($ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0))"
      by (simp add: bvalid_def rev_app_def plus_e_def greater_eq_b_def eq_b_def
                    k_def greater_b_def and_b_def imp_b_def)
  next
    show "{{$ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0}}
          WHILE $ ''x'' [>] k 0
          DO ''y'' ::= $ ''y'' [+] k 1;; ''x'' ::= $ ''x'' [-] k 1 OD
          {{$ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0 [\<and>]
           [\<not>]($ ''x'' [>] k 0) }} "
    proof (rule WhileRule)
      show "{{$ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0 [\<and>]
      $ ''x'' [>] k 0}}''y'' ::= $ ''y'' [+] k 1;;
    ''x'' ::= $ ''x'' [-]
              k 1{{$ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0}} "
      proof (rule SequenceRule)
        show "{{($ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0)
                [''x''\<Leftarrow>$ ''x'' [-] k 1]}}
              ''x'' ::= $ ''x'' [-]k 1
              {{$ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0}}"
          by (rule AssignmentAxiom)
      next
        show "{{$ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0 [\<and>]
      $ ''x'' [>]
      k 0}}''y'' ::= $ ''y'' [+]
                     k 1{{($ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0)
    [''x''\<Leftarrow>$ ''x'' [-] k 1]}}"
        proof simp
          show "{{$ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0 [\<and>]
      $ ''x'' [>] k 0}}
      ''y'' ::= $ ''y'' [+] k 1
                {{$ ''y'' [+] ($ ''x'' [-] k 1) [=] k (a + b) [\<and>]
                  $ ''x'' [-] k 1 [\<ge>] k 0}} "
          proof (rule PreconditionStrengthening)
            show "{{(($ ''y'' [+] ($ ''x'' [-] k 1) [=] k (a + b) [\<and>] $ ''x'' [-] k 1 [\<ge>] k 0)
          [''y''\<Leftarrow>$ ''y'' [+] k 1])}}''y'' ::= $ ''y'' [+]
                     k 1{{$ ''y'' [+] ($ ''x'' [-] k 1) [=] k (a + b) [\<and>]
                          $ ''x'' [-] k 1 [\<ge>] k 0}}"
              by (rule AssignmentAxiom)
          next
            show "|\<Turnstile> (($ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0 [\<and>]
          $ ''x'' [>] k 0) [\<longrightarrow>]
         (($ ''y'' [+] ($ ''x'' [-] k 1) [=] k (a + b) [\<and>] $ ''x'' [-] k 1 [\<ge>] k 0)
          [''y''\<Leftarrow>$ ''y'' [+] k 1]))"
            proof simp
              show "|\<Turnstile> (($ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0 [\<and>]
          $ ''x'' [>] k 0) [\<longrightarrow>]
         ($ ''y'' [+] k 1 [+] ($ ''x'' [-] k 1) [=] k (a + b) [\<and>]
          $ ''x'' [-] k 1 [\<ge>] k 0))"
                by (simp add: bvalid_def rev_app_def plus_e_def minus_e_def
                              greater_eq_b_def eq_b_def k_def greater_b_def
                              and_b_def imp_b_def)
            qed
          qed
        qed
      qed
    qed
  qed
qed

subsection{*Verification Conditions*}
text{*
Lastly, I ask you to redo \texttt{problem8}, but this time where you use none
of the rules defining \texttt{hprovable}, or the two derived rules of consequence,
but instead make use of the rules \texttt{alt\_ann\_provable\_provable},
\texttt{vcg\_and\_P} found in \texttt{Hoare\_ann\_SIMP}.  After that,
\texttt{simp} will remove the instances of \texttt{vcg} and \texttt{wp}, and
you are left with a problem like the ones in Subsection \ref{laf}.
*}

text{*
\begin{problem}(10 pts)
\end{problem}\vspace*{-2em}
*}
lemma problem9:
"{{$ ''y'' [=] k a [\<and>] $ ''x'' [=] k b [\<and>] k b [>] k 0}}
WHILE $ ''x'' [>] k 0 DO
(''y'' ::= $ ''y'' [+] k 1;;
 ''x'' ::= $ ''x'' [-] k 1)
OD
{{$ ''y'' [=] k (a + b)}}"

  apply (rule_tac C = "While $ ''x'' [>] k 0
                       Inv ($ ''y'' [+] $ ''x'' [=] k(a + b))
                            [\<and>] ($ ''x'' [\<ge>] k 0)
                       Do
                         (''y'' :== $ ''y'' [+] k 1;-;
                          ''x'' :== $ ''x'' [-] k 1)
                       Od"
         in alt_ann_provable_provable)
   apply simp
  apply (rule vcg_and_P)
  apply simp
  by (simp add: bvalid_def rev_app_def plus_e_def minus_e_def greater_eq_b_def eq_b_def
                   k_def greater_b_def and_b_def imp_b_def not_b_def true_b_def)

lemma problem9_isar:
"{{$ ''y'' [=] k a [\<and>] $ ''x'' [=] k b [\<and>] k b [>] k 0}}
WHILE $ ''x'' [>] k 0 DO
(''y'' ::= $ ''y'' [+] k 1;;
 ''x'' ::= $ ''x'' [-] k 1)
OD
{{$ ''y'' [=] k (a + b)}}"
proof (rule_tac C = "While $ ''x'' [>] k 0
                       Inv ($ ''y'' [+] $ ''x'' [=] k(a + b))
                            [\<and>] ($ ''x'' [\<ge>] k 0)
                       Do
                         (''y'' :== $ ''y'' [+] k 1;-;
                          ''x'' :== $ ''x'' [-] k 1)
                       Od"
         in alt_ann_provable_provable)
  show "WHILE $ ''x'' [>] k 0 DO ''y'' ::= $ ''y'' [+] k 1;; ''x'' ::= $ ''x'' [-] k 1
    OD =
    strip_annotations
     (While $ ''x'' [>] k 0 Inv $ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0
      Do ''y'' :== $ ''y'' [+] k 1 ;-; ''x'' :== $ ''x'' [-] k 1 Od)"
    by simp
next
  show "\<lbrace>$ ''y'' [=] k a [\<and>] $ ''x'' [=] k b [\<and>] k b [>] k 0\<rbrace>While $ ''x'' [>] k 0
    Inv $ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0
    Do ''y'' :== $ ''y'' [+] k 1 ;-; ''x'' :== $ ''x'' [-] k 1
    Od\<lbrace>$ ''y'' [=] k (a + b)\<rbrace>"
  proof (rule vcg_and_P)
    show "|\<Turnstile> ((($ ''y'' [=] k a [\<and>] $ ''x'' [=] k b [\<and>] k b [>] k 0) [\<longrightarrow>]
         (wp (While $ ''x'' [>] k 0
             Inv $ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0
             Do ''y'' :== $ ''y'' [+] k 1 ;-; ''x'' :== $ ''x'' [-] k 1 Od)
          ($ ''y'' [=] k (a + b)))) [\<and>]
         (vcg (While $ ''x'' [>] k 0
              Inv $ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0
              Do ''y'' :== $ ''y'' [+] k 1 ;-; ''x'' :== $ ''x'' [-] k 1 Od)
          ($ ''y'' [=] k (a + b)))) "
    proof simp
      show "|\<Turnstile> (((($ ''y'' [=] k a [\<and>] $ ''x'' [=] k b [\<and>] k b [>] k 0)) [\<longrightarrow>]
         ($ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0)) [\<and>]
         ((($ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0 [\<and>]
           $ ''x'' [>] k 0) [\<longrightarrow>]
          ($ ''y'' [+] k 1 [+] ($ ''x'' [-] k 1) [=] k (a + b) [\<and>]
          $ ''x'' [-] k 1 [\<ge>] k 0)) [\<and>]
          (true_b [\<and>] true_b) [\<and>]
          (($ ''y'' [+] $ ''x'' [=] k (a + b) [\<and>] $ ''x'' [\<ge>] k 0 [\<and>]
            [\<not>]($ ''x'' [>] k 0)) [\<longrightarrow>]
           ($ ''y'' [=] k (a + b)))))"
        by (simp add: bvalid_def rev_app_def plus_e_def minus_e_def
            greater_eq_b_def eq_b_def k_def greater_b_def and_b_def
            imp_b_def not_b_def true_b_def)
    qed
  qed
qed

subsection{*Extra Credit*}

text{*
\begin{problem}(10 pts)
\end{problem}\vspace*{-2em}
*}
lemma problem10:
"{{$ ''n'' [=] k a [\<and>] k a [>] k 0}}
''r'' ::= k 0;;
WHILE ($ ''n'' [>] k 0) DO
''r'' ::= $ ''r'' [+] $ ''n'';;
''n'' ::= $ ''n'' [-] k 1
OD
{{k 2 [\<times>] $ ''r'' [=] k (a * (a + 1))}}"

(* r + ((n * (n + 1)) / 2) = a * (a + 1) / 2 *)
(* (2 * r) + n * (n + 1) = a * (a + 1) *)
  apply (rule_tac C = "''r'' :== k 0 ;-;
                       (While $ ''n'' [>] k 0
                        Inv ((k 2 [\<times>] $''r'') [+] ($''n'' [\<times>] ($''n'' [+] k 1))
                             [=] k(a * (a + 1)))
                             [\<and>] ($ ''n'' [\<ge>] k 0)
                        Do
                          (''r'' :== $ ''r'' [+] $ ''n'';-;
                           ''n'' :== $ ''n'' [-] k 1)
                        Od)"
         in alt_ann_provable_provable)
   apply simp
  apply (rule vcg_and_P)
  apply simp
  apply (simp add: bvalid_def rev_app_def plus_e_def minus_e_def times_e_def
                   greater_eq_b_def eq_b_def
                   k_def greater_b_def and_b_def imp_b_def not_b_def true_b_def)
  apply auto
  apply (rule trans, rule sym)
   prefer 2
   apply assumption
  by (simp only:  Rings.ring_class.ring_distribs)

lemma problem10_isar:
"{{$ ''n'' [=] k a [\<and>] k a [>] k 0}}
''r'' ::= k 0;;
WHILE ($ ''n'' [>] k 0) DO
''r'' ::= $ ''r'' [+] $ ''n'';;
''n'' ::= $ ''n'' [-] k 1
OD
{{k 2 [\<times>] $ ''r'' [=] k (a * (a + 1))}}"
proof (rule_tac C = "''r'' :== k 0 ;-;
                       (While $ ''n'' [>] k 0
                        Inv ((k 2 [\<times>] $''r'') [+] ($''n'' [\<times>] ($''n'' [+] k 1))
                             [=] k(a * (a + 1)))
                             [\<and>] ($ ''n'' [\<ge>] k 0)
                        Do
                          (''r'' :== $ ''r'' [+] $ ''n'';-;
                           ''n'' :== $ ''n'' [-] k 1)
                        Od)"
         in alt_ann_provable_provable)
  show "''r'' ::= k 0;; WHILE $ ''n'' [>] k 0 DO ''r'' ::= $ ''r'' [+] $ ''n'';;
    ''n'' ::= $ ''n'' [-] k 1 OD =
    strip_annotations
     (''r'' :== k 0 ;-;
      (While $ ''n'' [>] k 0
       Inv k 2 [\<times>] $ ''r'' [+] ($ ''n'' [\<times>] ($ ''n'' [+] k 1)) [=]
           k (a * (a + 1)) [\<and>]
           $ ''n'' [\<ge>] k 0
       Do ''r'' :== $ ''r'' [+] $ ''n'' ;-; ''n'' :== $ ''n'' [-] k 1 Od))"
    by simp
next
  show "\<lbrace>$ ''n'' [=] k a [\<and>]
     k a [>]
     k 0\<rbrace>''r'' :== k 0 ;-;
         (While $ ''n'' [>] k 0
          Inv k 2 [\<times>] $ ''r'' [+] ($ ''n'' [\<times>] ($ ''n'' [+] k 1)) [=]
              k (a * (a + 1)) [\<and>]
              $ ''n'' [\<ge>] k 0
          Do ''r'' :== $ ''r'' [+] $ ''n'' ;-; ''n'' :== $ ''n'' [-] k 1
          Od)\<lbrace>k 2 [\<times>] $ ''r'' [=] k (a * (a + 1))\<rbrace> "
  proof (rule vcg_and_P)
    show "|\<Turnstile> ((($ ''n'' [=] k a [\<and>] k a [>] k 0) [\<longrightarrow>]
         (wp (''r'' :== k 0 ;-;
             (While $ ''n'' [>] k 0
              Inv k 2 [\<times>] $ ''r'' [+] ($ ''n'' [\<times>] ($ ''n'' [+] k 1)) [=]
                  k (a * (a + 1)) [\<and>]
                  $ ''n'' [\<ge>] k 0
              Do ''r'' :== $ ''r'' [+] $ ''n'' ;-; ''n'' :== $ ''n'' [-] k 1 Od))
          (k 2 [\<times>] $ ''r'' [=] k (a * (a + 1))))) [\<and>]
         (vcg (''r'' :== k 0 ;-;
              (While $ ''n'' [>] k 0
               Inv k 2 [\<times>] $ ''r'' [+] ($ ''n'' [\<times>] ($ ''n'' [+] k 1)) [=]
                   k (a * (a + 1)) [\<and>]
                   $ ''n'' [\<ge>] k 0
               Do ''r'' :== $ ''r'' [+] $ ''n'' ;-; ''n'' :== $ ''n'' [-] k 1 Od))
          (k 2 [\<times>] $ ''r'' [=] k (a * (a + 1)))))"
    proof simp
      show "|\<Turnstile> ((($ ''n'' [=] k a [\<and>] k a [>] k 0) [\<longrightarrow>]
         (k 2 [\<times>] k 0 [+] ($ ''n'' [\<times>] ($ ''n'' [+] k 1)) [=] k (a * (a + 1)) [\<and>]
         $ ''n'' [\<ge>] k 0)) [\<and>]
         (true_b [\<and>]
          (((k 2 [\<times>] $ ''r'' [+] ($ ''n'' [\<times>] ($ ''n'' [+] k 1)) [=]
            k (a * (a + 1)) [\<and>]
            $ ''n'' [\<ge>] k 0 [\<and>]
            $ ''n'' [>] k 0) [\<longrightarrow>]
           (k 2 [\<times>] ($ ''r'' [+] $ ''n'') [+]
           ($ ''n'' [-] k 1 [\<times>] ($ ''n'' [-] k 1 [+] k 1)) [=]
           k (a * (a + 1)) [\<and>]
           $ ''n'' [-] k 1 [\<ge>] k 0)) [\<and>]
           (true_b [\<and>] true_b) [\<and>]
           ((((k 2 [\<times>] $ ''r'' [+] ($ ''n'' [\<times>] ($ ''n'' [+] k 1)) [=]
             k (a * (a + 1))) [\<and>]
             ($ ''n'' [\<ge>] k 0) [\<and>]
            ( [\<not>]($ ''n'' [>] k 0)))) [\<longrightarrow>]
            (k 2 [\<times>] $ ''r'' [=] k (a * (a + 1))))))) "
      proof (simp add: bvalid_def rev_app_def plus_e_def minus_e_def times_e_def
                   greater_eq_b_def eq_b_def
                   k_def greater_b_def and_b_def imp_b_def not_b_def true_b_def)
        show " \<forall>s. (2 * s ''r'' + s ''n'' * (s ''n'' + 1) = a * (a + 1) \<and>
         0 \<le> s ''n'' \<and> 0 < s ''n'' \<longrightarrow>
         2 * s ''r'' + 2 * s ''n'' + (s ''n'' - 1) * s ''n'' = a * (a + 1)) \<and>
        (2 * s ''r'' + s ''n'' * (s ''n'' + 1) = a * (a + 1) \<and>
         0 \<le> s ''n'' \<and> \<not> 0 < s ''n'' \<longrightarrow>
         2 * s ''r'' = a * (a + 1))"
        proof auto
          fix s::"string \<Rightarrow> int"
          assume A1: "2 * s ''r'' + s ''n'' * (s ''n'' + 1) = a * (a + 1)"
          and A2: "0 < s ''n''"
          then
          show "2 * s ''r'' + 2 * s ''n'' + (s ''n'' - 1) * s ''n'' = a * (a + 1)"
          proof (rule_tac trans, rule_tac sym)
            from A1
            show "2 * s ''r'' + s ''n'' * (s ''n'' + 1) = a * (a + 1) " by assumption
          next
            show "(2::int) * s ''r'' + s ''n'' * (s ''n'' + 1) =
                  2 * s ''r'' + 2 * s ''n'' + (s ''n'' - 1) * s ''n''"
              by (simp only:  Rings.ring_class.ring_distribs)
          qed
        qed
      qed
    qed
  qed
qed

(*<*)
end
(*>*)