theory Check
  imports Submission
begin

lemma fixp: "\<And>f::nat \<Rightarrow> nat. \<forall>n. n \<le> f n \<Longrightarrow> A = {m. \<exists>n. m = f n} \<Longrightarrow> \<exists>m \<in> A. \<forall>n \<in> A. n \<le> m \<Longrightarrow> \<exists>k\<in>A. f k = k"
  by (rule Submission.fixp)

end


(* Title: Hashed_Elgamal.thy
  Author: Andreas Lochbihler, ETH Zurich *)

subsection \<open>Hashed Elgamal in the Random Oracle Model\<close>

theory Hashed_Elgamal imports
  CryptHOL.GPV_Bisim
  CryptHOL.Cyclic_Group_SPMF
  CryptHOL.List_Bits
  IND_CPA_PK
  Diffie_Hellman
begin

type_synonym bitstring = "bool list"

locale hash_oracle = fixes len :: "nat" begin

type_synonym 'a state = "'a \<rightharpoonup> bitstring"

definition "oracle" :: "'a state \<Rightarrow> 'a \<Rightarrow> (bitstring \<times> 'a state) spmf"
where
  "oracle \<sigma> x =
  (case \<sigma> x of None \<Rightarrow> do {
     bs \<leftarrow> spmf_of_set (nlists UNIV len);
     return_spmf (bs, \<sigma>(x \<mapsto> bs))
   } | Some bs \<Rightarrow> return_spmf (bs, \<sigma>))"

abbreviation (input) initial :: "'a state" where "initial \<equiv> Map.empty"

inductive invariant :: "'a state \<Rightarrow> bool"
where
  invariant: "\<lbrakk> finite (dom \<sigma>); length ` ran \<sigma> \<subseteq> {len} \<rbrakk> \<Longrightarrow> invariant \<sigma>"

lemma invariant_initial [simp]: "invariant initial"
by(rule invariant.intros) auto

lemma invariant_update [simp]: "\<lbrakk> invariant \<sigma>; length bs = len \<rbrakk> \<Longrightarrow> invariant (\<sigma>(x \<mapsto> bs))"
by(auto simp add: invariant.simps ran_def)

lemma invariant [intro!, simp]: "callee_invariant oracle invariant"
by unfold_locales(simp_all add: oracle_def in_nlists_UNIV split: option.split_asm)

lemma invariant_in_dom [simp]: "callee_invariant oracle (\<lambda>\<sigma>. x \<in> dom \<sigma>)"
by unfold_locales(simp_all add: oracle_def split: option.split_asm)

lemma lossless_oracle [simp]: "lossless_spmf (oracle \<sigma> x)"
by(simp add: oracle_def split: option.split)

lemma card_dom_state:
  assumes \<sigma>': "(x, \<sigma>') \<in> set_spmf (exec_gpv oracle gpv \<sigma>)"
  and ibound: "interaction_any_bounded_by gpv n"
  shows "card (dom \<sigma>') \<le> n + card (dom \<sigma>)"
proof(cases "finite (dom \<sigma>)")
  case True
  interpret callee_invariant_on "oracle" "\<lambda>\<sigma>. finite (dom \<sigma>)" \_full
    by unfold_locales(auto simp add: oracle_def split: option.split_asm)
  from ibound \<sigma>' _ _ _ True show ?thesis
    by(rule interaction_bounded_by'_exec_gpv_count)(auto simp add: oracle_def card_insert_if simp del: fun_upd_apply split: option.split_asm)
next
  case False
  interpret callee_invariant_on "oracle" "\<lambda>\<sigma>'. dom \<sigma> \<subseteq> dom \<sigma>'" \_full
    by unfold_locales(auto simp add: oracle_def split: option.split_asm)
  from \<sigma>' have "dom \<sigma> \<subseteq> dom \<sigma>'" by(rule exec_gpv_invariant) simp_all
  with False have "infinite (dom \<sigma>')" by(auto intro: finite_subset)
  with False show ?thesis by simp
qed

end

locale elgamal_base =
  fixes \<G> :: "'grp cyclic_group" (structure)
  and len_plain :: "nat"
begin

sublocale hash: hash_oracle "len_plain" .
abbreviation hash :: "'grp \<Rightarrow> (bitstring, 'grp, bitstring) gpv"
where "hash x \<equiv> Pause x Done"

type_synonym 'grp' pub_key = "'grp'"
type_synonym 'grp' priv_key = nat
type_synonym plain = bitstring
type_synonym 'grp' cipher = "'grp' \<times> bitstring"

definition key_gen :: "('grp pub_key \<times> 'grp priv_key) spmf"
where
  "key_gen = do {
     x \<leftarrow> sample_uniform (order \<G>);
     return_spmf (\<^bold>g [^] x, x)
  }"

definition aencrypt :: "'grp pub_key \<Rightarrow> plain \<Rightarrow> ('grp cipher, 'grp, bitstring) gpv"
where
  "aencrypt \<alpha> msg = do {
    y \<leftarrow> lift_spmf (sample_uniform (order \<G>));
    h \<leftarrow> hash (\<alpha> [^] y);
    Done (\<^bold>g [^] y, h [\<oplus>] msg)
  }"

definition adecrypt :: "'grp priv_key \<Rightarrow> 'grp cipher \<Rightarrow> (plain, 'grp, bitstring) gpv"
where
  "adecrypt x = (\<lambda>(\<beta>, \<zeta>). do {
    h \<leftarrow> hash (\<beta> [^] x);
    Done (\<zeta> [\<oplus>] h)
  })"

definition valid_plains :: "plain \<Rightarrow> plain \<Rightarrow> bool"
where "valid_plains msg1 msg2 \<longleftrightarrow> length msg1 = len_plain \<and> length msg2 = len_plain"

lemma lossless_aencrypt [simp]: "lossless_gpv \ (aencrypt \<alpha> msg) \<longleftrightarrow> 0 < order \<G>"
by(simp add: aencrypt_def Let_def)

lemma interaction_bounded_by_aencrypt [interaction_bound, simp]:
  "interaction_bounded_by (\<lambda>_. True) (aencrypt \<alpha> msg) 1"
unfolding aencrypt_def by interaction_bound(simp add: one_enat_def SUP_le_iff)

sublocale ind_cpa: ind_cpa_pk "lift_spmf key_gen" aencrypt adecrypt valid_plains .
sublocale lcdh: lcdh \<G> .

fun elgamal_adversary
   :: "('grp pub_key, plain, 'grp cipher, 'grp, bitstring, 'state) ind_cpa.adversary
   \<Rightarrow> 'grp lcdh.adversary"
where
  "elgamal_adversary (\1, \2) \<alpha> \<beta> = do {
    (((msg1, msg2), \<sigma>), s) \<leftarrow> exec_gpv hash.oracle (\1 \<alpha>) hash.initial;
    \<comment> \<open>have to check that the attacker actually sends an element from the group; otherwise stop early\<close>
    TRY do {
      _ :: unit \<leftarrow> assert_spmf (valid_plains msg1 msg2);
      h' \<leftarrow> spmf_of_set (nlists UNIV len_plain);
      (guess, s') \<leftarrow> exec_gpv hash.oracle (\2 (\<beta>, h') \<sigma>) s;
      return_spmf (dom s')
    } ELSE return_spmf (dom s)
  }"

end

locale elgamal = elgamal_base +
  assumes cyclic_group: "cyclic_group \<G>"
begin

interpretation cyclic_group \<G> by(fact cyclic_group)

lemma advantage_elgamal:
  includes lifting_syntax
  assumes lossless: "ind_cpa.lossless \"
  shows "ind_cpa.advantage hash.oracle hash.initial \ \<le> lcdh.advantage (elgamal_adversary \)"
proof -
  note [cong del] = if_weak_cong and [split del] = if_split
    and [simp] = map_lift_spmf gpv.map_id lossless_weight_spmfD map_spmf_bind_spmf bind_spmf_const
  obtain \1 \2 where \ [simp]: "\ = (\1, \2)" by(cases "\")

  interpret cyclic_group: cyclic_group \<G> by(rule cyclic_group)
  from finite_carrier have [simp]: "order \<G> > 0" using order_gt_0_iff_finite by(simp)

  from lossless have lossless1 [simp]: "\<And>pk. lossless_gpv \_full (\1 pk)"
    and lossless2 [simp]: "\<And>\<sigma> cipher. lossless_gpv \_full (\2 \<sigma> cipher)"
    by(auto simp add: ind_cpa.lossless_def)

  text \<open>We change the adversary's oracle to record the queries made by the adversary\<close>
  define hash_oracle' where "hash_oracle' = (\<lambda>\<sigma> x. do {
      h \<leftarrow> hash x;
      Done (h, insert x \<sigma>)
    })"
  have [simp]: "lossless_gpv \_full (hash_oracle' \<sigma> x)" for \<sigma> x by(simp add: hash_oracle'_def)
  have [simp]: "lossless_gpv \_full (inline hash_oracle' (\1 \<alpha>) s)" for \<alpha> s
    by(rule lossless_inline[where \=\_full]) simp_all
  define game0 where "game0 = TRY do {
      (pk, _) \<leftarrow> lift_spmf key_gen;
      b \<leftarrow> lift_spmf coin_spmf;
      (((msg1, msg2), \<sigma>), s) \<leftarrow> inline hash_oracle' (\1 pk) {};
      assert_gpv (valid_plains msg1 msg2);
      cipher \<leftarrow> aencrypt pk (if b then msg1 else msg2);
      (guess, s') \<leftarrow> inline hash_oracle' (\2 cipher \<sigma>) s;
      Done (guess = b)
    } ELSE lift_spmf coin_spmf"
  { define cr where "cr = (\<lambda>_ :: unit. \<lambda>_ :: 'a set. True)"
    have [transfer_rule]: "cr () {}" by(simp add: cr_def)
    have [transfer_rule]: "((=) ===> cr ===> cr) (\<lambda>_ \<sigma>. \<sigma>) insert" by(simp add: rel_fun_def cr_def)
    have [transfer_rule]: "(cr ===> (=) ===> rel_gpv (rel_prod (=) cr) (=)) id_oracle hash_oracle'"
      unfolding hash_oracle'_def id_oracle_def[abs_def] bind_gpv_Pause bind_rpv_Done by transfer_prover
    have "ind_cpa.ind_cpa \ = game0" unfolding game0_def \ ind_cpa_pk.ind_cpa.simps
      by(transfer fixing: \<G> len_plain \1 \2)(simp add: bind_map_gpv o_def ind_cpa_pk.ind_cpa.simps split_def) }
  note game0 = this
  have game0_alt_def: "game0 = do {
      x \<leftarrow> lift_spmf (sample_uniform (order \<G>));
      b \<leftarrow> lift_spmf coin_spmf;
      (((msg1, msg2), \<sigma>), s) \<leftarrow> inline hash_oracle' (\1 (\<^bold>g [^] x)) {};
      TRY do {
        _ :: unit \<leftarrow> assert_gpv (valid_plains msg1 msg2);
        cipher \<leftarrow> aencrypt (\<^bold>g [^] x) (if b then msg1 else msg2);
        (guess, s') \<leftarrow> inline hash_oracle' (\2 cipher \<sigma>) s;
        Done (guess = b)
      } ELSE lift_spmf coin_spmf
    }"
    by(simp add: split_def game0_def key_gen_def lift_spmf_bind_spmf bind_gpv_assoc try_gpv_bind_lossless[symmetric])

  define hash_oracle'' where "hash_oracle'' = (\<lambda>(s, \<sigma>) (x :: 'a). do {
      (h, \<sigma>') \<leftarrow> case \<sigma> x of
          None \<Rightarrow> bind_spmf (spmf_of_set (nlists UNIV len_plain)) (\<lambda>bs. return_spmf (bs, \<sigma>(x \<mapsto> bs)))
        | Some (bs :: bitstring) \<Rightarrow> return_spmf (bs, \<sigma>);
      return_spmf (h, insert x s, \<sigma>')
    })"
  have *: "exec_gpv hash.oracle (inline hash_oracle' \ s) \<sigma> =
    map_spmf (\<lambda>(a, b, c). ((a, b), c)) (exec_gpv hash_oracle'' \ (s, \<sigma>))" for \ \<sigma> s
    by(simp add: hash_oracle'_def hash_oracle''_def hash.oracle_def Let_def exec_gpv_inline exec_gpv_bind o_def split_def cong del: option.case_cong_weak)
  have [simp]: "lossless_spmf (hash_oracle'' s plain)" for s plain
    by(simp add: hash_oracle''_def Let_def split: prod.split option.split)
  have [simp]: "lossless_spmf (exec_gpv hash_oracle'' (\1 \<alpha>) s)" for s \<alpha>
    by(rule lossless_exec_gpv[where \=\_full]) simp_all
  have [simp]: "lossless_spmf (exec_gpv hash_oracle'' (\2 \<sigma> cipher) s)" for \<sigma> cipher s
    by(rule lossless_exec_gpv[where \=\_full]) simp_all

  let ?sample = "\<lambda>f. bind_spmf (sample_uniform (order \<G>)) (\<lambda>x. bind_spmf (sample_uniform (order \<G>)) (f x))"
  define game1 where "game1 = (\<lambda>(x :: nat) (y :: nat). do {
      b \<leftarrow> coin_spmf;
      (((msg1, msg2), \<sigma>), (s, s_h)) \<leftarrow> exec_gpv hash_oracle'' (\1 (\<^bold>g [^] x)) ({}, hash.initial);
      TRY do {
        _ :: unit \<leftarrow> assert_spmf (valid_plains msg1 msg2);
        (h, s_h') \<leftarrow> hash.oracle s_h (\<^bold>g [^] (x * y));
        let cipher = (\<^bold>g [^] y, h [\<oplus>] (if b then msg1 else msg2));
        (guess, (s', s_h'')) \<leftarrow> exec_gpv hash_oracle'' (\2 cipher \<sigma>) (s, s_h');
        return_spmf (guess = b, \<^bold>g [^] (x * y) \<in> s')
      } ELSE do {
        b \<leftarrow> coin_spmf;
        return_spmf (b, \<^bold>g [^] (x * y) \<in> s)
      }
    })"
  have game01: "run_gpv hash.oracle game0 hash.initial = map_spmf fst (?sample game1)"
    apply(simp add: exec_gpv_bind split_def bind_gpv_assoc aencrypt_def game0_alt_def game1_def o_def bind_map_spmf if_distribs * try_bind_assert_gpv try_bind_assert_spmf lossless_inline[where \=\_full] bind_rpv_def nat_pow_pow del: bind_spmf_const)
    including monad_normalisation by(simp add: bind_rpv_def nat_pow_pow)

  define game2 where "game2 = (\<lambda>(x :: nat) (y :: nat). do {
    b \<leftarrow> coin_spmf;
    (((msg1, msg2), \<sigma>), (s, s_h)) \<leftarrow> exec_gpv hash_oracle'' (\1 (\<^bold>g [^] x)) ({}, hash.initial);
    TRY do {
      _ :: unit \<leftarrow> assert_spmf (valid_plains msg1 msg2);
      h \<leftarrow> spmf_of_set (nlists UNIV len_plain);
      \<comment> \<open>We do not do the lookup in \<open>s_h\<close> here, so the rest differs only if the adversary guessed \<open>y\<close>\<close>
      let cipher = (\<^bold>g [^] y, h [\<oplus>] (if b then msg1 else msg2));
      (guess, (s', s_h')) \<leftarrow> exec_gpv hash_oracle'' (\2 cipher \<sigma>) (s, s_h);
      return_spmf (guess = b, \<^bold>g [^] (x * y) \<in> s')
    } ELSE do {
      b \<leftarrow> coin_spmf;
      return_spmf (b, \<^bold>g [^] (x * y) \<in> s)
    }
  })"
  interpret inv'': callee_invariant_on "hash_oracle''" "\<lambda>(s, s_h). s = dom s_h" \_full
    by unfold_locales(auto simp add: hash_oracle''_def split: option.split_asm if_split)
  have in_encrypt_oracle: "callee_invariant hash_oracle'' (\<lambda>(s, _). x \<in> s)" for x
    by unfold_locales(auto simp add: hash_oracle''_def)

  { fix x y :: nat
    let ?bad = "\<lambda>(s, s_h). \<^bold>g [^] (x * y) \<in> s"
    let ?X = "\<lambda>(s, s_h) (s', s_h'). s = dom s_h \<and> s' = s \<and> s_h = s_h'(\<^bold>g [^] (x * y) := None)"
    have bisim:
      "rel_spmf (\<lambda>(a, s1') (b, s2'). ?bad s1' = ?bad s2' \<and> (\<not> ?bad s2' \<longrightarrow> a = b \<and> ?X s1' s2'))
             (hash_oracle'' s1 plain) (hash_oracle'' s2 plain)"
      if "?X s1 s2" for s1 s2 plain using that
      by(auto split: prod.splits intro!: rel_spmf_bind_reflI simp add: hash_oracle''_def rel_spmf_return_spmf2 fun_upd_twist split: option.split dest!: fun_upd_eqD)
    have inv: "callee_invariant hash_oracle'' ?bad"
      by(unfold_locales)(auto simp add: hash_oracle''_def split: option.split_asm)
    have "rel_spmf (\<lambda>(win, bad) (win', bad'). bad = bad' \<and> (\<not> bad' \<longrightarrow> win = win')) (game2 x y) (game1 x y)"
      unfolding game1_def game2_def
      apply(clarsimp simp add: split_def o_def hash.oracle_def rel_spmf_bind_reflI if_distribs intro!: rel_spmf_bind_reflI simp del: bind_spmf_const)
      apply(rule rel_spmf_try_spmf)
      subgoal for b msg1 msg2 \<sigma> s s_h
        apply(rule rel_spmf_bind_reflI)
        apply(drule inv''.exec_gpv_invariant; clarsimp)
        apply(cases "s_h (\<^bold>g [^] (x * y))")
        subgoal \<comment> \<open>case @{const None}\<close>
          apply(clarsimp intro!: rel_spmf_bind_reflI)
          apply(rule rel_spmf_bindI)
           apply(rule exec_gpv_oracle_bisim_bad_full[OF _ _ bisim inv inv, where R="\<lambda>(x, s1) (y, s2). ?bad s1 = ?bad s2 \<and> (\<not> ?bad s2 \<longrightarrow> x = y)"]; clarsimp simp add: fun_upd_idem; fail)
          apply clarsimp
          done
        subgoal by(auto intro!: rel_spmf_bindI1 rel_spmf_bindI2 lossless_exec_gpv[where \=\_full] dest!: callee_invariant_on.exec_gpv_invariant[OF in_encrypt_oracle])
        done
      subgoal by(rule rel_spmf_reflI) simp
      done }
  hence "rel_spmf (\<lambda>(win, bad) (win', bad'). (bad \<longleftrightarrow> bad') \<and> (\<not> bad' \<longrightarrow> win \<longleftrightarrow> win')) (?sample game2) (?sample game1)"
    by(intro rel_spmf_bind_reflI)
  hence "\<bar>measure (measure_spmf (?sample game2)) {(x, _). x} - measure (measure_spmf (?sample game1)) {(y, _). y}\<bar>
        \<le> measure (measure_spmf (?sample game2)) {(_, bad). bad}"
    unfolding split_def by(rule fundamental_lemma)
  moreover have "measure (measure_spmf (?sample game2)) {(x, _). x} = spmf (map_spmf fst (?sample game2)) True"
    and "measure (measure_spmf (?sample game1)) {(y, _). y} = spmf (map_spmf fst (?sample game1)) True"
    and "measure (measure_spmf (?sample game2)) {(_, bad). bad} = spmf (map_spmf snd (?sample game2)) True"
    unfolding spmf_conv_measure_spmf measure_map_spmf by(rule arg_cong2[where f=measure]; fastforce)+
  ultimately have hop23: "\<bar>spmf (map_spmf fst (?sample game2)) True - spmf (map_spmf fst (?sample game1)) True\<bar> \<le> spmf (map_spmf snd (?sample game2)) True" by simp

  define game3
    where "game3 = (\<lambda>f :: _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> bitstring spmf \<Rightarrow> _ spmf. \<lambda>(x :: nat) (y :: nat). do {
      b \<leftarrow> coin_spmf;
      (((msg1, msg2), \<sigma>), (s, s_h)) \<leftarrow> exec_gpv hash_oracle'' (\1 (\<^bold>g [^] x)) ({}, hash.initial);
      TRY do {
        _ :: unit \<leftarrow> assert_spmf (valid_plains msg1 msg2);
        h' \<leftarrow> f b msg1 msg2 (spmf_of_set (nlists UNIV len_plain));
        let cipher = (\<^bold>g [^] y, h');
        (guess, (s', s_h')) \<leftarrow> exec_gpv hash_oracle'' (\2 cipher \<sigma>) (s, s_h);
        return_spmf (guess = b, \<^bold>g [^] (x * y) \<in> s')
      } ELSE do {
        b \<leftarrow> coin_spmf;
        return_spmf (b, \<^bold>g [^] (x * y) \<in> s)
      }
    })"
  let ?f = "\<lambda>b msg1 msg2. map_spmf (\<lambda>h. (if b then msg1 else msg2) [\<oplus>] h)"
  have "game2 x y = game3 ?f x y" for x y
    unfolding game2_def game3_def by(simp add: Let_def bind_map_spmf xor_list_commute o_def nat_pow_pow)
  also have "game3 ?f x y = game3 (\<lambda>_ _ _ x. x) x y" for x y (* optimistic sampling *)
    unfolding game3_def
    by(auto intro!: try_spmf_cong bind_spmf_cong[OF refl] if_cong[OF refl] simp add: split_def one_time_pad valid_plains_def simp del: map_spmf_of_set_inj_on bind_spmf_const split: if_split)
  finally have game23: "game2 x y = game3 (\<lambda>_ _ _ x. x) x y" for x y .

  define hash_oracle''' where "hash_oracle''' = (\<lambda>(\<sigma> :: 'a \<Rightarrow> _). hash.oracle \<sigma>)"
  { define bisim where "bisim = (\<lambda>\<sigma> (s :: 'a set, \<sigma>' :: 'a \<rightharpoonup> bitstring). s = dom \<sigma> \<and> \<sigma> = \<sigma>')"
    have [transfer_rule]: "bisim Map_empty ({}, Map_empty)" by(simp add: bisim_def)
    have [transfer_rule]: "(bisim ===> (=) ===> rel_spmf (rel_prod (=) bisim)) hash_oracle''' hash_oracle''"
      by(auto simp add: hash_oracle''_def split_def hash_oracle'''_def spmf_rel_map hash.oracle_def rel_fun_def bisim_def split: option.split intro!: rel_spmf_bind_reflI)
    have * [transfer_rule]: "(bisim ===> (=)) dom fst" by(simp add: bisim_def rel_fun_def)
    have * [transfer_rule]: "(bisim ===> (=)) (\<lambda>x. x) snd" by(simp add: rel_fun_def bisim_def)
    have "game3 (\<lambda>_ _ _ x. x) x y = do {
        b \<leftarrow> coin_spmf;
        (((msg1, msg2), \<sigma>), s) \<leftarrow> exec_gpv hash_oracle''' (\1 (\<^bold>g [^] x)) hash.initial;
        TRY do {
          _ :: unit \<leftarrow> assert_spmf (valid_plains msg1 msg2);
          h' \<leftarrow> spmf_of_set (nlists UNIV len_plain);
          let cipher = (\<^bold>g [^] y, h');
          (guess, s') \<leftarrow> exec_gpv hash_oracle''' (\2 cipher \<sigma>) s;
          return_spmf (guess = b, \<^bold>g [^] (x * y) \<in> dom s')
        } ELSE do {
          b \<leftarrow> coin_spmf;
          return_spmf (b, \<^bold>g [^] (x * y) \<in> dom s)
        }
      }" for x y
      unfolding game3_def Map_empty_def[symmetric] split_def fst_conv snd_conv prod.collapse
      by(transfer fixing: \1 \<G> len_plain x y \2) simp
    moreover have "map_spmf snd (\<dots> x y) = do {
        zs \<leftarrow> elgamal_adversary \ (\<^bold>g [^] x) (\<^bold>g [^] y);
        return_spmf (\<^bold>g [^] (x * y) \<in> zs)
      }" for x y
      by(simp add: o_def split_def hash_oracle'''_def map_try_spmf map_scale_spmf)
        (simp add: o_def map_try_spmf map_scale_spmf map_spmf_conv_bind_spmf[symmetric] spmf.map_comp map_const_spmf_of_set)
    ultimately have "map_spmf snd (?sample (game3 (\<lambda>_ _ _ x. x))) = lcdh.lcdh (elgamal_adversary \)"
      by(simp add: o_def lcdh.lcdh_def Let_def nat_pow_pow) }
  then have game2_snd: "map_spmf snd (?sample game2) = lcdh.lcdh (elgamal_adversary \)"
    using game23 by(simp add: o_def)

  have "map_spmf fst (game3 (\<lambda>_ _ _ x. x) x y) = do {
      (((msg1, msg2), \<sigma>), (s, s_h)) \<leftarrow> exec_gpv hash_oracle'' (\1 (\<^bold>g [^] x)) ({}, hash.initial);
      TRY do {
        _ :: unit \<leftarrow> assert_spmf (valid_plains msg1 msg2);
        h' \<leftarrow> spmf_of_set (nlists UNIV len_plain);
        (guess, (s', s_h')) \<leftarrow> exec_gpv hash_oracle'' (\2 (\<^bold>g [^] y, h') \<sigma>) (s, s_h);
        map_spmf ((=) guess) coin_spmf
      } ELSE coin_spmf
    }" for x y
    including monad_normalisation
    by(simp add: game3_def o_def split_def map_spmf_conv_bind_spmf try_spmf_bind_out weight_spmf_le_1 scale_bind_spmf try_spmf_bind_out1 bind_scale_spmf)
  then have game3_fst: "map_spmf fst (game3 (\<lambda>_ _ _ x. x) x y) = coin_spmf" for x y
    by(simp add: o_def if_distribs spmf.map_comp map_eq_const_coin_spmf split_def)

  have "ind_cpa.advantage hash.oracle hash.initial \ = \<bar>spmf (map_spmf fst (?sample game1)) True - 1 / 2\<bar>"
    using game0 by(simp add: ind_cpa_pk.advantage_def game01 o_def)
  also have "\<dots> = \<bar>1 / 2 - spmf (map_spmf fst (?sample game1)) True\<bar>"
    by(simp add: abs_minus_commute)
  also have "1 / 2 = spmf (map_spmf fst (?sample game2)) True"
    by(simp add: game23 o_def game3_fst spmf_of_set)
  also note hop23 also note game2_snd
  finally show ?thesis by(simp add: lcdh.advantage_def)
qed

end

context elgamal_base begin

lemma lossless_key_gen [simp]: "lossless_spmf key_gen \<longleftrightarrow> 0 < order \<G>"
by(simp add: key_gen_def Let_def)

lemma lossless_elgamal_adversary:
  "\<lbrakk> ind_cpa.lossless \; \<And>\<eta>. 0 < order \<G> \<rbrakk>
  \<Longrightarrow> lcdh.lossless (elgamal_adversary \)"
by(cases \)(auto simp add: lcdh.lossless_def ind_cpa.lossless_def split_def Let_def intro!: lossless_exec_gpv[where \=\_full] lossless_inline)

end

end


(* Title: RTS/Common/RTS_safe.thy *)
(* Author: Susannah Mansky, UIUC 2020 *)

section "Regression Test Selection algorithm model"

theory RTS_safe
imports Main
begin

text \<open> This describes an \emph{existence safe} RTS algorithm: if a test
 is deselected based on an output, there is SOME equivalent output
 under the changed program. \<close>
locale RTS_safe =
 fixes
  out :: "'prog \<Rightarrow> 'test \<Rightarrow> 'prog_out set" and
  equiv_out :: "'prog_out \<Rightarrow> 'prog_out \<Rightarrow> bool" and
  deselect :: "'prog \<Rightarrow> 'prog_out \<Rightarrow> 'prog \<Rightarrow> bool" and
  progs :: "'prog set" and
  tests :: "'test set"
 assumes
  existence_safe: "\<lbrakk> P \<in> progs; P' \<in> progs; t \<in> tests; o1 \<in> out P t; deselect P o1 P' \<rbrakk>
   \<Longrightarrow> (\<exists>o2 \<in> out P' t. equiv_out o1 o2)" and
  equiv_out_equiv: "equiv UNIV {(x,y). equiv_out x y}" and
  equiv_out_deselect: "\<lbrakk> equiv_out o1 o2; deselect P o1 P' \<rbrakk> \<Longrightarrow> deselect P o2 P'"

context RTS_safe begin

lemma equiv_out_refl: "equiv_out a a"
using equiv_class_eq_iff equiv_out_equiv by fastforce

lemma equiv_out_trans: "\<lbrakk> equiv_out a b; equiv_out b c \<rbrakk> \<Longrightarrow> equiv_out a c"
using equiv_class_eq_iff equiv_out_equiv by fastforce

text "This shows that it is safe to continue deselecting a test based
 on its output under a previous program, to an arbitrary number of
 program changes, as long as the test is continually deselected. This
 is useful because it means changed programs don't need to generate new
 outputs for deselected tests to ensure safety of future deselections."
lemma existence_safe_trans:
assumes Pst_in: "Ps \<noteq> []" "set Ps \<subseteq> progs" "t \<in> tests" and
 o0: "o\<^sub>0 \<in> out (Ps!0) t" and
 des: "\<forall>n < (length Ps) - 1. deselect (Ps!n) o\<^sub>0 (Ps!(Suc n))"
shows "\<exists>o\<^sub>n \<in> out (last Ps) t. equiv_out o\<^sub>0 o\<^sub>n"
using assms proof(induct "length Ps" arbitrary: Ps)
  case 0 with Pst_in show ?case by simp
next
  case (Suc x) then show ?case
  proof(induct x)
  case z: 0
    from z.prems(2,3) have "Ps ! (length Ps - 2) = last Ps"
      by (simp add: last_conv_nth numeral_2_eq_2)
    with equiv_out_refl z.prems(2,6) show ?case by auto
  next
    case Suc':(Suc x')
    let ?Ps = "take (Suc x') Ps"
    have len': "Suc x' = length (take (Suc x') Ps)" using Suc'.prems(2) by auto
    moreover have nmt': "take (Suc x') Ps \<noteq> []" using len' by auto
    moreover have sub': "set (take (Suc x') Ps) \<subseteq> progs" using Suc.prems(2)
      by (meson order_trans set_take_subset)
    moreover have "t \<in> tests" using Pst_in(3) by simp
    moreover have "o\<^sub>0 \<in> out (take (Suc x') Ps ! 0) t" using Suc.prems(4) by simp
    moreover have "\<forall>n<length (take (Suc x') Ps) - 1.
     deselect (take (Suc x') Ps ! n) o\<^sub>0 (take (Suc x') Ps ! (Suc n))"
      using Suc.prems(5) len' by simp
    ultimately have "\<exists>o'\<in>out (last ?Ps) t. equiv_out o\<^sub>0 o'" by(rule Suc'.prems(1)[of ?Ps])
    then obtain o' where o': "o' \<in> out (last ?Ps) t" and eo: "equiv_out o\<^sub>0 o'" by clarify
    from Suc.prems(1) Suc'.prems(2) len' nmt'
    have "last (take (Suc x') Ps) = Ps!x'" "last Ps = Ps!(Suc x')"
      by (metis diff_Suc_1 last_conv_nth lessI nth_take)+
    moreover have "x' < length Ps - 1" using Suc'.prems(2) by linarith
    ultimately have des':"deselect (last (take (Suc x') Ps)) o\<^sub>0 (last Ps)"
      using Suc.prems(5) by simp
    from Suc.prems(1,2) sub' nmt' last_in_set
    have Ps_in: "last (take (Suc x') Ps) \<in> progs" "last Ps \<in> progs" by blast+
    have "\<exists>o\<^sub>n \<in> out (last Ps) t. equiv_out o' o\<^sub>n"
      by(rule existence_safe[where P="last (take (Suc x') Ps)" and P'="last Ps" and t=t,
                    OF Ps_in Pst_in(3) o' equiv_out_deselect[OF eo des']])
    then obtain o\<^sub>n where oN: "o\<^sub>n \<in> out (last Ps) t" and eo': "equiv_out o' o\<^sub>n" by clarify
    moreover from eo eo' have "equiv_out o\<^sub>0 o\<^sub>n" by(rule equiv_out_trans)
    ultimately show ?case by auto
  qed
qed

end \<comment> \<open> @{text RTS_safe} \<close>

end


section \<open>Linear Temporal Logic on Streams\<close>

theory Sequence_LTL
imports
  "Sequence"
  "HOL-Library.Linear_Temporal_Logic_on_Streams"
begin

  subsection \<open>Basics\<close>

  text \<open>Avoid destroying the constant @{const holds} prematurely.\<close>
  lemmas [simp del] = holds.simps holds_eq1 holds_eq2 not_holds_eq

  (* TODO: these cannot be applied successively to simplify infs due to introduction of \<circ>
    avoid or add extra simplification rules for infs *)
  lemma ev_smap[iff]: "ev P (smap f w) \<longleftrightarrow> ev (P \<circ> smap f) w" using ev_smap unfolding comp_apply by this
  lemma alw_smap[iff]: "alw P (smap f w) \<longleftrightarrow> alw (P \<circ> smap f) w" using alw_smap unfolding comp_apply by this
  lemma holds_smap[iff]: "holds P (smap f w) \<longleftrightarrow> holds (P \<circ> f) w" unfolding holds.simps by simp

  lemmas [iff] = ev_sconst alw_sconst hld_smap'

  lemmas [iff] = alw_ev_stl
  lemma alw_ev_sdrop[iff]: "alw (ev P) (sdrop n w) \<longleftrightarrow> alw (ev P) w"
    using alw_ev_sdrop alw_sdrop by blast
  lemma alw_ev_scons[iff]: "alw (ev P) (a ## w) \<longleftrightarrow> alw (ev P) w" by (metis alw_ev_stl stream.sel(2))
  lemma alw_ev_shift[iff]: "alw (ev P) (u @- v) \<longleftrightarrow> alw (ev P) v" by (induct u) (auto)

  lemmas [simp del, iff] = ev_alw_stl
  lemma ev_alw_sdrop[iff]: "ev (alw P) (sdrop n w) \<longleftrightarrow> ev (alw P) w"
    using alwD alw_alw alw_sdrop ev_alw_imp_alw_ev not_ev_iff by metis
  lemma ev_alw_scons[iff]: "ev (alw P) (a ## w) \<longleftrightarrow> ev (alw P) w" by (metis ev_alw_stl stream.sel(2))
  lemma ev_alw_shift[iff]: "ev (alw P) (u @- v) \<longleftrightarrow> ev (alw P) v" by (induct u) (auto)

  lemma holds_sconst[iff]: "holds P (sconst a) \<longleftrightarrow> P a" unfolding holds.simps by simp
  lemma HLD_sconst[iff]: "HLD A (sconst a) \<longleftrightarrow> a \<in> A" unfolding HLD_def holds.simps by simp

  lemma ev_alt_def: "ev \<phi> w \<longleftrightarrow> (\<exists> u v. w = u @- v \<and> \<phi> v)"
    using ev.base ev_shift ev_imp_shift by metis
  lemma ev_stl_alt_def: "ev \<phi> (stl w) \<longleftrightarrow> (\<exists> u v. w = u @- v \<and> u \<noteq> [] \<and> \<phi> v)"
    unfolding ev_alt_def by (cases w) (force simp: scons_eq)

  lemma ev_HLD_sset: "ev (HLD A) w \<longleftrightarrow> sset w \<inter> A \<noteq> {}" unfolding HLD_def ev_holds_sset by auto

  lemma alw_ev_coinduct[case_names alw_ev, consumes 1]:
    assumes "R w"
    assumes "\<And> w. R w \<Longrightarrow> ev \<phi> w \<and> ev R (stl w)"
    shows "alw (ev \<phi>) w"
  proof -
    have "ev R w" using assms(1) by rule
    then show ?thesis using assms(2) by (coinduct) (metis alw_sdrop not_ev_iff sdrop_stl sdrop_wait)
  qed

  subsection \<open>Infinite Occurrence\<close>

  abbreviation "infs P w \<equiv> alw (ev (holds P)) w"
  abbreviation "fins P w \<equiv> \<not> infs P w"

  lemma infs_suffix: "infs P w \<longleftrightarrow> (\<forall> u v. w = u @- v \<longrightarrow> Bex (sset v) P)"
    using alwD alw_iff_sdrop alw_shift ev_holds_sset stake_sdrop by (metis (mono_tags, hide_lams))
  lemma infs_snth: "infs P w \<longleftrightarrow> (\<forall> n. \<exists> k \<ge> n. P (w !! k))"
    by (auto simp: alw_iff_sdrop ev_iff_sdrop holds.simps intro: le_add1 dest: le_Suc_ex)
  lemma infs_infm: "infs P w \<longleftrightarrow> (\<exists>\<^sub>\<infinity> i. P (w !! i))"
    unfolding infs_snth INFM_nat_le by rule

  lemma infs_mono: "(\<And> a. a \<in> sset w \<Longrightarrow> P a \<Longrightarrow> Q a) \<Longrightarrow> infs P w \<Longrightarrow> infs Q w"
    unfolding infs_snth by force
  lemma infs_mono_strong: "stream_all2 (\<lambda> a b. P a \<longrightarrow> Q b) u v \<Longrightarrow> infs P u \<Longrightarrow> infs Q v"
    unfolding stream_rel_snth infs_snth by blast

  lemma infs_all: "Ball (sset w) P \<Longrightarrow> infs P w" unfolding infs_snth by auto

  lemma infs_bot[iff]: "infs bot w \<longleftrightarrow> False" using infs_any by auto
  lemma infs_top[iff]: "infs top w \<longleftrightarrow> True" by (simp add: infs_all)
  lemma infs_disj[iff]: "infs (\<lambda> a. P a \<or> Q a) w \<longleftrightarrow> infs P w \<or> infs Q w"
    unfolding infs_snth using le_trans le_cases by metis
  lemma infs_bex[iff]:
    assumes "finite S"
    shows "infs (\<lambda> a. \<exists> x \<in> S. P x a) w \<longleftrightarrow> (\<exists> x \<in> S. infs (P x) w)"
    using assms infs_any by induct auto
  lemma infs_bex_le_nat[iff]: "infs (\<lambda> a. \<exists> k < n :: nat. P k a) w \<longleftrightarrow> (\<exists> k < n. infs (P k) w)"
  proof -
    have "infs (\<lambda> a. \<exists> k < n. P k a) w \<longleftrightarrow> infs (\<lambda> a. \<exists> k \<in> {k. k < n}. P k a) w" by simp
    also have "\<dots> \<longleftrightarrow> (\<exists> k \<in> {k. k < n}. infs (P k) w)" by blast
    also have "\<dots> \<longleftrightarrow> (\<exists> k < n. infs (P k) w)" by simp
    finally show ?thesis by this
  qed

  lemma infs_cycle[iff]:
    assumes "w \<noteq> []"
    shows "infs P (cycle w) \<longleftrightarrow> Bex (set w) P"
  proof
    show "infs P (cycle w) \<Longrightarrow> Bex (set w) P"
      using assms by (auto simp: ev_holds_sset dest: alwD)
    show "Bex (set w) P \<Longrightarrow> infs P (cycle w)"
      using assms by (coinduction rule: infs_set_coinduct) (blast dest: cycle_decomp)
  qed

end


theory PreferenceLogicTestsApp2 imports PreferenceLogicBasics (*** Benzmüller & Fuenmayor, 2021 ***)
begin (*****Application-specific tests for the value ontology****)
 (* EE variant (\<and>)*)
lemma "\<lfloor>A \<^bold>\<preceq>\<^sub>E\<^sub>E (A\<^bold>\<and>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<and>B) \<^bold>\<preceq>\<^sub>E\<^sub>E A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<preceq>\<^sub>E\<^sub>E B) \<^bold>\<rightarrow> (A \<^bold>\<preceq>\<^sub>E\<^sub>E (C\<^bold>\<and>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<preceq>\<^sub>E\<^sub>E (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<^bold>\<preceq>\<^sub>E\<^sub>E B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<and>B) \<^bold>\<preceq>\<^sub>E\<^sub>E A) \<^bold>\<rightarrow> (B \<^bold>\<preceq>\<^sub>E\<^sub>E A)\<rfloor>" by blast
lemma "\<lfloor>(B \<^bold>\<preceq>\<^sub>E\<^sub>E A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<^bold>\<preceq>\<^sub>E\<^sub>E A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
 (* EE variant (\<or>)*)
lemma "\<lfloor>A \<^bold>\<preceq>\<^sub>E\<^sub>E (A\<^bold>\<or>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<or>B) \<^bold>\<preceq>\<^sub>E\<^sub>E A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<preceq>\<^sub>E\<^sub>E B) \<^bold>\<rightarrow> (A \<^bold>\<preceq>\<^sub>E\<^sub>E (C\<^bold>\<or>B))\<rfloor>" by blast
lemma "\<lfloor>(A \<^bold>\<preceq>\<^sub>E\<^sub>E (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<^bold>\<preceq>\<^sub>E\<^sub>E B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<or>B) \<^bold>\<preceq>\<^sub>E\<^sub>E A) \<^bold>\<rightarrow> (B \<^bold>\<preceq>\<^sub>E\<^sub>E A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<^bold>\<preceq>\<^sub>E\<^sub>E A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<^bold>\<preceq>\<^sub>E\<^sub>E A)\<rfloor>" by blast
 (* AE variant (\<and>)*)
lemma "\<lfloor>A \<^bold>\<preceq>\<^sub>A\<^sub>E (A\<^bold>\<and>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<and>B) \<^bold>\<preceq>\<^sub>A\<^sub>E A\<rfloor>" using rBR by blast (*change wrt. strict*)
lemma "\<lfloor>(A \<^bold>\<preceq>\<^sub>A\<^sub>E B) \<^bold>\<rightarrow> (A \<^bold>\<preceq>\<^sub>A\<^sub>E (C\<^bold>\<and>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<preceq>\<^sub>A\<^sub>E (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<^bold>\<preceq>\<^sub>A\<^sub>E B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<and>B) \<^bold>\<preceq>\<^sub>A\<^sub>E A) \<^bold>\<rightarrow> (B \<^bold>\<preceq>\<^sub>A\<^sub>E A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<^bold>\<preceq>\<^sub>A\<^sub>E A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<^bold>\<preceq>\<^sub>A\<^sub>E A)\<rfloor>" by blast
 (* AE variant (\<or>)*)
lemma "\<lfloor>A \<^bold>\<preceq>\<^sub>A\<^sub>E (A\<^bold>\<or>B)\<rfloor>" using rBR by blast (*change wrt. strict*)
lemma "\<lfloor>(A\<^bold>\<or>B) \<^bold>\<preceq>\<^sub>A\<^sub>E A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<preceq>\<^sub>A\<^sub>E B) \<^bold>\<rightarrow> (A \<^bold>\<preceq>\<^sub>A\<^sub>E (C\<^bold>\<or>B))\<rfloor>" by blast
lemma "\<lfloor>(A \<^bold>\<preceq>\<^sub>A\<^sub>E (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<^bold>\<preceq>\<^sub>A\<^sub>E B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<or>B) \<^bold>\<preceq>\<^sub>A\<^sub>E A) \<^bold>\<rightarrow> (B \<^bold>\<preceq>\<^sub>A\<^sub>E A)\<rfloor>" by blast
lemma "\<lfloor>(B \<^bold>\<preceq>\<^sub>A\<^sub>E A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<^bold>\<preceq>\<^sub>A\<^sub>E A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
 (* AA variant (\<and>)*)
lemma "\<lfloor>A \<^bold>\<preceq>\<^sub>A\<^sub>A (A\<^bold>\<and>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<and>B) \<^bold>\<preceq>\<^sub>A\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<preceq>\<^sub>A\<^sub>A B) \<^bold>\<rightarrow> (A \<^bold>\<preceq>\<^sub>A\<^sub>A (C\<^bold>\<and>B))\<rfloor>" by blast
lemma "\<lfloor>(A \<^bold>\<preceq>\<^sub>A\<^sub>A (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<^bold>\<preceq>\<^sub>A\<^sub>A B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<and>B) \<^bold>\<preceq>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> (B \<^bold>\<preceq>\<^sub>A\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<^bold>\<preceq>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<^bold>\<preceq>\<^sub>A\<^sub>A A)\<rfloor>" by blast
 (* AA variant (\<or>)*)
lemma "\<lfloor>A \<^bold>\<preceq>\<^sub>A\<^sub>A (A\<^bold>\<or>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<or>B) \<^bold>\<preceq>\<^sub>A\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<preceq>\<^sub>A\<^sub>A B) \<^bold>\<rightarrow> (A \<^bold>\<preceq>\<^sub>A\<^sub>A (C\<^bold>\<or>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<preceq>\<^sub>A\<^sub>A (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<^bold>\<preceq>\<^sub>A\<^sub>A B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<or>B) \<^bold>\<preceq>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> (B \<^bold>\<preceq>\<^sub>A\<^sub>A A)\<rfloor>" by blast
lemma "\<lfloor>(B \<^bold>\<preceq>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<^bold>\<preceq>\<^sub>A\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
 (* EA variant (\<and>)*)
lemma "\<lfloor>A \<^bold>\<preceq>\<^sub>E\<^sub>A (A\<^bold>\<and>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<and>B) \<^bold>\<preceq>\<^sub>E\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<preceq>\<^sub>E\<^sub>A B) \<^bold>\<rightarrow> (A \<^bold>\<preceq>\<^sub>E\<^sub>A (C\<^bold>\<and>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<preceq>\<^sub>E\<^sub>A (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<^bold>\<preceq>\<^sub>E\<^sub>A B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<and>B) \<^bold>\<preceq>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> (B \<^bold>\<preceq>\<^sub>E\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<^bold>\<preceq>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<^bold>\<preceq>\<^sub>E\<^sub>A A)\<rfloor>" by blast
 (* EA variant (\<or>)*)
lemma "\<lfloor>A \<^bold>\<preceq>\<^sub>E\<^sub>A (A\<^bold>\<or>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<or>B) \<^bold>\<preceq>\<^sub>E\<^sub>A A\<rfloor>"  nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<preceq>\<^sub>E\<^sub>A B) \<^bold>\<rightarrow> (A \<^bold>\<preceq>\<^sub>E\<^sub>A (C\<^bold>\<or>B))\<rfloor>" by blast
lemma "\<lfloor>(A \<^bold>\<preceq>\<^sub>E\<^sub>A (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<^bold>\<preceq>\<^sub>E\<^sub>A B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<or>B) \<^bold>\<preceq>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> (B \<^bold>\<preceq>\<^sub>E\<^sub>A A)\<rfloor>" by blast
lemma "\<lfloor>(B \<^bold>\<preceq>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<^bold>\<preceq>\<^sub>E\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
end

(*
(*--------------------------------------------------*)
lemma "\<lfloor>A \<preceq>\<^sub>A\<^sub>A (A\<^bold>\<and>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<and>B) \<preceq>\<^sub>A\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<preceq>\<^sub>A\<^sub>A B) \<^bold>\<rightarrow> (A \<preceq>\<^sub>A\<^sub>A (C\<^bold>\<and>B))\<rfloor>" by blast
lemma "\<lfloor>(A \<preceq>\<^sub>A\<^sub>A (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<preceq>\<^sub>A\<^sub>A B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<and>B) \<preceq>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> (B \<preceq>\<^sub>A\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<preceq>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<preceq>\<^sub>A\<^sub>A A)\<rfloor>" by blast

(*---------------------------------------------------*)
lemma "\<lfloor>A \<preceq>\<^sub>A\<^sub>A (A\<^bold>\<or>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<or>B) \<preceq>\<^sub>A\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<preceq>\<^sub>A\<^sub>A B) \<^bold>\<rightarrow> (A \<preceq>\<^sub>A\<^sub>A (C\<^bold>\<or>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<preceq>\<^sub>A\<^sub>A (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<preceq>\<^sub>A\<^sub>A B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<or>B) \<preceq>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> (B \<preceq>\<^sub>A\<^sub>A A)\<rfloor>" by blast
lemma "\<lfloor>(B \<preceq>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<preceq>\<^sub>A\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)

(*-------------------------------------------*)
lemma "\<lfloor>A \<preceq>\<^sub>E\<^sub>A (A\<^bold>\<and>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<and>B) \<preceq>\<^sub>E\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<preceq>\<^sub>E\<^sub>A B) \<^bold>\<rightarrow> (A \<preceq>\<^sub>E\<^sub>A (C\<^bold>\<and>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<preceq>\<^sub>E\<^sub>A (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<preceq>\<^sub>E\<^sub>A B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<and>B) \<preceq>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> (B \<preceq>\<^sub>E\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<preceq>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<preceq>\<^sub>E\<^sub>A A)\<rfloor>" by blast

(*------------------------------------------------*)
lemma "\<lfloor>A \<preceq>\<^sub>E\<^sub>A (A\<^bold>\<or>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<or>B) \<preceq>\<^sub>E\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<preceq>\<^sub>E\<^sub>A B) \<^bold>\<rightarrow> (A \<preceq>\<^sub>E\<^sub>A (C\<^bold>\<or>B))\<rfloor>" by blast
lemma "\<lfloor>(A \<preceq>\<^sub>E\<^sub>A (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<preceq>\<^sub>E\<^sub>A B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<or>B) \<preceq>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> (B \<preceq>\<^sub>E\<^sub>A A)\<rfloor>" by blast
lemma "\<lfloor>(B \<preceq>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<preceq>\<^sub>E\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
*)


theory mutilated_ideal
imports "Main"

begin

definition chessboard :: "(nat \<times> nat) set" where
  "chessboard = {..7} \<times> {..7}"

definition mchessboard :: "(nat \<times> nat) set" where
  "mchessboard = chessboard - {(0, 0), (7, 7)}"

datatype domino =
  horizontal "nat \<times> nat"
| vertical   "nat \<times> nat"

fun covers :: "domino \<Rightarrow> (nat \<times> nat) set" where
  "covers (horizontal (i, j)) = {(i, j), (i+1, j)}"
| "covers (vertical (i, j)) = {(i, j), (i, j+1)}"

definition white :: "(nat \<times> nat) set" where
  "white = {p. even (fst p + snd p)}"

definition flip :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat)" where
  "flip p = (7 - fst p, snd p)"

theorem mutilated_chessboard:
  fixes s :: "domino set"
  assumes h1: "\<forall> x \<in> s. \<forall> y \<in> s. x \<noteq> y \<longrightarrow> covers x \<inter> covers y = {}" and
          h1a: "finite s"
  shows "(\<Union> x \<in> s. covers x) \<noteq> mchessboard"
proof
  have "bij_betw flip (chessboard \<inter> white) (chessboard \<inter> -white)"
    sorry
  hence h2: "card (chessboard \<inter> white) = card (chessboard \<inter> -white)"
    sorry
  have "(0, 0) \<in> chessboard \<inter> white" and "(7, 7) \<in> chessboard \<inter> white"
    sorry
  with h2 have h3: "card (mchessboard \<inter> white) < card (mchessboard \<inter> -white)"
    sorry
  have "\<forall> x. card (covers x \<inter> white) = card (covers x \<inter> -white)"
    sorry
  with h1 have h4: "card ((\<Union> x \<in> s. covers x) \<inter> white) = card ((\<Union> x \<in> s. covers x) \<inter> -white)"
    sorry
  assume "(\<Union> x \<in> s. covers x) = mchessboard"
  with h3 h4 show False
    sorry
qed

end


(*  Title:       A Definitional Encoding of TLA in Isabelle/HOL
    Authors:     Gudmund Grov <ggrov at inf.ed.ac.uk>
                 Stephan Merz <Stephan.Merz at loria.fr>
    Year:        2011
    Maintainer:  Gudmund Grov <ggrov at inf.ed.ac.uk>
*)

section \<open>Semantics\<close>

theory Semantics
imports Sequence Intensional
begin

text \<open>
  This theory mechanises a \emph{shallow} embedding of \tlastar{} using the
  \<open>Sequence\<close> and \<open>Intensional\<close> theories. A shallow embedding
  represents \tlastar{} using Isabelle/HOL predicates, while a \emph{deep}
  embedding would represent \tlastar{} formulas and pre-formulas as mutually
  inductive datatypes\footnote{See e.g. \<^cite>\<open>"Wildmoser04"\<close> for a discussion
  about deep vs. shallow embeddings in Isabelle/HOL.}.
  The choice of a shallow over a deep embedding is motivated by the following
  factors: a shallow embedding is usually less involved, and existing Isabelle
  theories and tools can be applied more directly to enhance automation; due to
  the lifting in the \<open>Intensional\<close> theory, a shallow embedding can reuse
  standard logical operators, whilst a deep embedding requires a different
  set of operators for both formulas and pre-formulas. Finally, since our
  target is system verification rather than proving meta-properties of \tlastar{},
  which requires a deep embedding, a shallow embedding is more fit for purpose.
\<close>

subsection "Types of Formulas"

text \<open>
  To mechanise the \tlastar{} semantics, the following
  type abbreviations are used:
\<close>

type_synonym ('a,'b) formfun = "'a seq \<Rightarrow> 'b"
type_synonym 'a formula = "('a,bool) formfun"
type_synonym ('a,'b) stfun = "'a \<Rightarrow> 'b"
type_synonym 'a stpred = "('a,bool) stfun"

instance
 "fun" :: (type,type) world ..

instance
 "prod" :: (type,type) world ..

text \<open>
  Pair and function are instantiated to be of type class world.
  This allows use of the lifted intensional logic for formulas, and
  standard logical connectives can therefore be used.
\<close>

subsection "Semantics of TLA*"

text \<open>The semantics of \tlastar{} is defined.\<close>

definition always :: "('a::world) formula \<Rightarrow> 'a formula"
where "always F \<equiv> \<lambda> s. \<forall> n. (s |\<^sub>s n) \<Turnstile> F"

definition nexts :: "('a::world) formula \<Rightarrow> 'a formula"
where "nexts F \<equiv> \<lambda> s. (tail s) \<Turnstile> F"

definition before :: "('a::world,'b) stfun \<Rightarrow> ('a,'b) formfun"
where "before f \<equiv> \<lambda> s. (first s) \<Turnstile> f"

definition after :: "('a::world,'b) stfun \<Rightarrow> ('a,'b) formfun"
where "after f \<equiv> \<lambda> s. (second s) \<Turnstile> f"

definition unch  :: "('a::world,'b) stfun \<Rightarrow> 'a formula"
where "unch v \<equiv> \<lambda> s. s \<Turnstile> (after v) = (before v)"

definition action :: "('a::world) formula \<Rightarrow> ('a,'b) stfun \<Rightarrow> 'a formula"
where "action P v \<equiv> \<lambda> s. \<forall> i. ((s |\<^sub>s i) \<Turnstile> P) \<or> ((s |\<^sub>s i) \<Turnstile> unch v)"

subsubsection "Concrete Syntax"

text\<open>This is the concrete syntax for the (abstract) operators above.\<close>

syntax
 "_always" :: "lift \<Rightarrow> lift" ("(\<box>_)" [90] 90)
 "_nexts" :: "lift \<Rightarrow> lift" ("(\<circle>_)" [90] 90)
 "_action" :: "[lift,lift] \<Rightarrow> lift" ("(\<box>[_]'_(_))" [20,1000] 90)
 "_before"    :: "lift \<Rightarrow> lift"  ("($_)" [100] 99)
 "_after"     :: "lift \<Rightarrow> lift"  ("(_$)" [100] 99)
 "_prime"     :: "lift \<Rightarrow> lift"  ("(_`)" [100] 99)
 "_unch"     :: "lift \<Rightarrow> lift"  ("(Unchanged _)" [100] 99)
 "TEMP"  :: "lift \<Rightarrow> 'b" ("(TEMP _)")

syntax (ASCII)
 "_always" :: "lift \<Rightarrow> lift" ("([]_)" [90] 90)
 "_nexts" :: "lift \<Rightarrow> lift" ("(Next _)" [90] 90)
 "_action" :: "[lift,lift] \<Rightarrow> lift" ("([][_]'_(_))" [20,1000] 90)

translations
 "_always" \<rightleftharpoons> "CONST always"
 "_nexts" \<rightleftharpoons> "CONST nexts"
 "_action" \<rightleftharpoons> "CONST action"
 "_before"    \<rightleftharpoons> "CONST before"
 "_after"     \<rightleftharpoons> "CONST after"
 "_prime"     \<rightharpoonup> "CONST after"
 "_unch"     \<rightleftharpoons> "CONST unch"
 "TEMP F" \<rightharpoonup> "(F:: (nat \<Rightarrow> _) \<Rightarrow> _)"

subsection "Abbreviations"

text \<open>Some standard temporal abbreviations, with their concrete syntax.\<close>

definition actrans :: "('a::world) formula \<Rightarrow> ('a,'b) stfun \<Rightarrow> 'a formula"
where "actrans P v \<equiv> TEMP(P \<or> unch v)"

definition eventually :: "('a::world) formula \<Rightarrow> 'a formula"
where "eventually F \<equiv> LIFT(\<not>\<box>(\<not>F))"

definition angle_action :: "('a::world) formula \<Rightarrow> ('a,'b) stfun \<Rightarrow> 'a formula"
where "angle_action P v \<equiv> LIFT(\<not>\<box>[\<not>P]_v)"

definition angle_actrans :: "('a::world) formula \<Rightarrow> ('a,'b) stfun \<Rightarrow> 'a formula"
where "angle_actrans P v \<equiv> TEMP (\<not> actrans (LIFT(\<not>P)) v)"

definition leadsto :: "('a::world) formula \<Rightarrow> 'a formula \<Rightarrow> 'a formula"
where "leadsto P Q \<equiv> LIFT \<box>(P \<longrightarrow> eventually Q)"

subsubsection "Concrete Syntax"

syntax (ASCII)
  "_actrans" :: "[lift,lift] \<Rightarrow> lift" ("([_]'_(_))"  [20,1000] 90)
  "_eventually" :: "lift \<Rightarrow> lift" ("(<>_)" [90] 90)
  "_angle_action" :: "[lift,lift] \<Rightarrow> lift" ("(<><_>'_(_))" [20,1000] 90)
  "_angle_actrans" :: "[lift,lift] \<Rightarrow> lift" ("(<_>'_(_))" [20,1000] 90)
  "_leadsto" :: "[lift,lift] \<Rightarrow> lift" ("(_ ~> _)" [26,25] 25)

syntax
  "_eventually" :: "lift \<Rightarrow> lift" ("(\<diamond>_)" [90] 90)
  "_angle_action" :: "[lift,lift] \<Rightarrow> lift" ("(\<diamond>\<langle>_\<rangle>'_(_))" [20,1000] 90)
  "_angle_actrans" :: "[lift,lift] \<Rightarrow> lift" ("(\<langle>_\<rangle>'_(_))" [20,1000] 90)
  "_leadsto" :: "[lift,lift] \<Rightarrow> lift" ("(_ \<leadsto> _)" [26,25] 25)

translations
  "_actrans" \<rightleftharpoons> "CONST actrans"
  "_eventually" \<rightleftharpoons> "CONST eventually"
  "_angle_action" \<rightleftharpoons> "CONST angle_action"
  "_angle_actrans" \<rightleftharpoons> "CONST angle_actrans"
  "_leadsto" \<rightleftharpoons> "CONST leadsto"

subsection "Properties of Operators"

text \<open>The following lemmas show that these operators have the expected semantics.\<close>

lemma eventually_defs: "(w \<Turnstile> \<diamond> F) = (\<exists> n. (w |\<^sub>s n) \<Turnstile> F)"
  by (simp add: eventually_def always_def)

lemma angle_action_defs: "(w \<Turnstile> \<diamond>\<langle>P\<rangle>_v) = (\<exists> i. ((w |\<^sub>s i) \<Turnstile> P) \<and> ((w |\<^sub>s i) \<Turnstile> v$ \<noteq> $v))"
  by (simp add: angle_action_def action_def unch_def)

lemma unch_defs: "(w \<Turnstile> Unchanged v) = (((second w) \<Turnstile> v) = ((first w) \<Turnstile> v))"
  by (simp add: unch_def before_def nexts_def after_def tail_def suffix_def first_def second_def)

lemma linalw:
  assumes h1: "a \<le> b" and h2: "(w |\<^sub>s a) \<Turnstile> \<box>A"
  shows "(w |\<^sub>s b) \<Turnstile> \<box>A"
proof (clarsimp simp: always_def)
  fix n
  from h1 obtain k where g1: "b = a + k" by (auto simp: le_iff_add)
  with h2 show "(w |\<^sub>s b |\<^sub>s n) \<Turnstile> A" by (auto simp: always_def suffix_plus ac_simps)
qed

subsection "Invariance Under Stuttering"

text \<open>
  A key feature of \tlastar{} is that specification at different abstraction
  levels can be compared. The soundness of this relies on the stuttering invariance
  of formulas. Since the embedding is shallow, it cannot be shown that a generic
  \tlastar{} formula is stuttering invariant. However, this section will show that
  each operator is stuttering invariant or preserves stuttering invariance in an
  appropriate sense, which can be used to show stuttering invariance
  for given specifications.

  Formula \<open>F\<close> is stuttering invariant if for any two similar behaviours
  (i.e., sequences of states), \<open>F\<close> holds in one iff it holds in the other.
  The definition is generalised to arbitrary expressions, and not just predicates.
\<close>

definition stutinv :: "('a,'b) formfun \<Rightarrow> bool"
where "stutinv F \<equiv> \<forall> \<sigma> \<tau>. \<sigma> \<approx> \<tau> \<longrightarrow> (\<sigma> \<Turnstile> F) = (\<tau> \<Turnstile> F)"

text\<open>
  The requirement for stuttering invariance is too strong for pre-formulas.
  For example, an action formula specifies a relation between the first two states
  of a behaviour, and will rarely be satisfied by a stuttering step. This is why
  pre-formulas are ``protected'' by (square or angle) brackets in \tlastar{}:
  the only place a pre-formula \<open>P\<close> can be used is inside an action:
  \<open>\<box>[P]_v\<close>.
  To show that \<open>\<box>[P]_v\<close> is stuttering invariant, is must be shown that a
  slightly weaker predicate holds for @{term P}. For example, if @{term P} contains
  a term of the form \<open>\<circle>\<circle>Q\<close>, then it is not a well-formed pre-formula, thus
  \<open>\<box>[P]_v\<close> is not stuttering invariant. This weaker version of
  stuttering invariance has been named \emph{near stuttering invariance}.
\<close>

definition nstutinv :: "('a,'b) formfun \<Rightarrow> bool"
where "nstutinv P \<equiv> \<forall> \<sigma> \<tau>. (first \<sigma> = first \<tau>) \<and> (tail \<sigma>) \<approx> (tail \<tau>) \<longrightarrow> (\<sigma> \<Turnstile> P) = (\<tau> \<Turnstile> P)"

syntax
  "_stutinv" :: "lift \<Rightarrow> bool" ("(STUTINV _)" [40] 40)
  "_nstutinv" :: "lift \<Rightarrow> bool" ("(NSTUTINV _)" [40] 40)

translations
  "_stutinv" \<rightleftharpoons> "CONST stutinv"
  "_nstutinv" \<rightleftharpoons> "CONST nstutinv"

text \<open>
  Predicate @{term "stutinv F"} formalises stuttering invariance for
  formula @{term F}. That is if two sequences are similar @{term "s \<approx> t"} (equal up
  to stuttering) then the validity of @{term F} under both @{term s} and @{term t}
  are equivalent. Predicate @{term "nstutinv P"} should be read as \emph{nearly
  stuttering invariant} -- and is required for some stuttering invariance proofs.
\<close>

lemma stutinv_strictly_stronger:
  assumes h: "STUTINV F" shows "NSTUTINV F"
  unfolding nstutinv_def
proof (clarify)
  fix s t :: "nat \<Rightarrow> 'a"
  assume a1: "first s = first t" and a2: "(tail s) \<approx> (tail t)"
  have "s \<approx> t"
  proof -
    have tg1: "(first s) ## (tail s) = s" by (rule seq_app_first_tail)
    have tg2: "(first t) ## (tail t) = t" by (rule seq_app_first_tail)
    with a1 have tg2': "(first s) ## (tail t) = t" by simp
    from a2 have "(first s) ## (tail s) \<approx> (first s) ## (tail t)" by (rule app_seqsimilar)
    with tg1 tg2' show ?thesis by simp
  qed
  with h show "(s \<Turnstile> F) = (t \<Turnstile> F)" by (simp add: stutinv_def)
qed

subsubsection "Properties of @{term stutinv}"

text \<open>
  This subsection proves stuttering invariance, preservation of stuttering invariance
  and introduction of stuttering invariance for different formulas.
  First, state predicates are stuttering invariant.
\<close>

theorem stut_before: "STUTINV $F"
proof (clarsimp simp: stutinv_def)
  fix s t :: "'a seq"
  assume a1: "s \<approx> t"
  hence "(first s) = (first t)" by (rule sim_first)
  thus "(s \<Turnstile> $F) = (t \<Turnstile> $F)" by (simp add: before_def)
qed

lemma nstut_after: "NSTUTINV F$"
proof (clarsimp simp: nstutinv_def)
  fix s t :: "'a seq"
  assume a1: "tail s \<approx> tail t"
  thus "(s \<Turnstile> F$) = (t \<Turnstile> F$)" by (simp add: after_def tail_sim_second)
qed

text\<open>The always operator preserves stuttering invariance.\<close>

theorem stut_always: assumes H:"STUTINV F" shows "STUTINV \<box>F"
proof (clarsimp simp: stutinv_def)
  fix s t :: "'a seq"
  assume a2: "s \<approx> t"
  show "(s \<Turnstile> (\<box> F)) = (t \<Turnstile> (\<box> F))"
  proof
    assume a1: "t \<Turnstile> \<box> F"
    show "s \<Turnstile> \<box> F"
    proof (clarsimp simp: always_def)
      fix n
      from a2[THEN sim_step] obtain m where m: "s |\<^sub>s n \<approx> t |\<^sub>s m" by blast
      from a1 have "(t |\<^sub>s m) \<Turnstile> F" by (simp add: always_def)
      with H m show "(s |\<^sub>s n) \<Turnstile> F" by (simp add: stutinv_def)
    qed
  next
    assume a1: "s \<Turnstile> (\<box> F)"
    show "t \<Turnstile> (\<box> F)"
    proof (clarsimp simp: always_def)
      fix n
      from a2[THEN seqsim_sym, THEN sim_step] obtain m where m: "t |\<^sub>s n \<approx> s |\<^sub>s m" by blast
      from a1 have "(s |\<^sub>s m) \<Turnstile> F" by (simp add: always_def)
      with H m show "(t |\<^sub>s n) \<Turnstile> F" by (simp add: stutinv_def)
    qed
  qed
qed

text \<open>
  Assuming that formula @{term P} is nearly suttering invariant
  then \<open>\<box>[P]_v\<close> will be stuttering invariant.
\<close>

lemma stut_action_lemma:
  assumes H: "NSTUTINV P" and st: "s \<approx> t" and P: "t \<Turnstile> \<box>[P]_v"
  shows "s \<Turnstile> \<box>[P]_v"
proof (clarsimp simp: action_def)
  fix n
  assume "\<not> ((s |\<^sub>s n) \<Turnstile> Unchanged v)"
  hence v: "v (s (Suc n)) \<noteq> v (s n)"
    by (simp add: unch_defs first_def second_def suffix_def)
  from st[THEN sim_step] obtain m where
    a2': "s |\<^sub>s n \<approx> t |\<^sub>s m
          \<and> (s |\<^sub>s Suc n \<approx> t |\<^sub>s Suc m \<or> s |\<^sub>s Suc n \<approx> t |\<^sub>s m)" ..
  hence g1: "(s |\<^sub>s n \<approx> t |\<^sub>s m)" by simp
  hence g1'': "first (s |\<^sub>s n) = first (t |\<^sub>s m)" by (simp add: sim_first)
  hence g1': "s n = t m" by (simp add: suffix_def first_def)
  from a2' have g2: "s |\<^sub>s Suc n \<approx> t |\<^sub>s Suc m \<or> s |\<^sub>s Suc n \<approx> t |\<^sub>s m" by simp
  from P have a1': "((t |\<^sub>s m) \<Turnstile> P) \<or> ((t |\<^sub>s m) \<Turnstile> Unchanged v)" by (simp add: action_def)
  from g2 show "(s |\<^sub>s n) \<Turnstile> P"
  proof
    assume "s |\<^sub>s Suc n \<approx> t |\<^sub>s m"
    hence "first (s |\<^sub>s Suc n) = first (t |\<^sub>s m)" by (simp add: sim_first)
    hence "s (Suc n) = t m" by (simp add: suffix_def first_def)
    with g1' v show ?thesis by simp  \<comment> \<open>by contradiction\<close>
  next
    assume a3: "s |\<^sub>s Suc n \<approx> t |\<^sub>s Suc m"
    hence "first (s |\<^sub>s Suc n) = first (t |\<^sub>s Suc m)" by (simp add: sim_first)
    hence a3': "s (Suc n) = t (Suc m)" by (simp add: suffix_def first_def)
    from a1' show ?thesis
    proof
      assume "(t |\<^sub>s m) \<Turnstile> Unchanged v"
      hence "v (t (Suc m)) = v (t m)"
        by (simp add: unch_defs first_def second_def suffix_def)
      with g1' a3' v show ?thesis by simp  \<comment> \<open>again, by contradiction\<close>
    next
      assume a4: "(t |\<^sub>s m) \<Turnstile> P"
      from a3 have "tail (s |\<^sub>s n) \<approx> tail (t |\<^sub>s m)" by (simp add: tail_def suffix_plus)
      with H g1'' a4 show ?thesis by (auto simp: nstutinv_def)
    qed
  qed
qed

theorem stut_action: assumes H: "NSTUTINV P" shows "STUTINV \<box>[P]_v"
proof (clarsimp simp: stutinv_def)
  fix s t :: "'a seq"
  assume st: "s \<approx> t"
  show "(s \<Turnstile> \<box>[P]_v) = (t \<Turnstile> \<box>[P]_v)"
  proof
    assume "t \<Turnstile> \<box>[P]_v"
    with H st show "s \<Turnstile> \<box>[P]_v" by (rule stut_action_lemma)
  next
    assume "s \<Turnstile> \<box>[P]_v"
    with H st[THEN seqsim_sym] show "t \<Turnstile> \<box>[P]_v" by (rule stut_action_lemma)
  qed
qed

text \<open>
  The lemmas below shows that propositional and predicate operators
  preserve stuttering invariance.
\<close>

lemma stut_and: "\<lbrakk>STUTINV F;STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F \<and> G)"
  by (simp add: stutinv_def)

lemma stut_or: "\<lbrakk>STUTINV F;STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F \<or> G)"
  by (simp add: stutinv_def)

lemma stut_imp: "\<lbrakk>STUTINV F;STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F \<longrightarrow> G)"
  by (simp add: stutinv_def)

lemma stut_eq: "\<lbrakk>STUTINV F;STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F = G)"
  by (simp add: stutinv_def)

lemma stut_noteq: "\<lbrakk>STUTINV F;STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F \<noteq> G)"
  by (simp add: stutinv_def)

lemma stut_not: "STUTINV F \<Longrightarrow> STUTINV (\<not> F)"
  by (simp add: stutinv_def)

lemma stut_all: "(\<And>x. STUTINV (F x)) \<Longrightarrow> STUTINV (\<forall> x. F x)"
  by (simp add: stutinv_def)

lemma stut_ex: "(\<And>x. STUTINV (F x)) \<Longrightarrow> STUTINV (\<exists> x. F x)"
  by (simp add: stutinv_def)

lemma stut_const: "STUTINV #c"
  by (simp add: stutinv_def)

lemma stut_fun1: "STUTINV X \<Longrightarrow> STUTINV (f <X>)"
  by (simp add: stutinv_def)

lemma stut_fun2: "\<lbrakk>STUTINV X;STUTINV Y\<rbrakk> \<Longrightarrow> STUTINV (f <X,Y>)"
  by (simp add: stutinv_def)

lemma stut_fun3: "\<lbrakk>STUTINV X;STUTINV Y;STUTINV Z\<rbrakk> \<Longrightarrow> STUTINV (f <X,Y,Z>)"
  by (simp add: stutinv_def)

lemma stut_fun4: "\<lbrakk>STUTINV X;STUTINV Y;STUTINV Z; STUTINV W\<rbrakk> \<Longrightarrow> STUTINV (f <X,Y,Z,W>)"
  by (simp add: stutinv_def)

lemma stut_plus: "\<lbrakk>STUTINV x;STUTINV y\<rbrakk> \<Longrightarrow> STUTINV (x+y)"
  by (simp add: stutinv_def)

subsubsection "Properties of @{term nstutinv}"

text \<open>
  This subsection shows analogous properties about near stuttering
  invariance.

  If a formula @{term F} is stuttering invariant then \<open>\<circle>F\<close> is
  nearly stuttering invariant.
\<close>

lemma nstut_nexts: assumes H: "STUTINV F" shows "NSTUTINV \<circle>F"
using H by (simp add: stutinv_def nstutinv_def nexts_def)

text \<open>
  The lemmas below shows that propositional and predicate operators
  preserves near stuttering invariance.
\<close>

lemma nstut_and: "\<lbrakk>NSTUTINV F;NSTUTINV G\<rbrakk> \<Longrightarrow> NSTUTINV (F \<and> G)"
  by (auto simp: nstutinv_def)

lemma nstut_or: "\<lbrakk>NSTUTINV F;NSTUTINV G\<rbrakk> \<Longrightarrow> NSTUTINV (F \<or> G)"
  by (auto simp: nstutinv_def)

lemma nstut_imp: "\<lbrakk>NSTUTINV F;NSTUTINV G\<rbrakk> \<Longrightarrow> NSTUTINV (F \<longrightarrow> G)"
  by (auto simp: nstutinv_def)

lemma nstut_eq: "\<lbrakk>NSTUTINV F; NSTUTINV G\<rbrakk> \<Longrightarrow> NSTUTINV (F = G)"
  by (force simp: nstutinv_def)

lemma nstut_not: "NSTUTINV F \<Longrightarrow> NSTUTINV (\<not> F)"
  by (auto simp: nstutinv_def)

lemma nstut_noteq: "\<lbrakk>NSTUTINV F; NSTUTINV G\<rbrakk> \<Longrightarrow> NSTUTINV (F \<noteq> G)"
  by (simp add: nstut_eq nstut_not)

lemma nstut_all: "(\<And>x. NSTUTINV (F x)) \<Longrightarrow> NSTUTINV (\<forall> x. F x)"
  by (auto simp: nstutinv_def)

lemma nstut_ex: "(\<And>x. NSTUTINV (F x)) \<Longrightarrow> NSTUTINV (\<exists> x. F x)"
  by (auto simp: nstutinv_def)

lemma nstut_const: "NSTUTINV #c"
  by (auto simp: nstutinv_def)

lemma nstut_fun1: "NSTUTINV X \<Longrightarrow> NSTUTINV (f <X>)"
  by (force simp: nstutinv_def)

lemma nstut_fun2: "\<lbrakk>NSTUTINV X; NSTUTINV Y\<rbrakk> \<Longrightarrow> NSTUTINV (f <X,Y>)"
  by (force simp: nstutinv_def)

lemma nstut_fun3: "\<lbrakk>NSTUTINV X; NSTUTINV Y; NSTUTINV Z\<rbrakk> \<Longrightarrow> NSTUTINV (f <X,Y,Z>)"
  by (force simp: nstutinv_def)

lemma nstut_fun4: "\<lbrakk>NSTUTINV X; NSTUTINV Y; NSTUTINV Z; NSTUTINV W\<rbrakk> \<Longrightarrow> NSTUTINV (f <X,Y,Z,W>)"
  by (force simp: nstutinv_def)

lemma nstut_plus: "\<lbrakk>NSTUTINV x;NSTUTINV y\<rbrakk> \<Longrightarrow> NSTUTINV (x+y)"
  by (simp add: nstut_fun2)

subsubsection "Abbreviations"

text \<open>
  We show the obvious fact that the same properties holds for abbreviated
  operators.
\<close>

lemmas nstut_before = stut_before[THEN stutinv_strictly_stronger]

lemma nstut_unch: "NSTUTINV (Unchanged v)"
proof (unfold unch_def)
  have g1: "NSTUTINV v$" by (rule nstut_after)
  have "NSTUTINV $v" by (rule stut_before[THEN stutinv_strictly_stronger])
  with g1 show "NSTUTINV (v$ = $v)" by (rule nstut_eq)
qed

text\<open>
  Formulas \<open>[P]_v\<close> are not \tlastar{} formulas by themselves,
  but we need to reason about them when they appear wrapped
  inside \<open>\<box>[-]_v\<close>. We only require that it preserves nearly
  stuttering invariance. Observe that \<open>[P]_v\<close> trivially holds for
  a stuttering step, so it cannot be stuttering invariant.
\<close>

lemma nstut_actrans: "NSTUTINV P \<Longrightarrow> NSTUTINV [P]_v"
  by (simp add: actrans_def nstut_unch nstut_or)

lemma stut_eventually: "STUTINV F \<Longrightarrow> STUTINV \<diamond>F"
  by (simp add: eventually_def stut_not stut_always)

lemma stut_leadsto: "\<lbrakk>STUTINV F; STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F \<leadsto> G)"
  by (simp add: leadsto_def stut_always stut_eventually stut_imp)

lemma stut_angle_action: "NSTUTINV P \<Longrightarrow> STUTINV \<diamond>\<langle>P\<rangle>_v"
  by (simp add: angle_action_def nstut_not stut_action stut_not)

lemma nstut_angle_acttrans: "NSTUTINV P \<Longrightarrow> NSTUTINV \<langle>P\<rangle>_v"
  by (simp add: angle_actrans_def nstut_not nstut_actrans)

lemmas stutinvs = stut_before stut_always stut_action
  stut_and stut_or stut_imp stut_eq stut_noteq stut_not
  stut_all stut_ex stut_eventually stut_leadsto stut_angle_action stut_const
  stut_fun1 stut_fun2 stut_fun3 stut_fun4

lemmas nstutinvs =  nstut_after nstut_nexts nstut_actrans
  nstut_unch nstut_and nstut_or nstut_imp nstut_eq nstut_noteq nstut_not
  nstut_all nstut_ex nstut_angle_acttrans stutinv_strictly_stronger
  nstut_fun1 nstut_fun2 nstut_fun3 nstut_fun4 stutinvs[THEN stutinv_strictly_stronger]

lemmas bothstutinvs = stutinvs nstutinvs

end


(*  Author:     Bernhard Haeupler *)

section \<open>Some examples demonstrating the comm-ring method\<close>

theory Commutative_Ring_Ex
imports "../Commutative_Ring"
begin

lemma "4*(x::int)^5*y^3*x^2*3 + x*z + 3^5 = 12*x^7*y^3 + z*x + 243"
  by comm_ring

lemma "((x::int) + y)^2  = x^2 + y^2 + 2*x*y"
  by comm_ring

lemma "((x::int) + y)^3  = x^3 + y^3 + 3*x^2*y + 3*y^2*x"
  by comm_ring

lemma "((x::int) - y)^3  = x^3 + 3*x*y^2 + (-3)*y*x^2 - y^3"
  by comm_ring

lemma "((x::int) - y)^2  = x^2 + y^2 - 2*x*y"
  by comm_ring

lemma " ((a::int) + b + c)^2 = a^2 + b^2 + c^2 + 2*a*b + 2*b*c + 2*a*c"
  by comm_ring

lemma "((a::int) - b - c)^2 = a^2 + b^2 + c^2 - 2*a*b + 2*b*c - 2*a*c"
  by comm_ring

lemma "(a::int)*b + a*c = a*(b+c)"
  by comm_ring

lemma "(a::int)^2 - b^2 = (a - b) * (a + b)"
  by comm_ring

lemma "(a::int)^3 - b^3 = (a - b) * (a^2 + a*b + b^2)"
  by comm_ring

lemma "(a::int)^3 + b^3 = (a + b) * (a^2 - a*b + b^2)"
  by comm_ring

lemma "(a::int)^4 - b^4 = (a - b) * (a + b)*(a^2 + b^2)"
  by comm_ring

lemma "(a::int)^10 - b^10 =
  (a - b) * (a^9 + a^8*b + a^7*b^2 + a^6*b^3 + a^5*b^4 + a^4*b^5 + a^3*b^6 + a^2*b^7 + a*b^8 + b^9)"
  by comm_ring

end