(*
 * 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 WordAbs
imports "AutoCorres.AutoCorres"
begin

external_file "word_abs.c"
install_C_file "word_abs.c"
autocorres
  [ (* signed_word_abs is implicit; these are the functions that would be abstracted: *)
    (*signed_word_abs =
        S_add_S S_sub_S S_mul_S S_div_S S_mod_S neg_S
        S_and_S S_or_S S_xor_S not_S
        U_shiftl_U_abs_S U_shiftr_U_abs_S U_shiftl_S_abs_S U_shiftr_S_abs_S
        S_shiftl_U_abs_S S_shiftr_U_abs_S S_shiftl_S_abs_S S_shiftr_S_abs_S
        U_shiftl_U_abs_US U_shiftr_U_abs_US U_shiftl_S_abs_US U_shiftr_S_abs_US
        S_shiftl_U_abs_US S_shiftr_U_abs_US S_shiftl_S_abs_US S_shiftr_S_abs_US
  ,*) no_signed_word_abs =
        U_shiftl_U_no_abs U_shiftr_U_no_abs U_shiftl_S_no_abs U_shiftr_S_no_abs
        S_shiftl_U_no_abs S_shiftr_U_no_abs S_shiftl_S_no_abs S_shiftr_S_no_abs
        U_shiftl_U_abs_U U_shiftr_U_abs_U U_shiftl_S_abs_U U_shiftr_S_abs_U
        S_shiftl_U_abs_U S_shiftr_U_abs_U S_shiftl_S_abs_U S_shiftr_S_abs_U
  , unsigned_word_abs =
        ver366
        U_add_U U_sub_U U_mul_U U_div_U U_mod_U neg_U
        U_and_U U_or_U U_xor_U not_U
        U_shiftl_U_abs_U U_shiftr_U_abs_U U_shiftl_S_abs_U U_shiftr_S_abs_U
        S_shiftl_U_abs_U S_shiftr_U_abs_U S_shiftl_S_abs_U S_shiftr_S_abs_U
        U_shiftl_U_abs_US U_shiftr_U_abs_US U_shiftl_S_abs_US U_shiftr_S_abs_US
        S_shiftl_U_abs_US S_shiftr_U_abs_US S_shiftl_S_abs_US S_shiftr_S_abs_US
  , ts_rules = nondet
] "word_abs.c"

context word_abs begin

lemma "\<lbrace> P \<rbrace> ver366' 0 \<lbrace> \<lambda>v s. v = 0 \<and> P s \<rbrace>"
  by (wpsimp simp: ver366'_def)
lemma "\<lbrace> P \<rbrace> ver366' UINT_MAX \<lbrace> \<lambda>v s. v = UINT_MAX-1 \<and> P s \<rbrace>"
  by (wpsimp simp: ver366'_def UINT_MAX_def)

section \<open>Arithmetic ops\<close>
thm S_add_S'_def S_sub_S'_def S_mul_S'_def S_div_S'_def S_mod_S'_def neg_S'_def
    U_add_U'_def U_sub_U'_def U_mul_U'_def U_div_U'_def U_mod_U'_def neg_U'_def

lemma "x + y < INT_MIN \<or> x + y > INT_MAX \<Longrightarrow> \<not> no_fail \<top> (S_add_S' (x::int) (y::int))"
  by (monad_eq simp: S_add_S'_def no_fail_def INT_MIN_def INT_MAX_def)
lemma "\<lbrace>\<lambda>s. INT_MIN \<le> x + y \<and> x + y \<le> INT_MAX \<and> P s\<rbrace>
         S_add_S' (x::int) (y::int)
       \<lbrace>\<lambda>r s. r = x + y \<and> P s\<rbrace>!"
  by (wpsimp simp: S_add_S'_def INT_MIN_def INT_MAX_def)
lemma "x - y < INT_MIN \<or> x - y > INT_MAX \<Longrightarrow> \<not> no_fail \<top> (S_sub_S' (x::int) (y::int))"
  by (monad_eq simp: S_sub_S'_def no_fail_def INT_MIN_def INT_MAX_def)
lemma "\<lbrace>\<lambda>s. INT_MIN \<le> x - y \<and> x - y \<le> INT_MAX \<and> P s\<rbrace>
         S_sub_S' (x::int) (y::int)
       \<lbrace>\<lambda>r s. r = x - y \<and> P s\<rbrace>!"
  by (wpsimp simp: S_sub_S'_def INT_MIN_def INT_MAX_def)
lemma "x * y < INT_MIN \<or> x * y > INT_MAX \<Longrightarrow> \<not> no_fail \<top> (S_mul_S' (x::int) (y::int))"
  by (monad_eq simp: S_mul_S'_def no_fail_def INT_MIN_def INT_MAX_def)
lemma "\<lbrace>\<lambda>s. INT_MIN \<le> x * y \<and> x * y \<le> INT_MAX \<and> P s\<rbrace>
         S_mul_S' (x::int) (y::int)
       \<lbrace>\<lambda>r s. r = x * y \<and> P s\<rbrace>!"
  by (wpsimp simp: S_mul_S'_def INT_MIN_def INT_MAX_def)
lemma "y = 0 \<or> x sdiv y < INT_MIN \<or> x sdiv y > INT_MAX \<Longrightarrow> \<not> no_fail \<top> (S_div_S' (x::int) (y::int))"
  by (monad_eq simp: S_div_S'_def no_fail_def INT_MIN_def INT_MAX_def)
lemma "\<lbrace>\<lambda>s. y \<noteq> 0 \<and> INT_MIN \<le> x sdiv y \<and> x sdiv y \<le> INT_MAX \<and> P s\<rbrace>
         S_div_S' (x::int) (y::int)
       \<lbrace>\<lambda>r s. r = x sdiv y \<and> P s\<rbrace>!"
  by (wpsimp simp: S_div_S'_def INT_MIN_def INT_MAX_def)
lemma "y = 0 \<or> x smod y < INT_MIN \<or> x smod y > INT_MAX \<Longrightarrow> \<not> no_fail \<top> (S_mod_S' (x::int) (y::int))"
  by (monad_eq simp: S_mod_S'_def no_fail_def INT_MIN_def INT_MAX_def)
lemma "\<lbrace>\<lambda>s. y \<noteq> 0 \<and> INT_MIN \<le> x smod y \<and> x smod y \<le> INT_MAX \<and> P s\<rbrace>
         S_mod_S' (x::int) (y::int)
       \<lbrace>\<lambda>r s. r = x smod y \<and> P s\<rbrace>!"
  by (wpsimp simp: S_mod_S'_def INT_MIN_def INT_MAX_def)
lemma "x \<le> INT_MIN \<or> x > -INT_MIN \<Longrightarrow> \<not> no_fail \<top> (neg_S' (x::int))"
  by (monad_eq simp: neg_S'_def no_fail_def INT_MIN_def)
lemma "\<lbrace>\<lambda>s. INT_MIN < x \<and> x \<le> -INT_MIN \<and> P s\<rbrace> neg_S' (x::int) \<lbrace>\<lambda>r s. r = -x \<and> P s\<rbrace>!"
  by (wpsimp simp: neg_S'_def INT_MIN_def)

lemma "x + y > UINT_MAX \<Longrightarrow> \<not> no_fail \<top> (U_add_U' (x::nat) (y::nat))"
  by (monad_eq simp: U_add_U'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. x + y \<le> UINT_MAX \<and> P s\<rbrace>
         U_add_U' (x::nat) (y::nat)
       \<lbrace>\<lambda>r s. r = x + y \<and> P s\<rbrace>!"
  by (wpsimp simp: U_add_U'_def UINT_MAX_def)
lemma "x < y \<Longrightarrow> \<not> no_fail \<top> (U_sub_U' (x::nat) (y::nat))"
  by (monad_eq simp: U_sub_U'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. x \<ge> y \<and> P s\<rbrace>
         U_sub_U' (x::nat) (y::nat)
       \<lbrace>\<lambda>r s. r = x - y \<and> P s\<rbrace>!"
  by (wpsimp simp: U_sub_U'_def)
lemma "x * y > UINT_MAX \<Longrightarrow> \<not> no_fail \<top> (U_mul_U' (x::nat) (y::nat))"
  by (monad_eq simp: U_mul_U'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. x * y \<le> UINT_MAX \<and> P s\<rbrace>
         U_mul_U' (x::nat) (y::nat)
       \<lbrace>\<lambda>r s. r = x * y \<and> P s\<rbrace>!"
  by (wpsimp simp: U_mul_U'_def UINT_MAX_def)
lemma "y = 0 \<Longrightarrow> \<not> no_fail \<top> (U_div_U' (x::nat) (y::nat))"
  by (monad_eq simp: U_div_U'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. y \<noteq> 0 \<and> P s\<rbrace>
         U_div_U' (x::nat) (y::nat)
       \<lbrace>\<lambda>r s. r = x div y \<and> P s\<rbrace>!"
  by (wpsimp simp: U_div_U'_def UINT_MAX_def)
lemma "y = 0 \<Longrightarrow> \<not> no_fail \<top> (U_mod_U' (x::nat) (y::nat))"
  by (monad_eq simp: U_mod_U'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. y \<noteq> 0 \<and> P s\<rbrace>
         U_mod_U' (x::nat) (y::nat)
       \<lbrace>\<lambda>r s. r = x mod y \<and> P s\<rbrace>!"
  by (wpsimp simp: U_mod_U'_def UINT_MAX_def)
lemma "\<lbrace>P\<rbrace> neg_U' (x::nat) \<lbrace>\<lambda>r s. r = (if x = 0 then 0 else Suc UINT_MAX - x) \<and> P s\<rbrace>!"
  unfolding neg_U'_def by (wp, simp)

section \<open>Bitwise ops\<close>

thm S_and_S'_def S_or_S'_def S_xor_S'_def not_S'_def
    U_and_U'_def U_or_U'_def U_xor_U'_def not_U'_def

lemma "\<lbrace>P\<rbrace> S_and_S' (x::int) (y::int) \<lbrace>\<lambda>r s. r = x AND y \<and> P s\<rbrace>!"
  by (wpsimp simp: S_and_S'_def)
lemma "\<lbrace>P\<rbrace> S_or_S' (x::int) (y::int) \<lbrace>\<lambda>r s. r = x OR y \<and> P s\<rbrace>!"
  by (wpsimp simp: S_or_S'_def)
lemma "\<lbrace>P\<rbrace> S_xor_S' (x::int) (y::int) \<lbrace>\<lambda>r s. r = x XOR y \<and> P s\<rbrace>!"
  by (wpsimp simp: S_xor_S'_def)
lemma "\<lbrace>P\<rbrace> not_S' (x::int) \<lbrace>\<lambda>r s. r = NOT x \<and> P s\<rbrace>!"
  by (wpsimp simp: not_S'_def)

lemma "\<lbrace>P\<rbrace> U_and_U' (x::nat) (y::nat) \<lbrace>\<lambda>r s. r = x AND y \<and> P s\<rbrace>!"
  by (wpsimp simp: U_and_U'_def)
lemma "\<lbrace>P\<rbrace> U_or_U' (x::nat) (y::nat) \<lbrace>\<lambda>r s. r = x OR y \<and> P s\<rbrace>!"
  by (wpsimp simp: U_or_U'_def)
lemma "\<lbrace>P\<rbrace> U_xor_U' (x::nat) (y::nat) \<lbrace>\<lambda>r s. r = x XOR y \<and> P s\<rbrace>!"
  by (wpsimp simp: U_xor_U'_def)
lemma "\<lbrace>P\<rbrace> not_U' (x::nat) \<lbrace>\<lambda>r s. r = UINT_MAX - x \<and> P s\<rbrace>!"
  by (wpsimp simp: not_U'_def)

section \<open>Left shifts\<close>

thm U_shiftl_U_abs_US'_def U_shiftr_U_abs_US'_def U_shiftl_S_abs_US'_def U_shiftr_S_abs_US'_def
    S_shiftl_U_abs_US'_def S_shiftr_U_abs_US'_def S_shiftl_S_abs_US'_def S_shiftr_S_abs_US'_def
thm U_shiftl_U_abs_U'_def U_shiftr_U_abs_U'_def U_shiftl_S_abs_U'_def U_shiftr_S_abs_U'_def
    S_shiftl_U_abs_U'_def S_shiftr_U_abs_U'_def S_shiftl_S_abs_U'_def S_shiftr_S_abs_U'_def
thm U_shiftl_U_abs_S'_def U_shiftr_U_abs_S'_def U_shiftl_S_abs_S'_def U_shiftr_S_abs_S'_def
    S_shiftl_U_abs_S'_def S_shiftr_U_abs_S'_def S_shiftl_S_abs_S'_def S_shiftr_S_abs_S'_def
thm U_shiftl_U_no_abs'_def U_shiftr_U_no_abs'_def U_shiftl_S_no_abs'_def U_shiftr_S_no_abs'_def
    S_shiftl_U_no_abs'_def S_shiftr_U_no_abs'_def S_shiftl_S_no_abs'_def S_shiftr_S_no_abs'_def

subsection \<open>@{text U_shiftl_U}\<close>

lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (U_shiftl_U_abs_US' (x :: nat) (n :: nat))"
  by (monad_eq simp: U_shiftl_U_abs_US'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. n < 32 \<and> x << n \<le> UINT_MAX\<rbrace>
         U_shiftl_U_abs_US' (x::nat) (n::nat)
       \<lbrace>\<lambda>r s. r = x << n\<rbrace>!"
  by (wpsimp simp: U_shiftl_U_abs_US'_def UINT_MAX_def)

lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (U_shiftl_U_abs_U' (x :: nat) (n :: nat))"
  by (monad_eq simp: U_shiftl_U_abs_U'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. n < 32 \<and> x << n \<le> UINT_MAX\<rbrace>
         U_shiftl_U_abs_U' (x::nat) (n::nat)
       \<lbrace>\<lambda>r s. r = x << n\<rbrace>!"
  by (wpsimp simp: U_shiftl_U_abs_U'_def UINT_MAX_def)

lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (U_shiftl_U_abs_S' (x :: word32) (n :: word32))"
  by (monad_eq simp: U_shiftl_U_abs_S'_def no_fail_def word_le_not_less)
lemma "\<lbrace>\<lambda>s. n < 32\<rbrace>
         U_shiftl_U_abs_S' (x::word32) (n::word32)
       \<lbrace>\<lambda>r s. r = x << unat n\<rbrace>!"
  by (wpsimp simp: U_shiftl_U_abs_S'_def)

lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (U_shiftl_U_no_abs' (x :: word32) (n :: word32))"
  by (monad_eq simp: U_shiftl_U_no_abs'_def no_fail_def word_le_not_less)
lemma "\<lbrace>\<lambda>s. n < 32\<rbrace>
         U_shiftl_U_no_abs' (x::word32) (n::word32)
       \<lbrace>\<lambda>r s. r = x << unat n\<rbrace>!"
  by (wpsimp simp: U_shiftl_U_no_abs'_def)

subsection \<open>@{text U_shiftl_S}\<close>

lemma "n < 0 \<Longrightarrow> \<not> no_fail \<top> (U_shiftl_S_abs_US' (x :: nat) (n :: int))"
  by (monad_eq simp: U_shiftl_S_abs_US'_def no_fail_def)
lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (U_shiftl_S_abs_US' (x :: nat) (n :: int))"
  by (monad_eq simp: U_shiftl_S_abs_US'_def no_fail_def)
lemma "x << nat n > UINT_MAX \<Longrightarrow> \<not> no_fail \<top> (U_shiftl_S_abs_US' (x :: nat) (n :: int))"
  by (monad_eq simp: U_shiftl_S_abs_US'_def no_fail_def UINT_MAX_def)
lemma "\<lbrace>\<lambda>s. 0 \<le> n \<and> n < 32 \<and> x << nat n \<le> UINT_MAX\<rbrace>
         U_shiftl_S_abs_US' (x::nat) (n::int)
       \<lbrace>\<lambda>r s. r = x << nat n\<rbrace>!"
  by (wpsimp simp: U_shiftl_S_abs_US'_def UINT_MAX_def)

lemma "n <s 0 \<Longrightarrow> \<not> no_fail \<top> (U_shiftl_S_abs_U' (x :: nat) (n :: sword32))"
  by (monad_eq simp: U_shiftl_S_abs_U'_def no_fail_def word_sless_alt word_sle_def)
lemma "32 <=s n \<Longrightarrow> \<not> no_fail \<top> (U_shiftl_S_abs_U' (x :: nat) (n :: sword32))"
  by (monad_eq simp: U_shiftl_S_abs_U'_def no_fail_def word_sless_alt word_sle_def)
lemma "x << unat n > UINT_MAX \<Longrightarrow> \<not> no_fail \<top> (U_shiftl_S_abs_U' (x :: nat) (n :: sword32))"
  by (monad_eq simp: U_shiftl_S_abs_U'_def no_fail_def
                     word_sless_alt word_sle_def nat_sint UINT_MAX_def)
lemma "\<lbrace>\<lambda>s. 0 <=s n \<and> n <s 32 \<and> x << unat n \<le> UINT_MAX\<rbrace>
         U_shiftl_S_abs_U' (x::nat) (n::sword32)
       \<lbrace>\<lambda>r s. r = x << unat n\<rbrace>!"
  by (wpsimp simp: U_shiftl_S_abs_U'_def UINT_MAX_def nat_sint word_sle_def word_sless_alt)

lemma "n < 0 \<Longrightarrow> \<not> no_fail \<top> (U_shiftl_S_abs_S' (x :: word32) (n :: int))"
  by (monad_eq simp: U_shiftl_S_abs_S'_def no_fail_def)
lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (U_shiftl_S_abs_S' (x :: word32) (n :: int))"
  by (monad_eq simp: U_shiftl_S_abs_S'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. 0 \<le> n \<and> n < 32\<rbrace>
         U_shiftl_S_abs_S' (x::word32) (n::int)
       \<lbrace>\<lambda>r s. r = x << nat n\<rbrace>!"
  by (wpsimp simp: U_shiftl_S_abs_S'_def UINT_MAX_def unat_of_int)

lemma "n <s 0 \<Longrightarrow> \<not> no_fail \<top> (U_shiftl_S_no_abs' (x :: word32) (n :: sword32))"
  by (monad_eq simp: U_shiftl_S_no_abs'_def no_fail_def word_sle_def word_sless_alt)
lemma "32 <=s n \<Longrightarrow> \<not> no_fail \<top> (U_shiftl_S_no_abs' (x :: word32) (n :: sword32))"
  by (monad_eq simp: U_shiftl_S_no_abs'_def no_fail_def word_sle_def word_sless_alt)
lemma "\<lbrace>\<lambda>s. 0 <=s n \<and> n <s 32\<rbrace>
         U_shiftl_S_no_abs' (x :: word32) (n :: sword32)
       \<lbrace>\<lambda>r s. r = x << unat n\<rbrace>!"
  by (wpsimp simp: U_shiftl_S_no_abs'_def UINT_MAX_def)

subsection \<open>@{text S_shiftl_U}\<close>

lemma "x < 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_U_abs_US' (x :: int) (n :: nat))"
  by (monad_eq simp: S_shiftl_U_abs_US'_def no_fail_def)
lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_U_abs_US' (x :: int) (n :: nat))"
  by (monad_eq simp: S_shiftl_U_abs_US'_def no_fail_def)
lemma "x << nat n > INT_MAX \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_U_abs_US' (x :: int) (n :: nat))"
  by (monad_eq simp: S_shiftl_U_abs_US'_def no_fail_def INT_MAX_def)
lemma "\<lbrace>\<lambda>s. n < 32 \<and> 0 \<le> x \<and> x << nat n \<le> INT_MAX\<rbrace>
         S_shiftl_U_abs_US' (x::int) (n::nat)
       \<lbrace>\<lambda>r s. r = x << nat n\<rbrace>!"
  apply (wpsimp simp: S_shiftl_U_abs_US'_def INT_MAX_def shiftl_nat_def shiftl_int_def)
  apply (subst unat_of_int)
    apply simp
   apply (drule le_less_trans[where x="x*2^n" and z="2^32"])
    apply simp
   apply (subst mult_less_cancel_left_pos[where c="2^n", symmetric])
    apply simp
   apply (subst (asm) mult.commute)
   apply (erule less_le_trans)
   apply simp
  apply (simp flip: nat_mult_distrib nat_power_eq nat_numeral)
  done

lemma "x <s 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_U_abs_U' (x :: sword32) (n :: nat))"
  by (monad_eq simp: S_shiftl_U_abs_U'_def no_fail_def word_sle_def word_sless_alt)
lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_U_abs_U' (x :: sword32) (n :: nat))"
  apply (monad_eq simp: S_shiftl_U_abs_U'_def no_fail_def)
  oops \<comment> \<open>C parser issue: Jira VER-509\<close>
lemma "sint x << n > INT_MAX \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_U_abs_U' (x :: sword32) (n :: nat))"
  by (monad_eq simp: S_shiftl_U_abs_U'_def no_fail_def shiftl_int_def INT_MAX_def
                     nat_int_comparison(2) int_unat_nonneg)
lemma "\<lbrace>\<lambda>s. n < 32 \<and> 0 <=s x \<and> sint x << nat n \<le> INT_MAX\<rbrace>
         S_shiftl_U_abs_U' (x::sword32) (n::nat)
       \<lbrace>\<lambda>r s. r = x << nat n\<rbrace>!"
  by (wpsimp simp: S_shiftl_U_abs_U'_def INT_MAX_def shiftl_int_def
                   nat_int_comparison(2) int_unat_nonneg)

lemma "x < 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_U_abs_S' (x :: int) (n :: word32))"
  by (monad_eq simp: S_shiftl_U_abs_S'_def no_fail_def)
lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_U_abs_S' (x :: int) (n :: word32))"
  by (monad_eq simp: S_shiftl_U_abs_S'_def no_fail_def word_le_nat_alt)
lemma "x << unat n > INT_MAX \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_U_abs_S' (x :: int) (n :: word32))"
  by (monad_eq simp: S_shiftl_U_abs_S'_def no_fail_def INT_MAX_def)
lemma "\<lbrace>\<lambda>s. n < 32 \<and> 0 \<le> x \<and> x << unat n \<le> INT_MAX\<rbrace>
         S_shiftl_U_abs_S' (x::int) (n::word32)
       \<lbrace>\<lambda>r s. r = x << unat n\<rbrace>!"
  apply (wpsimp simp: S_shiftl_U_abs_S'_def INT_MAX_def shiftl_nat_def shiftl_int_def
                      word_less_nat_alt)
  apply (subst unat_of_int)
    apply simp
   apply (drule le_less_trans[where x="x*2^unat n" and z="2^32"])
    apply simp
   apply simp
   apply (subst mult_less_cancel_left_pos[where c="2^unat n", symmetric])
    apply simp
   apply (subst (asm) mult.commute)
   apply (erule less_le_trans)
   apply simp
  apply (simp flip: nat_mult_distrib nat_power_eq nat_numeral)
  done

lemma "x <s 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_U_no_abs' (x :: sword32) (n :: word32))"
  by (monad_eq simp: S_shiftl_U_no_abs'_def no_fail_def word_sle_def word_sless_alt)
lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_U_no_abs' (x :: sword32) (n :: word32))"
  apply (monad_eq simp: S_shiftl_U_no_abs'_def no_fail_def)
  oops \<comment> \<open>C parser issue: Jira VER-509\<close>
lemma "sint x << unat n > INT_MAX \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_U_no_abs' (x :: sword32) (n :: word32))"
  by (monad_eq simp: S_shiftl_U_no_abs'_def no_fail_def shiftl_int_def INT_MAX_def
                     nat_int_comparison(2) int_unat_nonneg)
lemma "\<lbrace>\<lambda>s. n < 32 \<and> 0 <=s x \<and> sint x << unat n \<le> INT_MAX\<rbrace>
         S_shiftl_U_no_abs' (x::sword32) (n::word32)
       \<lbrace>\<lambda>r s. r = x << unat n\<rbrace>!"
  by (wpsimp simp: S_shiftl_U_no_abs'_def INT_MAX_def shiftl_int_def
                   nat_int_comparison(2) int_unat_nonneg)

subsection \<open>@{text S_shiftl_S}\<close>

lemma "x < 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_S_abs_US' (x :: int) (n :: int))"
  by (monad_eq simp: S_shiftl_S_abs_US'_def no_fail_def)
lemma "n < 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_S_abs_US' (x :: int) (n :: int))"
  by (monad_eq simp: S_shiftl_S_abs_US'_def no_fail_def)
lemma "x << nat n > INT_MAX \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_S_abs_US' (x :: int) (n :: int))"
  by (monad_eq simp: S_shiftl_S_abs_US'_def no_fail_def INT_MAX_def)
lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_S_abs_US' (x :: int) (n :: int))"
  by (monad_eq simp: S_shiftl_S_abs_US'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. 0 \<le> n \<and> n < 32 \<and> 0 \<le> x \<and> x << nat n \<le> INT_MAX\<rbrace>
         S_shiftl_S_abs_US' (x::int) (n::int)
       \<lbrace>\<lambda>r s. r = x << nat n\<rbrace>!"
  apply (wpsimp simp: S_shiftl_S_abs_US'_def INT_MAX_def shiftl_nat_def shiftl_int_def)
  apply (subst unat_of_int)
    apply simp
   apply simp
   apply (drule le_less_trans[where x="x*2^nat n" and z="2^32"])
    apply simp
   apply (subst mult_less_cancel_left_pos[where c="2^nat n", symmetric])
    apply simp
   apply (subst (asm) mult.commute)
   apply (erule less_le_trans)
   apply simp
  apply (subst unat_of_int)
    apply simp
   apply simp
  apply (simp flip: nat_mult_distrib nat_power_eq nat_numeral)
  done

lemma "x <s 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_S_abs_U' (x :: sword32) (n :: sword32))"
  by (monad_eq simp: S_shiftl_S_abs_U'_def no_fail_def word_sle_def word_sless_alt)
lemma "n <s 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_S_abs_U' (x :: sword32) (n :: sword32))"
  by (monad_eq simp: S_shiftl_S_abs_U'_def no_fail_def word_sle_def word_sless_alt)
lemma "32 <=s n \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_S_abs_U' (x :: sword32) (n :: sword32))"
  apply (monad_eq simp: S_shiftl_S_abs_U'_def no_fail_def word_sle_def word_sless_alt)
  oops \<comment> \<open>C parser issue: Jira VER-509\<close>
lemma "sint x << unat n > INT_MAX \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_S_abs_U' (x :: sword32) (n :: sword32))"
  by (monad_eq simp: S_shiftl_S_abs_U'_def no_fail_def shiftl_int_def INT_MAX_def
                     nat_int_comparison(2) int_unat_nonneg)
lemma "\<lbrace>\<lambda>s. 0 <=s n \<and> n <s 32 \<and> 0 <=s x \<and> sint x << unat n \<le> INT_MAX\<rbrace>
         S_shiftl_S_abs_U' (x::sword32) (n::sword32)
       \<lbrace>\<lambda>r s. r = x << unat n\<rbrace>!"
  by (wpsimp simp: S_shiftl_S_abs_U'_def INT_MAX_def shiftl_int_def
                   nat_int_comparison(2) int_unat_nonneg)

lemma "x < 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_S_abs_S' (x :: int) (n :: int))"
  by (monad_eq simp: S_shiftl_S_abs_S'_def no_fail_def)
lemma "n < 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_S_abs_S' (x :: int) (n :: int))"
  by (monad_eq simp: S_shiftl_S_abs_S'_def no_fail_def)
lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_S_abs_S' (x :: int) (n :: int))"
  by (monad_eq simp: S_shiftl_S_abs_S'_def no_fail_def)
lemma "x << n > INT_MAX \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_S_abs_S' (x :: int) (n :: int))"
  by (monad_eq simp: S_shiftl_S_abs_S'_def no_fail_def INT_MAX_def)
lemma "\<lbrace>\<lambda>s. 0 \<le> n \<and> n < 32 \<and> 0 \<le> x \<and> x << n \<le> INT_MAX\<rbrace>
         S_shiftl_S_abs_S' (x::int) (n::int)
       \<lbrace>\<lambda>r s. r = x << nat n\<rbrace>!"
  apply (wpsimp simp: S_shiftl_S_abs_S'_def INT_MAX_def shiftl_nat_def shiftl_int_def)
  apply (subst unat_of_int)
    apply simp
   apply (drule le_less_trans[where x="x*2^n" and z="2^32"])
    apply simp
   apply (subst mult_less_cancel_left_pos[where c="2^n", symmetric])
    apply simp
   apply (subst (asm) mult.commute)
   apply (erule less_le_trans)
   apply simp
  apply (simp add: le_unat_uoi[where z="32"])
  apply (simp flip: nat_mult_distrib nat_power_eq nat_numeral)
  done

lemma "x <s 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_S_no_abs' (x :: sword32) (n :: sword32))"
  by (monad_eq simp: S_shiftl_S_no_abs'_def no_fail_def word_sle_def word_sless_alt)
lemma "n <s 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_S_no_abs' (x :: sword32) (n :: sword32))"
  by (monad_eq simp: S_shiftl_S_no_abs'_def no_fail_def word_sle_def word_sless_alt)
lemma "32 <=s n \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_S_no_abs' (x :: sword32) (n :: sword32))"
  apply (monad_eq simp: S_shiftl_S_no_abs'_def no_fail_def)
  oops \<comment> \<open>C parser issue: Jira VER-509\<close>
lemma "sint x << unat n > INT_MAX \<Longrightarrow> \<not> no_fail \<top> (S_shiftl_S_no_abs' (x :: sword32) (n :: sword32))"
  by (monad_eq simp: S_shiftl_S_no_abs'_def no_fail_def shiftl_int_def INT_MAX_def
                     nat_int_comparison(2) int_unat_nonneg)
lemma "\<lbrace>\<lambda>s. 0 <=s n \<and> n <s 32 \<and> 0 <=s x \<and> sint x << unat n \<le> INT_MAX\<rbrace>
         S_shiftl_S_no_abs' (x::sword32) (n::sword32)
       \<lbrace>\<lambda>r s. r = x << unat n\<rbrace>!"
  by (wpsimp simp: S_shiftl_S_no_abs'_def INT_MAX_def shiftl_int_def
                   nat_int_comparison(2) int_unat_nonneg)

section \<open>Right shifts\<close>

subsection \<open>@{text U_shiftr_U}\<close>

lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (U_shiftr_U_abs_US' (x :: nat) (n :: nat))"
  by (monad_eq simp: U_shiftr_U_abs_US'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. n < 32\<rbrace> U_shiftr_U_abs_US' (x::nat) (n::nat) \<lbrace>\<lambda>r s. r = x >> n\<rbrace>!"
  by (wpsimp simp: U_shiftr_U_abs_US'_def)

lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (U_shiftr_U_abs_U' (x :: nat) (n :: nat))"
  by (monad_eq simp: U_shiftr_U_abs_U'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. n < 32\<rbrace> U_shiftr_U_abs_U' (x::nat) (n::nat) \<lbrace>\<lambda>r s. r = x >> n\<rbrace>!"
  by (wpsimp simp: U_shiftr_U_abs_U'_def)

lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (U_shiftr_U_abs_S' (x :: word32) (n :: word32))"
  by (monad_eq simp: U_shiftr_U_abs_S'_def no_fail_def word_le_not_less)
lemma "\<lbrace>\<lambda>s. n < 32\<rbrace> U_shiftr_U_abs_S' (x::word32) (n::word32) \<lbrace>\<lambda>r s. r = x >> unat n\<rbrace>!"
  by (wpsimp simp: U_shiftr_U_abs_S'_def)

lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (U_shiftr_U_no_abs' (x :: word32) (n :: word32))"
  by (monad_eq simp: U_shiftr_U_no_abs'_def no_fail_def word_le_not_less)
lemma "\<lbrace>\<lambda>s. n < 32\<rbrace> U_shiftr_U_no_abs' (x::word32) (n::word32) \<lbrace>\<lambda>r s. r = x >> unat n\<rbrace>!"
  by (wpsimp simp: U_shiftr_U_no_abs'_def)

subsection \<open>@{text U_shiftr_S}\<close>

lemma "n < 0 \<Longrightarrow> \<not> no_fail \<top> (U_shiftr_S_abs_US' (x :: nat) (n :: int))"
  by (monad_eq simp: U_shiftr_S_abs_US'_def no_fail_def)
lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (U_shiftr_S_abs_US' (x :: nat) (n :: int))"
  by (monad_eq simp: U_shiftr_S_abs_US'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. 0 \<le> n \<and> n < 32\<rbrace> U_shiftr_S_abs_US' (x::nat) (n::int) \<lbrace>\<lambda>r s. r = x >> nat n\<rbrace>!"
  by (wpsimp simp: U_shiftr_S_abs_US'_def)

lemma "n <s 0 \<Longrightarrow> \<not> no_fail \<top> (U_shiftr_S_abs_U' (x :: nat) (n :: sword32))"
  by (monad_eq simp: U_shiftr_S_abs_U'_def no_fail_def word_sless_alt word_sle_def)
lemma "32 <=s n \<Longrightarrow> \<not> no_fail \<top> (U_shiftr_S_abs_U' (x :: nat) (n :: sword32))"
  by (monad_eq simp: U_shiftr_S_abs_U'_def no_fail_def word_sless_alt word_sle_def)
lemma "\<lbrace>\<lambda>s. 0 <=s n \<and> n <s 32\<rbrace> U_shiftr_S_abs_U' (x::nat) (n::sword32) \<lbrace>\<lambda>r s. r = x >> unat n\<rbrace>!"
  by (wpsimp simp: U_shiftr_S_abs_U'_def nat_sint word_sle_def word_sless_alt)

lemma "n < 0 \<Longrightarrow> \<not> no_fail \<top> (U_shiftr_S_abs_S' (x :: word32) (n :: int))"
  by (monad_eq simp: U_shiftr_S_abs_S'_def no_fail_def)
lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (U_shiftr_S_abs_S' (x :: word32) (n :: int))"
  by (monad_eq simp: U_shiftr_S_abs_S'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. 0 \<le> n \<and> n < 32\<rbrace> U_shiftr_S_abs_S' (x::word32) (n::int) \<lbrace>\<lambda>r s. r = x >> nat n\<rbrace>!"
  by (wpsimp simp: U_shiftr_S_abs_S'_def unat_of_int)

lemma "n <s 0 \<Longrightarrow> \<not> no_fail \<top> (U_shiftr_S_no_abs' (x :: word32) (n :: sword32))"
  by (monad_eq simp: U_shiftr_S_no_abs'_def no_fail_def word_sle_def word_sless_alt)
lemma "32 <=s n \<Longrightarrow> \<not> no_fail \<top> (U_shiftr_S_no_abs' (x :: word32) (n :: sword32))"
  by (monad_eq simp: U_shiftr_S_no_abs'_def no_fail_def word_sle_def word_sless_alt)
lemma "\<lbrace>\<lambda>s. 0 <=s n \<and> n <s 32\<rbrace> U_shiftr_S_no_abs' (x :: word32) (n :: sword32) \<lbrace>\<lambda>r s. r = x >> unat n\<rbrace>!"
  by (wpsimp simp: U_shiftr_S_no_abs'_def)

subsection \<open>@{text S_shiftr_U}\<close>

lemma "x < 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_U_abs_US' (x :: int) (n :: nat))"
  by (monad_eq simp: S_shiftr_U_abs_US'_def no_fail_def)
lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_U_abs_US' (x :: int) (n :: nat))"
  by (monad_eq simp: S_shiftr_U_abs_US'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. n < 32 \<and> 0 \<le> x\<rbrace> S_shiftr_U_abs_US' (x::int) (n::nat) \<lbrace>\<lambda>r s. r = x >> nat n\<rbrace>!"
  by (wpsimp simp: S_shiftr_U_abs_US'_def)

lemma "x <s 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_U_abs_U' (x :: sword32) (n :: nat))"
  by (monad_eq simp: S_shiftr_U_abs_U'_def no_fail_def word_sle_def word_sless_alt)
lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_U_abs_U' (x :: sword32) (n :: nat))"
  by (monad_eq simp: S_shiftr_U_abs_U'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. n < 32 \<and> 0 <=s x\<rbrace> S_shiftr_U_abs_U' (x::sword32) (n::nat) \<lbrace>\<lambda>r s. r = x >> nat n\<rbrace>!"
  by (wpsimp simp: S_shiftr_U_abs_U'_def)

lemma "x < 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_U_abs_S' (x :: int) (n :: word32))"
  by (monad_eq simp: S_shiftr_U_abs_S'_def no_fail_def)
lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_U_abs_S' (x :: int) (n :: word32))"
  by (monad_eq simp: S_shiftr_U_abs_S'_def no_fail_def word_le_nat_alt)
lemma "\<lbrace>\<lambda>s. n < 32 \<and> 0 \<le> x\<rbrace> S_shiftr_U_abs_S' (x::int) (n::word32) \<lbrace>\<lambda>r s. r = x >> unat n\<rbrace>!"
  by (wpsimp simp: S_shiftr_U_abs_S'_def word_less_nat_alt)

lemma "x <s 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_U_no_abs' (x :: sword32) (n :: word32))"
  by (monad_eq simp: S_shiftr_U_no_abs'_def no_fail_def word_sle_def word_sless_alt)
lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_U_no_abs' (x :: sword32) (n :: word32))"
  by (monad_eq simp: S_shiftr_U_no_abs'_def no_fail_def word_le_not_less)
lemma "\<lbrace>\<lambda>s. n < 32 \<and> 0 <=s x\<rbrace> S_shiftr_U_no_abs' (x::sword32) (n::word32) \<lbrace>\<lambda>r s. r = x >> unat n\<rbrace>!"
  by (wpsimp simp: S_shiftr_U_no_abs'_def)

subsection \<open>@{text S_shiftr_S}\<close>

lemma "x < 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_S_abs_US' (x :: int) (n :: int))"
  by (monad_eq simp: S_shiftr_S_abs_US'_def no_fail_def)
lemma "n < 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_S_abs_US' (x :: int) (n :: int))"
  by (monad_eq simp: S_shiftr_S_abs_US'_def no_fail_def)
lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_S_abs_US' (x :: int) (n :: int))"
  by (monad_eq simp: S_shiftr_S_abs_US'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. 0 \<le> n \<and> n < 32 \<and> 0 \<le> x\<rbrace> S_shiftr_S_abs_US' (x::int) (n::int) \<lbrace>\<lambda>r s. r = x >> nat n\<rbrace>!"
  by (wpsimp simp: S_shiftr_S_abs_US'_def)

lemma "x <s 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_S_abs_U' (x :: sword32) (n :: sword32))"
  by (monad_eq simp: S_shiftr_S_abs_U'_def no_fail_def word_sle_def word_sless_alt)
lemma "n <s 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_S_abs_U' (x :: sword32) (n :: sword32))"
  by (monad_eq simp: S_shiftr_S_abs_U'_def no_fail_def word_sle_def word_sless_alt)
lemma "32 <=s n \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_S_abs_U' (x :: sword32) (n :: sword32))"
  by (monad_eq simp: S_shiftr_S_abs_U'_def no_fail_def word_sle_def word_sless_alt)
lemma "\<lbrace>\<lambda>s. 0 <=s n \<and> n <s 32 \<and> 0 <=s x\<rbrace>
         S_shiftr_S_abs_U' (x::sword32) (n::sword32)
       \<lbrace>\<lambda>r s. r = x >> unat n\<rbrace>!"
  by (wpsimp simp: S_shiftr_S_abs_U'_def)

lemma "x < 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_S_abs_S' (x :: int) (n :: int))"
  by (monad_eq simp: S_shiftr_S_abs_S'_def no_fail_def)
lemma "n < 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_S_abs_S' (x :: int) (n :: int))"
  by (monad_eq simp: S_shiftr_S_abs_S'_def no_fail_def)
lemma "n \<ge> 32 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_S_abs_S' (x :: int) (n :: int))"
  by (monad_eq simp: S_shiftr_S_abs_S'_def no_fail_def)
lemma "\<lbrace>\<lambda>s. 0 \<le> n \<and> n < 32 \<and> 0 \<le> x\<rbrace>
         S_shiftr_S_abs_S' (x::int) (n::int)
       \<lbrace>\<lambda>r s. r = x >> nat n\<rbrace>!"
  by (wpsimp simp: S_shiftr_S_abs_S'_def)

lemma "x <s 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_S_no_abs' (x :: sword32) (n :: sword32))"
  by (monad_eq simp: S_shiftr_S_no_abs'_def no_fail_def word_sle_def word_sless_alt)
lemma "n <s 0 \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_S_no_abs' (x :: sword32) (n :: sword32))"
  by (monad_eq simp: S_shiftr_S_no_abs'_def no_fail_def word_sle_def word_sless_alt)
lemma "32 <=s n \<Longrightarrow> \<not> no_fail \<top> (S_shiftr_S_no_abs' (x :: sword32) (n :: sword32))"
  by (monad_eq simp: S_shiftr_S_no_abs'_def no_fail_def word_sle_def word_sless_alt)
lemma "\<lbrace>\<lambda>s. 0 <=s n \<and> n <s 32 \<and> 0 <=s x\<rbrace>
         S_shiftr_S_no_abs' (x::sword32) (n::sword32)
       \<lbrace>\<lambda>r s. r = x >> unat n\<rbrace>!"
  by (wpsimp simp: S_shiftr_S_no_abs'_def)

end

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
(*
  Changelist since submission on 2009-11-26:

  2009-12-09: Ordered iterators, to_list produces sorted list

*)
header {* \isaheader{Map Implementation by Red-Black-Trees} *}
theory RBTMapImpl
imports
  "../spec/MapSpec"
  "../../Lib/RBT_add"
  "~~/src/HOL/Library/RBT"
  "../gen_algo/MapGA"
begin
text_raw {*\label{thy:RBTMapImpl}*}

hide_const (open) RBT.map RBT.fold RBT.foldi RBT.empty RBT.insert

(*@impl Map
  @type ('k::linorder,'v) rm
  @abbrv rm,r
  Maps over linearly ordered keys implemented by red-black trees.
*)

type_synonym ('k,'v) rm = "('k,'v) RBT.rbt"

definition rm_basic_ops :: "('k::linorder,'v,('k,'v) rm) omap_basic_ops"
  where [icf_rec_def]: "rm_basic_ops \<equiv> \<lparr>
  bmap_op_\<alpha> = RBT.lookup,
  bmap_op_invar = \<lambda>_. True,
  bmap_op_empty = (\<lambda>_::unit. RBT.empty),
  bmap_op_lookup = (\<lambda>k m. RBT.lookup m k),
  bmap_op_update = RBT.insert,
  bmap_op_update_dj = RBT.insert,
  bmap_op_delete = RBT.delete,
  bmap_op_list_it = (\<lambda>r. RBT_add.rm_iterateoi (RBT.impl_of r)),
  bmap_op_ordered_list_it = (\<lambda>r. RBT_add.rm_iterateoi (RBT.impl_of r)),
  bmap_op_rev_list_it = (\<lambda>r. RBT_add.rm_reverse_iterateoi (RBT.impl_of r))
\<rparr>"

setup Locale_Code.open_block
interpretation rm_basic!: StdBasicOMap rm_basic_ops
  apply unfold_locales
  apply (simp_all add: rm_basic_ops_def)
  apply (rule map_iterator_linord_is_it)
  apply dup_subgoals
  unfolding RBT.lookup_def
  apply simp_all
  apply (rule rm_iterateoi_correct)
  apply simp
  apply (rule rm_reverse_iterateoi_correct)
  apply simp
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "rm_ops \<equiv> rm_basic.dflt_oops\<lparr>map_op_add := RBT.union\<rparr>"
setup Locale_Code.open_block
interpretation rm!: StdOMap rm_ops
proof -
  interpret aux1: StdOMap rm_basic.dflt_oops
    unfolding rm_ops_def
    by (rule rm_basic.dflt_oops_impl)
  interpret aux2: map_add RBT.lookup "\<lambda>_. True" RBT.union
    apply unfold_locales
    apply (rule lookup_union)
    .

  show "StdOMap rm_ops"
    apply (rule StdOMap_intro)
    apply icf_locales
    done
qed

interpretation rm!: StdMap_no_invar rm_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "rm"*}

lemma pi_rm[proper_it]:
  "proper_it' RBT_add.rm_iterateoi RBT_add.rm_iterateoi"
  apply (rule proper_it'I)
  by (induct_tac s) (simp_all add: rm_iterateoi_alt_def icf_proper_iteratorI)
lemma pi_rm_rev[proper_it]:
  "proper_it' RBT_add.rm_reverse_iterateoi RBT_add.rm_reverse_iterateoi"
  apply (rule proper_it'I)
  by (induct_tac s) (simp_all add: rm_reverse_iterateoi_alt_def
    icf_proper_iteratorI)

interpretation pi_rm: proper_it_loc RBT_add.rm_iterateoi RBT_add.rm_iterateoi
  apply unfold_locales by (rule pi_rm)
interpretation pi_rm_rev: proper_it_loc RBT_add.rm_reverse_iterateoi
  RBT_add.rm_reverse_iterateoi
  apply unfold_locales by (rule pi_rm_rev)

text {* Code generator test *}
definition "test_codegen \<equiv> (rm.add ,
  rm.add_dj ,
  rm.ball ,
  rm.bex ,
  rm.delete ,
  rm.empty ,
  rm.isEmpty ,
  rm.isSng ,
  rm.iterate ,
  rm.iteratei ,
  rm.iterateo ,
  rm.iterateoi ,
  rm.list_it ,
  rm.lookup ,
  rm.max ,
  rm.min ,
  rm.restrict ,
  rm.rev_iterateo ,
  rm.rev_iterateoi ,
  rm.rev_list_it ,
  rm.reverse_iterateo ,
  rm.reverse_iterateoi ,
  rm.sel ,
  rm.size ,
  rm.size_abort ,
  rm.sng ,
  rm.to_list ,
  rm.to_map ,
  rm.to_rev_list ,
  rm.to_sorted_list ,
  rm.update ,
  rm.update_dj)"

export_code test_codegen in SML

end


section \<open>Example\<close>

text \<open>We provide an example in order to prove that our locale is non-vacuous.
This example corresponds to the computation and associated snapshot described
in Section 4 of~\<^cite>\<open>"chandy"\<close>.\<close>

theory Example
  imports
    Snapshot

begin

datatype PType = P | Q
datatype MType = M | M'
datatype SType = S_Wait | S_Send | T_Wait | T_Send

fun trans :: "PType \<Rightarrow> SType \<Rightarrow> SType \<Rightarrow> bool" where
  "trans p s s' = False"

fun send :: "channel_id \<Rightarrow> PType \<Rightarrow> PType \<Rightarrow> SType
             \<Rightarrow> SType \<Rightarrow> MType \<Rightarrow> bool" where
  "send c p q s s' m = ((c = 0 \<and> p = P \<and> q = Q
                          \<and> s = S_Send \<and> s' = S_Wait \<and> m = M)
                     \<or> (c = 1 \<and> p = Q \<and> q = P
                          \<and> s = T_Send \<and> s' = T_Wait \<and> m = M'))"

fun recv :: "channel_id \<Rightarrow> PType \<Rightarrow> PType \<Rightarrow> SType
             \<Rightarrow> SType \<Rightarrow> MType \<Rightarrow> bool" where
  "recv c p q s s' m = ((c = 1 \<and> p = P \<and> q = Q
                          \<and> s = S_Wait \<and> s' = S_Send \<and> m = M')
                     \<or> (c = 0 \<and> p = Q \<and> q = P
                          \<and> s = T_Wait \<and> s' = T_Send \<and> m = M))"

fun chan :: "nat \<Rightarrow> (PType * PType) option" where
 "chan n = (if n = 0 then Some (P, Q)
            else if n = 1 then Some (Q, P)
            else None)"

abbreviation init :: "(PType, SType, MType) configuration" where
  "init \<equiv> \<lparr>
       states = (%p. if p = P then S_Send else T_Send),
       msgs = (%d. []),
       process_snapshot = (%p. None),
       channel_snapshot = (%d. ([], NotStarted))
    \<rparr>"

abbreviation t0 where "t0 \<equiv> Snapshot P"

abbreviation s1 :: "(PType, SType, MType) configuration" where
  "s1 \<equiv> \<lparr>
       states = (%p. if p = P then S_Send else T_Send),
       msgs = (%d. if d = 0 then [Marker] else []),
       process_snapshot = (%p. if p = P then Some S_Send else None),
       channel_snapshot = (%d. if d = 1 then ([], Recording) else ([], NotStarted))
    \<rparr>"

abbreviation t1 where "t1 \<equiv> Send 0 P Q S_Send S_Wait M"

abbreviation s2 :: "(PType, SType, MType) configuration" where
  "s2 \<equiv> \<lparr>
       states = (%p. if p = P then S_Wait else T_Send),
       msgs = (%d. if d = 0 then [Marker, Msg M] else []),
       process_snapshot = (%p. if p = P then Some S_Send else None),
       channel_snapshot = (%d. if d = 1 then ([], Recording) else ([], NotStarted))
    \<rparr>"

abbreviation t2 where "t2 \<equiv> Send 1 Q P T_Send T_Wait M'"

abbreviation s3 :: "(PType, SType, MType) configuration" where
  "s3 \<equiv> \<lparr>
       states = (%p. if p = P then S_Wait else T_Wait),
       msgs = (%d. if d = 0 then [Marker, Msg M] else if d = 1 then [Msg M'] else []),
       process_snapshot = (%p. if p = P then Some S_Send else None),
       channel_snapshot = (%d. if d = 1 then ([], Recording) else ([], NotStarted))
    \<rparr>"

abbreviation t3 where "t3 \<equiv> Snapshot Q"

abbreviation s4 :: "(PType, SType, MType) configuration" where
  "s4 \<equiv> \<lparr>
       states = (%p. if p = P then S_Wait else T_Wait),
       msgs = (%d. if d = 0 then [Marker, Msg M] else if d = 1 then [Msg M', Marker] else []),
       process_snapshot = (%p. if p = P then Some S_Send else Some T_Wait),
       channel_snapshot = (%d. if d = 1 then ([], Recording) else if d = 0 then ([], Recording) else ([], NotStarted))
    \<rparr>"

abbreviation t4 where "t4 \<equiv> RecvMarker 0 Q P"

abbreviation s5 :: "(PType, SType, MType) configuration" where
  "s5 \<equiv> \<lparr>
       states = (%p. if p = P then S_Wait else T_Wait),
       msgs = (%d. if d = 0 then [Msg M] else if d = 1 then [Msg M', Marker] else []),
       process_snapshot = (%p. if p = P then Some S_Send else Some T_Wait),
       channel_snapshot = (%d. if d = 0 then ([], Done) else if d = 1 then ([], Recording) else ([], NotStarted))
    \<rparr>"

abbreviation t5 where "t5 \<equiv> Recv 1 P Q S_Wait S_Send M'"

abbreviation s6 :: "(PType, SType, MType) configuration" where
  "s6 \<equiv> \<lparr>
       states = (%p. if p = P then S_Send else T_Wait),
       msgs = (%d. if d = 0 then [Msg M] else if d = 1 then [Marker] else []),
       process_snapshot = (%p. if p = P then Some S_Send else Some T_Wait),
       channel_snapshot = (%d. if d = 0 then ([], Done) else if d = 1 then ([M'], Recording) else ([], NotStarted))
    \<rparr>"

abbreviation t6 where "t6 \<equiv> RecvMarker 1 P Q"

abbreviation s7 :: "(PType, SType, MType) configuration" where
  "s7 \<equiv> \<lparr>
       states = (%p. if p = P then S_Send else T_Wait),
       msgs = (%d. if d = 0 then [Msg M] else if d = 1 then [] else []),
       process_snapshot = (%p. if p = P then Some S_Send else Some T_Wait),
       channel_snapshot = (%d. if d = 0 then ([], Done) else if d = 1 then ([M'], Done) else ([], NotStarted))
    \<rparr>"

lemma s7_no_marker:
  shows
    "\<forall>cid. Marker \<notin> set (msgs s7 cid)"
  by simp

interpretation computation chan trans send recv init s7
proof
  have "distributed_system chan"
  proof
    show "\<forall>i. \<nexists>p. chan i = Some (p, p)" by simp
  qed
  show "\<forall>p q. p \<noteq> q \<longrightarrow> (\<lambda>p q. \<exists>i. chan i = Some (p, q))\<^sup>+\<^sup>+ p q"
  proof ((rule allI)+, rule impI)
    fix p q :: PType assume "p \<noteq> q"
    then have "(p = P \<and> q = Q) \<or> (p = Q \<and> q = P)"
      using PType.exhaust by auto
    then have "\<exists>i. chan i = Some (p, q)" by (elim disjE) auto
    then show "(\<lambda>p q. \<exists>i. chan i = Some (p, q))\<^sup>+\<^sup>+ p q" by blast
  qed
  show "finite {i. \<exists>p q. chan i = Some (p, q)}"
  proof -
    have "{i. \<exists>p q. chan i = Some (p, q)} = {0,1}" by auto
    then show ?thesis by simp
  qed
  show "1 < card (UNIV :: PType set)"
  proof -
    have "(UNIV :: PType set) = {P, Q}"
      using PType.exhaust by blast
    then have "card (UNIV :: PType set) = 2"
      by (metis One_nat_def PType.distinct(1) Suc_1 card.insert card.empty finite.emptyI finite.insertI insert_absorb insert_not_empty singletonD)
    then show ?thesis by auto
  qed
  show "finite (UNIV :: PType set)"
  proof -
    have "(UNIV :: PType set) = {P, Q}"
      using PType.exhaust by blast
    then show ?thesis
      by (metis finite.emptyI finite.insertI)
  qed
  show "\<forall>i. \<nexists>p. chan i = Some (p, p)" by simp
  show "\<forall>i. (\<exists>p q. chan i = Some (p, q)) \<longrightarrow> Marker \<notin> set (msgs init i)" by auto
  show "\<forall>i. chan i = None \<longrightarrow> msgs init i = []" by auto
  show "\<forall>p. \<not> ps init p \<noteq> None" by auto
  show "\<forall>i. cs init i = ([], NotStarted)" by auto
  show "\<exists>t. distributed_system.trace chan Example.trans send recv init t s7"
  proof -
    let ?t = "[t0, t1, t2, t3, t4, t5, t6]"
    have "distributed_system.next chan trans send recv init t0 s1"
    proof -
      have "distributed_system.can_occur chan trans send recv t0 init"
        using \<open>distributed_system chan\<close> distributed_system.can_occur_def by fastforce
      then show ?thesis
        by (simp add: \<open>distributed_system chan\<close> distributed_system.next_snapshot)
    qed
    moreover have "distributed_system.next chan trans send recv s1 t1 s2"
    proof -
      have "distributed_system.can_occur chan trans send recv t1 s1"
        using \<open>distributed_system chan\<close> distributed_system.can_occur_def by fastforce
      then show ?thesis
        by (simp add: \<open>distributed_system chan\<close> distributed_system.next_send)
    qed
    moreover have "distributed_system.next chan trans send recv s2 t2 s3"
    proof -
      have "distributed_system.can_occur chan trans send recv t2 s2"
        using \<open>distributed_system chan\<close> distributed_system.can_occur_def by fastforce
      moreover have "\<forall>r. r \<noteq> P \<longrightarrow> r = Q" using PType.exhaust by auto
      ultimately show ?thesis by (simp add: \<open>distributed_system chan\<close> distributed_system.next_send)
    qed
    moreover have "distributed_system.next chan trans send recv s3 t3 s4"
    proof -
      have "distributed_system.can_occur chan trans send recv t3 s3"
        using \<open>distributed_system chan\<close> distributed_system.can_occur_def by fastforce
      moreover have "\<forall>p'. p' \<noteq> P \<longrightarrow> p' = Q" using PType.exhaust by auto
      ultimately show ?thesis by (simp add: \<open>distributed_system chan\<close> distributed_system.next_snapshot)
    qed
    moreover have "distributed_system.next chan trans send recv s4 t4 s5"
    proof -
      have "distributed_system.can_occur chan trans send recv t4 s4"
        using \<open>distributed_system chan\<close> distributed_system.can_occur_def by fastforce
      then show ?thesis
        by (simp add: \<open>distributed_system chan\<close> distributed_system.next_def)
    qed
    moreover have "distributed_system.next chan trans send recv s5 t5 s6"
    proof -
      have "distributed_system.can_occur chan trans send recv t5 s5"
        using \<open>distributed_system chan\<close> distributed_system.can_occur_def by fastforce
      then show ?thesis
        by (simp add: \<open>distributed_system chan\<close> distributed_system.next_def)
    qed
    moreover have "distributed_system.next chan trans send recv s6 t6 s7"
    proof -
      have "distributed_system.can_occur chan trans send recv t6 s6"
        using \<open>distributed_system chan\<close> distributed_system.can_occur_def by fastforce
      then show ?thesis
        by (simp add: \<open>distributed_system chan\<close> distributed_system.next_def)
    qed
    ultimately have "distributed_system.trace chan trans send recv init ?t s7"
      by (meson \<open>distributed_system chan\<close> distributed_system.trace.simps)
    then show ?thesis by blast
  qed
  show "\<forall>t i cid. distributed_system.trace chan Example.trans send recv init t s7 \<and>
       Marker \<in> set (msgs (distributed_system.s chan Example.trans send recv init t i) cid) \<longrightarrow>
       (\<exists>j\<ge>i. Marker \<notin> set (msgs (distributed_system.s chan Example.trans send recv init t j) cid))"
  proof ((rule allI)+, (rule impI)+)
    fix t i cid
    assume asm: "distributed_system.trace chan Example.trans send recv init t s7 \<and>
                 Marker \<in> set (msgs (distributed_system.s chan Example.trans send recv init t i) cid)"
    have tr_exists: "distributed_system.trace chan Example.trans send recv init t s7" using asm by blast
    have marker_in_channel: "Marker \<in> set (msgs (distributed_system.s chan Example.trans send recv init t i) cid)" using asm by simp
    have s7_is_fin: "s7 = (distributed_system.s chan Example.trans send recv init t (length t))"
      by (metis (no_types, lifting) \<open>distributed_system chan\<close> \<open>distributed_system.trace chan Example.trans send recv init t s7\<close> distributed_system.exists_trace_for_any_i distributed_system.trace_and_start_determines_end order_refl take_all)
    have "i < length t"
    proof (rule ccontr)
      assume "~ i < length t"
      then have "distributed_system.trace chan Example.trans send recv
                (distributed_system.s chan Example.trans send recv init t (length t))
                []
                (distributed_system.s chan Example.trans send recv init t i)"
        by (metis (no_types, lifting) \<open>distributed_system chan\<close> distributed_system.exists_trace_for_any_i distributed_system.trace.simps distributed_system.trace_and_start_determines_end not_less s7_is_fin take_all tr_exists)
      then have "Marker \<notin> set (msgs (distributed_system.s chan Example.trans send recv init t i) cid)"
      proof -
        have "distributed_system.s chan Example.trans send recv init t i = s7"
          using \<open>distributed_system chan\<close> \<open>distributed_system.trace chan Example.trans send recv (distributed_system.s chan Example.trans send recv init t (length t)) [] (distributed_system.s chan Example.trans send recv init t i)\<close> distributed_system.trace.simps s7_is_fin by fastforce
        then show ?thesis using s7_no_marker by simp
      qed
      then show False using marker_in_channel by simp
    qed
    then show "(\<exists>j\<ge>i. Marker \<notin> set (msgs (distributed_system.s chan Example.trans send recv init t j) cid))"
    proof -
      have "distributed_system.trace chan Example.trans send recv
            (distributed_system.s chan Example.trans send recv init t i)
            (take ((length t) - i) (drop i t))
            (distributed_system.s chan Example.trans send recv init t (length t))"
        using \<open>distributed_system chan\<close> \<open>i < length t\<close> distributed_system.exists_trace_for_any_i_j less_imp_le_nat tr_exists by blast
      then have "Marker \<notin> set (msgs (distributed_system.s chan Example.trans send recv init t (length t)) cid)"
      proof -
        have "distributed_system.s chan Example.trans send recv init t (length t) = s7"
          by (simp add: s7_is_fin)
        then show ?thesis using s7_no_marker by simp
      qed
      then show ?thesis
        using \<open>i < length t\<close> less_imp_le_nat by blast
    qed
  qed
  show "\<forall>t p. distributed_system.trace chan Example.trans send recv init t s7 \<longrightarrow>
              (\<exists>i. ps (distributed_system.s chan Example.trans send recv init t i) p \<noteq> None \<and> i \<le> length t)"
  proof ((rule allI)+, rule impI)
    fix t p
    assume "distributed_system.trace chan Example.trans send recv init t s7"
    have s7_is_fin: "s7 = (distributed_system.s chan Example.trans send recv init t (length t))"
      by (metis (no_types, lifting) \<open>distributed_system chan\<close> \<open>distributed_system.trace chan Example.trans send recv init t s7\<close> distributed_system.exists_trace_for_any_i distributed_system.trace_and_start_determines_end order_refl take_all)
    moreover have "has_snapshotted s7 p" by simp
    ultimately show "(\<exists>i. ps (distributed_system.s chan Example.trans send recv init t i) p \<noteq> None \<and> i \<le> length t)"
      by auto
  qed
qed

end