(*  Title:       Permute
    Authors:     Jasmin Blanchette, Andrei Popescu, Dmitriy Traytel
    Maintainer:  Dmitriy Traytel <traytel at inf.ethz.ch>
*)

section \<open>Changing the Order of Live Variables\<close>

(*<*)
theory Permute
  imports "HOL-Library.BNF_Axiomatization"
begin
(*>*)

unbundle cardinal_syntax

declare [[bnf_internals]]
bnf_axiomatization (dead 'p, Fset1: 'a1, Fset2: 'a2, Fset3: 'a3) F for map: Fmap rel: Frel
type_synonym ('p, 'a1, 'a2, 'a3) F' = "('p, 'a3, 'a1, 'a2) F"

abbreviation Fin :: "'a1 set \<Rightarrow> 'a2 set \<Rightarrow> 'a3 set \<Rightarrow> (('p, 'a1, 'a2, 'a3) F) set" where
  "Fin A1 A2 A3 \<equiv> {x. Fset1 x \<subseteq> A1 \<and> Fset2 x \<subseteq> A2 \<and> Fset3 x \<subseteq> A3}"

abbreviation F'map :: "('a1 \<Rightarrow> 'b1) \<Rightarrow> ('a2 \<Rightarrow> 'b2) \<Rightarrow> ('a3 \<Rightarrow> 'b3) \<Rightarrow> ('p, 'a1, 'a2, 'a3) F' \<Rightarrow> ('p, 'b1, 'b2, 'b3) F'" where
  "F'map f g h \<equiv> Fmap h f g"

abbreviation F'set1 :: "('p, 'a1, 'a2, 'a3) F' \<Rightarrow> 'a1 set" where
  "F'set1 \<equiv> Fset2"

abbreviation F'set2 :: "('p, 'a1, 'a2, 'a3) F' \<Rightarrow> 'a2 set" where
  "F'set2 \<equiv> Fset3"

abbreviation F'set3 :: "('p, 'a1, 'a2, 'a3) F' \<Rightarrow> 'a3 set" where
  "F'set3 \<equiv> Fset1"

abbreviation F'bd where
  "F'bd \<equiv> bd_F"

theorem F'map_id: "F'map id id id = id"
  by (rule F.map_id0)

theorem F'map_comp: "F'map (f1 o g1) (f2 o g2) (f3 o g3) = F'map f1 f2 f3 o F'map g1 g2 g3"
  by (rule F.map_comp0)

theorem F'map_cong: "\<lbrakk>\<And>z. z \<in> F'set1 x \<Longrightarrow> f1 z = g1 z; \<And>z. z \<in> F'set2 x \<Longrightarrow> f2 z = g2 z; \<And>z. z \<in> F'set3 x \<Longrightarrow> f3 z = g3 z\<rbrakk>
  \<Longrightarrow> F'map f1 f2 f3 x = F'map g1 g2 g3 x"
  apply (rule F.map_cong0)
    apply assumption+
  done

theorem F'set1_natural: "F'set1 o F'map f1 f2 f3 = image f1 o F'set1"
  by (rule F.set_map0(2))

theorem F'set2_natural: "F'set2 o F'map f1 f2 f3 = image f2 o F'set2"
  by (rule F.set_map0(3))

theorem F'set3_natural: "F'set3 o F'map f1 f2 f3 = image f3 o F'set3"
  by (rule F.set_map0(1))

theorem F'bd_card_order: "card_order F'bd"
  by (rule F.bd_card_order)

theorem F'bd_cinfinite: "cinfinite F'bd"
  by (rule F.bd_cinfinite)

theorem F'set1_bd: "|F'set1 (x :: ('c, 'a, 'b, 'd) F)| \<le>o (F'bd :: 'c bd_type_F rel)"
  by (rule F.set_bd(2))

theorem F'set3_bd: "|F'set3 (x :: ('c, 'a, 'b, 'd) F)| \<le>o (F'bd :: 'c bd_type_F rel)"
  by (rule F.set_bd(1))

abbreviation F'in :: "'a1 set \<Rightarrow> 'a2 set \<Rightarrow> 'a3 set \<Rightarrow> (('p, 'a1, 'a2, 'a3) F') set" where
  "F'in A1 A2 A3 \<equiv> {x. F'set1 x \<subseteq> A1 \<and> F'set2 x \<subseteq> A2 \<and> F'set3 x \<subseteq> A3}"

lemma F'in_alt: "F'in A1 A2 A3 = Fin A3 A1 A2"
  apply (rule Collect_cong)
  by (tactic \<open>BNF_Tactics.mk_rotate_eq_tac @{context}
  (BNF_Util.rtac @{context} @{thm refl}) @{thm trans} @{thm conj_assoc} @{thm conj_commute} @{thm conj_cong}
  [1, 2, 3] [3, 1, 2] 1\<close>)

definition F'rel where
  "F'rel R1 R2 R3 = (BNF_Def.Grp (F'in (Collect (case_prod R1)) (Collect (case_prod R2)) (Collect (case_prod R3))) (F'map fst fst fst))^--1 OO
                 (BNF_Def.Grp (F'in (Collect (case_prod R1)) (Collect (case_prod R2)) (Collect (case_prod R3))) (F'map snd snd snd))"

lemmas F'rel_unfold = trans[OF F'rel_def trans[OF OO_Grp_cong[OF F'in_alt] sym[OF F.rel_compp_Grp]]]

bnf F': "('p, 'a1, 'a2, 'a3) F'"
  map: F'map
  sets: F'set1 F'set2 F'set3
  bd: "F'bd :: 'p bd_type_F rel"
  rel: F'rel
              apply -
              apply (rule F'map_id)
             apply (rule F'map_comp)
            apply (erule F'map_cong) apply assumption+
           apply (rule F'set1_natural)
          apply (rule F'set2_natural)
         apply (rule F'set3_natural)
        apply (rule F'bd_card_order)
       apply (rule F'bd_cinfinite)
      apply (rule F'set1_bd)
     apply (rule F'set2_bd)
    apply (rule F'set3_bd)
   apply (unfold F'rel_unfold F.rel_compp[symmetric] eq_OO) [1] apply (rule order_refl)
  apply (rule F'rel_def[unfolded OO_Grp_alt mem_Collect_eq])
  done

(*<*)
end
(*>*)


subsection \<open>MulNode Phase\<close>

theory MulPhase
  imports
    Common
    Proofs.StampEvalThms
begin

fun mul_size :: "IRExpr \<Rightarrow> nat" where
  "mul_size (UnaryExpr op e) = (mul_size e) + 2" |
  "mul_size (BinaryExpr BinMul x y) = ((mul_size x) + (mul_size y) + 2) * 2" |
  "mul_size (BinaryExpr op x y) = (mul_size x) + (mul_size y) + 2" |
  "mul_size (ConditionalExpr cond t f) = (mul_size cond) + (mul_size t) + (mul_size f) + 2" |
  "mul_size (ConstantExpr c) = 1" |
  "mul_size (ParameterExpr ind s) = 2" |
  "mul_size (LeafExpr nid s) = 2" |
  "mul_size (ConstantVar c) = 2" |
  "mul_size (VariableExpr x s) = 2"

phase MulNode
  terminating mul_size
begin

(* Word level proofs *)
lemma bin_eliminate_redundant_negative:
  "uminus (x :: 'a::len word) * uminus (y :: 'a::len word) = x * y"
  by simp

lemma bin_multiply_identity:
 "(x :: 'a::len word) * 1 = x"
  by simp

lemma bin_multiply_eliminate:
 "(x :: 'a::len word) * 0 = 0"
  by simp

lemma bin_multiply_negative:
 "(x :: 'a::len word) * uminus 1 = uminus x"
  by simp

lemma bin_multiply_power_2:
 "(x:: 'a::len word) * (2^j) = x << j"
  by simp

(* Helper *)
lemma take_bit64[simp]:
  fixes w :: "int64"
  shows "take_bit 64 w = w"
proof -
  have "Nat.size w = 64"
    by (simp add: size64)
  then show ?thesis
    by (metis lt2p_lem mask_eq_iff take_bit_eq_mask verit_comp_simplify1(2) wsst_TYs(3))
qed

(* TODO: merge this with val_eliminate_redundant_negative *)
lemma mergeTakeBit:
  fixes a :: "nat"
  fixes b c :: "64 word"
  shows "take_bit a (take_bit a (b) * take_bit a (c)) =
         take_bit a (b * c)"
 by (smt (verit, ccfv_SIG) take_bit_mult take_bit_of_int unsigned_take_bit_eq word_mult_def)

(* Value level proofs *)
lemma val_eliminate_redundant_negative:
  assumes "val[-x * -y] \<noteq> UndefVal"
  shows "val[-x * -y] = val[x * y]"
  using assms apply (cases x; cases y; auto)
  using mergeTakeBit by auto

lemma val_multiply_neutral:
  assumes "x = new_int b v"
  shows "val[x * (IntVal b 1)] = val[x]"
  using assms by force

lemma val_multiply_zero:
  assumes "x = new_int b v"
  shows "val[x * (IntVal b 0)] = IntVal b 0"
  using assms by simp

lemma val_multiply_negative:
  assumes "x = new_int b v"
  shows "val[x * intval_negate (IntVal b 1)] = intval_negate x"
  by (smt (verit) Value.disc(1) Value.inject(1) add.inverse_neutral intval_negate.simps(1)
      is_IntVal_def mask_0 mask_eq_take_bit_minus_one new_int.elims of_bool_eq(2) take_bit_dist_neg
      take_bit_of_1 val_eliminate_redundant_negative val_multiply_neutral val_multiply_zero
      verit_minus_simplify(4) zero_neq_one assms)

(* x * 2^i = x << i*)
lemma val_MulPower2:
  fixes i :: "64 word"
  assumes "y = IntVal 64 (2 ^ unat(i))"
  and     "0 < i"
  and     "i < 64"
  and     "val[x * y] \<noteq> UndefVal"
  shows   "val[x * y] = val[x << IntVal 64 i]"
  using assms apply (cases x; cases y; auto)
    subgoal premises p for x2
    proof -
      have 63: "(63 :: int64) = mask 6"
        by eval
      then have "(2::int) ^ 6 = 64"
        by eval
      then have "uint i < (2::int) ^ 6"
        by (metis linorder_not_less lt2p_lem of_int_numeral p(4) size64 word_2p_lem word_of_int_2p
            wsst_TYs(3))
      then have "and i (mask 6) = i"
        using mask_eq_iff by blast
      then show "x2 << unat i = x2 << unat (and i (63::64 word))"
        unfolding 63
        by force
    qed
    by presburger

(*  x * ((2 ^ j) + 1) = (x << j) + x  *)
lemma val_MulPower2Add1:
  fixes i :: "64 word"
  assumes "y = IntVal 64 ((2 ^ unat(i)) + 1)"
  and     "0 < i"
  and     "i < 64"
  and     "val_to_bool(val[IntVal 64 0 < x])"
  and     "val_to_bool(val[IntVal 64 0 < y])"
  shows   "val[x * y] = val[(x << IntVal 64 i) + x]"
  using assms apply (cases x; cases y; auto)
    subgoal premises p for x2
  proof -
    have 63: "(63 :: int64) = mask 6"
      by eval
    then have "(2::int) ^ 6 = 64"
      by eval
    then have "and i (mask 6) = i"
      using mask_eq_iff by (simp add: less_mask_eq p(6))
    then have "x2 * ((2::64 word) ^ unat i + (1::64 word)) = (x2 * ((2::64 word) ^ unat i)) + x2"
      by (simp add: distrib_left)
    then show "x2 * ((2::64 word) ^ unat i + (1::64 word)) = x2 << unat (and i (63::64 word)) + x2"
      by (simp add: "63" \<open>and (i::64 word) (mask (6::nat)) = i\<close>)
    qed
    using val_to_bool.simps(2) by presburger

(*  x * ((2 ^ j) - 1) = (x << j) - x  *)
lemma val_MulPower2Sub1:
  fixes i :: "64 word"
  assumes "y = IntVal 64 ((2 ^ unat(i)) - 1)"
  and     "0 < i"
  and     "i < 64"
  and     "val_to_bool(val[IntVal 64 0 < x])"
  and     "val_to_bool(val[IntVal 64 0 < y])"
  shows   "val[x * y] = val[(x << IntVal 64 i) - x]"
  using assms apply (cases x; cases y; auto)
    subgoal premises p for x2
  proof -
    have 63: "(63 :: int64) = mask 6"
      by eval
    then have "(2::int) ^ 6 = 64"
      by eval
    then have "and i (mask 6) = i"
      using mask_eq_iff by (simp add: less_mask_eq p(6))
    then have "x2 * ((2::64 word) ^ unat i - (1::64 word)) = (x2 * ((2::64 word) ^ unat i)) - x2"
      by (simp add: right_diff_distrib')
    then show "x2 * ((2::64 word) ^ unat i - (1::64 word)) = x2 << unat (and i (63::64 word)) - x2"
      by (simp add: "63" \<open>and (i::64 word) (mask (6::nat)) = i\<close>)
    qed
    using val_to_bool.simps(2) by presburger

(* Value level helpers *)
lemma val_distribute_multiplication:
  assumes "x = new_int 64 xx \<and> q = new_int 64 qq \<and> a = new_int 64 aa"
  shows "val[x * (q + a)] = val[(x * q) + (x * a)]"
  apply (cases x; cases q; cases a; auto) using distrib_left assms by auto

(*  x * ((2 ^ j) + (2 ^ k)) = (x << j) + (x << k)  *)
lemma val_MulPower2AddPower2:
  fixes i j :: "64 word"
  assumes "y = IntVal 64 ((2 ^ unat(i)) + (2 ^ unat(j)))"
  and     "0 < i"
  and     "0 < j"
  and     "i < 64"
  and     "j < 64"
  and     "x = new_int 64 xx"
  shows   "val[x * y] = val[(x << IntVal 64 i) + (x << IntVal 64 j)]"
  using assms
  proof -
    have 63: "(63 :: int64) = mask 6"
      by eval
    then have "(2::int) ^ 6 = 64"
      by eval
    then have n: "IntVal 64 ((2 ^ unat(i)) + (2 ^ unat(j))) =
           val[(IntVal 64 (2 ^ unat(i))) + (IntVal 64 (2 ^ unat(j)))]"
       (* x * (2^i + 2^j)*)
      using assms by (cases i; cases j; auto)
   then have 1: "val[x * ((IntVal 64 (2 ^ unat(i))) + (IntVal 64 (2 ^ unat(j))))] =
           val[(x * IntVal 64 (2 ^ unat(i))) + (x * IntVal 64 (2 ^ unat(j)))]"
      (* (x * 2^i) + (x * 2^j)*)
     using assms val_distribute_multiplication val_MulPower2 by simp
   then have 2: "val[(x * IntVal 64 (2 ^ unat(i)))] = val[x << IntVal 64 i]"
     by (smt (verit) Value.distinct(1) intval_mul.simps(1) new_int.simps new_int_bin.simps assms
         val_MulPower2)
   then show "?thesis"
     by (smt (verit, del_insts) "1" Value.distinct(1) assms(1) assms(3) assms(5) assms(6)
         intval_mul.simps(1) n new_int.simps new_int_bin.elims val_MulPower2)
   qed

thm_oracles val_MulPower2AddPower2

(* Exp-level proofs *)
lemma exp_multiply_zero_64:
 "exp[x * (const (IntVal 64 0))] \<ge> ConstantExpr (IntVal 64 0)"
  using val_multiply_zero apply auto
  by (smt (verit) Value.inject(1) constantAsStamp.simps(1) int_signed_value_bounds intval_mul.elims
        mult_zero_right new_int.simps new_int_bin.simps nle_le numeral_eq_Suc take_bit_of_0
        unfold_const valid_stamp.simps(1) valid_value.simps(1) zero_less_Suc wf_value_def)

lemma exp_multiply_neutral:
 "exp[x * (const (IntVal b 1))] \<ge> x"
  using val_multiply_neutral apply auto
  by (smt (verit) Value.inject(1) eval_unused_bits_zero intval_mul.elims mult.right_neutral
      new_int.elims new_int_bin.elims)

thm_oracles exp_multiply_neutral

lemma exp_MulPower2:
  fixes i :: "64 word"
  assumes "y = ConstantExpr (IntVal 64 (2 ^ unat(i)))"
  and     "0 < i"
  and     "i < 64"
  and     "exp[x > (const IntVal b 0)]"
  and     "exp[y > (const IntVal b 0)]"
  shows "exp[x * y] \<ge> exp[x << ConstantExpr (IntVal 64 i)]"
   using assms apply simp
  by (metis ConstantExprE equiv_exprs_def unfold_binary)

lemma exp_MulPower2Add1:
  fixes i :: "64 word"
  assumes "y = ConstantExpr (IntVal 64 ((2 ^ unat(i)) + 1))"
  and     "0 < i"
  and     "i < 64"
  and     "exp[x > (const IntVal b 0)]"
  and     "exp[y > (const IntVal b 0)]"
shows   "exp[x * y] \<ge> exp[(x << ConstantExpr (IntVal 64 i)) + x]"
   using assms apply simp
  by (metis (no_types, lifting) ConstantExprE equiv_exprs_def unfold_binary)

lemma exp_MulPower2Sub1:
  fixes i :: "64 word"
  assumes "y = ConstantExpr (IntVal 64 ((2 ^ unat(i)) - 1))"
  and     "0 < i"
  and     "i < 64"
  and     "exp[x > (const IntVal b 0)]"
  and     "exp[y > (const IntVal b 0)]"
shows   "exp[x * y] \<ge> exp[(x << ConstantExpr (IntVal 64 i)) - x]"
   using assms apply simp
  by (metis (no_types, lifting) ConstantExprE equiv_exprs_def unfold_binary)

lemma exp_MulPower2AddPower2:
  fixes i j :: "64 word"
  assumes "y = ConstantExpr (IntVal 64 ((2 ^ unat(i)) + (2 ^ unat(j))))"
  and     "0 < i"
  and     "0 < j"
  and     "i < 64"
  and     "j < 64"
  and     "exp[x > (const IntVal b 0)]"
  and     "exp[y > (const IntVal b 0)]"
shows   "exp[x * y] \<ge> exp[(x << ConstantExpr (IntVal 64 i)) + (x << ConstantExpr (IntVal 64 j))]"
   using assms apply simp
  by (metis (no_types, lifting) ConstantExprE equiv_exprs_def unfold_binary)

(* Exp level helpers *)

(* Subgoal is false *)
lemma greaterConstant:
  fixes a b :: "64 word"
  assumes "a > b"
  and     "y = ConstantExpr (IntVal 64 a)"
  and     "x = ConstantExpr (IntVal 64 b)"
  shows "exp[y > x]"
  apply auto
  sorry

lemma exp_distribute_multiplication:
  shows "exp[(x * q) + (x * a)] \<ge> exp[x * (q + a)]"
  sorry

text \<open>Optimisations\<close>

optimization EliminateRedundantNegative: "-x * -y \<longmapsto> x * y"
  using mul_size.simps apply auto
  by (metis BinaryExpr val_eliminate_redundant_negative bin_eval.simps(2))

optimization MulNeutral: "x * ConstantExpr (IntVal b 1) \<longmapsto> x"
  using exp_multiply_neutral by blast

optimization MulEliminator: "x * ConstantExpr (IntVal b 0) \<longmapsto> const (IntVal b 0)"
   apply auto
  by (smt (verit) Value.inject(1) constantAsStamp.simps(1) int_signed_value_bounds intval_mul.elims
      mult_zero_right new_int.simps new_int_bin.simps take_bit_of_0 unfold_const
      valid_stamp.simps(1) valid_value.simps(1) val_multiply_zero)

optimization MulNegate: "x * -(const (IntVal b 1)) \<longmapsto> -x"
  apply auto
  by (smt (verit) Value.distinct(1) Value.sel(1) add.inverse_inverse intval_mul.elims
      intval_negate.simps(1) mask_eq_take_bit_minus_one new_int.simps new_int_bin.simps
      take_bit_dist_neg unary_eval.simps(2) unfold_unary val_multiply_negative
      val_eliminate_redundant_negative val_multiply_negative wf_value_def)

fun isNonZero :: "Stamp \<Rightarrow> bool" where
  "isNonZero (IntegerStamp b lo hi) = (lo > 0)" |
  "isNonZero _ = False"

lemma isNonZero_defn:
  assumes "isNonZero (stamp_expr x)"
  assumes "wf_stamp x"
  shows "([m, p] \<turnstile> x \<mapsto> v) \<longrightarrow> (\<exists>vv b. (v = IntVal b vv \<and> val_to_bool val[(IntVal b 0) < v]))"
  apply (rule impI) subgoal premises eval
proof -
  obtain b lo hi where xstamp: "stamp_expr x = IntegerStamp b lo hi"
    by (meson isNonZero.elims(2) assms)
  then obtain vv where vdef: "v = IntVal b vv"
    by (metis assms(2) eval valid_int wf_stamp_def)
  have "lo > 0"
    using assms(1) xstamp by force
  then have signed_above: "int_signed_value b vv > 0"
    using assms unfolding wf_stamp_def
    using eval vdef xstamp by fastforce
  have "take_bit b vv = vv"
    using eval eval_unused_bits_zero vdef by auto
  then have "vv > 0"
    by (metis bit_take_bit_iff int_signed_value.simps not_less_zero signed_eq_0_iff
        signed_take_bit_eq_if_positive take_bit_0 take_bit_of_0 verit_comp_simplify1(1) word_gt_0
        signed_above)
  then show ?thesis
    using vdef signed_above
    by simp
qed
  done

optimization MulPower2: "x * y \<longmapsto> x << const (IntVal 64 i)
                              when (i > 0 \<and>
                                    64 > i \<and>
                                    y = exp[const (IntVal 64 (2 ^ unat(i)))])"
   defer
   apply simp apply (rule impI; (rule allI)+; rule impI)
  subgoal premises eval for m p v
proof -
  obtain xv where xv: "[m, p] \<turnstile> x \<mapsto> xv"
    using eval(2) by blast
  then obtain xvv where xvv: "xv = IntVal 64 xvv"
    by (smt (verit) ConstantExprE bin_eval.simps(2) evalDet intval_bits.simps intval_mul.elims
          new_int_bin.simps unfold_binary eval)
  obtain yv where yv: "[m, p] \<turnstile> y \<mapsto> yv"
    using eval(1) eval(2) by blast
  then have lhs: "[m, p] \<turnstile> exp[x * y] \<mapsto> val[xv * yv]"
    by (metis bin_eval.simps(2) eval(1) eval(2) evalDet unfold_binary xv)
  have "[m, p] \<turnstile> exp[const (IntVal 64 i)] \<mapsto> val[(IntVal 64 i)]"
    by (smt (verit, ccfv_SIG) ConstantExpr constantAsStamp.simps(1) eval_bits_1_64 take_bit64
        validStampIntConst wf_value_def valid_value.simps(1) xv xvv)
  then have rhs: "[m, p] \<turnstile> exp[x << const (IntVal 64 i)] \<mapsto> val[xv << (IntVal 64 i)]"
    using xv xvv using evaltree.BinaryExpr
    by (metis Value.simps(5) bin_eval.simps(8) intval_left_shift.simps(1) new_int.simps)
  have "val[xv * yv] = val[xv << (IntVal 64 i)]"
    by (metis ConstantExprE eval(1) evaltree_not_undef lhs yv val_MulPower2)
  then show ?thesis
    by (metis eval(1) eval(2) evalDet lhs rhs)
qed
  done

optimization MulPower2Add1: "x * y \<longmapsto> (x << const (IntVal 64 i)) + x
                              when (i > 0 \<and>
                                    64 > i \<and>
                                    y = ConstantExpr (IntVal 64 ((2 ^ unat(i)) + 1)) )"
   defer
   apply simp apply (rule impI; (rule allI)+; rule impI)
  subgoal premises p for m p v
  proof -
    obtain xv where xv: "[m, p] \<turnstile> x \<mapsto> xv"
      using p by fast
    then obtain xvv where xvv: "xv = IntVal 64 xvv"
      by (smt (verit) p ConstantExprE bin_eval.simps(2) evalDet intval_bits.simps intval_mul.elims
          new_int_bin.simps unfold_binary)
    obtain yv where yv: "[m, p] \<turnstile> y \<mapsto> yv"
      using p  by blast
    have ygezero: "y > ConstantExpr (IntVal 64 0)"
      using greaterConstant p wf_value_def by fastforce
    then have 1: "0 < i \<and>
                  i < 64 \<and>
                  y = ConstantExpr (IntVal 64 ((2 ^ unat(i)) + 1))"
      using p by blast
    then have lhs: "[m, p] \<turnstile> exp[x * y] \<mapsto> val[xv * yv]"
      by (metis bin_eval.simps(2) evalDet p(1) p(2) xv yv unfold_binary)
    then have "[m, p] \<turnstile> exp[const (IntVal 64 i)] \<mapsto> val[(IntVal 64 i)]"
      by (metis wf_value_def verit_comp_simplify1(2) zero_less_numeral ConstantExpr
          constantAsStamp.simps(1) take_bit64 validStampIntConst valid_value.simps(1))
    then have rhs2: "[m, p] \<turnstile> exp[x << const (IntVal 64 i)] \<mapsto> val[xv << (IntVal 64 i)]"
      by (metis Value.simps(5) bin_eval.simps(8) intval_left_shift.simps(1) new_int.simps xv xvv
          evaltree.BinaryExpr)
    then have rhs: "[m, p] \<turnstile> exp[(x << const (IntVal 64 i)) + x] \<mapsto> val[(xv << (IntVal 64 i)) + xv]"
       by (metis (no_types, lifting) intval_add.simps(1) rhs2 bin_eval.simps(1) Value.simps(5)
           evaltree.BinaryExpr intval_left_shift.simps(1) new_int.simps xv xvv)
     then have simple: "val[xv * (IntVal 64 (2 ^ unat(i)))] = val[xv << (IntVal 64 i)]"
       using val_MulPower2  sorry
     then have "val[xv * yv] = val[(xv << (IntVal 64 i)) + xv]"
        sorry
     then show ?thesis
       by (metis "1" evalDet lhs p(2) rhs)
  qed
  done

(* Need to prove exp_MulPower2Sub1 *)
optimization MulPower2Sub1: "x * y \<longmapsto> (x << const (IntVal 64 i)) - x
                              when (i > 0 \<and>
                                    64 > i \<and>
                                    y = ConstantExpr (IntVal 64 ((2 ^ unat(i)) - 1)) )"
   defer
   apply simp apply (rule impI; (rule allI)+; rule impI)
  subgoal premises p for m p v
  proof -
    obtain xv where xv: "[m,p] \<turnstile> x \<mapsto> xv"
      using p by fast
    then obtain xvv where xvv: "xv = IntVal 64 xvv"
      by (smt (verit) p ConstantExprE bin_eval.simps(2) evalDet intval_bits.simps intval_mul.elims
          new_int_bin.simps unfold_binary)
    obtain yv where yv: "[m,p] \<turnstile> y \<mapsto> yv"
      using p  by blast
    have ygezero: "y > ConstantExpr (IntVal 64 0)"
      by (smt (verit, del_insts) eq_iff_diff_eq_0 mask_0 mask_eq_exp_minus_1 power_inject_exp
          uint_2p unat_eq_zero word_gt_0 zero_neq_one greaterConstant p)
    then have 1: "0 < i \<and>
                  i < 64 \<and>
                  y = ConstantExpr (IntVal 64 ((2 ^ unat(i)) - 1))"
      using p by blast
    then have lhs: "[m, p] \<turnstile> exp[x * y] \<mapsto> val[xv * yv]"
      by (metis bin_eval.simps(2) evalDet p(1) p(2) xv yv unfold_binary)
    then have "[m, p] \<turnstile> exp[const (IntVal 64 i)] \<mapsto> val[(IntVal 64 i)]"
      by (metis wf_value_def verit_comp_simplify1(2) zero_less_numeral ConstantExpr
          constantAsStamp.simps(1) take_bit64 validStampIntConst valid_value.simps(1))
    then have rhs2: "[m, p] \<turnstile> exp[x << const (IntVal 64 i)] \<mapsto> val[xv << (IntVal 64 i)]"
      by (metis Value.simps(5) bin_eval.simps(8) intval_left_shift.simps(1) new_int.simps xv xvv
          evaltree.BinaryExpr)
    then have rhs: "[m, p] \<turnstile> exp[(x << const (IntVal 64 i)) - x] \<mapsto> val[(xv << (IntVal 64 i)) - xv]"
      by (smt (verit, ccfv_threshold) bin_eval.simps(3) new_int_bin.simps intval_sub.simps(1)
          rhs2 bin_eval.simps(1) Value.simps(5) evaltree.BinaryExpr intval_left_shift.simps(1)
          new_int.simps xv xvv )
    then have "val[xv * yv] = val[(xv << (IntVal 64 i)) - xv]"
       using "1" exp_MulPower2Sub1 ygezero sorry
     then show ?thesis
      by (metis evalDet lhs p(1) p(2) rhs)
  qed
done

end (* End of MulPhase *)

end (* End of file *)


(*  Title:      HOL/Auth/n_mutualExSimp_lemma_inv__2_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_mutualExSimp Protocol Case Study*}

theory n_mutualExSimp_lemma_inv__2_on_rules imports n_mutualExSimp_lemma_on_inv__2
begin
section{*All lemmas on causal relation between inv__2*}
lemma lemma_inv__2_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__2  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_Crit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Exit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Idle  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Crit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_CritVsinv__2) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Exit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_ExitVsinv__2) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Idle  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_IdleVsinv__2) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


(*  File:       Elect_Module_Ref.thy
    Copyright   2023  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Valentin, Karlsruhe Institute of Technology (KIT)"\<close>

theory Elect_Module_Ref
  imports "Verified_Voting_Rule_Construction.Elect_Module"
    "Component_Types/Electoral_Module_Ref"

begin

section \<open>Refined Elect Module\<close>

text \<open>This is more or less an experimental artifacts. We use the elector instead\<close>

 \<comment> \<open>The elect module should not return just the reference to all alternatives
  but a deep copy.\<close>

definition aux_set_copy :: "'a set \<Rightarrow> 'a set nres" where
  "aux_set_copy A \<equiv>  FOREACH A
     (\<lambda> x cp. RETURN (insert x cp)) {}"

lemma aux_set_copy_correct:
  shows "(aux_set_copy, (RETURN o op_set_copy))
    \<in> [\<lambda> s. finite s]\<^sub>f \<langle>Id\<rangle>set_rel \<rightarrow> \<langle>\<langle>Id\<rangle>set_rel\<rangle>nres_rel"
  unfolding aux_set_copy_def comp_apply
  apply (intro frefI nres_relI, clarsimp)
proof (rename_tac A)
  fix A :: "'a set"
  assume fina: "finite A"
  show "FOREACH A (\<lambda>x cp. RETURN (insert x cp)) {} \<le> RETURN A"
    apply (refine_vcg FOREACH_rule[where I = "\<lambda> it x.
      x = A -it"])
    by (auto simp add: fina)
qed

subsection \<open>Defintion\<close>

fun elect_module_ref :: "'a Electoral_Module_Ref" where
  "elect_module_ref A p = do {
   B \<leftarrow> aux_set_copy A;
   RETURN (B,{},{})
}"

lemma elect_module_ref_correct:
  shows "(uncurry elect_module_ref, uncurry (RETURN oo elect_module))
      \<in> [\<lambda> (A, pl). finite A]\<^sub>f (\<langle>Id\<rangle>set_rel \<times>\<^sub>r profile_rel)
  \<rightarrow> \<langle>\<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>Id\<rangle>set_rel\<rangle>nres_rel"
  unfolding elect_module_ref.simps elect_module.simps aux_set_copy_def
  apply (intro frefI fun_relI nres_relI) unfolding comp_apply
  apply clarsimp
proof (rename_tac A pl pr)
  fix A:: "'a set"
  fix pl pr
 assume fina: "finite A"
  from fina show "FOREACH A (\<lambda>x cp. RETURN (insert x cp)) {} \<bind> (\<lambda>B. RETURN (B, {}, {})) \<le> RETURN (A, {}, {})"
    apply (refine_vcg)
    apply (auto)
    using aux_set_copy_correct[THEN frefD, THEN nres_relD] aux_set_copy_def
    by (smt (verit, ccfv_threshold) RES_sng_eq_RETURN op_set_copy_def pair_in_Id_conv push_in_let_conv(2) refine_IdD set_rel_id_simp)

qed

sepref_definition hs_copy_sep is "aux_set_copy" ::
  " (hs.assn id_assn)\<^sup>k
 \<rightarrow>\<^sub>a (hs.assn id_assn)"
  unfolding aux_set_copy_def hs.fold_custom_empty
  by sepref

lemma hs_copy_hnr_aux: "(hs_copy_sep,RETURN o op_set_copy)
  \<in> [\<lambda> s. finite s]\<^sub>a (hs.assn id_assn)\<^sup>k \<rightarrow> hs.assn id_assn"
  using hs_copy_sep.refine[FCOMP aux_set_copy_correct] by auto

sepref_definition elect_module_sep is
  "uncurry elect_module_ref" ::
"(alts_set_impl_assn id_assn)\<^sup>k *\<^sub>a (profile_impl_assn id_assn)\<^sup>k
    \<rightarrow>\<^sub>a (result_impl_assn id_assn)"
  unfolding elect_module_ref.simps aux_set_copy_def hs.fold_custom_empty
  by sepref

lemma elect_module_sep_correct:
  shows "(uncurry elect_module_sep, uncurry (RETURN \<circ>\<circ> elect_module)) \<in>  [\<lambda>(a, b).
           finite
            a]\<^sub>a (alts_set_impl_assn id_assn)\<^sup>k *\<^sub>a
                 (list_assn
                   (hr_comp (ballot_impl_assn id_assn)
                     ballot_rel))\<^sup>k \<rightarrow> result_impl_assn id_assn"
  using
 elect_module_sep.refine[FCOMP elect_module_ref_correct]  set_rel_id hr_comp_Id2 by simp

declare elect_module_sep_correct[sepref_fr_rules]

end


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

theory Empty_Fail
  imports
    NonDetMonad
    WPSimp
begin

section \<open>Monads that are wellformed w.r.t. failure\<close>

text \<open>
  Usually, well-formed monads constructed from the primitives in NonDetMonad will have the following
  property: if they return an empty set of results, they will have the failure flag set.\<close>
definition empty_fail :: "('s,'a) nondet_monad \<Rightarrow> bool" where
  "empty_fail m \<equiv> \<forall>s. fst (m s) = {} \<longrightarrow> snd (m s)"

text \<open>Useful in forcing otherwise unknown executions to have the @{const empty_fail} property.\<close>
definition mk_ef :: "'a set \<times> bool \<Rightarrow> 'a set \<times> bool" where
  "mk_ef S \<equiv> (fst S, fst S = {} \<or> snd S)"

subsection \<open>WPC setup\<close>

lemma wpc_helper_empty_fail_final:
  "empty_fail f \<Longrightarrow> wpc_helper (P, P') (Q, Q') (empty_fail f)"
  by (clarsimp simp: wpc_helper_def)

wpc_setup "\<lambda>m. empty_fail m" wpc_helper_empty_fail_final

subsection \<open>@{const empty_fail} intro/dest rules\<close>

lemma empty_failI:
  "(\<And>s. fst (m s) = {} \<Longrightarrow> snd (m s)) \<Longrightarrow> empty_fail m"
  by (simp add: empty_fail_def)

lemma empty_failD:
  "\<lbrakk> empty_fail m; fst (m s) = {} \<rbrakk> \<Longrightarrow> snd (m s)"
  by (simp add: empty_fail_def)

lemma empty_fail_not_snd:
  "\<lbrakk> \<not> snd (m s); empty_fail m \<rbrakk> \<Longrightarrow> \<exists>v. v \<in> fst (m s)"
  by (fastforce simp: empty_fail_def)

lemmas empty_failD2 = empty_fail_not_snd[rotated]

lemma empty_failD3:
  "\<lbrakk> empty_fail f; \<not> snd (f s) \<rbrakk> \<Longrightarrow> fst (f s) \<noteq> {}"
  by (drule(1) empty_failD2, clarsimp)

lemma empty_fail_bindD1:
  "empty_fail (a >>= b) \<Longrightarrow> empty_fail a"
  unfolding empty_fail_def bind_def
  by (fastforce simp: split_def image_image)

subsection \<open>Wellformed monads\<close>

(*
  Collect generic empty_fail lemmas here:
   - naming convention is emtpy_fail_NAME.
   - add lemmas with assumptions to [empty_fail_cond] set
   - add lemmas without assumption to [empty_fail_term] set
*)

named_theorems empty_fail_term
named_theorems empty_fail_cond

lemma empty_fail_K_bind[empty_fail_cond]:
  "empty_fail f \<Longrightarrow> empty_fail (K_bind f x)"
  by simp

lemma empty_fail_fun_app[empty_fail_cond]:
  "empty_fail (f x) \<Longrightarrow> empty_fail (f $ x)"
  by simp

(* empty_fail as such does not need context, but empty_fail_select_f does, so we need to build
   up context in other rules *)
lemma empty_fail_If[empty_fail_cond]:
  "\<lbrakk> P \<Longrightarrow> empty_fail f; \<not>P \<Longrightarrow> empty_fail g \<rbrakk> \<Longrightarrow> empty_fail (if P then f else g)"
  by (simp split: if_split)

lemma empty_fail_If_applied[empty_fail_cond]:
  "\<lbrakk> P \<Longrightarrow> empty_fail (f x); \<not>P \<Longrightarrow> empty_fail (g x) \<rbrakk> \<Longrightarrow> empty_fail ((if P then f else g) x)"
  by simp

lemma empty_fail_put[empty_fail_term]:
  "empty_fail (put f)"
  by (simp add: put_def empty_fail_def)

lemma empty_fail_modify[empty_fail_term]:
  "empty_fail (modify f)"
  by (simp add: empty_fail_def simpler_modify_def)

lemma empty_fail_gets[empty_fail_term]:
  "empty_fail (gets f)"
  by (simp add: empty_fail_def simpler_gets_def)

lemma empty_fail_select[empty_fail_cond]:
  "S \<noteq> {} \<Longrightarrow> empty_fail (select S)"
  by (simp add: empty_fail_def select_def)

lemma empty_fail_select_f[empty_fail_cond]:
  assumes ef: "fst S = {} \<Longrightarrow> snd S"
  shows "empty_fail (select_f S)"
  by (fastforce simp add: empty_fail_def select_f_def intro: ef)

lemma empty_fail_bind[empty_fail_cond]:
  "\<lbrakk> empty_fail a; \<And>x. empty_fail (b x) \<rbrakk> \<Longrightarrow> empty_fail (a >>= b)"
  by (fastforce simp: bind_def empty_fail_def split_def)

lemma empty_fail_return[empty_fail_term]:
  "empty_fail (return x)"
  by (simp add: empty_fail_def return_def)

lemma empty_fail_returnOk[empty_fail_term]:
  "empty_fail (returnOk v)"
  by (fastforce simp: returnOk_def empty_fail_term)

lemma empty_fail_throwError[empty_fail_term]:
  "empty_fail (throwError v)"
  by (fastforce simp: throwError_def empty_fail_term)

lemma empty_fail_lift[empty_fail_cond]:
  "\<lbrakk> \<And>x. empty_fail (f x) \<rbrakk> \<Longrightarrow> empty_fail (lift f x)"
  unfolding lift_def
  by (auto simp: empty_fail_term split: sum.split)

lemma empty_fail_liftE[empty_fail_cond]:
  "empty_fail f \<Longrightarrow> empty_fail (liftE f)"
  by (simp add: liftE_def empty_fail_cond empty_fail_term)

lemma empty_fail_bindE[empty_fail_cond]:
  "\<lbrakk> empty_fail f; \<And>rv. empty_fail (g rv) \<rbrakk> \<Longrightarrow> empty_fail (f >>=E g)"
  by (simp add: bindE_def empty_fail_cond)

lemma empty_fail_mapM[empty_fail_cond]:
  assumes m: "\<And>x. x \<in> set xs \<Longrightarrow> empty_fail (m x)"
  shows "empty_fail (mapM m xs)"
using m
proof (induct xs)
  case Nil
  thus ?case by (simp add: mapM_def sequence_def empty_fail_term)
next
  case Cons
  have P: "\<And>m x xs. mapM m (x # xs) = (do y \<leftarrow> m x; ys \<leftarrow> (mapM m xs); return (y # ys) od)"
    by (simp add: mapM_def sequence_def Let_def)
  from Cons
  show ?case by (simp add: P m empty_fail_cond empty_fail_term)
qed

lemma empty_fail_fail[empty_fail_term]:
  "empty_fail fail"
  by (simp add: fail_def empty_fail_def)

lemma empty_fail_assert[empty_fail_term]:
  "empty_fail (assert P)"
  unfolding assert_def by (simp add: empty_fail_term)

lemma empty_fail_assert_opt[empty_fail_term]:
  "empty_fail (assert_opt x)"
  by (simp add: assert_opt_def empty_fail_term split: option.splits)

lemma empty_fail_mk_ef[empty_fail_term]:
  "empty_fail (mk_ef o m)"
  by (simp add: empty_fail_def mk_ef_def)

lemma empty_fail_gets_the[empty_fail_term]:
  "empty_fail (gets_the f)"
  unfolding gets_the_def
  by (simp add: empty_fail_cond empty_fail_term)

lemma empty_fail_gets_map[empty_fail_term]:
  "empty_fail (gets_map f p)"
  unfolding gets_map_def
  by (simp add: empty_fail_term empty_fail_cond)

lemma empty_fail_whenEs[empty_fail_cond]:
  "(P \<Longrightarrow> empty_fail f) \<Longrightarrow> empty_fail (whenE P f)"
  "(\<not>P \<Longrightarrow> empty_fail f) \<Longrightarrow> empty_fail (unlessE P f)"
  by (auto simp add: whenE_def unlessE_def empty_fail_term)

lemma empty_fail_assertE[empty_fail_term]:
  "empty_fail (assertE P)"
  by (simp add: assertE_def empty_fail_term)

lemma empty_fail_get[empty_fail_term]:
  "empty_fail get"
  by (simp add: empty_fail_def get_def)

lemma empty_fail_catch[empty_fail_cond]:
  "\<lbrakk> empty_fail f; \<And>x. empty_fail (g x) \<rbrakk> \<Longrightarrow> empty_fail (catch f g)"
  by (simp add: catch_def empty_fail_cond empty_fail_term split: sum.split)

lemma empty_fail_guard[empty_fail_term]:
  "empty_fail (state_assert G)"
  by (clarsimp simp: state_assert_def empty_fail_cond empty_fail_term)

lemma empty_fail_spec[empty_fail_term]:
  "empty_fail (state_select F)"
  by (clarsimp simp: state_select_def empty_fail_def)

lemma empty_fail_when[empty_fail_cond]:
  "(P \<Longrightarrow> empty_fail x) \<Longrightarrow> empty_fail (when P x)"
  unfolding when_def
  by (simp add: empty_fail_term)

lemma empty_fail_unless[empty_fail_cond]:
  "(\<not>P \<Longrightarrow> empty_fail f) \<Longrightarrow> empty_fail (unless P f)"
  unfolding unless_def
  by (simp add: empty_fail_cond)

lemma empty_fail_liftM[empty_fail_cond]:
  "empty_fail m \<Longrightarrow> empty_fail (liftM f m)"
  unfolding liftM_def
  by (fastforce simp: empty_fail_term empty_fail_cond)

lemma empty_fail_liftME[empty_fail_cond]:
  "empty_fail m \<Longrightarrow> empty_fail (liftME f m)"
  unfolding liftME_def
  by (simp add: empty_fail_term empty_fail_cond)

lemma empty_fail_handleE[empty_fail_cond]:
  "\<lbrakk> empty_fail L; \<And>r. empty_fail (R r) \<rbrakk> \<Longrightarrow> empty_fail (L <handle> R)"
  by (clarsimp simp: handleE_def handleE'_def empty_fail_term empty_fail_cond split: sum.splits)

lemma empty_fail_handle'[empty_fail_cond]:
  "\<lbrakk>empty_fail f; \<And>e. empty_fail (handler e)\<rbrakk> \<Longrightarrow> empty_fail (f <handle2> handler)"
  unfolding handleE'_def
  by (fastforce simp: empty_fail_term empty_fail_cond split: sum.splits)

lemma empty_fail_sequence[empty_fail_cond]:
  "(\<And>m. m \<in> set ms \<Longrightarrow> empty_fail m) \<Longrightarrow> empty_fail (sequence ms)"
  unfolding sequence_def
  by (induct ms; simp add: empty_fail_term empty_fail_cond)

lemma empty_fail_sequence_x[empty_fail_cond]:
  "(\<And>m. m \<in> set ms \<Longrightarrow> empty_fail m) \<Longrightarrow> empty_fail (sequence_x ms)"
  unfolding sequence_x_def
  by (induct ms; simp add: empty_fail_term empty_fail_cond)

lemma empty_fail_sequenceE[empty_fail_cond]:
  "(\<And>m. m \<in> set ms \<Longrightarrow> empty_fail m) \<Longrightarrow> empty_fail (sequenceE ms)"
  unfolding sequenceE_def
  by (induct ms; simp add: empty_fail_term empty_fail_cond)

lemma empty_fail_sequenceE_x[empty_fail_cond]:
  "(\<And>m. m \<in> set ms \<Longrightarrow> empty_fail m) \<Longrightarrow> empty_fail (sequenceE_x ms)"
  unfolding sequenceE_x_def
  by (induct ms; simp add: empty_fail_term empty_fail_cond)

lemma empty_fail_mapM_x[empty_fail_cond]:
  "(\<And>m. m \<in> f ` set ms \<Longrightarrow> empty_fail m) \<Longrightarrow> empty_fail (mapM_x f ms)"
  unfolding mapM_x_def
  by (fastforce intro: empty_fail_term empty_fail_cond)

lemma empty_fail_mapME[empty_fail_cond]:
  "(\<And>m. m \<in> f ` set xs \<Longrightarrow> empty_fail m) \<Longrightarrow> empty_fail (mapME f xs)"
  unfolding mapME_def
  by (fastforce intro: empty_fail_term empty_fail_cond)

lemma empty_fail_mapME_x[empty_fail_cond]:
  "(\<And>m'. m' \<in> f ` set xs \<Longrightarrow> empty_fail m') \<Longrightarrow> empty_fail (mapME_x f xs)"
  unfolding mapME_x_def
  by (fastforce intro: empty_fail_term empty_fail_cond)

lemma empty_fail_filterM[empty_fail_cond]:
  "(\<And>m. m \<in> set ms \<Longrightarrow> empty_fail (P m)) \<Longrightarrow> empty_fail (filterM P ms)"
  by (induct ms; simp add: empty_fail_term empty_fail_cond)

lemma empty_fail_zipWithM_x[empty_fail_cond]:
  "(\<And>x y. empty_fail (f x y)) \<Longrightarrow> empty_fail (zipWithM_x f xs ys)"
  unfolding zipWithM_x_def zipWith_def
  by (fastforce intro: empty_fail_term empty_fail_cond)

lemma empty_fail_zipWithM[empty_fail_cond]:
  "(\<And>x y. empty_fail (f x y)) \<Longrightarrow> empty_fail (zipWithM f xs ys)"
  unfolding zipWithM_def zipWith_def
  by (fastforce intro: empty_fail_term empty_fail_cond)

lemma empty_fail_maybeM[empty_fail_cond]:
  "\<forall>x. empty_fail (f x) \<Longrightarrow> empty_fail (maybeM f t)"
  unfolding maybeM_def
  by (fastforce intro: empty_fail_term split: option.splits)

lemma empty_fail_ifM[empty_fail_cond]:
  "\<lbrakk> empty_fail P; empty_fail a; empty_fail b \<rbrakk> \<Longrightarrow> empty_fail (ifM P a b)"
  by (simp add: ifM_def empty_fail_cond)

lemma empty_fail_ifME[empty_fail_cond]:
  "\<lbrakk> empty_fail P; empty_fail a; empty_fail b \<rbrakk> \<Longrightarrow> empty_fail (ifME P a b)"
  by (simp add: ifME_def empty_fail_cond)

lemma empty_fail_whenM[empty_fail_cond]:
  "\<lbrakk> empty_fail P; empty_fail f \<rbrakk> \<Longrightarrow> empty_fail (whenM P f)"
  by (simp add: whenM_def empty_fail_term empty_fail_cond)

lemma empty_fail_andM[empty_fail_cond]:
  "\<lbrakk> empty_fail A; empty_fail B \<rbrakk> \<Longrightarrow> empty_fail (andM A B)"
  by (simp add: andM_def empty_fail_term empty_fail_cond)

lemma empty_fail_orM[empty_fail_cond]:
  "\<lbrakk> empty_fail A; empty_fail B \<rbrakk> \<Longrightarrow> empty_fail (orM A B)"
  by (simp add: orM_def empty_fail_term empty_fail_cond)

lemma empty_fail_notM[empty_fail_cond]:
  "empty_fail A \<Longrightarrow> empty_fail (notM A)"
  by (simp add: notM_def empty_fail_term empty_fail_cond)

(* not everything [simp] by default, because side conditions can slow down simp a lot *)
lemmas empty_fail[wp, intro!] = empty_fail_term empty_fail_cond
lemmas [simp] = empty_fail_term

subsection \<open>Equations and legacy names\<close>

lemma empty_fail_select_eq[simp]:
  "empty_fail (select V) = (V \<noteq> {})"
  by (clarsimp simp: select_def empty_fail_def)

lemma empty_fail_liftM_eq[simp]:
  "empty_fail (liftM f m) = empty_fail m"
  unfolding liftM_def
  by (fastforce dest: empty_fail_bindD1)

lemma empty_fail_liftE_eq[simp]:
  "empty_fail (liftE f) = empty_fail f"
  by (fastforce simp: liftE_def empty_fail_def bind_def)

lemma liftME_empty_fail_eq[simp]:
  "empty_fail (liftME f m) = empty_fail m"
  unfolding liftME_def
  by (fastforce dest: empty_fail_bindD1 simp: bindE_def)

(* legacy name binding *)
lemmas empty_fail_error_bits = empty_fail_returnOk empty_fail_throwError empty_fail_liftE_eq

end


(*  Title:      HOL/Auth/Guard/GuardK.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2002  University of Cambridge

Very similar to Guard except:
- Guard is replaced by GuardK, guard by guardK, Nonce by Key
- some scripts are slightly modified (+ keyset_in, kparts_parts)
- the hypothesis Key n ~:G (keyset G) is added
*)

section\<open>protocol-independent confidentiality theorem on keys\<close>

theory GuardK
imports Analz Extensions
begin

(******************************************************************************
messages where all the occurrences of Key n are
in a sub-message of the form Crypt (invKey K) X with K:Ks
******************************************************************************)

inductive_set
  guardK :: "nat => key set => msg set"
  for n :: nat and Ks :: "key set"
where
  No_Key [intro]: "Key n \<notin> parts {X} \<Longrightarrow> X \<in> guardK n Ks"
| Guard_Key [intro]: "invKey K \<in> Ks \<Longrightarrow> Crypt K X \<in> guardK n Ks"
| Crypt [intro]: "X \<in> guardK n Ks \<Longrightarrow> Crypt K X \<in> guardK n Ks"
| Pair [intro]: "\<lbrakk>X \<in> guardK n Ks; Y \<in> guardK n Ks\<rbrakk> \<Longrightarrow> \<lbrace>X,Y\<rbrace> \<in> guardK n Ks"

subsection\<open>basic facts about \<^term>\<open>guardK\<close>\<close>

lemma Nonce_is_guardK [iff]: "Nonce p \<in> guardK n Ks"
by auto

lemma Agent_is_guardK [iff]: "Agent A \<in> guardK n Ks"
by auto

lemma Number_is_guardK [iff]: "Number r \<in> guardK n Ks"
by auto

lemma Key_notin_guardK: "X \<in> guardK n Ks \<Longrightarrow> X \<noteq> Key n"
by (erule guardK.induct, auto)

lemma Key_notin_guardK_iff [iff]: "Key n \<notin> guardK n Ks"
by (auto dest: Key_notin_guardK)

lemma guardK_has_Crypt [rule_format]: "X \<in> guardK n Ks \<Longrightarrow> Key n \<in> parts {X}
\<longrightarrow> (\<exists>K Y. Crypt K Y \<in> kparts {X} \<and> Key n \<in> parts {Y})"
by (erule guardK.induct, auto)

lemma Key_notin_kparts_msg: "X \<in> guardK n Ks \<Longrightarrow> Key n \<notin> kparts {X}"
by (erule guardK.induct, auto dest: kparts_parts)

lemma Key_in_kparts_imp_no_guardK: "Key n \<in> kparts H
\<Longrightarrow> \<exists>X. X \<in> H \<and> X \<notin> guardK n Ks"
apply (drule in_kparts, clarify)
apply (rule_tac x=X in exI, clarify)
by (auto dest: Key_notin_kparts_msg)

lemma guardK_kparts [rule_format]: "X \<in> guardK n Ks \<Longrightarrow>
Y \<in> kparts {X} \<longrightarrow> Y \<in> guardK n Ks"
by (erule guardK.induct, auto dest: kparts_parts parts_sub)

lemma guardK_Crypt: "\<lbrakk>Crypt K Y \<in> guardK n Ks; K \<notin> invKey`Ks\<rbrakk> \<Longrightarrow> Y \<in> guardK n Ks"
  by (ind_cases "Crypt K Y \<in> guardK n Ks") (auto intro!: image_eqI)

lemma guardK_MPair [iff]: "(\<lbrace>X,Y\<rbrace> \<in> guardK n Ks)
= (X \<in> guardK n Ks \<and> Y \<in> guardK n Ks)"
by (auto, (ind_cases "\<lbrace>X,Y\<rbrace> \<in> guardK n Ks", auto)+)

lemma guardK_not_guardK [rule_format]: "X \<in>guardK n Ks \<Longrightarrow>
Crypt K Y \<in> kparts {X} \<longrightarrow> Key n \<in> kparts {Y} \<longrightarrow> Y \<notin> guardK n Ks"
by (erule guardK.induct, auto dest: guardK_kparts)

lemma guardK_extand: "\<lbrakk>X \<in> guardK n Ks; Ks \<subseteq> Ks';
\<lbrakk>K \<in> Ks'; K \<notin> Ks\<rbrakk> \<Longrightarrow> Key K \<notin> parts {X}\<rbrakk> \<Longrightarrow> X \<in> guardK n Ks'"
by (erule guardK.induct, auto)

subsection\<open>guarded sets\<close>

definition GuardK :: "nat \<Rightarrow> key set \<Rightarrow> msg set \<Rightarrow> bool" where
"GuardK n Ks H \<equiv> \<forall>X. X \<in> H \<longrightarrow> X \<in> guardK n Ks"

subsection\<open>basic facts about \<^term>\<open>GuardK\<close>\<close>

lemma GuardK_empty [iff]: "GuardK n Ks {}"
by (simp add: GuardK_def)

lemma Key_notin_kparts [simplified]: "GuardK n Ks H \<Longrightarrow> Key n \<notin> kparts H"
by (auto simp: GuardK_def dest: in_kparts Key_notin_kparts_msg)

lemma GuardK_must_decrypt: "\<lbrakk>GuardK n Ks H; Key n \<in> analz H\<rbrakk> \<Longrightarrow>
\<exists>K Y. Crypt K Y \<in> kparts H \<and> Key (invKey K) \<in> kparts H"
apply (drule_tac P="\<lambda>G. Key n \<in> G" in analz_pparts_kparts_substD, simp)
by (drule must_decrypt, auto dest: Key_notin_kparts)

lemma GuardK_kparts [intro]: "GuardK n Ks H \<Longrightarrow> GuardK n Ks (kparts H)"
by (auto simp: GuardK_def dest: in_kparts guardK_kparts)

lemma GuardK_mono: "\<lbrakk>GuardK n Ks H; G \<subseteq> H\<rbrakk> \<Longrightarrow> GuardK n Ks G"
by (auto simp: GuardK_def)

lemma GuardK_insert [iff]: "GuardK n Ks (insert X H)
= (GuardK n Ks H \<and> X \<in> guardK n Ks)"
by (auto simp: GuardK_def)

lemma GuardK_Un [iff]: "GuardK n Ks (G Un H) = (GuardK n Ks G & GuardK n Ks H)"
by (auto simp: GuardK_def)

lemma GuardK_synth [intro]: "GuardK n Ks G \<Longrightarrow> GuardK n Ks (synth G)"
by (auto simp: GuardK_def, erule synth.induct, auto)

lemma GuardK_analz [intro]: "\<lbrakk>GuardK n Ks G; \<forall>K. K \<in> Ks \<longrightarrow> Key K \<notin> analz G\<rbrakk>
\<Longrightarrow> GuardK n Ks (analz G)"
apply (auto simp: GuardK_def)
apply (erule analz.induct, auto)
by (ind_cases "Crypt K Xa \<in> guardK n Ks" for K Xa, auto)

lemma in_GuardK [dest]: "\<lbrakk>X \<in> G; GuardK n Ks G\<rbrakk> \<Longrightarrow> X \<in> guardK n Ks"
by (auto simp: GuardK_def)

lemma in_synth_GuardK: "\<lbrakk>X \<in> synth G; GuardK n Ks G\<rbrakk> \<Longrightarrow> X \<in> guardK n Ks"
by (drule GuardK_synth, auto)

lemma in_analz_GuardK: "\<lbrakk>X \<in> analz G; GuardK n Ks G;
\<forall>K. K \<in> Ks \<longrightarrow> Key K \<notin> analz G\<rbrakk> \<Longrightarrow> X \<in> guardK n Ks"
by (drule GuardK_analz, auto)

lemma GuardK_keyset [simp]: "\<lbrakk>keyset G; Key n \<notin> G\<rbrakk> \<Longrightarrow> GuardK n Ks G"
by (simp only: GuardK_def, clarify, drule keyset_in, auto)

lemma GuardK_Un_keyset: "\<lbrakk>GuardK n Ks G; keyset H; Key n \<notin> H\<rbrakk>
\<Longrightarrow> GuardK n Ks (G Un H)"
by auto

lemma in_GuardK_kparts: "\<lbrakk>X \<in> G; GuardK n Ks G; Y \<in> kparts {X}\<rbrakk> \<Longrightarrow> Y \<in> guardK n Ks"
by blast

lemma in_GuardK_kparts_neq: "\<lbrakk>X \<in> G; GuardK n Ks G; Key n' \<in> kparts {X}\<rbrakk>
\<Longrightarrow> n \<noteq> n'"
by (blast dest: in_GuardK_kparts)

lemma in_GuardK_kparts_Crypt: "\<lbrakk>X \<in> G; GuardK n Ks G; is_MPair X;
Crypt K Y \<in> kparts {X}; Key n \<in> kparts {Y}\<rbrakk> \<Longrightarrow> invKey K \<in> Ks"
apply (drule in_GuardK, simp)
apply (frule guardK_not_guardK, simp+)
apply (drule guardK_kparts, simp)
by (ind_cases "Crypt K Y \<in> guardK n Ks", auto)

lemma GuardK_extand: "\<lbrakk>GuardK n Ks G; Ks \<subseteq> Ks';
\<lbrakk>K \<in> Ks'; K \<notin> Ks\<rbrakk> \<Longrightarrow> Key K \<notin> parts G\<rbrakk> \<Longrightarrow> GuardK n Ks' G"
by (auto simp: GuardK_def dest: guardK_extand parts_sub)

subsection\<open>set obtained by decrypting a message\<close>

abbreviation (input)
  decrypt :: "msg set \<Rightarrow> key \<Rightarrow> msg \<Rightarrow> msg set" where
  "decrypt H K Y \<equiv> insert Y (H - {Crypt K Y})"

lemma analz_decrypt: "\<lbrakk>Crypt K Y \<in> H; Key (invKey K) \<in> H; Key n \<in> analz H\<rbrakk>
\<Longrightarrow> Key n \<in> analz (decrypt H K Y)"
apply (drule_tac P="\<lambda>H. Key n \<in> analz H" in ssubst [OF insert_Diff])
apply assumption
apply (simp only: analz_Crypt_if, simp)
done

lemma parts_decrypt: "\<lbrakk>Crypt K Y \<in> H; X \<in> parts (decrypt H K Y)\<rbrakk> \<Longrightarrow> X \<in> parts H"
by (erule parts.induct, auto intro: parts.Fst parts.Snd parts.Body)

subsection\<open>number of Crypt's in a message\<close>

fun crypt_nb :: "msg => nat" where
"crypt_nb (Crypt K X) = Suc (crypt_nb X)" |
"crypt_nb \<lbrace>X,Y\<rbrace> = crypt_nb X + crypt_nb Y" |
"crypt_nb X = 0" (* otherwise *)

subsection\<open>basic facts about \<^term>\<open>crypt_nb\<close>\<close>

lemma non_empty_crypt_msg: "Crypt K Y \<in> parts {X} \<Longrightarrow> crypt_nb X \<noteq> 0"
by (induct X, simp_all, safe, simp_all)

subsection\<open>number of Crypt's in a message list\<close>

primrec cnb :: "msg list => nat" where
"cnb [] = 0" |
"cnb (X#l) = crypt_nb X + cnb l"

subsection\<open>basic facts about \<^term>\<open>cnb\<close>\<close>

lemma cnb_app [simp]: "cnb (l @ l') = cnb l + cnb l'"
by (induct l, auto)

lemma mem_cnb_minus: "x \<in> set l \<Longrightarrow> cnb l = crypt_nb x + (cnb l - crypt_nb x)"
by (induct l, auto)

lemmas mem_cnb_minus_substI = mem_cnb_minus [THEN ssubst]

lemma cnb_minus [simp]: "x \<in> set l \<Longrightarrow> cnb (remove l x) = cnb l - crypt_nb x"
apply (induct l, auto)
by (erule_tac l=l and x=x in mem_cnb_minus_substI, simp)

lemma parts_cnb: "Z \<in> parts (set l) \<Longrightarrow>
cnb l = (cnb l - crypt_nb Z) + crypt_nb Z"
by (erule parts.induct, auto simp: in_set_conv_decomp)

lemma non_empty_crypt: "Crypt K Y \<in> parts (set l) \<Longrightarrow> cnb l \<noteq> 0"
by (induct l, auto dest: non_empty_crypt_msg parts_insert_substD)

subsection\<open>list of kparts\<close>

lemma kparts_msg_set: "\<exists>l. kparts {X} = set l \<and> cnb l = crypt_nb X"
apply (induct X, simp_all)
apply (rename_tac agent, rule_tac x="[Agent agent]" in exI, simp)
apply (rename_tac nat, rule_tac x="[Number nat]" in exI, simp)
apply (rename_tac nat, rule_tac x="[Nonce nat]" in exI, simp)
apply (rename_tac nat, rule_tac x="[Key nat]" in exI, simp)
apply (rule_tac x="[Hash X]" in exI, simp)
apply (clarify, rule_tac x="l@la" in exI, simp)
by (clarify, rename_tac nat X y, rule_tac x="[Crypt nat X]" in exI, simp)

lemma kparts_set: "\<exists>l'. kparts (set l) = set l' & cnb l' = cnb l"
apply (induct l)
apply (rule_tac x="[]" in exI, simp, clarsimp)
apply (rename_tac a b l')
apply (subgoal_tac "\<exists>l''.  kparts {a} = set l'' & cnb l'' = crypt_nb a", clarify)
apply (rule_tac x="l''@l'" in exI, simp)
apply (rule kparts_insert_substI, simp)
by (rule kparts_msg_set)

subsection\<open>list corresponding to "decrypt"\<close>

definition decrypt' :: "msg list => key => msg => msg list" where
"decrypt' l K Y == Y # remove l (Crypt K Y)"

declare decrypt'_def [simp]

subsection\<open>basic facts about \<^term>\<open>decrypt'\<close>\<close>

lemma decrypt_minus: "decrypt (set l) K Y <= set (decrypt' l K Y)"
by (induct l, auto)

text\<open>if the analysis of a finite guarded set gives n then it must also give
one of the keys of Ks\<close>

lemma GuardK_invKey_by_list [rule_format]: "\<forall>l. cnb l = p
\<longrightarrow> GuardK n Ks (set l) \<longrightarrow> Key n \<in> analz (set l)
\<longrightarrow> (\<exists>K. K \<in> Ks \<and> Key K \<in> analz (set l))"
apply (induct p)
(* case p=0 *)
apply (clarify, drule GuardK_must_decrypt, simp, clarify)
apply (drule kparts_parts, drule non_empty_crypt, simp)
(* case p>0 *)
apply (clarify, frule GuardK_must_decrypt, simp, clarify)
apply (drule_tac P="\<lambda>G. Key n \<in> G" in analz_pparts_kparts_substD, simp)
apply (frule analz_decrypt, simp_all)
apply (subgoal_tac "\<exists>l'. kparts (set l) = set l' \<and> cnb l' = cnb l", clarsimp)
apply (drule_tac G="insert Y (set l' - {Crypt K Y})"
and H="set (decrypt' l' K Y)" in analz_sub, rule decrypt_minus)
apply (rule_tac analz_pparts_kparts_substI, simp)
apply (case_tac "K \<in> invKey`Ks")
(* K:invKey`Ks *)
apply (clarsimp, blast)
(* K ~:invKey`Ks *)
apply (subgoal_tac "GuardK n Ks (set (decrypt' l' K Y))")
apply (drule_tac x="decrypt' l' K Y" in spec, simp)
apply (subgoal_tac "Crypt K Y \<in> parts (set l)")
apply (drule parts_cnb, rotate_tac -1, simp)
apply (clarify, drule_tac X="Key Ka" and H="insert Y (set l')" in analz_sub)
apply (rule insert_mono, rule set_remove)
apply (simp add: analz_insertD, blast)
(* Crypt K Y:parts (set l) *)
apply (blast dest: kparts_parts)
(* GuardK n Ks (set (decrypt' l' K Y)) *)
apply (rule_tac H="insert Y (set l')" in GuardK_mono)
apply (subgoal_tac "GuardK n Ks (set l')", simp)
apply (rule_tac K=K in guardK_Crypt, simp add: GuardK_def, simp)
apply (drule_tac t="set l'" in sym, simp)
apply (rule GuardK_kparts, simp, simp)
apply (rule_tac B="set l'" in subset_trans, rule set_remove, blast)
by (rule kparts_set)

lemma GuardK_invKey_finite: "\<lbrakk>Key n \<in> analz G; GuardK n Ks G; finite G\<rbrakk>
\<Longrightarrow> \<exists>K. K \<in> Ks \<and> Key K \<in> analz G"
apply (drule finite_list, clarify)
by (rule GuardK_invKey_by_list, auto)

lemma GuardK_invKey: "\<lbrakk>Key n \<in> analz G; GuardK n Ks G\<rbrakk>
\<Longrightarrow> \<exists>K. K \<in> Ks \<and> Key K \<in> analz G"
by (auto dest: analz_needs_only_finite GuardK_invKey_finite)

text\<open>if the analyse of a finite guarded set and a (possibly infinite) set of
keys gives n then it must also gives Ks\<close>

lemma GuardK_invKey_keyset: "\<lbrakk>Key n \<in> analz (G \<union> H); GuardK n Ks G; finite G;
keyset H; Key n \<notin> H\<rbrakk> \<Longrightarrow> \<exists>K. K \<in> Ks \<and> Key K \<in> analz (G \<union> H)"
apply (frule_tac P="\<lambda>G. Key n \<in> G" and G=G in analz_keyset_substD, simp_all)
apply (drule_tac G="G Un (H Int keysfor G)" in GuardK_invKey_finite)
apply (auto simp: GuardK_def intro: analz_sub)
by (drule keyset_in, auto)

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Strong_Early_Bisim_Pres
  imports Strong_Early_Bisim Strong_Early_Sim_Pres
begin

(************* Preservation rules *************)

lemma tauPres:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim> Q"

  shows "\<tau>.(P) \<sim> \<tau>.(Q)"
proof -
  let ?X = "{(\<tau>.(P), \<tau>.(Q)) | P Q. P \<sim> Q}"
  from \<open>P \<sim> Q\<close> have "(\<tau>.(P), \<tau>.(Q)) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto intro: tauPres dest: bisimE)
qed

lemma inputPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   x :: name

  assumes PSimQ: "\<forall>y. P[x::=y] \<sim> Q[x::=y]"

  shows "a<x>.P \<sim> a<x>.Q"
proof -
  let ?X = "{(a<x>.P, a<x>.Q) | a x P Q. \<forall>y. P[x::=y] \<sim> Q[x::=y]}"
  {
    fix axP axQ p
    assume "(axP, axQ) \<in> ?X"
    then obtain a x P Q where A: "\<forall>y. P[x::=y] \<sim> Q[x::=y]" and B: "axP = a<x>.P" and C: "axQ = a<x>.Q"
      by auto
    have "\<And>y. ((p::name prm) \<bullet> P)[(p \<bullet> x)::=y] \<sim> (p \<bullet> Q)[(p \<bullet> x)::=y]"
    proof -
      fix y
      from A have "P[x::=(rev p \<bullet> y)] \<sim> Q[x::=(rev p \<bullet> y)]"
        by blast
      hence "(p \<bullet> (P[x::=(rev p \<bullet> y)])) \<sim> p \<bullet> (Q[x::=(rev p \<bullet> y)])"
        by(rule bisimClosed)
      thus "(p \<bullet> P)[(p \<bullet> x)::=y] \<sim> (p \<bullet> Q)[(p \<bullet> x)::=y]"
        by(simp add: eqvts pt_pi_rev[OF pt_name_inst, OF at_name_inst])
    qed
    hence "((p::name prm) \<bullet> axP, p \<bullet> axQ) \<in> ?X" using B C
      by auto
  }
  hence "eqvt ?X" by(simp add: eqvt_def)
  from PSimQ have "(a<x>.P, a<x>.Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: bisimCoinduct)
    case(cSim P Q)
    thus ?case using \<open>eqvt ?X\<close>
      by(force intro: inputPres)
  next
    case(cSym P Q)
    thus ?case
      by(blast dest: bisimE)
  qed
qed

lemma outputPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   b :: name

  assumes "P \<sim> Q"

  shows "a{b}.P \<sim> a{b}.Q"
proof -
  let ?X = "{(a{b}.P, a{b}.Q) | a b P Q. P \<sim> Q}"
  from \<open>P \<sim> Q\<close> have "(a{b}.P, a{b}.Q) \<in> ?X" by auto
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (blast intro: outputPres dest: bisimE)+
qed

  assumes "P \<sim> Q"

  shows "[a\<frown>b]P \<sim> [a\<frown>b]Q"
proof -
  let ?X = "{x. \<exists>P Q a b. P \<sim> Q \<and> x = ([a\<frown>b]P, [a\<frown>b]Q)}"
  from assms have "([a\<frown>b]P, [a\<frown>b]Q) \<in> ?X" by blast
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (blast intro: matchPres dest: bisimE)+
qed

lemma mismatchPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   b :: name

  assumes "P \<sim> Q"

  shows "[a\<noteq>b]P \<sim> [a\<noteq>b]Q"
proof -
  let ?X = "{x. \<exists>P Q a b. P \<sim> Q \<and> x = ([a\<noteq>b]P, [a\<noteq>b]Q)}"
  from assms have "([a\<noteq>b]P, [a\<noteq>b]Q) \<in> ?X" by blast
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (blast intro: mismatchPres dest: bisimE)+
qed

lemma sumPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "P \<sim> Q"

  shows "P \<oplus> R \<sim> Q \<oplus> R"
proof -
  let ?X = "{(P \<oplus> R, Q \<oplus> R) | P Q R. P \<sim> Q}"
  from assms have "(P \<oplus> R, Q \<oplus> R) \<in> ?X" by blast
  thus ?thesis
    by(coinduct rule: bisimCoinduct) (auto dest: bisimE intro: reflexive sumPres)
qed

  shows "<\<nu>x>P \<sim> <\<nu>x>Q"
proof -
  let ?X = "{x. \<exists>P Q. P \<sim> Q \<and> (\<exists>a. x = (<\<nu>a>P, <\<nu>a>Q))}"
  from assms have "(<\<nu>x>P, <\<nu>x>Q) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: bisimCoinduct)
    case(cSim xP xQ)
    moreover {
      fix P Q a
      assume "P \<sim> Q"
      hence "P \<leadsto>[bisim] Q" by(rule bisimE)
      moreover have "\<And>P Q a. P \<sim> Q \<Longrightarrow> (<\<nu>a>P, <\<nu>a>Q) \<in> ?X \<union> bisim" by blast
      moreover have "bisim \<subseteq> ?X \<union> bisim" by blast
      moreover have "eqvt bisim" by(rule eqvt)
      moreover have "eqvt (?X \<union> bisim)" using eqvts
        by(auto simp add: eqvt_def) blast
      ultimately have "<\<nu>a>P \<leadsto>[(?X \<union> bisim)] <\<nu>a>Q"
        by(rule Strong_Early_Sim_Pres.resPres)
    }
    ultimately show ?case by auto
  next
    case(cSym xP xQ)
    thus ?case by(auto dest: bisimE)
  qed
qed

lemma parPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi
  and   T :: pi

  assumes "P \<sim> Q"

  shows "P \<parallel> R \<sim> Q \<parallel> R"
proof -
  let ?X = "{(resChain lst (P \<parallel> R), resChain lst (Q \<parallel> R)) | lst P Q R. P \<sim> Q}"
  have BC: "\<And>P Q. P \<parallel> Q = resChain [] (P \<parallel> Q)" by auto
  from assms have "(P \<parallel> R, Q \<parallel> R) \<in> ?X" by(blast intro: BC)
  thus ?thesis
  proof(coinduct rule: bisimWeakCoinduct)
    case(cSim PR QR)
    moreover {
      fix lst P Q R
      assume "P \<sim> Q"
      have "eqvt ?X" using eqvts by(auto simp add: eqvt_def) blast
      moreover have Res: "\<And>P Q x. (P, Q) \<in> ?X \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?X"
        by(auto, rule_tac x="x#lst" in exI) auto
      moreover {
        from \<open>P \<sim> Q\<close> have "P \<leadsto>[bisim] Q" by(rule bisimE)
        moreover note \<open>P \<sim> Q\<close>
        moreover have "\<And>P Q R. P \<sim> Q \<Longrightarrow> (P \<parallel> R, Q \<parallel> R) \<in> ?X"
          by(blast intro: BC)
        ultimately have "P \<parallel> R \<leadsto>[?X] Q \<parallel> R" using Res
          by(rule parPres)
      }

      ultimately have "resChain lst (P \<parallel> R) \<leadsto>[?X] resChain lst (Q \<parallel> R)"
        by(rule resChainI)
    }
    ultimately show ?case by auto
  next
    case(cSym P Q)
    thus ?case by(auto dest: bisimE)
  qed
qed

lemma bangRelBisimE:
  fixes P   :: pi
  and   Q   :: pi
  and   Rel :: "(pi \<times> pi) set"

  assumes A:   "(P, Q) \<in> bangRel Rel"
  and     Sym: "\<And>P Q. (P, Q) \<in> Rel \<Longrightarrow> (Q, P) \<in> Rel"

  shows "(Q, P) \<in> bangRel Rel"
proof -
  from A show ?thesis
  proof(induct)
    fix P Q
    assume "(P, Q) \<in> Rel"
    hence "(Q, P) \<in> Rel" by(rule Sym)
    thus "(!Q, !P) \<in> bangRel Rel" by(rule BRBang)
  next
    fix P Q R T
    assume RRelT: "(R, T) \<in> Rel"
    assume IH: "(Q, P) \<in> bangRel Rel"
    from RRelT have "(T, R) \<in> Rel" by(rule Sym)
    thus "(T \<parallel> Q, R \<parallel> P) \<in> bangRel Rel" using IH by(rule BRPar)
  next
    fix P Q a
    assume "(Q, P) \<in> bangRel Rel"
    thus "(<\<nu>a>Q, <\<nu>a>P) \<in> bangRel Rel" by(rule BRRes)
  qed
qed

  assumes PBiSimQ: "P \<sim> Q"

  shows "!P \<sim> !Q"
proof -
  let ?X = "bangRel bisim"
    from PBiSimQ have "(!P, !Q) \<in> ?X" by(rule BRBang)
    thus ?thesis
    proof(coinduct rule: bisimWeakCoinduct)
      case(cSim bP bQ)
      {
        fix P Q
        assume "(P, Q) \<in> ?X"
        hence "P \<leadsto>[?X] Q"
        proof(induct)
          fix P Q
          assume "P \<sim> Q"
          thus "!P \<leadsto>[?X] !Q" using bisimE(1) eqvt
            by(rule Strong_Early_Sim_Pres.bangPres)
        next
          fix P Q R T
          assume RBiSimT: "R \<sim> T"
          assume PBangRelQ: "(P, Q) \<in> ?X"
          assume PSimQ: "P \<leadsto>[?X] Q"
          from RBiSimT  have "R \<leadsto>[bisim] T" by(blast dest: bisimE)
          thus "R \<parallel> P \<leadsto>[?X] T \<parallel> Q" using PSimQ RBiSimT PBangRelQ BRPar BRRes eqvt eqvtBangRel
            by(blast intro: Strong_Early_Sim_Pres.parCompose)
        next
          fix P Q a
          assume "P \<leadsto>[?X] Q"
          moreover from eqvtBangRel eqvt have "eqvt ?X" by blast
          ultimately show "<\<nu>a>P \<leadsto>[?X] <\<nu>a>Q" using BRRes by(blast intro: Strong_Early_Sim_Pres.resPres)
        qed
      }
      with \<open>(bP, bQ) \<in> ?X\<close> show ?case by blast
    next
      case(cSym bP bQ)
      thus ?case by(metis bangRelSymetric bisimE)
  qed
qed

end


theory GabrielaLimonta
imports "~~/src/HOL/IMP/Big_Step" "~~/src/HOL/IMP/Vars"
begin

(** Score: 1/5
  5.1 Ran into trouble fast, due to wrong data-flow equations
  5.2 Missing
*)

fun gen :: "com \<Rightarrow> (vname * aexp) set"
and "kill" :: "com \<Rightarrow> (vname * aexp) set" where
"gen SKIP = {}" |
"gen (x ::= a) = (if x \<notin> vars a then {(x, a)} else {})" |
"gen (c1 ;; c2) = (gen c1 - kill c2) \<union> gen c2" |
"gen (IF b THEN c1 ELSE c2) = (gen c1 - kill c2) \<inter> gen c2" | (* ? Why the "- kill c2", in a completely symmetric thing like an if ? *)
"gen (WHILE b DO c) = gen c" | (* It may happen that the while-loop is not executed at all! *)
"kill SKIP = {}" |
"kill (x ::= a) = {(y,e). y = x \<and> e \<noteq> a} \<union> {(y,e). x \<in> vars e}" |
"kill (c1 ;; c2) = kill c1 \<union> kill c2" |
"kill (IF b THEN c1 ELSE c2) = kill c1 \<union> kill c2" |
"kill (WHILE b DO c) = kill c"

definition AD :: "(vname * aexp) set \<Rightarrow> com \<Rightarrow> (vname * aexp) set" where
"AD A c = gen c \<union> (A - kill c)"

lemma "{(''x'', (N 5)), (''y'', (N 8))} = AD {(''x'', (N 4)), (''y'', (N 8))} (''x'' ::= (N 5))"
by (auto simp: AD_def)

theorem "\<lbrakk> (c,s) \<Rightarrow> s'; \<forall> (x, a) \<in> A. s x = aval a s \<rbrakk>
  \<Longrightarrow> \<forall> (x, a) \<in> AD A c. s' x = aval a s'"
proof (induction arbitrary: A rule: big_step_induct)
print_cases
case (Skip s)
  thus ?case using AD_def by auto
next
case (Assign x' a' s)
  thus ?case using AD_def by (auto split: if_splits)
next
case (Seq c1 s1 s2 c2 s3)
  thus ?case using AD_def sorry
next
case (IfTrue b s c1 t)
  thus ?case using AD_def by auto
next
case (IfFalse b s c2 t)
  thus ?case using AD_def by auto
next
case (WhileFalse b s)
  thus ?case using AD_def and big_step.intros sorry
next
case (WhileTrue b s1 c s2 s3)
  thus ?case using AD_def and big_step.intros sorry
qed

end


(*  Title:      JinjaThreads/Compiler/Exception_Tables.thy
    Author:     Andreas Lochbihler
*)

section \<open>Various Operations for Exception Tables\<close>

theory Exception_Tables imports
  Compiler2
  "../Common/ExternalCallWF"
  "../JVM/JVMExceptions"
begin

definition pcs :: "ex_table \<Rightarrow> nat set"
where "pcs xt  \<equiv>  \<Union>(f,t,C,h,d) \<in> set xt. {f ..< t}"

lemma pcs_subset:
  fixes e :: "'addr expr1" and es :: "'addr expr1 list"
  shows "pcs(compxE2 e pc d) \<subseteq> {pc..<pc+size(compE2 e)}"
  and "pcs(compxEs2 es pc d) \<subseteq> {pc..<pc+size(compEs2 es)}"
apply(induct e pc d and es pc d rule: compxE2_compxEs2_induct)
apply (simp_all add:pcs_def)
apply (fastforce)+
done

lemma pcs_Nil [simp]: "pcs [] = {}"
by(simp add:pcs_def)

lemma pcs_Cons [simp]: "pcs (x#xt) = {fst x ..< fst(snd x)} \<union> pcs xt"
by(auto simp add: pcs_def)

lemma pcs_append [simp]: "pcs(xt\<^sub>1 @ xt\<^sub>2) = pcs xt\<^sub>1 \<union> pcs xt\<^sub>2"
by(simp add:pcs_def)

lemma [simp]: "pc < pc0 \<or> pc0+size(compEs2 es) \<le> pc \<Longrightarrow> pc \<notin> pcs(compxEs2 es pc0 d)"
using pcs_subset by fastforce

lemma [simp]: "pc1 + size(compE2 e1) \<le> pc2 \<Longrightarrow> pcs(compxE2 e1 pc1 d1) \<inter> pcs(compxE2 e2 pc2 d2) = {}"
using pcs_subset by fastforce

lemma [simp]: "pc\<^sub>1 + size(compE2 e) \<le> pc\<^sub>2 \<Longrightarrow> pcs(compxE2 e pc\<^sub>1 d\<^sub>1) \<inter> pcs(compxEs2 es pc\<^sub>2 d\<^sub>2) = {}"
using pcs_subset by fastforce

lemma match_ex_table_append_not_pcs [simp]:
 "pc \<notin> pcs xt0 \<Longrightarrow> match_ex_table P C pc (xt0 @ xt1) = match_ex_table P C pc xt1"
by (induct xt0) (auto simp: matches_ex_entry_def)

lemma outside_pcs_not_matches_entry [simp]:
  "\<lbrakk> x \<in> set xt; pc \<notin> pcs xt \<rbrakk> \<Longrightarrow> \<not> matches_ex_entry P D pc x"
by(auto simp:matches_ex_entry_def pcs_def)

lemma outside_pcs_compxE2_not_matches_entry [simp]:
  assumes xe: "xe \<in> set(compxE2 e pc d)"
  and outside: "pc' < pc \<or> pc+size(compE2 e) \<le> pc'"
  shows "\<not> matches_ex_entry P C pc' xe"
proof
  assume "matches_ex_entry P C pc' xe"
  with xe have "pc' \<in> pcs(compxE2 e pc d)"
    by(force simp add:matches_ex_entry_def pcs_def)
  with outside show False by simp
qed

lemma outside_pcs_compxEs2_not_matches_entry [simp]:
  assumes xe: "xe \<in> set(compxEs2 es pc d)"
  and outside: "pc' < pc \<or> pc+size(compEs2 es) \<le> pc'"
  shows "\<not> matches_ex_entry P C pc' xe"
proof
  assume "matches_ex_entry P C pc' xe"
  with xe have "pc' \<in> pcs(compxEs2 es pc d)"
    by(force simp add:matches_ex_entry_def pcs_def)
  with outside show False by simp
qed

lemma match_ex_table_app[simp]:
  "\<forall>xte \<in> set xt\<^sub>1. \<not> matches_ex_entry P D pc xte \<Longrightarrow>
  match_ex_table P D pc (xt\<^sub>1 @ xt) = match_ex_table P D pc xt"
by(induct xt\<^sub>1) simp_all

lemma match_ex_table_eq_NoneI [simp]:
  "\<forall>x \<in> set xtab. \<not> matches_ex_entry P C pc x \<Longrightarrow>
  match_ex_table P C pc xtab = None"
using match_ex_table_app[where ?xt = "[]"] by fastforce

lemma match_ex_entry:
  fixes start shows
  "matches_ex_entry P C pc (start, end, catch_type, handler) =
  (start \<le> pc \<and> pc < end \<and> (case catch_type of None \<Rightarrow> True | \<lfloor>C'\<rfloor> \<Rightarrow> P \<turnstile> C \<preceq>\<^sup>* C'))"
by(simp add:matches_ex_entry_def)

lemma pcs_compxE2D [dest]:
  "pc \<in> pcs (compxE2 e pc' d) \<Longrightarrow> pc' \<le> pc \<and> pc < pc' + length (compE2 e)"
using pcs_subset by(fastforce)

lemma pcs_compxEs2D [dest]:
  "pc \<in> pcs (compxEs2 es pc' d) \<Longrightarrow> pc' \<le> pc \<and> pc < pc' + length (compEs2 es)"
using pcs_subset by(fastforce)

definition shift :: "nat \<Rightarrow> ex_table \<Rightarrow> ex_table"
where
  "shift n xt \<equiv> map (\<lambda>(from,to,C,handler,depth). (n+from,n+to,C,n+handler,depth)) xt"

lemma shift_0 [simp]: "shift 0 xt = xt"
by(induct xt)(auto simp:shift_def)

lemma shift_Nil [simp]: "shift n [] = []"
by(simp add:shift_def)

lemma shift_Cons_tuple [simp]:
  "shift n ((from, to, C, handler, depth) # xt) = (from + n, to + n, C, handler + n, depth) # shift n xt"
by(simp add: shift_def)

lemma shift_append [simp]: "shift n (xt\<^sub>1 @ xt\<^sub>2) = shift n xt\<^sub>1 @ shift n xt\<^sub>2"
by(simp add:shift_def)

lemma shift_shift [simp]: "shift m (shift n xt) = shift (m+n) xt"
by(simp add: shift_def split_def)

lemma fixes e :: "'addr expr1" and es :: "'addr expr1 list"
  shows shift_compxE2: "shift pc (compxE2 e pc' d) = compxE2 e (pc' + pc) d"
  and  shift_compxEs2: "shift pc (compxEs2 es pc' d) = compxEs2 es (pc' + pc) d"
by(induct e and es arbitrary: pc pc' d and pc pc' d rule: compE2.induct compEs2.induct)
  (auto simp:shift_def ac_simps)

lemma compxE2_size_convs [simp]: "n \<noteq> 0 \<Longrightarrow> compxE2 e n d = shift n (compxE2 e 0 d)"
 and compxEs2_size_convs: "n \<noteq> 0 \<Longrightarrow> compxEs2 es n d = shift n (compxEs2 es 0 d)"
by(simp_all add:shift_compxE2 shift_compxEs2)

lemma pcs_shift_conv [simp]: "pcs (shift n xt) = (+) n ` pcs xt"
apply(auto simp add: shift_def pcs_def)
apply(rule_tac x="x-n" in image_eqI)
apply(auto)
apply(rule bexI)
 prefer 2
 apply(assumption)
apply(auto)
done

lemma image_plus_const_conv [simp]:
  fixes m :: nat
  shows "m \<in> (+) n ` A \<longleftrightarrow> m \<ge> n \<and> m - n \<in> A"
by(force)

lemma match_ex_table_shift_eq_None_conv [simp]:
  "match_ex_table P C pc (shift n xt) = None \<longleftrightarrow> pc < n \<or> match_ex_table P C (pc - n) xt = None"
by(induct xt)(auto simp add: match_ex_entry split: if_split_asm)

lemma match_ex_table_shift_pc_None:
  "pc \<ge> n \<Longrightarrow> match_ex_table P C pc (shift n xt) = None \<longleftrightarrow> match_ex_table P C (pc - n) xt = None"
by(simp add: match_ex_table_shift_eq_None_conv)

lemma match_ex_table_shift_eq_Some_conv [simp]:
  "match_ex_table P C pc (shift n xt) = \<lfloor>(pc', d)\<rfloor> \<longleftrightarrow>
   pc \<ge> n \<and> pc' \<ge> n \<and> match_ex_table P C (pc - n) xt = \<lfloor>(pc' - n, d)\<rfloor>"
by(induct xt)(auto simp add: match_ex_entry split: if_split_asm)

lemma match_ex_table_shift:
 "match_ex_table P C pc xt = \<lfloor>(pc', d)\<rfloor> \<Longrightarrow> match_ex_table P C (n + pc) (shift n xt) = \<lfloor>(n + pc', d)\<rfloor>"
by(simp add: match_ex_table_shift_eq_Some_conv)

lemma match_ex_table_shift_pcD:
  "match_ex_table P C pc (shift n xt) = \<lfloor>(pc', d)\<rfloor> \<Longrightarrow> pc \<ge> n \<and> pc' \<ge> n \<and> match_ex_table P C (pc - n) xt = \<lfloor>(pc' - n, d)\<rfloor>"
by(simp add: match_ex_table_shift_eq_Some_conv)

lemma match_ex_table_pcsD: "match_ex_table P C pc xt = \<lfloor>(pc', D)\<rfloor> \<Longrightarrow> pc \<in> pcs xt"
by(induct xt)(auto split: if_split_asm simp add: match_ex_entry)

definition stack_xlift :: "nat \<Rightarrow> ex_table \<Rightarrow> ex_table"
where "stack_xlift n xt \<equiv> map (\<lambda>(from,to,C,handler,depth). (from, to, C, handler, n + depth)) xt"

lemma stack_xlift_0 [simp]: "stack_xlift 0 xt = xt"
by(induct xt, auto simp add: stack_xlift_def)

lemma stack_xlift_Nil [simp]: "stack_xlift n [] = []"
by(simp add: stack_xlift_def)

lemma stack_xlift_Cons_tuple [simp]:
  "stack_xlift n ((from, to, C, handler, depth) # xt) = (from, to, C, handler, depth + n) # stack_xlift n xt"
by(simp add: stack_xlift_def)

lemma stack_xlift_append [simp]: "stack_xlift n (xt @ xt') = stack_xlift n xt @ stack_xlift n xt'"
by(simp add: stack_xlift_def)

lemma stack_xlift_stack_xlift [simp]: "stack_xlift n (stack_xlift m xt) = stack_xlift (n + m) xt"
by(simp add: stack_xlift_def split_def)

lemma fixes e :: "'addr expr1" and es :: "'addr expr1 list"
  shows stack_xlift_compxE2: "stack_xlift n (compxE2 e pc d) = compxE2 e pc (n + d)"
  and stack_xlift_compxEs2: "stack_xlift n (compxEs2 es pc d) = compxEs2 es pc (n + d)"
by(induct e and es arbitrary: d pc and d pc rule: compE2.induct compEs2.induct)
  (auto simp add: shift_compxE2 simp del: compxE2_size_convs)

lemma compxE2_stack_xlift_convs [simp]: "d > 0 \<Longrightarrow> compxE2 e pc d = stack_xlift d (compxE2 e pc 0)"
  and compxEs2_stack_xlift_convs [simp]: "d > 0 \<Longrightarrow> compxEs2 es pc d = stack_xlift d (compxEs2 es pc 0)"
by(simp_all add: stack_xlift_compxE2 stack_xlift_compxEs2)

lemma stack_xlift_shift [simp]: "stack_xlift d (shift n xt) = shift n (stack_xlift d xt)"
by(induct xt)(auto)

lemma pcs_stack_xlift_conv [simp]: "pcs (stack_xlift n xt) = pcs xt"
by(auto simp add: pcs_def stack_xlift_def)

lemma match_ex_table_stack_xlift_eq_None_conv [simp]:
  "match_ex_table P C pc (stack_xlift d xt) = None \<longleftrightarrow> match_ex_table P C pc xt = None"
by(induct xt)(auto simp add: match_ex_entry)

lemma match_ex_table_stack_xlift_eq_Some_conv [simp]:
  "match_ex_table P C pc (stack_xlift n xt) = \<lfloor>(pc', d)\<rfloor> \<longleftrightarrow> d \<ge> n \<and> match_ex_table P C pc xt = \<lfloor>(pc', d - n)\<rfloor>"
by(induct xt)(auto simp add: match_ex_entry)

lemma match_ex_table_stack_xliftD:
  "match_ex_table P C pc (stack_xlift n xt) = \<lfloor>(pc', d)\<rfloor> \<Longrightarrow> d \<ge> n \<and> match_ex_table P C pc xt = \<lfloor>(pc', d - n)\<rfloor>"
by(simp)

lemma match_ex_table_stack_xlift:
  "match_ex_table P C pc xt = \<lfloor>(pc', d)\<rfloor> \<Longrightarrow> match_ex_table P C pc (stack_xlift n xt) = \<lfloor>(pc', n + d)\<rfloor>"
by simp

lemma pcs_stack_xlift: "pcs (stack_xlift n xt) = pcs xt"
by(auto simp add: stack_xlift_def pcs_def)

lemma match_ex_table_None_append [simp]:
  "match_ex_table P C pc xt = None
  \<Longrightarrow> match_ex_table P C pc (xt @ xt') = match_ex_table P C pc xt'"
by(induct xt, auto)

lemma match_ex_table_Some_append [simp]:
  "match_ex_table P C pc xt = \<lfloor>(pc', d)\<rfloor> \<Longrightarrow> match_ex_table P C pc (xt @ xt') = \<lfloor>(pc', d)\<rfloor>"
by(induct xt)(auto)

lemma match_ex_table_append:
  "match_ex_table P C pc (xt @ xt') = (case match_ex_table P C pc xt of None \<Rightarrow> match_ex_table P C pc xt'
                                                                  | Some pcd \<Rightarrow> Some pcd)"
by(auto)

lemma match_ex_table_pc_length_compE2:
  "match_ex_table P a pc (compxE2 e pc' d) = \<lfloor>pcd\<rfloor> \<Longrightarrow> pc' \<le> pc \<and> pc < length (compE2 e) + pc'"

  and match_ex_table_pc_length_compEs2:
  "match_ex_table P a pc (compxEs2 es pc' d) = \<lfloor>pcd\<rfloor> \<Longrightarrow> pc' \<le> pc \<and> pc < length (compEs2 es) + pc'"
using pcs_subset by(cases pcd, fastforce dest!: match_ex_table_pcsD)+

lemma match_ex_table_compxE2_shift_conv:
  "f > 0 \<Longrightarrow> match_ex_table P C pc (compxE2 e f d) = \<lfloor>(pc', d')\<rfloor> \<longleftrightarrow> pc \<ge> f \<and> pc' \<ge> f \<and> match_ex_table P C (pc - f) (compxE2 e 0 d) = \<lfloor>(pc' - f, d')\<rfloor>"
by simp

lemma match_ex_table_compxEs2_shift_conv:
  "f > 0 \<Longrightarrow> match_ex_table P C pc (compxEs2 es f d) = \<lfloor>(pc', d')\<rfloor> \<longleftrightarrow> pc \<ge> f \<and> pc' \<ge> f \<and> match_ex_table P C (pc - f) (compxEs2 es 0 d) = \<lfloor>(pc' - f, d')\<rfloor>"
by(simp add: compxEs2_size_convs)

lemma match_ex_table_compxE2_stack_conv:
  "d > 0 \<Longrightarrow> match_ex_table P C pc (compxE2 e 0 d) = \<lfloor>(pc', d')\<rfloor> \<longleftrightarrow> d' \<ge> d \<and> match_ex_table P C pc (compxE2 e 0 0) = \<lfloor>(pc', d' - d)\<rfloor>"
by simp

lemma match_ex_table_compxEs2_stack_conv:
  "d > 0 \<Longrightarrow> match_ex_table P C pc (compxEs2 es 0 d) = \<lfloor>(pc', d')\<rfloor> \<longleftrightarrow> d' \<ge> d \<and> match_ex_table P C pc (compxEs2 es 0 0) = \<lfloor>(pc', d' - d)\<rfloor>"
by(simp add: compxEs2_stack_xlift_convs)

lemma fixes e :: "'addr expr1" and es :: "'addr expr1 list"
  shows match_ex_table_compxE2_not_same: "match_ex_table P C pc (compxE2 e n d) = \<lfloor>(pc', d')\<rfloor> \<Longrightarrow> pc \<noteq> pc'"
  and match_ex_table_compxEs2_not_same:"match_ex_table P C pc (compxEs2 es n d) = \<lfloor>(pc', d')\<rfloor> \<Longrightarrow> pc \<noteq> pc'"
apply(induct e n d and es n d rule: compxE2_compxEs2_induct)
apply(auto simp add: match_ex_table_append match_ex_entry simp del: compxE2_size_convs compxEs2_size_convs compxE2_stack_xlift_convs compxEs2_stack_xlift_convs split: if_split_asm)
done

end


(*  Title:      HOL/Auth/OtwayRees_AN.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge
*)

section\<open>The Otway-Rees Protocol as Modified by Abadi and Needham\<close>

theory OtwayRees_AN imports Public begin

text\<open>
This simplified version has minimal encryption and explicit messages.

Note that the formalization does not even assume that nonces are fresh.
This is because the protocol does not rely on uniqueness of nonces for
security, only for freshness, and the proof script does not prove freshness
properties.

From page 11 of
  Abadi and Needham (1996).
  Prudent Engineering Practice for Cryptographic Protocols.
  IEEE Trans. SE 22 (1)
\<close>

inductive_set otway :: "event list set"
  where
   Nil: \<comment> \<open>The empty trace\<close>
        "[] \<in> otway"

 | Fake: \<comment> \<open>The Spy may say anything he can say.  The sender field is correct,
            but agents don't use that information.\<close>
         "\<lbrakk>evsf \<in> otway;  X \<in> synth (analz (knows Spy evsf))\<rbrakk>
          \<Longrightarrow> Says Spy B X  # evsf \<in> otway"

 | Reception: \<comment> \<open>A message that has been sent can be received by the
                  intended recipient.\<close>
              "\<lbrakk>evsr \<in> otway;  Says A B X \<in>set evsr\<rbrakk>
               \<Longrightarrow> Gets B X # evsr \<in> otway"

 | OR1:  \<comment> \<open>Alice initiates a protocol run\<close>
         "evs1 \<in> otway
          \<Longrightarrow> Says A B \<lbrace>Agent A, Agent B, Nonce NA\<rbrace> # evs1 \<in> otway"

 | OR2:  \<comment> \<open>Bob's response to Alice's message.\<close>
         "\<lbrakk>evs2 \<in> otway;
             Gets B \<lbrace>Agent A, Agent B, Nonce NA\<rbrace> \<in>set evs2\<rbrakk>
          \<Longrightarrow> Says B Server \<lbrace>Agent A, Agent B, Nonce NA, Nonce NB\<rbrace>
                 # evs2 \<in> otway"

 | OR3:  \<comment> \<open>The Server receives Bob's message.  Then he sends a new
           session key to Bob with a packet for forwarding to Alice.\<close>
         "\<lbrakk>evs3 \<in> otway;  Key KAB \<notin> used evs3;
             Gets Server \<lbrace>Agent A, Agent B, Nonce NA, Nonce NB\<rbrace>
               \<in>set evs3\<rbrakk>
          \<Longrightarrow> Says Server B
               \<lbrace>Crypt (shrK A) \<lbrace>Nonce NA, Agent A, Agent B, Key KAB\<rbrace>,
                 Crypt (shrK B) \<lbrace>Nonce NB, Agent A, Agent B, Key KAB\<rbrace>\<rbrace>
              # evs3 \<in> otway"

 | OR4:  \<comment> \<open>Bob receives the Server's (?) message and compares the Nonces with
             those in the message he previously sent the Server.
             Need \<^term>\<open>B \<noteq> Server\<close> because we allow messages to self.\<close>
         "\<lbrakk>evs4 \<in> otway;  B \<noteq> Server;
             Says B Server \<lbrace>Agent A, Agent B, Nonce NA, Nonce NB\<rbrace> \<in>set evs4;
             Gets B \<lbrace>X, Crypt(shrK B)\<lbrace>Nonce NB,Agent A,Agent B,Key K\<rbrace>\<rbrace>
               \<in>set evs4\<rbrakk>
          \<Longrightarrow> Says B A X # evs4 \<in> otway"

 | Oops: \<comment> \<open>This message models possible leaks of session keys.  The nonces
             identify the protocol run.\<close>
         "\<lbrakk>evso \<in> otway;
             Says Server B
                      \<lbrace>Crypt (shrK A) \<lbrace>Nonce NA, Agent A, Agent B, Key K\<rbrace>,
                        Crypt (shrK B) \<lbrace>Nonce NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
               \<in>set evso\<rbrakk>
          \<Longrightarrow> Notes Spy \<lbrace>Nonce NA, Nonce NB, Key K\<rbrace> # evso \<in> otway"

declare Says_imp_knows_Spy [THEN analz.Inj, dest]
declare parts.Body  [dest]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un  [dest]

text\<open>A "possibility property": there are traces that reach the end\<close>
lemma "\<lbrakk>B \<noteq> Server; Key K \<notin> used []\<rbrakk>
      \<Longrightarrow> \<exists>evs \<in> otway.
           Says B A (Crypt (shrK A) \<lbrace>Nonce NA, Agent A, Agent B, Key K\<rbrace>)
             \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] otway.Nil
                    [THEN otway.OR1, THEN otway.Reception,
                     THEN otway.OR2, THEN otway.Reception,
                     THEN otway.OR3, THEN otway.Reception, THEN otway.OR4])
apply (possibility, simp add: used_Cons)
done

lemma Gets_imp_Says [dest!]:
     "\<lbrakk>Gets B X \<in> set evs; evs \<in> otway\<rbrakk> \<Longrightarrow> \<exists>A. Says A B X \<in> set evs"
by (erule rev_mp, erule otway.induct, auto)

text\<open>For reasoning about the encrypted portion of messages\<close>

lemma OR4_analz_knows_Spy:
     "\<lbrakk>Gets B \<lbrace>X, Crypt(shrK B) X'\<rbrace> \<in> set evs;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> X \<in> analz (knows Spy evs)"
by blast

text\<open>Theorems of the form \<^term>\<open>X \<notin> parts (spies evs)\<close> imply that
NOBODY sends messages containing X!\<close>

text\<open>Spy never sees a good agent's shared key!\<close>
lemma Spy_see_shrK [simp]:
     "evs \<in> otway \<Longrightarrow> (Key (shrK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
by (erule otway.induct, simp_all, blast+)

lemma Spy_analz_shrK [simp]:
     "evs \<in> otway \<Longrightarrow> (Key (shrK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "\<lbrakk>Key (shrK A) \<in> parts (knows Spy evs);  evs \<in> otway\<rbrakk> \<Longrightarrow> A \<in> bad"
by (blast dest: Spy_see_shrK)

subsection\<open>Proofs involving analz\<close>

text\<open>Describes the form of K and NA when the Server sends this message.\<close>
lemma Says_Server_message_form:
     "\<lbrakk>Says Server B
            \<lbrace>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>,
              Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
           \<in> set evs;
         evs \<in> otway\<rbrakk>
      \<Longrightarrow> K \<notin> range shrK \<and> (\<exists>i. NA = Nonce i) \<and> (\<exists>j. NB = Nonce j)"
apply (erule rev_mp)
apply (erule otway.induct, auto)
done

(****
 The following is to prove theorems of the form

  Key K \<in> analz (insert (Key KAB) (knows Spy evs)) \<Longrightarrow>
  Key K \<in> analz (knows Spy evs)

 A more general formula must be proved inductively.
****)

text\<open>Session keys are not used to encrypt other session keys\<close>

text\<open>The equality makes the induction hypothesis easier to apply\<close>
lemma analz_image_freshK [rule_format]:
 "evs \<in> otway \<Longrightarrow>
   \<forall>K KK. KK \<subseteq> -(range shrK) \<longrightarrow>
          (Key K \<in> analz (Key`KK \<union> (knows Spy evs))) =
          (K \<in> KK | Key K \<in> analz (knows Spy evs))"
apply (erule otway.induct)
apply (frule_tac [8] Says_Server_message_form)
apply (drule_tac [7] OR4_analz_knows_Spy, analz_freshK, spy_analz, auto)
done

lemma analz_insert_freshK:
  "\<lbrakk>evs \<in> otway;  KAB \<notin> range shrK\<rbrakk> \<Longrightarrow>
      (Key K \<in> analz (insert (Key KAB) (knows Spy evs))) =
      (K = KAB | Key K \<in> analz (knows Spy evs))"
by (simp only: analz_image_freshK analz_image_freshK_simps)

text\<open>The Key K uniquely identifies the Server's message.\<close>
lemma unique_session_keys:
     "\<lbrakk>Says Server B
          \<lbrace>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, K\<rbrace>,
            Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, K\<rbrace>\<rbrace>
         \<in> set evs;
        Says Server B'
          \<lbrace>Crypt (shrK A') \<lbrace>NA', Agent A', Agent B', K\<rbrace>,
            Crypt (shrK B') \<lbrace>NB', Agent A', Agent B', K\<rbrace>\<rbrace>
         \<in> set evs;
        evs \<in> otway\<rbrakk>
     \<Longrightarrow> A=A' \<and> B=B' \<and> NA=NA' \<and> NB=NB'"
apply (erule rev_mp, erule rev_mp, erule otway.induct, simp_all)
apply blast+  \<comment> \<open>OR3 and OR4\<close>
done

subsection\<open>Authenticity properties relating to NA\<close>

text\<open>If the encrypted message appears then it originated with the Server!\<close>
lemma NA_Crypt_imp_Server_msg [rule_format]:
    "\<lbrakk>A \<notin> bad;  A \<noteq> B;  evs \<in> otway\<rbrakk>
     \<Longrightarrow> Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace> \<in> parts (knows Spy evs)
       \<longrightarrow> (\<exists>NB. Says Server B
                    \<lbrace>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>,
                      Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
                    \<in> set evs)"
apply (erule otway.induct, force)
apply (simp_all add: ex_disj_distrib)
apply blast+  \<comment> \<open>Fake, OR3\<close>
done

text\<open>Corollary: if A receives B's OR4 message then it originated with the
      Server. Freshness may be inferred from nonce NA.\<close>
lemma A_trusts_OR4:
     "\<lbrakk>Says B' A (Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>) \<in> set evs;
         A \<notin> bad;  A \<noteq> B;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> \<exists>NB. Says Server B
                  \<lbrace>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>,
                    Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
                 \<in> set evs"
by (blast intro!: NA_Crypt_imp_Server_msg)

text\<open>Crucial secrecy property: Spy does not see the keys sent in msg OR3
    Does not in itself guarantee security: an attack could violate
    the premises, e.g. by having \<^term>\<open>A=Spy\<close>\<close>
lemma secrecy_lemma:
     "\<lbrakk>A \<notin> bad;  B \<notin> bad;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> Says Server B
           \<lbrace>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>,
             Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
          \<in> set evs \<longrightarrow>
          Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs \<longrightarrow>
          Key K \<notin> analz (knows Spy evs)"
apply (erule otway.induct, force)
apply (frule_tac [7] Says_Server_message_form)
apply (drule_tac [6] OR4_analz_knows_Spy)
apply (simp_all add: analz_insert_eq analz_insert_freshK pushes)
apply spy_analz  \<comment> \<open>Fake\<close>
apply (blast dest: unique_session_keys)+  \<comment> \<open>OR3, OR4, Oops\<close>
done

lemma Spy_not_see_encrypted_key:
     "\<lbrakk>Says Server B
            \<lbrace>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>,
              Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
           \<in> set evs;
         Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
  by (metis secrecy_lemma)

text\<open>A's guarantee.  The Oops premise quantifies over NB because A cannot know
  what it is.\<close>
lemma A_gets_good_key:
     "\<lbrakk>Says B' A (Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>) \<in> set evs;
         \<forall>NB. Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  A \<noteq> B;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
  by (metis A_trusts_OR4 secrecy_lemma)

subsection\<open>Authenticity properties relating to NB\<close>

text\<open>If the encrypted message appears then it originated with the Server!\<close>
lemma NB_Crypt_imp_Server_msg [rule_format]:
 "\<lbrakk>B \<notin> bad;  A \<noteq> B;  evs \<in> otway\<rbrakk>
  \<Longrightarrow> Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace> \<in> parts (knows Spy evs)
      \<longrightarrow> (\<exists>NA. Says Server B
                   \<lbrace>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>,
                     Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
                   \<in> set evs)"
apply (erule otway.induct, force, simp_all add: ex_disj_distrib)
apply blast+  \<comment> \<open>Fake, OR3\<close>
done

text\<open>Guarantee for B: if it gets a well-formed certificate then the Server
  has sent the correct message in round 3.\<close>
lemma B_trusts_OR3:
     "\<lbrakk>Says S B \<lbrace>X, Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
           \<in> set evs;
         B \<notin> bad;  A \<noteq> B;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> \<exists>NA. Says Server B
                   \<lbrace>Crypt (shrK A) \<lbrace>NA, Agent A, Agent B, Key K\<rbrace>,
                     Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
                   \<in> set evs"
by (blast intro!: NB_Crypt_imp_Server_msg)

text\<open>The obvious combination of \<open>B_trusts_OR3\<close> with
      \<open>Spy_not_see_encrypted_key\<close>\<close>
lemma B_gets_good_key:
     "\<lbrakk>Gets B \<lbrace>X, Crypt (shrK B) \<lbrace>NB, Agent A, Agent B, Key K\<rbrace>\<rbrace>
          \<in> set evs;
         \<forall>NA. Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  A \<noteq> B;  evs \<in> otway\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest: B_trusts_OR3 Spy_not_see_encrypted_key)

end