theory Stream_More
imports
  Transition_Systems_and_Automata.Sequence_LTL
  Instantiate_Existentials
  "HOL-Library.Rewrite"
begin

lemma list_all_stake_least:
  "list_all (Not \<circ> P) (stake (LEAST n. P (xs !! n)) xs)" (is "?G") if "\<exists> n. P (xs !! n)"
proof (rule ccontr)
  let ?n = "LEAST n. P (xs !! n)"
  assume "\<not> ?G"
  then have "\<exists> x \<in> set (stake ?n xs). P x" unfolding list_all_iff by auto
  then obtain n' where "n' < ?n" "P (xs !! n')" using set_stake_snth by metis
  with Least_le[of "\<lambda> n. P (xs !! n)" n'] show False by auto
qed

lemma alw_stream_all2_mono:
  assumes "stream_all2 P xs ys" "alw Q xs" "\<And> xs ys. stream_all2 P xs ys \<Longrightarrow> Q xs \<Longrightarrow> R ys"
  shows "alw R ys"
  using assms stream.rel_sel by (coinduction arbitrary: xs ys) (blast)

lemma alw_ev_HLD_cycle:
  assumes "stream_all2 (\<in>) xs (cycle as)" "a \<in> set as"
  shows "infs (\<lambda>x. x \<in> a) xs"
using assms(1)
proof (coinduct rule: infs_set_coinduct)
  case (infs_set xs)
  have 1: "as \<noteq> []" using assms(2) by auto
  have 2:
    "list_all2 (\<in>) (stake (length as) xs) (stake (length as) (cycle as))"
    "stream_all2 (\<in>) (sdrop (length as) xs) (sdrop (length as) (cycle as))"
    using infs_set stream_rel_shift stake_sdrop length_stake by metis+
  have 3: "stake (length as) (cycle as) = as" using 1 by simp
  have 4: "sdrop (length as) (cycle as) = cycle as" using sdrop_cycle_eq 1 by this
  have 5: "set (stake (length as) xs) \<inter> a \<noteq> {}"
    using assms(2) 2(1) unfolding list.in_rel 3
    by (auto) (metis IntI empty_iff mem_Collect_eq set_zip_leftD split_conv subsetCE zip_map_fst_snd)
  show ?case using 2 5 unfolding 4
    by force
qed

lemma alw_ev_mono:
  assumes "alw (ev \<phi>) xs" and "\<And> xs. \<phi> xs \<Longrightarrow> \<psi> xs"
  shows "alw (ev \<psi>) xs"
  by (rule alw_mp[OF assms(1)]) (auto intro: ev_mono assms(2) simp: alw_iff_sdrop)

lemma alw_ev_lockstep:
  assumes
    "alw (ev (holds P)) xs" "stream_all2 Q xs as"
    "\<And> x a. P x \<Longrightarrow> Q x a \<Longrightarrow> R a"
  shows
    "alw (ev (holds R)) as"
  using assms(1,2)
  apply (coinduction arbitrary: xs as rule: alw.coinduct)
  apply auto
  subgoal
    by (metis alw.cases assms(3) ev_holds_sset stream_all2_sset1)
  subgoal
    by (meson alw.cases stream.rel_sel)
  done

subsection \<open>sfilter, wait, nxt\<close>

text \<open>Useful?\<close>
lemma nxt_holds_iff_snth: "(nxt ^^ i) (holds P) xs \<longleftrightarrow> P (xs !! i)"
  by (induction i arbitrary: xs; simp add: holds.simps)

text \<open>Useful?\<close>
lemma wait_LEAST:
  "wait (holds P) xs = (LEAST n. P (xs !! n))" unfolding wait_def nxt_holds_iff_snth ..

lemma sfilter_SCons_decomp:
  assumes "sfilter P xs = x ## zs" "ev (holds P) xs"
  shows "\<exists> ys' zs'. xs = ys' @- x ## zs' \<and> list_all (Not o P) ys' \<and> P x \<and> sfilter P zs' = zs"
proof -
  note [simp] = holds.simps
  from ev_imp_shift[OF assms(2)] obtain as bs where "xs = as @- bs" "holds P bs"
    by auto
  then have "P (shd bs)" by auto
  with \<open>xs = _\<close> have "\<exists> n. P (xs !! n)" using assms(2) sdrop_wait by fastforce
  from sdrop_while_sdrop_LEAST[OF this] have *:
    "sdrop_while (Not \<circ> P) xs = sdrop (LEAST n. P (xs !! n)) xs" .
  let ?xs = "sdrop_while (Not \<circ> P) xs" let ?n = "LEAST n. P (xs !! n)"
  from assms(1) have "x = shd ?xs" "zs = sfilter P (stl ?xs)"
    by (subst (asm) sfilter.ctr; simp)+
  have "xs = stake ?n xs @- sdrop ?n xs" by simp
  moreover have "P x" using assms(1) unfolding sfilter_eq[OF assms(2)] ..
  moreover from \<open>\<exists> n. P _\<close> have "list_all (Not o P) (stake ?n xs)" by (rule list_all_stake_least)
  ultimately show ?thesis
    using \<open>x = _\<close> \<open>zs = _\<close> *[symmetric] by (inst_existentials "stake ?n xs" "stl ?xs") auto
qed

lemma sfilter_SCons_decomp':
  assumes "sfilter P xs = x ## zs" "ev (holds P) xs"
  shows
    "list_all (Not o P) (stake (wait (holds P) xs) xs)" (is "?G1")
    "P x"
    "\<exists> zs'. xs = stake (wait (holds P) xs) xs @- x ## zs' \<and> sfilter P zs' = zs" (is "?G2")
proof -
  note [simp] = holds.simps
  from ev_imp_shift[OF assms(2)] obtain as bs where "xs = as @- bs" "holds P bs"
    by auto
  then have "P (shd bs)" by auto
  with \<open>xs = _\<close> have "\<exists> n. P (xs !! n)" using assms(2) sdrop_wait by fastforce thm sdrop_wait
  from sdrop_while_sdrop_LEAST[OF this] have *:
    "sdrop_while (Not \<circ> P) xs = sdrop (LEAST n. P (xs !! n)) xs" .
  let ?xs = "sdrop_while (Not \<circ> P) xs" let ?n = "wait (holds P) xs"
  from assms(1) have "x = shd ?xs" "zs = sfilter P (stl ?xs)"
    by (subst (asm) sfilter.ctr; simp)+
  have "xs = stake ?n xs @- sdrop ?n xs" by simp
  moreover show "P x" using assms(1) unfolding sfilter_eq[OF assms(2)] ..
  moreover from \<open>\<exists> n. P _\<close> show "list_all (Not o P) (stake ?n xs)"
    by (auto intro: list_all_stake_least simp: wait_LEAST)
  ultimately show ?G2
    using \<open>x = _\<close> \<open>zs = _\<close> *[symmetric] by (inst_existentials "stl ?xs") (auto simp: wait_LEAST)
qed

lemma sfilter_shift_decomp:
  assumes "sfilter P xs = ys @- zs" "alw (ev (holds P)) xs"
  shows "\<exists> ys' zs'. xs = ys' @- zs' \<and> filter P ys' = ys \<and> sfilter P zs' = zs"
  using assms(1,2)
proof (induction ys arbitrary: xs)
  case Nil
  then show ?case by (inst_existentials "[] :: 'a list" xs; simp)
next
  case (Cons y ys)
  from alw_ev_imp_ev_alw[OF \<open>alw (ev _) xs\<close>] have "ev (holds P) xs"
    by (auto elim: ev_mono)
  with Cons.prems(1) sfilter_SCons_decomp[of P xs y "ys @- zs"] guess ys' zs' by clarsimp
  note guessed = this
  then have "sfilter P zs' = ys @- zs" by auto
  from \<open>alw (ev _) xs\<close> \<open>xs = _\<close> have "alw (ev (holds P)) zs'"
    by (metis ev.intros(2) ev_shift not_alw_iff stream.sel(2))
  from Cons.IH[OF \<open>sfilter P zs' = _\<close> this] guess zs1 zs2 by clarsimp
  with guessed show ?case
    by (inst_existentials "ys' @ y # zs1" zs2; simp add: list.pred_set)
qed

lemma finite_sset_sfilter_decomp:
  assumes "finite (sset (sfilter P xs))" "alw (ev (holds P)) xs"
  obtains x ws ys zs where "xs = ws @- x ## ys @- x ## zs" "P x"
proof atomize_elim
  let ?xs = "sfilter P xs"
  have 1: "\<not> sdistinct (sfilter P xs)" using sdistinct_infinite_sset assms(1) by auto
  from not_sdistinct_decomp[OF 1] guess ws ys x zs .
  note guessed1 = this
  from sfilter_shift_decomp[OF this assms(2)] guess ys' zs' by clarsimp
  note guessed2 = this
  then have "ev (holds P) zs'" using alw_shift assms(2) by blast
  from sfilter_SCons_decomp[OF guessed2(2) this] guess zs1 zs2 by clarsimp
  note guessed3 = this
  have "alw (ev (holds P)) zs2"
    by (metis alw_ev_stl alw_shift assms(2) guessed2(1) guessed3(1) stream.sel(2))
  from sfilter_shift_decomp[OF guessed3(4) this] guess zs3 zs4 by clarsimp
  note guessed4 = this
  have "ev (holds P) zs4"
    using \<open>alw (ev (holds P)) zs2\<close> alw_shift guessed4(1) by blast
  from sfilter_SCons_decomp[OF guessed4(2) this] guess zs5 zs6 by clarsimp
  with guessed1 guessed2 guessed3 guessed4 show "\<exists>ws x ys zs. xs = ws @- x ## ys @- x ## zs \<and> P x"
    by (inst_existentials "ys' @ zs1" x "zs3 @ zs5" zs6; simp)
qed

text \<open>Useful?\<close>
lemma sfilter_shd_LEAST:
  "shd (sfilter P xs) = xs !! (LEAST n. P (xs !! n))" if "ev (holds P) xs"
proof -
  note [simp] = holds.simps
  from sdrop_wait[OF \<open>ev _ xs\<close>] have "\<exists> n. P (xs !! n)" by auto
  from sdrop_while_sdrop_LEAST[OF this] show ?thesis by simp
qed

lemma alw_nxt_holds_cong:
  "(nxt ^^ n) (holds (\<lambda>x. P x \<and> Q x)) xs = (nxt ^^ n) (holds Q) xs" if "alw (holds P) xs"
  using that unfolding nxt_holds_iff_snth alw_iff_sdrop by (simp add: holds.simps)

lemma alw_wait_holds_cong:
  "wait (holds (\<lambda>x. P x \<and> Q x)) xs = wait (holds Q) xs" if "alw (holds P) xs"
  unfolding wait_def alw_nxt_holds_cong[OF that] ..

lemma alw_sfilter:
  "sfilter (\<lambda> x. P x \<and> Q x) xs = sfilter Q xs" if "alw (holds P) xs" "alw (ev (holds Q)) xs"
  using that
proof (coinduction arbitrary: xs)
  case prems: stream_eq
  note [simp] = holds.simps
  from prems(3,4) have ev_one: "ev (holds (\<lambda>x. P x \<and> Q x)) xs"
    by (subst ev_cong[of _ _ _ "holds Q"]) (assumption | auto)+
  from prems have "a = shd (sfilter (\<lambda>x. P x \<and> Q x) xs)" "b = shd (sfilter Q xs)"
    by (metis stream.sel(1))+
  with prems(3,4) have
    "a = xs !! (LEAST n. P (xs !! n) \<and> Q (xs !! n))" "b = xs !! (LEAST n. Q (xs !! n))"
    using ev_one by (auto 4 3 dest: sfilter_shd_LEAST)
  with alw_wait_holds_cong[unfolded wait_LEAST, OF \<open>alw (holds P) xs\<close>] have "a = b" by simp
  from sfilter_SCons_decomp'[OF prems(1)[symmetric], OF ev_one] guess u2 by clarsimp
  note guessed_a = this
  have "ev (holds Q) xs" using prems(4) by blast
  from sfilter_SCons_decomp'[OF prems(2)[symmetric], OF this] guess v2 by clarsimp
  with guessed_a \<open>a = b\<close> show ?case
    apply (intro conjI exI)
        apply assumption+
      apply (simp add: alw_wait_holds_cong[OF prems(3)], metis shift_left_inj stream.inject)
    by (metis alw.cases alw_shift prems(3,4) stream.sel(2))+
qed

lemma alw_ev_holds_mp:
  "alw (holds P) xs \<Longrightarrow> ev (holds Q) xs \<Longrightarrow> ev (holds (\<lambda>x. P x \<and> Q x)) xs"
  by (subst ev_cong, assumption) (auto simp: holds.simps)

lemma alw_ev_conjI:
  "alw (ev (holds (\<lambda> x. P x \<and> Q x))) xs" if "alw (holds P) xs" "alw (ev (holds Q)) xs"
  using that(2,1) by - (erule alw_mp, coinduction arbitrary: xs, auto intro: alw_ev_holds_mp)

subsection \<open>Useful?\<close>

lemma alw_holds_pred_stream_iff:
  "alw (holds P) xs \<longleftrightarrow> pred_stream P xs"
  by (simp add: alw_iff_sdrop stream_pred_snth holds.simps)

lemma alw_holds_sset:
  "alw (holds P) xs = (\<forall> x \<in> sset xs. P x)"
  by (simp add: alw_holds_pred_stream_iff stream.pred_set)

lemma pred_stream_sfilter:
  assumes alw_ev: "alw (ev (holds P)) xs"
  shows "pred_stream P (sfilter P xs)"
  using alw_ev
proof (coinduction arbitrary: xs)
  case (stream_pred xs)
  then have "ev (holds P) xs" by auto
  have "sfilter P xs = shd (sfilter P xs) ## stl (sfilter P xs)"
    by (cases "sfilter P xs") auto
  from sfilter_SCons_decomp[OF this \<open>ev (holds P) xs\<close>] guess ys' zs' by clarsimp
  then show ?case
    apply (inst_existentials zs')
    apply (metis sfilter.simps(1) stream.sel(1) stream_pred(1))
    apply (metis scons_eq sfilter.simps(2) stream_pred(1))
    apply (metis alw_ev_stl alw_shift stream.sel(2) stream_pred(2))
    done
qed

lemma alw_ev_sfilter_mono:
  assumes alw_ev: "alw (ev (holds P)) xs"
    and mono: "\<And> x. P x \<Longrightarrow> Q x"
  shows "pred_stream Q (sfilter P xs)"
  using stream.pred_mono[of P Q] assms pred_stream_sfilter by blast

lemma sset_sfilter:
  "sset (sfilter P xs) \<subseteq> sset xs" if "alw (ev (holds P)) xs"
proof -
  have "alw (holds (\<lambda> x. x \<in> sset xs)) xs" by (simp add: alw_iff_sdrop holds.simps)
  with \<open>alw (ev _) _\<close> alw_sfilter[OF this \<open>alw (ev _) _\<close>, symmetric]
    have "pred_stream (\<lambda> x. x \<in> sset xs) (sfilter P xs)"
    by (simp) (rule alw_ev_sfilter_mono; auto intro: alw_ev_conjI)
  then have "\<forall> x \<in> sset (sfilter P xs). x \<in> sset xs" unfolding stream.pred_set by this
  then show ?thesis by blast
qed

lemma stream_all2_weaken:
  "stream_all2 Q xs ys" if "stream_all2 P xs ys" "\<And> x y. P x y \<Longrightarrow> Q x y"
  using that by (coinduction arbitrary: xs ys) auto

lemma stream_all2_SCons1:
  "stream_all2 P (x ## xs) ys = (\<exists>z zs. ys = z ## zs \<and> P x z \<and> stream_all2 P xs zs)"
  by (subst (3) stream.collapse[symmetric], simp del: stream.collapse, force)

lemma stream_all2_SCons2:
  "stream_all2 P xs (y ## ys) = (\<exists>z zs. xs = z ## zs \<and> P z y \<and> stream_all2 P zs ys)"
  by (subst stream.collapse[symmetric], simp del: stream.collapse, force)

lemma stream_all2_combine:
  "stream_all2 R xs zs" if
  "stream_all2 P xs ys" "stream_all2 Q ys zs" "\<And> x y z. P x y \<and> Q y z \<Longrightarrow> R x z"
  using that(1,2)
  by (coinduction arbitrary: xs ys zs)
     (auto intro: that(3) simp: stream_all2_SCons1 stream_all2_SCons2)

lemma stream_all2_shift1:
  "stream_all2 P (xs1 @- xs2) ys =
  (\<exists> ys1 ys2. ys = ys1 @- ys2 \<and> list_all2 P xs1 ys1 \<and> stream_all2 P xs2 ys2)"
  apply (induction xs1 arbitrary: ys)
   apply (simp; fail)
  apply (simp add: stream_all2_SCons1 list_all2_Cons1)
  apply safe
  subgoal for a xs1 ys z zs ys1 ys2
    by (inst_existentials "z # ys1" ys2; simp)
  subgoal for a xs1 ys ys1 ys2 z zs
    by (inst_existentials z "zs @- ys2" zs "ys2"; simp)
  done

lemma stream_all2_shift2:
  "stream_all2 P ys (xs1 @- xs2) =
  (\<exists> ys1 ys2. ys = ys1 @- ys2 \<and> list_all2 P ys1 xs1 \<and> stream_all2 P ys2 xs2)"
  by (meson list.rel_flip stream.rel_flip stream_all2_shift1)

lemma stream_all2_bisim:
  assumes "stream_all2 (\<in>) xs as" "stream_all2 (\<in>) ys as" "sset as \<subseteq> S"
  shows "stream_all2 (\<lambda> x y. \<exists> a. x \<in> a \<and> y \<in> a \<and> a \<in> S) xs ys"
  using assms
  apply (coinduction arbitrary: as xs ys)
  subgoal for a u b v as xs ys
    apply (rule conjI)
     apply (inst_existentials "shd as", auto simp: stream_all2_SCons1; fail)
    apply (inst_existentials "stl as", auto 4 3 simp: stream_all2_SCons1; fail)
    done
  done

end


theory ShortestPath
  imports
  "../Graph_Theory/Graph_Theory"
begin

section \<open>Shortest Path (with non-negative edge costs)\<close>
text\<open>The following theory is used in the verification of a certifying algorithm's checker for shortest path. For more information see \cite{FrameworkVerificationofCertifyingComputations}.\<close>

locale basic_sp =
  fin_digraph +
  fixes dist :: "'a \<Rightarrow> ereal"
  fixes c :: "'b \<Rightarrow> real"
  fixes s :: "'a"
  assumes s_in_G: "s \<in> verts G"
  assumes general_source_val: "dist s \<le> 0"
  assumes trian:
    "\<And>e. e \<in> arcs G \<Longrightarrow>
      dist (head G e) \<le> dist (tail G e) + c e"

locale basic_just_sp =
  basic_sp +
  fixes num :: "'a \<Rightarrow> enat"
  assumes just:
    "\<And>v. \<lbrakk>v \<in> verts G; v \<noteq> s; num v \<noteq> \<infinity>\<rbrakk> \<Longrightarrow>
      \<exists> e \<in> arcs G. v = head G e \<and>
        dist v = dist (tail G e) + c e  \<and>
        num v = num (tail G e) + (enat 1)"

locale shortest_path_pos_cost =
  basic_just_sp +
  assumes tail_val: "dist s = 0"
  assumes no_path: "\<And>v. v \<in> verts G \<Longrightarrow> dist v = \<infinity> \<longleftrightarrow> num v = \<infinity>"
  assumes pos_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"

locale basic_just_sp_pred =
  basic_sp +
  fixes num :: "'a \<Rightarrow> enat"
  fixes pred :: "'a \<Rightarrow> 'b option"
  assumes just:
    "\<And>v. \<lbrakk>v \<in> verts G; v \<noteq> s; num v \<noteq> \<infinity>\<rbrakk> \<Longrightarrow>
      \<exists> e \<in> arcs G.
        pred v = Some e \<and>
        v = head G e \<and>
        dist v = dist (tail G e) + c e  \<and>
        num v = num (tail G e) + (enat 1)"

sublocale basic_just_sp_pred \<subseteq> basic_just_sp
using basic_just_sp_pred_axioms
unfolding basic_just_sp_pred_def
   basic_just_sp_pred_axioms_def
by unfold_locales (blast)

locale shortest_path_pos_cost_pred =
  basic_just_sp_pred +
  assumes tail_val: "dist s = 0"
  assumes no_path: "\<And>v. v \<in> verts G \<Longrightarrow> dist v = \<infinity> \<longleftrightarrow> num v = \<infinity>"
  assumes pos_cost: "\<And>e. e \<in> arcs G \<Longrightarrow> 0 \<le> c e"

sublocale shortest_path_pos_cost_pred \<subseteq> shortest_path_pos_cost
  using shortest_path_pos_cost_pred_axioms
  by unfold_locales
   (auto simp: shortest_path_pos_cost_pred_def basic_just_sp_pred_def
   shortest_path_pos_cost_pred_axioms_def basic_sp_def basic_sp_axioms_def)

lemma tail_value_helper:
  assumes "hd p = last p"
  assumes "distinct p"
  assumes "p \<noteq> []"
  shows "p = [hd p]"
  by (metis assms distinct.simps(2) list.sel(1) neq_Nil_conv last_ConsR last_in_set)

lemma (in basic_sp) dist_le_cost:
  fixes v :: 'a
  fixes p :: "'b list"
  assumes "awalk s p v"
  shows "dist v \<le> awalk_cost c p"
  using assms
  proof (induct "length p" arbitrary: p v)
  case 0
    hence "s = v" by auto
    thus ?case using 0(1) general_source_val
      by (metis awalk_cost_Nil length_0_conv zero_ereal_def)
  next
  case (Suc n)
    then obtain p' e where p'e: "p = p' @ [e]"
      by (cases p rule: rev_cases) auto
    then obtain u where ewu: "awalk s p' u \<and> awalk u [e] v"
      using awalk_append_iff Suc(3) by simp
    then have du: "dist u \<le> ereal (awalk_cost c p')"
      using Suc p'e by simp
    from ewu have ust: "u = tail G e" and vta: "v = head G e"
      by auto
    then have "dist v \<le> dist u + c e"
      using ewu du ust trian[where e=e] by force
    with du have "dist v \<le> ereal (awalk_cost c p') + c e"
      by (metis add_right_mono order_trans)
    thus "dist v \<le> awalk_cost c p"
      using awalk_cost_append p'e by simp
  qed

lemma (in fin_digraph) witness_path:
  assumes "\<mu> c s v = ereal r"
  shows "\<exists> p. apath s p v \<and> \<mu> c s v = awalk_cost c p"
proof -
  have sv: "s \<rightarrow>\<^sup>* v"
    using shortest_path_inf[of s v c] assms by fastforce
  {
    fix p assume "awalk s p v"
    then have no_neg_cyc:
    "\<not> (\<exists>w q. awalk w q w \<and> w \<in> set (awalk_verts s p) \<and> awalk_cost c q < 0)"
      using neg_cycle_imp_inf_\<mu> assms by force
  }
  thus ?thesis using no_neg_cyc_reach_imp_path[OF sv] by presburger
qed

lemma (in basic_sp)  dist_le_\<mu>:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v \<le> \<mu> c s v"
proof (rule ccontr)
  assume nt: "\<not> ?thesis"
  show False
  proof (cases "\<mu> c s v")
    show "\<And>r. \<mu> c s v = ereal r \<Longrightarrow> False"
    proof -
      fix r assume r_asm: "\<mu> c s v = ereal r"
      hence sv: "s \<rightarrow>\<^sup>* v"
        using shortest_path_inf[where u=s and v=v and f=c] by auto
      obtain p where
        "awalk s p v"
        "\<mu> c s v = awalk_cost c p"
        using witness_path[OF r_asm] unfolding apath_def by force
      thus False using nt dist_le_cost by simp
    qed
  next
    show "\<mu> c s v = \<infinity> \<Longrightarrow> False" using nt by simp
  next
    show "\<mu> c s v = - \<infinity> \<Longrightarrow> False" using dist_le_cost
    proof -
      assume asm: "\<mu> c s v = - \<infinity>"
      let ?C = "(\<lambda>x. ereal (awalk_cost c x)) ` {p. awalk s p v}"
      have "\<exists>x\<in> ?C. x < dist v"
        using nt unfolding \<mu>_def not_le INF_less_iff by simp
      then obtain p where
        "awalk s p v"
        "awalk_cost c p < dist v"
        by force
      thus False using dist_le_cost by force
    qed
  qed
qed

lemma (in basic_just_sp) dist_ge_\<mu>:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "num v \<noteq> \<infinity>"
  assumes "dist v \<noteq> -\<infinity>"
  assumes "\<mu> c s s = ereal 0"
  assumes "dist s = 0"
  assumes "\<And>u. u\<in>verts G \<Longrightarrow> u\<noteq>s \<Longrightarrow>
            num u \<noteq> \<infinity> \<Longrightarrow> num u \<noteq> enat 0"
  shows "dist v \<ge> \<mu> c s v"
proof -
  obtain n where "enat n = num v" using assms(2) by force
  thus ?thesis using assms
  proof(induct n arbitrary: v)
  case 0 thus ?case by (cases "v=s", auto)
  next
  case (Suc n)
    thus ?case
    proof (cases "v=s")
    case False
      obtain e where e_assms:
        "e \<in> arcs G"
        "v = head G e"
        "dist v = dist (tail G e) + ereal (c e)"
        "num v = num (tail G e) + enat 1"
        using just[OF Suc(3) False Suc(4)] by blast
      then have nsinf:"num (tail G e) \<noteq> \<infinity>"
        by (metis Suc(2) enat.simps(3) enat_1 plus_enat_simps(2))
      then have ns:"enat n = num (tail G e)"
        using e_assms(4) Suc(2) by force
      have  ds: "dist (tail G e) = \<mu> c s (tail G e)"
        using Suc(1)[OF ns tail_in_verts[OF e_assms(1)] nsinf]
        Suc(5-8) e_assms(3) dist_le_\<mu>[OF tail_in_verts[OF e_assms(1)]]
        by simp
      have dmuc:"dist v \<ge> \<mu> c s (tail G e) + ereal (c e)"
        using e_assms(3) ds  by auto
      thus ?thesis
      proof (cases "dist v = \<infinity>")
      case False
        have "arc_to_ends G e = (tail G e, v)"
          unfolding arc_to_ends_def
          by (simp add: e_assms(2))
        obtain r where  \<mu>r: "\<mu> c s (tail G e) = ereal r"
           using e_assms(3) Suc(5) ds False
           by (cases "\<mu> c s (tail G e)", auto)
        obtain p where
          "awalk s p (tail G e)" and
          \<mu>s: "\<mu> c s (tail G e) = ereal (awalk_cost c p)"
          using witness_path[OF \<mu>r] unfolding apath_def
          by blast
        then have pe: "awalk s (p @ [e]) v"
          using e_assms(1,2) by (auto simp: awalk_simps)
        hence muc:"\<mu> c s v \<le> \<mu> c s (tail G e) + ereal (c e)"
        using \<mu>s min_cost_le_walk_cost[OF pe] by simp
        thus  "dist v \<ge> \<mu> c s v"  using dmuc by simp
      qed simp
    qed (simp add: Suc(6,7))
  qed
qed

lemma (in shortest_path_pos_cost) num_not0:
  fixes v :: 'a
  assumes "v \<in> verts G"
  assumes "v \<noteq> s"
  assumes "num v \<noteq> \<infinity>"
  shows "num v \<noteq> enat 0"
proof -
  obtain ku where "num v = ku + enat 1"
    using assms just by blast
  thus ?thesis  by (induct ku) auto
qed

lemma (in shortest_path_pos_cost) dist_ne_ninf:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v \<noteq> -\<infinity>"
proof (cases "num v = \<infinity>")
case False
  obtain n where "enat n = num v"
    using False by force
  thus ?thesis using assms False
  proof(induct n arbitrary: v)
  case 0 thus ?case
    using num_not0 tail_val by (cases "v=s", auto)
  next
  case (Suc n)
    thus ?case
    proof (cases "v=s")
    case True
      thus ?thesis using tail_val by simp
    next
    case False
      obtain e where e_assms:
        "e \<in> arcs G"
        "dist v = dist (tail G e) + ereal (c e)"
        "num v = num (tail G e) + enat 1"
        using just[OF Suc(3) False Suc(4)] by blast
      then have nsinf:"num (tail G e) \<noteq> \<infinity>"
        by (metis Suc(2) enat.simps(3) enat_1 plus_enat_simps(2))
      then have ns:"enat n = num (tail G e)"
        using e_assms(3) Suc(2) by force
      have "dist (tail G e ) \<noteq> - \<infinity>"
        by (rule Suc(1) [OF ns tail_in_verts[OF e_assms(1)] nsinf])
      thus ?thesis using e_assms(2) by simp
    qed
  qed
next
case True
  thus ?thesis using no_path[OF assms] by simp
qed

theorem (in shortest_path_pos_cost) correct_shortest_path:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
  using no_path[OF assms(1)] dist_le_\<mu>[OF assms(1)]
    dist_ge_\<mu>[OF assms(1) _ dist_ne_ninf[OF assms(1)]
    tail_value_check[OF s_in_G] tail_val num_not0]
    by fastforce

corollary (in shortest_path_pos_cost_pred) correct_shortest_path_pred:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "dist v = \<mu> c s v"
  using correct_shortest_path assms by simp

end


(*  Title:      HOL/Nitpick_Examples/Hotel_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2010-2011

Nitpick example based on Tobias Nipkow's hotel key card formalization.
*)

section \<open>Nitpick Example Based on Tobias Nipkow's Hotel Key Card
          Formalization\<close>

theory Hotel_Nits
imports Main
begin

nitpick_params [verbose, max_potential = 0, sat_solver = MiniSat_JNI,
                max_threads = 1, timeout = 240]

typedecl guest
typedecl key
typedecl room

type_synonym keycard = "key \<times> key"

record state =
  owns :: "room \<Rightarrow> guest option"
  currk :: "room \<Rightarrow> key"
  issued :: "key set"
  cards :: "guest \<Rightarrow> keycard set"
  roomk :: "room \<Rightarrow> key"
  isin :: "room \<Rightarrow> guest set"
  safe :: "room \<Rightarrow> bool"

inductive_set reach :: "state set" where
init:
"inj initk \<Longrightarrow>
 \<lparr>owns = (\<lambda>r. None), currk = initk, issued = range initk, cards = (\<lambda>g. {}),
  roomk = initk, isin = (\<lambda>r. {}), safe = (\<lambda>r. True)\<rparr> \<in> reach" |
check_in:
"\<lbrakk>s \<in> reach; k \<notin> issued s\<rbrakk> \<Longrightarrow>
 s\<lparr>currk := (currk s)(r := k), issued := issued s \<union> {k},
   cards := (cards s)(g := cards s g \<union> {(currk s r, k)}),
   owns :=  (owns s)(r := Some g), safe := (safe s)(r := False)\<rparr> \<in> reach" |
enter_room:
"\<lbrakk>s \<in> reach; (k,k') \<in> cards s g; roomk s r \<in> {k,k'}\<rbrakk> \<Longrightarrow>
 s\<lparr>isin := (isin s)(r := isin s r \<union> {g}),
   roomk := (roomk s)(r := k'),
   safe := (safe s)(r := owns s r = Some g \<and> isin s r = {} (* \<and> k' = currk s r *)
                         \<or> safe s r)\<rparr> \<in> reach" |
exit_room:
"\<lbrakk>s \<in> reach; g \<in> isin s r\<rbrakk> \<Longrightarrow> s\<lparr>isin := (isin s)(r := isin s r - {g})\<rparr> \<in> reach"

theorem safe: "s \<in> reach \<Longrightarrow> safe s r \<Longrightarrow> g \<in> isin s r \<Longrightarrow> owns s r = Some g"
nitpick [card room = 1, card guest = 2, card "guest option" = 3,
         card key = 4, card state = 6, show_consts, format = 2,
         expect = genuine]
(* nitpick [card room = 1, card guest = 2, expect = genuine] *) (* slow *)
oops

end


(*  Title:      HOL/Proofs/Lambda/Eta.thy
    Author:     Tobias Nipkow and Stefan Berghofer
    Copyright   1995, 2005 TU Muenchen
*)

section \<open>Eta-reduction\<close>

theory Eta imports ParRed begin

subsection \<open>Definition of eta-reduction and relatives\<close>

primrec
  free :: "dB => nat => bool"
where
    "free (Var j) i = (j = i)"
  | "free (s \<degree> t) i = (free s i \<or> free t i)"
  | "free (Abs s) i = free s (i + 1)"

inductive
  eta :: "[dB, dB] => bool"  (infixl "\<rightarrow>\<^sub>\<eta>" 50)
where
    eta [simp, intro]: "\<not> free s 0 ==> Abs (s \<degree> Var 0) \<rightarrow>\<^sub>\<eta> s[dummy/0]"
  | appL [simp, intro]: "s \<rightarrow>\<^sub>\<eta> t ==> s \<degree> u \<rightarrow>\<^sub>\<eta> t \<degree> u"
  | appR [simp, intro]: "s \<rightarrow>\<^sub>\<eta> t ==> u \<degree> s \<rightarrow>\<^sub>\<eta> u \<degree> t"
  | abs [simp, intro]: "s \<rightarrow>\<^sub>\<eta> t ==> Abs s \<rightarrow>\<^sub>\<eta> Abs t"

abbreviation
  eta_reds :: "[dB, dB] => bool"   (infixl "\<rightarrow>\<^sub>\<eta>\<^sup>*" 50) where
  "s \<rightarrow>\<^sub>\<eta>\<^sup>* t == eta\<^sup>*\<^sup>* s t"

abbreviation
  eta_red0 :: "[dB, dB] => bool"   (infixl "\<rightarrow>\<^sub>\<eta>\<^sup>=" 50) where
  "s \<rightarrow>\<^sub>\<eta>\<^sup>= t == eta\<^sup>=\<^sup>= s t"

inductive_cases eta_cases [elim!]:
  "Abs s \<rightarrow>\<^sub>\<eta> z"
  "s \<degree> t \<rightarrow>\<^sub>\<eta> u"
  "Var i \<rightarrow>\<^sub>\<eta> t"

subsection \<open>Properties of \<open>eta\<close>, \<open>subst\<close> and \<open>free\<close>\<close>

lemma subst_not_free [simp]: "\<not> free s i \<Longrightarrow> s[t/i] = s[u/i]"
  by (induct s arbitrary: i t u) (simp_all add: subst_Var)

lemma free_lift [simp]:
    "free (lift t k) i = (i < k \<and> free t i \<or> k < i \<and> free t (i - 1))"
  apply (induct t arbitrary: i k)
  apply (auto cong: conj_cong)
  done

lemma free_subst [simp]:
    "free (s[t/k]) i =
      (free s k \<and> free t i \<or> free s (if i < k then i else i + 1))"
  apply (induct s arbitrary: i k t)
    prefer 2
    apply simp
    apply blast
   prefer 2
   apply simp
  apply (simp add: diff_Suc subst_Var split: nat.split)
  done

lemma free_eta: "s \<rightarrow>\<^sub>\<eta> t ==> free t i = free s i"
  by (induct arbitrary: i set: eta) (simp_all cong: conj_cong)

lemma not_free_eta:
    "[| s \<rightarrow>\<^sub>\<eta> t; \<not> free s i |] ==> \<not> free t i"
  by (simp add: free_eta)

lemma eta_subst [simp]:
    "s \<rightarrow>\<^sub>\<eta> t ==> s[u/i] \<rightarrow>\<^sub>\<eta> t[u/i]"
  by (induct arbitrary: u i set: eta) (simp_all add: subst_subst [symmetric])

theorem lift_subst_dummy: "\<not> free s i \<Longrightarrow> lift (s[dummy/i]) i = s"
  by (induct s arbitrary: i dummy) simp_all

subsection \<open>Confluence of \<open>eta\<close>\<close>

lemma square_eta: "square eta eta (eta\<^sup>=\<^sup>=) (eta\<^sup>=\<^sup>=)"
  apply (unfold square_def id_def)
  apply (rule impI [THEN allI [THEN allI]])
  apply (erule eta.induct)
     apply (slowsimp intro: subst_not_free eta_subst free_eta [THEN iffD1])
    apply safe
       prefer 5
       apply (blast intro!: eta_subst intro: free_eta [THEN iffD1])
      apply blast+
  done

theorem eta_confluent: "confluent eta"
  apply (rule square_eta [THEN square_reflcl_confluent])
  done

subsection \<open>Congruence rules for \<open>eta\<^sup>*\<close>\<close>

lemma rtrancl_eta_Abs: "s \<rightarrow>\<^sub>\<eta>\<^sup>* s' ==> Abs s \<rightarrow>\<^sub>\<eta>\<^sup>* Abs s'"
  by (induct set: rtranclp)
    (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_eta_AppL: "s \<rightarrow>\<^sub>\<eta>\<^sup>* s' ==> s \<degree> t \<rightarrow>\<^sub>\<eta>\<^sup>* s' \<degree> t"
  by (induct set: rtranclp)
    (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_eta_AppR: "t \<rightarrow>\<^sub>\<eta>\<^sup>* t' ==> s \<degree> t \<rightarrow>\<^sub>\<eta>\<^sup>* s \<degree> t'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_eta_App:
    "[| s \<rightarrow>\<^sub>\<eta>\<^sup>* s'; t \<rightarrow>\<^sub>\<eta>\<^sup>* t' |] ==> s \<degree> t \<rightarrow>\<^sub>\<eta>\<^sup>* s' \<degree> t'"
  by (blast intro!: rtrancl_eta_AppL rtrancl_eta_AppR intro: rtranclp_trans)

subsection \<open>Commutation of \<open>beta\<close> and \<open>eta\<close>\<close>

lemma free_beta:
    "s \<rightarrow>\<^sub>\<beta> t ==> free t i \<Longrightarrow> free s i"
  by (induct arbitrary: i set: beta) auto

lemma beta_subst [intro]: "s \<rightarrow>\<^sub>\<beta> t ==> s[u/i] \<rightarrow>\<^sub>\<beta> t[u/i]"
  by (induct arbitrary: u i set: beta) (simp_all add: subst_subst [symmetric])

lemma subst_Var_Suc [simp]: "t[Var i/i] = t[Var(i)/i + 1]"
  by (induct t arbitrary: i) (auto elim!: linorder_neqE simp: subst_Var)

lemma eta_lift [simp]: "s \<rightarrow>\<^sub>\<eta> t ==> lift s i \<rightarrow>\<^sub>\<eta> lift t i"
  by (induct arbitrary: i set: eta) simp_all

lemma rtrancl_eta_subst: "s \<rightarrow>\<^sub>\<eta> t \<Longrightarrow> u[s/i] \<rightarrow>\<^sub>\<eta>\<^sup>* u[t/i]"
  apply (induct u arbitrary: s t i)
    apply (simp_all add: subst_Var)
    apply blast
   apply (blast intro: rtrancl_eta_App)
  apply (blast intro!: rtrancl_eta_Abs eta_lift)
  done

lemma rtrancl_eta_subst':
  fixes s t :: dB
  assumes eta: "s \<rightarrow>\<^sub>\<eta>\<^sup>* t"
  shows "s[u/i] \<rightarrow>\<^sub>\<eta>\<^sup>* t[u/i]" using eta
  by induct (iprover intro: eta_subst)+

lemma rtrancl_eta_subst'':
  fixes s t :: dB
  assumes eta: "s \<rightarrow>\<^sub>\<eta>\<^sup>* t"
  shows "u[s/i] \<rightarrow>\<^sub>\<eta>\<^sup>* u[t/i]" using eta
  by induct (iprover intro: rtrancl_eta_subst rtranclp_trans)+

lemma square_beta_eta: "square beta eta (eta\<^sup>*\<^sup>*) (beta\<^sup>=\<^sup>=)"
  apply (unfold square_def)
  apply (rule impI [THEN allI [THEN allI]])
  apply (erule beta.induct)
     apply (slowsimp intro: rtrancl_eta_subst eta_subst)
    apply (blast intro: rtrancl_eta_AppL)
   apply (blast intro: rtrancl_eta_AppR)
  apply simp
  apply (slowsimp intro: rtrancl_eta_Abs free_beta
    iff del: dB.distinct simp: dB.distinct)    (*23 seconds?*)
  done

lemma confluent_beta_eta: "confluent (sup beta eta)"
  apply (assumption |
    rule square_rtrancl_reflcl_commute confluent_Un
      beta_confluent eta_confluent square_beta_eta)+
  done

subsection \<open>Implicit definition of \<open>eta\<close>\<close>

text \<open>\<^term>\<open>Abs (lift s 0 \<degree> Var 0) \<rightarrow>\<^sub>\<eta> s\<close>\<close>

lemma not_free_iff_lifted:
    "(\<not> free s i) = (\<exists>t. s = lift t i)"
  apply (induct s arbitrary: i)
    apply simp
    apply (rule iffI)
     apply (erule linorder_neqE)
      apply (rename_tac nat a, rule_tac x = "Var nat" in exI)
      apply simp
     apply (rename_tac nat a, rule_tac x = "Var (nat - 1)" in exI)
     apply simp
    apply clarify
    apply (rule notE)
     prefer 2
     apply assumption
    apply (erule thin_rl)
    apply (case_tac t)
      apply simp
     apply simp
    apply simp
   apply simp
   apply (erule thin_rl)
   apply (erule thin_rl)
   apply (rule iffI)
    apply (elim conjE exE)
    apply (rename_tac u1 u2)
    apply (rule_tac x = "u1 \<degree> u2" in exI)
    apply simp
   apply (erule exE)
   apply (erule rev_mp)
   apply (case_tac t)
     apply simp
    apply simp
    apply blast
   apply simp
  apply simp
  apply (erule thin_rl)
  apply (rule iffI)
   apply (erule exE)
   apply (rule_tac x = "Abs t" in exI)
   apply simp
  apply (erule exE)
  apply (erule rev_mp)
  apply (case_tac t)
    apply simp
   apply simp
  apply simp
  apply blast
  done

theorem explicit_is_implicit:
  "(\<forall>s u. (\<not> free s 0) --> R (Abs (s \<degree> Var 0)) (s[u/0])) =
    (\<forall>s. R (Abs (lift s 0 \<degree> Var 0)) s)"
  by (auto simp add: not_free_iff_lifted)

subsection \<open>Eta-postponement theorem\<close>

text \<open>
  Based on a paper proof due to Andreas Abel.
  Unlike the proof by Masako Takahashi \<^cite>\<open>"Takahashi-IandC"\<close>, it does not
  use parallel eta reduction, which only seems to complicate matters unnecessarily.
\<close>

theorem eta_case:
  fixes s :: dB
  assumes free: "\<not> free s 0"
  and s: "s[dummy/0] => u"
  shows "\<exists>t'. Abs (s \<degree> Var 0) => t' \<and> t' \<rightarrow>\<^sub>\<eta>\<^sup>* u"
proof -
  from s have "lift (s[dummy/0]) 0 => lift u 0" by (simp del: lift_subst)
  with free have "s => lift u 0" by (simp add: lift_subst_dummy del: lift_subst)
  hence "Abs (s \<degree> Var 0) => Abs (lift u 0 \<degree> Var 0)" by simp
  moreover have "\<not> free (lift u 0) 0" by simp
  hence "Abs (lift u 0 \<degree> Var 0) \<rightarrow>\<^sub>\<eta> lift u 0[dummy/0]"
    by (rule eta.eta)
  hence "Abs (lift u 0 \<degree> Var 0) \<rightarrow>\<^sub>\<eta>\<^sup>* u" by simp
  ultimately show ?thesis by iprover
qed

theorem eta_par_beta:
  assumes st: "s \<rightarrow>\<^sub>\<eta> t"
  and tu: "t => u"
  shows "\<exists>t'. s => t' \<and> t' \<rightarrow>\<^sub>\<eta>\<^sup>* u" using tu st
proof (induct arbitrary: s)
  case (var n)
  thus ?case by (iprover intro: par_beta_refl)
next
  case (abs s' t)
  note abs' = this
  from \<open>s \<rightarrow>\<^sub>\<eta> Abs s'\<close> show ?case
  proof cases
    case (eta s'' dummy)
    from abs have "Abs s' => Abs t" by simp
    with eta have "s''[dummy/0] => Abs t" by simp
    with \<open>\<not> free s'' 0\<close> have "\<exists>t'. Abs (s'' \<degree> Var 0) => t' \<and> t' \<rightarrow>\<^sub>\<eta>\<^sup>* Abs t"
      by (rule eta_case)
    with eta show ?thesis by simp
  next
    case (abs r)
    from \<open>r \<rightarrow>\<^sub>\<eta> s'\<close>
    obtain t' where r: "r => t'" and t': "t' \<rightarrow>\<^sub>\<eta>\<^sup>* t" by (iprover dest: abs')
    from r have "Abs r => Abs t'" ..
    moreover from t' have "Abs t' \<rightarrow>\<^sub>\<eta>\<^sup>* Abs t" by (rule rtrancl_eta_Abs)
    ultimately show ?thesis using abs by simp iprover
  qed
next
  case (app u u' t t')
  from \<open>s \<rightarrow>\<^sub>\<eta> u \<degree> t\<close> show ?case
  proof cases
    case (eta s' dummy)
    from app have "u \<degree> t => u' \<degree> t'" by simp
    with eta have "s'[dummy/0] => u' \<degree> t'" by simp
    with \<open>\<not> free s' 0\<close> have "\<exists>r. Abs (s' \<degree> Var 0) => r \<and> r \<rightarrow>\<^sub>\<eta>\<^sup>* u' \<degree> t'"
      by (rule eta_case)
    with eta show ?thesis by simp
  next
    case (appL s')
    from \<open>s' \<rightarrow>\<^sub>\<eta> u\<close>
    obtain r where s': "s' => r" and r: "r \<rightarrow>\<^sub>\<eta>\<^sup>* u'" by (iprover dest: app)
    from s' and app have "s' \<degree> t => r \<degree> t'" by simp
    moreover from r have "r \<degree> t' \<rightarrow>\<^sub>\<eta>\<^sup>* u' \<degree> t'" by (simp add: rtrancl_eta_AppL)
    ultimately show ?thesis using appL by simp iprover
  next
    case (appR s')
    from \<open>s' \<rightarrow>\<^sub>\<eta> t\<close>
    obtain r where s': "s' => r" and r: "r \<rightarrow>\<^sub>\<eta>\<^sup>* t'" by (iprover dest: app)
    from s' and app have "u \<degree> s' => u' \<degree> r" by simp
    moreover from r have "u' \<degree> r \<rightarrow>\<^sub>\<eta>\<^sup>* u' \<degree> t'" by (simp add: rtrancl_eta_AppR)
    ultimately show ?thesis using appR by simp iprover
  qed
next
  case (beta u u' t t')
  from \<open>s \<rightarrow>\<^sub>\<eta> Abs u \<degree> t\<close> show ?case
  proof cases
    case (eta s' dummy)
    from beta have "Abs u \<degree> t => u'[t'/0]" by simp
    with eta have "s'[dummy/0] => u'[t'/0]" by simp
    with \<open>\<not> free s' 0\<close> have "\<exists>r. Abs (s' \<degree> Var 0) => r \<and> r \<rightarrow>\<^sub>\<eta>\<^sup>* u'[t'/0]"
      by (rule eta_case)
    with eta show ?thesis by simp
  next
    case (appL s')
    from \<open>s' \<rightarrow>\<^sub>\<eta> Abs u\<close> show ?thesis
    proof cases
      case (eta s'' dummy)
      have "Abs (lift u 1) = lift (Abs u) 0" by simp
      also from eta have "\<dots> = s''" by (simp add: lift_subst_dummy del: lift_subst)
      finally have s: "s = Abs (Abs (lift u 1) \<degree> Var 0) \<degree> t" using appL and eta by simp
      from beta have "lift u 1 => lift u' 1" by simp
      hence "Abs (lift u 1) \<degree> Var 0 => lift u' 1[Var 0/0]"
        using par_beta.var ..
      hence "Abs (Abs (lift u 1) \<degree> Var 0) \<degree> t => lift u' 1[Var 0/0][t'/0]"
        using \<open>t => t'\<close> ..
      with s have "s => u'[t'/0]" by simp
      thus ?thesis by iprover
    next
      case (abs r)
      from \<open>r \<rightarrow>\<^sub>\<eta> u\<close>
      obtain r'' where r: "r => r''" and r'': "r'' \<rightarrow>\<^sub>\<eta>\<^sup>* u'" by (iprover dest: beta)
      from r and beta have "Abs r \<degree> t => r''[t'/0]" by simp
      moreover from r'' have "r''[t'/0] \<rightarrow>\<^sub>\<eta>\<^sup>* u'[t'/0]"
        by (rule rtrancl_eta_subst')
      ultimately show ?thesis using abs and appL by simp iprover
    qed
  next
    case (appR s')
    from \<open>s' \<rightarrow>\<^sub>\<eta> t\<close>
    obtain r where s': "s' => r" and r: "r \<rightarrow>\<^sub>\<eta>\<^sup>* t'" by (iprover dest: beta)
    from s' and beta have "Abs u \<degree> s' => u'[r/0]" by simp
    moreover from r have "u'[r/0] \<rightarrow>\<^sub>\<eta>\<^sup>* u'[t'/0]"
      by (rule rtrancl_eta_subst'')
    ultimately show ?thesis using appR by simp iprover
  qed
qed

theorem eta_postponement':
  assumes eta: "s \<rightarrow>\<^sub>\<eta>\<^sup>* t" and beta: "t => u"
  shows "\<exists>t'. s => t' \<and> t' \<rightarrow>\<^sub>\<eta>\<^sup>* u" using eta beta
proof (induct arbitrary: u)
  case base
  thus ?case by blast
next
  case (step s' s'' s''')
  then obtain t' where s': "s' => t'" and t': "t' \<rightarrow>\<^sub>\<eta>\<^sup>* s'''"
    by (auto dest: eta_par_beta)
  from s' obtain t'' where s: "s => t''" and t'': "t'' \<rightarrow>\<^sub>\<eta>\<^sup>* t'" using step
    by blast
  from t'' and t' have "t'' \<rightarrow>\<^sub>\<eta>\<^sup>* s'''" by (rule rtranclp_trans)
  with s show ?case by iprover
qed

theorem eta_postponement:
  assumes "(sup beta eta)\<^sup>*\<^sup>* s t"
  shows "(beta\<^sup>*\<^sup>* OO eta\<^sup>*\<^sup>*) s t" using assms
proof induct
  case base
  show ?case by blast
next
  case (step s' s'')
  from step(3) obtain t' where s: "s \<rightarrow>\<^sub>\<beta>\<^sup>* t'" and t': "t' \<rightarrow>\<^sub>\<eta>\<^sup>* s'" by blast
  from step(2) show ?case
  proof
    assume "s' \<rightarrow>\<^sub>\<beta> s''"
    with beta_subset_par_beta have "s' => s''" ..
    with t' obtain t'' where st: "t' => t''" and tu: "t'' \<rightarrow>\<^sub>\<eta>\<^sup>* s''"
      by (auto dest: eta_postponement')
    from par_beta_subset_beta st have "t' \<rightarrow>\<^sub>\<beta>\<^sup>* t''" ..
    with s have "s \<rightarrow>\<^sub>\<beta>\<^sup>* t''" by (rule rtranclp_trans)
    thus ?thesis using tu ..
  next
    assume "s' \<rightarrow>\<^sub>\<eta> s''"
    with t' have "t' \<rightarrow>\<^sub>\<eta>\<^sup>* s''" ..
    with s show ?thesis ..
  qed
qed

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

section "Normalising Word Numerals"

theory Norm_Words
imports "Signed_Words"
begin

text \<open>
  Normalise word numerals, including negative ones apart from @{term "-1"}, to the
  interval @{text "[0..2^len_of 'a)"}. Only for concrete word lengths.
\<close>

lemma neg_num_bintr:
  "(- numeral x :: 'a::len word) =
  word_of_int (bintrunc (len_of TYPE('a)) (-numeral x))"
  by (simp only: word_ubin.Abs_norm word_neg_numeral_alt)

ML \<open>
  fun is_refl (Const (@{const_name Pure.eq}, _) $ x $ y) = (x = y)
    | is_refl _ = false;

  fun signed_dest_wordT (Type (@{type_name word}, [Type (@{type_name signed}, [T])])) = Word_Lib.dest_binT T
    | signed_dest_wordT T = Word_Lib.dest_wordT T

  fun typ_size_of t = signed_dest_wordT (type_of (Thm.term_of t));

  fun num_len (Const (@{const_name Num.Bit0}, _) $ n) = num_len n + 1
    | num_len (Const (@{const_name Num.Bit1}, _) $ n) = num_len n + 1
    | num_len (Const (@{const_name Num.One}, _)) = 1
    | num_len (Const (@{const_name numeral}, _) $ t) = num_len t
    | num_len (Const (@{const_name uminus}, _) $ t) = num_len t
    | num_len t = raise TERM ("num_len", [t])

  fun unsigned_norm is_neg _ ctxt ct =
  (if is_neg orelse num_len (Thm.term_of ct) > typ_size_of ct then let
      val btr = if is_neg
                then @{thm neg_num_bintr} else @{thm num_abs_bintr}
      val th = [Thm.reflexive ct, mk_eq btr] MRS transitive_thm

      (* will work in context of theory Word as well *)
      val ss = simpset_of (@{context} addsimps @{thms bintrunc_numeral})
      val cnv = simplify (put_simpset ss ctxt) th
    in if is_refl (Thm.prop_of cnv) then NONE else SOME cnv end
    else NONE)
  handle TERM ("num_len", _) => NONE
       | TYPE ("dest_binT", _, _) => NONE
\<close>

simproc_setup
  unsigned_norm ("numeral n::'a::len word") = \<open>unsigned_norm false\<close>

simproc_setup
  unsigned_norm_neg0 ("-numeral (num.Bit0 num)::'a::len word") = \<open>unsigned_norm true\<close>

simproc_setup
  unsigned_norm_neg1 ("-numeral (num.Bit1 num)::'a::len word") = \<open>unsigned_norm true\<close>

declare word_pow_0 [simp]

lemma minus_one_norm:
  "(-1 :: 'a :: len word) = of_nat (2 ^ len_of TYPE('a) - 1)"
  by (simp add:of_nat_diff)

lemmas minus_one_norm_num =
  minus_one_norm [where 'a="'b::len bit0"] minus_one_norm [where 'a="'b::len0 bit1"]

lemma "f (7 :: 2 word) = f 3" by simp

lemma "f (-2) = f (21 + 1 :: 3 word)" by simp

lemma "f (-2) = f (13 + 1 :: 'a::len word)"
  apply simp (* does not touch generic word length *)
  oops

lemma "f (-2) = f (0xFFFFFFFE :: 32 word)" by simp

lemma "(-1 :: 2 word) = 3" by simp

lemma "f (-2) = f (0xFFFFFFFE :: 32 signed word)" by simp

text \<open>
  We leave @{term "-1"} untouched by default, because it is often useful
  and its normal form can be large.
  To include it in the normalisation, add @{thm [source] minus_one_norm_num}.
  The additional normalisation is restricted to concrete numeral word lengths,
  like the rest.
\<close>
context
  notes minus_one_norm_num [simp]
begin

lemma "f (-1) = f (15 :: 4 word)" by simp

lemma "f (-1) = f (7 :: 3 word)" by simp

lemma "f (-1) = f (0xFFFF :: 16 word)" by simp

lemma "f (-1) = f (0xFFFF + 1 :: 'a::len word)"
  apply simp (* does not touch generic -1 *)
  oops

end

end


theory PF_Negation_Type_Matching
  imports
  Iptables_Semantics.Negation_Type
  PF_Matching_Ternary
  Iptables_Semantics.Datatype_Selectors
  PF_Normalized_Matches
begin

(* adapted from Iptables_Semantics.Negation_Type_Matching *)
section\<open>Negation Type Matching\<close>

text\<open>Transform a @{typ "'a negation_type list"} to a @{typ "'a match_expr"} via conjunction.\<close>
fun alist_and :: "'a negation_type list \<Rightarrow> 'a match_expr" where
  "alist_and [] = MatchAny" |
  "alist_and ((Pos e)#es) = MatchAnd (Match e) (alist_and es)" |
  "alist_and ((Neg e)#es) = MatchAnd (MatchNot (Match e)) (alist_and es)"

lemma normalized_nnf_match_alist_and: "normalized_nnf_match (alist_and as)"
  by(induction as rule: alist_and.induct) simp_all

lemma alist_and_append: "matches \<gamma> (alist_and (l1 @ l2)) a d p \<longleftrightarrow> matches \<gamma>  (MatchAnd (alist_and l1)  (alist_and l2)) a d p"
  proof(induction l1)
  case Nil thus ?case by (simp add: bunch_of_lemmata_about_matches)
  next
  case (Cons l l1) thus ?case by (cases l) (simp_all add: bunch_of_lemmata_about_matches)
  qed

  text\<open>This version of @{const alist_and} avoids the trailing @{const MatchAny}. Only intended for code.\<close>
  fun alist_and' :: "'a negation_type list \<Rightarrow> 'a match_expr" where
    "alist_and' [] = MatchAny" |
    "alist_and' [Pos e] = Match e" |
    "alist_and' [Neg e] = MatchNot (Match e)"|
    "alist_and' ((Pos e)#es) = MatchAnd (Match e) (alist_and' es)" |
    "alist_and' ((Neg e)#es) = MatchAnd (MatchNot (Match e)) (alist_and' es)"

  lemma alist_and': "matches (\<gamma>, \<alpha>) (alist_and' as) = matches (\<gamma>, \<alpha>) (alist_and as)"
    by(induction as rule: alist_and'.induct) (simp_all add: bunch_of_lemmata_about_matches)

  lemma normalized_nnf_match_alist_and': "normalized_nnf_match (alist_and' as)"
    by(induction as rule: alist_and'.induct) simp_all

  lemma matches_alist_and_alist_and':
    "matches \<gamma> (alist_and' ls) a d p \<longleftrightarrow> matches \<gamma> (alist_and ls) a d p"
    apply(induction ls rule: alist_and'.induct)
    by(simp add: bunch_of_lemmata_about_matches)+

  lemma alist_and'_append: "matches \<gamma> (alist_and' (l1 @ l2)) a d p \<longleftrightarrow> matches \<gamma> (MatchAnd (alist_and' l1) (alist_and' l2)) a d p"
    proof(induction l1)
    case Nil thus ?case by (simp add: bunch_of_lemmata_about_matches)
    next
    case (Cons l l1) thus ?case
      apply (cases l)
       by(simp_all add: matches_alist_and_alist_and' bunch_of_lemmata_about_matches)
    qed

lemma alist_and_NegPos_map_getNeg_getPos_matches:
  "(\<forall>m\<in>set (getNeg spts). matches \<gamma> (MatchNot (Match (C m))) a d p) \<and>
   (\<forall>m\<in>set (getPos spts). matches \<gamma> (Match (C m)) a d p)
    \<longleftrightarrow>
    matches \<gamma> (alist_and (NegPos_map C spts)) a d p"
  proof(induction spts rule: alist_and.induct)
  qed(auto simp add: bunch_of_lemmata_about_matches)

fun negation_type_to_match_expr_f :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a negation_type \<Rightarrow> 'b match_expr" where
  "negation_type_to_match_expr_f f (Pos a) = Match (f a)" |
  "negation_type_to_match_expr_f f (Neg a) = MatchNot (Match (f a))"

lemma alist_and_negation_type_to_match_expr_f_matches:
    "matches \<gamma> (alist_and (NegPos_map C spts)) a d p \<longleftrightarrow>
        (\<forall>m\<in>set spts. matches \<gamma> (negation_type_to_match_expr_f C m) a d p)"
  proof(induction spts rule: alist_and.induct)
  qed(auto simp add: bunch_of_lemmata_about_matches)

definition negation_type_to_match_expr :: "'a negation_type \<Rightarrow> 'a match_expr" where
  "negation_type_to_match_expr m \<equiv> negation_type_to_match_expr_f id m"

lemma negation_type_to_match_expr_simps:
  "negation_type_to_match_expr (Pos e) = (Match e)"
  "negation_type_to_match_expr (Neg e) = (MatchNot (Match e))"
by(simp_all add: negation_type_to_match_expr_def)

lemma alist_and_negation_type_to_match_expr: "alist_and (n#es) =  MatchAnd (negation_type_to_match_expr n) (alist_and es)"
  by(cases n, simp_all add: negation_type_to_match_expr_simps)

fun to_negation_type_nnf :: "'a match_expr \<Rightarrow> 'a negation_type list" where
 "to_negation_type_nnf MatchAny = []" |
 "to_negation_type_nnf (Match a) = [Pos a]" |
 "to_negation_type_nnf (MatchNot (Match a)) = [Neg a]" |
 "to_negation_type_nnf (MatchAnd a b) = (to_negation_type_nnf a) @ (to_negation_type_nnf b)" |
 "to_negation_type_nnf _ = undefined"

lemma "normalized_nnf_match m \<Longrightarrow> matches \<gamma> (alist_and (to_negation_type_nnf m)) a d p  = matches \<gamma> m a d p"
  proof(induction m rule: to_negation_type_nnf.induct)
  qed(simp_all add: bunch_of_lemmata_about_matches alist_and_append)

text\<open>Isolating the matching semantics\<close>
fun nt_match_list :: "('a, 'packet) match_tac \<Rightarrow> action \<Rightarrow> decision \<Rightarrow> 'packet \<Rightarrow> 'a negation_type list \<Rightarrow> bool" where
  "nt_match_list _ _ _ _ [] = True" |
  "nt_match_list \<gamma> a d p ((Pos x)#xs) \<longleftrightarrow> matches \<gamma> (Match x) a d p \<and> nt_match_list \<gamma> a d p xs" |
  "nt_match_list \<gamma> a d p ((Neg x)#xs) \<longleftrightarrow> matches \<gamma> (MatchNot (Match x)) a d p \<and> nt_match_list \<gamma> a d p xs"

lemma nt_match_list_matches: "nt_match_list \<gamma> a d p l \<longleftrightarrow> matches \<gamma> (alist_and l) a d p"
  apply(induction l rule: alist_and.induct)
    apply(case_tac [!] \<gamma>)
    apply(simp_all add: bunch_of_lemmata_about_matches)
  done

lemma nt_match_list_simp: "nt_match_list \<gamma> a d p ms \<longleftrightarrow>
      (\<forall>m \<in> set (getPos ms). matches \<gamma> (Match m) a d p) \<and> (\<forall>m \<in> set (getNeg ms). matches \<gamma> (MatchNot (Match m)) a d p)"
  proof(induction \<gamma> a d p ms rule: nt_match_list.induct)
  case 3 thus ?case by fastforce
  qed(simp_all)

lemma matches_alist_and: "matches \<gamma> (alist_and l) a d p \<longleftrightarrow> (\<forall>m \<in> set (getPos l). matches \<gamma> (Match m) a d p) \<and> (\<forall>m \<in> set (getNeg l). matches \<gamma> (MatchNot (Match m)) a d p)"
  using nt_match_list_matches nt_match_list_simp by fast

end


theory Bool_Fold imports "HOL-IMP.Fold" "../Short_Theory" begin

notation Map.empty ("empty")

text {*
\exercise
Strengthen and re-prove the congruence rules for conditional semantic equivalence
to take the value of boolean expressions into account in the \texttt{IF} and
\texttt{WHILE} cases. As a reminder, the weaker rules are:

@{thm [display] equiv_up_to_if_weak}

@{thm [display] equiv_up_to_while_weak}

Find a formulation that takes @{text b} into account for equivalences about @{term c} or @{term d}.
*}

lemma equiv_up_to_if:
(* your definition/proof here *)

lemma equiv_up_to_while:
  assumes b: "P \<Turnstile> b <\<sim>> b'"
  assumes c: "(\<lambda>s. P s \<and> bval b s) \<Turnstile> c \<sim> c'"
  assumes I: "\<And>s s'. (c, s) \<Rightarrow> s' \<Longrightarrow> P s \<Longrightarrow> bval b s \<Longrightarrow> P s'"
  shows "P \<Turnstile> WHILE b DO c \<sim> WHILE b' DO c'"
(* your definition/proof here *)

text {*
\endexercise

\exercise
Extend constant folding with analysing boolean expressions
and eliminate dead \texttt{IF} branches as well as loops whose body is
never executed. Use the contents of theory @{short_theory "Fold"} as a blueprint.
*}

fun bfold :: "bexp \<Rightarrow> tab \<Rightarrow> bexp"  where
(* your definition/proof here *)

primrec bdefs :: "com \<Rightarrow> tab \<Rightarrow> tab"  where
(* your definition/proof here *)

primrec fold' :: "com \<Rightarrow> tab \<Rightarrow> com"  where
(* your definition/proof here *)

text {*
  Hint: you will need to make use of stronger congruence rules
        for conditional semantic equivalence.
*}

lemma fold'_equiv: "approx t \<Turnstile> c \<sim> fold' c t"
(* your definition/proof here *)

theorem constant_folding_equiv': "fold' c Map.empty \<sim> c"
(* your definition/proof here *)

text {* \endexercise *}

end


section \<open>Sets with at Most 2 Elements\<close>

(*<*)
theory Bool_Bounded_Set
imports
  "HOL-Cardinals.Cardinals"
begin
(*>*)

typedef 'a bset =
  "{A :: 'a set. |A| \<le>o ctwo}"
  morphisms set_bset Abs_bset
  by (rule exI[of _ "{}"]) (auto simp: card_of_empty4 ctwo_def)

setup_lifting type_definition_bset

lift_definition map_bset ::
  "('a \<Rightarrow> 'b) \<Rightarrow> 'a bset \<Rightarrow> 'b bset" is image
  using card_of_image ordLeq_transitive by blast

inductive rel_bset :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a bset \<Rightarrow> 'b bset \<Rightarrow> bool" for R where
  "set_bset x \<subseteq> {(x, y). R x y} \<Longrightarrow> rel_bset R (map_bset fst x) (map_bset snd x)"

lift_definition bempty :: "'a bset" is "{}"  by (auto simp: card_of_empty4 ctwo_def)
lift_definition bsingleton :: "'a \<Rightarrow> 'a bset" is "\<lambda>x. {x}" by (auto simp: ctwo_def)
lift_definition bdoubleton :: "'a \<Rightarrow> 'a \<Rightarrow> 'a bset" is "\<lambda>x y. {x, y}"
  by (auto simp: ctwo_def finite_card_of_iff_card2 card_insert card_Diff_singleton_if)

lemma map_bset_bempty[simp]: "map_bset f bempty = bempty"
  by transfer simp

lemma map_bset_eq_bempty[simp]:
  "map_bset f x = bempty \<longleftrightarrow> x = bempty"
  "bempty = map_bset f x \<longleftrightarrow> x = bempty"
  by (transfer, simp)+

lemma map_bset_bsingleton[simp]: "map_bset f (bsingleton x) = bsingleton (f x)"
  by transfer simp

lemma map_bset_bdoubleton[simp]: "map_bset f (bdoubleton x y) = bdoubleton (f x) (f y)"
  by transfer simp

lemma bdoubleton_same[simp]: "bdoubleton x x = bsingleton x"
  by transfer simp

lemma bempty_neq_bdoubleton[simp]:
  "bempty \<noteq> bdoubleton x y"
  "bdoubleton x y \<noteq> bempty"
  by (transfer, simp)+

lemma bsinleton_eq_bdoubleton[simp]:
  "bsingleton x = bdoubleton y z \<longleftrightarrow> (x = y \<and> y = z)"
  "bdoubleton y z = bsingleton x \<longleftrightarrow> (x = y \<and> y = z)"
  by (transfer, auto)+

lemma bsinleton_inj[simp]:
  "bsingleton x = bsingleton y \<longleftrightarrow> (x = y)"
  by (transfer, simp)

lemma bdoubleton_eq_iff[simp]:
  "bdoubleton x y = bdoubleton z w \<longleftrightarrow> (x = z \<and> y = w \<or> x = w \<and> y = z)"
  by transfer (simp add: doubleton_eq_iff)

lemmas [simp] = bempty.rep_eq bsingleton.rep_eq bdoubleton.rep_eq

lemma bset_cases:
  "\<lbrakk>X = bempty \<Longrightarrow> P; \<And>x. X = bsingleton x \<Longrightarrow> P; \<And>x y. \<lbrakk>x \<noteq> y; X = bdoubleton x y\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
proof (transfer fixing: P)
  fix Z :: "'a set"
  assume "|Z| \<le>o ctwo"
  moreover then have "finite Z" by (metis card_of_ordLeq_infinite ctwo_def finite_code)
  ultimately have "card Z \<le> 2" unfolding ctwo_def by (subst (asm) finite_card_of_iff_card2) auto
  moreover assume "Z = {} \<Longrightarrow> P" "\<And>x. Z = {x} \<Longrightarrow> P" "\<And>x y. \<lbrakk>x \<noteq> y; Z = {x, y}\<rbrakk> \<Longrightarrow> P"
  ultimately show P using \<open>finite Z\<close>
  proof (induct "card Z")
    case (Suc m) from Suc(2)[symmetric] Suc(2-7) show P by (cases m) (auto simp: card_Suc_eq)
  qed simp
qed

bnf "'k bset"
  map: map_bset
  sets: set_bset
  bd: natLeq
  rel: rel_bset
proof (standard, goal_cases)
  case 1 then show ?case
    by transfer simp
next
  case 2 then show ?case
    apply (rule ext)
    apply transfer
    apply auto
    done
next
  case 3 then show ?case
    apply transfer
    apply (auto simp: image_iff)
    done
next
  case 4 then show ?case
    apply (rule ext)
    apply transfer
    apply simp
    done
next
  case 5 then show ?case by (simp add: card_order_csum natLeq_card_order)
next
  case 6 then show ?case by (simp add: cinfinite_csum natLeq_cinfinite)
next
  case 7 then show ?case
    apply transfer
    apply (erule ordLeq_transitive[OF _ ordLess_imp_ordLeq[OF ctwo_ordLess_natLeq]])
    done
next
  case (8 R S)
  then show ?case
  proof (safe elim!: rel_bset.cases, unfold rel_bset.simps)
    fix z1 z2
    assume "set_bset z1 \<subseteq> {(x, y). R x y}" "set_bset z2 \<subseteq> {(x, y). S x y}" "map_bset snd z1 = map_bset fst z2"
    then show "\<exists>x. map_bset fst z1 = map_bset fst x \<and> map_bset snd z2 = map_bset snd x \<and>
      set_bset x \<subseteq> {(x, y). (R OO S) x y}"
      by (cases z1 z2 rule: bset_cases[case_product bset_cases])
        (fastforce intro: exI[of _ "bsingleton (a, b)" for a b]
        dest: spec[of _ "bdoubleton (a, b) (c, d)" for a b c d])+
  qed
next
  case (9 R)
  then show ?case
    by (auto simp: fun_eq_iff intro: rel_bset.intros elim: rel_bset.cases)
qed

(*<*)
end
(*>*)


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

subsection \<open>IND-CPA from PRF\<close>

theory PRF_IND_CPA imports
  CryptHOL.GPV_Bisim
  CryptHOL.List_Bits
  Pseudo_Random_Function
  IND_CPA
begin

text \<open>
  Formalises the construction from \<^cite>\<open>"PetcherMorrisett2015POST"\<close>.
\<close>

declare [[simproc del: let_simp]]

type_synonym key = "bool list"
type_synonym plain = "bool list"
type_synonym cipher = "bool list * bool list"

locale otp =
  fixes f :: "key \<Rightarrow> bool list \<Rightarrow> bool list"
  and len :: nat
  assumes length_f: "\<And>xs ys. \<lbrakk> length xs = len; length ys = len \<rbrakk> \<Longrightarrow> length (f xs ys) = len"
begin

definition key_gen :: "bool list spmf"
where "key_gen = spmf_of_set (nlists UNIV len)"

definition valid_plain :: "plain \<Rightarrow> bool"
where "valid_plain plain \<longleftrightarrow> length plain = len"

definition encrypt :: "key \<Rightarrow> plain \<Rightarrow> cipher spmf"
where
  "encrypt key plain = do {
     r \<leftarrow> spmf_of_set (nlists UNIV len);
     return_spmf (r, xor_list plain (f key r))
   }"

fun decrypt :: "key \<Rightarrow> cipher \<Rightarrow> plain option"
where "decrypt key (r, c) = Some (xor_list (f key r) c)"

lemma encrypt_decrypt_correct:
  "\<lbrakk> length key = len; length plain = len \<rbrakk>
  \<Longrightarrow> encrypt key plain \<bind> (\<lambda>cipher. return_spmf (decrypt key cipher)) = return_spmf (Some plain)"
by(simp add: encrypt_def zip_map2 o_def split_def bind_eq_return_spmf length_f in_nlists_UNIV xor_list_left_commute)

interpretation ind_cpa: ind_cpa key_gen encrypt decrypt valid_plain .
interpretation "prf": "prf" key_gen f "spmf_of_set (nlists UNIV len)" .

definition prf_encrypt_oracle :: "unit \<Rightarrow> plain \<Rightarrow> (cipher \<times> unit, plain, plain) gpv"
where
  "prf_encrypt_oracle x plain = do {
     r \<leftarrow> lift_spmf (spmf_of_set (nlists UNIV len));
     Pause r (\<lambda>pad. Done ((r, xor_list plain pad), ()))
  }"

lemma interaction_bounded_by_prf_encrypt_oracle [interaction_bound]:
  "interaction_any_bounded_by (prf_encrypt_oracle \<sigma> plain) 1"
unfolding prf_encrypt_oracle_def by simp

lemma lossless_prf_encyrpt_oracle [simp]: "lossless_gpv \_top (prf_encrypt_oracle s x)"
by(simp add: prf_encrypt_oracle_def)

definition prf_adversary :: "(plain, cipher, 'state) ind_cpa.adversary \<Rightarrow> (plain, plain) prf.adversary"
where
  "prf_adversary \ = do {
     let (\1, \2) = \;
     (((p1, p2), \<sigma>), n) \<leftarrow> inline prf_encrypt_oracle \1 ();
     if valid_plain p1 \<and> valid_plain p2 then do {
       b \<leftarrow> lift_spmf coin_spmf;
       let pb = (if b then p1 else p2);
       r \<leftarrow> lift_spmf (spmf_of_set (nlists UNIV len));
       pad \<leftarrow> Pause r Done;
       let c = (r, xor_list pb pad);
       (b', _) \<leftarrow> inline prf_encrypt_oracle (\2 c \<sigma>) n;
       Done (b' = b)
     } else lift_spmf coin_spmf
  }"

theorem prf_encrypt_advantage:
  assumes "ind_cpa.ibounded_by \ q"
  and "lossless_gpv \_full (fst \)"
  and "\<And>cipher \<sigma>. lossless_gpv \_full (snd \ cipher \<sigma>)"
  shows "ind_cpa.advantage \ \<le> prf.advantage (prf_adversary \) + q / 2 ^ len"
proof -
  note [split del] = if_split
    and [cong del] = if_weak_cong
    and [simp] =
      bind_spmf_const map_spmf_bind_spmf bind_map_spmf
      exec_gpv_bind exec_gpv_inline
      rel_spmf_bind_reflI rel_spmf_reflI
  obtain \1 \2 where \: "\ = (\1, \2)" by(cases "\")
  from \<open>ind_cpa.ibounded_by _ _\<close>
  obtain q1 q2 :: nat
    where q1: "interaction_any_bounded_by \1 q1"
    and q2: "\<And>cipher \<sigma>. interaction_any_bounded_by (\2 cipher \<sigma>) q2"
    and "q1 + q2 \<le> q"
    unfolding \ by(rule ind_cpa.ibounded_byE)(auto simp add: iadd_le_enat_iff)
  from \ assms have lossless1: "lossless_gpv \_full \1"
    and lossless2: "\<And>cipher \<sigma>. lossless_gpv \_full (\2 cipher \<sigma>)" by simp_all
  have weight1: "\<And>oracle s. (\<And>s x. lossless_spmf (oracle s x))
    \<Longrightarrow> weight_spmf (exec_gpv oracle \1 s) = 1"
    by(rule lossless_weight_spmfD)(rule lossless_exec_gpv[OF lossless1], simp_all)
  have weight2: "\<And>oracle s cipher \<sigma>. (\<And>s x. lossless_spmf (oracle s x))
    \<Longrightarrow> weight_spmf (exec_gpv oracle (\2 cipher \<sigma>) s) = 1"
    by(rule lossless_weight_spmfD)(rule lossless_exec_gpv[OF lossless2], simp_all)

  let ?oracle1 = "\<lambda>key (s', s) y. map_spmf (\<lambda>((x, s'), s). (x, (), ())) (exec_gpv (prf.prf_oracle key) (prf_encrypt_oracle () y) ())"
  have bisim1: "\<And>key. rel_spmf (\<lambda>(x, _) (y, _). x = y)
          (exec_gpv (ind_cpa.encrypt_oracle key) \1 ())
          (exec_gpv (?oracle1 key) \1 ((), ()))"
    using TrueI
    by(rule exec_gpv_oracle_bisim)(auto simp add: encrypt_def prf_encrypt_oracle_def ind_cpa.encrypt_oracle_def prf.prf_oracle_def o_def)
  have bisim2: "\<And>key cipher \<sigma>. rel_spmf (\<lambda>(x, _) (y, _). x = y)
             (exec_gpv (ind_cpa.encrypt_oracle key) (\2 cipher \<sigma>) ())
             (exec_gpv (?oracle1 key) (\2 cipher \<sigma>) ((), ()))"
    using TrueI
    by(rule exec_gpv_oracle_bisim)(auto simp add: encrypt_def prf_encrypt_oracle_def ind_cpa.encrypt_oracle_def prf.prf_oracle_def o_def)

  have ind_cpa_0: "rel_spmf (=) (ind_cpa.ind_cpa \) (prf.game_0 (prf_adversary \))"
    unfolding IND_CPA.ind_cpa.ind_cpa_def \ key_gen_def Let_def prf_adversary_def Pseudo_Random_Function.prf.game_0_def
    apply(simp)
    apply(rewrite in "bind_spmf _ \<hole>" bind_commute_spmf)
    apply(rule rel_spmf_bind_reflI)
    apply(rule rel_spmf_bindI[OF bisim1])
    apply(clarsimp simp add: if_distribs bind_coin_spmf_eq_const')
    apply(auto intro: rel_spmf_bindI[OF bisim2] intro!: rel_spmf_bind_reflI simp add: encrypt_def prf.prf_oracle_def cong del: if_cong)
    done

  define rf_encrypt where "rf_encrypt = (\<lambda>s plain. bind_spmf (spmf_of_set (nlists UNIV len)) (\<lambda>r :: bool list.
    bind_spmf (prf.random_oracle s r) (\<lambda>(pad, s').
    return_spmf ((r, xor_list plain pad), s')))
  )"
  interpret rf_finite: callee_invariant_on rf_encrypt "\<lambda>s. finite (dom s)" \_full
    by unfold_locales(auto simp add: rf_encrypt_def dest: prf.finite.callee_invariant)
  have lossless_rf_encrypt [simp]: "\<And>s plain. lossless_spmf (rf_encrypt s plain)"
    by(auto simp add: rf_encrypt_def)

  define game2 where "game2 = do {
    (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
    if valid_plain p0 \<and> valid_plain p1 then do {
      b \<leftarrow> coin_spmf;
      let pb = (if b then p0 else p1);
      (cipher, s2) \<leftarrow> rf_encrypt s1 pb;
      (b', s3) \<leftarrow> exec_gpv rf_encrypt (\2 cipher \<sigma>) s2;
      return_spmf (b' = b)
    } else coin_spmf
  }"

  let ?oracle2 = "\<lambda>(s', s) y. map_spmf (\<lambda>((x, s'), s). (x, (), s)) (exec_gpv prf.random_oracle (prf_encrypt_oracle () y) s)"
  let ?I = "\<lambda>(x, _, s) (y, s'). x = y \<and> s = s'"
  have bisim1: "rel_spmf ?I (exec_gpv ?oracle2 \1 ((), Map.empty)) (exec_gpv rf_encrypt \1 Map.empty)"
     by(rule exec_gpv_oracle_bisim[where X="\<lambda>(_, s) s'. s = s'"])
       (auto simp add: rf_encrypt_def prf_encrypt_oracle_def intro!: rel_spmf_bind_reflI)
  have bisim2: "\<And>cipher \<sigma> s. rel_spmf ?I (exec_gpv ?oracle2 (\2 cipher \<sigma>) ((), s)) (exec_gpv rf_encrypt (\2 cipher \<sigma>) s)"
    by(rule exec_gpv_oracle_bisim[where X="\<lambda>(_, s) s'. s = s'"])
      (auto simp add: prf_encrypt_oracle_def rf_encrypt_def intro!: rel_spmf_bind_reflI)
  have game1_2 [unfolded spmf_rel_eq]: "rel_spmf (=) (prf.game_1 (prf_adversary \)) game2"
    unfolding prf.game_1_def game2_def prf_adversary_def
    by(rewrite in "if _ then \<hole> else _" rf_encrypt_def)
      (auto simp add: Let_def \ if_distribs intro!: rel_spmf_bindI[OF bisim2] rel_spmf_bind_reflI rel_spmf_bindI[OF bisim1])

  define game2_a where "game2_a = do {
    r \<leftarrow> spmf_of_set (nlists UNIV len);
    (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
    let bad = r \<in> dom s1;
    if valid_plain p0 \<and> valid_plain p1 then do {
      b \<leftarrow> coin_spmf;
      let pb = (if b then p0 else p1);
      (pad, s2) \<leftarrow> prf.random_oracle s1 r;
      let cipher = (r, xor_list pb pad);
      (b', s3) \<leftarrow> exec_gpv rf_encrypt (\2 cipher \<sigma>) s2;
      return_spmf (b' = b, bad)
    } else coin_spmf \<bind> (\<lambda>b. return_spmf (b, bad))
  }"
  define game2_b where "game2_b = do {
    r \<leftarrow> spmf_of_set (nlists UNIV len);
    (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
    let bad = r \<in> dom s1;
    if valid_plain p0 \<and> valid_plain p1 then do {
      b \<leftarrow> coin_spmf;
      let pb = (if b then p0 else p1);
      pad \<leftarrow> spmf_of_set (nlists UNIV len);
      let cipher = (r, xor_list pb pad);
      (b', s3) \<leftarrow> exec_gpv rf_encrypt (\2 cipher \<sigma>) (s1(r \<mapsto> pad));
      return_spmf (b' = b, bad)
    } else coin_spmf \<bind> (\<lambda>b. return_spmf (b, bad))
  }"

  have "game2 = do {
      r \<leftarrow> spmf_of_set (nlists UNIV len);
      (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
      if valid_plain p0 \<and> valid_plain p1 then do {
        b \<leftarrow> coin_spmf;
        let pb = (if b then p0 else p1);
        (pad, s2) \<leftarrow> prf.random_oracle s1 r;
        let cipher = (r, xor_list pb pad);
        (b', s3) \<leftarrow> exec_gpv rf_encrypt (\2 cipher \<sigma>) s2;
        return_spmf (b' = b)
      } else coin_spmf
    }"
    including monad_normalisation by(simp add: game2_def split_def rf_encrypt_def Let_def)
  also have "\<dots> = map_spmf fst game2_a" unfolding game2_a_def
    by(clarsimp simp add: map_spmf_conv_bind_spmf Let_def if_distribR if_distrib split_def cong: if_cong)
  finally have game2_2a: "game2 = \<dots>"  .

  have "map_spmf snd game2_a = map_spmf snd game2_b" unfolding game2_a_def game2_b_def
    by(auto simp add: o_def Let_def split_def if_distribs weight2 split: option.split intro: bind_spmf_cong[OF refl])
  moreover
  have "rel_spmf (=) (map_spmf fst (game2_a \<upharpoonleft> (snd -` {False}))) (map_spmf fst (game2_b \<upharpoonleft> (snd -` {False})))"
    unfolding game2_a_def game2_b_def
    by(clarsimp simp add: restrict_bind_spmf o_def Let_def if_distribs split_def restrict_return_spmf prf.random_oracle_def intro!: rel_spmf_bind_reflI split: option.splits)
  hence "spmf game2_a (True, False) = spmf game2_b (True, False)"
     unfolding spmf_rel_eq by(subst (1 2) spmf_map_restrict[symmetric]) simp
  ultimately
  have game2a_2b: "\<bar>spmf (map_spmf fst game2_a) True - spmf (map_spmf fst game2_b) True\<bar> \<le> spmf (map_spmf snd game2_a) True"
    by(subst (1 2) spmf_conv_measure_spmf)(rule identical_until_bad; simp add: spmf.map_id[unfolded id_def] spmf_conv_measure_spmf)

  define game2_a_bad where "game2_a_bad = do {
      r \<leftarrow> spmf_of_set (nlists UNIV len);
      (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
      return_spmf (r \<in> dom s1)
    }"
  have game2a_bad: "map_spmf snd game2_a = game2_a_bad"
    unfolding game2_a_def game2_a_bad_def
    by(auto intro!: bind_spmf_cong[OF refl] simp add: o_def weight2 Let_def split_def split: if_split)
  have card: "\<And>B :: bool list set. card (B \<inter> nlists UNIV len) \<le> card (nlists UNIV len :: bool list set)"
    by(rule card_mono) simp_all
  then have "spmf game2_a_bad True = \<integral>\<^sup>+ x. card (dom (snd x) \<inter> nlists UNIV len) / 2 ^ len \<partial>measure_spmf (exec_gpv rf_encrypt \1 Map.empty)"
    unfolding game2_a_bad_def
    by(rewrite bind_commute_spmf)(simp add: ennreal_spmf_bind split_def map_mem_spmf_of_set[unfolded map_spmf_conv_bind_spmf] card_nlists)
  also { fix x s
    assume *: "(x, s) \<in> set_spmf (exec_gpv rf_encrypt \1 Map.empty)"
    hence "finite (dom s)" by(rule rf_finite.exec_gpv_invariant) simp_all
    hence 1: "card (dom s \<inter> nlists UNIV len) \<le> card (dom s)" by(intro card_mono) simp_all
    moreover from q1 *
    have "card (dom s) \<le> q1 + card (dom (Map.empty :: (plain, plain) prf.dict))"
      by(rule rf_finite.interaction_bounded_by'_exec_gpv_count)
        (auto simp add: rf_encrypt_def eSuc_enat prf.random_oracle_def card_insert_if split: option.split_asm if_split)
    ultimately have "card (dom s \<inter> nlists UNIV len) \<le> q1" by(simp) }
  then have "\<dots> \<le>  \<integral>\<^sup>+ x. q1 / 2 ^ len \<partial>measure_spmf (exec_gpv rf_encrypt \1 Map.empty)"
    by(intro nn_integral_mono_AE)(clarsimp simp add: field_simps)
  also have "\<dots> \<le> q1 / 2 ^ len"
    by(simp add: measure_spmf.emeasure_eq_measure field_simps mult_left_le weight1)
  finally have game2a_bad_bound: "spmf game2_a_bad True \<le> q1 / 2 ^ len" by simp

  define rf_encrypt_bad
    where "rf_encrypt_bad = (\<lambda>secret (s :: (plain, plain) prf.dict, bad) plain. bind_spmf
     (spmf_of_set (nlists UNIV len)) (\<lambda>r.
     bind_spmf (prf.random_oracle s r) (\<lambda>(pad, s').
     return_spmf ((r, xor_list plain pad), (s', bad \<or> r = secret)))))"
  have rf_encrypt_bad_sticky [simp]: "\<And>s. callee_invariant (rf_encrypt_bad s) snd"
    by(unfold_locales)(auto simp add: rf_encrypt_bad_def)
  have lossless_rf_encrypt [simp]: "\<And>challenge s plain. lossless_spmf (rf_encrypt_bad challenge s plain)"
    by(clarsimp simp add: rf_encrypt_bad_def prf.random_oracle_def split: option.split)

  define game2_c where "game2_c = do {
    r \<leftarrow> spmf_of_set (nlists UNIV len);
    (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
    if valid_plain p0 \<and> valid_plain p1 then do {
      b \<leftarrow> coin_spmf;
      let pb = (if b then p0 else p1);
      pad \<leftarrow> spmf_of_set (nlists UNIV len);
      let cipher = (r, xor_list pb pad);
      (b', (s2, bad)) \<leftarrow> exec_gpv (rf_encrypt_bad r) (\2 cipher \<sigma>) (s1(r \<mapsto> pad), False);
      return_spmf (b' = b, bad)
    } else coin_spmf \<bind> (\<lambda>b. return_spmf (b, False))
  }"

  have bisim2c_bad: "\<And>cipher \<sigma> s x r. rel_spmf (\<lambda>(x, _) (y, _). x = y)
    (exec_gpv rf_encrypt (\2 cipher \<sigma>) (s(x \<mapsto> r)))
    (exec_gpv (rf_encrypt_bad x) (\2 cipher \<sigma>) (s(x \<mapsto> r), False))"
    by(rule exec_gpv_oracle_bisim[where X="\<lambda>s (s', _). s = s'"])
      (auto simp add: rf_encrypt_bad_def rf_encrypt_def intro!: rel_spmf_bind_reflI)

  have game2b_c [unfolded spmf_rel_eq]: "rel_spmf (=) (map_spmf fst game2_b) (map_spmf fst game2_c)"
    by(auto simp add: game2_b_def game2_c_def o_def split_def Let_def if_distribs intro!: rel_spmf_bind_reflI rel_spmf_bindI[OF bisim2c_bad])

  define game2_d where "game2_d = do {
    r \<leftarrow> spmf_of_set (nlists UNIV len);
    (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
    if valid_plain p0 \<and> valid_plain p1 then do {
      b \<leftarrow> coin_spmf;
      let pb = (if b then p0 else p1);
      pad \<leftarrow> spmf_of_set (nlists UNIV len);
      let cipher = (r, xor_list pb pad);
      (b', (s2, bad)) \<leftarrow> exec_gpv (rf_encrypt_bad r) (\2 cipher \<sigma>) (s1, False);
      return_spmf (b' = b, bad)
    } else coin_spmf \<bind> (\<lambda>b. return_spmf (b, False))
  }"

  { fix cipher \<sigma> and x :: plain and s r
    let ?I = "(\<lambda>(x, s, bad) (y, s', bad'). (bad \<longleftrightarrow> bad') \<and> (\<not> bad' \<longrightarrow> x \<longleftrightarrow> y))"
    let ?X = "\<lambda>(s, bad) (s', bad'). bad = bad' \<and> (\<forall>z. z \<noteq> x \<longrightarrow> s z = s' z)"
    have "\<And>s1 s2 x'. ?X s1 s2 \<Longrightarrow> rel_spmf (\<lambda>(a, s1') (b, s2'). snd s1' = snd s2' \<and> (\<not> snd s2' \<longrightarrow> a = b \<and> ?X s1' s2'))
       (rf_encrypt_bad x s1 x') (rf_encrypt_bad x s2 x')"
      by(case_tac "x = x'")(clarsimp simp add: rf_encrypt_bad_def prf.random_oracle_def rel_spmf_return_spmf1 rel_spmf_return_spmf2 Let_def split_def bind_UNION intro!: rel_spmf_bind_reflI split: option.split)+
    with _ _ have "rel_spmf ?I
             (exec_gpv (rf_encrypt_bad x) (\2 cipher \<sigma>) (s(x \<mapsto> r), False))
             (exec_gpv (rf_encrypt_bad x) (\2 cipher \<sigma>) (s, False))"
      by(rule exec_gpv_oracle_bisim_bad_full)(auto simp add: lossless2) }
  note bisim_bad = this
  have game2c_2d_bad [unfolded spmf_rel_eq]: "rel_spmf (=) (map_spmf snd game2_c) (map_spmf snd game2_d)"
    by(auto simp add: game2_c_def game2_d_def o_def Let_def split_def if_distribs intro!: rel_spmf_bind_reflI rel_spmf_bindI[OF bisim_bad])
  moreover
  have "rel_spmf (=) (map_spmf fst (game2_c \<upharpoonleft> (snd -` {False}))) (map_spmf fst (game2_d \<upharpoonleft> (snd -` {False})))"
    unfolding game2_c_def game2_d_def
    by(clarsimp simp add: restrict_bind_spmf o_def Let_def if_distribs split_def restrict_return_spmf intro!: rel_spmf_bind_reflI rel_spmf_bindI[OF bisim_bad])
  hence "spmf game2_c (True, False) = spmf game2_d (True, False)"
    unfolding spmf_rel_eq by(subst (1 2) spmf_map_restrict[symmetric]) simp
  ultimately have game2c_2d: "\<bar>spmf (map_spmf fst game2_c) True - spmf (map_spmf fst game2_d) True\<bar> \<le> spmf (map_spmf snd game2_c) True"
    apply(subst (1 2) spmf_conv_measure_spmf)
    apply(intro identical_until_bad)
    apply(simp_all add: spmf.map_id[unfolded id_def] spmf_conv_measure_spmf)
    done
  { fix cipher \<sigma> and challenge :: plain and s
    have "card (nlists UNIV len \<inter> (\<lambda>x. x = challenge) -` {True}) \<le> card {challenge}"
      by(rule card_mono) auto
    then have "spmf (map_spmf (snd \<circ> snd) (exec_gpv (rf_encrypt_bad challenge) (\2 cipher \<sigma>) (s, False))) True \<le> (1 / 2 ^ len) * q2"
      by(intro oi_True.interaction_bounded_by_exec_gpv_bad[OF q2])(simp_all add: rf_encrypt_bad_def o_def split_beta map_spmf_conv_bind_spmf[symmetric] spmf_map measure_spmf_of_set field_simps card_nlists)
    hence "(\<integral>\<^sup>+ x. ennreal (indicator {True} x) \<partial>measure_spmf (map_spmf (snd \<circ> snd) (exec_gpv (rf_encrypt_bad challenge) (\2 cipher \<sigma>) (s, False)))) \<le> (1 / 2 ^ len) * q2"
      by(simp only: ennreal_indicator nn_integral_indicator sets_measure_spmf sets_count_space Pow_UNIV UNIV_I emeasure_spmf_single) simp }
  then have "spmf (map_spmf snd game2_d) True \<le>
        \<integral>\<^sup>+ (r :: plain). \<integral>\<^sup>+ (((p0, p1), \<sigma>), s). (if valid_plain p0 \<and> valid_plain p1 then
             \<integral>\<^sup>+ b . \<integral>\<^sup>+ (pad :: plain). q2 / 2 ^ len \<partial>measure_spmf (spmf_of_set (nlists UNIV len)) \<partial>measure_spmf coin_spmf
              else 0)
           \<partial>measure_spmf (exec_gpv rf_encrypt \1 Map.empty) \<partial>measure_spmf (spmf_of_set (nlists UNIV len))"
      unfolding game2_d_def
      by(simp add: ennreal_spmf_bind o_def split_def Let_def if_distribs if_distrib[where f="\<lambda>x. ennreal (spmf x _)"] indicator_single_Some nn_integral_mono if_mono_cong del: nn_integral_const cong: if_cong)
  also have "\<dots> \<le> \<integral>\<^sup>+ (r :: plain). \<integral>\<^sup>+ (((p0, p1), \<sigma>), s). (if valid_plain p0 \<and> valid_plain p1 then ennreal (q2 / 2 ^ len) else q2 / 2 ^ len)
                   \<partial>measure_spmf (exec_gpv rf_encrypt \1 Map.empty) \<partial>measure_spmf (spmf_of_set (nlists UNIV len))"
    unfolding split_def
    by(intro nn_integral_mono if_mono_cong)(auto simp add: measure_spmf.emeasure_eq_measure)
  also have "\<dots> \<le> q2 / 2 ^ len" by(simp add: split_def weight1 measure_spmf.emeasure_eq_measure)
  finally have game2_d_bad: "spmf (map_spmf snd game2_d) True \<le> q2 / 2 ^ len" by simp

  define game3 where "game3 = do {
      (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
      if valid_plain p0 \<and> valid_plain p1 then do {
        b \<leftarrow> coin_spmf;
        let pb = (if b then p0 else p1);
        r \<leftarrow> spmf_of_set (nlists UNIV len);
        pad \<leftarrow> spmf_of_set (nlists UNIV len);
        let cipher = (r, xor_list pb pad);
        (b', s2) \<leftarrow> exec_gpv rf_encrypt (\2 cipher \<sigma>) s1;
        return_spmf (b' = b)
      } else coin_spmf
    }"
  have bisim2d_3: "\<And>cipher \<sigma> s r. rel_spmf (\<lambda>(x, _) (y, _). x = y)
             (exec_gpv (rf_encrypt_bad r) (\2 cipher \<sigma>) (s, False))
             (exec_gpv rf_encrypt (\2 cipher \<sigma>) s)"
    by(rule exec_gpv_oracle_bisim[where X="\<lambda>(s1, _) s2. s1 = s2"])(auto simp add: rf_encrypt_bad_def rf_encrypt_def intro!: rel_spmf_bind_reflI)
  have game2d_3: "rel_spmf (=) (map_spmf fst game2_d) game3"
    unfolding game2_d_def game3_def Let_def including monad_normalisation
    by(clarsimp simp add: o_def split_def if_distribs cong: if_cong intro!: rel_spmf_bind_reflI rel_spmf_bindI[OF bisim2d_3])

  have "\<bar>spmf game2 True - 1 / 2\<bar> \<le>
    \<bar>spmf (map_spmf fst game2_a) True - spmf (map_spmf fst game2_b) True\<bar> + \<bar>spmf (map_spmf fst game2_b) True - 1 / 2\<bar>"
    unfolding game2_2a by(rule abs_diff_triangle_ineq2)
  also have "\<dots> \<le> q1 / 2 ^ len + \<bar>spmf (map_spmf fst game2_b) True - 1 / 2\<bar>"
    using game2a_2b game2a_bad_bound unfolding game2a_bad by(intro add_right_mono) simp
  also have "\<bar>spmf (map_spmf fst game2_b) True - 1 / 2\<bar> \<le>
    \<bar>spmf (map_spmf fst game2_c) True - spmf (map_spmf fst game2_d) True\<bar> + \<bar>spmf (map_spmf fst game2_d) True - 1 / 2\<bar>"
    unfolding game2b_c by(rule abs_diff_triangle_ineq2)
  also (add_left_mono_trans) have "\<dots> \<le> q2 / 2 ^ len + \<bar>spmf (map_spmf fst game2_d) True - 1 / 2\<bar>"
    using game2c_2d game2_d_bad unfolding game2c_2d_bad by(intro add_right_mono) simp
  finally (add_left_mono_trans)
  have game2: "\<bar>spmf game2 True - 1 / 2\<bar> \<le> q1 / 2 ^ len + q2 / 2 ^ len +  \<bar>spmf game3 True - 1 / 2\<bar>"
    using game2d_3 by(simp add: field_simps spmf_rel_eq)

  have "game3 = do {
      (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
      if valid_plain p0 \<and> valid_plain p1 then do {
        b \<leftarrow> coin_spmf;
        let pb = (if b then p0 else p1);
        r \<leftarrow> spmf_of_set (nlists UNIV len);
        pad \<leftarrow> map_spmf (xor_list pb) (spmf_of_set (nlists UNIV len));
        let cipher = (r, xor_list pb pad);
        (b', s2) \<leftarrow> exec_gpv rf_encrypt (\2 cipher \<sigma>) s1;
        return_spmf (b' = b)
      } else coin_spmf
    }"
    by(simp add: valid_plain_def game3_def Let_def one_time_pad del: bind_map_spmf map_spmf_of_set_inj_on cong: bind_spmf_cong_simp if_cong split: if_split)
  also have "\<dots> = do {
       (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
       if valid_plain p0 \<and> valid_plain p1 then do {
         b \<leftarrow> coin_spmf;
         let pb = (if b then p0 else p1);
         r \<leftarrow> spmf_of_set (nlists UNIV len);
         pad \<leftarrow> spmf_of_set (nlists UNIV len);
         let cipher = (r, pad);
         (b', _) \<leftarrow> exec_gpv rf_encrypt (\2 cipher \<sigma>) s1;
         return_spmf (b' = b)
       } else coin_spmf
     }"
     by(simp add: game3_def Let_def valid_plain_def in_nlists_UNIV cong: bind_spmf_cong_simp if_cong split: if_split)
  also have "\<dots> = do {
      (((p0, p1), \<sigma>), s1) \<leftarrow> exec_gpv rf_encrypt \1 Map.empty;
      if valid_plain p0 \<and> valid_plain p1 then do {
        r \<leftarrow> spmf_of_set (nlists UNIV len);
        pad \<leftarrow> spmf_of_set (nlists UNIV len);
        let cipher = (r, pad);
        (b', _) \<leftarrow> exec_gpv rf_encrypt (\2 cipher \<sigma>) s1;
        map_spmf ((=) b') coin_spmf
      } else coin_spmf
    }"
    including monad_normalisation by(simp add: map_spmf_conv_bind_spmf split_def Let_def)
  also have "\<dots> = coin_spmf"
    by(simp add: map_eq_const_coin_spmf Let_def split_def weight2 weight1)
  finally have game3: "game3 = coin_spmf" .

  have "ind_cpa.advantage \ \<le> prf.advantage (prf_adversary \) + \<bar>spmf (prf.game_1 (prf_adversary \)) True - 1 / 2\<bar>"
    unfolding ind_cpa.advantage_def prf.advantage_def ind_cpa_0[unfolded spmf_rel_eq]
    by(rule abs_diff_triangle_ineq2)
  also have "\<bar>spmf (prf.game_1 (prf_adversary \)) True - 1 / 2\<bar> \<le> q1 / 2 ^ len + q2 / 2 ^ len"
    using game1_2 game2 game3 by(simp add: spmf_of_set)
  also have "\<dots> = (q1 + q2) / 2 ^ len" by(simp add: field_simps)
  also have "\<dots> \<le> q / 2 ^ len" using \<open>q1 + q2 \<le> q\<close> by(simp add: divide_right_mono)
  finally show ?thesis by(simp add: field_simps)
qed

lemma interaction_bounded_prf_adversary:
  fixes q :: nat
  assumes "ind_cpa.ibounded_by \ q"
  shows "prf.ibounded_by (prf_adversary \) (1 + q)"
proof -
  fix \<eta>
  from assms have "ind_cpa.ibounded_by \ q" by blast
  then obtain q1 q2 where q: "q1 + q2 \<le> q"
    and [interaction_bound]: "interaction_any_bounded_by (fst \) q1"
       "\<And>x \<sigma>. interaction_any_bounded_by (snd \ x \<sigma>) q2"
    unfolding ind_cpa.ibounded_by_def by(auto simp add: split_beta iadd_le_enat_iff)
  show "prf.ibounded_by (prf_adversary \) (1 + q)" using q
    apply (simp only: prf_adversary_def Let_def split_def)
    apply -
    apply interaction_bound
      apply (auto simp add: iadd_SUP_le_iff SUP_le_iff add.assoc [symmetric] one_enat_def cong del: image_cong_simp cong add: SUP_cong_simp)
    done
qed

lemma lossless_prf_adversary: "ind_cpa.lossless \ \<Longrightarrow> prf.lossless (prf_adversary \)"
by(fastforce simp add: prf_adversary_def Let_def split_def ind_cpa.lossless_def intro: lossless_inline)

end

locale otp_\<eta> =
  fixes f :: "security \<Rightarrow> key \<Rightarrow> bool list \<Rightarrow> bool list"
  and len :: "security \<Rightarrow> nat"
  assumes length_f: "\<And>\<eta> xs ys. \<lbrakk> length xs = len \<eta>; length ys = len \<eta> \<rbrakk> \<Longrightarrow> length (f \<eta> xs ys) = len \<eta>"
  and negligible_len [negligible_intros]: "negligible (\<lambda>\<eta>. 1 / 2 ^ (len \<eta>))"
begin

interpretation otp "f \<eta>" "len \<eta>" for \<eta> by(unfold_locales)(rule length_f)
interpretation ind_cpa: ind_cpa "key_gen \<eta>" "encrypt \<eta>" "decrypt \<eta>" "valid_plain \<eta>" for \<eta> .
interpretation "prf": "prf" "key_gen \<eta>" "f \<eta>" "spmf_of_set (nlists UNIV (len \<eta>))" for \<eta> .

lemma prf_encrypt_secure_for:
  assumes [negligible_intros]: "negligible (\<lambda>\<eta>. prf.advantage \<eta> (prf_adversary \<eta> (\ \<eta>)))"
  and q: "\<And>\<eta>. ind_cpa.ibounded_by (\ \<eta>) (q \<eta>)" and [negligible_intros]: "polynomial q"
  and lossless: "\<And>\<eta>. ind_cpa.lossless (\ \<eta>)"
  shows "negligible (\<lambda>\<eta>. ind_cpa.advantage \<eta> (\ \<eta>))"
proof(rule negligible_mono)
  show "negligible (\<lambda>\<eta>. prf.advantage \<eta> (prf_adversary \<eta> (\ \<eta>)) + q \<eta> / 2 ^ len \<eta>)"
    by(intro negligible_intros)
  { fix \<eta>
    from \<open>ind_cpa.ibounded_by _ _\<close> have "ind_cpa.ibounded_by (\ \<eta>) (q \<eta>)" by blast
    moreover from lossless have "ind_cpa.lossless (\ \<eta>)" by blast
    hence "lossless_gpv \_full (fst (\ \<eta>))" "\<And>cipher \<sigma>. lossless_gpv \_full (snd (\ \<eta>) cipher \<sigma>)"
      by(auto simp add: ind_cpa.lossless_def)
    ultimately have "ind_cpa.advantage \<eta> (\ \<eta>) \<le> prf.advantage \<eta> (prf_adversary \<eta> (\ \<eta>)) + q \<eta> / 2 ^ len \<eta>"
      by(rule prf_encrypt_advantage) }
  hence "eventually (\<lambda>\<eta>. \<bar>ind_cpa.advantage \<eta> (\ \<eta>)\<bar> \<le> 1 * \<bar>prf.advantage \<eta> (prf_adversary \<eta> (\ \<eta>)) + q \<eta> / 2 ^ len \<eta>\<bar>) at_top"
    by(simp add: always_eventually ind_cpa.advantage_nonneg prf.advantage_nonneg)
  then show "(\<lambda>\<eta>. ind_cpa.advantage \<eta> (\ \<eta>)) \<in> O(\<lambda>\<eta>. prf.advantage \<eta> (prf_adversary \<eta> (\ \<eta>)) + q \<eta> / 2 ^ len \<eta>)"
    by(intro bigoI[where c=1]) simp
qed

end

end