(* Title: PRF_UPF_IND_CCA.thy
  Author: Andreas Lochbihler, ETH Zurich
  Author: S. Reza Sefidgar, ETH Zurich *)

subsection \<open>IND-CCA from a PRF and an unpredictable function\<close>

theory PRF_UPF_IND_CCA
imports
  Pseudo_Random_Function
  CryptHOL.List_Bits
  Unpredictable_Function
  IND_CCA2_sym
  CryptHOL.Negligible
begin

text \<open>Formalisation of Shoup's construction of an IND-CCA secure cipher from a PRF and an unpredictable function \<^cite>\<open>\<open>\S 7\<close> in "Shoup2004IACR"\<close>.\<close>

type_synonym bitstring = "bool list"

locale simple_cipher =
  PRF: "prf" prf_key_gen prf_fun "spmf_of_set (nlists UNIV prf_clen)" +
  UPF: upf upf_key_gen upf_fun
  for prf_key_gen :: "'prf_key spmf"
  and prf_fun :: "'prf_key \<Rightarrow> bitstring \<Rightarrow> bitstring"
  and prf_domain :: "bitstring set"
  and prf_range :: "bitstring set"
  and prf_dlen :: nat
  and prf_clen :: nat
  and upf_key_gen :: "'upf_key spmf"
  and upf_fun :: "'upf_key \<Rightarrow> bitstring \<Rightarrow> 'hash"
  +
  assumes prf_domain_finite: "finite prf_domain"
  assumes prf_domain_nonempty: "prf_domain \<noteq> {}"
  assumes prf_domain_length:  "x \<in> prf_domain \<Longrightarrow> length x = prf_dlen"
  assumes prf_codomain_length:
    "\<lbrakk> key_prf \<in> set_spmf prf_key_gen; m \<in> prf_domain \<rbrakk> \<Longrightarrow> length (prf_fun key_prf m) = prf_clen"
  assumes prf_key_gen_lossless: "lossless_spmf prf_key_gen"
  assumes upf_key_gen_lossless: "lossless_spmf upf_key_gen"
begin

type_synonym 'hash' cipher_text = "bitstring \<times> bitstring \<times> 'hash'"

definition key_gen :: "('prf_key \<times> 'upf_key) spmf" where
 "key_gen = do {
   k_prf \<leftarrow> prf_key_gen;
   k_upf :: 'upf_key \<leftarrow> upf_key_gen;
   return_spmf (k_prf, k_upf)
 }"

lemma lossless_key_gen [simp]: "lossless_spmf key_gen"
  by(simp add: key_gen_def prf_key_gen_lossless upf_key_gen_lossless)

fun encrypt :: "('prf_key \<times> 'upf_key) \<Rightarrow> bitstring \<Rightarrow> 'hash cipher_text spmf"
where
  "encrypt (k_prf, k_upf) m = do {
    x \<leftarrow> spmf_of_set prf_domain;
    let c = prf_fun k_prf x [\<oplus>] m;
    let t = upf_fun k_upf (x @ c);
    return_spmf ((x, c, t))
  }"

lemma lossless_encrypt [simp]: "lossless_spmf (encrypt k m)"
  by (cases k) (simp add: Let_def prf_domain_nonempty prf_domain_finite split: bool.split)

fun decrypt :: "('prf_key \<times> 'upf_key) \<Rightarrow> 'hash cipher_text \<Rightarrow> bitstring option"
where
  "decrypt (k_prf, k_upf) (x, c, t) = (
    if upf_fun k_upf (x @ c) = t \<and> length x = prf_dlen then
      Some (prf_fun k_prf x [\<oplus>] c)
    else
      None
  )"

lemma cipher_correct:
  "\<lbrakk> k \<in> set_spmf key_gen; length m = prf_clen \<rbrakk>
  \<Longrightarrow> encrypt k m \<bind> (\<lambda>c. return_spmf (decrypt k c)) = return_spmf (Some m)"
by (cases k) (simp add: prf_domain_nonempty prf_domain_finite prf_domain_length
  prf_codomain_length key_gen_def bind_eq_return_spmf Let_def)

declare encrypt.simps[simp del]

sublocale ind_cca: ind_cca key_gen encrypt decrypt "\<lambda>m. length m = prf_clen" .
interpretation ind_cca': ind_cca key_gen encrypt "\<lambda> _ _. None" "\<lambda>m. length m = prf_clen" .

definition intercept_upf_enc
  :: "'prf_key \<Rightarrow> bool \<Rightarrow> 'hash cipher_text set \<times> 'hash cipher_text set \<Rightarrow> bitstring \<times> bitstring
  \<Rightarrow> ('hash cipher_text option \<times> ('hash cipher_text set \<times> 'hash cipher_text set),
     bitstring + (bitstring \<times> 'hash), 'hash + unit) gpv"
where
  "intercept_upf_enc k b = (\<lambda>(L, D) (m1, m0).
    (case (length m1 = prf_clen \<and> length m0 = prf_clen) of
      False \<Rightarrow> Done (None, L, D)
    | True \<Rightarrow> do {
        x \<leftarrow> lift_spmf (spmf_of_set prf_domain);
        let c = prf_fun k x [\<oplus>] (if b then m1 else m0);
        t \<leftarrow> Pause (Inl (x @ c)) Done;
        Done ((Some (x, c, projl t)), (insert (x, c, projl t) L, D))
      }))"

definition intercept_upf_dec
  :: "'hash cipher_text set \<times> 'hash cipher_text set \<Rightarrow> 'hash cipher_text
  \<Rightarrow> (bitstring option \<times> ('hash cipher_text set \<times> 'hash cipher_text set),
     bitstring + (bitstring \<times> 'hash), 'hash + unit) gpv"
where
  "intercept_upf_dec = (\<lambda>(L, D) (x, c, t).
    if (x, c, t) \<in> L \<or> length x \<noteq> prf_dlen then Done (None, (L, D)) else do {
      Pause (Inr (x @ c, t)) Done;
      Done (None, (L, insert (x, c, t) D))
    })"

definition intercept_upf ::
  "'prf_key \<Rightarrow> bool \<Rightarrow> 'hash cipher_text set \<times> 'hash cipher_text set \<Rightarrow> bitstring \<times> bitstring + 'hash cipher_text
  \<Rightarrow> (('hash cipher_text option + bitstring option) \<times> ('hash cipher_text set \<times> 'hash cipher_text set),
     bitstring + (bitstring \<times> 'hash), 'hash + unit) gpv"
where
  "intercept_upf k b = plus_intercept (intercept_upf_enc k b) intercept_upf_dec"

lemma intercept_upf_simps [simp]:
  "intercept_upf k b (L, D) (Inr (x, c, t)) =
    (if (x, c, t) \<in> L \<or> length x \<noteq> prf_dlen then Done (Inr None, (L, D)) else do {
      Pause (Inr (x @ c, t)) Done;
      Done (Inr None, (L, insert (x, c, t) D))
    })"
  "intercept_upf k b (L, D) (Inl (m1, m0)) =
    (case (length m1 = prf_clen \<and> length m0 = prf_clen) of
      False \<Rightarrow> Done (Inl None, L, D)
    | True \<Rightarrow> do {
        x \<leftarrow> lift_spmf (spmf_of_set prf_domain);
        let c = prf_fun k x [\<oplus>] (if b then m1 else m0);
        t \<leftarrow> Pause (Inl (x @ c)) Done;
        Done (Inl (Some (x, c, projl t)), (insert (x, c, projl t) L, D))
      })"
   by(simp_all add: intercept_upf_def intercept_upf_dec_def intercept_upf_enc_def o_def map_gpv_bind_gpv gpv.map_id Let_def split!: bool.split)

lemma interaction_bounded_by_upf_enc_Inr [interaction_bound]:
  "interaction_bounded_by (Not \<circ> isl) (intercept_upf_enc k b LD mm) 0"
unfolding intercept_upf_enc_def case_prod_app
by(interaction_bound, clarsimp simp add: SUP_constant bot_enat_def split: prod.split)

lemma interaction_bounded_by_upf_dec_Inr [interaction_bound]:
  "interaction_bounded_by (Not \<circ> isl) (intercept_upf_dec LD c) 1"
unfolding intercept_upf_dec_def case_prod_app
by(interaction_bound, clarsimp simp add: SUP_constant split: prod.split)

lemma interaction_bounded_by_intercept_upf_Inr [interaction_bound]:
  "interaction_bounded_by (Not \<circ> isl) (intercept_upf k b LD x) 1"
unfolding intercept_upf_def
by interaction_bound(simp add: split_def one_enat_def SUP_le_iff split: sum.split)

lemma interaction_bounded_by_intercept_upf_Inl [interaction_bound]:
  "isl x \<Longrightarrow> interaction_bounded_by (Not \<circ> isl) (intercept_upf k b LD x) 0"
unfolding intercept_upf_def case_prod_app
by interaction_bound(auto split: sum.split)

lemma lossless_intercept_upf_enc [simp]: "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) (intercept_upf_enc k b LD mm)"
by(simp add: intercept_upf_enc_def split_beta prf_domain_finite prf_domain_nonempty Let_def split: bool.split)

lemma lossless_intercept_upf_dec [simp]: "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) (intercept_upf_dec LD mm)"
by(simp add: intercept_upf_dec_def split_beta)

lemma lossless_intercept_upf [simp]: "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) (intercept_upf k b LD x)"
by(cases x)(simp_all add: intercept_upf_def)

lemma results_gpv_intercept_upf [simp]: "results_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) (intercept_upf k b LD x) \<subseteq> responses_\<I> (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) x \<times> UNIV"
by(cases x)(auto simp add: intercept_upf_def)

definition reduction_upf :: "(bitstring, 'hash cipher_text) ind_cca.adversary
  \<Rightarrow> (bitstring, 'hash) UPF.adversary"
where "reduction_upf \<A> = do {
    k \<leftarrow> lift_spmf prf_key_gen;
    b \<leftarrow> lift_spmf coin_spmf;
    (_, (L, D)) \<leftarrow> inline (intercept_upf k b) \<A> ({}, {});
    Done () }"

lemma lossless_reduction_upf [simp]:
  "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) \<A> \<Longrightarrow> lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) (reduction_upf \<A>)"
by(auto simp add: reduction_upf_def prf_key_gen_lossless intro: lossless_inline del: subsetI)

context includes lifting_syntax begin

lemma round_1:
  assumes "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) \<A>"
  shows "\<bar>spmf (ind_cca.game \<A>) True - spmf (ind_cca'.game \<A>) True\<bar> \<le> UPF.advantage (reduction_upf \<A>)"
proof -
  define oracle_decrypt0' where "oracle_decrypt0' \<equiv> (\<lambda>key (bad, L) (x', c', t'). return_spmf (
      if (x', c', t') \<in> L \<or> length x' \<noteq> prf_dlen then (None, (bad, L))
      else (decrypt key (x', c', t'), (bad \<or> upf_fun (snd key) (x' @ c') = t', L))))"
  have oracle_decrypt0'_simps:
    "oracle_decrypt0' key (bad, L) (x', c', t') = return_spmf (
       if (x', c', t') \<in> L \<or> length x' \<noteq> prf_dlen then (None, (bad, L))
       else (decrypt key (x', c', t'), (bad \<or> upf_fun (snd key) (x' @ c') = t', L)))"
    for key L bad x' c' t' by(simp add: oracle_decrypt0'_def)
  have lossless_oracle_decrypt0' [simp]: "lossless_spmf (oracle_decrypt0' k Lbad c)" for k Lbad c
    by(simp add: oracle_decrypt0'_def split_def)
  have callee_invariant_oracle_decrypt0' [simp]: "callee_invariant (oracle_decrypt0' k) fst" for k
    by (unfold_locales) (auto simp add: oracle_decrypt0'_def split: if_split_asm)

  define oracle_decrypt1'
    where "oracle_decrypt1' = (\<lambda>(key :: 'prf_key \<times> 'upf_key) (bad, L) (x', c', t').
      return_spmf (None :: bitstring option,
        (bad \<or> upf_fun (snd key) (x' @ c') = t' \<and> (x', c', t') \<notin> L \<and> length x' = prf_dlen), L))"
  have oracle_decrypt1'_simps:
    "oracle_decrypt1' key (bad, L) (x', c', t') =
    return_spmf (None,
      (bad \<or> upf_fun (snd key) (x' @ c') = t' \<and> (x', c', t') \<notin> L \<and> length x' = prf_dlen, L))"
    for key L bad x' c' t' by(simp add: oracle_decrypt1'_def)
  have lossless_oracle_decrypt1' [simp]: "lossless_spmf (oracle_decrypt1' k Lbad c)" for k Lbad c
    by(simp add: oracle_decrypt1'_def split_def)
  have callee_invariant_oracle_decrypt1' [simp]: "callee_invariant (oracle_decrypt1' k) fst" for k
    by (unfold_locales) (auto simp add: oracle_decrypt1'_def)

  define game01'
    where "game01' = (\<lambda>(decrypt :: 'prf_key \<times> 'upf_key \<Rightarrow> (bitstring \<times> bitstring \<times> 'hash, bitstring option, bool \<times> (bitstring \<times> bitstring \<times> 'hash) set) callee) \<A>. do {
    key \<leftarrow> key_gen;
    b \<leftarrow> coin_spmf;
    (b', (bad', L')) \<leftarrow> exec_gpv (\<dagger>(ind_cca.oracle_encrypt key b) \<oplus>\<^sub>O decrypt key) \<A> (False, {});
    return_spmf (b = b', bad') })"
  let ?game0' = "game01' oracle_decrypt0'"
  let ?game1' = "game01' oracle_decrypt1'"

  have game0'_eq: "ind_cca.game \<A> = map_spmf fst (?game0' \<A>)" (is ?game0)
    and game1'_eq: "ind_cca'.game \<A> = map_spmf fst (?game1' \<A>)" (is ?game1)
  proof -
    let ?S = "rel_prod2 (=)"
    define initial where "initial = (False, {} :: 'hash cipher_text set)"
    have [transfer_rule]: "?S {} initial" by(simp add: initial_def)

    have [transfer_rule]:
      "((=) ===> ?S ===> (=) ===> rel_spmf (rel_prod (=) ?S))
       ind_cca.oracle_decrypt oracle_decrypt0'"
      unfolding ind_cca.oracle_decrypt_def[abs_def] oracle_decrypt0'_def[abs_def]
      by(simp add: rel_spmf_return_spmf1 rel_fun_def)

    have [transfer_rule]:
      "((=) ===> ?S ===> (=) ===> rel_spmf (rel_prod (=) ?S))
       ind_cca'.oracle_decrypt oracle_decrypt1'"
      unfolding ind_cca'.oracle_decrypt_def[abs_def] oracle_decrypt1'_def[abs_def]
      by (simp add: rel_spmf_return_spmf1 rel_fun_def)

    note [transfer_rule] = extend_state_oracle_transfer
    show ?game0 ?game1 unfolding game01'_def ind_cca.game_def ind_cca'.game_def initial_def[symmetric]
      by (simp_all add: map_spmf_bind_spmf o_def split_def) transfer_prover+
  qed

  have *: "rel_spmf (\<lambda>(b'1, (bad1, L1)) (b'2, (bad2, L2)). bad1 = bad2 \<and> (\<not> bad2 \<longrightarrow> b'1 = b'2))
         (exec_gpv (\<dagger>(ind_cca.oracle_encrypt k b) \<oplus>\<^sub>O oracle_decrypt1' k) \<A> (False, {}))
         (exec_gpv (\<dagger>(ind_cca.oracle_encrypt k b) \<oplus>\<^sub>O oracle_decrypt0' k) \<A> (False, {}))"
    for k b
    by (cases k; rule exec_gpv_oracle_bisim_bad[where X="(=)" and ?bad1.0=fst and ?bad2.0=fst and \<I> = "\<I>_full \<oplus>\<^sub>\<I> \<I>_full"])
       (auto intro: rel_spmf_reflI callee_invariant_extend_state_oracle_const' simp add: spmf_rel_map1 spmf_rel_map2 oracle_decrypt0'_simps oracle_decrypt1'_simps assms split: plus_oracle_split)
    \<comment> \<open>We cannot get rid of the losslessness assumption on @{term \<A>} in this step, because if it
      were not, then the bad event might still occur, but the adversary does not terminate in
      the case of @{term "?game1'"}. Thus, the reduction does not terminate either, but it cannot
      detect whether the bad event has happened. So the advantage in the UPF game could be lower than
      the probability of the bad event, if the adversary is not lossless.\<close>
  have "\<bar>measure (measure_spmf (?game1' \<A>)) {(b, bad). b} - measure (measure_spmf (?game0' \<A>)) {(b, bad). b}\<bar>
     \<le> measure (measure_spmf (?game1' \<A>)) {(b, bad). bad}"
    by (rule fundamental_lemma[where ?bad2.0=snd])(auto intro!: rel_spmf_bind_reflI rel_spmf_bindI[OF *] simp add: game01'_def)
  also have "\<dots> = spmf (map_spmf snd (?game1' \<A>)) True"
    by (simp add: spmf_conv_measure_spmf measure_map_spmf split_def vimage_def)
  also have "map_spmf snd (?game1' \<A>) = UPF.game (reduction_upf \<A>)"
  proof -
    note [split del] = if_split
    have "map_spmf (\<lambda>x. fst (snd x)) (exec_gpv (\<dagger>(ind_cca.oracle_encrypt (k_prf, k_upf) b) \<oplus>\<^sub>O oracle_decrypt1' (k_prf, k_upf)) \<A> (False, {})) =
        map_spmf (\<lambda>x. fst (snd x)) (exec_gpv (UPF.oracle k_upf) (inline (intercept_upf k_prf b) \<A> ({}, {})) (False, {}))"
      (is "map_spmf ?fl ?lhs = map_spmf ?fr ?rhs" is "map_spmf _ (exec_gpv ?oracle_normal _ ?init_normal) = _")
      for k_prf k_upf b
    proof(rule map_spmf_eq_map_spmfI)
      define oracle_intercept
        where [simp]: "oracle_intercept = (\<lambda>(s', s) y. map_spmf (\<lambda>((x, s'), s). (x, s', s))
         (exec_gpv (UPF.oracle k_upf) (intercept_upf k_prf b s' y) s))"
      let ?I = "(\<lambda>((L, D), (flg, Li)).
          (\<forall>(x, c, t) \<in> L. upf_fun k_upf (x @ c) = t \<and> length x = prf_dlen) \<and>
          (\<forall>e\<in>Li. \<exists>(x,c,_) \<in> L. e = x @ c) \<and>
          ((\<exists>(x, c, t) \<in> D. upf_fun k_upf (x @ c) = t) \<longleftrightarrow> flg))"
      interpret callee_invariant_on oracle_intercept "?I" \<I>_full
        apply(unfold_locales)
        subgoal for s x y s'
          apply(cases s; cases s'; cases x)
           apply(clarsimp simp add: set_spmf_of_set_finite[OF prf_domain_finite]
                UPF.oracle_hash_def prf_domain_length exec_gpv_bind Let_def split: bool.splits)
          apply(force simp add: exec_gpv_bind UPF.oracle_flag_def split: if_split_asm)
          done
        subgoal by simp
        done

      define S :: "bool \<times> 'hash cipher_text set \<Rightarrow> ('hash cipher_text set \<times> 'hash cipher_text set) \<times>  bool \<times> bitstring set \<Rightarrow> bool"
        where "S = (\<lambda>(bad, L1) ((L2, D), _). bad = (\<exists>(x, c, t)\<in>D. upf_fun k_upf (x @ c) = t) \<and> L1 = L2) \<upharpoonleft> (\<lambda>_. True) \<otimes> ?I"
      define initial :: "('hash cipher_text set \<times> 'hash cipher_text set) \<times>  bool \<times> bitstring set"
        where "initial = (({}, {}), (False, {}))"
      have [transfer_rule]: "S ?init_normal initial" by(simp add: S_def initial_def)
      have [transfer_rule]: "(S ===> (=) ===> rel_spmf (rel_prod (=) S)) ?oracle_normal oracle_intercept"
        unfolding S_def
        by(rule callee_invariant_restrict_relp, unfold_locales)
          (auto simp add: rel_fun_def bind_spmf_of_set prf_domain_finite prf_domain_nonempty bind_spmf_pmf_assoc bind_assoc_pmf bind_return_pmf spmf_rel_map exec_gpv_bind Let_def ind_cca.oracle_encrypt_def oracle_decrypt1'_def encrypt.simps UPF.oracle_hash_def UPF.oracle_flag_def bind_map_spmf o_def split: plus_oracle_split bool.split if_split intro!: rel_spmf_bind_reflI rel_pmf_bind_reflI)
      have "rel_spmf (rel_prod (=) S) ?lhs (exec_gpv oracle_intercept \<A> initial)"
        by(transfer_prover)
      then show "rel_spmf (\<lambda>x y. ?fl x = ?fr y) ?lhs ?rhs"
        by(auto simp add: S_def exec_gpv_inline spmf_rel_map initial_def elim: rel_spmf_mono)
    qed
    then show ?thesis including monad_normalisation
      by(auto simp add: reduction_upf_def UPF.game_def game01'_def key_gen_def map_spmf_conv_bind_spmf split_def exec_gpv_bind intro!: bind_spmf_cong[OF refl])
  qed
  finally show ?thesis using game0'_eq game1'_eq
    by (auto simp add: spmf_conv_measure_spmf measure_map_spmf vimage_def fst_def UPF.advantage_def)
qed

definition oracle_encrypt2 ::
  "('prf_key \<times> 'upf_key) \<Rightarrow> bool \<Rightarrow> (bitstring, bitstring) PRF.dict \<Rightarrow> bitstring \<times> bitstring
    \<Rightarrow> ('hash cipher_text option \<times> (bitstring, bitstring) PRF.dict) spmf"
where
  "oracle_encrypt2 = (\<lambda>(k_prf, k_upf) b D (msg1, msg0). (case (length msg1 = prf_clen \<and> length msg0 = prf_clen) of
      False \<Rightarrow> return_spmf (None, D)
    | True \<Rightarrow> do {
        x \<leftarrow> spmf_of_set prf_domain;
        P \<leftarrow> spmf_of_set (nlists UNIV prf_clen);
        let p = (case D x of Some r \<Rightarrow> r | None \<Rightarrow> P);
        let c = p [\<oplus>] (if b then msg1 else msg0);
        let t = upf_fun k_upf (x @ c);
        return_spmf (Some (x, c, t), D(x \<mapsto> p))
      }))"

definition oracle_decrypt2:: "('prf_key \<times> 'upf_key) \<Rightarrow> ('hash cipher_text, bitstring option, 'state) callee"
where "oracle_decrypt2 = (\<lambda>key D cipher. return_spmf (None, D))"

lemma lossless_oracle_decrypt2 [simp]: "lossless_spmf (oracle_decrypt2 k Dbad c)"
  by(simp add: oracle_decrypt2_def split_def)

lemma callee_invariant_oracle_decrypt2 [simp]: "callee_invariant (oracle_decrypt2 key) fst"
  by (unfold_locales) (auto simp add: oracle_decrypt2_def split: if_split_asm)

lemma oracle_decrypt2_parametric [transfer_rule]:
  "(rel_prod P U ===> S ===> rel_prod (=) (rel_prod (=) H) ===> rel_spmf (rel_prod (=) S))
   oracle_decrypt2 oracle_decrypt2"
  unfolding oracle_decrypt2_def split_def relator_eq[symmetric] by transfer_prover

definition game2 :: "(bitstring, 'hash cipher_text) ind_cca.adversary \<Rightarrow> bool spmf"
where
  "game2 \<A> \<equiv> do {
    key \<leftarrow> key_gen;
    b \<leftarrow> coin_spmf;
    (b', D) \<leftarrow> exec_gpv
      (oracle_encrypt2 key b \<oplus>\<^sub>O oracle_decrypt2 key) \<A> Map_empty;
    return_spmf (b = b')
  }"

fun intercept_prf ::
  "'upf_key \<Rightarrow> bool \<Rightarrow> unit \<Rightarrow> (bitstring \<times> bitstring) + 'hash cipher_text
  \<Rightarrow> (('hash cipher_text option + bitstring option) \<times> unit, bitstring, bitstring) gpv"
where
  "intercept_prf _ _ _ (Inr _) = Done (Inr None, ())"
| "intercept_prf k b _ (Inl (m1, m0)) = (case (length m1) = prf_clen \<and> (length m0) = prf_clen of
      False \<Rightarrow> Done (Inl None, ())
    | True \<Rightarrow> do {
        x \<leftarrow> lift_spmf (spmf_of_set prf_domain);
        p \<leftarrow> Pause x Done;
        let c = p [\<oplus>] (if b then m1 else m0);
        let t = upf_fun k (x @ c);
        Done (Inl (Some (x, c, t)), ())
      })"

definition reduction_prf
  :: "(bitstring, 'hash cipher_text) ind_cca.adversary \<Rightarrow> (bitstring, bitstring) PRF.adversary"
where
 "reduction_prf \<A> = do {
   k \<leftarrow> lift_spmf upf_key_gen;
   b \<leftarrow> lift_spmf coin_spmf;
   (b', _) \<leftarrow> inline (intercept_prf k b) \<A> ();
   Done (b' = b)
 }"

lemma round_2: "\<bar>spmf (ind_cca'.game \<A>) True - spmf (game2 \<A>) True\<bar> = PRF.advantage (reduction_prf \<A>)"
proof -
  define oracle_encrypt1''
    where "oracle_encrypt1'' = (\<lambda>(k_prf, k_upf) b (_ :: unit) (msg1, msg0).
      case length msg1 = prf_clen \<and> length msg0 = prf_clen of
        False \<Rightarrow> return_spmf (None, ())
      | True \<Rightarrow> do {
          x \<leftarrow> spmf_of_set prf_domain;
          let p = prf_fun k_prf x;
          let c = p [\<oplus>] (if b then msg1 else msg0);
          let t = upf_fun k_upf (x @ c);
          return_spmf (Some (x, c, t), ())})"
  define game1'' where "game1'' = do {
    key \<leftarrow> key_gen;
    b \<leftarrow> coin_spmf;
    (b', D) \<leftarrow> exec_gpv (oracle_encrypt1'' key b \<oplus>\<^sub>O oracle_decrypt2 key) \<A> ();
    return_spmf (b = b')}"

  have "ind_cca'.game \<A> = game1''"
  proof -
    define S where "S = (\<lambda>(L :: 'hash cipher_text set) (D :: unit). True)"
    have [transfer_rule]: "S {} ()" by (simp add: S_def)
    have [transfer_rule]:
      "((=) ===> (=) ===> S ===> (=) ===> rel_spmf (rel_prod (=) S))
       ind_cca'.oracle_encrypt oracle_encrypt1''"
      unfolding ind_cca'.oracle_encrypt_def[abs_def] oracle_encrypt1''_def[abs_def]
      by (auto simp add: rel_fun_def Let_def S_def encrypt.simps prf_domain_finite prf_domain_nonempty intro: rel_spmf_bind_reflI rel_pmf_bind_reflI split: bool.split)
    have [transfer_rule]:
      "((=) ===> S ===> (=) ===> rel_spmf (rel_prod (=) S))
       ind_cca'.oracle_decrypt oracle_decrypt2"
      unfolding ind_cca'.oracle_decrypt_def[abs_def] oracle_decrypt2_def[abs_def]
      by(auto simp add: rel_fun_def)
    show ?thesis unfolding ind_cca'.game_def game1''_def by transfer_prover
  qed

  also have "\<dots> = PRF.game_0 (reduction_prf \<A>)"
  proof -
    { fix k_prf k_upf b
      define oracle_normal
        where "oracle_normal = oracle_encrypt1'' (k_prf, k_upf) b \<oplus>\<^sub>O oracle_decrypt2 (k_prf, k_upf)"
      define oracle_intercept
        where "oracle_intercept = (\<lambda>(s', s :: unit) y. map_spmf (\<lambda>((x, s'), s). (x, s', s)) (exec_gpv (PRF.prf_oracle k_prf) (intercept_prf k_upf b s' y) ()))"
      define initial where "initial = ()"
      define S where "S = (\<lambda>(s2 :: unit, _ :: unit) (s1 :: unit). True)"
      have [transfer_rule]: "S ((), ()) initial" by(simp add: S_def initial_def)
      have [transfer_rule]: "(S ===> (=) ===> rel_spmf (rel_prod (=) S)) oracle_intercept oracle_normal"
        unfolding oracle_normal_def oracle_intercept_def
        by(auto split: bool.split plus_oracle_split simp add: S_def rel_fun_def exec_gpv_bind PRF.prf_oracle_def oracle_encrypt1''_def Let_def map_spmf_conv_bind_spmf oracle_decrypt2_def intro!: rel_spmf_bind_reflI rel_spmf_reflI)
      have "map_spmf (\<lambda>x. b = fst x) (exec_gpv oracle_normal \<A> initial) =
        map_spmf (\<lambda>x. b = fst (fst x)) (exec_gpv (PRF.prf_oracle k_prf) (inline (intercept_prf k_upf b) \<A> ()) ())"
        by(transfer fixing: b \<A> prf_fun k_prf prf_domain prf_clen upf_fun k_upf)
          (auto simp add: map_spmf_eq_map_spmf_iff exec_gpv_inline spmf_rel_map oracle_intercept_def split_def intro: rel_spmf_reflI) }
    then show ?thesis unfolding game1''_def PRF.game_0_def key_gen_def reduction_prf_def
      by (auto simp add: exec_gpv_bind_lift_spmf exec_gpv_bind map_spmf_conv_bind_spmf split_def eq_commute intro!: bind_spmf_cong[OF refl])
  qed
  also have "game2 \<A> = PRF.game_1 (reduction_prf \<A>)"
  proof -
    note [split del] = if_split
    { fix k_upf b k_prf
      define oracle2
        where "oracle2 = oracle_encrypt2 (k_prf, k_upf) b \<oplus>\<^sub>O oracle_decrypt2 (k_prf, k_upf)"
      define oracle_intercept
        where "oracle_intercept = (\<lambda>(s', s) y. map_spmf (\<lambda>((x, s'), s). (x, s', s)) (exec_gpv PRF.random_oracle (intercept_prf k_upf b s' y) s))"
      define S
        where "S = (\<lambda>(s2 :: unit, s2') (s1 :: (bitstring, bitstring) PRF.dict). s2' = s1)"

      have [transfer_rule]: "S ((), Map_empty) Map_empty" by(simp add: S_def)
      have [transfer_rule]: "(S ===> (=) ===> rel_spmf (rel_prod (=) S)) oracle_intercept oracle2"
        unfolding oracle2_def oracle_intercept_def
        by(auto split: bool.split plus_oracle_split option.split simp add: S_def rel_fun_def exec_gpv_bind PRF.random_oracle_def oracle_encrypt2_def Let_def map_spmf_conv_bind_spmf oracle_decrypt2_def rel_spmf_return_spmf1 fun_upd_idem intro!: rel_spmf_bind_reflI rel_spmf_reflI)

      have [symmetric]: "map_spmf (\<lambda>x. b = fst (fst x)) (exec_gpv (PRF.random_oracle) (inline (intercept_prf k_upf b) \<A> ()) Map.empty) =
        map_spmf (\<lambda>x. b = fst x) (exec_gpv oracle2 \<A> Map_empty)"
        by(transfer fixing: b prf_clen prf_domain upf_fun k_upf \<A> k_prf)
          (simp add: exec_gpv_inline map_spmf_conv_bind_spmf[symmetric] spmf.map_comp o_def split_def oracle_intercept_def) }
    then show ?thesis
      unfolding game2_def PRF.game_1_def key_gen_def reduction_prf_def
      by (clarsimp simp add: exec_gpv_bind_lift_spmf exec_gpv_bind map_spmf_conv_bind_spmf split_def bind_spmf_const prf_key_gen_lossless lossless_weight_spmfD eq_commute)
  qed
  ultimately show ?thesis by(simp add: PRF.advantage_def)
qed

definition oracle_encrypt3 ::
   "('prf_key \<times> 'upf_key) \<Rightarrow> bool \<Rightarrow> (bool \<times> (bitstring, bitstring) PRF.dict) \<Rightarrow>
    bitstring \<times> bitstring \<Rightarrow> ('hash cipher_text option \<times> (bool \<times> (bitstring, bitstring) PRF.dict)) spmf"
where
  "oracle_encrypt3 = (\<lambda>(k_prf, k_upf) b (bad, D) (msg1, msg0).
    (case (length msg1 = prf_clen \<and> length msg0 = prf_clen) of
      False \<Rightarrow> return_spmf (None, (bad, D))
    | True \<Rightarrow> do {
        x \<leftarrow> spmf_of_set prf_domain;
        P \<leftarrow> spmf_of_set (nlists UNIV prf_clen);
        let (p, F) = (case D x of Some r \<Rightarrow> (P, True) | None \<Rightarrow> (P, False));
        let c = p [\<oplus>] (if b then msg1 else msg0);
        let t = upf_fun k_upf (x @ c);
        return_spmf (Some (x, c, t), (bad \<or> F, D(x \<mapsto> p)))
      }))"

lemma lossless_oracle_encrypt3 [simp]:
  "lossless_spmf (oracle_encrypt3 k b D m10) "
  by (cases m10) (simp add: oracle_encrypt3_def prf_domain_nonempty prf_domain_finite
    split_def Let_def split: bool.splits)

lemma callee_invariant_oracle_encrypt3 [simp]: "callee_invariant (oracle_encrypt3 key b) fst"
  by (unfold_locales) (auto simp add: oracle_encrypt3_def split_def Let_def split: bool.splits)

definition game3 :: "(bitstring, 'hash cipher_text) ind_cca.adversary \<Rightarrow> (bool \<times> bool) spmf"
where
  "game3 \<A> \<equiv> do {
    key \<leftarrow> key_gen;
    b \<leftarrow> coin_spmf;
    (b', (bad, D)) \<leftarrow> exec_gpv (oracle_encrypt3 key b \<oplus>\<^sub>O oracle_decrypt2 key) \<A> (False, Map_empty);
    return_spmf (b = b', bad)
  }"

lemma round_3:
  assumes "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) \<A>"
  shows "\<bar>measure (measure_spmf (game3 \<A>)) {(b, bad). b} - spmf (game2 \<A>) True\<bar>
          \<le> measure (measure_spmf (game3 \<A>)) {(b, bad). bad}"
proof -
  define oracle_encrypt2'
    where "oracle_encrypt2' = (\<lambda>(k_prf :: 'prf_key, k_upf) b (bad, D) (msg1, msg0).
      case length msg1 = prf_clen \<and> length msg0 = prf_clen of
        False \<Rightarrow> return_spmf (None, (bad, D))
      | True \<Rightarrow> do {
          x \<leftarrow> spmf_of_set prf_domain;
          P \<leftarrow> spmf_of_set (nlists UNIV prf_clen);
          let (p, F) = (case D x of Some r \<Rightarrow> (r, True) | None \<Rightarrow> (P, False));
          let c = p [\<oplus>] (if b then msg1 else msg0);
          let t = upf_fun k_upf (x @ c);
          return_spmf (Some (x, c, t), (bad \<or> F, D(x \<mapsto> p)))
        })"

  have [simp]: "lossless_spmf (oracle_encrypt2' key b D msg10) " for key b D msg10
    by (cases msg10) (simp add: oracle_encrypt2'_def prf_domain_nonempty prf_domain_finite
      split_def Let_def split: bool.split)
  have [simp]: "callee_invariant (oracle_encrypt2' key b) fst" for key b
    by (unfold_locales) (auto simp add: oracle_encrypt2'_def split_def Let_def split: bool.splits)

  define game2'
    where "game2' = (\<lambda>\<A>. do {
      key \<leftarrow> key_gen;
      b \<leftarrow> coin_spmf;
      (b', (bad, D)) \<leftarrow> exec_gpv (oracle_encrypt2' key b \<oplus>\<^sub>O oracle_decrypt2 key) \<A> (False, Map_empty);
      return_spmf (b = b', bad)})"

  have game2'_eq: "game2 \<A> = map_spmf fst (game2' \<A>)"
  proof -
    define S where "S = (\<lambda>(D1 :: (bitstring, bitstring) PRF.dict) (bad :: bool, D2). D1 = D2)"
    have [transfer_rule, simp]: "S Map_empty (b, Map_empty)" for b by (simp add: S_def)

    have [transfer_rule]: "((=) ===> (=) ===> S ===> (=) ===> rel_spmf (rel_prod (=) S))
      oracle_encrypt2 oracle_encrypt2'"
      unfolding oracle_encrypt2_def[abs_def] oracle_encrypt2'_def[abs_def]
      by (auto simp add: rel_fun_def Let_def split_def S_def
           intro!: rel_spmf_bind_reflI split: bool.split option.split)
    have [transfer_rule]: "((=) ===> S ===> (=) ===> rel_spmf (rel_prod (=) S))
      oracle_decrypt2 oracle_decrypt2"
      by(auto simp add: rel_fun_def oracle_decrypt2_def)

    show ?thesis unfolding game2_def game2'_def
      by (simp add: map_spmf_bind_spmf o_def split_def Map_empty_def[symmetric] del: Map_empty_def)
         transfer_prover
  qed
  moreover have *: "rel_spmf (\<lambda>(b'1, bad1, L1) (b'2, bad2, L2). (bad1 \<longleftrightarrow> bad2) \<and> (\<not> bad2 \<longrightarrow> b'1 \<longleftrightarrow> b'2))
    (exec_gpv (oracle_encrypt3 key b \<oplus>\<^sub>O oracle_decrypt2 key) \<A> (False, Map_empty))
    (exec_gpv (oracle_encrypt2' key b \<oplus>\<^sub>O oracle_decrypt2 key) \<A> (False, Map_empty))"
    for key b
    apply(rule exec_gpv_oracle_bisim_bad[where X="(=)" and X_bad = "\<lambda>_ _. True" and ?bad1.0=fst and ?bad2.0=fst and \<I>="\<I>_full \<oplus>\<^sub>\<I> \<I>_full"])
    apply(simp_all add: assms)
    apply(auto simp add: assms spmf_rel_map Let_def oracle_encrypt2'_def oracle_encrypt3_def split: plus_oracle_split prod.split bool.split option.split intro!: rel_spmf_bind_reflI rel_spmf_reflI)
    done
  have "\<bar>measure (measure_spmf (game3 \<A>)) {(b, bad). b} - measure (measure_spmf (game2' \<A>)) {(b, bad). b}\<bar> \<le>
    measure (measure_spmf (game3 \<A>)) {(b, bad). bad}"
    unfolding game2'_def game3_def
    by(rule fundamental_lemma[where ?bad2.0=snd])(intro rel_spmf_bind_reflI rel_spmf_bindI[OF *]; clarsimp)
  ultimately show ?thesis by(simp add: spmf_conv_measure_spmf measure_map_spmf vimage_def fst_def)
qed

lemma round_4:
  assumes "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) \<A>"
  shows "map_spmf fst (game3 \<A>) = coin_spmf"
proof -
  define oracle_encrypt4
    where "oracle_encrypt4 = (\<lambda>(k_prf :: 'prf_key, k_upf) (s :: unit) (msg1 :: bitstring, msg0 :: bitstring).
      case length msg1 = prf_clen \<and> length msg0 = prf_clen of
        False \<Rightarrow> return_spmf (None, s)
      | True \<Rightarrow> do {
          x \<leftarrow> spmf_of_set prf_domain;
          P \<leftarrow> spmf_of_set (nlists UNIV prf_clen);
          let c = P;
          let t = upf_fun k_upf (x @ c);
          return_spmf (Some (x, c, t), s) })"

  have [simp]: "lossless_spmf (oracle_encrypt4 k s msg10)" for k s msg10
    by (cases msg10) (simp add: oracle_encrypt4_def prf_domain_finite prf_domain_nonempty
      split_def Let_def split: bool.splits)

  define game4 where "game4 = (\<lambda>\<A>. do {
    key \<leftarrow> key_gen;
    (b', _) \<leftarrow> exec_gpv (oracle_encrypt4 key \<oplus>\<^sub>O oracle_decrypt2 key) \<A> ();
    map_spmf ((=) b') coin_spmf})"

  have "map_spmf fst (game3 \<A>) = game4 \<A>"
  proof -
    note [split del] = if_split
    define S where "S = (\<lambda>(_ :: unit) (_ :: bool \<times> (bitstring, bitstring) PRF.dict). True)"
    define initial3 where "initial3 = (False, Map.empty :: (bitstring, bitstring) PRF.dict)"
    have [transfer_rule]: "S () initial3" by(simp add: S_def)
    have [transfer_rule]: "((=) ===> (=) ===> S ===> (=) ===> rel_spmf (rel_prod (=) S))
       (\<lambda>key b. oracle_encrypt4 key) oracle_encrypt3"
    proof(intro rel_funI; hypsubst)
      fix key unit msg10 b Dbad
      have "map_spmf fst (oracle_encrypt4 key () msg10) = map_spmf fst (oracle_encrypt3 key b Dbad msg10)"
        unfolding oracle_encrypt3_def oracle_encrypt4_def
        apply (clarsimp simp add: map_spmf_conv_bind_spmf Let_def split: bool.split prod.split; rule conjI; clarsimp)
        apply (rewrite in "\<hole> = _" one_time_pad[symmetric, where xs="if b then fst msg10 else snd msg10"])
         apply(simp split: if_split)
        apply(simp add: bind_map_spmf o_def option.case_distrib case_option_collapse xor_list_commute split_def cong del: option.case_cong_weak if_weak_cong)
        done
      then show "rel_spmf (rel_prod (=) S) (oracle_encrypt4 key unit msg10) (oracle_encrypt3 key b Dbad msg10)"
        by(auto simp add: spmf_rel_eq[symmetric] spmf_rel_map S_def elim: rel_spmf_mono)
    qed

    show ?thesis
      unfolding game3_def game4_def including monad_normalisation
      by (simp add: map_spmf_bind_spmf o_def split_def map_spmf_conv_bind_spmf initial3_def[symmetric] eq_commute)
         transfer_prover
  qed
  also have "\<dots> = coin_spmf"
    by(simp add: map_eq_const_coin_spmf game4_def bind_spmf_const split_def lossless_exec_gpv[OF assms] lossless_weight_spmfD)
  finally  show ?thesis .
qed

lemma game3_bad:
  assumes "interaction_bounded_by isl \<A> q"
  shows "measure (measure_spmf (game3 \<A>)) {(b, bad). bad} \<le> q / card prf_domain * q"
proof -
  have "measure (measure_spmf (game3 \<A>)) {(b, bad). bad} = spmf (map_spmf snd (game3 \<A>)) True"
    by (simp add: spmf_conv_measure_spmf measure_map_spmf vimage_def snd_def)
  also
  have "spmf (map_spmf (fst \<circ> snd) (exec_gpv (oracle_encrypt3 k b \<oplus>\<^sub>O oracle_decrypt2 k) \<A> (False, Map.empty))) True \<le> q / card prf_domain * q"
    (is "spmf (map_spmf _ (exec_gpv ?oracle _ _)) _ \<le>  _")
    if k: "k \<in> set_spmf key_gen" for k b
  proof(rule callee_invariant_on.interaction_bounded_by'_exec_gpv_bad_count)
    obtain k_prf k_upf where k: "k = (k_prf, k_upf)" by(cases k)
    let ?I = "\<lambda>(bad, D). finite (dom D) \<and> dom D \<subseteq> prf_domain"
    have "callee_invariant (oracle_encrypt3 k b) ?I"
      by unfold_locales(clarsimp simp add: prf_domain_finite oracle_encrypt3_def Let_def split_def split: bool.splits)+
    moreover have "callee_invariant (oracle_decrypt2 k) ?I"
      by unfold_locales (clarsimp simp add: prf_domain_finite oracle_decrypt2_def)+
    ultimately show "callee_invariant ?oracle ?I" by simp

    let ?count = "\<lambda>(bad, D). card (dom D)"
    show "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (?oracle s x); ?I s; isl x \<rbrakk> \<Longrightarrow> ?count s' \<le> Suc (?count s)"
      by(clarsimp simp add: isl_def oracle_encrypt3_def split_def Let_def card_insert_if split: bool.splits)
    show "\<lbrakk> (y, s') \<in> set_spmf (?oracle s x); ?I s; \<not> isl x \<rbrakk> \<Longrightarrow> ?count s' \<le> ?count s" for s x y s'
      by(cases x)(simp_all add: oracle_decrypt2_def)
    show "spmf (map_spmf (fst \<circ> snd) (?oracle s' x)) True \<le> q / card prf_domain"
      if I: "?I s'" and bad: "\<not> fst s'" and count: "?count s' < q + ?count (False, Map.empty)"
      and x: "isl x"
      for s' x
    proof -
      obtain bad D where s' [simp]: "s' = (bad, D)" by(cases s')
      from x obtain m1 m0 where x [simp]: "x = Inl (m1, m0)" by(auto elim: islE)
      have *: "(case D x of None \<Rightarrow> False | Some x \<Rightarrow> True) \<longleftrightarrow> x \<in> dom D" for x
        by(auto split: option.split)
      show ?thesis
      proof(cases "length m1 = prf_clen \<and> length m0 = prf_clen")
        case True
        with bad
        have "spmf (map_spmf (fst \<circ> snd) (?oracle s' x)) True = pmf (bernoulli_pmf (card (dom D \<inter> prf_domain) / card prf_domain)) True"
          by(simp add: spmf.map_comp o_def oracle_encrypt3_def k * bool.case_distrib[where h="\<lambda>p. spmf (map_spmf _ p) _"] option.case_distrib[where h=snd] map_spmf_bind_spmf Let_def split_beta bind_spmf_const cong: bool.case_cong option.case_cong split del: if_split split: bool.split)
            (simp add: map_spmf_conv_bind_spmf[symmetric] map_mem_spmf_of_set prf_domain_finite prf_domain_nonempty)
        also have "\<dots> = card (dom D \<inter> prf_domain) / card prf_domain"
          by(rule pmf_bernoulli_True)(auto simp add: field_simps prf_domain_finite prf_domain_nonempty card_gt_0_iff card_mono)
        also have "dom D \<inter> prf_domain = dom D" using I by auto
        also have "card (dom D) \<le> q" using count by simp
        finally show ?thesis by(simp add: divide_right_mono o_def)
      next
        case False
        thus ?thesis using bad
          by(auto simp add: spmf.map_comp o_def oracle_encrypt3_def k split: bool.split)
      qed
    qed
  qed(auto split: plus_oracle_split_asm simp add: oracle_decrypt2_def assms)
  then have "spmf (map_spmf snd (game3 \<A>)) True \<le> q / card prf_domain * q"
    by(auto 4 3 simp add: game3_def map_spmf_bind_spmf o_def split_def map_spmf_conv_bind_spmf intro: spmf_bind_leI)
  finally show ?thesis .
qed

theorem security:
  assumes lossless: "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) \<A>"
  and bound: "interaction_bounded_by isl \<A> q"
  shows "ind_cca.advantage \<A> \<le>
    PRF.advantage (reduction_prf \<A>) + UPF.advantage (reduction_upf \<A>) +
    real q / real (card prf_domain) * real q" (is "?LHS \<le> _")
proof -
  have "?LHS \<le> \<bar>spmf (ind_cca.game \<A>) True - spmf (ind_cca'.game \<A>) True\<bar> + \<bar>spmf (ind_cca'.game \<A>) True - 1 / 2\<bar>"
    (is "_ \<le> ?round1 + ?rest") using abs_triangle_ineq by(simp add: ind_cca.advantage_def)
  also have "?round1 \<le> UPF.advantage (reduction_upf \<A>)"
    using lossless by(rule round_1)
  also have "?rest \<le> \<bar>spmf (ind_cca'.game \<A>) True - spmf (game2 \<A>) True\<bar> + \<bar>spmf (game2 \<A>) True - 1 / 2\<bar>"
    (is "_ \<le> ?round2 + ?rest") using abs_triangle_ineq by simp
  also have "?round2 = PRF.advantage (reduction_prf \<A>)" by(rule round_2)
  also have "?rest \<le> \<bar>measure (measure_spmf (game3 \<A>)) {(b, bad). b} - spmf (game2 \<A>) True\<bar> +
       \<bar>measure (measure_spmf (game3 \<A>)) {(b, bad). b} - 1 / 2\<bar>"
    (is "_ \<le> ?round3 + _") using abs_triangle_ineq by simp
  also have "?round3 \<le> measure (measure_spmf (game3 \<A>)) {(b, bad). bad}"
    using round_3[OF lossless] .
  also have "\<dots> \<le> q / card prf_domain * q" using bound by(rule game3_bad)
  also have "measure (measure_spmf (game3 \<A>)) {(b, bad). b} = spmf coin_spmf True"
    using round_4[OF lossless, symmetric]
    by(simp add: spmf_conv_measure_spmf measure_map_spmf vimage_def fst_def)
  also have "\<bar>\<dots> - 1 / 2\<bar> = 0" by(simp add: spmf_of_set)
  finally show ?thesis by(simp)
qed

theorem security1:
  assumes lossless: "lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) \<A>"
  assumes q: "interaction_bounded_by isl \<A> q"
  and q': "interaction_bounded_by (Not \<circ> isl) \<A> q'"
  shows "ind_cca.advantage \<A> \<le>
    PRF.advantage (reduction_prf \<A>) +
    UPF.advantage1 (guessing_many_one.reduction q' (\<lambda>_. reduction_upf \<A>) ()) * q' +
    real q * real q / real (card prf_domain)"
proof -
  have "ind_cca.advantage \<A> \<le>
    PRF.advantage (reduction_prf \<A>) + UPF.advantage (reduction_upf \<A>) +
    real q / real (card prf_domain) * real q"
    using lossless q by(rule security)
  also note q'[interaction_bound]
  have "interaction_bounded_by (Not \<circ> isl) (reduction_upf \<A>) q'"
    unfolding reduction_upf_def by(interaction_bound)(simp_all add: SUP_le_iff)
  then have "UPF.advantage (reduction_upf \<A>) \<le> UPF.advantage1 (guessing_many_one.reduction q' (\<lambda>_. reduction_upf \<A>) ()) * q'"
    by(rule UPF.advantage_advantage1)
  finally show ?thesis by(simp)
qed

end

end

locale simple_cipher' =
  fixes prf_key_gen :: "security \<Rightarrow> 'prf_key spmf"
  and prf_fun :: "security \<Rightarrow> 'prf_key \<Rightarrow> bitstring \<Rightarrow> bitstring"
  and prf_domain :: "security \<Rightarrow> bitstring set"
  and prf_range :: "security \<Rightarrow> bitstring set"
  and prf_dlen :: "security \<Rightarrow> nat"
  and prf_clen :: "security \<Rightarrow> nat"
  and upf_key_gen :: "security \<Rightarrow> 'upf_key spmf"
  and upf_fun :: "security \<Rightarrow> 'upf_key \<Rightarrow> bitstring \<Rightarrow> 'hash"
  assumes simple_cipher: "\<And>\<eta>. simple_cipher (prf_key_gen \<eta>) (prf_fun \<eta>) (prf_domain \<eta>) (prf_dlen \<eta>) (prf_clen \<eta>) (upf_key_gen \<eta>)"
begin

sublocale simple_cipher
  "prf_key_gen \<eta>" "prf_fun \<eta>" "prf_domain \<eta>" "prf_range \<eta>" "prf_dlen \<eta>" "prf_clen \<eta>" "upf_key_gen \<eta>" "upf_fun \<eta>"
  for \<eta>
by(rule simple_cipher)

theorem security_asymptotic:
  fixes q q' :: "security \<Rightarrow> nat"
  assumes lossless: "\<And>\<eta>. lossless_gpv (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) (\<A> \<eta>)"
  and bound: "\<And>\<eta>. interaction_bounded_by isl (\<A> \<eta>) (q \<eta>)"
  and bound': "\<And>\<eta>. interaction_bounded_by (Not \<circ> isl) (\<A> \<eta>) (q' \<eta>)"
  and [negligible_intros]:
    "polynomial q'" "polynomial q"
    "negligible (\<lambda>\<eta>. PRF.advantage \<eta> (reduction_prf \<eta> (\<A> \<eta>)))"
    "negligible (\<lambda>\<eta>. UPF.advantage1 \<eta> (guessing_many_one.reduction (q' \<eta>) (\<lambda>_. reduction_upf \<eta> (\<A> \<eta>)) ()))"
    "negligible (\<lambda>\<eta>. 1 / card (prf_domain \<eta>))"
  shows "negligible (\<lambda>\<eta>. ind_cca.advantage \<eta> (\<A> \<eta>))"
proof -
  have "negligible (\<lambda>\<eta>. PRF.advantage \<eta> (reduction_prf \<eta> (\<A> \<eta>)) +
    UPF.advantage1 \<eta> (guessing_many_one.reduction (q' \<eta>) (\<lambda>_. reduction_upf \<eta> (\<A> \<eta>)) ()) * q' \<eta> +
    real (q \<eta>) / real (card (prf_domain \<eta>)) * real (q \<eta>))"
    by(rule negligible_intros)+
  thus ?thesis by(rule negligible_le)(simp add: security1[OF lossless bound bound'] ind_cca.advantage_nonneg)
qed

end

end


section \<open>Verification Condition Testing\<close>

theory control_flow_partial_examples
  imports "../../hoare/HoareLogic/PartialCorrectness/utp_hoare"
begin
section "Examples"

text{*In this section we provide a set of examples on the verification
      of programs that uses  control flow statements
      with Hoare logic for partial correctness.
      The combination of
      relational algebra, ie. UTP, and lens algebra allows for a semantic based
      framework for the specification of programming languages and their features. It also
      allows a powerful proof tactics for the framework such as @{method rel_auto},
      @{method pred_auto}, etc.*}

text{*
   In the following examples:
      \begin{itemize}
         \<^item> The formal notation @{term "\<lbrace>Pre\<rbrace>prog\<lbrace>Post\<rbrace>\<^sub>u"} represent a hoare triple for partial
            correctness.
         \<^item> All variables are represented by lenses and have the type @{typ "'v \<Longrightarrow> 's"}:
           where  @{typ "'v"} is the view type of the lens and @{typ "'s"} is the type of the state.
         \<^item> Lens properties such as @{term "weak_lens"}, @{term "mwb_lens"}, @{term "wb_lens"},
           @{term "vwb_lens"}, @{term "ief_lens"}, @{term "bij_lens"}
           are used to semantically express what does not change in the state space. For example
           applying the property @{term "bij_lens"} of variable @{term "x"} gives the term
           @{term "bij_lens x"}. Informally this means that any change on x will appear on all
           other variables in the state space.The property @{term "ief_lens"} is just the opposite
           of @{term "bij_lens"}.
         \<^item> The formal notation @{term "x \<sharp>\<sharp> P"} is a syntactic sugar for
            @{term "unrest_relation x P"}:
           informally it is used to semantically express that the variable x does not occur
           in the program P.
         \<^item> The formal notation @{term "x :== v"} is a syntactic sugar for @{term "assigns_r [x \<mapsto>\<^sub>s v]"}:
           informally it represent an assignment of a value v to a variable x.
         \<^item> The formal notation @{term "&x"} is a syntactic sugar for @{term "\<langle>id\<rangle>\<^sub>s x"}:
           informally it represent the content of a variable x.
         \<^item> The formal notation @{term "\<guillemotleft>l\<guillemotright>"} is a syntactic sugar for @{term "lit l"}:
            informally it represent a lifting of an HOL literal l to utp expression.
         \<^item> The formal notation @{term "x \<bowtie> y"} is a syntactic sugar for @{term "lens_indep x y"}:
           informally it is a semantic representation that uses two variables
           to characterise independence between two state space regions.
         \<^item> The tactics @{method rel_auto}, @{method pred_auto}, @{method rel_simp},
           @{method pred_simp}, @{method rel_blast}, @{method pred_blast} are used
           to discharge proofs related to UTP-relations and UTP-predicates.
     \end{itemize}
     *}

subsection {*block feature*}

text {*block_test1 is a scenario. The scenario represent a program where i is name of the variable
       in the scope of the initial state s. In the scenario, and using the command block,
       we create a new variable with the same name inside the block ie., inside the new scope.
       Now i is a local var for the scope t.
       In that case we can use a restore function on the state s to set the variable to its
       previous value ie.,its value in the scope s, and this before we exit the block.*}

lemma   blocks_test1:
  assumes "weak_lens i"
  shows "\<lbrace>true\<rbrace>
          i :== \<guillemotleft>2::int\<guillemotright>;;
          block (i :== \<guillemotleft>5\<guillemotright>) (II) (\<lambda> (s, s') (t, t').  i:== \<guillemotleft>\<lbrakk>\<langle>id\<rangle>\<^sub>s i\<rbrakk>\<^sub>e s\<guillemotright>) (\<lambda> (s, s') (t, t').  II)
         \<lbrace>&i =\<^sub>u \<guillemotleft>2::int\<guillemotright>\<rbrace>\<^sub>u"
  using assms by rel_auto

text {*block_test2 is similar to  block_test1 but the var i is a global var.
       In that case we can use restore function and the state t to set the variable to its
       latest value, ie.,its value in in the scope t,probably modified inside the scope of the block.*}

lemma   blocks_test2:
  assumes "weak_lens i"
  shows "\<lbrace>true\<rbrace>
          i :== \<guillemotleft>2::int\<guillemotright>;;
          block (i :== \<guillemotleft>5\<guillemotright>) (II) (\<lambda> (s, s') (t, t').  i:== \<guillemotleft>\<lbrakk>\<langle>id\<rangle>\<^sub>s i\<rbrakk>\<^sub>e t\<guillemotright>) (\<lambda> (s, s') (t, t').  II)
         \<lbrace>&i =\<^sub>u \<guillemotleft>5::int\<guillemotright>\<rbrace>\<^sub>u"
  using assms by rel_auto

subsection {*Infinite loops*}
text{*The next two lemmas are the witness needed to justify the theory of designs.*}

lemma 1:"while\<^sub>\<bottom> true do II od = true"
  unfolding while_bot_def
  apply rel_simp unfolding gfp_def apply transfer apply auto done

lemma "in\<alpha> \<sharp> ( x :== \<guillemotleft>c\<guillemotright>) \<Longrightarrow> while\<^sub>\<bottom> true  do II od;; x :== \<guillemotleft>c\<guillemotright> = x :== \<guillemotleft>c\<guillemotright>"
  apply (subst 1) apply (simp only: assigns_r.abs_eq )
  apply (simp only: seqr_def) apply simp
 apply rel_simp  apply transfer apply auto done

end


(*
Title: Value-Dependent SIFUM-Type-Systems
Authors: Toby Murray, Robert Sison, Edward Pierzchalski, Christine Rizkallah
(Based on the SIFUM-Type-Systems AFP entry, whose authors
 are: Sylvia Grewe, Heiko Mantel, Daniel Schoepe)
*)
theory Example_Swap_Add
imports
  "../TypeSystem"
  TypeSystemTactics
begin

text \<open>
  Use upper-case variable names to avoid clashing with one-letter free variables
\<close>
datatype addr = X | control_X | Y | control_Y | Z | control_Z
type_synonym val = nat
type_synonym mem = "addr \<Rightarrow> val"

datatype aexp = Load "addr" | Const "val" | Add "addr" "addr"

fun
  ev\<^sub>A :: "mem \<Rightarrow> aexp \<Rightarrow> val"
where
  "ev\<^sub>A mem (Load x) = mem x" |
  "ev\<^sub>A mem (Const c) = c" |
  "ev\<^sub>A mem (Add x y) = mem x + mem y"

fun
  aexp_vars :: "aexp \<Rightarrow> addr set"
where
  "aexp_vars (Load x) = {x}" |
  "aexp_vars (Const c) = {}" |
  "aexp_vars (Add x y) = {x,y}"

datatype bexp = Same "addr" "aexp" |
                Eq "addr" "val" |
                Not bexp |
                Imp bexp bexp |
                And bexp bexp |
                Or bexp bexp | TT | FF

fun
  ev\<^sub>B :: "mem \<Rightarrow> bexp \<Rightarrow> bool"
where
  "ev\<^sub>B mem (Same x e) = ((mem x) = (ev\<^sub>A mem e))" |
  "ev\<^sub>B mem (Eq x c) = ((mem x) = c)" |
  "ev\<^sub>B mem (Not e) = (\<not> ev\<^sub>B mem e)" |
  "ev\<^sub>B mem (Imp e f) = (ev\<^sub>B mem e \<longrightarrow> ev\<^sub>B mem f)" |
  "ev\<^sub>B mem (And e f) = (ev\<^sub>B mem e \<and> ev\<^sub>B mem f)" |
  "ev\<^sub>B mem (Or e f) = (ev\<^sub>B mem e \<or> ev\<^sub>B mem f)" |
  "ev\<^sub>B mem TT = True" |
  "ev\<^sub>B mem FF = False"

fun
  bexp_vars :: "bexp \<Rightarrow> addr set"
where
  "bexp_vars (Eq x c) = {x}" |
  "bexp_vars (Same x e) = {x} \<union> aexp_vars e" |
  "bexp_vars (Not e) = bexp_vars e" |
  "bexp_vars (Imp e f) = bexp_vars e \<union> bexp_vars f" |
  "bexp_vars (And e f) = bexp_vars e \<union> bexp_vars f" |
  "bexp_vars (Or e f) = bexp_vars e \<union> bexp_vars f" |
  "bexp_vars _ = {}"

fun
  bexp_neg :: "bexp \<Rightarrow> bexp"
where
  "bexp_neg e = (Not e)"

fun
   bexp_assign :: "addr \<Rightarrow> aexp \<Rightarrow> bexp"
where
  "bexp_assign x e  = (Same x e)"

definition
  dma_control_var :: "val \<Rightarrow> Sec"
where
  "dma_control_var v \<equiv> if v = 0 then Low else High"

fun
  control_var_of :: "addr \<Rightarrow> addr"
where
  "control_var_of X = control_X" |
  "control_var_of Y = control_Y" |
  "control_var_of Z = control_Z"

definition
  dma :: "mem \<Rightarrow> addr \<Rightarrow> Sec"
where
  "dma m x \<equiv> if x \<in> {X,Y,Z} then dma_control_var (m (control_var_of x)) else Low"

definition
  \<C>_vars :: "addr \<Rightarrow> addr set"
where
  "\<C>_vars x \<equiv> if x \<in> {X,Y,Z} then {control_var_of x} else {}"

definition
  mds\<^sub>s :: "Mode \<Rightarrow> 'Var set"
where
  "mds\<^sub>s \<equiv> \<lambda>_. {}"

locale sifum_example =
  sifum_lang_no_dma ev\<^sub>A ev\<^sub>B aexp_vars bexp_vars +
  assumes eval_det: "(lc, lc') \<in> sifum_lang_no_dma.eval\<^sub>w ev\<^sub>A ev\<^sub>B \<Longrightarrow> (lc, lc'') \<in> sifum_lang_no_dma.eval\<^sub>w ev\<^sub>A ev\<^sub>B \<Longrightarrow> lc' = lc''"

definition
  \<C> :: "addr set"
where
  "\<C> \<equiv> \<Union>x. \<C>_vars x"

fun
  dma_type :: "addr \<Rightarrow> bexp set"
where
  "dma_type X = {Eq control_X 0}" |
  "dma_type Z = {Eq control_Z 0}" |
  "dma_type Y = {Eq control_Y 0}" |
  "dma_type _ = {}"

sublocale sifum_example \<subseteq> sifum_types_assign ev\<^sub>A ev\<^sub>B aexp_vars bexp_vars dma \<C>_vars \<C> bexp_neg dma_type FF bexp_assign
  apply(unfold_locales)
              apply(blast intro: eval_det)
             apply(rule Var_finite)
            apply(auto simp: \<C>_vars_def dma_def \<C>_def split: if_splits)[3]
         apply(rename_tac mem e, case_tac e, auto)[1]
        apply(case_tac x, auto simp: dma_def dma_control_var_def)[1]
       apply(case_tac x, auto simp: \<C>_vars_def)[1]
      apply(simp+)[2]
    apply(case_tac e, auto)[1]
   apply(case_tac e, simp)
  apply(auto simp: \<C>_def)
  done

context sifum_example begin

lemma if_type'':
  "\<lbrakk>type_bexpr \<Gamma> e t; pred_entailment P t;
    has_type  \<Gamma> \<S> (add_pred P \<S> e) c\<^sub>1 \<Gamma>' \<S>' P';
    has_type \<Gamma> \<S> (add_pred P \<S> (bexp_neg e)) c\<^sub>2 \<Gamma>' \<S>' P'';
    pred_entailment P' {e}; pred_entailment P'' {bexp_neg e};
    P''' = restrict_preds_to_vars (((Imp e) ` (P' - {e})) \<union> ((Imp (bexp_neg e)) ` (P'' - {bexp_neg e}))) {v. stable \<S>' v}\<rbrakk>
\<Longrightarrow> has_type \<Gamma> \<S> P (Stmt.If e c\<^sub>1 c\<^sub>2) \<Gamma>' \<S>' P'''"
  apply(erule (3) if_type,simp+)
     apply(auto simp: pred_entailment_def pred_def image_def restrict_preds_to_vars_def)[1]
    apply(auto simp: pred_entailment_def pred_def image_def restrict_preds_to_vars_def)[1]
   apply(clarsimp simp: tyenv_wellformed_def mds_consistent_def stable_def image_def restrict_preds_to_vars_def)
   apply fastforce
  apply(clarsimp simp: tyenv_wellformed_def mds_consistent_def stable_def image_def restrict_preds_to_vars_def)
  apply fastforce
  done

definition
  swap_vars :: "(addr, aexp, bexp) Stmt"
where
  "swap_vars \<equiv>
     ModeDecl Skip (Acq control_X AsmNoWrite) ;;
     ModeDecl Skip (Acq control_Y AsmNoWrite) ;;
     ModeDecl Skip (Acq control_Z AsmNoWrite) ;;
     ModeDecl Skip (Acq X AsmNoReadOrWrite) ;;
     ModeDecl Skip (Acq Y AsmNoReadOrWrite) ;;
     ModeDecl Skip (Acq Z AsmNoReadOrWrite) ;;
     Assign Z (Load X) ;;
     Assign X (Load Y) ;;
     Assign Y (Load Z) ;;
     Assign control_Z (Load control_X) ;;
     Assign control_X (Load control_Y) ;;
     Assign control_Y (Load control_Z) ;;
     ModeDecl Skip (Rel X AsmNoReadOrWrite) ;;
     ModeDecl Skip (Rel Y AsmNoReadOrWrite) ;;
     ModeDecl Skip (Rel Z AsmNoReadOrWrite) ;;
     ModeDecl Skip (Rel control_X AsmNoWrite) ;;
     ModeDecl Skip (Rel control_Y AsmNoWrite) ;;
     ModeDecl Skip (Rel control_Z AsmNoWrite) ;;
     Skip"

lemma \<C>_simp[simp]:
  "\<C> = {control_X, control_Y, control_Z}"
proof -
  have "\<C> = control_var_of ` {x. x = X \<or> x = Y \<or> x = Z}"
    by (simp add: \<C>_def \<C>_vars_def UNION_singleton_eq_range)
  also have "{x. x = X \<or> x = Y \<or> x = Z} = {X, Y, Z}"
    by auto
  finally show ?thesis
    by simp
qed

lemma type_aexpr_Load':
  "v \<in> dom \<Gamma> \<Longrightarrow> t = (the (\<Gamma> v)) \<Longrightarrow> type_aexpr \<Gamma> (Load v) t"
  apply(insert type_aexpr[of \<Gamma> "Load v", simplified])
  apply(simp add: to_total_def)
  done

lemma type_aexpr_Add:
  "x \<notin> dom \<Gamma> \<Longrightarrow> y \<notin> dom \<Gamma> \<Longrightarrow>
   type_aexpr \<Gamma> (Add x y) (\<Union> {dma_type x, dma_type y})"
  apply(insert type_aexpr[of \<Gamma> "Add x y", simplified])
  apply(simp add: to_total_def)
  done

lemma type_aexpr_Add':
  "x \<notin> dom \<Gamma> \<Longrightarrow> y \<in> dom \<Gamma> \<Longrightarrow> t = (the (\<Gamma> y)) \<Longrightarrow>
   type_aexpr \<Gamma> (Add x y) (\<Union> {dma_type x, t})"
  apply(insert type_aexpr[of \<Gamma> "Add x y", simplified])
  apply(simp add: to_total_def)
  done

lemma type_aexpr_Add'':
  "x \<in> dom \<Gamma> \<Longrightarrow> y \<notin> dom \<Gamma> \<Longrightarrow> t = (the (\<Gamma> x)) \<Longrightarrow>
   type_aexpr \<Gamma> (Add x y) (\<Union> {t, dma_type y})"
  apply(insert type_aexpr[of \<Gamma> "Add x y", simplified])
  apply(simp add: to_total_def)
  done

lemma type_aexpr_Add''':
  "x \<in> dom \<Gamma> \<Longrightarrow> y \<in> dom \<Gamma> \<Longrightarrow> t = (the (\<Gamma> x)) \<Longrightarrow> t' = (the (\<Gamma> y)) \<Longrightarrow>
   type_aexpr \<Gamma> (Add x y) (\<Union> {t, t'})"
  apply(insert type_aexpr[of \<Gamma> "Add x y", simplified])
  apply(simp add: to_total_def)
  done

lemma type_aexpr_Const[simp]:
  "type_aexpr \<Gamma> (Const c) {}"
  apply(insert type_aexpr[of \<Gamma> "Const c", simplified],simp)
  done

declare restrict_preds_to_vars_def [simp]
declare add_pred_def [simp]
declare stable_def [simp]
declare to_total_def [simp]
declare \<C>_vars_def [simp]
declare anno_type_stable_def [simp]
declare anno_type_sec_def [simp]
declare assign_post_def [simp]

lemma control_vars_cases:
  "control_X \<in> \<C>_vars v \<Longrightarrow> v = X"
  "control_Y \<in> \<C>_vars v \<Longrightarrow> v = Y"
  "control_Z \<in> \<C>_vars v \<Longrightarrow> v = Z"
  by(case_tac v, auto)+

lemma mem_is_different[simp, intro]:
  "mem x = A \<Longrightarrow> mem y \<noteq> A \<Longrightarrow> \<not> ev\<^sub>B  mem (Same y (Load x))"
  "mem x = A \<Longrightarrow> mem y \<noteq> A \<Longrightarrow> \<not> ev\<^sub>B  mem (Same x (Load y))"
  by fastforce+

lemma restrict_preds_to_vars_empty[simp]:
  "restrict_preds_to_vars {} V = {}"
  apply(simp add: restrict_preds_to_vars_def)
  done

lemma restrict_preds_to_vars_idemp[simp]:
  "restrict_preds_to_vars (restrict_preds_to_vars P V) V =
   restrict_preds_to_vars P V"
  apply(simp add: restrict_preds_to_vars_def)
  done

lemma restrict_preds_to_vars_insert1[simp]:
  "(\<forall>x\<in>bexp_vars a. x \<in> V) \<Longrightarrow> restrict_preds_to_vars (insert a P) V = (insert a (restrict_preds_to_vars P V))"
  apply(simp add: restrict_preds_to_vars_def)
  apply fastforce
  done

lemma restrict_preds_to_vars_insert2[simp]:
  "(\<exists>x\<in>bexp_vars a. x \<notin> V) \<Longrightarrow> restrict_preds_to_vars (insert a P) V = ((restrict_preds_to_vars P V))"
  apply(simp add: restrict_preds_to_vars_def)
  apply fastforce
  done

declare restrict_preds_to_vars_def[simp del]

lemma swap_vars_typed:
  "\<Gamma> = (\<lambda>_. None) \<Longrightarrow> \<S> = ({},{}) \<Longrightarrow> P = {} \<Longrightarrow>
  \<exists>\<Gamma>' \<S>' P'. has_type \<Gamma> \<S> P swap_vars \<Gamma>' \<S>' P'"
  apply(intro exI)
  apply(simp add: swap_vars_def)
  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply clarsimp
       apply(rule skip_type)
      apply(simp+)[4]
  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply clarsimp
       apply(rule skip_type)
      apply(simp+)[4]
  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply clarsimp
       apply(rule skip_type)
      apply(simp+)[4]
  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
        apply clarsimp
       apply(rule skip_type)
      apply(simp+)[4]
  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply clarsimp
       apply(rule skip_type)
      apply(simp+)[4]
  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply clarsimp
       apply(rule skip_type)
      apply(simp+)[4]

  apply(rule seq_type)
   apply(rule assign\<^sub>2[OF _ _ _ HOL.refl])
      apply simp
     apply(rule type_aexpr_Load')
     apply(simp+)[4]

  apply(rule seq_type)
   apply(rule assign\<^sub>2[OF _ _ _ HOL.refl])
      apply simp
     apply(rule type_aexpr_Load')
     apply(simp+)[4]

  apply(rule seq_type)
   apply(rule assign\<^sub>2[OF _ _ _ HOL.refl])
      apply simp
     apply(rule type_aexpr_Load')
     apply(simp+)[4]

  apply(rule seq_type)
   apply(rule assign\<^sub>\<C>[OF _ _ _ _ HOL.refl])
      apply simp
     apply(rule type_aexpr_Load)
     apply (simp+)[4]
  apply simp

  apply(rule seq_type)
   apply(rule conc'[where x="Z" and t="dma_type Z", OF _ HOL.refl])
       apply(rule conc'[where x=Y and t="dma_type Z", OF _ HOL.refl])
           apply(rule assign\<^sub>\<C>[OF _ _ _ _ HOL.refl])
                apply simp
               apply(rule type_aexpr_Load)
               apply simp+
         apply(clarsimp simp: type_equiv_def subtype_def pred_entailment_def pred_def)
        apply(fastforce simp: type_wellformed_def)
       apply simp
      apply simp
     apply(clarsimp simp: type_equiv_def subtype_def pred_entailment_def pred_def)
    apply(fastforce simp: type_wellformed_def)
   apply simp

  apply simp
  apply(rule seq_type)
   apply(rule conc'[where x=X and t="dma_type X" , OF _ HOL.refl])
       apply(rule assign\<^sub>\<C>[OF _ _ _ _ HOL.refl])
           apply simp
          apply(rule type_aexpr_Load)
          apply simp+
     apply(clarsimp simp: type_equiv_def subtype_def pred_entailment_def pred_def)
    apply(clarsimp simp: type_wellformed_def)
   apply simp

  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply(rule skip_type)
      apply simp
     apply(fastforce simp: add_anno_def subtype_def pred_entailment_def pred_def)
    apply simp
   apply simp

  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply clarsimp
       apply(rule skip_type)
      apply simp
     apply(fastforce simp: add_anno_def subtype_def pred_entailment_def pred_def)
    apply simp
   apply simp

  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply clarsimp
       apply(rule skip_type)
      apply simp
     apply(fastforce simp: add_anno_def subtype_def pred_entailment_def pred_def)
    apply simp
   apply simp

  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply clarsimp
       apply(rule skip_type)
      apply simp
     apply(fastforce simp: add_anno_def subtype_def)
     apply (simp add: add_anno_def)
    apply simp

  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply clarsimp
       apply(rule skip_type)
      apply simp
     apply(fastforce simp: add_anno_def subtype_def)
     apply (simp add: add_anno_def)
    apply simp

  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply clarsimp
       apply(rule skip_type)
      apply simp
     apply(fastforce simp: add_anno_def subtype_def)
     apply (simp add: add_anno_def)
    apply simp

  apply(rule skip_type)
  done

lemma swap_vars_sifum_secure:
  "com_sifum_secure (swap_vars,(\<lambda>_. {}))"
  apply(insert swap_vars_typed[OF HOL.refl HOL.refl HOL.refl])
  apply clarify
  apply(rule typed_secure)
   apply(fastforce simp: \<Gamma>_of_mds_def \<S>_of_mds_def)
  apply(auto simp: mds_yields_stable_types_def)
  done

definition
  add_vars :: "(addr, aexp, bexp) Stmt"
where
  "add_vars \<equiv>
     ModeDecl Skip (Acq control_X AsmNoWrite) ;;
     ModeDecl Skip (Acq control_Y AsmNoWrite) ;;
     ModeDecl Skip (Acq control_Z AsmNoWrite) ;;
     ModeDecl Skip (Acq Z AsmNoReadOrWrite) ;;
     Assign Z (Add X Y) ;;
     If (Eq control_X 0)
        (If (Eq control_Y 0)
            (Assign control_Z (Const 0))
            (Assign control_Z (Const 1)))
        (Assign control_Z (Const 1)) ;;
     ModeDecl Skip (Rel Z AsmNoReadOrWrite) ;;
     ModeDecl Skip (Rel control_X AsmNoWrite) ;;
     ModeDecl Skip (Rel control_Y AsmNoWrite) ;;
     ModeDecl Skip (Rel control_Z AsmNoWrite) ;;
     Skip"

lemma pred_entailment_singleton_by_case_distinction:
  "Imp e f \<in> P \<Longrightarrow> Imp (bexp.Not e) f \<in> P \<Longrightarrow> pred_entailment P {f}"
  apply(clarsimp simp: pred_entailment_def pred_def)
  apply(case_tac "ev\<^sub>B mem e")
   apply fastforce+
  done

lemma restrict_preds_to_vars_nest [simp]:
  "restrict_preds_to_vars (restrict_preds_to_vars P V) V' = restrict_preds_to_vars P (V \<inter> V')"
  apply(auto simp: restrict_preds_to_vars_def)
  done

lemma restrict_preds_to_vars_imp_image1 [simp]:
  "\<not> bexp_vars e \<subseteq> V \<Longrightarrow> restrict_preds_to_vars (Imp e ` P) V = {}"
  apply(auto simp: restrict_preds_to_vars_def)
  done

lemma restrict_preds_to_vars_imp_image2 [simp]:
  "bexp_vars e \<subseteq> V \<Longrightarrow> restrict_preds_to_vars (Imp e ` P) V = ((Imp e) ` (restrict_preds_to_vars P V))"
  apply(auto simp: restrict_preds_to_vars_def)
  done

lemma insert_minus1 [simp]:
  "x = y \<Longrightarrow> (insert x A) - {y} = (A - {y})"
  by auto

lemma insert_minus2 [simp]:
  "x \<noteq> y \<Longrightarrow> (insert x A) - {y} = insert x (A - {y})"
  by auto

lemma add_vars_typed:
  "\<Gamma> = (\<lambda>_. None) \<Longrightarrow> \<S> = ({},{}) \<Longrightarrow> P = {} \<Longrightarrow>
  \<exists>\<Gamma>' \<S>' P'. has_type \<Gamma> \<S> P add_vars \<Gamma>' \<S>' P'"
  apply(intro exI)
  apply(simp add: add_vars_def)
  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply(rule skip_type)
      apply simp+
  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply(rule skip_type)
      apply simp+
  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply(rule skip_type)
      apply simp+
  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply(rule skip_type)
      apply simp+

  apply(rule seq_type)
   apply(rule assign\<^sub>2)
       apply simp
      apply (rule type_aexpr_Add type_aexpr_Add' type_aexpr_Add'' type_aexpr_Add'''; simp)
     apply(simp)
    apply(simp)
   apply simp

  apply(clarsimp)
  apply(rule seq_type)
   apply(rule if_type''[OF _ _ _ _ _ _ HOL.refl])
        apply(rule type_bexprI)
        apply(clarsimp)
        apply(rule HOL.refl)
       apply simp
      apply(rule if_type''[OF _ _ _ _ _ _ HOL.refl])
           apply(rule type_bexprI)
           apply(clarsimp simp: to_total_def)
           apply(rule HOL.refl)
          apply simp
         apply(rule assign\<^sub>\<C>)
              apply simp
             apply(rule type_aexpr_Const)
            apply simp
           apply (clarsimp, fast)
          apply(simp)
         apply simp
        apply(rule assign\<^sub>\<C>)
             apply simp
            apply(rule type_aexpr_Const)
           apply simp
          apply auto[1]
         apply(simp)
        apply clarsimp
       apply(clarsimp simp: subset_entailment)
      apply(clarsimp simp: subset_entailment)

     apply(rule assign\<^sub>\<C>)
          apply simp
         apply(rule type_aexpr_Const)
        apply simp
       apply clarsimp
       apply fast
      apply(simp)
     apply simp
    apply(fastforce intro: pred_entailment_singleton_by_case_distinction simp: image_def)
   apply(fastforce intro: subset_entailment)
  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply(rule skip_type)
      apply simp
     apply(clarsimp simp: subtype_def pred_def add_anno_def pred_entailment_def)
    apply simp+

 apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply(rule skip_type)
      apply simp
     apply(clarsimp simp: subtype_def pred_def add_anno_def)
    apply (simp add: add_anno_def)
   apply simp+

  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply(rule skip_type)
      apply fastforce+
  done

method post_conc_tac
  declares aexpr bexpr =
  ( simp,
   clarsimp simp: type_equiv_def subtype_def pred_entailment_def pred_def,
   clarsimp simp: type_wellformed_def,
   simp,
   has_type_tac')

method conc_tac for x :: addr and y :: addr  =
  (rule conc'[where  x="x" and t="dma_type y", OF _ HOL.refl])

lemma swap_vars_typed':
  "\<Gamma> = (\<lambda>_. None) \<Longrightarrow> \<S> = ({},{}) \<Longrightarrow> P = {} \<Longrightarrow>
  \<exists>\<Gamma>' \<S>' P'. has_type \<Gamma> \<S> P swap_vars \<Gamma>' \<S>' P'"
  apply (has_type_tac prog: swap_vars_def aexpr: type_aexpr_Load' type_aexpr_Load bexpr:type_bexprI)
   apply(conc_tac Z Z)
       apply(conc_tac Y Z)
           apply (has_type_tac' aexpr:type_aexpr_Load' type_aexpr_Load bexpr:type_bexprI)
          apply post_conc_tac
      apply post_conc_tac
   apply (has_type_tac' aexpr:type_aexpr_Load' type_aexpr_Load bexpr:type_bexprI)
   apply(conc_tac X X)
       apply (has_type_tac' aexpr:type_aexpr_Load' type_aexpr_Load bexpr:type_bexprI)
      apply  (post_conc_tac)
  done

lemma add_vars_typed':
  "\<Gamma> = (\<lambda>_. None) \<Longrightarrow> \<S> = ({},{}) \<Longrightarrow> P = {} \<Longrightarrow>
  \<exists>\<Gamma>' \<S>' P'. has_type \<Gamma> \<S> P add_vars \<Gamma>' \<S>' P'"
  apply (has_type_no_if_tac
          prog: add_vars_def
          aexpr: type_aexpr_Load' type_aexpr_Load type_aexpr_Add
           type_aexpr_Add' type_aexpr_Add''  type_aexpr_Const
          bexpr:type_bexprI)
   apply(rule if_type''[OF _ _ _ _ _ _ HOL.refl])
        apply(rule type_bexprI)
        apply(clarsimp)
        apply(rule HOL.refl)
       apply simp
      apply(rule if_type''[OF _ _ _ _ _ _ HOL.refl])
           apply(rule type_bexprI)
           apply(clarsimp)
           apply(rule HOL.refl)
          apply simp
         apply (has_type_tac' aexpr: type_aexpr_Const)
        apply (has_type_tac' aexpr: type_aexpr_Const)
       apply(clarsimp simp: subset_entailment)
      apply(clarsimp simp: subset_entailment)
     apply (has_type_tac' aexpr: type_aexpr_Const)
    apply simp
    apply(fastforce intro: pred_entailment_singleton_by_case_distinction simp: image_def)
   apply(fastforce intro: subset_entailment)
  apply (has_type_tac')
  done

end

end


theory morten_pds imports Main
begin

(* This is a formalization of pushdown systems. We follow the definitions, algorithms and proofs in:
   PhD Thesis: "Model-Checking Pushdown Systems", Stefan Schwoon, http://www.lsv.fr/Publis/PAPERS/PDF/schwoon-phd02.pdf  *)

(* Note: This is a first attempt, and is definitely 'work-in-progress'. *)

typedecl state
typedecl label

(* Define the states and labels to be fixed but arbitrary sets.
   Would it be better to have them as parameters? E.g. if we want to prove something about a specific construction of a PDS. *)
consts P_states :: "state set"
consts \<Gamma> :: "label set"
datatype operation = pop | swap "label" | push "label" "label"
type_synonym rule = "(state \<times> label) \<times> (state \<times> operation)"
consts \<Delta> :: "rule set"
definition \<P> where (* This is the PDS *)
  "\<P> = (P_states, \<Gamma>, \<Delta>)"

(* An aside on the push operation:
   push is here defined as Schwoon does it, where it replaces the top label with a word of length 2.
   In the tool, we define push as just appending one label in top.
   (In Schwoon's terms, for the rule \<langle>p,\<gamma>\<rangle> \<hookrightarrow> \<langle>p', \<gamma>\<^sub>1 \<gamma>\<^sub>2\<rangle> we require that \<gamma> = \<gamma>\<^sub>2.)
   I believe this restriction could potentially simplify the post* algorithm, though I have not actually worked out the details.
 *)

primrec op_labels :: "operation \<Rightarrow> label list" where
  "op_labels pop = []"
| "op_labels (swap \<gamma>) = [\<gamma>]"
| "op_labels (push \<gamma>  \<gamma>') = [\<gamma>, \<gamma>']"

type_synonym conf = "state \<times> label list" (* A configuration consists of a state and a label stack *)

definition is_rule :: "state \<times> label \<Rightarrow> state \<times> operation \<Rightarrow> bool" (infix "\<hookrightarrow>" 80) where
  "is_rule x y \<equiv> (x,y) \<in> \<Delta>"

primrec step' :: "label list \<Rightarrow> state \<Rightarrow> conf set" where
  "step' [] p = {}"
| "step' (\<gamma>#w') p = {(p', (op_labels w)@w') | p' w. (p,\<gamma>) \<hookrightarrow> (p', w)}"

(* Defines the immediate successors of a configuration in the PDS. *)
definition step :: "conf \<Rightarrow> conf set" where
  "step \<equiv> \<lambda>(p,w). step' w p"

definition step_relp :: "conf \<Rightarrow> conf \<Rightarrow> bool" where
  "step_relp c c' \<equiv> c' \<in> step c"
definition step_rel :: "conf rel" where
  "step_rel \<equiv> {(c, c'). step_relp c c'}"
definition step_starp  :: "state \<times> label list \<Rightarrow> state \<times> label list \<Rightarrow> bool" (infix "\<Rightarrow>\<^sup>*" 80) where
  "step_starp \<equiv> step_relp\<^sup>*\<^sup>*"
definition step_star :: "conf rel" where
  "step_star \<equiv> {(c, c'). step_starp c c'}"
abbreviation
  step_star_trans ("(_\<Rightarrow>\<^sup>*_\<Rightarrow>\<^sup>*_)" 80) where
  "c \<Rightarrow>\<^sup>* c' \<Rightarrow>\<^sup>* c'' \<equiv> (c \<Rightarrow>\<^sup>* c') \<and> (c' \<Rightarrow>\<^sup>* c'')"

(* For a set of configurations C, post*(C) is the set of all configurations reachable from C. *)
definition post_star :: "conf set \<Rightarrow> conf set" where
  "post_star C \<equiv> {c'. \<exists>c \<in> C. c \<Rightarrow>\<^sup>* c'}"
(* And pre*(C) is the set of all configurations that can reach a configuration in C. *)
definition pre_star :: "conf set \<Rightarrow> conf set" where
  "pre_star C \<equiv> {c'. \<exists>c \<in> C. c' \<Rightarrow>\<^sup>* c}"

(* For computing pre* and post*, we need to define a \<P>-automaton, which defines a regular set of configurations in the PDS \<P>.
   A \<P>-automaton is an NFA with multiple initial and final states. The initial states are exactly the states in \<P>.
   The label alphabet is the same as in \<P>.
 *)
consts QnotP :: "state set"
definition Q where
  "Q = QnotP \<union> P_states"
consts F :: "state \<Rightarrow> bool"
type_synonym transition = "state \<times> label \<times> state"

(* This defines a specific (but arbitrary) \<P>-automaton.
   However, the pre* and post* procedures build up the automaton, so maybe this is not useful. *)
consts my_rel :: "transition set" ("\<rightarrow>")
definition \<A> where
  "\<A> = (Q, \<Gamma>, \<rightarrow>, P_states, F)"

(* For any given set of transitions, this defines the set of tuples (p,w,q) such that there is a w-path from p to q. *)
inductive_set transition_star :: "transition set \<Rightarrow> (state \<times> label list \<times> state) set"
  for t :: "transition set" where
  transition_star_refl[iff]: "(p, [], p) \<in> (transition_star t)"
| transition_star_step: "\<lbrakk>(p,\<gamma>,q') \<in> t; (q',w,q) \<in> (transition_star t)\<rbrakk>
                           \<Longrightarrow> (p, \<gamma>#w, q) \<in> (transition_star t)"
inductive_cases transition_star_empty [elim]: "(p, [], q) \<in> (transition_star t)"
inductive_cases transition_star_cons: "(p, \<gamma>#w, q) \<in> (transition_star t)"

lemma transition_star_mono[mono]: "mono transition_star"
  unfolding mono_def
  apply clarsimp
  subgoal for x y p w q
    by (induct w arbitrary: p; blast intro: transition_star_step elim: transition_star_cons)
  done

(* A configuration (p,w) in \<P> is accepted by the \<P>-automaton, if there is an accepting w-path starting from p. *)
definition accepts :: "transition set \<Rightarrow> conf \<Rightarrow> bool" where
  "accepts ts \<equiv> \<lambda>(p,w). \<exists>q \<in> Q. F q \<and> (p,w,q)\<in>(transition_star ts)"

(* Potentially useful lemmas. *)

lemma accepts_mono[mono]: "mono accepts"
  using transition_star_mono
  unfolding mono_def accepts_def
  by blast

lemma accepts_cons: "\<lbrakk>(p, \<gamma>, q) \<in> ts; accepts ts (q, w)\<rbrakk> \<Longrightarrow> accepts ts (p, \<gamma> # w)"
  unfolding accepts_def
  using transition_star_step by auto

lemma accepts_unfold: "\<lbrakk>accepts ts (p, \<gamma> # w)\<rbrakk> \<Longrightarrow> \<exists>q. (p, \<gamma>, q) \<in> ts \<and> accepts ts (q, w)"
  unfolding accepts_def
  by (induct w; blast elim: transition_star_cons)
lemma accepts_unfoldn: "\<lbrakk>accepts ts (p, w' @ w)\<rbrakk> \<Longrightarrow> \<exists>q. (p, w', q) \<in> transition_star ts \<and> accepts ts (q, w)"
  unfolding accepts_def
  by (induct w' arbitrary: p w, fastforce)
     (simp, blast intro: transition_star_step elim: transition_star_cons)

lemma accepts_append: "\<lbrakk>(p, w', q) \<in> transition_star ts; accepts ts (q, w)\<rbrakk> \<Longrightarrow> accepts ts (p, w' @ w)"
  unfolding accepts_def
  using transition_star_step
  by (induct w' arbitrary: w p q, fastforce)
     (clarsimp, metis (no_types, lifting) list.discI list.inject transition_star.cases)

(*
fun accept_fun :: "conf \<Rightarrow> bool" where
  "accept_fun (p, []) = F p"
| "accept_fun (p, \<gamma>#w) = (\<exists>q \<in> Q. (p, \<gamma>, q) \<in> rel \<and> accept_fun (q, w))"
*)
definition language :: "transition set \<Rightarrow> conf set" where
  "language ts = {c. accepts ts c}"

end


theory Comp_Indist
imports "../Cyclic_Group_SPMF" Negligible
begin

text {* A probability ensemble is a family of random variables indexed by
  some input of arbitrary type and a natural number security size parameter.
  The space of events considered depends on the \emph{view}. *}

type_synonym ('a,'v) ensemble = "'a \<Rightarrow> nat \<Rightarrow> 'v spmf"

text {* A polynomial time distinguisher probablistically "characterises" an arbitrary SPMF.
  We assume a family of constants giving us a set of all polytime distinguishers for
  every type \<alpha>, indexed by a size parameter n \<in> nat. *}
consts polydist :: "nat \<Rightarrow> ('v spmf \<Rightarrow> bool spmf) set"

text {* This is close to Lindell although seems convoluted.
  Lindell quantifies over all D, then asserts \<epsilon> and quantifies over
  inputs and n.  Then he later says he assumes D is polytime in n.  *}

definition comp_indist :: "('a,'v) ensemble \<Rightarrow> ('a,'v) ensemble \<Rightarrow> bool"
where "comp_indist X Y \<equiv>
   \<forall> (D :: 'v spmf \<Rightarrow> bool spmf).
    \<exists> (\<epsilon> :: nat \<Rightarrow> real). negligible \<epsilon> \<and>
       (\<forall> (a :: 'a) (n :: nat).
            (D \<in> polydist n) \<longrightarrow>
              \<bar>spmf (D (X a n)) True - spmf (D (Y a n)) True\<bar> \<le> \<epsilon> n)"

lemma neg_ex: "\<forall> D. \<exists> \<epsilon>. negligible \<epsilon> \<and> (\<forall>n. D \<in> polydist n \<longrightarrow> 0 \<le> \<epsilon> n)"
by(rule allI, rule_tac x = "0" in exI, simp)

lemma eq_comp_in[simp]: "comp_indist X X"
by(simp add: comp_indist_def neg_ex)

lemma comp_in_order: "comp_indist X Y \<longleftrightarrow> comp_indist Y X"
by(simp add: comp_indist_def Groups.ordered_ab_group_add_abs_class.abs_minus_commute)

lemma comp_in_trans: "\<lbrakk>comp_indist X Y;comp_indist Y Z\<rbrakk> \<Longrightarrow> comp_indist X Z"
apply(simp add: comp_indist_def, rule allI)
apply(erule_tac x="D" in allE, erule exE, erule conjE)+
apply(rule_tac x="\<lambda>n. \<epsilon> n + \<epsilon>' n" in exI)
apply(rule conjI, simp add: Negligible.negligible_plus)
apply(rule allI, rule allI, rule impI)
apply(erule_tac x="a" in allE, erule_tac x="n" in allE)+
by auto

end


(*  Title:      min.thy
    Author:     1f604
    Date:       8 June 2017

Find min of 2 numbers
*)

theory min imports Hoare_Logic  begin

lemma min:  "VARS X Y Z a b
 {True}
X := a;
Y := b;
Z := 0;
 WHILE X ≠ 0 ∧ Y ≠ 0
 INV {Z + min X Y = min a b ∧ 0≤X ∧ 0≤Y }
 DO X := X - (1::nat); Y := Y - (1::nat); Z := Z+(1::nat) OD
 {Z = min a b}"
  apply vcg_simp
    apply auto
done

end


(* Author: Andreas Lochbihler, ETH Zurich *)

theory Applicative_Vector imports
  Applicative
  "HOL-Analysis.Finite_Cartesian_Product"
  "HOL-Library.Adhoc_Overloading"
begin

definition pure_vec :: "'a \<Rightarrow> ('a, 'b :: finite) vec"
where "pure_vec x = (\<chi> _ . x)"

definition ap_vec :: "('a \<Rightarrow> 'b, 'c :: finite) vec \<Rightarrow> ('a, 'c) vec \<Rightarrow> ('b, 'c) vec"
where "ap_vec f x = (\<chi> i. (f $ i) (x $ i))"

adhoc_overloading Applicative.ap ap_vec

applicative vec (K, W)
for
  pure: pure_vec
  ap: ap_vec
by(auto simp add: pure_vec_def ap_vec_def vec_nth_inverse)

lemma pure_vec_nth [simp]: "pure_vec x $ i = x"
by(simp add: pure_vec_def)

lemma ap_vec_nth [simp]: "ap_vec f x $ i  = (f $ i) (x $ i)"
by(simp add: ap_vec_def)

end


section \<open> Conversion Between Unit Systems \<close>

theory ISQ_Conversion
  imports ISQ_Units
begin

subsection \<open> Conversion Schemas \<close>

text \<open>  A conversion schema provides factors for each of the base units for converting between
  two systems of units. We currently only support conversion between systems that can meaningfully
  characterise a subset of the seven SI dimensions. \<close>

record ConvSchema =
  cLengthF      :: rat
  cMassF        :: rat
  cTimeF        :: rat
  cCurrentF     :: rat
  cTemperatureF :: rat
  cAmountF      :: rat
  cIntensityF   :: rat

text \<open> We require that all the factors of greater than zero. \<close>

typedef ('s\<^sub>1::unit_system, 's\<^sub>2::unit_system) Conversion ("(_/ \<Rightarrow>\<^sub>U _)" [1, 0] 0) =
  "{c :: ConvSchema. cLengthF c > 0 \<and> cMassF c > 0 \<and> cTimeF c > 0 \<and> cCurrentF c > 0
         \<and> cTemperatureF c > 0 \<and> cAmountF c > 0 \<and> cIntensityF c > 0}"
  by (rule_tac x="\<lparr> cLengthF = 1, cMassF = 1, cTimeF = 1, cCurrentF = 1
                  , cTemperatureF = 1, cAmountF = 1, cIntensityF = 1 \<rparr>" in exI, simp)

setup_lifting type_definition_Conversion

lift_definition LengthF      :: "('s\<^sub>1::unit_system \<Rightarrow>\<^sub>U 's\<^sub>2::unit_system) \<Rightarrow> rat" is cLengthF .
lift_definition MassF        :: "('s\<^sub>1::unit_system \<Rightarrow>\<^sub>U 's\<^sub>2::unit_system) \<Rightarrow> rat" is cMassF .
lift_definition TimeF        :: "('s\<^sub>1::unit_system \<Rightarrow>\<^sub>U 's\<^sub>2::unit_system) \<Rightarrow> rat" is cTimeF .
lift_definition CurrentF     :: "('s\<^sub>1::unit_system \<Rightarrow>\<^sub>U 's\<^sub>2::unit_system) \<Rightarrow> rat" is cCurrentF .
lift_definition TemperatureF :: "('s\<^sub>1::unit_system \<Rightarrow>\<^sub>U 's\<^sub>2::unit_system) \<Rightarrow> rat" is cTemperatureF .
lift_definition AmountF      :: "('s\<^sub>1::unit_system \<Rightarrow>\<^sub>U 's\<^sub>2::unit_system) \<Rightarrow> rat" is cAmountF .
lift_definition IntensityF   :: "('s\<^sub>1::unit_system \<Rightarrow>\<^sub>U 's\<^sub>2::unit_system) \<Rightarrow> rat" is cIntensityF .

lemma Conversion_props [simp]: "LengthF c > 0" "MassF c > 0" "TimeF c > 0" "CurrentF c > 0"
  "TemperatureF c > 0" "AmountF c > 0" "IntensityF c > 0"
  by (transfer, simp)+

subsection \<open> Conversion Algebra \<close>

lift_definition convid :: "'s::unit_system \<Rightarrow>\<^sub>U 's" ("id\<^sub>C")
is "
  \<lparr> cLengthF = 1
  , cMassF = 1
  , cTimeF = 1
  , cCurrentF = 1
  , cTemperatureF = 1
  , cAmountF = 1
  , cIntensityF = 1 \<rparr>" by simp

lift_definition convcomp ::
  "('s\<^sub>2 \<Rightarrow>\<^sub>U 's\<^sub>3::unit_system) \<Rightarrow> ('s\<^sub>1::unit_system \<Rightarrow>\<^sub>U 's\<^sub>2::unit_system) \<Rightarrow> ('s\<^sub>1 \<Rightarrow>\<^sub>U 's\<^sub>3)" (infixl "\<circ>\<^sub>C" 55) is
"\<lambda> c\<^sub>1 c\<^sub>2. \<lparr> cLengthF = cLengthF c\<^sub>1 * cLengthF c\<^sub>2, cMassF = cMassF c\<^sub>1 * cMassF c\<^sub>2
         , cTimeF = cTimeF c\<^sub>1 * cTimeF c\<^sub>2, cCurrentF = cCurrentF c\<^sub>1 * cCurrentF c\<^sub>2
         , cTemperatureF = cTemperatureF c\<^sub>1 * cTemperatureF c\<^sub>2
         , cAmountF = cAmountF c\<^sub>1 * cAmountF c\<^sub>2, cIntensityF = cIntensityF c\<^sub>1 * cIntensityF c\<^sub>2 \<rparr>"
  by simp

lift_definition convinv :: "('s\<^sub>1::unit_system \<Rightarrow>\<^sub>U 's\<^sub>2::unit_system) \<Rightarrow> ('s\<^sub>2 \<Rightarrow>\<^sub>U 's\<^sub>1)" ("inv\<^sub>C") is
"\<lambda> c. \<lparr> cLengthF = inverse (cLengthF c), cMassF = inverse (cMassF c), cTimeF = inverse (cTimeF c)
      , cCurrentF = inverse (cCurrentF c), cTemperatureF = inverse (cTemperatureF c)
      , cAmountF = inverse (cAmountF c), cIntensityF = inverse (cIntensityF c) \<rparr>" by simp

lemma convinv_inverse [simp]: "convinv (convinv c) = c"
  by (transfer, simp)

lemma convcomp_inv [simp]: "c \<circ>\<^sub>C inv\<^sub>C c = id\<^sub>C"
  by (transfer, simp)

lemma inv_convcomp [simp]: "inv\<^sub>C c \<circ>\<^sub>C c = id\<^sub>C"
  by (transfer, simp)

lemma Conversion_invs [simp]: "LengthF (inv\<^sub>C x) = inverse (LengthF x)" "MassF (inv\<^sub>C x) = inverse (MassF x)"
  "TimeF (inv\<^sub>C x) = inverse (TimeF x)" "CurrentF (inv\<^sub>C x) = inverse (CurrentF x)"
  "TemperatureF (inv\<^sub>C x) = inverse (TemperatureF x)" "AmountF (inv\<^sub>C x) = inverse (AmountF x)"
  "IntensityF (inv\<^sub>C x) = inverse (IntensityF x)"
  by (transfer, simp)+

lemma Conversion_comps [simp]: "LengthF (c\<^sub>1 \<circ>\<^sub>C c\<^sub>2) = LengthF c\<^sub>1 * LengthF c\<^sub>2"
  "MassF (c\<^sub>1 \<circ>\<^sub>C c\<^sub>2) = MassF c\<^sub>1 * MassF c\<^sub>2"
  "TimeF (c\<^sub>1 \<circ>\<^sub>C c\<^sub>2) = TimeF c\<^sub>1 * TimeF c\<^sub>2"
  "CurrentF (c\<^sub>1 \<circ>\<^sub>C c\<^sub>2) = CurrentF c\<^sub>1 * CurrentF c\<^sub>2"
  "TemperatureF (c\<^sub>1 \<circ>\<^sub>C c\<^sub>2) = TemperatureF c\<^sub>1 * TemperatureF c\<^sub>2"
  "AmountF (c\<^sub>1 \<circ>\<^sub>C c\<^sub>2) = AmountF c\<^sub>1 * AmountF c\<^sub>2"
  "IntensityF (c\<^sub>1 \<circ>\<^sub>C c\<^sub>2) = IntensityF c\<^sub>1 * IntensityF c\<^sub>2"
  by (transfer, simp)+

subsection \<open> Conversion Functions \<close>

definition dconvfactor :: "('s\<^sub>1::unit_system \<Rightarrow>\<^sub>U 's\<^sub>2::unit_system) \<Rightarrow> Dimension \<Rightarrow> rat" where
"dconvfactor c d =
  LengthF c ^\<^sub>Z dim_nth d Length
  * MassF c ^\<^sub>Z dim_nth d Mass
  * TimeF c ^\<^sub>Z dim_nth d Time
  * CurrentF c ^\<^sub>Z dim_nth d Current
  * TemperatureF c ^\<^sub>Z dim_nth d Temperature
  * AmountF c ^\<^sub>Z dim_nth d Amount
  * IntensityF c ^\<^sub>Z dim_nth d Intensity"

lemma dconvfactor_pos [simp]: "dconvfactor c d > 0"
  by (simp add: dconvfactor_def)

lemma dconvfactor_nz [simp]: "dconvfactor c d \<noteq> 0"
  by (metis dconvfactor_pos less_numeral_extra(3))

lemma dconvfactor_convinv: "dconvfactor (convinv c) d = inverse (dconvfactor c d)"
  by (simp add: dconvfactor_def intpow_inverse[THEN sym])

lemma dconvfactor_id [simp]: "dconvfactor id\<^sub>C d = 1"
  by (simp add: dconvfactor_def, transfer, simp)

lemma dconvfactor_compose:
  "dconvfactor (c\<^sub>1 \<circ>\<^sub>C c\<^sub>2) d = dconvfactor c\<^sub>1 d * dconvfactor c\<^sub>2 d"
  by (simp add: dconvfactor_def, transfer, simp add: mult_ac intpow_mult_distrib)

lemma dconvfactor_inverse:
  "dconvfactor c (inverse d) = inverse (dconvfactor c d)"
  by (simp add: dconvfactor_def inverse_dimvec_def intpow_uminus)

lemma dconvfactor_times:
  "dconvfactor c (x \<cdot> y) = dconvfactor c x \<cdot> dconvfactor c y"
  by (auto simp add: dconvfactor_def  mult_ac intpow_mult_combine times_dimvec_def)

lift_definition qconv :: "('s\<^sub>1, 's\<^sub>2) Conversion \<Rightarrow> ('a::field_char_0)['d::dim_type, 's\<^sub>1::unit_system] \<Rightarrow> 'a['d, 's\<^sub>2::unit_system]"
is "\<lambda> c q. \<lparr> mag = of_rat (dconvfactor c (dim q)) * mag q, dim = dim q, unit_sys = unit \<rparr>" by simp

lemma magQ_qconv: "\<lbrakk>qconv c q\<rbrakk>\<^sub>Q = of_rat (dconvfactor c (dimQ q)) * \<lbrakk>q\<rbrakk>\<^sub>Q"
  by (simp add: si_def, transfer, simp)

lemma qconv_id [simp]: "qconv id\<^sub>C x = x"
  by (transfer', simp add: Measurement_System_eq_intro)

lemma qconv_comp: "qconv (c\<^sub>1 \<circ>\<^sub>C c\<^sub>2) x = qconv c\<^sub>1 (qconv c\<^sub>2 x)"
  by (transfer, simp add: dconvfactor_compose of_rat_mult)

lemma qconv_convinv [simp]: "qconv (convinv c) (qconv c x) = x"
  by (transfer, simp add: dconvfactor_convinv mult.assoc[THEN sym] of_rat_mult[THEN sym] Measurement_System_eq_intro)

lemma qconv_scaleQ [simp]: "qconv c (d *\<^sub>Q x) = d *\<^sub>Q qconv c x"
  by (transfer, simp)

lemma qconv_plus [simp]: "qconv c (x + y) = qconv c x + qconv c y"
  by (transfer, auto simp add: plus_Quantity_ext_def mult.commute ring_class.ring_distribs)

lemma qconv_minus [simp]: "qconv c (x - y) = qconv c x - qconv c y"
  by (transfer, auto simp add: plus_Quantity_ext_def mult.commute ring_class.ring_distribs)

lemma qconv_qmult [simp]: "qconv c (x \<^bold>\<cdot> y) = qconv c x \<^bold>\<cdot> qconv c y"
  by (transfer, simp add: times_Quantity_ext_def times_Measurement_System_ext_def dconvfactor_times of_rat_mult)

lemma qconv_qinverse [simp]: "qconv c (x\<^sup>-\<^sup>\<one>) = (qconv c x)\<^sup>-\<^sup>\<one>"
  by (transfer, simp add: inverse_Quantity_ext_def inverse_Measurement_System_ext_def dconvfactor_inverse of_rat_inverse)

lemma qconv_Length [simp]: "qconv c BUNIT(L, _) = LengthF c *\<^sub>Q BUNIT(L, _)"
  by (simp add: dconvfactor_def magQ_qconv si_eq mk_BaseDim_def one_dimvec_def)

lemma qconv_Mass [simp]: "qconv c BUNIT(M, _) = MassF c *\<^sub>Q BUNIT(M, _)"
  by (simp add: dconvfactor_def magQ_qconv si_eq mk_BaseDim_def one_dimvec_def)

lemma qconv_Time [simp]: "qconv c BUNIT(T, _) = TimeF c *\<^sub>Q BUNIT(T, _)"
  by (simp add: dconvfactor_def magQ_qconv si_eq mk_BaseDim_def one_dimvec_def)

lemma qconv_Current [simp]: "qconv c BUNIT(I, _) = CurrentF c *\<^sub>Q BUNIT(I, _)"
  by (simp add: dconvfactor_def magQ_qconv si_eq mk_BaseDim_def one_dimvec_def)

lemma qconv_Temperature [simp]: "qconv c BUNIT(\<Theta>, _) = TemperatureF c *\<^sub>Q BUNIT(\<Theta>, _)"
  by (simp add: dconvfactor_def magQ_qconv si_eq mk_BaseDim_def one_dimvec_def)

lemma qconv_Amount [simp]: "qconv c BUNIT(N, _) = AmountF c *\<^sub>Q BUNIT(N, _)"
  by (simp add: dconvfactor_def magQ_qconv si_eq mk_BaseDim_def one_dimvec_def)

lemma qconv_Intensity [simp]: "qconv c BUNIT(J, _) = IntensityF c *\<^sub>Q BUNIT(J, _)"
  by (simp add: dconvfactor_def magQ_qconv si_eq mk_BaseDim_def one_dimvec_def)

end