theory Secure_Mult
imports Cyclic_Group_SPMF Uniform_Sampling Comp_Indist
begin

(*Here we prove information theoretic security for the secure multiplication protocol*)

lemma weight_1: assumes 1: "q > 0" shows "lossless_spmf (sample_uniform q)"
apply(auto simp add: sample_uniform_def)
using assms by blast

(*Security for party 1*)

(*Construct views of pary 1*)
definition R1 :: "(nat \<times> nat) \<Rightarrow> nat \<Rightarrow> (nat \<times> nat \<times> nat \<times> nat \<times> nat \<times> nat) spmf"
where "R1 input n = do {
  let (x,y) = input;
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  r :: nat \<leftarrow> sample_uniform q;
  a' :: nat \<leftarrow> sample_uniform q;
  b' :: nat \<leftarrow> sample_uniform q;
  r' :: nat \<leftarrow> sample_uniform q;
  return_spmf(x mod q, a, r, (y + (q - b)) mod q, (x*(y-b') + (q - r')) mod q, ((x*y mod q - (x*(y-b') + (q - r')) mod q) mod q))}"

definition  S1 :: "(nat \<times> nat) \<Rightarrow> nat \<Rightarrow> (nat \<times> nat \<times> nat \<times> nat \<times> nat \<times> nat) spmf"
where "S1 input n = do {
  let (x,y) = input;
  a' :: nat \<leftarrow> sample_uniform q;
  b' :: nat \<leftarrow> sample_uniform q;
  c' \<leftarrow> sample_uniform q;
  s1' \<leftarrow> sample_uniform q;
  return_spmf(x mod nat q, a', (x*b' + (q -c')) mod q, b', s1', (x*y mod q - s1') mod q)}"

(*Security is information theoretic*)
lemma inf_theoretic_1: assumes 1: "q > 0" shows "R1 input n = S1 input n"
proof-
have "R1 input n = do {
  let (x,y) = input;
  a' :: nat \<leftarrow> sample_uniform q;
  b' :: nat \<leftarrow> sample_uniform q;
  c' \<leftarrow> sample_uniform q;
  s1' \<leftarrow> sample_uniform q;
  return_spmf(x mod nat q, a', c', b', s1', (x*y mod q - s1') mod q)}"
    proof-
    have "R1 input n = do {
      let (x,y) = input;
      a :: nat \<leftarrow> sample_uniform q;
      b \<leftarrow> map_spmf(\<lambda> b.  (y + (q - b)) mod q) (sample_uniform q);
      r :: nat \<leftarrow> sample_uniform q;
      a' :: nat \<leftarrow> sample_uniform q;
      b' :: nat \<leftarrow> sample_uniform q;
      r' :: nat \<leftarrow> sample_uniform q;
      return_spmf(x mod q, a, r, b, (x*(y-b') + (q - r')) mod q, ((x*y mod q - (x*(y-b') + (q - r')) mod q) mod q))}"
        by(simp add: R1_def map_spmf_conv_bind_spmf bind_spmf_const)
    also have "... = do {
      let (x,y) = input;
      a :: nat \<leftarrow> sample_uniform q;
      b \<leftarrow> map_spmf(\<lambda> b. b) (sample_uniform q);
      r :: nat \<leftarrow> sample_uniform q;
      a' :: nat \<leftarrow> sample_uniform q;
      b' :: nat \<leftarrow> sample_uniform q;
      r' :: nat \<leftarrow> sample_uniform q;
      return_spmf(x mod q, a, r, b, (x*(y-b') + (q - r')) mod q, ((x*y mod q - (x*(y-b') + (q - r')) mod q) mod q))}"
        by(simp add: samp_uni_minus_one_time_pad)
    also have "... = do {
      let (x,y) = input;
      a :: nat \<leftarrow> sample_uniform q;
      b \<leftarrow> sample_uniform q;
      r :: nat \<leftarrow> sample_uniform q;
      a' :: nat \<leftarrow> sample_uniform q;
      b' :: nat \<leftarrow> sample_uniform q;
      r' :: nat \<leftarrow> sample_uniform q;
      return_spmf(x mod q, a, r, b, (x*(y-b') + (q - r')) mod q, ((x*y mod q - (x*(y-b') + (q - r')) mod q) mod q))}"
        by(simp)
    also have "... = do {
      let (x,y) = input;
      a :: nat \<leftarrow> sample_uniform q;
      b \<leftarrow> sample_uniform q;
      r :: nat \<leftarrow> sample_uniform q;
      a' :: nat \<leftarrow> sample_uniform q;
      b' :: nat \<leftarrow> sample_uniform q;
      z \<leftarrow> map_spmf(\<lambda> r'.  (x*(y-b') + (q - r')) mod q) (sample_uniform q);
      return_spmf(x mod q, a, r, b, z, ((x*y mod q - z) mod q))}"
        by(simp add: map_spmf_conv_bind_spmf bind_spmf_const)
    also have "... = do {
      let (x,y) = input;
      a :: nat \<leftarrow> sample_uniform q;
      b \<leftarrow> sample_uniform q;
      r :: nat \<leftarrow> sample_uniform q;
      a' :: nat \<leftarrow> sample_uniform q;
      b' :: nat \<leftarrow> sample_uniform q;
      z \<leftarrow> map_spmf(\<lambda> r'.  r') (sample_uniform q);
      return_spmf(x mod q, a, r, b, z, ((x*y mod q - z) mod q))}"
        by(simp add: samp_uni_minus_one_time_pad)
    also have "... = do {
      let (x,y) = input;
      a :: nat \<leftarrow> sample_uniform q;
      b \<leftarrow> sample_uniform q;
      r :: nat \<leftarrow> sample_uniform q;
      z \<leftarrow> sample_uniform q;
      return_spmf(x mod q, a, r, b, z, ((x*y mod q - z) mod q))}"
        by(simp add: weight_1 1 bind_spmf_const)
    ultimately show ?thesis by(simp add: R1_def S1_def)
  qed
also have "S1 input n = do {
  let (x,y) = input;
  a' :: nat \<leftarrow> sample_uniform q;
  b' :: nat \<leftarrow> sample_uniform q;
  c' \<leftarrow> sample_uniform q;
  s1' \<leftarrow> sample_uniform q;
  return_spmf(x mod nat q, a', c', b', s1', (x*y mod q - s1') mod q)}"
  proof-
  have "S1 input n = do {
    let (x,y) = input;
    a' :: nat \<leftarrow> sample_uniform q;
    b' :: nat \<leftarrow> sample_uniform q;
    z \<leftarrow> map_spmf(\<lambda> c'. (x*b' + (q -c')) mod q) (sample_uniform q);
    s1' \<leftarrow> sample_uniform q;
    return_spmf(x mod nat q, a', z, b', s1', (x*y mod q - s1') mod q)}"
      by(simp add: S1_def map_spmf_conv_bind_spmf bind_spmf_const)
  also have "... = do {
    let (x,y) = input;
    a' :: nat \<leftarrow> sample_uniform q;
    b' :: nat \<leftarrow> sample_uniform q;
    z \<leftarrow> map_spmf(\<lambda> c'. c') (sample_uniform q);
    s1' \<leftarrow> sample_uniform q;
    return_spmf(x mod nat q, a', z, b', s1', (x*y mod q - s1') mod q)}"
      by(simp add: samp_uni_minus_one_time_pad)
  ultimately show ?thesis by(simp)
  qed
ultimately show ?thesis by(simp add: S1_def R1_def)
qed

lemma comp_indist_sec_1: assumes "q > 0" shows "comp_indist (R1) (S1)"
using inf_theoretic_1 assms unfolding comp_indist_def
by auto

(*Security for party 2*)

(*Construct views*)
definition R2 :: "(nat \<times> nat) \<Rightarrow> nat \<Rightarrow> (nat \<times> nat \<times> nat \<times> nat \<times> nat \<times> nat) spmf"
where "R2 input n = do {
  let (x,y) = input;
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  r :: nat \<leftarrow> sample_uniform q;
  a' :: nat \<leftarrow> sample_uniform q;
  b' :: nat \<leftarrow> sample_uniform q;
  r' :: nat \<leftarrow> sample_uniform q;
  return_spmf(y mod q, b, (a*b  + (q - r)) mod q, (x + a) mod q, (x*(y-b') + (q - r')) mod q, ((x*y mod q - (x*(y-b') + (q - r')) mod q) mod q))}"

definition  S2 :: "(nat \<times> nat) \<Rightarrow> nat \<Rightarrow> (nat \<times> nat \<times> nat \<times> nat \<times> nat \<times> nat) spmf"
where "S2 input n = do {
  let (x,y) = input;
  a' :: nat \<leftarrow> sample_uniform q;
  b' :: nat \<leftarrow> sample_uniform q;
  c' :: nat \<leftarrow> sample_uniform q;
  s1' :: nat \<leftarrow> sample_uniform q;
  return_spmf(y mod q, b', c', a', s1', (x*y mod q - s1') mod q)}"

(*Security is information theoretic*)
lemma inf_theoretic_2: assumes 1: "q > 0" shows "R2 input n = S2 input n"
proof-
have "R2 input n = do {
  let (x,y) = input;   a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  r \<leftarrow> map_spmf (\<lambda> r. (a*b  + (q - r)) mod q) (sample_uniform q);
  a' :: nat \<leftarrow> sample_uniform q;
  b' :: nat \<leftarrow> sample_uniform q;
  r' :: nat \<leftarrow> sample_uniform q;
  return_spmf(y mod q, b, r, (x + a) mod q, (x*(y-b') + (q - r')) mod q, ((x*y mod q - (x*(y-b') + (q - r')) mod q) mod q))}"
    by(simp add: R2_def map_spmf_conv_bind_spmf bind_spmf_const)
also have "... = do {
  let (x,y) = input;
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  r \<leftarrow> map_spmf (\<lambda> r. r) (sample_uniform q);
  a' :: nat \<leftarrow> sample_uniform q;
  b' :: nat \<leftarrow> sample_uniform q;
  r' :: nat \<leftarrow> sample_uniform q;
  return_spmf(y mod q, b, r, (x + a) mod q, (x*(y-b') + (q - r')) mod q, ((x*y mod q - (x*(y-b') + (q - r')) mod q) mod q))}"
    by(simp add: samp_uni_minus_one_time_pad)
also have "... = do {
  let (x,y) = input;
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  r ::nat \<leftarrow> (sample_uniform q);
  a' :: nat \<leftarrow> sample_uniform q;
  b' :: nat \<leftarrow> sample_uniform q;
  r' :: nat \<leftarrow> sample_uniform q;
  return_spmf(y mod q, b, r, (x + a) mod q, (x*(y-b') + (q - r')) mod q, ((x*y mod q - (x*(y-b') + (q - r')) mod q) mod q))}"
    by(simp)
also have "... = do {
  let (x,y) = input;
  a \<leftarrow> map_spmf(\<lambda> a. (x + a) mod q) (sample_uniform q);
  b :: nat \<leftarrow> sample_uniform q;
  r :: nat \<leftarrow> (sample_uniform q);
  a' :: nat \<leftarrow> sample_uniform q;
  b' :: nat \<leftarrow> sample_uniform q;
  r' :: nat \<leftarrow> sample_uniform q;
  return_spmf(y mod q, b, r, a, (x*(y-b') + (q - r')) mod q, ((x*y mod q - (x*(y-b') + (q - r')) mod q) mod q))}"
    by(simp add:map_spmf_conv_bind_spmf bind_spmf_const)
also have "... = do {
  let (x,y) = input;
  a \<leftarrow> map_spmf(\<lambda> a. a) (sample_uniform q);
  b :: nat \<leftarrow> sample_uniform q;
  r :: nat \<leftarrow> (sample_uniform q);
  a' :: nat \<leftarrow> sample_uniform q;
  b' :: nat \<leftarrow> sample_uniform q;
  r' :: nat \<leftarrow> sample_uniform q;
  return_spmf(y mod q, b, r, a, (x*(y-b') + (q - r')) mod q, ((x*y mod q - (x*(y-b') + (q - r')) mod q) mod q))}"
    by(simp add: samp_uni_plus_one_time_pad)
also have "... = do {
  let (x,y) = input;
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  r :: nat \<leftarrow> sample_uniform q;
  a' :: nat \<leftarrow> sample_uniform q;
  b' :: nat \<leftarrow> sample_uniform q;
  r' :: nat \<leftarrow> sample_uniform q;
  return_spmf(y mod q, b, r, a, (x*(y-b') + (q - r')) mod q, ((x*y mod q - (x*(y-b') + (q - r')) mod q) mod q))}"
    by(simp)
also have "... = do {
  let (x,y) = input;
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  r :: nat \<leftarrow> sample_uniform q;
  a' :: nat \<leftarrow> sample_uniform q;
  b' :: nat \<leftarrow> sample_uniform q;
  z \<leftarrow> map_spmf(\<lambda> r'.  (x*(y-b') + (q - r')) mod q) (sample_uniform q);
  return_spmf(y mod q, b, r, a, z, ((x*y mod q - z) mod q))}"
    by(simp add: map_spmf_conv_bind_spmf bind_spmf_const)
also have "... = do {
  let (x,y) = input;
  a :: nat \<leftarrow> sample_uniform q;
  b \<leftarrow> sample_uniform q;
  r :: nat \<leftarrow> sample_uniform q;
  a' :: nat \<leftarrow> sample_uniform q;
  b' :: nat \<leftarrow> sample_uniform q;
  z \<leftarrow> map_spmf(\<lambda> r'.  r') (sample_uniform q);
  return_spmf(y mod q, b, r, a, z, ((x*y mod q - z) mod q))}"
    by(simp add: samp_uni_minus_one_time_pad)
also have "... = do {
  let (x,y) = input;
  a :: nat \<leftarrow> sample_uniform q;
  b \<leftarrow> sample_uniform q;
  r :: nat \<leftarrow> sample_uniform q;
  z \<leftarrow> sample_uniform q;
  return_spmf(y mod q, b, r, a, z, ((x*y mod q - z) mod q))}"
    by(simp add: weight_1 1 bind_spmf_const)
ultimately show ?thesis by(simp add: R2_def S2_def)
qed

lemma comp_indist_sec_2: assumes "q > 0" shows "comp_indist (R2) (S2)"
using inf_theoretic_2 assms unfolding comp_indist_def
by auto

end


(*
    Title:      Echelon_Form_IArrays.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Echelon Form refined to immutable arrays\<close>

theory Echelon_Form_IArrays
imports
  Echelon_Form
  Gauss_Jordan.Gauss_Jordan_IArrays
begin

subsection\<open>The algorithm over immutable arrays\<close>

definition
  "bezout_matrix_iarrays A a b j bezout =
    tabulate2 (nrows_iarray A) (nrows_iarray A)
      (let (p, q, u, v, d) = bezout (A !! a !! j) (A !! b !! j)
        in (%x y. if x = a \<and> y = a then p else
              if x = a \<and> y = b then q else
              if x = b \<and> y = a then u else
              if x = b \<and> y = b then v else
              if x = y then 1 else 0))"

primrec
  bezout_iterate_iarrays :: "'a::{bezout_ring} iarray iarray \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat
                              \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'a \<times> 'a \<times> 'a \<times> 'a))
                              \<Rightarrow> 'a iarray iarray"
where "bezout_iterate_iarrays A 0 i j bezout = A"
      | "bezout_iterate_iarrays A (Suc n) i j bezout =
        (if (Suc n) \<le> i
          then A
          else bezout_iterate_iarrays (bezout_matrix_iarrays A i (Suc n) j bezout **i A) n i j bezout)"

definition
  "echelon_form_of_column_k_iarrays A' k =
    (let (A, i, bezout) =  A';
          nrows_A = nrows_iarray A;
          column_Ak = column_iarray k A;
          all_zero_below_i = vector_all_zero_from_index (i+1, column_Ak)
      in if i = nrows_A \<or> (A !! i !! k = 0) \<and> all_zero_below_i
            then (A, i, bezout) else
         if all_zero_below_i
            then (A, i + 1, bezout) else
                let n = least_non_zero_position_of_vector_from_index column_Ak i;
                    interchange_A = interchange_rows_iarray A i n
                in
          (bezout_iterate_iarrays interchange_A (nrows_A - 1) i k bezout, i + 1, bezout))"

definition "echelon_form_of_upt_k_iarrays A k bezout
  = fst (foldl echelon_form_of_column_k_iarrays (A,0,bezout) [0..<Suc k])"

definition "echelon_form_of_iarrays A bezout
  = echelon_form_of_upt_k_iarrays A (ncols_iarray A - 1) bezout"

subsection\<open>Properties\<close>

subsubsection\<open>Bezout Matrix for immutable arrays\<close>

lemma matrix_to_iarray_bezout_matrix:
  shows "matrix_to_iarray (bezout_matrix A a b j bezout)
  = bezout_matrix_iarrays (matrix_to_iarray A) (to_nat a) (to_nat b) (to_nat j) bezout"
  (is "?lhs = ?rhs")
proof -
  have n: "nrows_iarray (IArray (map (vec_to_iarray \<circ> ($) A \<circ> from_nat) [0..<CARD('b)]))
    = CARD('b)" unfolding nrows_iarray_def vec_to_iarray_def o_def by auto
  have rw1:"(map (\<lambda>x. IArray.of_fun
    (\<lambda>i. A $ from_nat x $ from_nat i) CARD('c)) [0..<CARD('b)] ! to_nat a !! to_nat j) = A $ a $ j"
    by (metis (erased, lifting) from_nat_to_nat_id length_upt minus_nat.diff_0 nth_map
      nth_upt of_fun_nth plus_nat.add_0 to_nat_less_card)
  have rw2: "(map (\<lambda>x. IArray.of_fun
    (\<lambda>i. A $ from_nat x $ from_nat i) CARD('c)) [0..<CARD('b)] ! to_nat b !! to_nat j) = (A $ b $ j)"
    by (metis (erased, lifting) from_nat_to_nat_id length_upt minus_nat.diff_0 nth_map
      nth_upt of_fun_nth plus_nat.add_0 to_nat_less_card)
  have rw3: "IArray (map (\<lambda>x. IArray.of_fun
    (\<lambda>i. A $ from_nat x $ from_nat i) CARD('c)) [0..<CARD('b)]) !! to_nat a !! to_nat j = A $ a $ j"
    by (metis IArray.sub_def list_of.simps rw1)
  have rw4: "IArray (map (\<lambda>x. IArray.of_fun
    (\<lambda>i. A $ from_nat x $ from_nat i) CARD('c)) [0..<CARD('b)]) !! to_nat b !! to_nat j = A $ b $ j"
    by (metis IArray.sub_def list_of.simps rw2)
  show ?thesis
    unfolding matrix_to_iarray_def bezout_matrix_iarrays_def tabulate2_def
    apply auto unfolding n apply (rule map_ext, auto simp add: bezout_matrix_def Let_def)
    unfolding o_def vec_to_iarray_def  Let_def
    unfolding IArray.sub_def[symmetric] rw1 rw2 rw3 rw4
    unfolding IArray.of_fun_def iarray.inject
    apply (rule map_ext) unfolding vec_lambda_beta
  proof
    fix x xa
    assume x: "x < CARD('b)"
    assume "xa \<in> set [0..<CARD('b)]"
    hence xa: "xa < CARD('b)" using atLeast_upt by blast
    have rw5: "(from_nat x = a) = (x = to_nat a)"
      using x from_nat_not_eq from_nat_to_nat_id by blast
    have rw6: "(from_nat x = b) = (x = to_nat b)"
        by (metis x from_nat_to_nat_id to_nat_from_nat_id)
    have rw7: "(from_nat xa = b) = (xa = to_nat b)"
        by (metis xa from_nat_to_nat_id to_nat_from_nat_id)
    have rw8: "((from_nat x::'b) = (from_nat xa::'b)) = (x = xa)"
        by (metis from_nat_not_eq x xa)
    have rw9: "(from_nat xa = a) = (xa = to_nat a)"
        by (metis from_nat_to_nat_id to_nat_from_nat_id xa)
    have cond01: "(from_nat x = a \<and> from_nat xa = a) == (x = to_nat a \<and> xa = to_nat a)"
      using rw5 rw9 by simp
    have cond02: "(from_nat x = a \<and> from_nat xa = b) == (x = to_nat a \<and> xa = to_nat b)"
      using rw5 rw7 by simp
    have cond03: "(from_nat x = b \<and> from_nat xa = a) == (x = to_nat b \<and> xa = to_nat a)"
      using rw6 rw9 by simp
    have cond04: "(from_nat x = b \<and> from_nat xa = b) == (x = to_nat b \<and> xa = to_nat b)"
      using rw6 rw7 by simp
    have cond05: "((from_nat x::'b) = (from_nat xa::'b)) == (x = xa)"
      using rw8 by simp
    show "(case bezout (A $ a $ j) (A $ b $ j) of
             (p, q, u, v, d) \<Rightarrow>
               if from_nat x = a \<and> from_nat xa = a then p
               else if from_nat x = a \<and> from_nat xa = b then q
                    else if from_nat x = b \<and> from_nat xa = a then u
                         else if from_nat x = b \<and> from_nat xa = b then v
                              else if (from_nat x::'b) = from_nat xa then 1 else 0) =
            (case bezout (A $ a $ j) (A $ b $ j) of
             (p, q, u, v, d) \<Rightarrow>
               \<lambda>x y. if x = to_nat a \<and> y = to_nat a then p
                     else if x = to_nat a \<and> y = to_nat b then q
                          else if x = to_nat b \<and> y = to_nat a then u
                               else if x = to_nat b \<and> y = to_nat b then v
                                    else if x = y then 1 else 0)
             x xa"
             proof (cases "bezout (A $ a $ j) (A $ b $ j)")
             fix p q u v d
             assume b: "bezout (A $ a $ j) (A $ b $ j) = (p, q, u, v, d)"
             show ?thesis
              unfolding b
              apply clarify
              unfolding cond01
              unfolding cond02
              unfolding cond03
              unfolding cond04
              unfolding cond05 by (rule refl)
    qed
  qed
qed

subsubsection\<open>Bezout Iterate for immutable arrays\<close>

lemma matrix_to_iarray_bezout_iterate:
  assumes n: "n<nrows A"
  shows "matrix_to_iarray (bezout_iterate A n i j bezout)
  = bezout_iterate_iarrays (matrix_to_iarray A) n (to_nat i) (to_nat j) bezout"
  using n
proof (induct n arbitrary: A)
  case 0
  thus ?case unfolding bezout_iterate_iarrays.simps bezout_iterate.simps by simp
next
  case (Suc n)
  show ?case
  proof (cases "Suc n \<le> to_nat i")
    case True
    show ?thesis
      unfolding bezout_iterate.simps bezout_iterate_iarrays.simps
      using True by auto
  next
    case False
    let ?B="(bezout_matrix_iarrays (matrix_to_iarray A) (to_nat i) (Suc n) (to_nat j) bezout
      **i matrix_to_iarray A)"
    let ?B2="matrix_to_iarray (bezout_matrix A i (from_nat (Suc n)) j bezout ** A)"
    have "matrix_to_iarray (bezout_iterate A (Suc n) i j bezout)
      = matrix_to_iarray (bezout_iterate (bezout_matrix A i (from_nat (Suc n)) j bezout ** A) n i j bezout)"
      unfolding bezout_iterate.simps using False by auto
    also have "... = bezout_iterate_iarrays ?B2 n (to_nat i) (to_nat j) bezout"
    proof (rule Suc.hyps)
      show "n < nrows (bezout_matrix A i (from_nat (Suc n)) j bezout ** A)"
        using Suc.prems unfolding nrows_def by simp
    qed
    also have "... = bezout_iterate_iarrays ?B n (to_nat i) (to_nat j) bezout"
      unfolding matrix_to_iarray_matrix_matrix_mult
      unfolding matrix_to_iarray_bezout_matrix[of A i "from_nat (Suc n)" j bezout]
      unfolding to_nat_from_nat_id[OF Suc.prems[unfolded nrows_def]] ..
    also have "... = bezout_iterate_iarrays (matrix_to_iarray A) (Suc n) (to_nat i) (to_nat j) bezout"
      unfolding bezout_iterate_iarrays.simps using False by auto
    finally show ?thesis .
  qed
qed

lemma matrix_vector_all_zero_from_index2:
  fixes A::"'a::{zero}^'columns::{mod_type}^'rows::{mod_type}"
  shows "(\<forall>m>i. A $ m $ k = 0) = vector_all_zero_from_index ((to_nat i)+1, vec_to_iarray (column k A))"
proof (cases "to_nat i = nrows A - 1")
  case True
  have "(\<forall>m>i. A $ m $ k = 0) = True"
    by (metis One_nat_def Suc_pred True not_less_eq nrows_def to_nat_0 to_nat_less_card to_nat_mono)
  also have "... = vector_all_zero_from_index ((to_nat i)+1, vec_to_iarray (column k A))"
    unfolding vector_all_zero_from_index_def Let_def
    unfolding vec_to_iarray_def column_def
    by (auto, metis True nrows_def One_nat_def Suc_pred not_le zero_less_card_finite)
  finally show ?thesis .
next
  case False
  have i_le: "i<i+1"
    by (metis False Suc_le' add_diff_cancel_right' nrows_def suc_not_zero)
  hence "(\<forall>m>i. A $ m $ k = 0) = (\<forall>m\<ge>i+1. A $ m $ k = 0)" using i_le le_Suc by auto
  also have "... = vector_all_zero_from_index ((to_nat i)+1, vec_to_iarray (column k A))"
    unfolding matrix_vector_all_zero_from_index
    by (metis (mono_tags, hide_lams) from_nat_suc from_nat_to_nat_id i_le not_less0
      to_nat_0 to_nat_from_nat_id to_nat_mono to_nat_plus_one_less_card)
  finally show ?thesis .
qed

subsubsection\<open>Echelon form of column k for immutable arrays\<close>

lemma matrix_to_iarray_echelon_form_of_column_k:
  fixes A::"'a::{bezout_ring}^'cols::{mod_type}^'rows::{mod_type}"
  assumes k: "k<ncols A"
  and i: "i\<le>nrows A"
  shows "matrix_to_iarray (fst ((echelon_form_of_column_k bezout) (A,i) k))
  = fst (echelon_form_of_column_k_iarrays (matrix_to_iarray A, i, bezout) k)"
proof (cases "i<nrows A")
  case False
  have i_eq: "i=nrows A" by (metis False le_imp_less_or_eq i)
  show "matrix_to_iarray (fst ((echelon_form_of_column_k bezout) (A,i) k))
    = fst (echelon_form_of_column_k_iarrays (matrix_to_iarray A, i, bezout) k)"
    unfolding echelon_form_of_column_k_efficient echelon_form_of_column_k_def Let_def
    unfolding echelon_form_of_column_k_iarrays_def Let_def snd_conv fst_conv
    unfolding matrix_to_iarray_nrows
    unfolding i_eq matrix_to_iarray_nrows by auto
next
  case True
  let ?interchange="(interchange_rows A (from_nat i)
    (LEAST n. A $ n $ from_nat k \<noteq> 0 \<and> from_nat i \<le> n))"
  have all_zero: "(\<forall>m\<ge>mod_type_class.from_nat i. A $ m $ mod_type_class.from_nat k = 0)
    = vector_all_zero_from_index (i, column_iarray k (matrix_to_iarray A))"
    unfolding matrix_vector_all_zero_from_index
    unfolding to_nat_from_nat_id[OF True[unfolded nrows_def]]
    unfolding vec_to_iarray_column'[OF k] ..
  have all_zero2: " (\<forall>m>from_nat i. A $ m $ mod_type_class.from_nat k = 0)
    = (vector_all_zero_from_index (i + 1, column_iarray k (matrix_to_iarray A)))"
    unfolding matrix_vector_all_zero_from_index2
    unfolding to_nat_from_nat_id[OF True[unfolded nrows_def]]
    unfolding vec_to_iarray_column'[OF k] ..
  have n: "(nrows_iarray (matrix_to_iarray A) - Suc 0) < nrows ?interchange"
    unfolding matrix_to_iarray_nrows[symmetric]
    unfolding nrows_def by simp
  show ?thesis
    using True
    unfolding echelon_form_of_column_k_efficient echelon_form_of_column_k_def Let_def split_beta
    unfolding echelon_form_of_column_k_iarrays_def Let_def snd_conv fst_conv
    unfolding matrix_to_iarray_nrows
    unfolding all_zero all_zero2 apply auto
    unfolding matrix_to_iarray_bezout_iterate[OF n]
    unfolding matrix_to_iarray_interchange_rows
    using vec_to_iarray_least_non_zero_position_of_vector_from_index'[of "from_nat i" "from_nat k" A]
    unfolding to_nat_from_nat_id[OF True[unfolded nrows_def]]
    unfolding to_nat_from_nat_id[OF k[unfolded ncols_def]]
    unfolding vec_to_iarray_column'[OF k]
    by (auto, metis Suc_eq_plus1 all_zero all_zero2 less_le)
qed

lemma snd_matrix_to_iarray_echelon_form_of_column_k:
  fixes A::"'a::{bezout_ring}^'cols::{mod_type}^'rows::{mod_type}"
  assumes k: "k<ncols A"
  and i: "i\<le>nrows A"
  shows "snd ((echelon_form_of_column_k bezout) (A,i) k)
  = fst (snd (echelon_form_of_column_k_iarrays (matrix_to_iarray A, i, bezout) k))"
proof (cases "i<nrows A")
  case False
  have i_eq: "i=nrows A" by (metis False le_imp_less_or_eq i)
  show "snd ((echelon_form_of_column_k bezout) (A,i) k)
    = fst (snd (echelon_form_of_column_k_iarrays (matrix_to_iarray A, i, bezout) k))"
    unfolding echelon_form_of_column_k_efficient echelon_form_of_column_k_def Let_def
    unfolding echelon_form_of_column_k_iarrays_def Let_def snd_conv fst_conv
    unfolding i_eq matrix_to_iarray_nrows by auto
next
  case True
  let ?interchange="(interchange_rows A (from_nat i)
    (LEAST n. A $ n $ from_nat k \<noteq> 0 \<and> from_nat i \<le> n))"
  have all_zero: "(\<forall>m\<ge>mod_type_class.from_nat i. A $ m $ mod_type_class.from_nat k = 0)
    = vector_all_zero_from_index (i, column_iarray k (matrix_to_iarray A))"
    unfolding matrix_vector_all_zero_from_index
    unfolding to_nat_from_nat_id[OF True[unfolded nrows_def]]
    unfolding vec_to_iarray_column'[OF k] ..
  have all_zero2: " (\<forall>m>from_nat i. A $ m $ mod_type_class.from_nat k = 0)
    = (vector_all_zero_from_index (i + 1, column_iarray k (matrix_to_iarray A)))"
    unfolding matrix_vector_all_zero_from_index2
    unfolding to_nat_from_nat_id[OF True[unfolded nrows_def]]
    unfolding vec_to_iarray_column'[OF k] ..
    have Aik: "A $ from_nat i $ from_nat k = matrix_to_iarray A !! i !! k"
      by (metis True k matrix_to_iarray_nth ncols_def nrows_def to_nat_from_nat_id)
  show ?thesis
    using True Aik
    unfolding echelon_form_of_column_k_efficient
    unfolding echelon_form_of_column_k_efficient_def Let_def split_beta
    unfolding echelon_form_of_column_k_iarrays_def Let_def snd_conv fst_conv
    unfolding all_zero all_zero2
    unfolding matrix_to_iarray_nrows by auto
qed

corollary fst_snd_matrix_to_iarray_echelon_form_of_column_k:
  fixes A::"'a::{bezout_ring}^'cols::{mod_type}^'rows::{mod_type}"
  assumes k: "k<ncols A"
  and i: "i\<le>nrows A"
  shows "snd ((echelon_form_of_column_k bezout) (A,i) k)
  = fst (snd (echelon_form_of_column_k_iarrays (matrix_to_iarray A, i, bezout) k))"
  using snd_matrix_to_iarray_echelon_form_of_column_k[OF assms] by simp

subsubsection\<open>Echelon form up to column k for immutable arrays\<close>

lemma snd_snd_foldl_echelon_form_of_column_k_iarrays:
  "snd (snd (foldl echelon_form_of_column_k_iarrays (matrix_to_iarray A, 0, bezout) [0..<k]))
  = bezout"
proof (induct k)
  case 0 thus ?case by auto
next
  case (Suc k)
  show ?case
    using Suc.hyps
    unfolding echelon_form_of_column_k_iarrays_def
    unfolding Let_def unfolding split_beta by auto
qed

lemma foldl_echelon_form_column_k_eq:
  fixes A::"'a::{bezout_ring}^'cols::{mod_type}^'rows::{mod_type}"
  assumes k: "k<ncols A"
  shows matrix_to_iarray_echelon_form_of_upt_k[code_unfold]:
  "matrix_to_iarray (echelon_form_of_upt_k A k bezout)
  = echelon_form_of_upt_k_iarrays (matrix_to_iarray A) k bezout"
  and fst_foldl_ef_k_eq: "fst (snd (foldl echelon_form_of_column_k_iarrays
  (matrix_to_iarray A,0,bezout) [0..<Suc k]))
  = snd (foldl (echelon_form_of_column_k bezout) (A,0) [0..<Suc k])"
  and fst_foldl_ef_k_less:
  "snd (foldl (echelon_form_of_column_k bezout) (A,0) [0..<Suc k]) \<le> nrows A"
  using assms
proof (induct k)
  show "matrix_to_iarray (echelon_form_of_upt_k A 0 bezout)
    = echelon_form_of_upt_k_iarrays (matrix_to_iarray A) 0 bezout"
    unfolding echelon_form_of_upt_k_def echelon_form_of_upt_k_iarrays_def
    by (simp, metis le0 matrix_to_iarray_echelon_form_of_column_k ncols_not_0 neq0_conv)
  show "fst (snd (foldl echelon_form_of_column_k_iarrays (matrix_to_iarray A, 0, bezout) [0..<Suc 0]))
    = snd (foldl (echelon_form_of_column_k bezout) (A, 0) [0..<Suc 0])"
    by (simp, metis le0 ncols_not_0 not_gr0 snd_matrix_to_iarray_echelon_form_of_column_k)
  show "snd (foldl (echelon_form_of_column_k bezout) (A, 0) [0..<Suc 0]) \<le> nrows A"
    apply simp
    unfolding echelon_form_of_column_k_def Let_def snd_conv fst_conv
    unfolding nrows_def by auto
next
  fix k
  assume "(k < ncols A \<Longrightarrow> matrix_to_iarray (echelon_form_of_upt_k A k bezout)
    = echelon_form_of_upt_k_iarrays (matrix_to_iarray A) k bezout)"
    and  "(k < ncols A \<Longrightarrow>
    fst (snd (foldl echelon_form_of_column_k_iarrays (matrix_to_iarray A, 0, bezout) [0..<Suc k])) =
    snd (foldl (echelon_form_of_column_k bezout) (A, 0) [0..<Suc k]))"
    and hyp3: "(k < ncols A \<Longrightarrow> snd (foldl (echelon_form_of_column_k bezout) (A, 0) [0..<Suc k]) \<le> nrows A)"
    and Suc_k_less_card: "Suc k < ncols A"
  hence hyp1: "matrix_to_iarray (echelon_form_of_upt_k A k bezout)
    = echelon_form_of_upt_k_iarrays (matrix_to_iarray A) k bezout"
    and hyp2: "fst (snd (foldl echelon_form_of_column_k_iarrays
    (matrix_to_iarray A, 0, bezout) [0..<Suc k]))
    = snd (foldl (echelon_form_of_column_k bezout) (A, 0) [0..<Suc k])"
    and hyp3: "snd (foldl (echelon_form_of_column_k bezout) (A, 0) [0..<Suc k]) \<le> nrows A"
    by auto
  hence hyp1_unfolded: "matrix_to_iarray (fst (foldl (echelon_form_of_column_k bezout) (A,0) [0..<Suc k]))
    = fst (foldl echelon_form_of_column_k_iarrays (matrix_to_iarray A,0,bezout) [0..<Suc k])"
    using hyp1 unfolding echelon_form_of_upt_k_def echelon_form_of_upt_k_iarrays_def by simp
  have upt_rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [(Suc k)]" by auto
  let ?f = "foldl echelon_form_of_column_k_iarrays (matrix_to_iarray A, 0, bezout) [0..<Suc k]"
  let ?f2 = "foldl (echelon_form_of_column_k bezout) (A,0) [0..<(Suc k)]"
  have fold_rw: "?f = (fst ?f, fst (snd ?f), snd (snd ?f))" by simp
  have fold_rw': "?f2 = (fst ?f2, snd ?f2)" by simp
  have rw: "snd (foldl (echelon_form_of_column_k bezout) (A, 0) [0..<Suc k])
    = fst (snd (foldl echelon_form_of_column_k_iarrays (matrix_to_iarray A, 0, bezout) [0..<Suc k]))"
    using hyp2 by auto
  show "fst (snd (foldl echelon_form_of_column_k_iarrays (matrix_to_iarray A, 0, bezout)
    [0..<Suc (Suc k)])) = snd (foldl (echelon_form_of_column_k bezout) (A, 0) [0..<Suc (Suc k)])"
    unfolding upt_rw foldl_append unfolding List.foldl.simps apply (subst fold_rw)
    apply (subst fold_rw') unfolding hyp2 unfolding hyp1_unfolded[symmetric]
    unfolding rw
    unfolding snd_snd_foldl_echelon_form_of_column_k_iarrays
    proof (rule fst_snd_matrix_to_iarray_echelon_form_of_column_k [symmetric])
      show "Suc k < ncols (fst ?f2)" using Suc_k_less_card unfolding ncols_def .
      show "fst (snd (foldl echelon_form_of_column_k_iarrays (matrix_to_iarray A, 0, bezout) [0..<Suc k]))
    \<le> nrows (fst (foldl (echelon_form_of_column_k bezout) (A, 0) [0..<Suc k]))"
      by (metis hyp2 hyp3 nrows_def)
  qed
  show "matrix_to_iarray (echelon_form_of_upt_k A (Suc k) bezout)
    = echelon_form_of_upt_k_iarrays (matrix_to_iarray A) (Suc k) bezout"
    unfolding echelon_form_of_upt_k_def echelon_form_of_upt_k_iarrays_def
      upt_rw foldl_append List.foldl.simps apply (subst fold_rw) apply (subst fold_rw')
    unfolding hyp2 hyp1_unfolded[symmetric]
    unfolding rw
    unfolding snd_snd_foldl_echelon_form_of_column_k_iarrays
  proof (rule matrix_to_iarray_echelon_form_of_column_k)
    show "Suc k < ncols (fst ?f2)" using Suc_k_less_card unfolding ncols_def .
    show "fst (snd (foldl echelon_form_of_column_k_iarrays (matrix_to_iarray A, 0, bezout) [0..<Suc k]))
    \<le> nrows (fst (foldl (echelon_form_of_column_k bezout) (A, 0) [0..<Suc k]))"
    by (metis hyp2 hyp3 nrows_def)
  qed
  show "snd (foldl (echelon_form_of_column_k bezout) (A, 0) [0..<Suc (Suc k)]) \<le> nrows A"
    using [[unfold_abs_def = false]]
    unfolding upt_rw foldl_append unfolding List.foldl.simps apply (subst fold_rw')
    unfolding echelon_form_of_column_k_def Let_def
    using hyp3 le_antisym not_less_eq_eq unfolding nrows_def by fastforce
qed

subsubsection\<open>Echelon form up to column k for immutable arrays\<close>

lemma matrix_to_iarray_echelon_form_of[code_unfold]:
  "matrix_to_iarray (echelon_form_of A bezout)
    = echelon_form_of_iarrays (matrix_to_iarray A) bezout"
  unfolding echelon_form_of_def echelon_form_of_iarrays_def
  by (metis (poly_guards_query) One_nat_def diff_less lessI matrix_to_iarray_echelon_form_of_upt_k
    ncols_def ncols_eq_card_columns zero_less_card_finite)

end


theory mk_mfun
  imports mapp
begin

declare [[names_short = true]]

context Function_Model begin

definition mFunMem :: \<open>'a \<Rightarrow> bool\<close>
  where "mFunMem b \<equiv> m\<exists>f : mFunc. m\<exists>c. mapp f b c \<or> mapp f c b"

lemma mfmemI :
  assumes f : "f : mFunc"
      and "mapp f b c \<or> mapp f c b"
    shows "b : mFunMem"
  using assms mfunc_m mapp_m
  unfolding mFunMem_def has_ty_def mtex_def mex_def tex_def by blast

lemma mfmemE :
  assumes "b : mFunMem"
  obtains f c
    where "f : mFunc" "mapp f b c \<or> mapp f c b"
  using assms
  unfolding mFunMem_def has_ty_def mtex_def mex_def tex_def by blast

lemma mfmem_m :
  assumes b : "b : mFunMem"
    shows "b : M"
  by (rule mfmemE[OF b], use mapp_m in auto)

lemma mfmem_fmem :
  assumes b : "b : mFunMem"
  shows "b : FunMem"
proof (rule mfmemE[OF b])
  fix f c assume
    f : "f : mFunc" and
    bc : "mapp f b c \<or> mapp f c b"
  hence
    "snd f : Function"
    "app (snd f) b c \<or> app (snd f) c b"
    using mfunc_snd_func mappD by auto
  thus "b : FunMem"
    using funmemI1 funmemI2 by auto
qed

lemma mfmem_ex :
  assumes b : "b : mFunMem"
  shows "\<not> Excluded func b"
proof (rule mfmemE[OF b])
  fix f c assume
    f : "f : mFunc" and mapp : "mapp f b c \<or> mapp f c b"
  then obtain f' j where
    f' : "f' : Function" and "f = <func, f'>"
    "j : Ord" and dom_ran : "dom f' \<subseteq> Tier j \<ominus> func" "ran f' \<subseteq> Tier j \<ominus> func"
    using mfuncE2 by auto
  hence "app f' b c \<or> app f' c b"
    using mapp mappD_pair f by auto
  hence "b \<in> dom f' \<or> b \<in> ran f'"
    using domI[OF f'] ranI[OF f'] by auto
  thus "\<not> Excluded func b"
    using exsetD2[OF tier_set[OF \<open>j : Ord\<close>]] dom_ran by auto
qed

lemma ex_mfmem :
  assumes b : "b : M" and b_ex : "\<not> Excluded func b"
      and b_fmem : "b : FunMem"
  shows "b : mFunMem"
proof (rule mfmemI[of \<open><func, \<lambda>c\<in>{b}. c>\<close>])
  let ?f = "<func, \<lambda>c\<in>{b}. c>"
  from b obtain j where
    j:"j : Ord" and bx:"b \<in> Tier j"
    using mE by auto
   hence
    b_smem : "b : SetMem" and sng_fmem :"{b} : SetOf FunMem"
    using setmemI[OF tier_set[OF j] bx] sng_setof[OF _ b_fmem] by auto
  hence sng_lam_fun: "(\<lambda>c\<in>{b}. c) : Function"
    using lam_fun[OF sng_set[OF b_smem]] by auto
  hence memfun:"(\<lambda>c. c) : {b} \<leadsto> FunMem"
    using mem_funI setof_mem[OF sng_fmem] by auto
  hence dom_ran :"dom (\<lambda>c\<in>{b}. c) = {b}" "ran (\<lambda>c\<in>{b}. c) = {c | c \<in> {b}}"
    using lam_dom[OF sng_fmem] lam_ran[OF sng_fmem]
    by auto
  have "dom (\<lambda>c\<in>{b}. c) \<subseteq> Tier j \<ominus> func" "ran (\<lambda>c\<in>{b}. c) \<subseteq> Tier j \<ominus> func"
    unfolding dom_ran Subset_def
    using repfunE[OF sng_set[OF b_smem]] sng_iff[OF b_smem] bx
      exsetI[OF tier_set[OF j] _ b_ex] by (metis, metis)
  thus f:"?f : mFunc"
    using mfuncI[OF mI_mfunc[OF j sng_lam_fun]] by auto
  show "mapp \<langle>func,\<lambda>c\<in>{b}. c\<rangle> b b \<or> mapp \<langle>func,\<lambda>c\<in>{b}. c\<rangle> b b"
    unfolding mapp_def mfunc_snd_eq[OF f]
     lam_iff[OF sng_set[OF b_smem]] sng_iff[OF b_smem]
    using b_fmem by auto
qed

definition mFunPred :: \<open>['a, ['a,'a] \<Rightarrow> bool] \<Rightarrow> bool\<close>
  where "mFunPred x P \<equiv> m\<forall>b : mFunMem. b m x \<longrightarrow> (m\<exists>\<^sub>\<le>\<^sub>1 c : mFunMem. P b c)"

lemma mfpred_fpred :
  assumes x : "x : mSet" and P : "P : mFunPred x"
    shows "(\<lambda>a b. P a b \<and> a : mFunMem \<and> b : mFunMem) : FunPred (snd x)"
proof (rule funpredI, unfold tuniq_def, rule, auto)
  fix b c d assume
    b : "b : FunMem" "b : mFunMem" and "b \<in> snd x" and
    c : "c : FunMem" "c : mFunMem" "P b c" and
    d : "d : FunMem" "d : mFunMem" "P b d"
  hence "b m x"
    using x unfolding mMem_def
    by auto
  hence "m\<exists>\<^sub>\<le>\<^sub>1 c : mFunMem. P b c"
    using P  mmem_m b
    unfolding mFunPred_def has_ty_def mtall_def mall_def tall_def by auto
  thus "c = d"
    using c d mfmem_m
    unfolding mtuniq_def muniq_def tuniq_def Uniq_def by blast
qed

definition mk_mfun' :: \<open>['a, ['a,'a] \<Rightarrow> bool] \<Rightarrow> 'a\<close>
  where "mk_mfun' x P \<equiv> <func, mkfun (snd x) (\<lambda>a b. P a b \<and> a : mFunMem \<and> b : mFunMem)>"

definition mk_mfun :: \<open>['a, ['a,'a] \<Rightarrow> bool] \<Rightarrow> 'a\<close>
  where "mk_mfun x P \<equiv> if x : mSet \<and> P : mFunPred x
                       then mk_mfun' x P
                       else Function_Model_mdefault"

lemma mk_mfun_eq :
  assumes "x : mSet" "P : mFunPred x"
  shows "mk_mfun x P = <func, mkfun (snd x) (\<lambda>a b. P a b \<and> a : mFunMem \<and> b : mFunMem)>"
  using assms
  unfolding mk_mfun_def mk_mfun'_def
  by auto

lemma mk_mfun_typ :
  "mk_mfun : (\<Pi> x : mSet. mFunPred x \<rightarrow> mFunc)"
proof (rule depfunI, rule funI, unfold mk_mfun_eq, rule mfuncI)
  fix x P assume
    x : "x : mSet" and P : "P : mFunPred x"
  define P' where "P' \<equiv> (\<lambda>a b. P a b \<and> a : mFunMem \<and> b : mFunMem)"
  let ?f = "mkfun (snd x) P'"
  have x' : "snd x : Set" and P' : "P' : FunPred (snd x)"
    unfolding P'_def
    using mset_snd_set[OF x] mfpred_fpred[OF x P] by auto
  hence f:"?f : Function"
    using mkfun_fun by auto
  hence app:"\<And>b c. app ?f b c \<Longrightarrow> b : mFunMem \<and> c : mFunMem"
    using mkfun_iff[OF x' P']
    unfolding P'_def by auto
  hence "dom ?f : SetOf M" and "ran ?f : SetOf M"
    using setofI[OF dom_set[OF f]] setofI[OF ran_set[OF f]]
          domE[OF f] ranE[OF f] mfmem_m by (meson, meson)
  then obtain i j where
    i : "i : Ord" and "dom ?f \<subseteq> Tier i" and
    j : "j : Ord" and "ran ?f \<subseteq> Tier j"
    using setof_m_tier by metis
  then obtain k where
    k : "k : Ord" and dom_ran :
    "dom ?f \<subseteq> Tier k" "ran ?f \<subseteq> Tier k"
    using linear_leq[OF i j] tier_increasing_leq[OF i j] tier_increasing_leq[OF j i]
          subset_trans by meson
  hence "dom ?f \<subseteq> Tier k \<ominus> func" "ran ?f \<subseteq> Tier k \<ominus> func"
    using domE[OF f] ranE[OF f] app
          exsetI[OF tier_set[OF k] _ mfmem_ex]
    unfolding Subset_def by (meson, meson)
  thus "<func, mkfun (snd x) (\<lambda>a b. P a b \<and> a : mFunMem \<and> b : mFunMem)> : M"
    using mI_mfunc[OF k f]
    unfolding P'_def by auto
qed

lemmas mk_mfun_mfunc = funE[OF depfunE[OF mk_mfun_typ]]

lemma mk_mfun_typ_ax :
  "m\<forall>x. x : mSet \<longrightarrow> (\<forall>P. P : mFunPred x \<longrightarrow> mk_mfun x P : mFunc)"
  using mk_mfun_mfunc
  unfolding mall_def tall_def by auto

lemma mk_mfun_iff :
  assumes x : "x : mSet"
      and P : "P : mFunPred x"
    shows "mapp (mk_mfun x P) b c \<longleftrightarrow>
      (b m x \<and> P b c \<and> b : mFunMem \<and> c : mFunMem)"
proof -
  define P' where "P' \<equiv> (\<lambda>a b. P a b \<and> a : mFunMem \<and> b : mFunMem)"
  from mk_mfun_mfunc[OF x P] have
    f : "mk_mfun x P : mFunc" .
  have x':"snd x : Set" and P':"P' : FunPred (snd x)"
    using mset_snd_set[OF x] mfpred_fpred[OF x P]
    unfolding P'_def by auto
  hence "mkfun (snd x) P' : Function"
    using mkfun_fun by auto

  show ?thesis
  proof (auto)
    assume "mapp (mk_mfun x P) b c"
    hence "app (mkfun (snd x) P') b c"
      using mfunc_snd_eq f
      unfolding mapp_def mk_mfun_eq[OF x P] P'_def
      by auto
    thus "b m x" "P b c" "b : mFunMem" "c : mFunMem"
      using mkfun_iff[OF x' P'] x
      unfolding P'_def mMem_def by auto
  next
    assume "b m x" "P b c" "b : mFunMem" "c : mFunMem"
    hence "app (mkfun (snd x) P') b c"
      using mkfun_iff[OF x' P'] mfmem_fmem
      unfolding P'_def mMem_def by auto
    thus "mapp (mk_mfun x P) b c"
      using mfunc_snd_eq f
      unfolding mapp_def mk_mfun_eq[OF x P] P'_def
      by auto
  qed
qed

lemma mk_mfun_ax :
  "m\<forall>s : mSet. \<forall>P : mFunPred s. m\<forall>x y.
    mapp (mk_mfun s P) x y \<longleftrightarrow> (x m s \<and> P x y \<and> x : mFunMem \<and> y : mFunMem)"
  unfolding mtall_def mall_def tall_def
  using mk_mfun_iff by auto

lemma mk_mfun_cong' :
  assumes x : "x : mSet"
      and P : "P : mFunPred x"
      and Q : "Q : mFunPred x"
      and iff : "\<And>a b. a : M \<Longrightarrow> b : M \<Longrightarrow> P a b \<longleftrightarrow> Q a b"
    shows "mk_mfun' x P = mk_mfun' x Q"
    unfolding mk_mfun'_def mk_mfun'_def
proof (rule pair_eqI[OF refl])
  have x' : "snd x : Set" and
       P' : "(\<lambda>a b. P a b \<and> a : mFunMem \<and> b : mFunMem) : FunPred (snd x)" and
       Q' : "(\<lambda>a b. Q a b \<and> a : mFunMem \<and> b : mFunMem) : FunPred (snd x)"
    using mset_snd_set[OF x] mfpred_fpred[OF x P] mfpred_fpred[OF x Q] by auto
  show "mkfun (\<pi> x) (\<lambda>a b. P a b \<and> a : mFunMem \<and> b : mFunMem) =
        mkfun (\<pi> x) (\<lambda>a b. Q a b \<and> a : mFunMem \<and> b : mFunMem)"
  by (rule fun_eqI[OF mkfun_fun[OF x' P'] mkfun_fun[OF x' Q']],
      unfold mkfun_iff[OF x' P'] mkfun_iff[OF x' Q'], use mfmem_m iff in auto)
qed

lemma mk_mfun_m :
  "mk_mfun x P : M"
  using mfunc_m[OF mk_mfun_mfunc] Function_Model_mdefault_m
  unfolding mk_mfun_def by auto

lemma mfpred_cong :
  assumes "\<And>a b. a : M \<Longrightarrow> b : M \<Longrightarrow> P a b = Q a b"
  shows "mFunPred x P = mFunPred x Q"
  using assms  unfolding mFunPred_def has_ty_def
      mtuniq_def muniq_def tuniq_def Uniq_def
      mtall_def mall_def tall_def by blast

lemma mk_mfun_cong :
  assumes iff:"\<And>a b. a : M \<Longrightarrow> b : M \<Longrightarrow> P a b \<longleftrightarrow> Q a b"
    shows "mk_mfun x P = mk_mfun x Q"
proof -
  have pq:"P : mFunPred x \<longleftrightarrow> Q : mFunPred x"
    using mfpred_cong iff
    unfolding has_ty_def by blast
  thus ?thesis
    unfolding mk_mfun_def
    using mk_mfun_cong' iff by auto
qed

theorem mk_mfun_rsp :
  assumes "x : M" and iff : "\<And>x y. x : M \<Longrightarrow> y : M \<Longrightarrow> P x y \<longleftrightarrow> Q x y"
  shows "mk_mfun x P : M \<and> (mk_mfun x P = mk_mfun x Q)"
  using mk_mfun_m mk_mfun_cong iff by blast

end
end


(*  Title:      HOL/UNITY/Guar.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Author:     Sidi Ehmety

From Chandy and Sanders, "Reasoning About Program Composition",
Technical Report 2000-003, University of Florida, 2000.

Compatibility, weakest guarantees, etc.  and Weakest existential
property, from Charpentier and Chandy "Theorems about Composition",
Fifth International Conference on Mathematics of Program, 2000.
*)

section\<open>Guarantees Specifications\<close>

theory Guar
imports Comp
begin

instance program :: (type) order
  by standard (auto simp add: program_less_le dest: component_antisym intro: component_trans)

text\<open>Existential and Universal properties.  I formalize the two-program
      case, proving equivalence with Chandy and Sanders's n-ary definitions\<close>

definition ex_prop :: "'a program set => bool" where
   "ex_prop X == \<forall>F G. F ok G -->F \<in> X | G \<in> X --> (F\<squnion>G) \<in> X"

definition strict_ex_prop  :: "'a program set => bool" where
   "strict_ex_prop X == \<forall>F G.  F ok G --> (F \<in> X | G \<in> X) = (F\<squnion>G \<in> X)"

definition uv_prop  :: "'a program set => bool" where
   "uv_prop X == SKIP \<in> X & (\<forall>F G. F ok G --> F \<in> X & G \<in> X --> (F\<squnion>G) \<in> X)"

definition strict_uv_prop  :: "'a program set => bool" where
   "strict_uv_prop X ==
      SKIP \<in> X & (\<forall>F G. F ok G --> (F \<in> X & G \<in> X) = (F\<squnion>G \<in> X))"

text\<open>Guarantees properties\<close>

definition guar :: "['a program set, 'a program set] => 'a program set" (infixl "guarantees" 55) where
          (*higher than membership, lower than Co*)
   "X guarantees Y == {F. \<forall>G. F ok G --> F\<squnion>G \<in> X --> F\<squnion>G \<in> Y}"

  (* Weakest guarantees *)
definition wg :: "['a program, 'a program set] => 'a program set" where
  "wg F Y == \<Union>({X. F \<in> X guarantees Y})"

   (* Weakest existential property stronger than X *)
definition wx :: "('a program) set => ('a program)set" where
   "wx X == \<Union>({Y. Y \<subseteq> X & ex_prop Y})"

  (*Ill-defined programs can arise through "Join"*)
definition welldef :: "'a program set" where
  "welldef == {F. Init F \<noteq> {}}"

definition refines :: "['a program, 'a program, 'a program set] => bool"
                        ("(3_ refines _ wrt _)" [10,10,10] 10) where
  "G refines F wrt X ==
     \<forall>H. (F ok H & G ok H & F\<squnion>H \<in> welldef \<inter> X) -->
         (G\<squnion>H \<in> welldef \<inter> X)"

definition iso_refines :: "['a program, 'a program, 'a program set] => bool"
                              ("(3_ iso'_refines _ wrt _)" [10,10,10] 10) where
  "G iso_refines F wrt X ==
   F \<in> welldef \<inter> X --> G \<in> welldef \<inter> X"

lemma OK_insert_iff:
     "(OK (insert i I) F) =
      (if i \<in> I then OK I F else OK I F & (F i ok JOIN I F))"
by (auto intro: ok_sym simp add: OK_iff_ok)

subsection\<open>Existential Properties\<close>

lemma ex1:
  assumes "ex_prop X" and "finite GG"
  shows "GG \<inter> X \<noteq> {} \<Longrightarrow> OK GG (%G. G) \<Longrightarrow> (\<Squnion>G \<in> GG. G) \<in> X"
  apply (atomize (full))
  using assms(2) apply induct
   using assms(1) apply (unfold ex_prop_def)
   apply (auto simp add: OK_insert_iff Int_insert_left)
  done

lemma ex2:
     "\<forall>GG. finite GG & GG \<inter> X \<noteq> {} \<longrightarrow> OK GG (\<lambda>G. G) \<longrightarrow> (\<Squnion>G \<in> GG. G) \<in> X
      \<Longrightarrow> ex_prop X"
apply (unfold ex_prop_def, clarify)
apply (drule_tac x = "{F,G}" in spec)
apply (auto dest: ok_sym simp add: OK_iff_ok)
done

(*Chandy & Sanders take this as a definition*)
lemma ex_prop_finite:
     "ex_prop X =
      (\<forall>GG. finite GG & GG \<inter> X \<noteq> {} & OK GG (%G. G)--> (\<Squnion>G \<in> GG. G) \<in> X)"
by (blast intro: ex1 ex2)

(*Their "equivalent definition" given at the end of section 3*)
lemma ex_prop_equiv:
     "ex_prop X = (\<forall>G. G \<in> X = (\<forall>H. (G component_of H) --> H \<in> X))"
apply auto
apply (unfold ex_prop_def component_of_def, safe, blast, blast)
apply (subst Join_commute)
apply (drule ok_sym, blast)
done

subsection\<open>Universal Properties\<close>

lemma uv1:
  assumes "uv_prop X"
    and "finite GG"
    and "GG \<subseteq> X"
    and "OK GG (%G. G)"
  shows "(\<Squnion>G \<in> GG. G) \<in> X"
  using assms(2-)
  apply induct
   using assms(1)
   apply (unfold uv_prop_def)
   apply (auto simp add: Int_insert_left OK_insert_iff)
  done

lemma uv2:
     "\<forall>GG. finite GG & GG \<subseteq> X & OK GG (%G. G) --> (\<Squnion>G \<in> GG. G) \<in> X
      ==> uv_prop X"
apply (unfold uv_prop_def)
apply (rule conjI)
 apply (drule_tac x = "{}" in spec)
 prefer 2
 apply clarify
 apply (drule_tac x = "{F,G}" in spec)
apply (auto dest: ok_sym simp add: OK_iff_ok)
done

(*Chandy & Sanders take this as a definition*)
lemma uv_prop_finite:
     "uv_prop X =
      (\<forall>GG. finite GG \<and> GG \<subseteq> X \<and> OK GG (\<lambda>G. G) \<longrightarrow> (\<Squnion>G \<in> GG. G) \<in> X)"
by (blast intro: uv1 uv2)

subsection\<open>Guarantees\<close>

lemma guaranteesI:
     "(!!G. [| F ok G; F\<squnion>G \<in> X |] ==> F\<squnion>G \<in> Y) ==> F \<in> X guarantees Y"
by (simp add: guar_def component_def)

lemma guaranteesD:
     "[| F \<in> X guarantees Y;  F ok G;  F\<squnion>G \<in> X |] ==> F\<squnion>G \<in> Y"
by (unfold guar_def component_def, blast)

(*This version of guaranteesD matches more easily in the conclusion
  The major premise can no longer be  F \<subseteq> H since we need to reason about G*)
lemma component_guaranteesD:
     "[| F \<in> X guarantees Y;  F\<squnion>G = H;  H \<in> X;  F ok G |] ==> H \<in> Y"
by (unfold guar_def, blast)

lemma guarantees_weaken:
     "[| F \<in> X guarantees X'; Y \<subseteq> X; X' \<subseteq> Y' |] ==> F \<in> Y guarantees Y'"
by (unfold guar_def, blast)

lemma subset_imp_guarantees_UNIV: "X \<subseteq> Y ==> X guarantees Y = UNIV"
by (unfold guar_def, blast)

(*Equivalent to subset_imp_guarantees_UNIV but more intuitive*)
lemma subset_imp_guarantees: "X \<subseteq> Y ==> F \<in> X guarantees Y"
by (unfold guar_def, blast)

(*Remark at end of section 4.1 *)

lemma ex_prop_imp: "ex_prop Y ==> (Y = UNIV guarantees Y)"
apply (simp (no_asm_use) add: guar_def ex_prop_equiv)
apply safe
 apply (drule_tac x = x in spec)
 apply (drule_tac [2] x = x in spec)
 apply (drule_tac [2] sym)
apply (auto simp add: component_of_def)
done

lemma guarantees_imp: "(Y = UNIV guarantees Y) ==> ex_prop(Y)"
by (auto simp add: guar_def ex_prop_equiv component_of_def dest: sym)

lemma ex_prop_equiv2: "(ex_prop Y) = (Y = UNIV guarantees Y)"
apply (rule iffI)
apply (rule ex_prop_imp)
apply (auto simp add: guarantees_imp)
done

subsection\<open>Distributive Laws.  Re-Orient to Perform Miniscoping\<close>

lemma guarantees_UN_left:
     "(\<Union>i \<in> I. X i) guarantees Y = (\<Inter>i \<in> I. X i guarantees Y)"
by (unfold guar_def, blast)

lemma guarantees_Un_left:
     "(X \<union> Y) guarantees Z = (X guarantees Z) \<inter> (Y guarantees Z)"
by (unfold guar_def, blast)

lemma guarantees_INT_right:
     "X guarantees (\<Inter>i \<in> I. Y i) = (\<Inter>i \<in> I. X guarantees Y i)"
by (unfold guar_def, blast)

lemma guarantees_Int_right:
     "Z guarantees (X \<inter> Y) = (Z guarantees X) \<inter> (Z guarantees Y)"
by (unfold guar_def, blast)

lemma guarantees_Int_right_I:
     "[| F \<in> Z guarantees X;  F \<in> Z guarantees Y |]
     ==> F \<in> Z guarantees (X \<inter> Y)"
by (simp add: guarantees_Int_right)

lemma guarantees_INT_right_iff:
     "(F \<in> X guarantees (\<Inter>(Y ` I))) = (\<forall>i\<in>I. F \<in> X guarantees (Y i))"
by (simp add: guarantees_INT_right)

lemma shunting: "(X guarantees Y) = (UNIV guarantees (-X \<union> Y))"
by (unfold guar_def, blast)

lemma contrapositive: "(X guarantees Y) = -Y guarantees -X"
by (unfold guar_def, blast)

(** The following two can be expressed using intersection and subset, which
    is more faithful to the text but looks cryptic.
**)

lemma combining1:
    "[| F \<in> V guarantees X;  F \<in> (X \<inter> Y) guarantees Z |]
     ==> F \<in> (V \<inter> Y) guarantees Z"
by (unfold guar_def, blast)

lemma combining2:
    "[| F \<in> V guarantees (X \<union> Y);  F \<in> Y guarantees Z |]
     ==> F \<in> V guarantees (X \<union> Z)"
by (unfold guar_def, blast)

(** The following two follow Chandy-Sanders, but the use of object-quantifiers
    does not suit Isabelle... **)

(*Premise should be (!!i. i \<in> I ==> F \<in> X guarantees Y i) *)
lemma all_guarantees:
     "\<forall>i\<in>I. F \<in> X guarantees (Y i) ==> F \<in> X guarantees (\<Inter>i \<in> I. Y i)"
by (unfold guar_def, blast)

(*Premises should be [| F \<in> X guarantees Y i; i \<in> I |] *)
lemma ex_guarantees:
     "\<exists>i\<in>I. F \<in> X guarantees (Y i) ==> F \<in> X guarantees (\<Union>i \<in> I. Y i)"
by (unfold guar_def, blast)

subsection\<open>Guarantees: Additional Laws (by lcp)\<close>

lemma guarantees_Join_Int:
    "[| F \<in> U guarantees V;  G \<in> X guarantees Y; F ok G |]
     ==> F\<squnion>G \<in> (U \<inter> X) guarantees (V \<inter> Y)"
apply (simp add: guar_def, safe)
 apply (simp add: Join_assoc)
apply (subgoal_tac "F\<squnion>G\<squnion>Ga = G\<squnion>(F\<squnion>Ga) ")
 apply (simp add: ok_commute)
apply (simp add: Join_ac)
done

lemma guarantees_Join_Un:
    "[| F \<in> U guarantees V;  G \<in> X guarantees Y; F ok G |]
     ==> F\<squnion>G \<in> (U \<union> X) guarantees (V \<union> Y)"
apply (simp add: guar_def, safe)
 apply (simp add: Join_assoc)
apply (subgoal_tac "F\<squnion>G\<squnion>Ga = G\<squnion>(F\<squnion>Ga) ")
 apply (simp add: ok_commute)
apply (simp add: Join_ac)
done

lemma guarantees_JN_INT:
     "[| \<forall>i\<in>I. F i \<in> X i guarantees Y i;  OK I F |]
      ==> (JOIN I F) \<in> (\<Inter>(X ` I)) guarantees (\<Inter>(Y ` I))"
apply (unfold guar_def, auto)
apply (drule bspec, assumption)
apply (rename_tac "i")
apply (drule_tac x = "JOIN (I-{i}) F\<squnion>G" in spec)
apply (auto intro: OK_imp_ok
            simp add: Join_assoc [symmetric] JN_Join_diff JN_absorb)
done

lemma guarantees_JN_UN:
    "[| \<forall>i\<in>I. F i \<in> X i guarantees Y i;  OK I F |]
     ==> (JOIN I F) \<in> (\<Union>(X ` I)) guarantees (\<Union>(Y ` I))"
apply (unfold guar_def, auto)
apply (drule bspec, assumption)
apply (rename_tac "i")
apply (drule_tac x = "JOIN (I-{i}) F\<squnion>G" in spec)
apply (auto intro: OK_imp_ok
            simp add: Join_assoc [symmetric] JN_Join_diff JN_absorb)
done

subsection\<open>Guarantees Laws for Breaking Down the Program (by lcp)\<close>

lemma guarantees_Join_I1:
     "[| F \<in> X guarantees Y;  F ok G |] ==> F\<squnion>G \<in> X guarantees Y"
by (simp add: guar_def Join_assoc)

lemma guarantees_Join_I2:
     "[| G \<in> X guarantees Y;  F ok G |] ==> F\<squnion>G \<in> X guarantees Y"
apply (simp add: Join_commute [of _ G] ok_commute [of _ G])
apply (blast intro: guarantees_Join_I1)
done

lemma guarantees_JN_I:
     "[| i \<in> I;  F i \<in> X guarantees Y;  OK I F |]
      ==> (\<Squnion>i \<in> I. (F i)) \<in> X guarantees Y"
apply (unfold guar_def, clarify)
apply (drule_tac x = "JOIN (I-{i}) F\<squnion>G" in spec)
apply (auto intro: OK_imp_ok simp add: JN_Join_diff Join_assoc [symmetric])
done

(*** well-definedness ***)

lemma Join_welldef_D1: "F\<squnion>G \<in> welldef ==> F \<in> welldef"
by (unfold welldef_def, auto)

lemma Join_welldef_D2: "F\<squnion>G \<in> welldef ==> G \<in> welldef"
by (unfold welldef_def, auto)

(*** refinement ***)

lemma refines_refl: "F refines F wrt X"
by (unfold refines_def, blast)

(*We'd like transitivity, but how do we get it?*)
lemma refines_trans:
     "[| H refines G wrt X;  G refines F wrt X |] ==> H refines F wrt X"
apply (simp add: refines_def)
oops

lemma strict_ex_refine_lemma:
     "strict_ex_prop X
      ==> (\<forall>H. F ok H & G ok H & F\<squnion>H \<in> X --> G\<squnion>H \<in> X)
              = (F \<in> X --> G \<in> X)"
by (unfold strict_ex_prop_def, auto)

lemma strict_ex_refine_lemma_v:
     "strict_ex_prop X
      ==> (\<forall>H. F ok H & G ok H & F\<squnion>H \<in> welldef & F\<squnion>H \<in> X --> G\<squnion>H \<in> X) =
          (F \<in> welldef \<inter> X --> G \<in> X)"
apply (unfold strict_ex_prop_def, safe)
apply (erule_tac x = SKIP and P = "%H. PP H --> RR H" for PP RR in allE)
apply (auto dest: Join_welldef_D1 Join_welldef_D2)
done

lemma ex_refinement_thm:
     "[| strict_ex_prop X;
         \<forall>H. F ok H & G ok H & F\<squnion>H \<in> welldef \<inter> X --> G\<squnion>H \<in> welldef |]
      ==> (G refines F wrt X) = (G iso_refines F wrt X)"
apply (rule_tac x = SKIP in allE, assumption)
apply (simp add: refines_def iso_refines_def strict_ex_refine_lemma_v)
done

lemma strict_uv_refine_lemma:
     "strict_uv_prop X ==>
      (\<forall>H. F ok H & G ok H & F\<squnion>H \<in> X --> G\<squnion>H \<in> X) = (F \<in> X --> G \<in> X)"
by (unfold strict_uv_prop_def, blast)

lemma strict_uv_refine_lemma_v:
     "strict_uv_prop X
      ==> (\<forall>H. F ok H & G ok H & F\<squnion>H \<in> welldef & F\<squnion>H \<in> X --> G\<squnion>H \<in> X) =
          (F \<in> welldef \<inter> X --> G \<in> X)"
apply (unfold strict_uv_prop_def, safe)
apply (erule_tac x = SKIP and P = "%H. PP H --> RR H" for PP RR in allE)
apply (auto dest: Join_welldef_D1 Join_welldef_D2)
done

lemma uv_refinement_thm:
     "[| strict_uv_prop X;
         \<forall>H. F ok H & G ok H & F\<squnion>H \<in> welldef \<inter> X -->
             G\<squnion>H \<in> welldef |]
      ==> (G refines F wrt X) = (G iso_refines F wrt X)"
apply (rule_tac x = SKIP in allE, assumption)
apply (simp add: refines_def iso_refines_def strict_uv_refine_lemma_v)
done

(* Added by Sidi Ehmety from Chandy & Sander, section 6 *)
lemma guarantees_equiv:
    "(F \<in> X guarantees Y) = (\<forall>H. H \<in> X \<longrightarrow> (F component_of H \<longrightarrow> H \<in> Y))"
by (unfold guar_def component_of_def, auto)

lemma wg_weakest: "!!X. F\<in> (X guarantees Y) ==> X \<subseteq> (wg F Y)"
by (unfold wg_def, auto)

lemma wg_guarantees: "F\<in> ((wg F Y) guarantees Y)"
by (unfold wg_def guar_def, blast)

lemma wg_equiv: "(H \<in> wg F X) = (F component_of H --> H \<in> X)"
by (simp add: guarantees_equiv wg_def, blast)

lemma component_of_wg: "F component_of H ==> (H \<in> wg F X) = (H \<in> X)"
by (simp add: wg_equiv)

lemma wg_finite:
    "\<forall>FF. finite FF \<and> FF \<inter> X \<noteq> {} \<longrightarrow> OK FF (\<lambda>F. F)
          \<longrightarrow> (\<forall>F\<in>FF. ((\<Squnion>F \<in> FF. F) \<in> wg F X) = ((\<Squnion>F \<in> FF. F) \<in> X))"
apply clarify
apply (subgoal_tac "F component_of (\<Squnion>F \<in> FF. F) ")
apply (drule_tac X = X in component_of_wg, simp)
apply (simp add: component_of_def)
apply (rule_tac x = "\<Squnion>F \<in> (FF-{F}) . F" in exI)
apply (auto intro: JN_Join_diff dest: ok_sym simp add: OK_iff_ok)
done

lemma wg_ex_prop: "ex_prop X ==> (F \<in> X) = (\<forall>H. H \<in> wg F X)"
apply (simp (no_asm_use) add: ex_prop_equiv wg_equiv)
apply blast
done

(** From Charpentier and Chandy "Theorems About Composition" **)
(* Proposition 2 *)
lemma wx_subset: "(wx X)<=X"
by (unfold wx_def, auto)

lemma wx_ex_prop: "ex_prop (wx X)"
apply (simp add: wx_def ex_prop_equiv cong: bex_cong, safe, blast)
apply force
done

lemma wx_weakest: "\<forall>Z. Z<= X --> ex_prop Z --> Z \<subseteq> wx X"
by (auto simp add: wx_def)

(* Proposition 6 *)
lemma wx'_ex_prop: "ex_prop({F. \<forall>G. F ok G --> F\<squnion>G \<in> X})"
apply (unfold ex_prop_def, safe)
 apply (drule_tac x = "G\<squnion>Ga" in spec)
 apply (force simp add: Join_assoc)
apply (drule_tac x = "F\<squnion>Ga" in spec)
apply (simp add: ok_commute  Join_ac)
done

text\<open>Equivalence with the other definition of wx\<close>

lemma wx_equiv: "wx X = {F. \<forall>G. F ok G --> (F\<squnion>G) \<in> X}"
apply (unfold wx_def, safe)
 apply (simp add: ex_prop_def, blast)
apply (simp (no_asm))
apply (rule_tac x = "{F. \<forall>G. F ok G --> F\<squnion>G \<in> X}" in exI, safe)
apply (rule_tac [2] wx'_ex_prop)
apply (drule_tac x = SKIP in spec)+
apply auto
done

text\<open>Propositions 7 to 11 are about this second definition of wx.
   They are the same as the ones proved for the first definition of wx,
 by equivalence\<close>

(* Proposition 12 *)
(* Main result of the paper *)
lemma guarantees_wx_eq: "(X guarantees Y) = wx(-X \<union> Y)"
by (simp add: guar_def wx_equiv)

(* Rules given in section 7 of Chandy and Sander's
    Reasoning About Program composition paper *)
lemma stable_guarantees_Always:
     "Init F \<subseteq> A ==> F \<in> (stable A) guarantees (Always A)"
apply (rule guaranteesI)
apply (simp add: Join_commute)
apply (rule stable_Join_Always1)
 apply (simp_all add: invariant_def)
done

lemma constrains_guarantees_leadsTo:
     "F \<in> transient A ==> F \<in> (A co A \<union> B) guarantees (A leadsTo (B-A))"
apply (rule guaranteesI)
apply (rule leadsTo_Basis')
 apply (drule constrains_weaken_R)
  prefer 2 apply assumption
 apply blast
apply (blast intro: Join_transient_I1)
done

end


section "Implementing a set of triples by maps"
theory TripleSetByMap
imports TripleSetSpec
begin

locale tsbm_defs =
  m1: StdMap m1_ops +
  m2: StdMap m2_ops +
  s3: StdSet s3_ops
  for m1_ops::"('a,'m2,'m1,_) map_ops_scheme"
  and m2_ops::"('b,'s3,'m2,_) map_ops_scheme"
  and s3_ops::"('c,'s3,_) set_ops_scheme"
begin
  definition tsbm_\<alpha> :: "('a,'b,'c,'m1) triple_set_\<alpha>" where
    "tsbm_\<alpha> m1 \<equiv> {(v,w,v').
      \<exists>m2 s3. m1.\<alpha> m1 v = Some m2
            \<and> m2.\<alpha> m2 w = Some s3
            \<and> v' \<in> s3.\<alpha> s3}"

  definition "tsbm_invar m1 \<equiv>
    m1.invar m1 \<and>
    (\<forall>m2 \<in> ran (m1.\<alpha> m1). m2.invar m2 \<and>
       (\<forall>s3\<in>ran (m2.\<alpha> m2). s3.invar s3))"

  lemma tsbm_invar_alt_def :
    "tsbm_invar m1 =
     (m1.invar m1 \<and>
      (\<forall>v m2. m1.\<alpha> m1 v = Some m2 \<longrightarrow> (
         m2.invar m2 \<and>
         (\<forall>w s3. m2.\<alpha> m2 w = Some s3 \<longrightarrow>
             s3.invar s3))))"
  unfolding tsbm_invar_def
  by (auto simp add: ran_def)

  lemma tsbm_invar_alt_def2 :
    "tsbm_invar m1 =
     (m1.invar m1 \<and>
      (\<forall>v m2. m1.lookup v m1 = Some m2 \<longrightarrow> (
         m2.invar m2 \<and>
         (\<forall>w s3. m2.lookup w m2 = Some s3 \<longrightarrow>
             s3.invar s3))))"
  unfolding tsbm_invar_alt_def
  by (auto simp add: m1.correct m2.correct)

  definition tsbm_empty :: "('a,'b,'c,'m1) triple_set_empty" where
    "tsbm_empty \<equiv> m1.empty"

  lemma tsbm_empty_correct:
    "triple_set_empty tsbm_\<alpha> tsbm_invar tsbm_empty"
    unfolding triple_set_empty_def tsbm_empty_def tsbm_\<alpha>_def tsbm_invar_def
    by (simp add: m1.correct)

  definition tsbm_add :: "('a,'b,'c,'m1) triple_set_add" where
    "tsbm_add v w v' l \<equiv>
     case m1.lookup v l of
        None \<Rightarrow> (m1.update v (m2.sng w (s3.sng v')) l) |
        Some m2 \<Rightarrow> (case m2.lookup w m2 of
          None \<Rightarrow>    m1.update v (m2.update w (s3.sng v')    m2) l |
          Some s3 \<Rightarrow> m1.update v (m2.update w (s3.ins v' s3) m2) l)"

  lemma tsbm_add_correct:
    "triple_set_add tsbm_\<alpha> tsbm_invar tsbm_add"
  proof
    fix l v w v'
    assume invar: "tsbm_invar l"

    from invar
    show "tsbm_invar (tsbm_add v w v' l)"
      unfolding tsbm_invar_alt_def tsbm_add_def
      by (simp add: m1.correct m2.correct s3.correct
               split: option.split if_split)

    from invar
    show "tsbm_\<alpha> (tsbm_add v w v' l) = insert (v, w, v') (tsbm_\<alpha> l)"
      unfolding tsbm_invar_alt_def tsbm_\<alpha>_def tsbm_add_def
      by (simp add: m1.correct m2.correct s3.correct set_eq_iff
               split: option.split if_split)
  qed

  definition tsbm_memb :: "('a,'b,'c,'m1) triple_set_memb" where
    "tsbm_memb t a b c \<equiv>
     case m1.lookup a t of
        None \<Rightarrow> False |
        Some m2 \<Rightarrow> (case m2.lookup b m2 of
          None \<Rightarrow>    False |
          Some s3 \<Rightarrow> s3.memb c s3)"

  lemma tsbm_memb_correct:
    "triple_set_memb tsbm_\<alpha> tsbm_invar tsbm_memb"
  proof
    fix t a b c
    assume invar: "tsbm_invar t"
    thus "tsbm_memb t a b c = ((a, b, c) \<in> tsbm_\<alpha> t)"
      unfolding tsbm_memb_def tsbm_\<alpha>_def
      by (simp split: option.split add: s3.correct tsbm_invar_alt_def m1.correct m2.correct)
  qed

  definition tsbm_add_Cs :: "('a,'b,'s3,'m1) triple_set_add_Cs" where
    "tsbm_add_Cs a b cs l \<equiv>
     case m1.lookup a l of
        None \<Rightarrow> (m1.update a (m2.sng b cs) l) |
        Some m2 \<Rightarrow> (case m2.lookup b m2 of
          None \<Rightarrow>    m1.update a (m2.update b cs m2) l |
          Some s3 \<Rightarrow> m1.update a (m2.update b (s3.union s3 cs) m2) l)"

  lemma tsbm_add_Cs_correct:
    "triple_set_add_Cs s3.\<alpha> s3.invar tsbm_\<alpha> tsbm_invar tsbm_add_Cs"
  proof
    fix cs t a b
    assume invar_t: "tsbm_invar t"
    assume invar_cs: "s3.invar cs"

    from invar_t invar_cs
    show "tsbm_invar (tsbm_add_Cs a b cs t)"
      unfolding tsbm_invar_alt_def2 tsbm_add_Cs_def
      by (simp add: m1.correct m2.correct s3.correct split: option.split if_split)

    from invar_t invar_cs
    show "tsbm_\<alpha> (tsbm_add_Cs a b cs t) = {(a, b, c) |c. c \<in> s3.\<alpha> cs} \<union> (tsbm_\<alpha> t)"
      unfolding tsbm_invar_alt_def tsbm_\<alpha>_def tsbm_add_Cs_def
      by (auto simp add: m1.correct m2.correct s3.correct set_eq_iff
               split: option.split if_split)
  qed

  definition tsbm_set_Cs :: "('a,'b,'s3,'m1) triple_set_add_Cs" where
    "tsbm_set_Cs a b cs l \<equiv>
     case m1.lookup a l of
        None \<Rightarrow> (m1.update a (m2.sng b cs) l) |
        Some m2 \<Rightarrow> m1.update a (m2.update b cs m2) l"

  lemma tsbm_set_Cs_correct:
    "triple_set_set_Cs s3.\<alpha> s3.invar tsbm_\<alpha> tsbm_invar tsbm_set_Cs"
  proof
    fix cs t a b
    assume invar_t: "tsbm_invar t"
    assume invar_cs: "s3.invar cs"
    assume dj: "\<And>c. (a, b, c) \<notin> tsbm_\<alpha> t"

    from invar_t invar_cs
    show "tsbm_invar (tsbm_set_Cs a b cs t)"
      unfolding tsbm_invar_alt_def2 tsbm_set_Cs_def
      by (simp add: m1.correct m2.correct s3.correct split: option.split if_split)

    from invar_t invar_cs dj
    show "tsbm_\<alpha> (tsbm_set_Cs a b cs t) = {(a, b, c) |c. c \<in> s3.\<alpha> cs} \<union> (tsbm_\<alpha> t)"
      unfolding tsbm_invar_alt_def tsbm_\<alpha>_def tsbm_set_Cs_def
      by (auto simp add: m1.correct m2.correct s3.correct set_eq_iff
               split: option.split if_split)
  qed

  definition tsbm_add_Cl :: "('a,'b,'c,'m1) triple_set_add_Cl" where
    "tsbm_add_Cl a b cs l \<equiv>
     case m1.lookup a l of
        None \<Rightarrow> (m1.update a (m2.sng b (s3.from_list cs)) l) |
        Some m2 \<Rightarrow> (case m2.lookup b m2 of
          None \<Rightarrow>    m1.update a (m2.update b (s3.from_list cs) m2) l |
          Some s3 \<Rightarrow> m1.update a (m2.update b (foldl (\<lambda>s3 v'. s3.ins v' s3) s3 cs) m2) l)"

  lemma tsbm_add_Cl_correct:
    "triple_set_add_Cl tsbm_\<alpha> tsbm_invar tsbm_add_Cl"
  proof
    fix l v w vs
    assume invar: "tsbm_invar l"
    define inner_add where "inner_add \<equiv> \<lambda>s3. foldl (\<lambda>s3 v'. s3.ins v' s3) s3 vs"
    have inner_add_fold : "\<And>s3. foldl (\<lambda>s3 v'. s3.ins v' s3) s3 vs = inner_add s3"
      unfolding inner_add_def by simp

    have inner_add_thm: "\<And>s3. s3.invar s3 \<Longrightarrow>
      s3.invar (inner_add s3) \<and> s3.\<alpha> (inner_add s3) = s3.\<alpha> s3 \<union> set vs"
      unfolding inner_add_def
      apply (induct vs)
      apply (simp_all add: s3.correct)
    done

    from invar
    show "tsbm_invar (tsbm_add_Cl v w vs l)"
      unfolding tsbm_invar_alt_def2 tsbm_add_Cl_def
      by (simp add: m1.correct m2.correct s3.correct inner_add_fold inner_add_thm
               split: option.split if_split)

    from invar
    show "tsbm_\<alpha> (tsbm_add_Cl v w vs l) = {(v, w, v') |v'. v' \<in> set vs} \<union> (tsbm_\<alpha> l)"
      unfolding tsbm_invar_alt_def tsbm_\<alpha>_def tsbm_add_Cl_def
      by (auto simp add: m1.correct m2.correct s3.correct set_eq_iff inner_add_fold inner_add_thm
               split: option.split if_split)
  qed

  definition tsbm_add_Al :: "('a,'b,'c,'m1) triple_set_add_Al" where
    "tsbm_add_Al as b c t \<equiv> foldl (\<lambda>t a. tsbm_add a b c t) t as"

  lemma tsbm_add_Al_correct:
    "triple_set_add_Al tsbm_\<alpha> tsbm_invar tsbm_add_Al"
  proof
    fix t as b c
    assume invar_t: "tsbm_invar t"

    hence "tsbm_invar (tsbm_add_Al as b c t) \<and>
           tsbm_\<alpha> (tsbm_add_Al as b c t) = {(a, b, c) |a. a \<in> set as} \<union> tsbm_\<alpha> t"
    proof (induct as arbitrary: t)
      case Nil thus ?case unfolding tsbm_add_Al_def by simp
    next
      case (Cons a as)
      note ind_hyp = Cons(1)
      note invar_t = Cons(2)

      from triple_set_add.triple_set_add_correct[OF tsbm_add_correct,
         OF invar_t, of a b c]
         ind_hyp [of "tsbm_add a b c t"]
      show ?case unfolding tsbm_add_Al_def by auto
    qed

    thus "tsbm_invar (tsbm_add_Al as b c t)"
         "tsbm_\<alpha> (tsbm_add_Al as b c t) = {(a, b, c) |a. a \<in> set as} \<union> tsbm_\<alpha> t"
      by simp_all
  qed

  definition tsbm_add_Bl :: "('a,'b,'c,'m1) triple_set_add_Bl" where
    "tsbm_add_Bl a bs c t \<equiv> foldl (\<lambda>t b. tsbm_add a b c t) t bs"

  lemma tsbm_add_Bl_correct:
    "triple_set_add_Bl tsbm_\<alpha> tsbm_invar tsbm_add_Bl"
  proof
    fix t a bs c
    assume invar_t: "tsbm_invar t"

    hence "tsbm_invar (tsbm_add_Bl a bs c t) \<and>
           tsbm_\<alpha> (tsbm_add_Bl a bs c t) = {(a, b, c) |b. b \<in> set bs} \<union> tsbm_\<alpha> t"
    proof (induct bs arbitrary: t)
      case Nil thus ?case unfolding tsbm_add_Bl_def by simp
    next
      case (Cons b bs)
      note ind_hyp = Cons(1)
      note invar_t = Cons(2)

      from triple_set_add.triple_set_add_correct[OF tsbm_add_correct,
         OF invar_t, of a b c]
         ind_hyp [of "tsbm_add a b c t"]
      show ?case unfolding tsbm_add_Bl_def by auto
    qed

    thus "tsbm_invar (tsbm_add_Bl a bs c t)"
         "tsbm_\<alpha> (tsbm_add_Bl a bs c t) = {(a, b, c) |b. b \<in> set bs} \<union> tsbm_\<alpha> t"
      by simp_all
  qed

  definition tsbm_delete :: "('a,'b,'c,'m1) triple_set_delete" where
    "tsbm_delete a b c m1 \<equiv>
     case m1.lookup a m1 of
        None \<Rightarrow> m1 |
        Some m2 \<Rightarrow> (case m2.lookup b m2 of
          None \<Rightarrow>    m1 |
          Some s3 \<Rightarrow> m1.update a (m2.update b (s3.delete c s3) m2) m1)"

  lemma tsbm_delete_correct:
    "triple_set_delete tsbm_\<alpha> tsbm_invar tsbm_delete"
  proof
    fix l v w v'
    assume invar: "tsbm_invar l"

    from invar
    show "tsbm_invar (tsbm_delete v w v' l)"
      unfolding tsbm_invar_alt_def tsbm_delete_def
      by (simp add: m1.correct m2.correct s3.correct
               split: option.split if_split)

    from invar
    show "tsbm_\<alpha> (tsbm_delete v w v' l) = (tsbm_\<alpha> l) - {(v, w, v')}"
      unfolding tsbm_invar_alt_def tsbm_\<alpha>_def tsbm_delete_def
      by (simp add: m1.correct m2.correct s3.correct set_eq_iff
               split: option.split if_split) auto
  qed

  definition tsbm_filter_it where
    "tsbm_filter_it it1 it2 it3 P_a P_b P_c P m1 =
        set_iterator_filter (\<lambda>vev'. P_c (snd (snd vev')) \<and> P vev')
        (map_iterator_product
           (map_iterator_key_filter P_a (it1 m1))
           (\<lambda>m2. map_iterator_product
               (map_iterator_key_filter P_b (it2 m2)) it3))"

  lemma tsbm_filter_it_alt_def[code] :
     "tsbm_filter_it = (\<lambda>it1 it2 it3 P_a P_b P_c P m1 c f.
        it1 m1 c
         (\<lambda>(a, m2) \<sigma>. if P_a a
                then it2 m2 c
                      (\<lambda>(b, s3) \<sigma>. if P_b b
                              then it3 s3 c (\<lambda>c \<sigma>. if P_c c \<and> P (a, b, c) then
                                f (a, b, c) \<sigma> else \<sigma>) \<sigma> else \<sigma>)
                      \<sigma>
                else \<sigma>))"
     unfolding tsbm_filter_it_def[abs_def] set_iterator_filter_alt_def
               map_iterator_product_alt_def map_iterator_key_filter_alt_def
               fst_conv snd_conv split_def
     by simp

  lemma tsbm_filter_it_correct :
    assumes it1_OK: "map_iteratei m1.\<alpha> m1.invar it1"
    assumes it2_OK: "map_iteratei m2.\<alpha> m2.invar it2"
    assumes it3_OK: "set_iteratei s3.\<alpha> s3.invar it3"
    shows "triple_set_filter_it tsbm_\<alpha> tsbm_invar (tsbm_filter_it it1 it2 it3)"
  unfolding triple_set_filter_it_def
  proof (intro allI impI)
    fix t and P_a :: "'a \<Rightarrow> bool" and P_b :: "'b \<Rightarrow> bool" and P_c :: "'c \<Rightarrow> bool" and
        P :: "('a \<times> 'b \<times> 'c) \<Rightarrow> bool"
    assume invar_t: "tsbm_invar t"
    from invar_t have invar_m1: "m1.invar t"
      unfolding tsbm_invar_def by simp

    let ?it2'' = "\<lambda>m2. map_iterator_product
      (map_iterator_key_filter P_b (it2 m2)) it3"
    let ?S_2'' = "\<lambda>m2. {(e, v'). \<exists>s3. m2.\<alpha> m2 e = Some s3 \<and> P_b e \<and> v' \<in> s3.\<alpha> s3}"

    { fix a m2
      assume t_a_eq:"(m1.\<alpha> t |` {a. P_a a}) a = Some m2"

      from invar_t t_a_eq have invar_m2: "m2.invar m2"
        unfolding tsbm_invar_alt_def
        by (auto simp add: m1.correct restrict_map_eq)

      { fix b s3
        assume m2_b_eq: "(m2.\<alpha> m2 |` {e. P_b b}) b = Some s3"
        from invar_t t_a_eq invar_m2 m2_b_eq have invar_s3: "s3.invar s3"
          unfolding tsbm_invar_alt_def restrict_map_def
          by (simp add: m1.correct m2.correct split: if_splits)

        note it3_OK' = set_iteratei.iteratei_rule [OF it3_OK, OF invar_s3]
      } note it3_OK'' = this

      note it2_OK' = map_iteratei.iteratei_rule [OF it2_OK, OF invar_m2]
      note it2_OK'' = map_iterator_key_filter_correct [OF it2_OK', of P_b]

      from map_iterator_product_correct [OF it2_OK'', of it3 s3.\<alpha>] it3_OK''
      have "set_iterator (?it2'' m2) (?S_2'' m2)"
        by (simp add: restrict_map_eq)
           (metis (no_types) UNIV_I)
    } note it2_OK'' = this

    have aux: "{(k, e). \<exists>v. m1.\<alpha> t k = Some v \<and> (case e of (k, e) \<Rightarrow>
              \<exists>va. m2.\<alpha> v k = Some va \<and> e \<in> s3.\<alpha> va)} = tsbm_\<alpha> t"
      unfolding tsbm_\<alpha>_def by auto

    note it1_OK' = map_iteratei.iteratei_rule [OF it1_OK, OF invar_m1]
    note it1_OK'' = map_iterator_key_filter_correct [OF it1_OK', of P_a]

    let ?it1'' = "map_iterator_product
      (map_iterator_key_filter P_a (it1 t)) ?it2''"
    let ?S_1'' = "{(k, e). \<exists>v. m1.\<alpha> t k = Some v \<and> P_a k \<and>
           (case e of (e, v') \<Rightarrow> \<exists>s3. m2.\<alpha> v e = Some s3 \<and> P_b e \<and> v' \<in> s3.\<alpha> s3)}"

    have S_1''_eq: "?S_1'' = {(v, e, v'). (v, e, v') \<in> tsbm_\<alpha> t \<and> P_a v \<and> P_b e}"
      unfolding tsbm_\<alpha>_def by auto

   from map_iterator_product_correct [OF it1_OK'', of ?it2'' ?S_2''] it2_OK''
    have it1_OK'': "set_iterator ?it1''
       {(v, e, v'). (v, e, v') \<in> tsbm_\<alpha> t \<and> P_a v \<and> P_b e}"
      by (simp add: restrict_map_eq S_1''_eq)

    from set_iterator_filter_correct [OF it1_OK'', of "(\<lambda>vev'. P_c (snd (snd vev')) \<and> P vev')"]
    show "set_iterator (tsbm_filter_it it1 it2 it3 P_a P_b P_c P t)
           {(v1, e, v2). (v1, e, v2) \<in> tsbm_\<alpha> t \<and> P_a v1 \<and> P_b e \<and> P_c v2 \<and> P (v1, e, v2)}"
      unfolding tsbm_filter_it_def[symmetric]
      apply simp
      apply (rule subst [where P = "set_iterator (tsbm_filter_it it1 it2 it3 P_a P_b P_c P t)"])
      apply auto
    done
  qed

  definition tsbm_it where
    "tsbm_it it1 it2 it3 = tsbm_filter_it it1 it2 it3 (\<lambda>_. True) (\<lambda>_. True) (\<lambda>_. True) (\<lambda>_. True)"

  lemma tsbm_it_alt_def [code] :
    "tsbm_it it1 it2 it3 = (\<lambda>m1 c f.
        it1 m1 c (\<lambda>(a, m2). it2 m2 c (\<lambda>(b, s3). it3 s3 c (\<lambda>c. f (a, b, c)))))"
    unfolding tsbm_it_def tsbm_filter_it_alt_def by simp

  lemma tsbm_it_correct :
    assumes it1_OK: "map_iteratei m1.\<alpha> m1.invar it1"
    assumes it2_OK: "map_iteratei m2.\<alpha> m2.invar it2"
    assumes it3_OK: "set_iteratei s3.\<alpha> s3.invar it3"
    shows "triple_set_iterator tsbm_\<alpha> tsbm_invar (tsbm_it it1 it2 it3)"
  unfolding triple_set_iterator_def tsbm_it_def
    apply (intro allI impI)
    apply (insert triple_set_filter_it.triple_set_filter_it_correct [OF
     tsbm_filter_it_correct[OF it1_OK it2_OK it3_OK], of _ "\<lambda>_. True" "\<lambda>_. True" "\<lambda>_. True" "\<lambda>_. True"])
    apply simp
  done

  definition tsbm_A_it where
   "tsbm_A_it it1 (t::'m1) (b::'b) (c::'c) =
    map_iterator_dom_filter (\<lambda>am2.
      case m2.lookup b (snd am2) of
         None \<Rightarrow> False
       | Some s3 \<Rightarrow> s3.memb c s3) (it1 t)"

  lemma tsbm_A_it_alt_def[code] :
    "tsbm_A_it = (\<lambda>it1 t b c c' f.
        it1 t c'
         (\<lambda>(a,m2) \<sigma>. if case_option False (set_op_memb s3_ops c)
                     (map_op_lookup m2_ops b m2)
                 then f a \<sigma> else \<sigma>))"
    unfolding tsbm_A_it_def[abs_def] map_iterator_dom_filter_alt_def
              curry_def split_def
              fst_conv snd_conv by simp

  lemma tsbm_A_it_correct :
    assumes it1_OK: "map_iteratei m1.\<alpha> m1.invar it1"
    shows "triple_set_A_it tsbm_\<alpha> tsbm_invar (tsbm_A_it it1)"
  unfolding triple_set_A_it_def
  proof (intro allI impI)
    fix t b c
    assume invar_t: "tsbm_invar t"
    from invar_t have invar_m1: "m1.invar t"
      unfolding tsbm_invar_def by simp

    from map_iteratei.iteratei_rule [OF it1_OK, OF invar_m1] have
      step1: "map_iterator (it1 t) (map_op_\<alpha> m1_ops t)" .

    from map_iterator_dom_filter_correct [OF step1,
      of "\<lambda>am2. case m2.lookup b (snd am2) of None \<Rightarrow> False | Some s3 \<Rightarrow> s3.memb c s3"]
    have step2: "set_iterator (tsbm_A_it it1 t b c)
          {k. \<exists>v. m1.\<alpha> t k = Some v \<and>
             (case m2.lookup b v of None \<Rightarrow> False
              | Some s3 \<Rightarrow> s3.memb c s3)}"
      by (simp add: tsbm_A_it_def[symmetric])

   from invar_t
   have step3: "{k. \<exists>v. m1.\<alpha> t k = Some v \<and> (case m2.lookup b v of None \<Rightarrow> False
                                  | Some s3 \<Rightarrow> s3.memb c s3)} =
                {a . (a, b, c) \<in> tsbm_\<alpha> t}"
     unfolding tsbm_\<alpha>_def tsbm_invar_alt_def
     by (auto simp add: map_to_set_def m1.correct m2.correct s3.correct split: option.splits)
        (metis m2.lookup_correct map_upd_eqD1 s3.memb_correct)

   from step2 step3
   show "set_iterator (tsbm_A_it it1 t b c) {a . (a, b, c) \<in> tsbm_\<alpha> t}"
     unfolding tsbm_A_it_def by simp
  qed

  definition tsbm_B_it where
   "tsbm_B_it it (t::'m1) (a::'a) (c::'c) =
     (case m1.lookup a t of
         None \<Rightarrow> set_iterator_emp
       | Some m2 \<Rightarrow>
           (map_iterator_dom_filter (\<lambda>bs3. s3.memb c (snd bs3)) (it m2)))"

  lemma tsbm_B_it_alt_def[code] :
    "tsbm_B_it = (\<lambda>it t a c.
        case map_op_lookup m1_ops a t of None \<Rightarrow> (\<lambda>c f \<sigma>0. \<sigma>0)
        | Some m2 \<Rightarrow> \<lambda>ca f. it m2 ca (\<lambda>(x, y) \<sigma>. if set_op_memb s3_ops c y then f x \<sigma> else \<sigma>))"
    unfolding tsbm_B_it_def[abs_def] map_iterator_dom_filter_alt_def
              curry_def split_def
              fst_conv snd_conv set_iterator_emp_def[abs_def] by simp

  lemma tsbm_B_it_correct :
    assumes it_OK: "map_iteratei m2.\<alpha> m2.invar it"
    shows "triple_set_B_it tsbm_\<alpha> tsbm_invar (tsbm_B_it it)"
  unfolding triple_set_B_it_def
  proof (intro allI impI)
    fix t a c
    assume invar_t: "tsbm_invar t"
    from invar_t have invar_m1: "m1.invar t"
      unfolding tsbm_invar_def by simp

    show "set_iterator (tsbm_B_it it t a c)
             {b . (a, b, c) \<in> tsbm_\<alpha> t}"
    proof (cases "m1.lookup a t")
      case None note m1_a_eq = this
      with invar_m1 have "{b . (a, b, c) \<in> tsbm_\<alpha> t} = {}"
        unfolding tsbm_\<alpha>_def
         by (simp add: m1.correct)
      thus ?thesis
        unfolding tsbm_B_it_def
        by (simp add: m1_a_eq set_iterator_emp_correct)
    next
      case (Some m2) note m1_a_eq = this
      with invar_t have invar_m2: "m2.invar m2"  and
                        invar_s3: "\<And>w s3. m2.\<alpha> m2 w = Some s3 \<Longrightarrow> s3.invar s3"
        unfolding tsbm_invar_alt_def
        by (simp_all add: m1.correct)

      from invar_s3 have c_in_simp:
        "\<And>k s3. m2.\<alpha> m2 k = Some s3 \<and> s3.memb c s3 \<longleftrightarrow>
                m2.\<alpha> m2 k = Some s3 \<and> c \<in> s3.\<alpha> s3"
        by (auto simp add: s3.correct)

      from map_iteratei.iteratei_rule[OF it_OK, OF invar_m2]
      have it_m2: "map_iterator (it m2) (m2.\<alpha> m2)" .

      from map_iterator_dom_filter_correct [OF it_m2, of "(\<lambda>bs3. s3.memb c (snd bs3))"]
           m1_a_eq invar_m1
      show ?thesis
        by (simp add: tsbm_B_it_def tsbm_\<alpha>_def m1.correct c_in_simp)
    qed
  qed

  definition tsbm_C_it where
    "tsbm_C_it it m1 a b =
     (case m1.lookup a m1 of
         None \<Rightarrow> set_iterator_emp
       | Some m2 \<Rightarrow>
           (case m2.lookup b m2 of
               None \<Rightarrow> set_iterator_emp
             | Some s3 \<Rightarrow> it s3))"

  lemmas tsbm_C_it_alt_def[code] =
    tsbm_C_it_def[abs_def, unfolded set_iterator_emp_def[abs_def]]

  lemma tsbm_C_it_correct :
    assumes it_OK: "set_iteratei s3.\<alpha> s3.invar it"
    shows "triple_set_C_it tsbm_\<alpha> tsbm_invar (tsbm_C_it it)"
  unfolding triple_set_C_it_def
  proof (intro allI impI)
    fix t a b
    assume invar_t: "tsbm_invar t"
    from invar_t have invar_m1: "m1.invar t"
      unfolding tsbm_invar_def by simp

    show "set_iterator (tsbm_C_it it t a b)
             {c . (a, b, c) \<in> tsbm_\<alpha> t}"
    proof (cases "m1.lookup a t")
      case None note m1_v_eq = this
      with invar_m1 have "{c . (a, b, c) \<in> tsbm_\<alpha> t} = {}"
        unfolding tsbm_\<alpha>_def
         by (simp add: m1.correct)
      thus ?thesis
        unfolding tsbm_C_it_def
        by (simp add: m1_v_eq set_iterator_emp_correct)
    next
      case (Some m2) note m1_a_eq = this
      with invar_t have invar_m2: "m2.invar m2"
        unfolding tsbm_invar_alt_def
        by (simp add: m1.correct)

      show ?thesis
      proof (cases "m2.lookup b m2")
        case None note m2_b_eq = this
        with invar_m1 invar_m2 m1_a_eq have "{c . (a, b, c) \<in> tsbm_\<alpha> t} = {}"
          unfolding tsbm_\<alpha>_def
           by (simp add: m1.correct m2.correct)
        thus ?thesis
          unfolding tsbm_C_it_def
          by (simp add: m1_a_eq m2_b_eq set_iterator_emp_correct)
      next
        case (Some s3) note m2_b_eq = this

        with invar_t invar_m2 m1_a_eq have invar_s3: "s3.invar s3"
          unfolding tsbm_invar_alt_def
          by (simp add: m1.correct m2.correct)

        from set_iteratei.iteratei_rule[OF it_OK, OF invar_s3]
        have it_s3: "set_iterator (it s3) (s3.\<alpha> s3)" by simp

        have succ_eq: "{c . (a, b, c) \<in> tsbm_\<alpha> t} = s3.\<alpha> s3"
          using m1_a_eq m2_b_eq invar_m1 invar_m2
          unfolding tsbm_\<alpha>_def by (simp add: m1.correct m2.correct)

        show ?thesis
          using succ_eq it_s3
          unfolding tsbm_C_it_def
          by (simp add: m1_a_eq m2_b_eq)
      qed
    qed
  qed

  definition tsbm_BC_it where
    "tsbm_BC_it it2 it3 m1 a =
     (case m1.lookup a m1 of
         None \<Rightarrow> set_iterator_emp
       | Some m2 \<Rightarrow>
           map_iterator_product (it2 m2) it3)"

  lemma tsbm_BC_it_alt_def[code] :
    "tsbm_BC_it = (\<lambda>it2 it3 m1 a.
      (case m1.lookup a m1 of
          None \<Rightarrow> \<lambda>c f \<sigma>0. \<sigma>0
        | Some m2 \<Rightarrow> \<lambda>c f. it2 m2 c (\<lambda>(b, s3). it3 s3 c (\<lambda>c'. f (b, c')))))"
    unfolding tsbm_BC_it_def[abs_def] map_iterator_product_alt_def split_def
              curry_def set_iterator_emp_def[abs_def] fst_conv snd_conv
    by simp

  lemma tsbm_BC_it_correct :
    assumes it2_OK: "map_iteratei m2.\<alpha> m2.invar it2"
    assumes it3_OK: "set_iteratei s3.\<alpha> s3.invar it3"
    shows "triple_set_BC_it tsbm_\<alpha> tsbm_invar (tsbm_BC_it it2 it3)"
  unfolding triple_set_BC_it_def
  proof (intro allI impI)
    fix t a
    assume invar_t: "tsbm_invar t"
    from invar_t have invar_m1: "m1.invar t"
      unfolding tsbm_invar_def by simp

    show "set_iterator (tsbm_BC_it it2 it3 t a)
             {(b, c) . (a, b, c) \<in> tsbm_\<alpha> t}"
    proof (cases "m1.lookup a t")
      case None note m1_a_eq = this
      with invar_m1 have "{(b, c) . (a, b, c) \<in> tsbm_\<alpha> t} = {}"
        unfolding tsbm_\<alpha>_def
         by (simp add: m1.correct)
      thus ?thesis
        unfolding tsbm_BC_it_def
        by (simp add: m1_a_eq set_iterator_emp_correct)
    next
      case (Some m2) note m1_a_eq = this
      with invar_t have invar_m2: "m2.invar m2"
        unfolding tsbm_invar_alt_def
        by (simp add: m1.correct)

      from map_iteratei.iteratei_rule[OF it2_OK, OF invar_m2]
      have it2_OK': "map_iterator (it2 m2) (m2.\<alpha> m2)" .

      have it3_OK': "\<And>k s3. m2.\<alpha> m2 k = Some s3 \<Longrightarrow>
           set_iterator (it3 s3) (s3.\<alpha> s3)"
      proof -
        fix k s3
        assume m2_k_eq: "m2.\<alpha> m2 k = Some s3"

        from invar_t invar_m1 invar_m2 m1_a_eq m2_k_eq
        have invar_s3: "s3.invar s3"
          unfolding tsbm_invar_alt_def
          by (simp add: m1.correct m2.correct)

        with set_iteratei.iteratei_rule[OF it3_OK]
        show "set_iterator (it3 s3) (s3.\<alpha> s3)"
          by simp
      qed

      from map_iterator_product_correct [OF it2_OK',
         of it3 "s3.\<alpha>"] it3_OK' m1_a_eq invar_m1
      show ?thesis
         by (simp add: tsbm_BC_it_def tsbm_\<alpha>_def m1.correct)
    qed
  qed

  definition tsbm_AB_it where
    "tsbm_AB_it it1 it2 m1 c =
        map_iterator_product (it1 m1)
           (\<lambda>m2. map_iterator_dom_filter (s3.memb c \<circ> snd)
              (it2 m2))"

  lemma tsbm_AB_it_alt_def[code] :
     "tsbm_AB_it = (\<lambda>it1 it2 m1 c ca f.
        it1 m1 ca
         (\<lambda>(a, m2). it2 m2 ca
               (\<lambda>(b, s3) \<sigma>. if set_op_memb s3_ops c s3 then f (a, b) \<sigma>
                       else \<sigma>)))"
     unfolding tsbm_AB_it_def[abs_def] map_iterator_product_alt_def
               curry_def map_iterator_dom_filter_alt_def o_def
               split_def fst_conv snd_conv by simp

  lemma tsbm_AB_it_correct :
    assumes it1_OK: "map_iteratei m1.\<alpha> m1.invar it1"
    assumes it2_OK: "map_iteratei m2.\<alpha> m2.invar it2"
    shows "triple_set_AB_it tsbm_\<alpha> tsbm_invar (tsbm_AB_it it1 it2)"
  unfolding triple_set_AB_it_def
  proof (intro allI impI)
    fix l v'
    assume invar_l: "tsbm_invar l"
    from invar_l have invar_m1: "m1.invar l"
      unfolding tsbm_invar_def by simp

    let ?it_b = "\<lambda>m2. map_iterator_dom_filter (s3.memb v' \<circ> snd) (it2 m2)"
    let ?S_b = "\<lambda>m2. {e . \<exists>s3. m2.\<alpha> m2 e = Some s3 \<and> s3.memb v' s3}"

    { fix v m2
      assume l_v_eq: "m1.\<alpha> l v = Some m2"

      from invar_l l_v_eq have invar_m2: "m2.invar m2"
        unfolding tsbm_invar_alt_def
        by (simp add: m1.correct)

      note it2_OK' = map_iteratei.iteratei_rule [OF it2_OK, OF invar_m2]
      from map_iterator_dom_filter_correct [OF it2_OK', of "s3.memb v' \<circ> snd"]
      have "set_iterator (?it_b m2) (?S_b m2)"
        by simp
    } note it_b_aux = this

    from invar_l
    have S_b_aux: "{(k, e). \<exists>v. m1.\<alpha> l k = Some v \<and> e \<in> ?S_b v} =
                   {(v, e) |v e. (v, e, v') \<in> tsbm_\<alpha> l}"
      unfolding tsbm_invar_alt_def tsbm_\<alpha>_def
      by (auto simp add: m1.correct m2.correct s3.correct)

    note it1_OK' = map_iteratei.iteratei_rule [OF it1_OK, OF invar_m1]
    from map_iterator_product_correct [OF it1_OK', of ?it_b ?S_b] S_b_aux it_b_aux
    show "set_iterator (tsbm_AB_it it1 it2 l v')
             {(v, e) . (v, e, v') \<in> tsbm_\<alpha> l} "
      by (simp add: tsbm_AB_it_def[symmetric])
  qed

  definition tsbm_AC_it where
    "tsbm_AC_it it1 it3 m1 b =
        map_iterator_product (it1 m1)
           (\<lambda>m2. case m2.lookup b m2 of None \<Rightarrow> set_iterator_emp
                 | Some s3 \<Rightarrow> it3 s3)"

  lemma tsbm_AC_it_alt_def[code] :
     "tsbm_AC_it = (\<lambda>it1 it3 m1 b c f.
        it1 m1 c
         (\<lambda>(a, m2). case_option (\<lambda>c f \<sigma>0. \<sigma>0) it3 (map_op_lookup m2_ops b m2) c
               (\<lambda>b. f (a, b))))"
     unfolding tsbm_AC_it_def[abs_def] map_iterator_product_alt_def
               curry_def map_iterator_dom_filter_alt_def set_iterator_emp_def[abs_def]
               fst_conv snd_conv split_def by simp

  lemma tsbm_AC_it_correct :
    assumes it1_OK: "map_iteratei m1.\<alpha> m1.invar it1"
    assumes it3_OK: "set_iteratei s3.\<alpha> s3.invar it3"
    shows "triple_set_AC_it tsbm_\<alpha> tsbm_invar (tsbm_AC_it it1 it3)"
  unfolding triple_set_AC_it_def
  proof (intro allI impI)
    fix l b
    assume invar_l: "tsbm_invar l"
    from invar_l have invar_m1: "m1.invar l"
      unfolding tsbm_invar_def by simp

    let ?it_c = " (\<lambda>m2. case m2.lookup b m2 of None \<Rightarrow> set_iterator_emp
                 | Some s3 \<Rightarrow> it3 s3)"
    let ?S_c = "\<lambda>m2. {c . \<exists>s3. m2.\<alpha> m2 b = Some s3 \<and> s3.memb c s3}"

    have it_c_aux: "\<And>a m2. m1.\<alpha> l a = Some m2 \<Longrightarrow>
       set_iterator (?it_c m2) (?S_c m2)"
    proof -
      fix m2 a
      assume "m1.\<alpha> l a = Some m2"
      with invar_l have invar_m2: "m2.invar m2"  and
                        invar_s3: "\<And>w s3. m2.\<alpha> m2 w = Some s3 \<Longrightarrow> s3.invar s3"
        unfolding tsbm_invar_alt_def
        by (simp_all add: m1.correct)

      show "set_iterator (?it_c m2) (?S_c m2)"
      proof (cases "m2.lookup b m2")
        case None note m2_b_eq = this
        with invar_m2 show ?thesis by (simp add: m2.correct set_iterator_emp_correct)
      next
        case (Some s3) note m2_b_eq = this
        with invar_s3 invar_m2 have s3_invar': "s3.invar s3" by (simp add: m2.correct)

        from set_iteratei.iteratei_rule[OF it3_OK, OF s3_invar'] m2_b_eq s3_invar'
        show ?thesis by (simp add: invar_m2 m2.correct s3.correct)
      qed
    qed

    from invar_l
    have S_c_aux: "{(a, c). \<exists>m2. m1.\<alpha> l a = Some m2 \<and> c \<in> ?S_c m2} =
                   {(a, c) . (a, b, c) \<in> tsbm_\<alpha> l}"
      unfolding tsbm_invar_alt_def tsbm_\<alpha>_def
      by (auto simp add: m1.correct m2.correct s3.correct)

    note it1_OK' = map_iteratei.iteratei_rule [OF it1_OK, OF invar_m1]
    from map_iterator_product_correct [OF it1_OK', of ?it_c ?S_c] S_c_aux it_c_aux
    show "set_iterator (tsbm_AC_it it1 it3 l b)
             {(a, c) . (a, b, c) \<in> tsbm_\<alpha> l} "
      by (simp add: tsbm_AC_it_def[symmetric])
  qed

end

consts test :: bool

find_theorems "test"

end


(*  Title:      HOL/Word/Word_Examples.thy
    Authors:    Gerwin Klein and Thomas Sewell, NICTA

Examples demonstrating and testing various word operations.
*)

section "Examples of word operations"

theory Word_Examples
  imports Word_Bitwise
begin

type_synonym word32 = "32 word"
type_synonym word8 = "8 word"
type_synonym byte = word8

text "modulus"

lemma "(27 :: 4 word) = -5" by simp

lemma "(27 :: 4 word) = 11" by simp

lemma "27 \<noteq> (11 :: 6 word)" by simp

text "signed"

lemma "(127 :: 6 word) = -1" by simp

text "number ring simps"

lemma
  "27 + 11 = (38::'a::len word)"
  "27 + 11 = (6::5 word)"
  "7 * 3 = (21::'a::len word)"
  "11 - 27 = (-16::'a::len word)"
  "- (- 11) = (11::'a::len word)"
  "-40 + 1 = (-39::'a::len word)"
  by simp_all

lemma "word_pred 2 = 1" by simp

lemma "word_succ (- 3) = -2" by simp

lemma "23 < (27::8 word)" by simp
lemma "23 \<le> (27::8 word)" by simp
lemma "\<not> 23 < (27::2 word)" by simp
lemma "0 < (4::3 word)" by simp
lemma "1 < (4::3 word)" by simp
lemma "0 < (1::3 word)" by simp

text "ring operations"

lemma "a + 2 * b + c - b = (b + c) + (a :: 32 word)" by simp

text "casting"

lemma "uint (234567 :: 10 word) = 71" by simp
lemma "uint (-234567 :: 10 word) = 953" by simp
lemma "sint (234567 :: 10 word) = 71" by simp
lemma "sint (-234567 :: 10 word) = -71" by simp
lemma "uint (1 :: 10 word) = 1" by simp

lemma "unat (-234567 :: 10 word) = 953" by simp
lemma "unat (1 :: 10 word) = 1" by simp

lemma "ucast (0b1010 :: 4 word) = (0b10 :: 2 word)" by simp
lemma "ucast (0b1010 :: 4 word) = (0b1010 :: 10 word)" by simp
lemma "scast (0b1010 :: 4 word) = (0b111010 :: 6 word)" by simp
lemma "ucast (1 :: 4 word) = (1 :: 2 word)" by simp

text "reducing goals to nat or int and arith:"
lemma "i < x \<Longrightarrow> i < i + 1" for i x :: "'a::len word"
  by unat_arith
lemma "i < x \<Longrightarrow> i < i + 1" for i x :: "'a::len word"
  by unat_arith

text "bool lists"

lemma "of_bl [True, False, True, True] = (0b1011::'a::len word)" by simp

lemma "to_bl (0b110::4 word) = [False, True, True, False]" by simp

text "this is not exactly fast, but bearable"
lemma "of_bl (replicate 32 True) = (0xFFFFFFFF::32 word)" by simp

text "this works only for replicate n True"
lemma "of_bl (replicate 32 True) = (0xFFFFFFFF::32 word)"
  by (unfold mask_bl [symmetric]) (simp add: mask_def)

text "bit operations"

lemma "0b110 AND 0b101 = (0b100 :: 32 word)" by simp
lemma "0b110 OR 0b011 = (0b111 :: 8 word)" by simp
lemma "0xF0 XOR 0xFF = (0x0F :: byte)" by simp
lemma "NOT (0xF0 :: 16 word) = 0xFF0F" by simp
lemma "0 AND 5 = (0 :: byte)" by simp
lemma "1 AND 1 = (1 :: byte)" by simp
lemma "1 AND 0 = (0 :: byte)" by simp
lemma "1 AND 5 = (1 :: byte)" by simp
lemma "1 OR 6 = (7 :: byte)" by simp
lemma "1 OR 1 = (1 :: byte)" by simp
lemma "1 XOR 7 = (6 :: byte)" by simp
lemma "1 XOR 1 = (0 :: byte)" by simp
lemma "NOT 1 = (254 :: byte)" by simp
lemma "NOT 0 = (255 :: byte)" apply simp oops
(* FIXME: "NOT 0" rewrites to "max_word" instead of "-1" *)

lemma "(-1 :: 32 word) = 0xFFFFFFFF" by simp

lemma "(0b0010 :: 4 word) !! 1" by simp
lemma "\<not> (0b0010 :: 4 word) !! 0" by simp
lemma "\<not> (0b1000 :: 3 word) !! 4" by simp
lemma "\<not> (1 :: 3 word) !! 2" by simp

lemma "(0b11000 :: 10 word) !! n = (n = 4 \<or> n = 3)"
  by (auto simp add: bin_nth_Bit0 bin_nth_Bit1)

lemma "set_bit 55 7 True = (183::'a::len0 word)" by simp
lemma "set_bit 0b0010 7 True = (0b10000010::'a::len0 word)" by simp
lemma "set_bit 0b0010 1 False = (0::'a::len0 word)" by simp
lemma "set_bit 1 3 True = (0b1001::'a::len0 word)" by simp
lemma "set_bit 1 0 False = (0::'a::len0 word)" by simp
lemma "set_bit 0 3 True = (0b1000::'a::len0 word)" by simp
lemma "set_bit 0 3 False = (0::'a::len0 word)" by simp

lemma "lsb (0b0101::'a::len word)" by simp
lemma "\<not> lsb (0b1000::'a::len word)" by simp
lemma "lsb (1::'a::len word)" by simp
lemma "\<not> lsb (0::'a::len word)" by simp

lemma "\<not> msb (0b0101::4 word)" by simp
lemma   "msb (0b1000::4 word)" by simp
lemma "\<not> msb (1::4 word)" by simp
lemma "\<not> msb (0::4 word)" by simp

lemma "word_cat (27::4 word) (27::8 word) = (2843::'a::len word)" by simp
lemma "word_cat (0b0011::4 word) (0b1111::6word) = (0b0011001111 :: 10 word)"
  by simp

lemma "0b1011 << 2 = (0b101100::'a::len0 word)" by simp
lemma "0b1011 >> 2 = (0b10::8 word)" by simp
lemma "0b1011 >>> 2 = (0b10::8 word)" by simp
lemma "1 << 2 = (0b100::'a::len0 word)" apply simp? oops

lemma "slice 3 (0b101111::6 word) = (0b101::3 word)" by simp
lemma "slice 3 (1::6 word) = (0::3 word)" apply simp? oops

lemma "word_rotr 2 0b0110 = (0b1001::4 word)" by simp
lemma "word_rotl 1 0b1110 = (0b1101::4 word)" by simp
lemma "word_roti 2 0b1110 = (0b1011::4 word)" by simp
lemma "word_roti (- 2) 0b0110 = (0b1001::4 word)" by simp
lemma "word_rotr 2 0 = (0::4 word)" by simp
lemma "word_rotr 2 1 = (0b0100::4 word)" apply simp? oops
lemma "word_rotl 2 1 = (0b0100::4 word)" apply simp? oops
lemma "word_roti (- 2) 1 = (0b0100::4 word)" apply simp? oops

lemma "(x AND 0xff00) OR (x AND 0x00ff) = (x::16 word)"
proof -
  have "(x AND 0xff00) OR (x AND 0x00ff) = x AND (0xff00 OR 0x00ff)"
    by (simp only: word_ao_dist2)
  also have "0xff00 OR 0x00ff = (-1::16 word)"
    by simp
  also have "x AND -1 = x"
    by simp
  finally show ?thesis .
qed

text "alternative proof using bitwise expansion"

lemma "(x AND 0xff00) OR (x AND 0x00ff) = (x::16 word)"
  by word_bitwise

text "more proofs using bitwise expansion"

lemma "(x AND NOT 3) >> 4 << 2 = ((x >> 2) AND NOT 3)"
  for x :: "10 word"
  by word_bitwise

lemma "((x AND -8) >> 3) AND 7 = (x AND 56) >> 3"
  for x :: "12 word"
  by word_bitwise

text "some problems require further reasoning after bit expansion"

lemma "x \<le> 42 \<Longrightarrow> x \<le> 89"
  for x :: "8 word"
  apply word_bitwise
  apply blast
  done

lemma "(x AND 1023) = 0 \<Longrightarrow> x \<le> -1024"
  for x :: word32
  apply word_bitwise
  apply clarsimp
  done

text "operations like shifts by non-numerals will expose some internal list
 representations but may still be easy to solve"

lemma shiftr_overflow: "32 \<le> a \<Longrightarrow> b >> a = 0"
  for b :: word32
  apply word_bitwise
  apply simp
  done

end