section \<open>Security of one-time-pad encryption\<close>

theory One_Time_Pad imports
  System_Construction
begin

definition key :: "security \<Rightarrow> bool list spmf" where
  "key \<eta> \<equiv> spmf_of_set (nlists UNIV \<eta>)"

definition enc :: "security \<Rightarrow> bool list \<Rightarrow> bool list \<Rightarrow> bool list spmf" where
  "enc \<eta> k m \<equiv> return_spmf (k [\<oplus>] m)"

definition dec :: "security \<Rightarrow> bool list \<Rightarrow> bool list \<Rightarrow> bool list option" where
  "dec \<eta> k c \<equiv> Some (k [\<oplus>] c)"

definition sim :: "'b list option \<Rightarrow> 'a \<Rightarrow> ('b list option \<times> 'b list option, 'a, nat option) gpv" where
  "sim c q \<equiv> (do {
    lo \<leftarrow> Pause q Done;
    (case lo of
      Some n \<Rightarrow> if c = None
        then do {
          x \<leftarrow> lift_spmf (spmf_of_set (nlists UNIV n));
          Done (Some x, Some x)}
        else Done (c, c)
    | None   \<Rightarrow> Done (None, c))})"

context
  fixes \<eta> :: "security"
begin

private definition key_channel_send :: "bool list option \<times> bool list  cstate
  \<Rightarrow> bool list \<Rightarrow> (unit \<times> bool list option \<times> bool list cstate) spmf" where
  "key_channel_send s m \<equiv> do {
    (k, s) \<leftarrow> (key.key_oracle (key \<eta>))\<dagger> s ();
    c \<leftarrow> enc \<eta> k m;
    (_, s) \<leftarrow> \<dagger>channel.send_oracle s c;
    return_spmf ((), s)}"

private definition key_channel_recv :: "bool list option \<times> bool list cstate
  \<Rightarrow> 'a \<Rightarrow> (bool list option \<times> bool list option \<times> bool list cstate) spmf" where
  "key_channel_recv s m \<equiv>do {
    (c, s) \<leftarrow> \<dagger>channel.recv_oracle s ();
    (case c of None \<Rightarrow> return_spmf (None, s)
    | Some c' \<Rightarrow> do {
      (k, s) \<leftarrow> (key.key_oracle (key \<eta>))\<dagger> s ();
      return_spmf (dec \<eta> k c', s)})}"

private abbreviation callee_sec_channel where
  "callee_sec_channel callee \<equiv> lift_state_oracle extend_state_oracle (attach_callee callee sec_channel.sec_oracle)"

private inductive S :: "(bool list option \<times> unit \<times> bool list cstate) spmf \<Rightarrow>
  (bool list option \<times> bool list cstate) spmf \<Rightarrow> bool" where
  "S (return_spmf (None, (), Void))
     (return_spmf (None, Void))"
| "S (return_spmf (None, (), Store plain))
     (map_spmf (\<lambda>key. (Some key, Store (key [\<oplus>] plain))) (spmf_of_set (nlists UNIV \<eta>)))"
if "length plain = id' \<eta>"
| "S (return_spmf (None, (), Collect plain))
     (map_spmf (\<lambda>key. (Some key, Collect (key [\<oplus>] plain))) (spmf_of_set (nlists UNIV \<eta>)))"
if "length plain = id' \<eta>"
| "S (return_spmf (Some (key [\<oplus>] plain), (), Store plain))
     (return_spmf (Some key, Store (key [\<oplus>] plain)))"
if "length plain = id' \<eta>" "length key = id' \<eta>" for key
| "S (return_spmf (Some (key [\<oplus>] plain), (), Collect plain))
     (return_spmf (Some key, Collect (key [\<oplus>] plain)))"
if "length plain = id' \<eta>" "length key = id' \<eta>" for key
| "S (return_spmf (None, (), Fail))
     (map_spmf (\<lambda>x. (Some x, Fail)) (spmf_of_set (nlists UNIV \<eta>)))"
| "S (return_spmf (Some (key [\<oplus>] plain), (), Fail))
     (return_spmf (Some key, Fail))"
if "length plain = id' \<eta>" "length key = id' \<eta>" for key plain

lemma resources_indistinguishable:
  shows "(UNIV <+> nlists UNIV (id' \<eta>) <+> UNIV) \<turnstile>\<^sub>R
    RES (callee_sec_channel sim \<oplus>\<^sub>O \<dagger>\<dagger>channel.send_oracle \<oplus>\<^sub>O \<dagger>\<dagger>channel.recv_oracle) (None :: bool list option, (), Void)
    \<approx>
    RES (\<dagger>auth_channel.auth_oracle \<oplus>\<^sub>O key_channel_send \<oplus>\<^sub>O key_channel_recv) (None :: bool list option, Void)"
    (is "?A \<turnstile>\<^sub>R RES (?L1 \<oplus>\<^sub>O ?L2 \<oplus>\<^sub>O ?L3) ?SL \<approx> RES (?R1 \<oplus>\<^sub>O ?R2 \<oplus>\<^sub>O ?R3) ?SR")
proof -
  note [simp] =
    exec_gpv_bind spmf.map_comp o_def map_bind_spmf bind_map_spmf bind_spmf_const
    sec_channel.sec_oracle.simps auth_channel.auth_oracle.simps
    channel.send_oracle.simps key_channel_send_def
    channel.recv_oracle.simps key_channel_recv_def
    key.key_oracle.simps dec_def key_def enc_def

  have *: "?A \<turnstile>\<^sub>C ?L1 \<oplus>\<^sub>O ?L2 \<oplus>\<^sub>O ?L3(?SL) \<approx> ?R1 \<oplus>\<^sub>O ?R2 \<oplus>\<^sub>O ?R3(?SR)"
  proof(rule trace'_eqI_sim[where S=S], goal_cases Init_OK Output_OK State_OK)
    case Init_OK
    show ?case by (simp add: S.simps)
  next
    case (Output_OK p q query)
    show ?case
    proof (cases query)
      case (Inl adv_query)
      with Output_OK show ?thesis
      proof (cases adv_query)
        case Look
        with Output_OK Inl show ?thesis
        proof cases
          case Store_State_Channel: (2 plain)

          have*: "length plain = id' \<eta> \<Longrightarrow>
            map_spmf (\<lambda>x. Inl (Some x)) (spmf_of_set (nlists UNIV (id' \<eta>))) =
            map_spmf (\<lambda>x. Inl (Some x)) (map_spmf (\<lambda>x. x [\<oplus>] plain) (spmf_of_set (nlists UNIV \<eta>)))" for \<eta>
            unfolding id'_def by (subst xor_list_commute, subst one_time_pad[where xs=plain, symmetric]) simp_all

          from Store_State_Channel show ?thesis using Output_OK(2-) Inl Look
            by(simp add: sim_def, simp add: map_spmf_conv_bind_spmf[symmetric])
              (subst (2) spmf.map_comp[where f="\<lambda>x. Inl (Some x)", symmetric, unfolded o_def], simp only: *)
        qed (auto simp add: sim_def)
      qed (auto simp add: sim_def id'_def elim: S.cases)
    next
      case Snd_Rcv: (Inr query')
      with Output_OK show ?thesis
      proof (cases query')
        case (Inr rcv_query)
        with Output_OK Snd_Rcv show ?thesis
        proof cases
          case Collect_State_Channel: (3 plain)
          then show ?thesis using Output_OK(2-) Snd_Rcv Inr
            by (simp cong: bind_spmf_cong_simp add: in_nlists_UNIV id'_def)
        qed simp_all
      qed (auto elim: S.cases)
    qed
  next
    case (State_OK p q query state answer state')
    then show ?case
    proof (cases query)
      case (Inl adv_query)
      with State_OK show ?thesis
      proof (cases adv_query)
        case Look
        with State_OK Inl show ?thesis
        proof cases
          case Store_State_Channel: (2 plain)
          have *: "length plain = id' \<eta> \<Longrightarrow> key \<in> nlists UNIV \<eta>  \<Longrightarrow>
            S (cond_spmf_fst (map_spmf (\<lambda>x. (Inl (Some x), Some x, (), Store plain))
               (spmf_of_set (nlists UNIV (id' \<eta>)))) (Inl (Some (key [\<oplus>] plain))))
            (cond_spmf_fst  (map_spmf (\<lambda>x. (Inl (Some (x [\<oplus>] plain)), Some x, Store (x [\<oplus>] plain)))
               (spmf_of_set (nlists UNIV \<eta>))) (Inl (Some (key [\<oplus>] plain))))" for key
          proof(subst (1 2) cond_spmf_fst_map_Pair1, goal_cases)
            case 2
            note inj_onD[OF inj_on_xor_list_nlists, rotated, simplified xor_list_commute]
            with 2 show ?case
              unfolding inj_on_def by (auto simp add: id'_def)
          next
            case 5
            note inj_onD[OF inj_on_xor_list_nlists, rotated, simplified xor_list_commute]
            with 5 show ?case
              by (subst (1 2 3) inv_into_f_f)
                ((clarsimp simp add: inj_on_def), (auto simp add: S.simps id'_def inj_on_def in_nlists_UNIV ))
          qed (simp_all add: id'_def in_nlists_UNIV min_def inj_on_def)
          from Store_State_Channel show ?thesis using State_OK(2-) Inl Look
            by (clarsimp simp add: sim_def) (simp add: map_spmf_conv_bind_spmf[symmetric] * )
        qed (auto simp add: sim_def map_spmf_conv_bind_spmf[symmetric] S.simps)
      qed (erule S.cases; (simp add: sim_def, auto simp add: map_spmf_conv_bind_spmf[symmetric] S.simps))+
    next
      case Snd_Rcv: (Inr query')
      with State_OK show ?thesis
      proof (cases query')
        case (Inr rcv_query)
        with State_OK Snd_Rcv show ?thesis
        proof cases
          case Collect_State_Channel: (3 plain)
          then show ?thesis using State_OK(2-) Snd_Rcv Inr
            by clarsimp (simp add: S.simps in_nlists_UNIV id'_def map_spmf_conv_bind_spmf[symmetric] cong: bind_spmf_cong_simp)
        qed (simp add: sim_def, auto simp add: map_spmf_conv_bind_spmf[symmetric] S.simps)
      qed (erule S.cases,
          (simp add: sim_def, auto simp add: map_spmf_conv_bind_spmf[symmetric] S.simps  in_nlists_UNIV))
    qed
  qed

  from * show ?thesis by simp
qed

lemma real_resource_wiring:
  shows "cipher.res (key \<eta>) (enc \<eta>) (dec \<eta>)
    = RES (\<dagger>auth_channel.auth_oracle \<oplus>\<^sub>O key_channel_send \<oplus>\<^sub>O key_channel_recv) (None, Void)"
  including lifting_syntax
proof -
  note[simp]= Rel_def prod.rel_eq[symmetric] split_def split_beta o_def exec_gpv_bind bind_map_spmf
    resource_of_oracle_rprodl rprodl_extend_state_oracle
    conv_callee_parallel[symmetric] extend_state_oracle_plus_oracle[symmetric]
    attach_CNV_RES attach_callee_parallel_intercept attach_stateless_callee

  show ?thesis
    unfolding channel.res_def cipher.res_def  cipher.routing_def cipher.enc_def cipher.dec_def
      interface_wiring cipher.\<pi>E_def key.res_def key_channel_send_def key_channel_recv_def
    by (simp add: conv_callee_parallel_id_left[where s="()", symmetric])
      ((auto cong: option.case_cong simp add: option.case_distrib[where h="\<lambda>gpv. exec_gpv _ gpv _"]
          intro!: extend_state_oracle_parametric ) | subst lift_state_oracle_extend_state_oracle)+
qed

lemma ideal_resource_wiring:
  shows "(CNV callee s) |\<^sub>= 1\<^sub>C \<rhd> channel.res sec_channel.sec_oracle
    = RES (callee_sec_channel callee \<oplus>\<^sub>O \<dagger>\<dagger>channel.send_oracle \<oplus>\<^sub>O \<dagger>\<dagger>channel.recv_oracle ) (s, (), Void)"  (is "?L1 \<rhd> _ = ?R")
proof -
  have[simp]: "\<I>_full, \<I>_full \<oplus>\<^sub>\<I> (\<I>_full \<oplus>\<^sub>\<I> \<I>_full) \<turnstile>\<^sub>C ?L1 \<sim> ?L1" (is "_, ?I \<turnstile>\<^sub>C _ \<sim> _")
    by(rule eq_\<I>_converter_mono)
      (rule parallel_converter2_eq_\<I>_cong eq_\<I>_converter_reflI WT_converter_\<I>_full \<I>_full_le_plus_\<I> order_refl plus_\<I>_mono)+

  have[simp]: "?I \<turnstile>c (sec_channel.sec_oracle \<oplus>\<^sub>O channel.send_oracle \<oplus>\<^sub>O channel.recv_oracle) s \<surd>" for s
    by(rule WT_plus_oracleI WT_parallel_oracle WT_callee_full; (unfold split_paired_all)?)+

  have[simp]: "?L1 \<rhd> RES (sec_channel.sec_oracle \<oplus>\<^sub>O channel.send_oracle \<oplus>\<^sub>O channel.recv_oracle) Void = ?R"
    by(simp add: conv_callee_parallel_id_right[where s'="()", symmetric] attach_CNV_RES
        attach_callee_parallel_intercept resource_of_oracle_rprodl extend_state_oracle_plus_oracle)

  show ?thesis unfolding channel.res_def
    by (subst eq_\<I>_attach[OF WT_resource_of_oracle, where ?\<I>' = "?I" and ?conv="?L1" and ?conv'="?L1"]) simp_all
qed

end

lemma eq_\<I>_gpv_Done1:
  "eq_\<I>_gpv A \<I> (Done x) gpv \<longleftrightarrow> lossless_spmf (the_gpv gpv) \<and> (\<forall>a\<in>set_spmf (the_gpv gpv). eq_\<I>_generat A \<I> (eq_\<I>_gpv A \<I>) (Pure x) a)"
  by(auto intro: eq_\<I>_gpv.intros simp add: rel_spmf_return_spmf1 elim: eq_\<I>_gpv.cases)

lemma eq_\<I>_gpv_Done2:
  "eq_\<I>_gpv A \<I> gpv (Done x) \<longleftrightarrow> lossless_spmf (the_gpv gpv) \<and> (\<forall>a\<in>set_spmf (the_gpv gpv). eq_\<I>_generat A \<I> (eq_\<I>_gpv A \<I>) a (Pure x))"
  by(auto intro: eq_\<I>_gpv.intros simp add: rel_spmf_return_spmf2 elim: eq_\<I>_gpv.cases)

context begin
interpretation CIPHER: cipher "key \<eta>" "enc \<eta>" "dec \<eta>" for \<eta> .
interpretation S_CHAN: sec_channel .

lemma one_time_pad:
  defines "\<I>_real \<equiv> \<lambda>\<eta>. \<I>_uniform UNIV (insert None (Some ` nlists UNIV \<eta>))"
    and "\<I>_ideal \<equiv> \<lambda>\<eta>. \<I>_uniform UNIV {None, Some \<eta>}"
    and "\<I>_common \<equiv> \<lambda>\<eta>. \<I>_uniform (nlists UNIV \<eta>) UNIV \<oplus>\<^sub>\<I> \<I>_uniform UNIV (insert None (Some ` nlists UNIV \<eta>))"
  shows
    "constructive_security2 CIPHER.res (\<lambda>_. S_CHAN.res) (\<lambda>_. CNV sim None)
     \<I>_real \<I>_ideal \<I>_common (\<lambda>_. \<infinity>) False (\<lambda>_. auth_sec_wiring)"
proof
  let ?\<I>_key = "\<lambda>\<eta>. \<I>_uniform UNIV (nlists UNIV \<eta>)"
  let ?\<I>_enc = "\<lambda>\<eta>. \<I>_uniform (nlists UNIV \<eta>) UNIV"
  let ?\<I>_dec = "\<lambda>\<eta>. \<I>_uniform UNIV (insert None (Some ` nlists UNIV \<eta>))"
  have i1 [WT_intro]: "\<I>_uniform (nlists UNIV \<eta>) UNIV, ?\<I>_key \<eta> \<oplus>\<^sub>\<I> ?\<I>_enc \<eta> \<turnstile>\<^sub>C CIPHER.enc \<eta> \<surd>" for \<eta>
    unfolding CIPHER.enc_def by(rule WT_converter_of_callee)(auto simp add: stateless_callee_def enc_def in_nlists_UNIV)
  have i2 [WT_intro]: "?\<I>_dec \<eta>, ?\<I>_key \<eta> \<oplus>\<^sub>\<I> ?\<I>_dec \<eta> \<turnstile>\<^sub>C CIPHER.dec \<eta> \<surd>" for \<eta>
    unfolding CIPHER.dec_def by(rule WT_converter_of_callee)(auto simp add: stateless_callee_def dec_def in_nlists_UNIV)
  have [WT_intro]: "\<I>_common \<eta>, (?\<I>_key \<eta> \<oplus>\<^sub>\<I> ?\<I>_enc \<eta>) \<oplus>\<^sub>\<I> (?\<I>_key \<eta> \<oplus>\<^sub>\<I> ?\<I>_dec \<eta>) \<turnstile>\<^sub>C CIPHER.enc \<eta> |\<^sub>= CIPHER.dec \<eta> \<surd>" for \<eta>
    unfolding \<I>_common_def by(rule WT_intro)+
  have key: "callee_invariant_on (CIPHER.KEY.key_oracle \<eta> \<oplus>\<^sub>O CIPHER.KEY.key_oracle \<eta>) (pred_option (\<lambda>x. length x = \<eta>))
     (?\<I>_key \<eta> \<oplus>\<^sub>\<I> ?\<I>_key \<eta>)" for \<eta>
    apply unfold_locales
    subgoal for s x y s' by(cases s; cases x)(auto simp add: option.pred_set, simp_all add: key_def in_nlists_UNIV)
    subgoal for s by(cases s)(auto intro!: WT_calleeI, simp_all add: key_def in_nlists_UNIV)
    done
  have i3: "?\<I>_key \<eta> \<oplus>\<^sub>\<I> ?\<I>_key \<eta> \<turnstile>res CIPHER.KEY.res \<eta> \<surd>" for \<eta>
    unfolding CIPHER.KEY.res_def by(rule callee_invariant_on.WT_resource_of_oracle[OF key]) simp
  let ?I = "\<lambda>\<eta>. pred_cstate (\<lambda>x. length x = \<eta>)"
  have WT_auth: "\<I>_real \<eta> \<turnstile>c CIPHER.AUTH.auth_oracle s \<surd>" if "?I \<eta> s" for \<eta> s
    apply(rule WT_calleeI)
    subgoal for x y s' using that
      by(cases "(s, x)" rule: CIPHER.AUTH.auth_oracle.cases)(auto simp add: \<I>_real_def in_nlists_UNIV intro!: imageI)
    done
  have WT_recv: "?\<I>_dec \<eta> \<turnstile>c S_CHAN.recv_oracle s \<surd>" if "pred_cstate (\<lambda>x. length x = \<eta>) s" for \<eta> s
    using that by(cases s)(auto intro!: WT_calleeI simp add: in_nlists_UNIV)
  have WT_send: "?\<I>_enc \<eta> \<turnstile>c S_CHAN.send_oracle s \<surd>" for \<eta> s
    by(rule WT_calleeI)(auto)
  have *: "callee_invariant_on (CIPHER.AUTH.auth_oracle \<oplus>\<^sub>O S_CHAN.send_oracle \<oplus>\<^sub>O S_CHAN.recv_oracle) (?I \<eta>)
     (\<I>_real \<eta> \<oplus>\<^sub>\<I> \<I>_common \<eta>)" for \<eta>
    apply unfold_locales
    subgoal for s x y s'
      by(cases x; cases "(s, projl x)" rule: CIPHER.AUTH.auth_oracle.cases; cases "projr x")(auto simp add: \<I>_common_def in_nlists_UNIV)
    subgoal by(auto simp add: \<I>_common_def WT_auth WT_recv intro: WT_calleeI)
    done
  have i4 [unfolded \<I>_common_def, WT_intro]: "\<I>_real \<eta> \<oplus>\<^sub>\<I> \<I>_common \<eta> \<turnstile>res CIPHER.AUTH.res \<surd>" for \<eta>
    unfolding CIPHER.AUTH.res_def by(rule callee_invariant_on.WT_resource_of_oracle[OF *]) simp
  show cipher: "\<I>_real \<eta> \<oplus>\<^sub>\<I> \<I>_common \<eta> \<turnstile>res CIPHER.res \<eta> \<surd>" for \<eta>
    unfolding CIPHER.res_def by(rule WT_intro i3)+

  show secure: "\<I>_ideal \<eta> \<oplus>\<^sub>\<I> \<I>_common \<eta> \<turnstile>res S_CHAN.res \<surd>" for \<eta>
  proof -
    have[simp]:"\<I>_ideal \<eta> \<turnstile>c S_CHAN.sec_oracle s \<surd>" if "?I \<eta> s" for s
    proof (cases rule: WT_calleeI, goal_cases)
      case (1 call ret s')
      then show ?case using that by (cases "(s, call)" rule: S_CHAN.sec_oracle.cases) (simp_all add: \<I>_ideal_def)
    qed
    have[simp]: "\<I>_common \<eta> \<turnstile>c (S_CHAN.send_oracle \<oplus>\<^sub>O S_CHAN.recv_oracle) s \<surd>"
      if "pred_cstate (\<lambda>x. length x = \<eta>) s" for s
      unfolding \<I>_common_def by(rule WT_plus_oracleI WT_send WT_recv that)+

    have *: "callee_invariant_on (S_CHAN.sec_oracle \<oplus>\<^sub>O S_CHAN.send_oracle \<oplus>\<^sub>O S_CHAN.recv_oracle) (?I \<eta>) (\<I>_ideal \<eta> \<oplus>\<^sub>\<I> \<I>_common \<eta>)"
      apply(unfold_locales)
      subgoal for s x y s'
        by(cases "(s, projl x)" rule: S_CHAN.sec_oracle.cases; cases "projr x")(auto simp add: \<I>_common_def in_nlists_UNIV)
      subgoal by simp
      done

    show ?thesis unfolding S_CHAN.res_def
      by(rule callee_invariant_on.WT_resource_of_oracle[OF *]) simp
  qed

  have sim [WT_intro]: "\<I>_real \<eta>, \<I>_ideal \<eta> \<turnstile>\<^sub>C CNV sim s \<surd>" if "s \<noteq> None \<longrightarrow> length (the s) = \<eta>" for s \<eta>
    using that by(coinduction arbitrary: s)(auto simp add: sim_def \<I>_ideal_def \<I>_real_def in_nlists_UNIV)
  show "\<I>_real \<eta>, \<I>_ideal \<eta> \<turnstile>\<^sub>C CNV sim None \<surd>" for \<eta> by(rule sim) simp

  { fix \<A> :: "security \<Rightarrow> (auth_query + bool list + unit, bool list option + unit + bool list option) distinguisher"
    assume WT: "\<And>\<eta>. \<I>_real \<eta> \<oplus>\<^sub>\<I> \<I>_common \<eta> \<turnstile>g \<A> \<eta> \<surd>"
      and bound: "\<And>\<eta>. interaction_bounded_by (\<lambda>_. True) (\<A> \<eta>) \<infinity>"
    have "connect (\<A> \<eta>) (CNV sim None |\<^sub>= 1\<^sub>C \<rhd> S_CHAN.res) = connect (\<A> \<eta>) (CIPHER.res \<eta>)" for \<eta>
      using _ WT
    proof(rule connect_cong_trace)
      show "(UNIV <+> nlists UNIV (id' \<eta>) <+> UNIV) \<turnstile>\<^sub>R CNV sim None |\<^sub>= 1\<^sub>C \<rhd> S_CHAN.res \<approx> CIPHER.res \<eta>"
        unfolding ideal_resource_wiring real_resource_wiring
        by(rule resources_indistinguishable)
      show "outs_gpv (\<I>_real \<eta> \<oplus>\<^sub>\<I> \<I>_common \<eta>) (\<A> \<eta>) \<subseteq> UNIV <+> nlists UNIV (id' \<eta>) <+> UNIV"
        using WT[of \<eta>, THEN WT_gpv_outs_gpv]
        by(auto simp add: \<I>_real_def \<I>_common_def id'_def)
      show "\<I>_real \<eta> \<oplus>\<^sub>\<I> \<I>_common \<eta> \<turnstile>res CIPHER.res \<eta> \<surd>" by(rule cipher)
      show "\<I>_real \<eta> \<oplus>\<^sub>\<I> \<I>_common \<eta> \<turnstile>res CNV sim None |\<^sub>= 1\<^sub>C \<rhd> S_CHAN.res \<surd>"
        by(rule WT_intro secure | simp)+
    qed
    then show "negligible (\<lambda>\<eta>. advantage (\<A> \<eta>) (CNV sim None |\<^sub>= 1\<^sub>C \<rhd> S_CHAN.res) (CIPHER.res \<eta>))"
      by(simp add: advantage_def)
  next
    let ?cnv = "map_converter id id auth_query_of sec_response_of 1\<^sub>C
      :: (auth_query, nat option, auth_query, bool list option) converter"
    have [simp]: "\<I>_full, map_\<I> id (map_option length) \<I>_full \<turnstile>\<^sub>C 1\<^sub>C \<surd>"
      using WT_converter_id order_refl
      by(rule WT_converter_mono)(simp add: le_\<I>_def)
    have WT [WT_intro]: "\<I>_ideal \<eta>, \<I>_real \<eta> \<turnstile>\<^sub>C ?cnv \<surd>" for \<eta>
      by(rule WT_converter_map_converter)(auto simp add: \<I>_ideal_def \<I>_real_def intro!: WT_converter_mono[OF WT_converter_id order_refl] simp add: le_\<I>_def in_nlists_UNIV)
    with eq_\<I>_converter_reflI[OF this]
    have "wiring (\<I>_ideal \<eta>) (\<I>_real \<eta>) ?cnv auth_sec_wiring" for \<eta> ..
    moreover
    have eq: "\<I>_ideal \<eta>, \<I>_ideal \<eta> \<turnstile>\<^sub>C map_converter id (map_option length) id id (CNV sim s) \<sim> 1\<^sub>C"
      if "s \<noteq> None \<longrightarrow> length (the s) = \<eta>" for \<eta> and s :: "bool list option"
      unfolding map_converter_of_callee map_gpv_conv_map_gpv'[symmetric] using that
      by(coinduction arbitrary: s)
        (fastforce intro!: eq_\<I>_gpv_Pause simp add: \<I>_ideal_def in_nlists_UNIV eq_\<I>_gpv_Done2 gpv.map_sel eq_onp_same_args sim_def map_gpv_conv_bind[symmetric] id_def[symmetric] split!: option.split if_split_asm)
    have "\<I>_ideal \<eta>, \<I>_ideal \<eta> \<turnstile>\<^sub>C ?cnv \<odot> CNV sim None \<surd>" for \<eta> by(rule WT WT_intro)+ simp
    with _ have "wiring (\<I>_ideal \<eta>) (\<I>_ideal \<eta>) (?cnv \<odot> CNV sim None) (id, id)" for \<eta>
      by(rule wiring.intros)(auto  simp add: comp_converter_map_converter1 comp_converter_id_left eq)
    ultimately show "\<exists>cnv. \<forall>\<eta>. wiring (\<I>_ideal \<eta>) (\<I>_real \<eta>) (cnv \<eta>) auth_sec_wiring \<and>
              wiring (\<I>_ideal \<eta>) (\<I>_ideal \<eta>) (cnv \<eta> \<odot> CNV sim None) (id, id)"
      by meson
  }
qed

end

end


section {* \isaheader{Generic Set Algorithms} *}
theory Gen_Set
imports "../Intf/Intf_Set" "../../Iterator/Iterator"
begin

  lemma foldli_union: "det_fold_set X (\<lambda>_. True) insert a (op \<union> a)"
  proof (rule, goal_cases)
    case (1 l) thus ?case
      by (induct l arbitrary: a) auto
  qed

  definition gen_union
    :: "_ \<Rightarrow> ('k \<Rightarrow> 's2 \<Rightarrow> 's2)
        \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> 's2"
    where
    "gen_union it ins A B \<equiv> it A (\<lambda>_. True) ins B"

  lemma gen_union[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes INS: "GEN_OP ins Set.insert (Rk\<rightarrow>\<langle>Rk\<rangle>Rs2\<rightarrow>\<langle>Rk\<rangle>Rs2)"
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 tsl)"
    shows "(gen_union (\<lambda>x. foldli (tsl x)) ins,op \<union>)
    \<in> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (\<langle>Rk\<rangle>Rs2) \<rightarrow> (\<langle>Rk\<rangle>Rs2)"
    apply (intro fun_relI)
    apply (subst Un_commute)
    unfolding gen_union_def
    apply (rule det_fold_set[OF
      foldli_union IT[unfolded autoref_tag_defs]])
    using INS
    unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_inter: "det_fold_set X (\<lambda>_. True)
    (\<lambda>x s. if x\<in>a then insert x s else s) {} (\<lambda>s. s\<inter>a)"
    (is "det_fold_set _ _ ?f _ _")
  proof -
    {
      fix l s0
      have "foldli l (\<lambda>_. True)
        (\<lambda>x s. if x\<in>a then insert x s else s) s0 = s0 \<union> (set l \<inter> a)"
        by (induct l arbitrary: s0) auto
    }
    from this[of _ "{}"] show ?thesis apply - by rule simp
  qed

  definition gen_inter :: "_ \<Rightarrow>
    ('k \<Rightarrow> 's2 \<Rightarrow> bool) \<Rightarrow> _"
    where "gen_inter it1 memb2 ins3 empty3 s1 s2
    \<equiv> it1 s1 (\<lambda>_. True)
      (\<lambda>x s. if memb2 x s2 then ins3 x s else s) empty3"

  lemma gen_inter[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 tsl)"
    assumes MEMB:
      "GEN_OP memb2 op \<in> (Rk \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id)"
    assumes INS:
      "GEN_OP ins3 Set.insert (Rk\<rightarrow>\<langle>Rk\<rangle>Rs3\<rightarrow>\<langle>Rk\<rangle>Rs3)"
    assumes EMPTY:
      "GEN_OP empty3 {} (\<langle>Rk\<rangle>Rs3)"
    shows "(gen_inter (\<lambda>x. foldli (tsl x)) memb2 ins3 empty3,op \<inter>)
    \<in> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (\<langle>Rk\<rangle>Rs2) \<rightarrow> (\<langle>Rk\<rangle>Rs3)"
    apply (intro fun_relI)
    unfolding gen_inter_def
    apply (rule det_fold_set[OF foldli_inter IT[unfolded autoref_tag_defs]])
    using MEMB INS EMPTY
    unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_diff:
    "det_fold_set X (\<lambda>_. True) (\<lambda>x s. op_set_delete x s) s (op - s)"
  proof (rule, goal_cases)
    case (1 l) thus ?case
      by (induct l arbitrary: s) auto
  qed

  definition gen_diff :: "('k\<Rightarrow>'s1\<Rightarrow>'s1) \<Rightarrow> _ \<Rightarrow> 's2 \<Rightarrow> _ "
    where "gen_diff del1 it2 s1 s2
    \<equiv> it2 s2 (\<lambda>_. True) (\<lambda>x s. del1 x s) s1"

  lemma gen_diff[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes DEL:
      "GEN_OP del1 op_set_delete (Rk \<rightarrow> \<langle>Rk\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs1)"
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs2 it2)"
    shows "(gen_diff del1 (\<lambda>x. foldli (it2 x)),op -)
      \<in> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (\<langle>Rk\<rangle>Rs2) \<rightarrow> (\<langle>Rk\<rangle>Rs1)"
    apply (intro fun_relI)
    unfolding gen_diff_def
    apply (rule det_fold_set[OF foldli_diff IT[unfolded autoref_tag_defs]])
    using DEL
    unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_ball_aux:
    "foldli l (\<lambda>x. x) (\<lambda>x _. P x) b \<longleftrightarrow> b \<and> Ball (set l) P"
    by (induct l arbitrary: b) auto

  lemma foldli_ball: "det_fold_set X (\<lambda>x. x) (\<lambda>x _. P x) True (\<lambda>s. Ball s P)"
    apply rule using foldli_ball_aux[where b=True] by simp

  definition gen_ball :: "_ \<Rightarrow> 's \<Rightarrow> ('k \<Rightarrow> bool) \<Rightarrow> _ "
    where "gen_ball it s P \<equiv> it s (\<lambda>x. x) (\<lambda>x _. P x) True"

  lemma gen_ball[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    shows "(gen_ball (\<lambda>x. foldli (it x)),Ball) \<in> \<langle>Rk\<rangle>Rs \<rightarrow> (Rk\<rightarrow>Id) \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_ball_def
    apply (rule det_fold_set[OF foldli_ball IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma foldli_bex_aux: "foldli l (\<lambda>x. \<not>x) (\<lambda>x _. P x) b \<longleftrightarrow> b \<or> Bex (set l) P"
    by (induct l arbitrary: b) auto

  lemma foldli_bex: "det_fold_set X (\<lambda>x. \<not>x) (\<lambda>x _. P x) False (\<lambda>s. Bex s P)"
    apply rule using foldli_bex_aux[where b=False] by simp

  definition gen_bex :: "_ \<Rightarrow> 's \<Rightarrow> ('k \<Rightarrow> bool) \<Rightarrow> _ "
    where "gen_bex it s P \<equiv> it s (\<lambda>x. \<not>x) (\<lambda>x _. P x) False"

  lemma gen_bex[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    shows "(gen_bex (\<lambda>x. foldli (it x)),Bex) \<in> \<langle>Rk\<rangle>Rs \<rightarrow> (Rk\<rightarrow>Id) \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_bex_def
    apply (rule det_fold_set[OF foldli_bex IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma ball_subseteq:
    "(Ball s1 (\<lambda>x. x\<in>s2)) \<longleftrightarrow> s1 \<subseteq> s2"
    by blast

  definition gen_subseteq
    :: "('s1 \<Rightarrow> ('k \<Rightarrow> bool) \<Rightarrow> bool) \<Rightarrow> ('k \<Rightarrow> 's2 \<Rightarrow> bool) \<Rightarrow> _"
    where "gen_subseteq ball1 mem2 s1 s2 \<equiv> ball1 s1 (\<lambda>x. mem2 x s2)"

  lemma gen_subseteq[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP ball1 Ball (\<langle>Rk\<rangle>Rs1 \<rightarrow> (Rk\<rightarrow>Id) \<rightarrow> Id)"
    assumes "GEN_OP mem2 op \<in> (Rk \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id)"
    shows "(gen_subseteq ball1 mem2,op \<subseteq>) \<in> \<langle>Rk\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_subseteq_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst ball_subseteq[symmetric])
    apply parametricity
    done

  definition "gen_equal ss1 ss2 s1 s2 \<equiv> ss1 s1 s2 \<and> ss2 s2 s1"

  lemma gen_equal[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP ss1 op \<subseteq> (\<langle>Rk\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id)"
    assumes "GEN_OP ss2 op \<subseteq> (\<langle>Rk\<rangle>Rs2 \<rightarrow> \<langle>Rk\<rangle>Rs1 \<rightarrow> Id)"
    shows "(gen_equal ss1 ss2, op =) \<in> \<langle>Rk\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_equal_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst set_eq_subset)
    apply (parametricity)
    done

  lemma foldli_card_aux: "distinct l \<Longrightarrow> foldli l (\<lambda>_. True)
    (\<lambda>_ n. Suc n) n = n + card (set l)"
    apply (induct l arbitrary: n)
    apply auto
    done

  lemma foldli_card: "det_fold_set X (\<lambda>_. True) (\<lambda>_ n. Suc n) 0 card"
    apply rule using foldli_card_aux[where n=0] by simp

  definition gen_card where
    "gen_card it s \<equiv> it s (\<lambda>x. True) (\<lambda>_ n. Suc n) 0"

  lemma gen_card[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    shows "(gen_card (\<lambda>x. foldli (it x)),card) \<in> \<langle>Rk\<rangle>Rs \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_card_def
    apply (rule det_fold_set[OF foldli_card IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma fold_set: "fold Set.insert l s = s \<union> set l"
    by (induct l arbitrary: s) auto

  definition gen_set :: "'s \<Rightarrow> ('k \<Rightarrow> 's \<Rightarrow> 's) \<Rightarrow> _" where
    "gen_set emp ins l = fold ins l emp"

  lemma gen_set[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes EMPTY:
      "GEN_OP emp {} (\<langle>Rk\<rangle>Rs)"
    assumes INS:
      "GEN_OP ins Set.insert (Rk\<rightarrow>\<langle>Rk\<rangle>Rs\<rightarrow>\<langle>Rk\<rangle>Rs)"
    shows "(gen_set emp ins,set)\<in>\<langle>Rk\<rangle>list_rel\<rightarrow>\<langle>Rk\<rangle>Rs"
    apply (intro fun_relI)
    unfolding gen_set_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst fold_set[where s="{}",simplified,symmetric])
    apply parametricity
    done

  lemma ball_isEmpty: "op_set_isEmpty s = (\<forall>x\<in>s. False)"
    by auto

  definition gen_isEmpty :: "('s \<Rightarrow> ('k \<Rightarrow> bool) \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool" where
    "gen_isEmpty ball s \<equiv> ball s (\<lambda>_. False)"

  lemma gen_isEmpty[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP ball Ball (\<langle>Rk\<rangle>Rs \<rightarrow> (Rk\<rightarrow>Id) \<rightarrow> Id)"
    shows "(gen_isEmpty ball,op_set_isEmpty) \<in> \<langle>Rk\<rangle>Rs \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_isEmpty_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst ball_isEmpty)
    apply parametricity
    done

  lemma foldli_size_abort_aux:
    "\<lbrakk>n0\<le>m; distinct l\<rbrakk> \<Longrightarrow>
      foldli l (\<lambda>n. n<m) (\<lambda>_ n. Suc n) n0 = min m (n0 + card (set l))"
    apply (induct l arbitrary: n0)
    apply auto
    done

  lemma foldli_size_abort: "
    det_fold_set X (\<lambda>n. n<m) (\<lambda>_ n. Suc n) 0 (op_set_size_abort m)"
    apply rule
    using foldli_size_abort_aux[where ?n0.0=0]
    by simp

  definition gen_size_abort where
    "gen_size_abort it m s \<equiv> it s (\<lambda>n. n<m) (\<lambda>_ n. Suc n) 0"

  lemma gen_size_abort[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    shows "(gen_size_abort (\<lambda>x. foldli (it x)),op_set_size_abort)
    \<in> Id \<rightarrow> \<langle>Rk\<rangle>Rs \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_size_abort_def
    apply (rule det_fold_set[OF foldli_size_abort IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma size_abort_isSng: "op_set_isSng s \<longleftrightarrow> op_set_size_abort 2 s = 1"
    by auto

  definition gen_isSng :: "(nat \<Rightarrow> 's \<Rightarrow> nat) \<Rightarrow> _" where
    "gen_isSng sizea s \<equiv> sizea 2 s = 1"

  lemma gen_isSng[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP sizea op_set_size_abort (Id \<rightarrow> (\<langle>Rk\<rangle>Rs) \<rightarrow> Id)"
    shows "(gen_isSng sizea,op_set_isSng) \<in> \<langle>Rk\<rangle>Rs \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_isSng_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst size_abort_isSng)
    apply parametricity
    done

  lemma foldli_disjoint_aux:
    "foldli l1 (\<lambda>x. x) (\<lambda>x _. \<not>x\<in>s2) b \<longleftrightarrow> b \<and> op_set_disjoint (set l1) s2"
    by (induct l1 arbitrary: b) auto

  lemma foldli_disjoint:
    "det_fold_set X (\<lambda>x. x) (\<lambda>x _. \<not>x\<in>s2) True (\<lambda>s1. op_set_disjoint s1 s2)"
    apply rule using foldli_disjoint_aux[where b=True] by simp

  definition gen_disjoint
    :: "_ \<Rightarrow> ('k\<Rightarrow>'s2\<Rightarrow>bool) \<Rightarrow> _"
    where "gen_disjoint it1 mem2 s1 s2
    \<equiv> it1 s1 (\<lambda>x. x) (\<lambda>x _. \<not>mem2 x s2) True"

  lemma gen_disjoint[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
    assumes MEM: "GEN_OP mem2 op \<in> (Rk \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id)"
    shows "(gen_disjoint (\<lambda>x. foldli (it1 x)) mem2,op_set_disjoint)
    \<in> \<langle>Rk\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_disjoint_def
    apply (rule det_fold_set[OF foldli_disjoint IT[unfolded autoref_tag_defs]])
    using MEM unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_filter_aux:
    "foldli l (\<lambda>_. True) (\<lambda>x s. if P x then insert x s else s) s0
    = s0 \<union> op_set_filter P (set l)"
    by (induct l arbitrary: s0) auto

  lemma foldli_filter:
    "det_fold_set X (\<lambda>_. True) (\<lambda>x s. if P x then insert x s else s) {}
      (op_set_filter P)"
    apply rule using foldli_filter_aux[where ?s0.0="{}"] by simp

  definition gen_filter
    where "gen_filter it1 emp2 ins2 P s1 \<equiv>
      it1 s1 (\<lambda>_. True) (\<lambda>x s. if P x then ins2 x s else s) emp2"

  lemma gen_filter[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
    assumes INS:
      "GEN_OP ins2 Set.insert (Rk\<rightarrow>\<langle>Rk\<rangle>Rs2\<rightarrow>\<langle>Rk\<rangle>Rs2)"
    assumes EMPTY:
      "GEN_OP empty2 {} (\<langle>Rk\<rangle>Rs2)"
    shows "(gen_filter (\<lambda>x. foldli (it1 x)) empty2 ins2,op_set_filter)
    \<in> (Rk\<rightarrow>Id) \<rightarrow> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (\<langle>Rk\<rangle>Rs2)"
    apply (intro fun_relI)
    unfolding gen_filter_def
    apply (rule det_fold_set[OF foldli_filter IT[unfolded autoref_tag_defs]])
    using INS EMPTY unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_image_aux:
    "foldli l (\<lambda>_. True) (\<lambda>x s. insert (f x) s) s0
    = s0 \<union> f`(set l)"
    by (induct l arbitrary: s0) auto

  lemma foldli_image:
    "det_fold_set X (\<lambda>_. True) (\<lambda>x s. insert (f x) s) {}
      (op ` f)"
    apply rule using foldli_image_aux[where ?s0.0="{}"] by simp

  definition gen_image
    where "gen_image it1 emp2 ins2 f s1 \<equiv>
      it1 s1 (\<lambda>_. True) (\<lambda>x s. ins2 (f x) s) emp2"

  lemma gen_image[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
    assumes INS:
      "GEN_OP ins2 Set.insert (Rk'\<rightarrow>\<langle>Rk'\<rangle>Rs2\<rightarrow>\<langle>Rk'\<rangle>Rs2)"
    assumes EMPTY:
      "GEN_OP empty2 {} (\<langle>Rk'\<rangle>Rs2)"
    shows "(gen_image (\<lambda>x. foldli (it1 x)) empty2 ins2,op `)
    \<in> (Rk\<rightarrow>Rk') \<rightarrow> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (\<langle>Rk'\<rangle>Rs2)"
    apply (intro fun_relI)
    unfolding gen_image_def
    apply (rule det_fold_set[OF foldli_image IT[unfolded autoref_tag_defs]])
    using INS EMPTY unfolding autoref_tag_defs
    apply (parametricity)+
    done

  (* TODO: Also do sel! *)

  lemma foldli_pick:
    assumes "l\<noteq>[]"
    obtains x where "x\<in>set l"
    and "(foldli l (case_option True (\<lambda>_. False)) (\<lambda>x _. Some x) None) = Some x"
    using assms by (cases l) auto

  definition gen_pick where
    "gen_pick it s \<equiv>
      (the (it s (case_option True (\<lambda>_. False)) (\<lambda>x _. Some x) None))"

context begin interpretation autoref_syn .
  lemma gen_pick[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    assumes NE: "SIDE_PRECOND (s'\<noteq>{})"
    assumes SREF: "(s,s')\<in>\<langle>Rk\<rangle>Rs"
    shows "(RETURN (gen_pick (\<lambda>x. foldli (it x)) s),
      (OP op_set_pick ::: \<langle>Rk\<rangle>Rs\<rightarrow>\<langle>Rk\<rangle>nres_rel)$s')\<in>\<langle>Rk\<rangle>nres_rel"
  proof -
    obtain tsl' where
      [param]: "(it s,tsl') \<in> \<langle>Rk\<rangle>list_rel"
      and IT': "RETURN tsl' \<le> it_to_sorted_list (\<lambda>_ _. True) s'"
      using IT[unfolded autoref_tag_defs is_set_to_list_def] SREF
      by (rule is_set_to_sorted_listE)

    from IT' NE have "tsl'\<noteq>[]" and [simp]: "s'=set tsl'"
      unfolding it_to_sorted_list_def by simp_all
    then obtain x where "x\<in>s'" and
      "(foldli tsl' (case_option True (\<lambda>_. False)) (\<lambda>x _. Some x) None) = Some x"
      (is "?fld = _")
      by (blast elim: foldli_pick)
    moreover
    have "(RETURN (gen_pick (\<lambda>x. foldli (it x)) s), RETURN (the ?fld))
      \<in> \<langle>Rk\<rangle>nres_rel"
      unfolding gen_pick_def
      apply (parametricity add: the_paramR)
      using `?fld = Some x`
      by simp
    ultimately show ?thesis
      unfolding autoref_tag_defs
      apply -
      apply (drule nres_relD)
      apply (rule nres_relI)
      apply (erule ref_two_step)
      by simp
  qed
end

  definition gen_Sigma
    where "gen_Sigma it1 it2 empX insX s1 f2 \<equiv>
      it1 s1 (\<lambda>_. True) (\<lambda>x s.
        it2 (f2 x) (\<lambda>_. True) (\<lambda>y s. insX (x,y) s) s
      ) empX
    "

  lemma foldli_Sigma_aux:
    fixes s :: "'s1_impl" and s':: "'k set"
    fixes f :: "'k_impl \<Rightarrow> 's2_impl" and f':: "'k \<Rightarrow> 'l set"
    fixes s0 :: "'kl_impl" and s0' :: "('k\<times>'l) set"
    assumes IT1: "is_set_to_list Rk Rs1 it1"
    assumes IT2: "is_set_to_list Rl Rs2 it2"
    assumes INS:
      "(insX, Set.insert) \<in>
        (\<langle>Rk,Rl\<rangle>prod_rel\<rightarrow>\<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3\<rightarrow>\<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3)"
    assumes S0R: "(s0, s0') \<in> \<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3"
    assumes SR: "(s, s') \<in> \<langle>Rk\<rangle>Rs1"
    assumes FR: "(f, f') \<in> Rk \<rightarrow> \<langle>Rl\<rangle>Rs2"
    shows "(foldli (it1 s) (\<lambda>_. True) (\<lambda>x s.
        foldli (it2 (f x)) (\<lambda>_. True) (\<lambda>y s. insX (x,y) s) s
      ) s0,s0' \<union> Sigma s' f')
      \<in> \<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3"
  proof -
    have S: "\<And>x s f. Sigma (insert x s) f = ({x}\<times>f x) \<union> Sigma s f"
      by auto

    obtain l' where
      IT1L: "(it1 s,l')\<in>\<langle>Rk\<rangle>list_rel"
      and SL: "s' = set l'"
      apply (rule
        is_set_to_sorted_listE[OF IT1[unfolded is_set_to_list_def] SR])
      by (auto simp: it_to_sorted_list_def)

    show ?thesis
      unfolding SL
      using IT1L S0R
    proof (induct arbitrary: s0 s0' rule: list_rel_induct)
      case Nil thus ?case by simp
    next
      case (Cons x x' l l')

      obtain l2' where
        IT2L: "(it2 (f x),l2')\<in>\<langle>Rl\<rangle>list_rel"
        and FXL: "f' x' = set l2'"
        apply (rule
          is_set_to_sorted_listE[
            OF IT2[unfolded is_set_to_list_def], of "f x" "f' x'"
          ])
        apply (parametricity add: Cons.hyps(1) FR)
        by (auto simp: it_to_sorted_list_def)

      have "(foldli (it2 (f x)) (\<lambda>_. True) (\<lambda>y. insX (x, y)) s0,
        s0' \<union> {x'}\<times>f' x') \<in> \<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3"
        unfolding FXL
        using IT2L `(s0, s0') \<in> \<langle>\<langle>Rk, Rl\<rangle>prod_rel\<rangle>Rs3`
        apply (induct  arbitrary: s0 s0' rule: list_rel_induct)
        apply simp
        apply simp
        apply (subst Un_insert_left[symmetric])
        apply (rprems)
        apply (parametricity add: INS `(x,x')\<in>Rk`)
        done

      show ?case
        apply simp
        apply (subst S)
        apply (subst Un_assoc[symmetric])
        apply (rule Cons.hyps)
        apply fact
        done
    qed
  qed

  lemma gen_Sigma[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT1: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
    assumes IT2: "SIDE_GEN_ALGO (is_set_to_list Rl Rs2 it2)"
    assumes EMPTY:
      "GEN_OP empX {} (\<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3)"
    assumes INS:
      "GEN_OP insX Set.insert
         (\<langle>Rk,Rl\<rangle>prod_rel\<rightarrow>\<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3\<rightarrow>\<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3)"
    shows "(gen_Sigma (\<lambda>x. foldli (it1 x)) (\<lambda>x. foldli (it2 x)) empX insX,Sigma)
      \<in> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (Rk \<rightarrow> \<langle>Rl\<rangle>Rs2) \<rightarrow> \<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3"
    apply (intro fun_relI)
    unfolding gen_Sigma_def
    using foldli_Sigma_aux[OF
      IT1[unfolded autoref_tag_defs]
      IT2[unfolded autoref_tag_defs]
      INS[unfolded autoref_tag_defs]
      EMPTY[unfolded autoref_tag_defs]
    ]
    by simp

lemma gen_cart:
  assumes PRIO_TAG_GEN_ALGO
  assumes [param]: "(sigma, Sigma) \<in> (\<langle>Rx\<rangle>Rsx \<rightarrow> (Rx \<rightarrow> \<langle>Ry\<rangle>Rsy) \<rightarrow> \<langle>Rx \<times>\<^sub>r Ry\<rangle>Rsp)"
  shows "(\<lambda>x y. sigma x (\<lambda>_. y), op_set_cart) \<in> \<langle>Rx\<rangle>Rsx \<rightarrow> \<langle>Ry\<rangle>Rsy \<rightarrow> \<langle>Rx \<times>\<^sub>r Ry\<rangle>Rsp"
  unfolding op_set_cart_def[abs_def]
  by parametricity
lemmas [autoref_rules] = gen_cart[OF _ GEN_OP_D]

context begin interpretation autoref_syn .

  lemma op_set_to_sorted_list_autoref[autoref_rules]:
    assumes "SIDE_GEN_ALGO (is_set_to_sorted_list ordR Rk Rs tsl)"
    shows "(\<lambda>si. RETURN (tsl si),  OP (op_set_to_sorted_list ordR))
      \<in> \<langle>Rk\<rangle>Rs \<rightarrow> \<langle>\<langle>Rk\<rangle>list_rel\<rangle>nres_rel"
    using assms
    apply (intro fun_relI nres_relI)
    apply simp
    apply (rule RETURN_SPEC_refine)
    apply (auto simp: is_set_to_sorted_list_def it_to_sorted_list_def)
    done

  lemma op_set_to_list_autoref[autoref_rules]:
    assumes "SIDE_GEN_ALGO (is_set_to_sorted_list ordR Rk Rs tsl)"
    shows "(\<lambda>si. RETURN (tsl si), op_set_to_list)
      \<in> \<langle>Rk\<rangle>Rs \<rightarrow> \<langle>\<langle>Rk\<rangle>list_rel\<rangle>nres_rel"
    using assms
    apply (intro fun_relI nres_relI)
    apply simp
    apply (rule RETURN_SPEC_refine)
    apply (auto simp: is_set_to_sorted_list_def it_to_sorted_list_def)
    done

end

lemma foldli_Union: "det_fold_set X (\<lambda>_. True) (op \<union>) {} Union"
proof (rule, goal_cases)
  case (1 l)
  have "\<forall>a. foldli l (\<lambda>_. True) op \<union> a = a \<union> \<Union>set l"
    by (induct l) auto
  thus ?case by auto
qed

definition gen_Union
  :: "_ \<Rightarrow> 's3 \<Rightarrow> ('s2 \<Rightarrow> 's3 \<Rightarrow> 's3)
      \<Rightarrow> 's1 \<Rightarrow> 's3"
  where
  "gen_Union it emp un X \<equiv> it X (\<lambda>_. True) un emp"

lemma gen_Union[autoref_rules_raw]:
  assumes PRIO_TAG_GEN_ALGO
  assumes EMP: "GEN_OP emp {} (\<langle>Rk\<rangle>Rs3)"
  assumes UN: "GEN_OP un (op \<union>) (\<langle>Rk\<rangle>Rs2\<rightarrow>\<langle>Rk\<rangle>Rs3\<rightarrow>\<langle>Rk\<rangle>Rs3)"
  assumes IT: "SIDE_GEN_ALGO (is_set_to_list (\<langle>Rk\<rangle>Rs2) Rs1 tsl)"
  shows "(gen_Union (\<lambda>x. foldli (tsl x)) emp un,Union) \<in> \<langle>\<langle>Rk\<rangle>Rs2\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs3"
  apply (intro fun_relI)
  unfolding gen_Union_def
  apply (rule det_fold_set[OF
    foldli_Union IT[unfolded autoref_tag_defs]])
  using EMP UN
  unfolding autoref_tag_defs
  apply (parametricity)+
  done

definition "atLeastLessThan_impl a b \<equiv> do {
  (_,r) \<leftarrow> WHILET (\<lambda>(i,r). i<b) (\<lambda>(i,r). RETURN (i+1, insert i r)) (a,{});
  RETURN r
}"

lemma atLeastLessThan_impl_correct:
  "atLeastLessThan_impl a b \<le> SPEC (\<lambda>r. r = {a..<b::nat})"
  unfolding atLeastLessThan_impl_def
  apply (refine_rcg refine_vcg WHILET_rule[where
    I = "\<lambda>(i,r). r = {a..<i} \<and> a\<le>i \<and> ((a<b \<longrightarrow> i\<le>b) \<and> (\<not>a<b \<longrightarrow> i=a))"
    and R = "measure (\<lambda>(i,_). b - i)"
    ])
  by auto

schematic_goal atLeastLessThan_code_aux:
  notes [autoref_rules] = IdI[of a] IdI[of b]
  assumes [autoref_rules]: "(emp,{})\<in>Rs"
  assumes [autoref_rules]: "(ins,insert)\<in>nat_rel \<rightarrow> Rs \<rightarrow> Rs"
  shows "(?c, atLeastLessThan_impl)
  \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> \<langle>Rs\<rangle>nres_rel"
  unfolding atLeastLessThan_impl_def[abs_def]
  apply (autoref (keep_goal))
  done
concrete_definition atLeastLessThan_code uses atLeastLessThan_code_aux

schematic_goal atLeastLessThan_tr_aux:
  "RETURN ?c \<le> atLeastLessThan_code emp ins a b"
  unfolding atLeastLessThan_code_def
  by (refine_transfer (post))
concrete_definition atLeastLessThan_tr
  for emp ins a b uses atLeastLessThan_tr_aux

lemma atLeastLessThan_gen[autoref_rules]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP emp {} Rs"
  assumes "GEN_OP ins insert (nat_rel \<rightarrow> Rs \<rightarrow> Rs)"
  shows "(atLeastLessThan_tr emp ins, atLeastLessThan)
    \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> Rs"
proof (intro fun_relI, simp)
  fix a b
  from assms have GEN:
    "(emp,{})\<in>Rs" "(ins,insert)\<in>nat_rel \<rightarrow> Rs \<rightarrow> Rs"
    by auto

  note atLeastLessThan_tr.refine[of emp ins a b]
  also note
    atLeastLessThan_code.refine[OF GEN,param_fo, OF IdI IdI, THEN nres_relD]
  also note atLeastLessThan_impl_correct
  finally show "(atLeastLessThan_tr emp ins a b, {a..<b}) \<in> Rs"
    by (auto simp: pw_le_iff refine_pw_simps)
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)
 *)

theory ListRev
imports "../../AutoCorres"
begin

install_C_file "list_rev.c"

autocorres [heap_abs_syntax] "list_rev.c"

primrec
  list :: "lifted_globals \<Rightarrow> node_C ptr \<Rightarrow> node_C ptr list \<Rightarrow> bool"
where
  "list s p [] = (p = NULL)"
| "list s p (x#xs) = (
       p = x \<and> p \<noteq> NULL \<and> is_valid_node_C s p \<and> list s (s[p]\<rightarrow>next) xs)"

lemma list_empty [simp]:
  "list s NULL xs = (xs = [])"
  by (induct xs) auto

lemma list_in [simp]:
  "\<lbrakk> list s p xs; p \<noteq> NULL \<rbrakk> \<Longrightarrow> p \<in> set xs"
  by (induct xs) auto

lemma list_non_NULL:
  "\<lbrakk> p \<noteq> NULL \<rbrakk> \<Longrightarrow>
    list s p xs = (\<exists>ys. xs = p # ys \<and> is_valid_node_C s p \<and> list s (s[p]\<rightarrow>next) ys)"
  by (cases xs) auto

lemma list_unique:
  "list s p xs \<Longrightarrow> list s p ys \<Longrightarrow> xs = ys"
  by (induct xs arbitrary: p ys) (auto simp add: list_non_NULL)

lemma list_append_Ex:
  "list s p (xs @ ys) \<Longrightarrow> (\<exists>q. list s q ys)"
  by (induct xs arbitrary: p) auto

lemma list_distinct [simp]:
  "list s p xs \<Longrightarrow> distinct xs"
  apply (induct xs arbitrary: p)
   apply simp
  apply (clarsimp dest!: split_list)
  apply (frule list_append_Ex)
  apply (auto dest: list_unique)
  done

lemma list_heap_update_ignore [simp]:
  "q \<notin> set xs \<Longrightarrow> list (s[q\<rightarrow>next := v]) p xs = list s p xs"
  apply (induct xs arbitrary: p)
   apply clarsimp
  apply (clarsimp simp: fun_upd_def)
  done

definition
  the_list :: "lifted_globals \<Rightarrow> node_C ptr \<Rightarrow> node_C ptr list"
where
  "the_list s p = (THE xs. list s p xs)"

lemma the_list_val [simp]: "list s p xs \<Longrightarrow> the_list s p = xs"
  apply (clarsimp simp: the_list_def)
  apply (metis (lifting) list_unique the_equality)
  done

definition "reverse_inv xs list' rev' s =
                 (\<exists>ys zs. list s list' ys
                    \<and> list s rev' zs
                    \<and> rev xs = rev ys @ zs
                    \<and> distinct (rev xs))"

lemma (in list_rev) reverse_correct:
  "\<lbrace> \<lambda>s. list s p xs \<rbrace>
     reverse' p
   \<lbrace> \<lambda>rv s. list s rv (rev xs) \<rbrace>!"
  apply (clarsimp simp: reverse'_def)
  apply (subst whileLoop_add_inv [where
        I="\<lambda>(list', rev') s. reverse_inv xs list' rev' s"
        and M="\<lambda>((list', rev'), s). length (the_list s list')",
        unfolded reverse_inv_def])
  apply wp
    apply (clarsimp simp del: distinct_rev)
    apply (case_tac ys, fastforce)
    apply (clarsimp simp del: distinct_rev)
    apply (rule_tac x=lista in exI)
    apply (simp add: fun_upd_def)
   apply (clarsimp simp del: distinct_rev)
  apply simp
  done

end


(*  Title:       CoreC++
    Author:      Daniel Wasserrab
    Maintainer:  Daniel Wasserrab <wasserra at fmi.uni-passau.de>

    Based on the Jinja theory Common/Decl.thy by David von Oheimb and Tobias Nipkow
*)

header {* \isaheader{CoreC++ types} *}

theory Type imports Auxiliary begin

type_synonym cname = string -- "class names"
type_synonym mname = string -- "method name"
type_synonym vname = string -- "names for local/field variables"

definition this :: vname where
  "this \<equiv> ''this''"

-- "types"
datatype ty
  = Void          -- "type of statements"
  | Boolean
  | Integer
  | NT            -- "null type"
  | Class cname   -- "class type"

datatype base  -- "superclass"
  = Repeats cname  -- "repeated (nonvirtual) inheritance"
  | Shares cname   -- "shared (virtual) inheritance"

primrec getbase :: "base \<Rightarrow> cname" where
  "getbase (Repeats C) = C"
| "getbase (Shares C)  = C"

primrec isRepBase :: "base \<Rightarrow> bool" where
  "isRepBase (Repeats C) = True"
| "isRepBase (Shares C) = False"

primrec isShBase :: "base \<Rightarrow> bool" where
  "isShBase(Repeats C) = False"
| "isShBase(Shares C) = True"

definition is_refT :: "ty \<Rightarrow> bool" where
  "is_refT T  \<equiv>  T = NT \<or> (\<exists>C. T = Class C)"

lemma [iff]: "is_refT(Class C)"
by(simp add:is_refT_def)

lemma refTE:
  "\<lbrakk>is_refT T; T = NT \<Longrightarrow> Q; \<And>C. T = Class C \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
by (auto simp add: is_refT_def)

lemma not_refTE:
  "\<lbrakk> \<not>is_refT T; T = Void \<or> T = Boolean \<or> T = Integer \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
by (cases T, auto simp add: is_refT_def)

type_synonym
  env  = "vname \<rightharpoonup> ty"

end


(*  Title:      RTS/JinjaSuppl/ClassesChanged.thy
    Author:    Susannah Mansky, UIUC 2020
    Description: Theory around the classes changed from one program to another
*)

section "@{term classes_changed} theory"

theory ClassesChanged
imports "../../JinjaDCI/Common/Decl"
begin

text "A class is considered changed if it exists only in one program or the other,
  or exists in both but is different."
definition classes_changed :: "'m prog \<Rightarrow> 'm prog \<Rightarrow> cname set" where
"classes_changed P1 P2 = {cn. class P1 cn \<noteq> class P2 cn}"

definition class_changed :: "'m prog \<Rightarrow> 'm prog \<Rightarrow> cname \<Rightarrow> bool" where
"class_changed P1 P2 cn = (class P1 cn \<noteq> class P2 cn)"

lemma classes_changed_class_changed[simp]: "cn \<in> classes_changed P1 P2 = class_changed P1 P2 cn"
 by (simp add: classes_changed_def class_changed_def)

lemma classes_changed_self[simp]: "classes_changed P P = {}"
 by (auto simp: class_changed_def)

lemma classes_changed_sym: "classes_changed P P' = classes_changed P' P"
 by (auto simp: class_changed_def)

lemma classes_changed_class: "\<lbrakk> cn \<notin> classes_changed P P'\<rbrakk> \<Longrightarrow> class P cn = class P' cn"
 by (clarsimp simp: class_changed_def)

lemma classes_changed_class_set: "\<lbrakk> S \<inter> classes_changed P P' = {} \<rbrakk>
  \<Longrightarrow> \<forall>C \<in> S. class P C = class P' C"
 by (fastforce simp: disjoint_iff_not_equal dest: classes_changed_class)

text "We now relate @{term classes_changed} over two programs to those
 over programs with an added class (such as a test class)."

lemma classes_changed_cons_eq:
 "classes_changed (t # P) P' = (classes_changed P P' - {fst t})
                     \<union> (if class_changed [t] P' (fst t) then {fst t} else {})"
 by (auto simp: classes_changed_def class_changed_def class_def)

lemma class_changed_cons:
 "fst t \<notin> classes_changed (t#P) (t#P')"
 by (simp add: class_changed_def class_def)

lemma classes_changed_cons:
 "classes_changed (t # P) (t # P') = classes_changed P P' - {fst t}"
proof(cases "fst t \<in> classes_changed P P'")
  case True
  then show ?thesis using class_changed_cons[where t=t and P=P and P'=P']
    classes_changed_cons_eq[where t=t] by (auto simp: class_changed_def class_cons)
next
  case False
  then show ?thesis using class_changed_cons[where t=t and P=P and P'=P']
    by (auto simp: class_changed_def) (metis (no_types, lifting) class_cons)+
qed

lemma classes_changed_int_Cons:
assumes "coll \<inter> classes_changed P P' = {}"
shows "coll \<inter> classes_changed (t # P) (t # P') = {}"
proof(cases "fst t \<in> classes_changed P P'")
  case True
  then have "classes_changed P P' = classes_changed (t # P) (t # P') \<union> {fst t}"
    using classes_changed_cons[where t=t and P=P and P'=P'] by fastforce
  then show ?thesis using assms by simp
next
  case False
  then have "classes_changed P P' = classes_changed (t # P) (t # P')"
    using classes_changed_cons[where t=t and P=P and P'=P'] by fastforce
  then show ?thesis using assms by simp
qed

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Galois Relator\<close>
theory Transport_Natural_Functors_Galois_Relator
  imports
    Transport_Natural_Functors_Base
begin

context transport_natural_functor
begin

lemma Galois_Frel_Galois: "(\<^bsub>L\<^esub>\<lessapprox>) \<le> Frel (\<^bsub>L1\<^esub>\<lessapprox>) (\<^bsub>L2\<^esub>\<lessapprox>) (\<^bsub>L3\<^esub>\<lessapprox>)"
  apply (rule le_relI)
  apply (erule GaloisE)
  apply (unfold left_rel_eq_Frel right_rel_eq_Frel right_eq_Fmap)
  apply (subst (asm) in_codom_Frel_eq_Fpred_in_codom)
  apply (erule FpredE)
  apply (subst (asm) Frel_Fmap_eq2)
  apply (rule Frel_mono_strong,
    assumption;
    rule t1.GaloisI t2.GaloisI t3.GaloisI;
    assumption)
  done

lemma Frel_Galois_le_Galois:
  "Frel (\<^bsub>L1\<^esub>\<lessapprox>) (\<^bsub>L2\<^esub>\<lessapprox>) (\<^bsub>L3\<^esub>\<lessapprox>) \<le> (\<^bsub>L\<^esub>\<lessapprox>)"
  apply (rule le_relI)
  apply (unfold t1.Galois_iff_in_codom_and_left_rel_right
    t2.Galois_iff_in_codom_and_left_rel_right
    t3.Galois_iff_in_codom_and_left_rel_right)
  apply (fold
    restrict_right_eq[of "\<lambda>x y. x \<le>\<^bsub>L1\<^esub> r1 y" "in_codom (\<le>\<^bsub>R1\<^esub>)",
      unfolded restrict_left_pred_def rel_inv_iff_rel]
    restrict_right_eq[of "\<lambda>x y. x \<le>\<^bsub>L2\<^esub> r2 y" "in_codom (\<le>\<^bsub>R2\<^esub>)",
      unfolded restrict_left_pred_def rel_inv_iff_rel]
    restrict_right_eq[of "\<lambda>x y. x \<le>\<^bsub>L3\<^esub> r3 y" "in_codom (\<le>\<^bsub>R3\<^esub>)",
      unfolded restrict_left_pred_def rel_inv_iff_rel])
  apply (subst (asm) Frel_restrict_right_Fpred_eq_Frel_restrict_right[symmetric])
  apply (erule restrict_rightE)
  apply (subst (asm) in_codom_Frel_eq_Fpred_in_codom[symmetric])
  apply (erule in_codomE)
  apply (rule GaloisI)
    apply (rule in_codomI)
    apply (subst right_rel_eq_Frel)
    apply assumption
    apply (unfold left_rel_eq_Frel right_eq_Fmap Frel_Fmap_eq2)
    apply assumption
  done

corollary Galois_eq_Frel_Galois: "(\<^bsub>L\<^esub>\<lessapprox>) = Frel (\<^bsub>L1\<^esub>\<lessapprox>) (\<^bsub>L2\<^esub>\<lessapprox>) (\<^bsub>L3\<^esub>\<lessapprox>)"
  by (intro antisym Galois_Frel_Galois Frel_Galois_le_Galois)

end

end


(*  Title:      Jinja/J/SmallProgress.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

header {* \isaheader{Progress of Small Step Semantics} *}

theory Progress
imports Equivalence WellTypeRT DefAss "../Common/Conform"
begin

lemma final_addrE:
  "\<lbrakk> P,E,h \<turnstile> e : Class C; final e;
    \<And>a. e = addr a \<Longrightarrow> R;
    \<And>a. e = Throw a \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
(*<*)by(auto simp:final_def)(*>*)

lemma finalRefE:
 "\<lbrakk> P,E,h \<turnstile> e : T; is_refT T; final e;
   e = null \<Longrightarrow> R;
   \<And>a C. \<lbrakk> e = addr a; T = Class C \<rbrakk> \<Longrightarrow> R;
   \<And>a. e = Throw a \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
(*<*)by(auto simp:final_def is_refT_def)(*>*)

text{* Derivation of new induction scheme for well typing: *}

inductive
  WTrt' :: "[J_prog,heap,env,expr,ty] \<Rightarrow> bool"
  and WTrts' :: "[J_prog,heap,env,expr list, ty list] \<Rightarrow> bool"
  and WTrt2' :: "[J_prog,env,heap,expr,ty] \<Rightarrow> bool"
        ("_,_,_ \<turnstile> _ :' _"   [51,51,51]50)
  and WTrts2' :: "[J_prog,env,heap,expr list, ty list] \<Rightarrow> bool"
        ("_,_,_ \<turnstile> _ [:''] _" [51,51,51]50)
  for P :: J_prog and h :: heap
where
  "P,E,h \<turnstile> e :' T \<equiv> WTrt' P h E e T"
| "P,E,h \<turnstile> es [:'] Ts \<equiv> WTrts' P h E es Ts"

| "is_class P C  \<Longrightarrow>  P,E,h \<turnstile> new C :' Class C"
| "\<lbrakk> P,E,h \<turnstile> e :' T; is_refT T; is_class P C \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> Cast C e :' Class C"
| "typeof\<^bsub>h\<^esub> v = Some T \<Longrightarrow> P,E,h \<turnstile> Val v :' T"
| "E v = Some T  \<Longrightarrow>  P,E,h \<turnstile> Var v :' T"
| "\<lbrakk> P,E,h \<turnstile> e\<^sub>1 :' T\<^sub>1;  P,E,h \<turnstile> e\<^sub>2 :' T\<^sub>2 \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> e\<^sub>1 \<guillemotleft>Eq\<guillemotright> e\<^sub>2 :' Boolean"
| "\<lbrakk> P,E,h \<turnstile> e\<^sub>1 :' Integer;  P,E,h \<turnstile> e\<^sub>2 :' Integer \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> e\<^sub>1 \<guillemotleft>Add\<guillemotright> e\<^sub>2 :' Integer"
| "\<lbrakk> P,E,h \<turnstile> Var V :' T;  P,E,h \<turnstile> e :' T';  P \<turnstile> T' \<le> T (* V \<noteq> This*) \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> V:=e :' Void"
| "\<lbrakk> P,E,h \<turnstile> e :' Class C; P \<turnstile> C has F:T in D \<rbrakk> \<Longrightarrow> P,E,h \<turnstile> e\<bullet>F{D} :' T"
| "P,E,h \<turnstile> e :' NT \<Longrightarrow> P,E,h \<turnstile> e\<bullet>F{D} :' T"
| "\<lbrakk> P,E,h \<turnstile> e\<^sub>1 :' Class C;  P \<turnstile> C has F:T in D;
    P,E,h \<turnstile> e\<^sub>2 :' T\<^sub>2;  P \<turnstile> T\<^sub>2 \<le> T \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> e\<^sub>1\<bullet>F{D}:=e\<^sub>2 :' Void"
| "\<lbrakk> P,E,h \<turnstile> e\<^sub>1:'NT; P,E,h \<turnstile> e\<^sub>2 :' T\<^sub>2 \<rbrakk> \<Longrightarrow> P,E,h \<turnstile> e\<^sub>1\<bullet>F{D}:=e\<^sub>2 :' Void"
| "\<lbrakk> P,E,h \<turnstile> e :' Class C; P \<turnstile> C sees M:Ts \<rightarrow> T = (pns,body) in D;
    P,E,h \<turnstile> es [:'] Ts'; P \<turnstile> Ts' [\<le>] Ts \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> e\<bullet>M(es) :' T"
| "\<lbrakk> P,E,h \<turnstile> e :' NT; P,E,h \<turnstile> es [:'] Ts \<rbrakk> \<Longrightarrow> P,E,h \<turnstile> e\<bullet>M(es) :' T"
| "P,E,h \<turnstile> [] [:'] []"
| "\<lbrakk> P,E,h \<turnstile> e :' T;  P,E,h \<turnstile> es [:'] Ts \<rbrakk> \<Longrightarrow>  P,E,h \<turnstile> e#es [:'] T#Ts"
| "\<lbrakk> typeof\<^bsub>h\<^esub> v = Some T\<^sub>1; P \<turnstile> T\<^sub>1 \<le> T; P,E(V\<mapsto>T),h \<turnstile> e\<^sub>2 :' T\<^sub>2 \<rbrakk>
  \<Longrightarrow>  P,E,h \<turnstile> {V:T := Val v; e\<^sub>2} :' T\<^sub>2"
| "\<lbrakk> P,E(V\<mapsto>T),h \<turnstile> e :' T'; \<not> assigned V e \<rbrakk> \<Longrightarrow>  P,E,h \<turnstile> {V:T; e} :' T'"
| "\<lbrakk> P,E,h \<turnstile> e\<^sub>1:' T\<^sub>1;  P,E,h \<turnstile> e\<^sub>2:'T\<^sub>2 \<rbrakk>  \<Longrightarrow>  P,E,h \<turnstile> e\<^sub>1;;e\<^sub>2 :' T\<^sub>2"
| "\<lbrakk> P,E,h \<turnstile> e :' Boolean;  P,E,h \<turnstile> e\<^sub>1:' T\<^sub>1;  P,E,h \<turnstile> e\<^sub>2:' T\<^sub>2;
    P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<or> P \<turnstile> T\<^sub>2 \<le> T\<^sub>1;
    P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<longrightarrow> T = T\<^sub>2; P \<turnstile> T\<^sub>2 \<le> T\<^sub>1 \<longrightarrow> T = T\<^sub>1 \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 :' T"
(*
 "\<lbrakk> P,E,h \<turnstile> e :' Boolean;  P,E,h \<turnstile> e\<^sub>1:' T\<^sub>1;  P,E,h \<turnstile> e\<^sub>2:' T\<^sub>2; P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 :' T\<^sub>2"
 "\<lbrakk> P,E,h \<turnstile> e :' Boolean;  P,E,h \<turnstile> e\<^sub>1:' T\<^sub>1;  P,E,h \<turnstile> e\<^sub>2:' T\<^sub>2; P \<turnstile> T\<^sub>2 \<le> T\<^sub>1 \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 :' T\<^sub>1"
*)
| "\<lbrakk> P,E,h \<turnstile> e :' Boolean;  P,E,h \<turnstile> c:' T \<rbrakk>
  \<Longrightarrow>  P,E,h \<turnstile> while(e) c :' Void"
| "\<lbrakk> P,E,h \<turnstile> e :' T\<^sub>r; is_refT T\<^sub>r \<rbrakk>  \<Longrightarrow>  P,E,h \<turnstile> throw e :' T"
| "\<lbrakk> P,E,h \<turnstile> e\<^sub>1 :' T\<^sub>1;  P,E(V \<mapsto> Class C),h \<turnstile> e\<^sub>2 :' T\<^sub>2; P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> try e\<^sub>1 catch(C V) e\<^sub>2 :' T\<^sub>2"

(*<*)
lemmas WTrt'_induct = WTrt'_WTrts'.induct [split_format (complete)]
  and WTrt'_inducts = WTrt'_WTrts'.inducts [split_format (complete)]

inductive_cases WTrt'_elim_cases[elim!]:
  "P,E,h \<turnstile> V :=e :' T"
(*>*)

lemma [iff]: "P,E,h \<turnstile> Val v :' T = (typeof\<^bsub>h\<^esub> v = Some T)"
(*<*)
apply(rule iffI)
apply (auto elim: WTrt'.cases intro!:WTrt'_WTrts'.intros)
done
(*>*)

lemma [iff]: "P,E,h \<turnstile> Var v :' T = (E v = Some T)"
(*<*)
apply(rule iffI)
apply (auto elim: WTrt'.cases intro!:WTrt'_WTrts'.intros)
done
(*>*)

lemma wt_wt': "P,E,h \<turnstile> e : T \<Longrightarrow> P,E,h \<turnstile> e :' T"
and wts_wts': "P,E,h \<turnstile> es [:] Ts \<Longrightarrow> P,E,h \<turnstile> es [:'] Ts"
(*<*)
apply (induct rule:WTrt_inducts)
prefer 14
apply(case_tac "assigned V e")
apply(clarsimp simp add:fun_upd_same assigned_def simp del:fun_upd_apply)
apply(erule (2) WTrt'_WTrts'.intros)
apply(erule (1) WTrt'_WTrts'.intros)
apply(blast intro:WTrt'_WTrts'.intros)+
done
(*>*)

lemma wt'_wt: "P,E,h \<turnstile> e :' T \<Longrightarrow> P,E,h \<turnstile> e : T"
and wts'_wts: "P,E,h \<turnstile> es [:'] Ts \<Longrightarrow> P,E,h \<turnstile> es [:] Ts"
(*<*)
apply (induct rule:WTrt'_inducts)
prefer 16
apply(rule WTrt_WTrts.intros)
apply(rule WTrt_WTrts.intros)
apply(rule WTrt_WTrts.intros)
apply simp
apply(erule (2) WTrt_WTrts.intros)
apply(blast intro:WTrt_WTrts.intros)+
done
(*>*)

corollary wt'_iff_wt: "(P,E,h \<turnstile> e :' T) = (P,E,h \<turnstile> e : T)"
(*<*)by(blast intro:wt_wt' wt'_wt)(*>*)

corollary wts'_iff_wts: "(P,E,h \<turnstile> es [:'] Ts) = (P,E,h \<turnstile> es [:] Ts)"
(*<*)by(blast intro:wts_wts' wts'_wts)(*>*)

(*<*)
lemmas WTrt_inducts2 = WTrt'_inducts [unfolded wt'_iff_wt wts'_iff_wts,
 case_names WTrtNew WTrtCast WTrtVal WTrtVar WTrtBinOpEq WTrtBinOpAdd WTrtLAss WTrtFAcc WTrtFAccNT WTrtFAss
 WTrtFAssNT WTrtCall WTrtCallNT WTrtNil WTrtCons WTrtInitBlock WTrtBlock WTrtSeq WTrtCond
 WTrtWhile WTrtThrow WTrtTry, consumes 1]
(*>*)

end


(* uses Isabelle2014 and autocorres version 1.0 *)
theory Check_Connected
imports
  "../Library/Autocorres_Misc"
  "../Witness_Property/Connected_Components"
begin
(* Parse the input file. *)
install_C_file "check_connected.c"

autocorres "check_connected.c"

context check_connected begin

(* Autocorres wp lemmas *)

lemma validNFE_getsE[wp]:
  "\<lbrace>\<lambda>s. P (f s) s\<rbrace> getsE f \<lbrace>P\<rbrace>, \<lbrace>E\<rbrace>!"
  by (auto simp: getsE_def) wp

lemma validNFE_guardE[wp]:
  "\<lbrace>\<lambda>s. f s \<and> P () s\<rbrace> guardE f \<lbrace>P\<rbrace>, \<lbrace>Q\<rbrace>!"
  by (auto simp: guardE_def, wp, linarith)

(* Lemmas for unat and of_nat *)
lemma eq_of_nat_conv:
  assumes "unat w1 = n"
  shows "w2 = of_nat n \<longleftrightarrow> w2 = w1"
  using assms by auto

(* More Lemmas for unat and of_nat *)
lemma less_unat_plus1:
  assumes "a < unat (b + 1)"
  shows "a < unat b \<or> a = unat b"
  apply (subgoal_tac  "b + 1 \<noteq> 0 ")
  using assms unat_minus_one add_diff_cancel
  by fastforce+

lemma unat_minus_plus1_less:
  fixes a b
  assumes "a < b"
  shows "unat (b - (a + 1)) < unat (b - a)"
  by (metis (no_types) ab_semigroup_add_class.add_ac(1) right_minus_eq measure_unat
      add_diff_cancel2 assms is_num_normalize(1) zadd_diff_inverse linorder_neq_iff)

lemma unat_image_upto:
  fixes n :: "32 word"
  shows "unat ` {0..<n} = {unat 0..<unat n}" (is "?A = ?B")
proof
  show "?B \<subseteq> ?A"
  proof
    fix i assume a: "i \<in> ?B"
    then obtain i':: "32 word" where ii: "i=  unat i'"
      by (metis ex_nat_less_eq le_unat_uoi not_leE order_less_asym unat_0)
    then have "i' \<in> {0..<n}"
      by (metis (hide_lams, mono_tags) atLeast0LessThan a unat_0
          word_zero_le lessThan_iff not_leE not_less_iff_gr_or_eq
          order_antisym  word_le_nat_alt Un_iff ivl_disj_un(8))
    thus  "i \<in> ?A" using ii by fast
  qed
next
  show "?A \<subseteq> ?B"
  proof
     fix i assume a: "i \<in> ?A"
    then obtain i':: "32 word" where ii: "i=  unat i'" by blast
    then have "i' \<in> {0..<n}" using a by force
    thus  "i \<in> ?B"
      by (metis Un_iff atLeast0LessThan ii ivl_disj_un(8)
          lessThan_iff unat_0 unat_mono word_zero_le)
  qed
qed
(*Implementation Graph Types*)

type_synonym IVertex = "32 word"
type_synonym IEdge_Id = "32 word"
type_synonym IEdge = "IVertex \<times> IVertex"
type_synonym IPEdge = "IVertex \<Rightarrow> 32 word"
type_synonym INum = "IVertex \<Rightarrow> 32 word"
type_synonym IGraph = "32 word \<times> 32 word \<times> (IEdge_Id \<Rightarrow> IEdge)"

abbreviation
  ivertex_cnt :: "IGraph \<Rightarrow> 32 word"
where
  "ivertex_cnt G \<equiv> fst G"

abbreviation
  iedge_cnt :: "IGraph \<Rightarrow> 32 word"
where
  "iedge_cnt G \<equiv> fst (snd G)"

abbreviation
  iedges :: "IGraph \<Rightarrow> IEdge_Id \<Rightarrow> IEdge"
where
  "iedges G \<equiv> snd (snd G)"

(* Make List - makes a list containing the result of a function *)
fun
  bool::"32 word \<Rightarrow> bool"
where
  "bool b = (if b=0 then False else True)"

fun
  mk_list' :: "nat \<Rightarrow> (32 word \<Rightarrow> 'b) \<Rightarrow> 'b list"
where
  "mk_list' n f = map f  (map of_nat [0..<n])"

fun
  mk_list'_temp :: "nat \<Rightarrow> (32 word \<Rightarrow> 'b) \<Rightarrow> nat \<Rightarrow> 'b list"
where
  "mk_list'_temp 0 _ _ = []" |
  "mk_list'_temp (Suc x) f i = (f (of_nat i)) # mk_list'_temp x f (Suc i)"

(* Make graph lists *)
fun
  mk_iedge_list :: "IGraph \<Rightarrow> IEdge list"
where
  "mk_iedge_list G = mk_list' (unat (iedge_cnt G)) (iedges G)"

fun
  mk_inum_list :: "IGraph \<Rightarrow> INum \<Rightarrow> 32 word list"
where
  "mk_inum_list G num = mk_list' (unat (ivertex_cnt G)) num"

fun
  mk_ipedge_list :: "IGraph \<Rightarrow> IPEdge \<Rightarrow> 32 word list"
where
  "mk_ipedge_list G pedge = mk_list' (unat (ivertex_cnt G)) pedge"

(* Equate to Implementation *)
fun
  to_edge :: "IEdge \<Rightarrow> Edge_C"
where
  "to_edge (u,v) = Edge_C u v"

lemma s_C_pte[simp]:
  "s_C (to_edge e) = fst e"
  by (cases e) auto

lemma t_C_pte[simp]:
  "t_C (to_edge e) = snd e"
  by (cases e) auto

definition is_graph where
  "is_graph h iG p \<equiv>
    is_valid_Graph_C h p \<and>
    ivertex_cnt iG = n_C (heap_Graph_C h p) \<and>
    iedge_cnt iG = m_C (heap_Graph_C h p) \<and>
    arrlist (heap_Edge_C h) (is_valid_Edge_C h)
      (map to_edge (mk_iedge_list iG)) (es_C (heap_Graph_C h p))"

definition
  "is_numm h iG iN p \<equiv> arrlist (heap_w32 h) (is_valid_w32 h) (mk_inum_list iG iN) p"

definition
  "is_pedge h iG iP (p:: 32 signed word ptr) \<equiv> arrlist (\<lambda>p. heap_w32 h (ptr_coerce p))
        (\<lambda>p. is_valid_w32 h (ptr_coerce p)) (mk_ipedge_list iG iP) p"

lemma sint_ucast:
  "sint (ucast (x ::word32) :: sword32) = sint x"
  by (clarsimp simp: sint_uint uint_up_ucast is_up)

definition
  is_root :: "IGraph \<Rightarrow> IVertex \<Rightarrow> IPEdge \<Rightarrow> INum \<Rightarrow> bool"
where
  "is_root iG r iP iN \<equiv> r < (ivertex_cnt iG) \<and> (iN r = 0) \<and> (sint (iP r) < 0)"

definition
  parent_num_assms_inv :: "IGraph \<Rightarrow> IVertex \<Rightarrow> IPEdge \<Rightarrow> INum \<Rightarrow> nat \<Rightarrow> bool"
where
  "parent_num_assms_inv G r p n k \<equiv>
    \<forall>i < k. (of_nat i) \<noteq> r \<longrightarrow>
            0 \<le> sint (p (of_nat i)) \<and>
            ((p (of_nat i)) < iedge_cnt G \<and>
            snd (iedges G (p (of_nat i))) = (of_nat i) \<and>
            n (of_nat i) = n (fst (iedges G (p (of_nat i)))) + 1) \<and>
            n (of_nat i) < ivertex_cnt G"

function (in connected_components_locale)
  pwalk :: "'a \<Rightarrow> 'a list"
where
  "pwalk v =
    (if (v = r  \<or> v \<notin> verts G)
      then [v]
      else
       pwalk (tail G (the (parent_edge v))) \<oplus> [tail G (the (parent_edge v)), v])"
  by simp+
termination (in connected_components_locale)
  using parent_num_assms
  by (relation "measure num", auto, fastforce)

lemma (in connected_components_locale) pwalk_simps:
  "v = r \<or> v \<notin> verts G \<Longrightarrow> pwalk v = [v]"
  "v \<noteq> r \<Longrightarrow> v \<in> verts G \<Longrightarrow> pwalk v =
    pwalk (tail G (the (parent_edge v))) @ [v]"
  by (simp, metis drop_0 pwalk.simps
    drop_Suc_Cons vwalk_join_def drop_Suc)

lemma (in connected_components_locale) pwalk_ne: "pwalk v \<noteq> []"
  by (metis drop_0 drop_Suc drop_Suc_Cons not_Cons_self
      pwalk.simps snoc_eq_iff_butlast vwalk_join_def)

lemma (in connected_components_locale) vwalk_length_pwalk:
  assumes "v \<in> verts G"
  assumes "v \<noteq> r"
  shows "vwalk_length (pwalk v) =
         vwalk_length (pwalk (tail G (the (parent_edge v)))) + 1"
  by (smt append_Cons assms length_append length_tl list.size(3,4) pwalk_ne
     pwalk.simps tl_append2 vwalk_join_Cons vwalk_join_def vwalk_length_simp)

lemma (in connected_components_locale) pwalk_split:
  assumes "x \<in> set (pwalk v)"
  shows "\<exists>p. pwalk v = pwalk x @ p"
using assms
proof (induct "vwalk_length (pwalk v)" arbitrary: v)
case (Suc n)
have vnr: "v \<noteq> r"
  using Suc(2) by fastforce
show ?case
  proof (cases "v \<in> verts G")
  case True
    thus ?thesis
    proof (cases "x = v")
    case False
      let ?u = "tail G (the (parent_edge v))"
      have xpu: "x \<in> set (pwalk ?u)"
        using Suc(3) pwalk_simps(2)[OF vnr True] False by fastforce
      hence "\<exists>p. pwalk (tail G (the (parent_edge v))) = pwalk x @ p"
        using vwalk_length_pwalk[OF True vnr] Suc(2)
        by (metis Suc(1)[OF _ xpu] Suc_eq_plus1
            Suc_eq_plus1_left diff_add_inverse)
      thus ?thesis using pwalk_simps(2)[OF vnr True] by fastforce
    qed fast
  qed (metis Suc.prems append_Nil2 empty_iff empty_set pwalk_simps(1) set_ConsD)
qed (metis pwalk_simps(1) add_is_0 vwalk_length_pwalk
     append_Nil2 empty_iff empty_set one_neq_zero set_ConsD)

lemma (in connected_components_locale) path_from_root_num:
  fixes v :: 'a
  assumes "v \<in> verts G"
  shows "vpath (pwalk v) G \<and>
         hd (pwalk v) = r \<and>
         last (pwalk v) = v \<and>
         num v = vwalk_length (pwalk v)"
using assms
proof (induct "vwalk_length (pwalk v)" arbitrary: v rule: less_induct)
case less
  thus ?case
  proof (cases "v=r")
    case True
      thus ?thesis using r_assms unfolding vpath_def by force
  next
    case False
      then obtain e where ee:
        "e \<in> arcs G"
        "e = the (parent_edge v)"
        "head G e = v \<and> num v = num (tail G e) + 1"
        using less.prems parent_num_assms by force
      let ?te = "tail G e"
      let ?p' = "pwalk ?te"
      let ?q = "[?te, v]"
      obtain p where
        pp: "p = ?p' \<oplus> ?q"
        by presburger
      hence pv: "p = pwalk v"
        using less.prems False ee(2) by force
      have ew: "vwalk ?q G" unfolding vwalk_def
        using ee(3) in_arcs_imp_in_arcs_ends[OF ee(1)]
              less.prems  tail_in_verts[OF ee(1)]
        by auto
      have wlp: "vwalk_length ?p' < vwalk_length (pwalk v)"
        using vwalk_length_pwalk[OF less.prems False] ee(2)
        by presburger
      hence pp':
        "vwalk ?p' G"
        "distinct ?p'"
        "hd ?p' = r"
        "last ?p' = ?te"
        "num ?te = vwalk_length ?p'"
        using less.hyps[where v="?te",
              OF _ tail_in_verts[OF ee(1)]]
        unfolding vpath_def by linarith+
      have jp: "joinable ?p' ?q"
         unfolding  joinable_def
         by (simp only: pp'(4) pp'(1)[unfolded vwalk_def], simp)
      have "vwalk_length [tail G e, v] = 1" by force
      hence np: "num v = vwalk_length p"
        using pp vwalk_join_vwalk_length[OF jp] ee pp'(5)
        by (simp only: pp vwalk_join_vwalk_length[OF jp] ee pp'(5))
      have wp: "vwalk p G"
        by (metis pp ew pp'(1) jp vwalk_joinI_vwalk)
      {
        fix x assume xp: "x \<in> set ?p'"
        have "vwalk_length (pwalk x) \<le> vwalk_length ?p'"
        using pwalk_split[OF xp] by (smt length_append vwalk_length_simp)
        then have wlx: "vwalk_length (pwalk x) < vwalk_length (pwalk v)"
          using wlp by linarith
        hence "num x = vwalk_length (pwalk x)"
          using pp'(1) less.hyps[OF wlx] xp vwalk_verts_in_verts by blast
        with wlx have "num x < vwalk_length (pwalk v)" by presburger
      }
    then have "v \<notin> set ?p'" using wlp np pv  by (metis less_not_refl)
    hence dp: "distinct p"
      by (metis butlast_snoc distinct.simps(2) distinct1_rotate pp pp'(2)
        list.simps(2) rotate1.simps(2) rotate1_hd_tl vwalk_join_def)
    hence "vpath p G \<and> hd p = r \<and> last p = v \<and>
           num v = vwalk_length p"
      using dp wp np pp' pp
      by (metis hd_append2 last_snoc list.sel(3) pwalk_ne vpathI vwalk_join_def)
    thus ?thesis using pv by fast
  qed
qed

(* Abstract Graph *)

definition
  no_loops :: "('a, 'b) pre_digraph \<Rightarrow> bool"
where
  "no_loops G \<equiv> \<forall>e \<in> arcs G. tail G e \<noteq> head G e"

definition
  abs_IGraph :: "IGraph \<Rightarrow> (32 word, 32 word) pre_digraph"
where
  "abs_IGraph G \<equiv> \<lparr> verts = {0..<ivertex_cnt G}, arcs = {0..<iedge_cnt G},
    tail = fst o iedges G, head = snd o iedges G \<rparr>"

lemma verts_absI[simp]: "verts (abs_IGraph G) = {0..<ivertex_cnt G}"
  and edges_absI[simp]: "arcs (abs_IGraph G) = {0..<iedge_cnt G}"
  and start_absI[simp]: "tail (abs_IGraph G) e = fst (iedges G e)"
  and target_absI[simp]: "head (abs_IGraph G) e = snd (iedges G e)"
  by (auto simp: abs_IGraph_def)

definition
  abs_pedge :: "(32 word \<Rightarrow> 32 word) \<Rightarrow> 32 word \<Rightarrow> 32 word option"
where
  "abs_pedge p \<equiv> (\<lambda>v. if sint (p v) < 0 then None else Some (p v))"

lemma None_abs_pedgeI[simp]:
  "((abs_pedge p) v = None) = (sint (p v) < 0)"
  using abs_pedge_def by auto

lemma Some_abs_pedgeI[simp]:
  "(\<exists>e. (abs_pedge p) v = Some e) = (sint (p v) \<ge> 0)"
  using None_not_eq None_abs_pedgeI
  by (metis abs_pedge_def linorder_not_le option.simps(3))

(*Helper Lemmas*)

lemma wellformed_iGraph:
  assumes "wf_digraph (abs_IGraph G)"
  shows "\<And>e. e < iedge_cnt G \<Longrightarrow>
        fst (iedges G e) < ivertex_cnt G \<and>
        snd (iedges G e) < ivertex_cnt G"
using assms unfolding wf_digraph_def by simp

lemma path_length:
  assumes "vpath p (abs_IGraph iG)"
  shows "vwalk_length p < unat (ivertex_cnt iG)"
proof -
  have pne: "p \<noteq> []" and dp: "distinct p" using assms by fast+
  have "unat (ivertex_cnt iG) = card (unat ` {0..<(fst iG)})"
    using unat_image_upto by simp
  then have "unat (ivertex_cnt iG) = card ((verts (abs_IGraph iG)))"
     by (simp add: inj_on_def card_image)
  hence "length p  \<le> unat (ivertex_cnt iG)"
      by (metis finite_code card_mono vwalk_def
          distinct_card[OF dp] vpath_def assms)
  hence "length p - 1 < unat (ivertex_cnt iG)"
    by (metis pne Nat.diff_le_self le_neq_implies_less
        less_imp_diff_less minus_eq one_neq_zero length_0_conv)
  thus "vwalk_length p < unat (fst iG)"
    using  assms
    unfolding vpath_def vwalk_def by simp
qed

lemma ptr_coerce_ptr_add_uint[simp]:
  "ptr_coerce (p +\<^sub>p uint x) =  p +\<^sub>p  (uint x)"
  by auto

lemma check_r'_spc:
  "is_graph s iG p \<Longrightarrow>
   is_numm s iG iN p' \<Longrightarrow>
   is_pedge s iG iP p'' \<Longrightarrow>
   check_r' p r p'' p' s =
   Some (if is_root iG r iP iN then 1 else 0)"
  unfolding check_r'_def unfolding is_graph_def is_numm_def is_pedge_def
  apply (simp add: ocondition_def oguard_def ogets_def oreturn_def obind_def)
  apply (simp add: is_root_def uint_nat word_less_def sint_ucast)
  apply (safe, simp_all add: arrlist_nth)
     apply (fastforce simp: dest:arrlist_nth_value[where i="int (unat r)"])
    apply (fastforce dest:arrlist_nth_valid[where i="int (unat r)"])
   apply (fastforce dest:arrlist_nth_value[where i="int (unat r)"])
  apply (fastforce dest:arrlist_nth_valid[where i="int (unat r)"])
  done

(*state monad without exception*)
lemma pedge_num_heap:
  "\<lbrakk>arrlist (\<lambda>p. heap_w32 h (ptr_coerce p)) (\<lambda>p. is_valid_w32 h (ptr_coerce p))
  (map (iL \<circ> of_nat) [0..<unat n]) l; i < n\<rbrakk> \<Longrightarrow>
    iL i = heap_w32 h (l +\<^sub>p int (unat i))"
  apply (subgoal_tac
  "heap_w32 h (l +\<^sub>p int (unat i)) = map (iL \<circ> of_nat) [0..<unat n] ! unat i")
   apply (subgoal_tac "map (iL \<circ> of_nat) [0..<unat n] ! unat i = iL i")
    apply fastforce
   apply (metis (hide_lams, mono_tags) unat_mono word_unat.Rep_inverse
    minus_nat.diff_0 nth_map_upt o_apply plus_nat.add_0)
  apply (simp add: arrlist_nth_value unat_mono)
  done

lemma pedge_num_heap_ptr_coerce:
  "\<lbrakk>arrlist (\<lambda>p. heap_w32 h (ptr_coerce p)) (\<lambda>p. is_valid_w32 h (ptr_coerce p))
  (map (iL \<circ> of_nat) [0..<unat n]) l; i < n; 0 \<le> i\<rbrakk> \<Longrightarrow>
    iL i = heap_w32 h (ptr_coerce (l +\<^sub>p int (unat i)))"
  apply (subgoal_tac
  "heap_w32 h (ptr_coerce (l +\<^sub>p int (unat i))) = map (iL \<circ> of_nat) [0..<unat n] ! unat i")
   apply (subgoal_tac "map (iL \<circ> of_nat) [0..<unat n] ! unat i = iL i")
    apply fastforce
   apply (metis (hide_lams, mono_tags) unat_mono word_unat.Rep_inverse
    minus_nat.diff_0 nth_map_upt o_apply plus_nat.add_0)
  apply (drule arrlist_nth_value[where i="int (unat i)"], (simp add:unat_mono)+)
  done

lemma edge_heap:
  "\<lbrakk> arrlist h v (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ep;
  e < m\<rbrakk> \<Longrightarrow> to_edge ((iedges iG) e) = h (ep +\<^sub>p (int (unat e)))"
  apply (subgoal_tac "h (ep +\<^sub>p (int (unat e))) =
  (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ! unat e")
   apply (subgoal_tac "to_edge ((iedges iG) e) =
   (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ! unat e")
    apply presburger
   apply (metis (hide_lams, mono_tags) length_map length_upt o_apply
      map_upt_eq_vals_D minus_nat.diff_0 unat_mono word_unat.Rep_inverse)
  apply (fastforce simp: unat_mono arrlist_nth_value)
  done

lemma head_heap:
  "\<lbrakk>arrlist h v (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ep; e < m\<rbrakk> \<Longrightarrow>
  snd ((iedges iG) e) = t_C (h (ep +\<^sub>p (uint e)))"
  using edge_heap to_edge.simps t_C_pte by (metis uint_nat)

lemma tail_heap:
  "\<lbrakk>arrlist h v (map (to_edge \<circ> (iedges iG \<circ> of_nat)) [0..<unat m]) ep; e < m\<rbrakk> \<Longrightarrow>
  fst ((iedges iG) e) =  s_C (h (ep +\<^sub>p  (uint e)))"
  using edge_heap to_edge.simps s_C_pte uint_nat by metis

lemma check_parent_num_spc':
  "\<lbrace> P and
    (\<lambda>s. wf_digraph (abs_IGraph iG) \<and>
         is_graph s iG g \<and>
         is_numm s iG iN n \<and>
         is_pedge s iG iP p \<and>
         r < ivertex_cnt iG)\<rbrace>
  check_parent_num' g r p n
  \<lbrace> (\<lambda>_ s. P s) And
    (\<lambda>rr s. rr \<noteq> 0 \<longleftrightarrow> parent_num_assms_inv iG r iP iN (unat (ivertex_cnt iG))) \<rbrace>!"
  apply (clarsimp simp: check_parent_num'_def)
  apply (subst whileLoopE_add_inv[where
        M="\<lambda>(vv, s). unat (ivertex_cnt iG - vv)" and
        I="\<lambda>vv s. P s \<and> parent_num_assms_inv iG r iP iN (unat vv) \<and>
          vv \<le> ivertex_cnt iG \<and>
          wf_digraph (abs_IGraph iG) \<and>
          is_graph s iG g \<and> is_numm s iG iN n \<and>
          is_pedge s iG iP p \<and>
          r < ivertex_cnt iG"])
  apply (simp add: skipE_def)
  apply wp
    unfolding is_graph_def is_numm_def is_pedge_def parent_num_assms_inv_def
    apply (subst if_bool_eq_conj)+
    apply (simp split: split_if_asm, safe, simp_all add: arrlist_nth)
                              apply (rule_tac i=" (uint vv)" in arrlist_nth_valid, simp+)
                              apply (metis uint_nat word_less_def)
                             apply (rule_tac x="unat vv" in exI)
                             apply (subgoal_tac "n_C (heap_Graph_C s g) \<le> iN vv")
                              apply (metis (hide_lams) word_less_nat_alt
                              word_not_le word_unat.Rep_inverse)
                             apply (subst pedge_num_heap[where l=n and iL=iN])
                               apply simp
                              apply simp
                             apply (metis uint_nat)
                            apply (rule_tac i=" (uint vv)" in arrlist_nth_valid)
                              apply simp+
                            apply (metis uint_nat word_less_def)
                           apply (rule_tac x="unat vv" in exI)
                           apply (rule conjI, metis unat_mono, simp)
                           apply (metis sint_ucast not_le uint_nat
                           pedge_num_heap_ptr_coerce word_zero_le)
                          apply (rule_tac x="unat vv" in exI)
                          apply (rule conjI, metis unat_mono, simp)
                          apply (metis not_le uint_nat pedge_num_heap_ptr_coerce word_zero_le)
                         apply (rule_tac x="unat vv" in exI)
                         apply (rule conjI, metis unat_mono, simp)
                         apply (subgoal_tac "snd (snd (snd iG) (iP vv)) =
                           t_C (heap_Edge_C s (es_C (heap_Graph_C s g) +\<^sub>p uint (iP vv)))")
                          apply (metis uint_nat pedge_num_heap_ptr_coerce word_zero_le)
                         apply (subst head_heap[where iG=iG], simp)
                          apply (metis not_le uint_nat pedge_num_heap_ptr_coerce word_zero_le)
                         apply simp
                        apply (rule_tac x="unat vv" in exI)
                        apply (rule conjI, metis unat_mono, simp,clarsimp)
                        apply (subgoal_tac "iN vv \<noteq> iN (fst (snd (snd iG) (iP vv))) + 1")
                         apply fast
                        apply (subst pedge_num_heap[where l=n and iL=iN])
                          apply simp+
                        apply (subst pedge_num_heap[where l=n and iL=iN])
                          apply simp
                         apply (drule wellformed_iGraph[where G=iG])
                          apply simp+
                        apply (subst tail_heap[where iG=iG], simp+)
                        apply (subst pedge_num_heap_ptr_coerce[where l=p and iL=iP])
                           apply simp+
                        apply (metis uint_nat)
                       apply (drule less_unat_plus1, safe, blast)
                       apply (subst pedge_num_heap_ptr_coerce[where l=p and iL=iP])
                          apply simp+
                       apply (metis sint_ucast not_less uint_nat)
                      apply (drule less_unat_plus1, safe, blast)
                      apply (subst pedge_num_heap_ptr_coerce[where l=p and iL=iP])
                         apply simp+
                      apply (metis not_less uint_nat)
                     apply (drule less_unat_plus1, safe, blast)
                     apply (subst pedge_num_heap_ptr_coerce[where l=p and iL=iP])
                        apply simp+
                     apply (subst head_heap[where iG=iG], (simp add: uint_nat)+)
                    apply (drule less_unat_plus1, safe, blast)
                    apply (subst pedge_num_heap[where l=n and iL=iN], simp+)
                    apply (subst pedge_num_heap[where l=n and iL=iN], simp)
                     apply (drule_tac e="iP vv" in  wellformed_iGraph[where G=iG])
                      apply (metis not_le pedge_num_heap_ptr_coerce word_zero_le)
                     apply simp
                    apply (subst tail_heap[where iG=iG], simp+)
                     apply (metis not_le pedge_num_heap_ptr_coerce word_zero_le)
                    apply (subst pedge_num_heap_ptr_coerce[where l=p and iL=iP])
                       apply simp+
                    apply (metis uint_nat)
                   apply (drule less_unat_plus1, safe, blast)
                   apply (subst pedge_num_heap[where l=n and iL=iN])
                     apply (simp add: uint_nat)+
                  apply (metis le_def word_le_nat_alt word_not_le
                  less_unat_plus1 eq_of_nat_conv)
                 apply (metis unat_minus_plus1_less)
                apply (rule arrlist_nth, blast, blast)
                apply (simp add: uint_nat unat_mono)
               apply (rule arrlist_nth, blast, blast)
               apply (simp add: uint_nat)
               apply (drule_tac i=vv in pedge_num_heap_ptr_coerce[where l=p and iL=iP])
                 apply simp+
               apply (drule_tac e="iP vv" in wellformed_iGraph[where G=iG])
                apply simp+
               apply (drule_tac e="iP vv" in tail_heap[where iG=iG])
                apply (simp add: uint_nat unat_mono)+
              apply (rule arrlist_nth, (simp add: uint_nat unat_mono)+)+
          apply (metis less_unat_plus1 word_unat.Rep_inverse)
         apply (metis eq_of_nat_conv less_unat_plus1)
        apply (metis (hide_lams, no_types) eq_of_nat_conv less_unat_plus1)
       apply (metis (no_types) less_unat_plus1 word_unat.Rep_inverse)
      apply (metis (no_types) less_unat_plus1 word_unat.Rep_inverse)
     apply (metis inc_le)
    apply (metis unat_minus_plus1_less)
   apply metis
  apply wp
  apply fast
  done
lemma num_less_n:
  fixes v
  assumes "is_root G r p n"
  assumes "parent_num_assms_inv G r p n (unat (ivertex_cnt G))"
  assumes "v < ivertex_cnt G"
  shows "n v < ivertex_cnt G"
proof -
  have "ivertex_cnt G > 0"
    using assms by (metis word_neq_0_conv word_not_simps(1))
  thus ?thesis
    using assms unfolding parent_num_assms_inv_def is_root_def
    by (cases "v=r", presburger , metis unat_mono word_unat.Rep_inverse)
qed

lemma parent_num_assms_inv_num_ne_0:
  fixes v
  assumes "wf_digraph (abs_IGraph G)"
  assumes "is_root G r p n"
  assumes "parent_num_assms_inv G r p n (unat (ivertex_cnt G))"
  assumes "v \<noteq> r"
  assumes "v < (ivertex_cnt G)"
  shows "n v \<noteq> 0"
proof-
  have "p v \<in> arcs (abs_IGraph G)"
    using assms(3-5) unat_mono
    unfolding parent_num_assms_inv_def
    by fastforce
  hence "fst (iedges G (p v)) \<in> verts (abs_IGraph G)"
     using assms(1) wf_digraph_def  by fastforce
  hence "n (fst (snd (snd G) (p v))) < ivertex_cnt G"
    using num_less_n[OF assms(2,3)] by fastforce
  moreover
  have "n v = n (fst (snd (snd G) (p v))) + 1"
    using assms unat_mono
    unfolding parent_num_assms_inv_def
    by force
  ultimately
  show ?thesis using assms
  by (metis less_is_non_zero_p1)
qed

lemma connected_components_locale_num_eq_invariants':
"\<And>G r p n.
  (connected_components_locale (abs_IGraph G) (unat \<circ>  n) (abs_pedge p) r
  \<and> (\<forall>v \<in> verts (abs_IGraph G). v\<noteq> r \<longrightarrow> (unat \<circ> n) v < unat (ivertex_cnt G))) =
    (wf_digraph (abs_IGraph G) \<and>
    is_root G r p n \<and>
    parent_num_assms_inv G r p n (unat (ivertex_cnt G)))"
proof -
  fix G fix r::"32 word" fix p n::"32 word \<Rightarrow> 32 word"
  let ?aG = "abs_IGraph G"
  let ?ap = "abs_pedge p"
  let ?an = "unat \<circ>  n"
  let ?wf = "wf_digraph ?aG"
  let ?is_root = "r \<in> verts ?aG \<and> ?ap r = None \<and> ?an r = 0"
  let ?pnai = "(\<forall>v. v \<in> verts ?aG \<and> v \<noteq> r \<longrightarrow>
                  (\<exists>e\<in>arcs ?aG. ?ap v = Some e \<and>
                  head ?aG e = v \<and>
                  ?an v = ?an (tail ?aG e) + 1)) \<and>
               (\<forall>v. v \<in>verts ?aG \<and>  v \<noteq> r \<longrightarrow>
                  ?an v < unat (ivertex_cnt G))"
  have isr_eq: "?is_root = is_root G r p n"
    unfolding is_root_def
    using None_abs_pedgeI unat_eq_0 by auto
moreover
  have "(?wf \<and> ?is_root \<and> ?pnai)
      = (?wf \<and> is_root G r p n \<and>
        parent_num_assms_inv G r p n (unat (ivertex_cnt G)))"
  proof -
  {
    assume wf: "?wf"
    assume isr: "?is_root"
    assume *: "\<And> v. v \<in> verts ?aG \<and> v \<noteq> r \<Longrightarrow>
    (\<exists>e \<in> arcs ?aG. ?ap v = Some e \<and>
    head ?aG e = v \<and>
    ?an v =  ?an (tail ?aG e) + 1) \<and> (?an v < unat (ivertex_cnt G))"
    {
      fix i
      let ?i = "of_nat i"
      assume "i < unat (ivertex_cnt G) \<and> ?i \<noteq> r"
      then have ii: "?i \<in> verts (abs_IGraph G) \<and> ?i \<noteq> r"
        by (simp add: word_of_nat_less)
      then obtain e where e_assms:
        "e \<in> arcs ?aG"
        "?ap ?i = Some e"
        "head ?aG e = ?i"
        "?an ?i =  ?an (tail ?aG e) + 1"
        "?an ?i < unat (ivertex_cnt G)" using *[OF ii] by auto
      have pi_e: "p ?i = e"
        using e_assms(2) abs_pedge_def Some_abs_pedgeI
        by (cases "?ap ?i") force+
      with e_assms pi_e  Some_abs_pedgeI have
        "p ?i < iedge_cnt G \<and>
         0 \<le> sint (p ?i) \<and>
         snd (iedges G (p ?i)) = ?i \<and>
         n ?i = n (fst (iedges G (p ?i))) + 1 \<and>
         n ?i < ivertex_cnt G \<and>
         n ?i \<noteq> 0"
         by (auto,
             metis Some_abs_pedgeI,
             metis (hide_lams, mono_tags) Suc_eq_plus1 unat_1
                    word_arith_nat_add word_unat.Rep_inverse,
             metis word_less_nat_alt)
    } then have "is_root G r p n \<and>
                parent_num_assms_inv G r p n (unat (ivertex_cnt G))"
    unfolding parent_num_assms_inv_def using isr isr_eq by blast
  }
  hence "?wf \<and> ?is_root \<and> ?pnai
      \<Longrightarrow> is_root G r p n \<and>
        parent_num_assms_inv G r p n (unat (ivertex_cnt G))" by presburger
  moreover
  {
    assume wf: "?wf"
    assume isr: "is_root G r p n"
    assume pna: "parent_num_assms_inv G r p n (unat (ivertex_cnt G))"
    {
      fix v
      assume vG: "v \<in> verts ?aG"
      assume vnr: "v \<noteq> r"
      have uvG: "unat v < unat (ivertex_cnt G)"
        using vG by (simp add: word_less_nat_alt)
      have nv_ne0: "n v \<noteq> 0" using pna isr wf unfolding parent_num_assms_inv_def
        by (metis parent_num_assms_inv_num_ne_0 pna uvG vnr word_less_nat_alt)
      then have *: "
        p v < iedge_cnt G \<and>
        0 \<le> sint (p v) \<and>
        snd (iedges G (p v)) =  v \<and>
        n v = n (fst (iedges G (p v))) + 1 \<and>
        n v < ivertex_cnt G"
        using vnr pna
        unfolding parent_num_assms_inv_def
        by (metis uvG word_unat.Rep_inverse)
      then have 1:
      "\<exists>e. e \<in> arcs ?aG \<and> ?ap v = Some e \<and>
           head ?aG e = v \<and>
           ?an v = ?an (tail ?aG e) + 1"
        using abs_pedge_def linorder_not_less unatSuc2 nv_ne0 by auto
     have 2: "?an v < unat (ivertex_cnt G)"
     using * by (metis o_apply word_less_nat_alt)
     from 1 2 have
     "(\<exists>e. e \<in> arcs ?aG \<and> ?ap v = Some e \<and>
           head ?aG e = v \<and>
           ?an v = ?an (tail ?aG e) + 1) \<and>
      ?an v < unat (ivertex_cnt G)" by blast
   } then have "?is_root \<and> ?pnai" using  isr isr_eq by fast
  }
  hence "?wf \<and> is_root G r p n \<and>
        parent_num_assms_inv G r p n (unat (ivertex_cnt G)) \<Longrightarrow>
        ?is_root \<and> ?pnai" by presburger
  ultimately
    show ?thesis by blast
  qed
ultimately
show  "?thesis G r p n"
  unfolding connected_components_locale_def
  connected_components_locale_axioms_def
  fin_digraph_def fin_digraph_axioms_def
  by auto
qed

lemma cc_num_less_n:
  assumes "connected_components_locale (abs_IGraph G) (unat \<circ>  n) (abs_pedge p) r"
  assumes "v \<in> verts (abs_IGraph G)"
  shows "(unat \<circ> n) v < unat (ivertex_cnt G)"
using connected_components_locale.path_from_root_num[OF assms] path_length
by presburger

lemma connected_components_locale_eq_invariants':
"\<And>G r p n.
  (connected_components_locale (abs_IGraph G) (unat \<circ>  n) (abs_pedge p) r) =
    (wf_digraph (abs_IGraph G) \<and>
    is_root G r p n \<and>
    parent_num_assms_inv G r p n (unat (ivertex_cnt G)))"
    using connected_components_locale_num_eq_invariants' cc_num_less_n by blast

lemma check_connected_spc:
  "\<lbrace> P and
    (\<lambda>s. wf_digraph (abs_IGraph iG) \<and>
         is_graph s iG g \<and>
         is_numm s iG iN n \<and>
         is_pedge s iG iP p)\<rbrace>
  check_connected' g r p n
  \<lbrace> (\<lambda>_ s. P s) And
    (\<lambda>rr s. rr \<noteq> 0 \<longleftrightarrow>
      connected_components_locale (abs_IGraph iG) (unat \<circ>  iN) (abs_pedge iP) r) \<rbrace>!"
  apply (clarsimp simp: check_connected'_def
  connected_components_locale_eq_invariants')
  apply wp
  apply (rule_tac P1=" P and
    (\<lambda>s. wf_digraph (abs_IGraph iG) \<and>
         is_graph s iG g \<and>
         is_numm s iG iN n \<and>
         is_pedge s iG iP p \<and>
         r < ivertex_cnt iG \<and>
         is_root iG r iP iN)"
     in validNF_post_imp[OF _ check_parent_num_spc'])
  unfolding fin_digraph_def fin_digraph_axioms_def
  apply force
  apply wp
  apply (auto simp: check_r'_spc is_root_def)[]
done

end
end