(*
 * Copyright Thomas Sewell, NICTA and Sascha Boehme, TU Muenchen
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Bitwise
  imports
    "HOL-Library.Word"
    More_Arithmetic
    Reversed_Bit_Lists
begin

text \<open>Helper constants used in defining addition\<close>

definition xor3 :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool"
  where "xor3 a b c = (a = (b = c))"

definition carry :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool"
  where "carry a b c = ((a \<and> (b \<or> c)) \<or> (b \<and> c))"

lemma carry_simps:
  "carry True a b = (a \<or> b)"
  "carry a True b = (a \<or> b)"
  "carry a b True = (a \<or> b)"
  "carry False a b = (a \<and> b)"
  "carry a False b = (a \<and> b)"
  "carry a b False = (a \<and> b)"
  by (auto simp add: carry_def)

lemma xor3_simps:
  "xor3 True a b = (a = b)"
  "xor3 a True b = (a = b)"
  "xor3 a b True = (a = b)"
  "xor3 False a b = (a \<noteq> b)"
  "xor3 a False b = (a \<noteq> b)"
  "xor3 a b False = (a \<noteq> b)"
  by (simp_all add: xor3_def)

text \<open>Breaking up word equalities into equalities on their
  bit lists. Equalities are generated and manipulated in the
  reverse order to \<^const>\<open>to_bl\<close>.\<close>

lemma bl_word_sub: "to_bl (x - y) = to_bl (x + (- y))"
  by simp

lemma rbl_word_1: "rev (to_bl (1 :: 'a::len word)) = takefill False (LENGTH('a)) [True]"
  apply (rule_tac s="rev (to_bl (word_succ (0 :: 'a word)))" in trans)
   apply simp
  apply (simp only: rtb_rbl_ariths(1)[OF refl])
  apply simp
  apply (case_tac "LENGTH('a)")
   apply simp
  apply (simp add: takefill_alt)
  done

lemma rbl_word_if: "rev (to_bl (if P then x else y)) = map2 (If P) (rev (to_bl x)) (rev (to_bl y))"
  by (simp add: split_def)

lemma rbl_add_carry_Cons:
  "(if car then rbl_succ else id) (rbl_add (x # xs) (y # ys)) =
    xor3 x y car # (if carry x y car then rbl_succ else id) (rbl_add xs ys)"
  by (simp add: carry_def xor3_def)

lemma rbl_add_suc_carry_fold:
  "length xs = length ys \<Longrightarrow>
    \<forall>car. (if car then rbl_succ else id) (rbl_add xs ys) =
      (foldr (\<lambda>(x, y) res car. xor3 x y car # res (carry x y car)) (zip xs ys) (\<lambda>_. [])) car"
  apply (erule list_induct2)
   apply simp
  apply (simp only: rbl_add_carry_Cons)
  apply simp
  done

lemma to_bl_plus_carry:
  "to_bl (x + y) =
    rev (foldr (\<lambda>(x, y) res car. xor3 x y car # res (carry x y car))
      (rev (zip (to_bl x) (to_bl y))) (\<lambda>_. []) False)"
  using rbl_add_suc_carry_fold[where xs="rev (to_bl x)" and ys="rev (to_bl y)"]
  apply (simp add: word_add_rbl[OF refl refl])
  apply (drule_tac x=False in spec)
  apply (simp add: zip_rev)
  done

definition "rbl_plus cin xs ys =
  foldr (\<lambda>(x, y) res car. xor3 x y car # res (carry x y car)) (zip xs ys) (\<lambda>_. []) cin"

lemma rbl_plus_simps:
  "rbl_plus cin (x # xs) (y # ys) = xor3 x y cin # rbl_plus (carry x y cin) xs ys"
  "rbl_plus cin [] ys = []"
  "rbl_plus cin xs [] = []"
  by (simp_all add: rbl_plus_def)

lemma rbl_word_plus: "rev (to_bl (x + y)) = rbl_plus False (rev (to_bl x)) (rev (to_bl y))"
  by (simp add: rbl_plus_def to_bl_plus_carry zip_rev)

definition "rbl_succ2 b xs = (if b then rbl_succ xs else xs)"

lemma rbl_succ2_simps:
  "rbl_succ2 b [] = []"
  "rbl_succ2 b (x # xs) = (b \<noteq> x) # rbl_succ2 (x \<and> b) xs"
  by (simp_all add: rbl_succ2_def)

lemma twos_complement: "- x = word_succ (NOT x)"
  using arg_cong[OF word_add_not[where x=x], where f="\<lambda>a. a - x + 1"]
  by (simp add: word_succ_p1 word_sp_01[unfolded word_succ_p1] del: word_add_not)

lemma rbl_word_neg: "rev (to_bl (- x)) = rbl_succ2 True (map Not (rev (to_bl x)))"
  for x :: \<open>'a::len word\<close>
  by (simp add: twos_complement word_succ_rbl[OF refl] bl_word_not rev_map rbl_succ2_def)

lemma rbl_word_cat:
  "rev (to_bl (word_cat x y :: 'a::len word)) =
    takefill False (LENGTH('a)) (rev (to_bl y) @ rev (to_bl x))"
  by (simp add: word_cat_bl word_rev_tf)

lemma rbl_word_slice:
  "rev (to_bl (slice n w :: 'a::len word)) =
    takefill False (LENGTH('a)) (drop n (rev (to_bl w)))"
  apply (simp add: slice_take word_rev_tf rev_take)
  apply (cases "n < LENGTH('b)", simp_all)
  done

lemma rbl_word_ucast:
  "rev (to_bl (ucast x :: 'a::len word)) = takefill False (LENGTH('a)) (rev (to_bl x))"
  apply (simp add: to_bl_ucast takefill_alt)
  apply (simp add: rev_drop)
  apply (cases "LENGTH('a) < LENGTH('b)")
   apply simp_all
  done

lemma rbl_shiftl:
  "rev (to_bl (w << n)) = takefill False (size w) (replicate n False @ rev (to_bl w))"
  by (simp add: bl_shiftl takefill_alt word_size rev_drop)

lemma rbl_shiftr:
  "rev (to_bl (w >> n)) = takefill False (size w) (drop n (rev (to_bl w)))"
  by (simp add: shiftr_slice rbl_word_slice word_size)

definition "drop_nonempty v n xs = (if n < length xs then drop n xs else [last (v # xs)])"

lemma drop_nonempty_simps:
  "drop_nonempty v (Suc n) (x # xs) = drop_nonempty x n xs"
  "drop_nonempty v 0 (x # xs) = (x # xs)"
  "drop_nonempty v n [] = [v]"
  by (simp_all add: drop_nonempty_def)

definition "takefill_last x n xs = takefill (last (x # xs)) n xs"

lemma takefill_last_simps:
  "takefill_last z (Suc n) (x # xs) = x # takefill_last x n xs"
  "takefill_last z 0 xs = []"
  "takefill_last z n [] = replicate n z"
  by (simp_all add: takefill_last_def) (simp_all add: takefill_alt)

lemma rbl_sshiftr:
  "rev (to_bl (w >>> n)) = takefill_last False (size w) (drop_nonempty False n (rev (to_bl w)))"
  apply (cases "n < size w")
   apply (simp add: bl_sshiftr takefill_last_def word_size
      takefill_alt rev_take last_rev
      drop_nonempty_def)
  apply (subgoal_tac "(w >>> n) = of_bl (replicate (size w) (msb w))")
   apply (simp add: word_size takefill_last_def takefill_alt
      last_rev word_msb_alt word_rev_tf
      drop_nonempty_def take_Cons')
   apply (case_tac "LENGTH('a)", simp_all)
  apply (rule word_eqI)
  apply (simp add: nth_sshiftr word_size test_bit_of_bl
      msb_nth)
  done

lemma nth_word_of_int:
  "(word_of_int x :: 'a::len word) !! n = (n < LENGTH('a) \<and> bin_nth x n)"
  apply (simp add: test_bit_bl word_size to_bl_of_bin)
  apply (subst conj_cong[OF refl], erule bin_nth_bl)
  apply auto
  done

lemma nth_scast:
  "(scast (x :: 'a::len word) :: 'b::len word) !! n =
    (n < LENGTH('b) \<and>
    (if n < LENGTH('a) - 1 then x !! n
     else x !! (LENGTH('a) - 1)))"
  apply transfer
  apply (auto simp add: bit_signed_take_bit_iff min_def)
  done

lemma rbl_word_scast:
  "rev (to_bl (scast x :: 'a::len word)) = takefill_last False (LENGTH('a)) (rev (to_bl x))"
  apply (rule nth_equalityI)
   apply (simp add: word_size takefill_last_def)
  apply (clarsimp simp: nth_scast takefill_last_def
      nth_takefill word_size rev_nth to_bl_nth)
  apply (cases "LENGTH('b)")
   apply simp
  apply (clarsimp simp: less_Suc_eq_le linorder_not_less
      last_rev word_msb_alt[symmetric]
      msb_nth)
  done

definition rbl_mul :: "bool list \<Rightarrow> bool list \<Rightarrow> bool list"
  where "rbl_mul xs ys = foldr (\<lambda>x sm. rbl_plus False (map ((\<and>) x) ys) (False # sm)) xs []"

lemma rbl_mul_simps:
  "rbl_mul (x # xs) ys = rbl_plus False (map ((\<and>) x) ys) (False # rbl_mul xs ys)"
  "rbl_mul [] ys = []"
  by (simp_all add: rbl_mul_def)

lemma takefill_le2: "length xs \<le> n \<Longrightarrow> takefill x m (takefill x n xs) = takefill x m xs"
  by (simp add: takefill_alt replicate_add[symmetric])

lemma take_rbl_plus: "\<forall>n b. take n (rbl_plus b xs ys) = rbl_plus b (take n xs) (take n ys)"
  apply (simp add: rbl_plus_def take_zip[symmetric])
  apply (rule_tac list="zip xs ys" in list.induct)
   apply simp
  apply (clarsimp simp: split_def)
  apply (case_tac n, simp_all)
  done

lemma word_rbl_mul_induct:
  "length xs \<le> size y \<Longrightarrow>
    rbl_mul xs (rev (to_bl y)) = take (length xs) (rev (to_bl (of_bl (rev xs) * y)))"
  for y :: "'a::len word"
proof (induct xs)
  case Nil
  show ?case by (simp add: rbl_mul_simps)
next
  case (Cons z zs)

  have rbl_word_plus': "to_bl (x + y) = rev (rbl_plus False (rev (to_bl x)) (rev (to_bl y)))"
    for x y :: "'a word"
    by (simp add: rbl_word_plus[symmetric])

  have mult_bit: "to_bl (of_bl [z] * y) = map ((\<and>) z) (to_bl y)"
    by (cases z) (simp cong: map_cong, simp add: map_replicate_const cong: map_cong)

  have shiftl: "of_bl xs * 2 * y = (of_bl xs * y) << 1" for xs
    by (simp add: shiftl_t2n)

  have zip_take_triv: "\<And>xs ys n. n = length ys \<Longrightarrow> zip (take n xs) ys = zip xs ys"
    by (rule nth_equalityI) simp_all

  from Cons show ?case
    apply (simp add: trans [OF of_bl_append add.commute]
        rbl_mul_simps rbl_word_plus' distrib_right mult_bit shiftl rbl_shiftl)
    apply (simp add: takefill_alt word_size rev_map take_rbl_plus min_def)
    apply (simp add: rbl_plus_def zip_take_triv)
    done
qed

lemma rbl_word_mul: "rev (to_bl (x * y)) = rbl_mul (rev (to_bl x)) (rev (to_bl y))"
  for x :: "'a::len word"
  using word_rbl_mul_induct[where xs="rev (to_bl x)" and y=y] by (simp add: word_size)

text \<open>Breaking up inequalities into bitlist properties.\<close>

definition
  "rev_bl_order F xs ys =
     (length xs = length ys \<and>
       ((xs = ys \<and> F)
          \<or> (\<exists>n < length xs. drop (Suc n) xs = drop (Suc n) ys
                   \<and> \<not> xs ! n \<and> ys ! n)))"

lemma rev_bl_order_simps:
  "rev_bl_order F [] [] = F"
  "rev_bl_order F (x # xs) (y # ys) = rev_bl_order ((y \<and> \<not> x) \<or> ((y \<or> \<not> x) \<and> F)) xs ys"
   apply (simp_all add: rev_bl_order_def)
  apply (rule conj_cong[OF refl])
  apply (cases "xs = ys")
   apply (simp add: nth_Cons')
   apply blast
  apply (simp add: nth_Cons')
  apply safe
   apply (rule_tac x="n - 1" in exI)
   apply simp
  apply (rule_tac x="Suc n" in exI)
  apply simp
  done

lemma rev_bl_order_rev_simp:
  "length xs = length ys \<Longrightarrow>
   rev_bl_order F (xs @ [x]) (ys @ [y]) = ((y \<and> \<not> x) \<or> ((y \<or> \<not> x) \<and> rev_bl_order F xs ys))"
  by (induct arbitrary: F rule: list_induct2) (auto simp: rev_bl_order_simps)

lemma rev_bl_order_bl_to_bin:
  "length xs = length ys \<Longrightarrow>
    rev_bl_order True xs ys = (bl_to_bin (rev xs) \<le> bl_to_bin (rev ys)) \<and>
    rev_bl_order False xs ys = (bl_to_bin (rev xs) < bl_to_bin (rev ys))"
  apply (induct xs ys rule: list_induct2)
   apply (simp_all add: rev_bl_order_simps bl_to_bin_app_cat concat_bit_Suc)
  apply (auto simp add: bl_to_bin_def add1_zle_eq)
  done

lemma word_le_rbl: "x \<le> y \<longleftrightarrow> rev_bl_order True (rev (to_bl x)) (rev (to_bl y))"
  for x y :: "'a::len word"
  by (simp add: rev_bl_order_bl_to_bin word_le_def)

lemma word_less_rbl: "x < y \<longleftrightarrow> rev_bl_order False (rev (to_bl x)) (rev (to_bl y))"
  for x y :: "'a::len word"
  by (simp add: word_less_alt rev_bl_order_bl_to_bin)

definition "map_last f xs = (if xs = [] then [] else butlast xs @ [f (last xs)])"

lemma map_last_simps:
  "map_last f [] = []"
  "map_last f [x] = [f x]"
  "map_last f (x # y # zs) = x # map_last f (y # zs)"
  by (simp_all add: map_last_def)

lemma word_sle_rbl:
  "x <=s y \<longleftrightarrow> rev_bl_order True (map_last Not (rev (to_bl x))) (map_last Not (rev (to_bl y)))"
  using word_msb_alt[where w=x] word_msb_alt[where w=y]
  apply (simp add: word_sle_msb_le word_le_rbl)
  apply (subgoal_tac "length (to_bl x) = length (to_bl y)")
   apply (cases "to_bl x", simp)
   apply (cases "to_bl y", simp)
   apply (clarsimp simp: map_last_def rev_bl_order_rev_simp)
   apply auto
  done

lemma word_sless_rbl:
  "x <s y \<longleftrightarrow> rev_bl_order False (map_last Not (rev (to_bl x))) (map_last Not (rev (to_bl y)))"
  using word_msb_alt[where w=x] word_msb_alt[where w=y]
  apply (simp add: word_sless_msb_less word_less_rbl)
  apply (subgoal_tac "length (to_bl x) = length (to_bl y)")
   apply (cases "to_bl x", simp)
   apply (cases "to_bl y", simp)
   apply (clarsimp simp: map_last_def rev_bl_order_rev_simp)
   apply auto
  done

text \<open>Lemmas for unpacking \<^term>\<open>rev (to_bl n)\<close> for numerals n and also
  for irreducible values and expressions.\<close>

lemma rev_bin_to_bl_simps:
  "rev (bin_to_bl 0 x) = []"
  "rev (bin_to_bl (Suc n) (numeral (num.Bit0 nm))) = False # rev (bin_to_bl n (numeral nm))"
  "rev (bin_to_bl (Suc n) (numeral (num.Bit1 nm))) = True # rev (bin_to_bl n (numeral nm))"
  "rev (bin_to_bl (Suc n) (numeral (num.One))) = True # replicate n False"
  "rev (bin_to_bl (Suc n) (- numeral (num.Bit0 nm))) = False # rev (bin_to_bl n (- numeral nm))"
  "rev (bin_to_bl (Suc n) (- numeral (num.Bit1 nm))) =
    True # rev (bin_to_bl n (- numeral (nm + num.One)))"
  "rev (bin_to_bl (Suc n) (- numeral (num.One))) = True # replicate n True"
  "rev (bin_to_bl (Suc n) (- numeral (num.Bit0 nm + num.One))) =
    True # rev (bin_to_bl n (- numeral (nm + num.One)))"
  "rev (bin_to_bl (Suc n) (- numeral (num.Bit1 nm + num.One))) =
    False # rev (bin_to_bl n (- numeral (nm + num.One)))"
  "rev (bin_to_bl (Suc n) (- numeral (num.One + num.One))) =
    False # rev (bin_to_bl n (- numeral num.One))"
  by (simp_all add: bin_to_bl_aux_append bin_to_bl_zero_aux bin_to_bl_minus1_aux replicate_append_same)

lemma to_bl_upt: "to_bl x = rev (map ((!!) x) [0 ..< size x])"
  apply (rule nth_equalityI)
   apply (simp add: word_size)
  apply (auto simp: to_bl_nth word_size rev_nth)
  done

lemma rev_to_bl_upt: "rev (to_bl x) = map ((!!) x) [0 ..< size x]"
  by (simp add: to_bl_upt)

lemma upt_eq_list_intros:
  "j \<le> i \<Longrightarrow> [i ..< j] = []"
  "i = x \<Longrightarrow> x < j \<Longrightarrow> [x + 1 ..< j] = xs \<Longrightarrow> [i ..< j] = (x # xs)"
  by (simp_all add: upt_eq_Cons_conv)

subsection \<open>Tactic definition\<close>

lemma if_bool_simps:
  "If p True y = (p \<or> y) \<and> If p False y = (\<not> p \<and> y) \<and>
    If p y True = (p \<longrightarrow> y) \<and> If p y False = (p \<and> y)"
  by auto

ML \<open>
structure Word_Bitwise_Tac =
struct

val word_ss = simpset_of \<^theory_context>\<open>Word\<close>;

fun mk_nat_clist ns =
  fold_rev (Thm.mk_binop \<^cterm>\<open>Cons :: nat \<Rightarrow> _\<close>)
    ns \<^cterm>\<open>[] :: nat list\<close>;

fun upt_conv ctxt ct =
  case Thm.term_of ct of
    (\<^const>\<open>upt\<close> $ n $ m) =>
      let
        val (i, j) = apply2 (snd o HOLogic.dest_number) (n, m);
        val ns = map (Numeral.mk_cnumber \<^ctyp>\<open>nat\<close>) (i upto (j - 1))
          |> mk_nat_clist;
        val prop =
          Thm.mk_binop \<^cterm>\<open>(=) :: nat list \<Rightarrow> _\<close> ct ns
          |> Thm.apply \<^cterm>\<open>Trueprop\<close>;
      in
        try (fn () =>
          Goal.prove_internal ctxt [] prop
            (K (REPEAT_DETERM (resolve_tac ctxt @{thms upt_eq_list_intros} 1
                ORELSE simp_tac (put_simpset word_ss ctxt) 1))) |> mk_meta_eq) ()
      end
  | _ => NONE;

val expand_upt_simproc =
  Simplifier.make_simproc \<^context> "expand_upt"
   {lhss = [\<^term>\<open>upt x y\<close>], proc = K upt_conv};

fun word_len_simproc_fn ctxt ct =
  (case Thm.term_of ct of
    Const (\<^const_name>\<open>len_of\<close>, _) $ t =>
     (let
        val T = fastype_of t |> dest_Type |> snd |> the_single
        val n = Numeral.mk_cnumber \<^ctyp>\<open>nat\<close> (Word_Lib.dest_binT T);
        val prop =
          Thm.mk_binop \<^cterm>\<open>(=) :: nat \<Rightarrow> _\<close> ct n
          |> Thm.apply \<^cterm>\<open>Trueprop\<close>;
      in
        Goal.prove_internal ctxt [] prop (K (simp_tac (put_simpset word_ss ctxt) 1))
        |> mk_meta_eq |> SOME
      end handle TERM _ => NONE | TYPE _ => NONE)
  | _ => NONE);

val word_len_simproc =
  Simplifier.make_simproc \<^context> "word_len"
   {lhss = [\<^term>\<open>len_of x\<close>], proc = K word_len_simproc_fn};

(* convert 5 or nat 5 to Suc 4 when n_sucs = 1, Suc (Suc 4) when n_sucs = 2,
   or just 5 (discarding nat) when n_sucs = 0 *)

fun nat_get_Suc_simproc_fn n_sucs ctxt ct =
  let
    val (f, arg) = dest_comb (Thm.term_of ct);
    val n =
      (case arg of \<^term>\<open>nat\<close> $ n => n | n => n)
      |> HOLogic.dest_number |> snd;
    val (i, j) = if n > n_sucs then (n_sucs, n - n_sucs) else (n, 0);
    val arg' = funpow i HOLogic.mk_Suc (HOLogic.mk_number \<^typ>\<open>nat\<close> j);
    val _ = if arg = arg' then raise TERM ("", []) else ();
    fun propfn g =
      HOLogic.mk_eq (g arg, g arg')
      |> HOLogic.mk_Trueprop |> Thm.cterm_of ctxt;
    val eq1 =
      Goal.prove_internal ctxt [] (propfn I)
        (K (simp_tac (put_simpset word_ss ctxt) 1));
  in
    Goal.prove_internal ctxt [] (propfn (curry (op $) f))
      (K (simp_tac (put_simpset HOL_ss ctxt addsimps [eq1]) 1))
    |> mk_meta_eq |> SOME
  end handle TERM _ => NONE;

fun nat_get_Suc_simproc n_sucs ts =
  Simplifier.make_simproc \<^context> "nat_get_Suc"
   {lhss = map (fn t => t $ \<^term>\<open>n :: nat\<close>) ts,
    proc = K (nat_get_Suc_simproc_fn n_sucs)};

val no_split_ss =
  simpset_of (put_simpset HOL_ss \<^context>
    |> Splitter.del_split @{thm if_split});

val expand_word_eq_sss =
  (simpset_of (put_simpset HOL_basic_ss \<^context> addsimps
       @{thms word_eq_rbl_eq word_le_rbl word_less_rbl word_sle_rbl word_sless_rbl}),
  map simpset_of [
   put_simpset no_split_ss \<^context> addsimps
    @{thms rbl_word_plus rbl_word_and rbl_word_or rbl_word_not
                                rbl_word_neg bl_word_sub rbl_word_xor
                                rbl_word_cat rbl_word_slice rbl_word_scast
                                rbl_word_ucast rbl_shiftl rbl_shiftr rbl_sshiftr
                                rbl_word_if},
   put_simpset no_split_ss \<^context> addsimps
    @{thms to_bl_numeral to_bl_neg_numeral to_bl_0 rbl_word_1},
   put_simpset no_split_ss \<^context> addsimps
    @{thms rev_rev_ident rev_replicate rev_map to_bl_upt word_size}
          addsimprocs [word_len_simproc],
   put_simpset no_split_ss \<^context> addsimps
    @{thms list.simps split_conv replicate.simps list.map
                                zip_Cons_Cons zip_Nil drop_Suc_Cons drop_0 drop_Nil
                                foldr.simps list.map zip.simps(1) zip_Nil zip_Cons_Cons takefill_Suc_Cons
                                takefill_Suc_Nil takefill.Z rbl_succ2_simps
                                rbl_plus_simps rev_bin_to_bl_simps append.simps
                                takefill_last_simps drop_nonempty_simps
                                rev_bl_order_simps}
          addsimprocs [expand_upt_simproc,
                       nat_get_Suc_simproc 4
                         [\<^term>\<open>replicate\<close>, \<^term>\<open>takefill x\<close>,
                          \<^term>\<open>drop\<close>, \<^term>\<open>bin_to_bl\<close>,
                          \<^term>\<open>takefill_last x\<close>,
                          \<^term>\<open>drop_nonempty x\<close>]],
    put_simpset no_split_ss \<^context> addsimps @{thms xor3_simps carry_simps if_bool_simps}
  ])

fun tac ctxt =
  let
    val (ss, sss) = expand_word_eq_sss;
  in
    foldr1 (op THEN_ALL_NEW)
      ((CHANGED o safe_full_simp_tac (put_simpset ss ctxt)) ::
        map (fn ss => safe_full_simp_tac (put_simpset ss ctxt)) sss)
  end;

end
\<close>

method_setup word_bitwise =
  \<open>Scan.succeed (fn ctxt => Method.SIMPLE_METHOD (Word_Bitwise_Tac.tac ctxt 1))\<close>
  "decomposer for word equalities and inequalities into bit propositions"

end


(*  Title:      ZF/Sum.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section\<open>Disjoint Sums\<close>

theory Sum imports Bool equalities begin

text\<open>And the "Part" primitive for simultaneous recursive type definitions\<close>

definition sum :: "[i,i]=>i" (infixr "+" 65) where
     "A+B == {0}*A \<union> {1}*B"

definition Inl :: "i=>i" where
     "Inl(a) == <0,a>"

definition Inr :: "i=>i" where
     "Inr(b) == <1,b>"

definition "case" :: "[i=>i, i=>i, i]=>i" where
     "case(c,d) == (%<y,z>. cond(y, d(z), c(z)))"

  (*operator for selecting out the various summands*)
definition Part :: "[i,i=>i] => i" where
     "Part(A,h) == {x \<in> A. \<exists>z. x = h(z)}"

subsection\<open>Rules for the @{term Part} Primitive\<close>

lemma Part_iff:
    "a \<in> Part(A,h) \<longleftrightarrow> a \<in> A & (\<exists>y. a=h(y))"
apply (unfold Part_def)
apply (rule separation)
done

lemma Part_eqI [intro]:
    "[| a \<in> A;  a=h(b) |] ==> a \<in> Part(A,h)"
by (unfold Part_def, blast)

lemmas PartI = refl [THEN [2] Part_eqI]

lemma PartE [elim!]:
    "[| a \<in> Part(A,h);  !!z. [| a \<in> A;  a=h(z) |] ==> P
     |] ==> P"
apply (unfold Part_def, blast)
done

lemma Part_subset: "Part(A,h) \<subseteq> A"
apply (unfold Part_def)
apply (rule Collect_subset)
done

subsection\<open>Rules for Disjoint Sums\<close>

lemmas sum_defs = sum_def Inl_def Inr_def case_def

lemma Sigma_bool: "Sigma(bool,C) = C(0) + C(1)"
by (unfold bool_def sum_def, blast)

(** Introduction rules for the injections **)

lemma InlI [intro!,simp,TC]: "a \<in> A ==> Inl(a) \<in> A+B"
by (unfold sum_defs, blast)

lemma InrI [intro!,simp,TC]: "b \<in> B ==> Inr(b) \<in> A+B"
by (unfold sum_defs, blast)

(** Elimination rules **)

lemma sumE [elim!]:
    "[| u \<in> A+B;
        !!x. [| x \<in> A;  u=Inl(x) |] ==> P;
        !!y. [| y \<in> B;  u=Inr(y) |] ==> P
     |] ==> P"
by (unfold sum_defs, blast)

(** Injection and freeness equivalences, for rewriting **)

lemma Inl_iff [iff]: "Inl(a)=Inl(b) \<longleftrightarrow> a=b"
by (simp add: sum_defs)

lemma Inr_iff [iff]: "Inr(a)=Inr(b) \<longleftrightarrow> a=b"
by (simp add: sum_defs)

lemma Inl_Inr_iff [simp]: "Inl(a)=Inr(b) \<longleftrightarrow> False"
by (simp add: sum_defs)

lemma Inr_Inl_iff [simp]: "Inr(b)=Inl(a) \<longleftrightarrow> False"
by (simp add: sum_defs)

lemma sum_empty [simp]: "0+0 = 0"
by (simp add: sum_defs)

(*Injection and freeness rules*)

lemmas Inl_inject = Inl_iff [THEN iffD1]
lemmas Inr_inject = Inr_iff [THEN iffD1]
lemmas Inl_neq_Inr = Inl_Inr_iff [THEN iffD1, THEN FalseE, elim!]
lemmas Inr_neq_Inl = Inr_Inl_iff [THEN iffD1, THEN FalseE, elim!]

lemma InlD: "Inl(a): A+B ==> a \<in> A"
by blast

lemma InrD: "Inr(b): A+B ==> b \<in> B"
by blast

lemma sum_iff: "u \<in> A+B \<longleftrightarrow> (\<exists>x. x \<in> A & u=Inl(x)) | (\<exists>y. y \<in> B & u=Inr(y))"
by blast

lemma Inl_in_sum_iff [simp]: "(Inl(x) \<in> A+B) \<longleftrightarrow> (x \<in> A)"
by auto

lemma Inr_in_sum_iff [simp]: "(Inr(y) \<in> A+B) \<longleftrightarrow> (y \<in> B)"
by auto

lemma sum_subset_iff: "A+B \<subseteq> C+D \<longleftrightarrow> A<=C & B<=D"
by blast

lemma sum_equal_iff: "A+B = C+D \<longleftrightarrow> A=C & B=D"
by (simp add: extension sum_subset_iff, blast)

lemma sum_eq_2_times: "A+A = 2*A"
by (simp add: sum_def, blast)

subsection\<open>The Eliminator: @{term case}\<close>

lemma case_Inl [simp]: "case(c, d, Inl(a)) = c(a)"
by (simp add: sum_defs)

lemma case_Inr [simp]: "case(c, d, Inr(b)) = d(b)"
by (simp add: sum_defs)

lemma case_type [TC]:
    "[| u \<in> A+B;
        !!x. x \<in> A ==> c(x): C(Inl(x));
        !!y. y \<in> B ==> d(y): C(Inr(y))
     |] ==> case(c,d,u) \<in> C(u)"
by auto

lemma expand_case: "u \<in> A+B ==>
        R(case(c,d,u)) \<longleftrightarrow>
        ((\<forall>x\<in>A. u = Inl(x) \<longrightarrow> R(c(x))) &
        (\<forall>y\<in>B. u = Inr(y) \<longrightarrow> R(d(y))))"
by auto

lemma case_cong:
  "[| z \<in> A+B;
      !!x. x \<in> A ==> c(x)=c'(x);
      !!y. y \<in> B ==> d(y)=d'(y)
   |] ==> case(c,d,z) = case(c',d',z)"
by auto

lemma case_case: "z \<in> A+B ==>
        case(c, d, case(%x. Inl(c'(x)), %y. Inr(d'(y)), z)) =
        case(%x. c(c'(x)), %y. d(d'(y)), z)"
by auto

subsection\<open>More Rules for @{term "Part(A,h)"}\<close>

lemma Part_mono: "A<=B ==> Part(A,h)<=Part(B,h)"
by blast

lemma Part_Collect: "Part(Collect(A,P), h) = Collect(Part(A,h), P)"
by blast

lemmas Part_CollectE =
     Part_Collect [THEN equalityD1, THEN subsetD, THEN CollectE]

lemma Part_Inl: "Part(A+B,Inl) = {Inl(x). x \<in> A}"
by blast

lemma Part_Inr: "Part(A+B,Inr) = {Inr(y). y \<in> B}"
by blast

lemma PartD1: "a \<in> Part(A,h) ==> a \<in> A"
by (simp add: Part_def)

lemma Part_id: "Part(A,%x. x) = A"
by blast

lemma Part_Inr2: "Part(A+B, %x. Inr(h(x))) = {Inr(y). y \<in> Part(B,h)}"
by blast

lemma Part_sum_equality: "C \<subseteq> A+B ==> Part(C,Inl) \<union> Part(C,Inr) = C"
by blast

end


theory SubstExp
  imports WellTypedExp
begin

    (*
      ####################################
        P2. variables in expressions
      ####################################
    *)

fun lam_vars :: "p_exp \<Rightarrow> string set" where
  "lam_vars (ConstExp c) = {}"
| "lam_vars (OpExp xop) = {}"
| "lam_vars (VarExp x v) = {}"
| "lam_vars (PairExp e1 e2) = lam_vars e1 \<union> lam_vars e2"
| "lam_vars (IfExp e1 e2 e3) = lam_vars e1 \<union> lam_vars e2 \<union> lam_vars e3"
| "lam_vars (LamExp x e) = lam_vars e \<union> {x}"
| "lam_vars (AppExp e1 e2) = lam_vars e1 \<union> lam_vars e2"

  (*
definition subst_name_match where
  "subst_name_match x x' v = (x = x' \<and> v = NoRef)"
  *)
fun subst_exp :: "p_exp \<Rightarrow> string \<Rightarrow> p_exp \<Rightarrow> p_exp" where
  "subst_exp (ConstExp c) x e = ConstExp c"
| "subst_exp (OpExp xop) x e = OpExp xop"
| "subst_exp (VarExp x' v) x e = (if x = x' then e else VarExp x' v)"
| "subst_exp (PairExp e1 e2) x e = (PairExp (subst_exp e1 x e) (subst_exp e2 x e))"
| "subst_exp (IfExp e1 e2 e3) x e = (IfExp (subst_exp e1 x e) (subst_exp e2 x e) (subst_exp e3 x e))"
| "subst_exp (LamExp x' e') x e = (if x = x' then LamExp x' e' else LamExp x' (subst_exp e' x e))"
| "subst_exp (AppExp e1 e2) x e = (AppExp (subst_exp e1 x e) (subst_exp e2 x e))"

fun deep_alpha_rename :: "p_exp \<Rightarrow> string \<Rightarrow> string \<Rightarrow> p_exp" where
  "deep_alpha_rename (ConstExp c) x y = ConstExp c"
| "deep_alpha_rename (OpExp xop) x y = OpExp xop"
| "deep_alpha_rename (VarExp x' v) x y = (if x = x' then VarExp y v else VarExp x' v)"
| "deep_alpha_rename (PairExp e1 e2) x y = PairExp (deep_alpha_rename e1 x y) (deep_alpha_rename e2 x y)"
| "deep_alpha_rename (IfExp e1 e2 e3) x y =
  IfExp (deep_alpha_rename e1 x y) (deep_alpha_rename e2 x y) (deep_alpha_rename e3 x y)"
| "deep_alpha_rename (LamExp x' e) x y = (if x = x' then LamExp y (deep_alpha_rename e x y)
  else LamExp x' (deep_alpha_rename e x y))"
| "deep_alpha_rename (AppExp e1 e2) x y = AppExp (deep_alpha_rename e1 x y) (deep_alpha_rename e2 x y)"

fun lam_var_remove :: "p_exp \<Rightarrow> string \<Rightarrow> string \<Rightarrow> p_exp" where
  "lam_var_remove (ConstExp c) x y = ConstExp c"
| "lam_var_remove (OpExp xop) x y = OpExp xop"
| "lam_var_remove (VarExp x' v) x y = VarExp x' v"
| "lam_var_remove (PairExp e1 e2) x y = PairExp (lam_var_remove e1 x y) (lam_var_remove e2 x y)"
| "lam_var_remove (IfExp e1 e2 e3) x y = IfExp (lam_var_remove e1 x y) (lam_var_remove e2 x y) (lam_var_remove e3 x y)"
| "lam_var_remove (LamExp x' e) x y = (if x = x' then LamExp y (deep_alpha_rename e x y)
  else LamExp x' (lam_var_remove e x y))"
| "lam_var_remove (AppExp e1 e2) x y = AppExp (lam_var_remove e1 x y) (lam_var_remove e2 x y)"

fun pre_vars :: "('a * 'a) list \<Rightarrow> 'a set" where
  "pre_vars Nil = {}"
| "pre_vars ((x, y) # t) = {x} \<union> pre_vars t"

fun post_vars :: "('a * 'a) list \<Rightarrow> 'a set" where
  "post_vars Nil = {}"
| "post_vars ((x, y) # t) = {y} \<union> post_vars t"

fun unique_post_vars :: "('a * 'a) list \<Rightarrow> bool" where
  "unique_post_vars Nil = True"
| "unique_post_vars ((x, y) # t) = (y \<notin> post_vars t \<and> unique_post_vars t)"

fun lam_var_list_remove :: "p_exp \<Rightarrow> (string * string) list \<Rightarrow> p_exp" where
  "lam_var_list_remove e Nil = e"
| "lam_var_list_remove e ((x, y) # t) = lam_var_list_remove (lam_var_remove e x y) t"

  (***** a valid substitution must rename all lambdas in e to avoid the free variables of e' ****)

definition safe_subst_exp :: "p_exp \<Rightarrow> string \<Rightarrow> p_exp \<Rightarrow> p_exp \<Rightarrow> bool" where
  "safe_subst_exp e x e' e_f = (\<exists> vl. unique_post_vars vl \<and> pre_vars vl = lam_vars e \<and>
    x \<notin> ref_vars e \<and> post_vars vl \<inter> (lam_vars e \<union> free_vars e \<union> free_vars e' \<union> ref_vars e \<union> ref_vars e') = {} \<and>
    subst_exp (lam_var_list_remove e vl) x e' = e_f)"

lemma eq_own: "\<exists> r. is_own r"
  apply (rule_tac x="OwnPerm" in exI)
  apply (simp add: is_own_def)
  done

    (*
      ####################################
        P11. start for substitution type preservation
      ####################################
    *)

lemma no_subst_ref_vars: "\<lbrakk> x \<notin> free_vars e; y \<notin> ref_vars e \<rbrakk> \<Longrightarrow> y \<notin> ref_vars (subst_exp e x e')"
  apply (induct e)
        apply (auto)
 (* apply (simp add: subst_name_match_def)*)
  done

lemma subst_ref_vars: "\<lbrakk> y \<notin> ref_vars e; y \<notin> ref_vars e' \<rbrakk> \<Longrightarrow> y \<notin> ref_vars (subst_exp e x e')"
  apply (induct e)
        apply (auto)
  done

lemma subst_type_preserve_no_fv: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; x \<notin> free_vars e \<rbrakk> \<Longrightarrow> well_typed env r_s1 (subst_exp e x e') tau r_s2 rx"
  apply (induction e arbitrary: env r_s1 tau r_s2 rx)
        apply (auto)
    (* var case *)
     (*  apply (simp add: subst_name_match_def)*)
    (* pair case *)
      apply (rule_tac x="r_s2a" in exI)
      apply (rule_tac x="r_s3" in exI)
      apply (rule_tac x="rx1" in exI)
      apply (auto)
      apply (rule_tac x="rx2" in exI)
      apply (auto)
    (* if case *)
     apply (rule_tac x="rx'" in exI)
     apply (rule_tac x="r_s2a" in exI)
     apply (auto)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
     apply (rule_tac x="rx2" in exI)
     apply (auto)
    (* lambda case *)
    apply (cut_tac y="x1a" and e="e" and x="x" and e'="e'" in no_subst_ref_vars)
    apply (auto)
   apply (rule_tac x="rxa" in exI)
   apply (auto)
   apply (rule_tac x="r_end" in exI)
   apply (rule_tac x="r_s'" in exI)
   apply (auto)
    (* app case *)
  apply (rule_tac x="t1" in exI)
  apply (rule_tac x="r" in exI)
  apply (rule_tac x="a" in exI)
  apply (rule_tac x="r_s2a" in exI)
  apply (rule_tac x="rx1" in exI)
  apply (auto)
  apply (rule_tac x="rx2" in exI)
  apply (rule_tac x="r_s3" in exI)
  apply (auto)
  done

end


(*  Title:       Executable Transitive Closures of Finite Relations
    Author:      Christian Sternagel <c.sternagel@gmail.com>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

section \<open>Closure Computation via Red Black Trees\<close>

theory Transitive_Closure_RBT_Impl
imports
  Transitive_Closure_Impl
  RBT_Map_Set_Extension
begin

text \<open>
  We provide two algorithms to compute the reflexive transitive closure which internally work on red
  black trees. Therefore, the carrier has to be linear ordered. The first one (@{term
  rtrancl_rbt_impl}) computes the closure on demand for a given set of initial states. The second
  one (@{term memo_rbt_rtrancl}) precomputes the closure for each individual state, stores the
  results, and then only does a look-up.

  For the transitive closure there are the corresponding algorithms @{term trancl_rbt_impl} and
  @{term memo_rbt_trancl}
\<close>

subsection \<open>Computing Closures from Sets On-The-Fly\<close>

text \<open>
  The algorithms are based on the generic algorithms @{const rtrancl_impl} and @{const trancl_impl}
  using red black trees. To compute the successors efficiently, all successors of a state are
  collected and stored in a red black tree map by using @{const elem_list_to_rm}. Then, to lift the
  successor relation for single states to lists of states, all results are united using @{const
  rs_Union}. The rest is standard.
\<close>

interpretation set_access "\<lambda> as bs. rs.union bs (rs.from_list as)" rs.\<alpha> rs.memb "rs.empty ()"
  by (unfold_locales, auto simp: rs.correct)

abbreviation rm_succ :: "('a :: linorder \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "rm_succ \<equiv> (\<lambda> r. let rm = elem_list_to_rm fst r in
    (\<lambda> as. rs.to_list (rs_Union (map (\<lambda> a. rs.from_list (map snd (rm_set_lookup rm a))) as))))"

definition rtrancl_rbt_impl :: "('a :: linorder \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'a rs"
where
  "rtrancl_rbt_impl = rtrancl_impl rm_succ
    (\<lambda> as bs. rs.union bs (rs.from_list as)) rs.memb (rs.empty ())"

definition trancl_rbt_impl :: "('a :: linorder \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'a rs"
where
  "trancl_rbt_impl = trancl_impl rm_succ
    (\<lambda> as bs. rs.union bs (rs.from_list as)) rs.memb (rs.empty ())"

lemma rtrancl_rbt_impl:
  "rs.\<alpha> (rtrancl_rbt_impl r as) = {b. \<exists> a \<in> set as. (a,b) \<in> (set r)\<^sup>*}"
  unfolding rtrancl_rbt_impl_def
  by (rule set_access_gen.rtrancl_impl, unfold_locales, unfold Let_def, simp add: rs.correct elem_list_to_rm.rm_set_lookup, force)

lemma trancl_rbt_impl:
  "rs.\<alpha> (trancl_rbt_impl r as) = {b. \<exists> a \<in> set as. (a,b) \<in> (set r)\<^sup>+}"
  unfolding trancl_rbt_impl_def
  by (rule set_access_gen.trancl_impl, unfold_locales, unfold Let_def, simp add: rs.correct elem_list_to_rm.rm_set_lookup, force)

subsection \<open>Precomputing Closures for Single States\<close>

text \<open>
  Storing all relevant entries is done by mapping all left-hand sides of the relation to their
  closure. Since we assume a linear order on the carrier, for the lookup we can use maps that are
  implemented as red black trees.
\<close>

definition memo_rbt_rtrancl :: "('a :: linorder \<times> 'a) list \<Rightarrow> ('a \<Rightarrow> 'a rs)"
where
  "memo_rbt_rtrancl r =
    (let
      tr = rtrancl_rbt_impl r;
      rm = rm.to_map (map (\<lambda> a. (a, tr [a])) ((rs.to_list \<circ> rs.from_list \<circ> map fst) r))
    in
      (\<lambda>a. case rm.lookup a rm of
        None \<Rightarrow> rs.from_list [a]
      | Some as \<Rightarrow> as))"

lemma memo_rbt_rtrancl:
  "rs.\<alpha> (memo_rbt_rtrancl r a) = {b. (a, b) \<in> (set r)\<^sup>*}" (is "?l = ?r")
proof -
  let ?rm = "rm.to_map
    (map (\<lambda>a. (a, rtrancl_rbt_impl r [a])) ((rs.to_list \<circ> rs.from_list \<circ> map fst) r))"
  show ?thesis
  proof (cases "rm.lookup a ?rm")
    case None
    have one: "?l = {a}"
      unfolding memo_rbt_rtrancl_def Let_def None
      by (simp add: rs.correct)
    from None [unfolded rm.lookup_correct [OF rm.invar], simplified rm.correct map_of_eq_None_iff]
    have a: "a \<notin> fst ` set r" by (simp add: rs.correct, force)
    {
      fix b
      assume "b \<in> ?r"
      from this [unfolded rtrancl_power relpow_fun_conv] obtain n f where
        ab: "f 0 = a \<and> f n = b" and steps: "\<And> i. i < n \<Longrightarrow> (f i, f (Suc i)) \<in> set r" by auto
      from ab steps [of 0] a have "b = a"
        by (cases n, force+)
    }
    then have "?r = {a}" by auto
    then show ?thesis unfolding one by simp
  next
    case (Some as)
    have as: "rs.\<alpha> as = {b. (a,b) \<in> (set r)\<^sup>*}"
      using map_of_SomeD [OF Some [unfolded rm.lookup_correct [OF rm.invar], simplified rm.correct]]
        rtrancl_rbt_impl [of r "[a]"] by force
    then show ?thesis unfolding memo_rbt_rtrancl_def Let_def Some by simp
  qed
qed

definition memo_rbt_trancl :: "('a :: linorder \<times> 'a) list \<Rightarrow> ('a \<Rightarrow> 'a rs)"
where
  "memo_rbt_trancl r =
    (let
      tr = trancl_rbt_impl r;
      rm = rm.to_map (map (\<lambda> a. (a, tr [a])) ((rs.to_list \<circ> rs.from_list \<circ> map fst) r))
    in (\<lambda> a.
      (case rm.lookup a rm of
        None \<Rightarrow> rs.empty ()
      | Some as \<Rightarrow> as)))"

lemma memo_rbt_trancl:
  "rs.\<alpha> (memo_rbt_trancl r a) = {b. (a, b) \<in> (set r)\<^sup>+}" (is "?l = ?r")
proof -
  let ?rm = "rm.to_map
    (map (\<lambda> a. (a, trancl_rbt_impl r [a])) ((rs.to_list \<circ> rs.from_list \<circ> map fst) r))"
  show ?thesis
  proof (cases "rm.lookup a ?rm")
    case None
    have one: "?l = {}"
      unfolding memo_rbt_trancl_def Let_def None
      by (simp add: rs.correct)
    from None [unfolded rm.lookup_correct [OF rm.invar], simplified rm.correct map_of_eq_None_iff]
    have a: "a \<notin> fst ` set r" by (simp add: rs.correct, force)
    {
      fix b
      assume "b \<in> ?r"
      from this [unfolded trancl_unfold_left] a have False by force
    }
    then have "?r = {}" by auto
    then show ?thesis unfolding one by simp
  next
    case (Some as)
    have as: "rs.\<alpha> as = {b. (a,b) \<in> (set r)\<^sup>+}"
      using map_of_SomeD [OF Some [unfolded rm.lookup_correct [OF rm.invar], simplified rm.correct]]
        trancl_rbt_impl [of r "[a]"] by force
    then show ?thesis unfolding memo_rbt_trancl_def Let_def Some by simp
  qed
qed

end


subsection \<open>Montanari Weak Relations\<close>

theory Montanari_Weak_Relations
imports
  Weak_Transition_Systems
  Weak_Relations_modified
  Montanari_Weak_Transition_Systems
begin

context lts_tau
begin

definition contrasim ::
  \<open>('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool\<close>
where
  \<open>contrasim R \<equiv> \<forall> p q p' A . (\<forall> a \<in> set(A). a \<noteq> \<tau>) \<and> R p q \<and> (p \<Rightarrow>$ A p') \<longrightarrow>
    (\<exists> q'. (q \<Rightarrow>$ A q') \<and> R q' p')\<close>

definition ZR :: "(('s \<Rightarrow> ('s set) \<Rightarrow> bool)) \<Rightarrow> ('s \<Rightarrow> ('s set) \<Rightarrow> bool)" where
\<open>ZR R p' Q' \<equiv> \<exists>p Q A. R p Q \<and> p \<Rightarrow>$A p' \<and> (\<forall>a \<in> set A. a \<noteq> \<tau>) \<and> Q' = (succs_seq_rec (rev A) Q)\<close>

definition set_type :: "('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> ('s set) \<Rightarrow> bool)" where
\<open>set_type R p Q \<equiv> \<exists>q. R p q \<and> Q = {q}\<close>

lemma R_is_in_ZR :
  assumes \<open>R p Q\<close>
  shows \<open>ZR R p Q\<close>
proof -
  have Q_cond: \<open>Q = succs_seq_rec (rev []) Q\<close>  by simp
  have p_cond: \<open>p \<Rightarrow>$[] p\<close> using steps.simps weak_step_seq.simps(1) by blast
  thus \<open>ZR R p Q\<close> using Q_cond ZR_def \<open>R p Q\<close>
    by (metis bex_empty empty_set tau_tau)
qed

lemma ZR_C_guarantees_tau_succ :
  assumes
    \<open>contrasim C\<close>
    \<open>ZR (set_type C) p Q\<close>
    \<open>p \<Rightarrow>^\<tau> p'\<close>
  shows \<open>\<exists>q'. q' \<in> (succs \<tau> Q) \<and> ZR (set_type C) q' {p'}\<close>
proof -
  obtain p0 Q0 A q0
      where \<open>(set_type C) p0 Q0\<close> \<open>p0 \<Rightarrow>$A p\<close> \<open>\<forall>a \<in> set A. a \<noteq> \<tau>\<close> \<open>Q0 = {q0}\<close>
        and Q_def: \<open>Q = (succs_seq_rec (rev A) Q0)\<close>
      using ZR_def assms set_type_def by metis
  hence \<open>C p0 q0\<close> using set_type_def by auto
  have \<open>p0 \<Rightarrow>$(A@[\<tau>]) p'\<close> using \<open>p0 \<Rightarrow>$A p\<close>  \<open>p \<Rightarrow>^\<tau>  p'\<close> rev_seq_step_concat by auto
  hence word: \<open>p0 \<Rightarrow>$A p'\<close>
    by (metis \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close> app_tau_taufree_list tau_def weak_step_over_tau)
  then obtain q' where \<open>q0 \<Rightarrow>$A q'\<close> \<open>C q' p'\<close>
    using assms contrasim_def[of \<open>C\<close>] \<open>C p0 q0\<close> \<open>\<forall>a \<in> set A. a \<noteq> \<tau>\<close> by blast
  hence \<open>(set_type C) q' {p'}\<close> using set_type_def by auto
  hence inZR: \<open>ZR (set_type C) q' {p'}\<close> using R_is_in_ZR  by auto
  have \<open>q' \<in> succs \<tau> Q\<close>
  proof (cases \<open>A = []\<close>)
    case True
    hence \<open>q0 \<Rightarrow>^\<tau> q'\<close> using \<open>q0 \<Rightarrow>$A q'\<close> by auto
    hence \<open>q' \<in> succs \<tau> {q0}\<close> using succs_def by simp
    hence \<open>q' \<in> succs \<tau> Q0\<close>  using \<open>Q0 = {q0}\<close>  by simp
    thus \<open>q' \<in> succs \<tau> Q\<close>  using Q_def by (simp add: True)
  next
    case False
    hence \<open>q' \<in> succs_seq_rec (rev A) Q0\<close>
      using \<open>Q0 = {q0}\<close> \<open>q0 \<Rightarrow>$ A q'\<close>
      by (simp add: word_reachable_implies_in_s)
    hence \<open>q' \<in> Q\<close> using Q_def by auto
    hence \<open>\<exists>q \<in> Q. q \<Rightarrow>^\<tau> q'\<close> using \<open>q' \<in> Q\<close> steps.refl by auto
    thus \<open>q' \<in> succs \<tau> Q\<close>using succs_def by simp
  qed
  thus \<open>\<exists>q'. q' \<in> succs \<tau> Q \<and> ZR (set_type C) q' {p'}\<close> using inZR by auto
qed

lemma ZR_C_guarantees_action_succ :
 assumes
    \<open>contrasim C\<close>
    \<open>ZR (set_type C) p Q\<close>
    \<open>p \<Rightarrow>a p'\<close>
    \<open>a \<noteq> \<tau>\<close>
  shows \<open>succs a Q \<noteq> {}  \<and> ZR (set_type C) p' (succs a Q)\<close>
proof -
  obtain p0 Q0 A q0
    where \<open>(set_type C) p0 Q0\<close> \<open>p0 \<Rightarrow>$A p\<close> \<open>Q0 = {q0}\<close> \<open>\<forall>a \<in> set A. a \<noteq> \<tau> \<close> and Q_def: \<open>Q = (succs_seq_rec (rev A) Q0)\<close>
    using ZR_def assms set_type_def by metis
  then obtain CS where CS_def: \<open>contrasim CS \<and> CS p0 q0\<close>
    using assms set_type_def by (metis singleton_inject)
  have notau: \<open>\<forall>a \<in> set (A@[a]). a \<noteq> \<tau>\<close>
    using \<open>a \<noteq> \<tau>\<close> \<open>\<forall>a \<in> set A. a \<noteq> \<tau> \<close> by auto
  have word: \<open>p0 \<Rightarrow>$(A@[a]) p'\<close>
    using \<open>p0 \<Rightarrow>$A p\<close>  \<open>p \<Rightarrow>a  p'\<close> rev_seq_step_concat
    by (meson steps.step steps_concat)
  then obtain q' where \<open>q0 \<Rightarrow>$(A@[a]) q' \<and> CS q' p'\<close>
    using CS_def contrasim_def[of \<open>CS\<close>] notau
    by fastforce
  hence in_succs: \<open>q' \<in> (succs_seq_rec (rev (A@[a])) {q0})\<close>
    using word_reachable_implies_in_s by blast
  hence \<open>q' \<in> (succs_seq_rec (a#(rev A)) {q0})\<close>
    by (metis rev_eq_Cons_iff rev_rev_ident)
  hence \<open>q' \<in> succs a (succs_seq_rec (rev A) {q0})\<close> by auto
  hence notempty: \<open>q' \<in> succs a Q\<close> using Q_def \<open>Q0 = {q0}\<close>  by auto
  have \<open>ZR (set_type C) p' (succs a Q)\<close>
    using in_succs word ZR_def[of \<open>(set_type C)\<close>] \<open>(set_type C) p0 Q0\<close>
      \<open>Q0 = {q0}\<close> Q_def simp_succs_seq_rev notau
    by meson
  with notempty show \<open>succs a Q \<noteq> {} \<and> ZR (set_type C) p' (succs a Q)\<close> by auto
qed

end
end


(*  Title:      ZF/ex/BinEx.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

Examples of performing binary arithmetic by simplification.
*)

theory BinEx imports Main begin
(*All runtimes below are on a 300MHz Pentium*)

lemma "#13  $+  #19 = #32"
by simp (*0 secs*)

lemma "#1234  $+  #5678 = #6912"
by simp (*190 msec*)

lemma "#1359  $+  #-2468 = #-1109"
by simp (*160 msec*)

lemma "#93746  $+  #-46375 = #47371"
by simp (*300 msec*)

lemma "$- #65745 = #-65745"
by simp (*80 msec*)

(* negation of ~54321 *)
lemma "$- #-54321 = #54321"
by simp (*90 msec*)

lemma "#13  $*  #19 = #247"
by simp (*110 msec*)

lemma "#-84  $*  #51 = #-4284"
by simp (*210 msec*)

(*The worst case for 8-bit operands *)
lemma "#255  $*  #255 = #65025"
by simp (*730 msec*)

lemma "#1359  $*  #-2468 = #-3354012"
by simp (*1.04 secs*)

(** Comparisons **)

lemma "(#89) $* #10 \<noteq> #889"
by simp

lemma "(#13) $< #18 $- #4"
by simp

lemma "(#-345) $< #-242 $+ #-100"
by simp

lemma "(#13557456) $< #18678654"
by simp

lemma "(#999999) $\<le> (#1000001 $+ #1) $- #2"
by simp

lemma "(#1234567) $\<le> #1234567"
by simp

(*** Quotient and remainder!! [they could be faster] ***)

lemma "#23 zdiv #3 = #7"
by simp

lemma "#23 zmod #3 = #2"
by simp

(** negative dividend **)

lemma "#-23 zdiv #3 = #-8"
by simp

lemma "#-23 zmod #3 = #1"
by simp

(** negative divisor **)

lemma "#23 zdiv #-3 = #-8"
by simp

lemma "#23 zmod #-3 = #-1"
by simp

(** Negative dividend and divisor **)

lemma "#-23 zdiv #-3 = #7"
by simp

lemma "#-23 zmod #-3 = #-2"
by simp

end


chapter \<open>First Example\<close>

theory %invisible First_Example
imports Main
begin

text \<open>\label{chap:exampleI}\<close>

text \<open>Pop-refinement is illustrated via a simple derivation,
in Isabelle/HOL,
of a program that includes non-functional aspects.\<close>

section \<open>Target Programming Language\<close>
text \<open>\label{sec:targetI}\<close>

text \<open>In the target language used in this example,
a program consists of
a list of distinct variables (the parameters of the program)
and an arithmetic expression (the body of the program).
The body is built out of
parameters,
non-negative integer constants,
addition operations,
and doubling (i.e.\ multiplication by 2) operations.
The program is executed
by supplying non-negative integers to the parameters
and evaluating the body to obtain a non-negative integer result.\<close>

text \<open>For instance, executing the program
\begin{verbatim}
  prog (a,b) {3 + 2 * (a + b)}
\end{verbatim}
with 5 and 7 supplied to \verb|a| and \verb|b| yields 27.
The syntax and semantics of this language are formalized as follows.\<close>

subsection \<open>Syntax\<close>
text \<open>\label{sec:syntaxI}\<close>

text \<open>Variables are identified by names.\<close>

type_synonym name = string

text \<open>Expressions are built out of
constants, variables, doubling operations, and addition operations.\<close>

datatype expr = Const nat | Var name | Double expr | Add expr expr

text \<open>A program consists of
a list of parameter variables and a body expression.\<close>

record prog =
 para :: "name list"
 body :: expr

subsection \<open>Static Semantics\<close>
text \<open>\label{sec:staticI}\<close>

text \<open>A context is a set of variables.\<close>

type_synonym ctxt = "name set"

text \<open>Given a context,
an expression is well-formed iff\
all its variables are in the context.\<close>

fun wfe :: "ctxt \<Rightarrow> expr \<Rightarrow> bool"
where
  "wfe \<Gamma> (Const c) \<longleftrightarrow> True" |
  "wfe \<Gamma> (Var v) \<longleftrightarrow> v \<in> \<Gamma>" |
  "wfe \<Gamma> (Double e) \<longleftrightarrow> wfe \<Gamma> e" |
  "wfe \<Gamma> (Add e\<^sub>1 e\<^sub>2) \<longleftrightarrow> wfe \<Gamma> e\<^sub>1 \<and> wfe \<Gamma> e\<^sub>2"

text \<open>The context of a program consists of the parameters.\<close>

definition ctxt :: "prog \<Rightarrow> ctxt"
where "ctxt p \<equiv> set (para p)"

text \<open>A program is well-formed iff\
the parameters are distinct
and the body is well-formed in the context of the program.\<close>

definition wfp :: "prog \<Rightarrow> bool"
where "wfp p \<equiv> distinct (para p) \<and> wfe (ctxt p) (body p)"

subsection \<open>Dynamic Semantics\<close>
text \<open>\label{sec:dynamicI}\<close>

text \<open>An environment associates values (non-negative integers)
to variables.\<close>

type_synonym env = "name \<rightharpoonup> nat"

text \<open>An environment matches a context iff\
environment and context have the same variables.\<close>

definition match :: "env \<Rightarrow> ctxt \<Rightarrow> bool"
where "match \<E> \<Gamma> \<equiv> dom \<E> = \<Gamma>"

text \<open>Evaluating an expression in an environment yields a value,
or an error (@{const None})
if the expression contains a variable not in the environment.\<close>

definition mul_opt :: "nat option \<Rightarrow> nat option \<Rightarrow> nat option" (infixl "\<otimes>" 70)
\<comment> \<open>Lifting of multiplication to @{typ "nat option"}.\<close>
where "U\<^sub>1 \<otimes> U\<^sub>2 \<equiv>
  case (U\<^sub>1, U\<^sub>2) of (Some u\<^sub>1, Some u\<^sub>2) \<Rightarrow> Some (u\<^sub>1 * u\<^sub>2) | _ \<Rightarrow> None"

definition add_opt :: "nat option \<Rightarrow> nat option \<Rightarrow> nat option" (infixl "\<oplus>" 65)
\<comment> \<open>Lifting of addition to @{typ "nat option"}.\<close>
where "U\<^sub>1 \<oplus> U\<^sub>2 \<equiv>
  case (U\<^sub>1, U\<^sub>2) of (Some u\<^sub>1, Some u\<^sub>2) \<Rightarrow> Some (u\<^sub>1 + u\<^sub>2) | _ \<Rightarrow> None"

fun eval :: "env \<Rightarrow> expr \<Rightarrow> nat option"
where
  "eval \<E> (Const c) = Some c" |
  "eval \<E> (Var v) = \<E> v" |
  "eval \<E> (Double e) = Some 2 \<otimes> eval \<E> e" |
  "eval \<E> (Add e\<^sub>1 e\<^sub>2) = eval \<E> e\<^sub>1 \<oplus> eval \<E> e\<^sub>2"

text \<open>Evaluating a well-formed expression never yields an error,
if the environment matches the context.\<close>

lemma eval_wfe:
  "wfe \<Gamma> e \<Longrightarrow> match \<E> \<Gamma> \<Longrightarrow> eval \<E> e \<noteq> None"
by (induct e, auto simp: match_def mul_opt_def add_opt_def)

text \<open>The environments of a program
are the ones that match the context of the program.\<close>

definition envs :: "prog \<Rightarrow> env set"
where "envs p \<equiv> {\<E>. match \<E> (ctxt p)}"

text \<open>Evaluating the body of a well-formed program
in an environment of the program
never yields an error.\<close>

lemma eval_wfp:
  "wfp p \<Longrightarrow> \<E> \<in> envs p \<Longrightarrow> eval \<E> (body p) \<noteq> None"
by (metis envs_def eval_wfe mem_Collect_eq wfp_def)

text \<open>Executing a program with values supplied to the parameters
yields a non-negative integer result,
or an error (@{const None})
if the parameters are not distinct,
the number of supplied values differs from the number of parameters,
or the evaluation of the body yields an error.\<close>

definition "supply" :: "prog \<Rightarrow> nat list \<Rightarrow> env option"
where "supply p us \<equiv>
  let vs = para p in
  if distinct vs \<and> length us = length vs
  then Some (map_of (zip vs us))
  else None"

definition exec :: "prog \<Rightarrow> nat list \<Rightarrow> nat option"
where "exec p us \<equiv>
  case supply p us of Some \<E> \<Rightarrow> eval \<E> (body p) | None \<Rightarrow> None"

text \<open>Executing a well-formed program
with the same number of values as the number of parameters
never yields an error.\<close>

lemma supply_wfp: "
  wfp p \<Longrightarrow>
  length us = length (para p) \<Longrightarrow>
  \<exists>\<E> \<in> envs p. supply p us = Some \<E>"
by (auto
 simp: wfp_def supply_def envs_def ctxt_def match_def split: option.split)

lemma exec_wfp:
  "wfp p \<Longrightarrow> length us = length (para p) \<Longrightarrow> exec p us \<noteq> None"
by (metis eval_wfp exec_def option.simps(5) supply_wfp)

subsection \<open>Performance\<close>
text \<open>\label{sec:nonfunc}\<close>

text \<open>As a non-functional semantic aspect,
the cost (e.g.\ time and power) to execute a program
is modeled as the number of doubling and addition operations.\<close>

fun coste :: "expr \<Rightarrow> nat"
where
  "coste (Const c) = 0" |
  "coste (Var v) = 0" |
  "coste (Double e) = 1 + coste e" |
  "coste (Add e\<^sub>1 e\<^sub>2) = 1 + coste e\<^sub>1 + coste e\<^sub>2"

definition costp :: "prog \<Rightarrow> nat"
where "costp p \<equiv> coste (body p)"

section \<open>Requirement Specification\<close>
text \<open>\label{sec:specificationI}\<close>

text \<open>The target program must:
\begin{enumerate}
\item
Be well-formed.
\item
Have exactly the two parameters @{term "''x''"} and @{term "''y''"},
in this order.
\item
Produce the result @{term "f x y"}
when @{term x} and @{term y}
are supplied to @{term "''x''"} and @{term "''y''"},
where @{term f} is defined below.
\item
Not exceed cost 3.
\end{enumerate}\<close>

definition f :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where "f x y \<equiv> 3 * x + 2 * y"

definition spec\<^sub>0 :: "prog \<Rightarrow> bool"
where "spec\<^sub>0 p \<equiv>
  wfp p \<and>
  para p = [''x'', ''y''] \<and>
  (\<forall>x y. exec p [x, y] = Some (f x y)) \<and>
  costp p \<le> 3"

text \<open>@{const f} is used by @{const spec\<^sub>0}
to express a functional requirement on the execution of the program.
@{const spec\<^sub>0} includes
the non-functional requirement @{term "costp(p) \<le> 3"}
and the syntactic interface requirement @{term "para(p) = [''x'', ''y'']"},
which are not expressed by @{const f} alone
and are expressible only in terms of programs.
@{const f} can be computed by a program
with cost higher than 3
and with more or different parameters;
it can also be computed by programs in different target languages.\<close>

section \<open>Stepwise Refinement\<close>
text \<open>\label{sec:refinementI}\<close>

text \<open>It is not difficult
to write a program that satisfies @{const spec\<^sub>0} and to prove that it does.
But with more complex target languages and requirement specifications,
writing a program and proving that it satisfies the requirements
is notoriously difficult.
Stepwise refinement decomposes the proof into manageable pieces,
constructing the implementation along the way.
The following sequence of refinement steps
may be overkill for obtaining an implementation of @{const spec\<^sub>0},
but illustrates concepts that should apply to more complex cases.\<close>

subsection \<open>Step 1\<close>
text \<open>\label{sec:refI:stepI}\<close>

text \<open>The second conjunct in @{const spec\<^sub>0} determines the parameters,
leaving only the body to be determined.
That conjunct also reduces
the well-formedness of the program to the well-formedness of the body,
and the execution of the program to the evaluation of the body.\<close>

abbreviation \<Gamma>\<^sub>x\<^sub>y :: ctxt
where "\<Gamma>\<^sub>x\<^sub>y \<equiv> {''x'', ''y''}"

abbreviation \<E>\<^sub>x\<^sub>y :: "nat \<Rightarrow> nat \<Rightarrow> env"
where "\<E>\<^sub>x\<^sub>y x y \<equiv> [''x'' \<mapsto> x, ''y'' \<mapsto> y]"

lemma reduce_prog_to_body: "
  para p = [''x'', ''y''] \<Longrightarrow>
  wfp p = wfe \<Gamma>\<^sub>x\<^sub>y (body p) \<and>
  exec p [x, y] = eval (\<E>\<^sub>x\<^sub>y x y) (body p)"
by (auto simp: wfp_def ctxt_def exec_def supply_def fun_upd_twist)

text \<open>Using lemma \<open>reduce_prog_to_body\<close>,
and using the definition of @{const costp}
to reduce the cost of the program to the cost of the body,
@{const spec\<^sub>0} is refined as follows.\<close>

definition spec\<^sub>1 :: "prog \<Rightarrow> bool"
where "spec\<^sub>1 p \<equiv>
  wfe \<Gamma>\<^sub>x\<^sub>y (body p) \<and>
  para p = [''x'', ''y''] \<and>
  (\<forall>x y. eval (\<E>\<^sub>x\<^sub>y x y) (body p) = Some (f x y)) \<and>
  coste (body p) \<le> 3"

lemma step_1_correct:
 "spec\<^sub>1 p \<Longrightarrow> spec\<^sub>0 p"
by (auto simp: spec\<^sub>1_def spec\<^sub>0_def reduce_prog_to_body costp_def)

text \<open>@{const spec\<^sub>1} and @{const spec\<^sub>0} are actually equivalent,
but the definition of @{const spec\<^sub>1} is ``closer'' to the implementation
than the definition of @{const spec\<^sub>0}:
the latter states constraints on the whole program,
while the former states simpler constraints on the body,
given that the parameters are already determined.
The proof of \<open>step_1_correct\<close>
can also be used to prove the equivalence of @{const spec\<^sub>1} and @{const spec\<^sub>0},
but in general proving inclusion is easier than proving equivalence.
Some of the following refinement steps yield non-equivalent predicates.\<close>

subsection \<open>Step 2\<close>
text \<open>\label{sec:refI:stepII}\<close>

text \<open>The third conjunct in @{const spec\<^sub>1} says that
the body computes @{term "f x y"},
which depends on both @{term x} and @{term y},
and which yields an odd result for some values of @{term x} and @{term y}.
Thus the body cannot be a constant, a variable, or a double,
leaving a sum as the only option.
Adding @{term "\<exists>e\<^sub>1 e\<^sub>2. body p = Add e\<^sub>1 e\<^sub>2"} as a conjunct to @{const spec\<^sub>1}
and re-arranging the other conjuncts,
moving some of them under the existential quantification
so that they can be simplified in the next refinement step,
@{const spec\<^sub>1} is refined as follows.\<close>

definition spec\<^sub>2 :: "prog \<Rightarrow> bool"
where "spec\<^sub>2 p \<equiv>
  para p = [''x'', ''y''] \<and>
  (\<exists>e\<^sub>1 e\<^sub>2.
    body p = Add e\<^sub>1 e\<^sub>2 \<and>
    wfe \<Gamma>\<^sub>x\<^sub>y (body p) \<and>
    (\<forall>x y. eval (\<E>\<^sub>x\<^sub>y x y) (body p) = Some (f x y)) \<and>
    coste (body p) \<le> 3)"

lemma step_2_correct:
 "spec\<^sub>2 p \<Longrightarrow> spec\<^sub>1 p"
by (auto simp: spec\<^sub>2_def spec\<^sub>1_def)

text \<open>This refinement step is guided by an analysis
of the constraints in @{const spec\<^sub>1}.\<close>

subsection \<open>Step 3\<close>
text \<open>\label{sec:refI:stepIII}\<close>

text \<open>The fact that the body is a sum
reduces the well-formedness, evaluation, and cost of the body
to the well-formedness, evaluation, and cost of the addends.\<close>

lemma reduce_body_to_addends: "
  body p = Add e\<^sub>1 e\<^sub>2 \<Longrightarrow>
  wfe \<Gamma>\<^sub>x\<^sub>y (body p) = (wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>1 \<and> wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>2) \<and>
  eval (\<E>\<^sub>x\<^sub>y x y) (body p) = eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>1 \<oplus> eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>2 \<and>
  coste (body p) = 1 + coste e\<^sub>1 + coste e\<^sub>2"
by auto

text \<open>Using \<open>reduce_body_to_addends\<close>
and arithmetic simplification,
@{const spec\<^sub>2} is refined as follows.\<close>

definition spec\<^sub>3 :: "prog \<Rightarrow> bool"
where "spec\<^sub>3 p \<equiv>
  para p = [''x'', ''y''] \<and>
  (\<exists>e\<^sub>1 e\<^sub>2.
    body p = Add e\<^sub>1 e\<^sub>2 \<and>
    wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>1 \<and>
    wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>2 \<and>
    (\<forall>x y. eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>1 \<oplus> eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>2 = Some (f x y)) \<and>
    coste e\<^sub>1 + coste e\<^sub>2 \<le> 2)"

lemma step_3_correct:
  "spec\<^sub>3 p \<Longrightarrow> spec\<^sub>2 p"
by (auto simp: spec\<^sub>3_def spec\<^sub>2_def)
\<comment> \<open>No need to use @{text reduce_body_to_addends} explicitly,\<close>
\<comment> \<open>as the default rules that @{text auto} uses to prove it apply here too.\<close>

text \<open>This refinement step
defines the top-level structure of the body,
reducing the constraints on the body
to simpler constraints on its components.\<close>

subsection \<open>Step 4\<close>
text \<open>\label{sec:refI:stepIV}\<close>

text \<open>The second-to-last conjunct in @{const spec\<^sub>3}
suggests to split @{term "f x y"} into two addends
to be computed by @{term e\<^sub>1} and @{term e\<^sub>2}.\<close>

text \<open>The addends @{term "(3::nat) * x"} and @{term "(2::nat) * y"}
suggested by the definition of @{const f}
would lead to a blind alley,
where the cost constraints could not be satisfied---%
the resulting @{term spec\<^sub>4} would be always false.
The refinement step would be ``correct'' (by strict inclusion)
but the refinement sequence could never reach an implementation.
It would be necessary to backtrack to @{const spec\<^sub>3}
and split @{term "f x y"} differently.\<close>

text \<open>To avoid the blind alley,
the definition of @{const f} is rephrased as follows.\<close>

lemma f_rephrased:
  "f x y = x + (2 * x + 2 * y)"
by (auto simp: f_def)

text \<open>This rephrased definition of @{const f}
does not use the multiplication by 3 of the original definition,
which is not (directly) supported by the target language;
it only uses operations supported by the language.\<close>

text \<open>Using \<open>f_rephrased\<close>, @{const spec\<^sub>3} is refined as follows.\<close>

definition spec\<^sub>4 :: "prog \<Rightarrow> bool"
where "spec\<^sub>4 p \<equiv>
  para p = [''x'', ''y''] \<and>
  (\<exists>e\<^sub>1 e\<^sub>2.
    body p = Add e\<^sub>1 e\<^sub>2 \<and>
    wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>1 \<and>
    wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>2 \<and>
    (\<forall>x y. eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>1 = Some x) \<and>
    (\<forall>x y. eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>2 = Some (2 * x + 2 * y)) \<and>
    coste e\<^sub>1 + coste e\<^sub>2 \<le> 2)"

lemma step_4_correct:
  "spec\<^sub>4 p \<Longrightarrow> spec\<^sub>3 p"
by (auto simp: spec\<^sub>4_def spec\<^sub>3_def add_opt_def f_rephrased)

text \<open>This refinement step reduces
the functional constraint on the body
to simpler functional constraints on the addends.
The functional constraint can be decomposed in different ways,
some of which are incompatible with the non-functional cost constraint:
blind alleys are avoided
by taking the non-functional constraint into account.\<close>

subsection \<open>Step 5\<close>
text \<open>\label{sec:refI:stepV}\<close>

text \<open>The term @{term x}
in the third-to-last conjunct in @{const spec\<^sub>4}
is a shallow embedding of the program expression \verb|x|,
whose deep embedding is the term @{term "Var ''x''"}.
Using the latter as @{term e\<^sub>1},
the third-to-last conjunct in @{const spec\<^sub>4} is satisfied;
the expression is well-formed and has cost 0.\<close>

lemma first_addend: "
  e\<^sub>1 = Var ''x'' \<Longrightarrow>
  eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>1 = Some x \<and>
  wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>1 \<and>
  coste e\<^sub>1 = 0"
by auto

text \<open>Adding @{term "e\<^sub>1 = Var ''x''"} as a conjunct to @{const spec\<^sub>4}
and simplifying,
@{const spec\<^sub>4} is refined as follows.\<close>

definition spec\<^sub>5 :: "prog \<Rightarrow> bool"
where "spec\<^sub>5 p \<equiv>
  para p = [''x'', ''y''] \<and>
  (\<exists>e\<^sub>2.
    body p = Add (Var ''x'') e\<^sub>2 \<and>
    wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>2 \<and>
    (\<forall>x y. eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>2 = Some (2 * x + 2 * y)) \<and>
    coste e\<^sub>2 \<le> 2)"

lemma step_5_correct:
  "spec\<^sub>5 p \<Longrightarrow> spec\<^sub>4 p"
by (auto simp: spec\<^sub>5_def spec\<^sub>4_def)
\<comment> \<open>No need to use @{text first_addend} explicitly,\<close>
\<comment> \<open>as the default rules that @{text auto} uses to prove it apply here too.\<close>

text \<open>This refinement step determines the first addend of the body,
leaving only the second addend to be determined.\<close>

subsection \<open>Step 6\<close>
text \<open>\label{sec:refI:stepVI}\<close>

text \<open>The term @{term "(2::nat) * x + 2 * y"}
in the second-to-last conjunct of @{const spec\<^sub>5}
is a shallow embedding of the program expression \verb|2 * x + 2 * y|,
whose deep embedding is the term
@{term "Add (Double (Var ''x'')) (Double (Var ''y''))"}.
Using the latter as @{term e\<^sub>2},
the second-to-last conjunct in @{const spec\<^sub>5} is satisfied,
but the last conjunct is not.
The following factorization of the shallowly embedded expression
leads to a reduced cost of the corresponding deeply embedded expression.\<close>

lemma factorization:
  "(2::nat) * x + 2 * y = 2 * (x + y)"
by auto

text \<open>The deeply embedded expression
@{term "Double (Add (Var ''x'') (Var ''y''))"},
which corresponds to the shallowly embedded expression
@{term "(2::nat) * (x + y)"},
satisfies the second-to-last conjunct of @{const spec\<^sub>5},
is well-formed,
and has cost 2.\<close>

lemma second_addend: "
  e\<^sub>2 = Double (Add (Var ''x'') (Var ''y'')) \<Longrightarrow>
  eval (\<E>\<^sub>x\<^sub>y x y) e\<^sub>2 = Some (2 * x + 2 * y) \<and>
  wfe \<Gamma>\<^sub>x\<^sub>y e\<^sub>2 \<and>
  coste e\<^sub>2 = 2"
by (auto simp: add_opt_def mul_opt_def)
\<comment> \<open>No need to use @{text factorization} explicitly,\<close>
\<comment> \<open>as the default rules that @{text auto} uses to prove it apply here too.\<close>

text \<open>Adding @{term "e\<^sub>2 = Double (Add (Var ''x'') (Var ''y''))"}
as a conjunct to @{const spec\<^sub>5}
and simplifying,
@{const spec\<^sub>5} is refined as follows.\<close>

definition spec\<^sub>6 :: "prog \<Rightarrow> bool"
where "spec\<^sub>6 p \<equiv>
  para p = [''x'', ''y''] \<and>
  body p = Add (Var ''x'') (Double (Add (Var ''x'') (Var ''y'')))"

lemma step_6_correct:
  "spec\<^sub>6 p \<Longrightarrow> spec\<^sub>5 p"
by (auto simp add: spec\<^sub>6_def spec\<^sub>5_def second_addend simp del: eval.simps)

text \<open>This refinement step determines the second addend of the body,
leaving nothing else to be determined.\<close>

text \<open>This and the previous refinement step
turn semantic constraints on the program components @{term e\<^sub>1} and @{term e\<^sub>2}
into syntactic definitions of such components.\<close>

subsection \<open>Step 7\<close>
text \<open>\label{sec:refI:stepVII}\<close>

text \<open>@{const spec\<^sub>6}, which defines the parameters and body,
is refined to characterize a unique program in explicit syntactic form.\<close>

abbreviation p\<^sub>0 :: prog
where "p\<^sub>0 \<equiv>
  \<lparr>para = [''x'', ''y''],
   body = Add (Var ''x'') (Double (Add (Var ''x'') (Var ''y'')))\<rparr>"

definition spec\<^sub>7 :: "prog \<Rightarrow> bool"
where "spec\<^sub>7 p \<equiv> p = p\<^sub>0"

lemma step_7_correct:
  "spec\<^sub>7 p \<Longrightarrow> spec\<^sub>6 p"
by (auto simp: spec\<^sub>7_def spec\<^sub>6_def)

text \<open>The program satisfies @{const spec\<^sub>0} by construction.
The program witnesses the consistency of the requirements,
i.e.\ the fact that @{const spec\<^sub>0} is not always false.\<close>

lemma p\<^sub>0_sat_spec\<^sub>0:
  "spec\<^sub>0 p\<^sub>0"
by (metis
 step_1_correct
 step_2_correct
 step_3_correct
 step_4_correct
 step_5_correct
 step_6_correct
 step_7_correct
 spec\<^sub>7_def)

text \<open>From @{const p\<^sub>0}, the program text
\begin{verbatim}
  prog (x,y) {x + 2 * (x + y)}
\end{verbatim}
is easily obtained.\<close>

end %invisible


(* Author: Jaime Mendizabal Roche *)

theory Euler_Criterion
imports Residues
begin

context
  fixes p :: "nat"
  fixes a :: "int"

  assumes p_prime: "prime p"
  assumes p_ge_2: "2 < p"
  assumes p_a_relprime: "[a \<noteq> 0](mod p)"
begin

private lemma odd_p: "odd p"
  using p_ge_2 p_prime prime_odd_nat by blast

private lemma p_minus_1_int:
  "int (p - 1) = int p - 1"
  by (metis of_nat_1 of_nat_diff p_prime prime_ge_1_nat)

private lemma p_not_eq_Suc_0 [simp]:
  "p \<noteq> Suc 0"
  using p_ge_2 by simp

private lemma one_mod_int_p_eq [simp]:
  "1 mod int p = 1"
proof -
  from p_ge_2 have "int 1 mod int p = int 1"
    by simp
  then show ?thesis
    by simp
qed

private lemma E_1:
  assumes "QuadRes (int p) a"
  shows "[a ^ ((p - 1) div 2) = 1] (mod int p)"
proof -
  from assms obtain b where b: "[b ^ 2 = a] (mod int p)"
    unfolding QuadRes_def by blast
  then have "[a ^ ((p - 1) div 2) = b ^ (2 * ((p - 1) div 2))] (mod int p)"
    by (simp add: cong_pow cong_sym power_mult)
  then have "[a ^ ((p - 1) div 2) = b ^ (p - 1)] (mod int p)"
    using odd_p by force
  moreover have "[b ^ (p - 1) = 1] (mod int p)"
  proof -
    have "[nat \<bar>b\<bar> ^ (p - 1) = 1] (mod p)"
    using p_prime proof (rule fermat_theorem)
      from b p_a_relprime show "\<not> p dvd nat \<bar>b\<bar>"
        by (auto simp add: cong_iff_dvd_diff power2_eq_square)
          (metis cong_iff_dvd_diff cong_dvd_iff dvd_mult2)
    qed
    then have "nat \<bar>b\<bar> ^ (p - 1) mod p = 1 mod p"
      by (simp add: cong_def)
    then have "int (nat \<bar>b\<bar> ^ (p - 1) mod p) = int (1 mod p)"
      by simp
    moreover from odd_p have "\<bar>b\<bar> ^ (p - Suc 0) = b ^ (p - Suc 0)"
      by (simp add: power_even_abs)
    ultimately show ?thesis
      by (auto simp add: cong_def zmod_int)
  qed
  ultimately show ?thesis
    by (auto intro: cong_trans)
qed

private definition S1 :: "int set" where "S1 = {0 <.. int p - 1}"

private definition P :: "int \<Rightarrow> int \<Rightarrow> bool" where
  "P x y \<longleftrightarrow> [x * y = a] (mod p) \<and> y \<in> S1"

private definition f_1 :: "int \<Rightarrow> int" where
  "f_1 x = (THE y. P x y)"

private definition f :: "int \<Rightarrow> int set" where
  "f x = {x, f_1 x}"

private definition S2 :: "int set set" where "S2 = f ` S1"

private lemma P_lemma: assumes "x \<in> S1"
  shows "\<exists>! y. P x y"
proof -
  have "\<not> p dvd x" using assms zdvd_not_zless S1_def by auto
  hence co_xp: "coprime x p" using p_prime prime_imp_coprime_int[of p x]
    by (simp add: ac_simps)
  then obtain y' where y': "[x * y' = 1] (mod p)" using cong_solve_coprime_int by blast
  moreover define y where "y = y' * a mod p"
  ultimately have "[x * y = a] (mod p)"
    using mod_mult_right_eq [of x "y' * a" p]
    cong_scalar_right [of "x * y'" 1 "int p" a]
    by (auto simp add: cong_def ac_simps)
  moreover have "y \<in> {0 .. int p - 1}" unfolding y_def using p_ge_2 by auto
  hence "y \<in> S1" using calculation cong_iff_dvd_diff p_a_relprime S1_def cong_dvd_iff by fastforce
  ultimately have "P x y" unfolding P_def by blast
  moreover {
    fix y1 y2
    assume "P x y1" "P x y2"
    moreover hence "[y1 = y2] (mod p)" unfolding P_def
      using co_xp cong_mult_lcancel[of x p y1 y2] cong_sym cong_trans by blast
    ultimately have "y1 = y2" unfolding P_def S1_def using cong_less_imp_eq_int by auto
  }
  ultimately show ?thesis by blast
qed

private lemma f_1_lemma_1: assumes "x \<in> S1"
  shows "P x (f_1 x)" using assms P_lemma theI'[of "P x"] f_1_def by presburger

private lemma f_1_lemma_2: assumes "x \<in> S1"
  shows "f_1 (f_1 x) = x"
  using assms f_1_lemma_1[of x] f_1_def P_lemma[of "f_1 x"] P_def by (auto simp: mult.commute)

private lemma f_lemma_1: assumes "x \<in> S1"
  shows "f x = f (f_1 x)" using f_def f_1_lemma_2[of x] assms by auto

private lemma l1: assumes "\<not> QuadRes p a" "x \<in> S1"
  shows "x \<noteq> f_1 x"
  using f_1_lemma_1[of x] assms unfolding P_def QuadRes_def power2_eq_square by fastforce

private lemma l2: assumes "\<not> QuadRes p a" "x \<in> S1"
  shows "[\<Prod> (f x) = a] (mod p)"
  using assms l1 f_1_lemma_1 P_def f_def by auto

private lemma l3: assumes "x \<in> S2"
  shows "finite x" using assms f_def S2_def by auto

private lemma l4: "S1 = \<Union> S2" using f_1_lemma_1 P_def f_def S2_def by auto

private lemma l5: assumes "x \<in> S2" "y \<in> S2" "x \<noteq> y"
  shows "x \<inter> y = {}"
proof -
  obtain a b where ab: "x = f a" "a \<in> S1" "y = f b" "b \<in> S1" using assms S2_def by auto
  hence "a \<noteq> b" "a \<noteq> f_1 b" "f_1 a \<noteq> b" using assms(3) f_lemma_1 by blast+
  moreover hence "f_1 a \<noteq> f_1 b" using f_1_lemma_2[of a] f_1_lemma_2[of b] ab by force
  ultimately show ?thesis using f_def ab by fastforce
qed

private lemma l6: "prod Prod S2 = \<Prod> S1"
  using prod.Union_disjoint[of S2 "\<lambda>x. x"] l3 l4 l5 unfolding comp_def by auto

private lemma l7: "fact n = \<Prod> {0 <.. int n}"
proof (induction n)
case (Suc n)
  have "int (Suc n) = int n + 1" by simp
  hence "insert (int (Suc n)) {0<..int n} = {0<..int (Suc n)}" by auto
  thus ?case using prod.insert[of "{0<..int n}" "int (Suc n)" "\<lambda>x. x"] Suc fact_Suc by auto
qed simp

private lemma l8: "fact (p - 1) = \<Prod> S1" using l7[of "p - 1"] S1_def p_minus_1_int by presburger

private lemma l9: "[prod Prod S2 = -1] (mod p)"
  using l6 l8 wilson_theorem[of p] p_prime by presburger

private lemma l10: assumes "card S = n" "\<And>x. x \<in> S \<Longrightarrow> [g x = a] (mod p)"
  shows "[prod g S = a ^ n] (mod p)" using assms
proof (induction n arbitrary: S)
case 0
  thus ?case using card_0_eq[of S] prod.empty prod.infinite by fastforce
next
case (Suc n)
  then obtain x where x: "x \<in> S" by force
  define S' where "S' = S - {x}"
  hence "[prod g S' = a ^ n] (mod int p)"
    using x Suc(1)[of S'] Suc(2) Suc(3) by (simp add: card_ge_0_finite)
  moreover have "prod g S = g x * prod g S'"
    using x S'_def Suc(2) prod.remove[of S x g] by fastforce
  ultimately show ?case using x Suc(3) cong_mult
    by simp blast
qed

private lemma l11: assumes "\<not> QuadRes p a"
  shows "card S2 = (p - 1) div 2"
proof -
  have "sum card S2 = 2 * card S2"
    using sum.cong[of S2 S2 card "\<lambda>x. 2"] l1 f_def S2_def assms by fastforce
  moreover have "p - 1 = sum card S2"
    using l4 card_UN_disjoint[of S2 "\<lambda>x. x"] l3 l5 S1_def S2_def by auto
  ultimately show ?thesis by linarith
qed

private lemma l12: assumes "\<not> QuadRes p a"
  shows "[prod Prod S2 = a ^ ((p - 1) div 2)] (mod p)"
  using assms l2 l10 l11 unfolding S2_def by blast

private lemma E_2: assumes "\<not> QuadRes p a"
  shows "[a ^ ((p - 1) div 2) = -1] (mod p)" using l9 l12 cong_trans cong_sym assms by blast

lemma euler_criterion_aux: "[(Legendre a p) = a ^ ((p - 1) div 2)] (mod p)"
  using p_a_relprime by (auto simp add: Legendre_def
    intro!: cong_sym [of _ 1] cong_sym [of _ "- 1"]
    dest: E_1 E_2)

end

theorem euler_criterion: assumes "prime p" "2 < p"
  shows "[(Legendre a p) = a ^ ((p - 1) div 2)] (mod p)"
proof (cases "[a = 0] (mod p)")
  case True
  then have "[a ^ ((p - 1) div 2) = 0 ^ ((p - 1) div 2)] (mod p)"
    using cong_pow by blast
  moreover have "(0::int) ^ ((p - 1) div 2) = 0"
    using zero_power [of "(p - 1) div 2"] assms(2) by simp
  ultimately have "[a ^ ((p - 1) div 2) = 0] (mod p)"
    using True assms(1) prime_dvd_power_int_iff
    by (simp add: cong_iff_dvd_diff)
  then show ?thesis unfolding Legendre_def using True cong_sym
    by auto
next
  case False
  then show ?thesis
    using euler_criterion_aux assms by presburger
qed

hide_fact euler_criterion_aux

end