section\<open>Preservation of cardinals in generic extensions\<close>

theory Cardinal_Preservation
  imports
    Forcing_Main
begin

context forcing_data1

begin

lemma antichain_abs' [absolut]:
  "\<lbrakk> A\<in>M \<rbrakk> \<Longrightarrow> antichain\<^bsup>M\<^esup>(\<bbbP>,leq,A) \<longleftrightarrow> antichain(\<bbbP>,leq,A)"
  unfolding antichain_rel_def antichain_def compat_def
  using transitivity[of _ A]
  by (auto simp add:absolut)

lemma inconsistent_imp_incompatible:
  assumes "p \<tturnstile> \<phi> env" "q \<tturnstile> Neg(\<phi>) env" "p\<in>\<bbbP>" "q\<in>\<bbbP>"
    "arity(\<phi>) \<le> length(env)" "\<phi> \<in> formula" "env \<in> list(M)"
  shows "p \<bottom> q"
proof
  assume "compat(p,q)"
  then
  obtain d where "d \<preceq> p" "d \<preceq> q" "d \<in> \<bbbP>" by blast
  moreover
  note assms
  moreover from calculation
  have "d \<tturnstile> \<phi> env" "d \<tturnstile> Neg(\<phi>) env"
    using strengthening_lemma by simp_all
  ultimately
  show "False"
    using Forces_Neg[of d env \<phi>] refl_leq
    by (auto dest:transitivity; drule_tac bspec; auto dest:transitivity)
qed

notation check (\<open>_\<^sup>v\<close> [101] 100)

end \<comment> \<open>\<^locale>\<open>forcing_data1\<close>\<close>

locale G_generic2 = G_generic1 + forcing_data2
locale G_generic2_AC = G_generic1_AC + G_generic2

locale G_generic3 = G_generic2 + forcing_data3
locale G_generic3_AC = G_generic2_AC + G_generic3

locale G_generic3_AC_CH = G_generic3_AC + M_ZFC2_ground_CH_trans

sublocale G_generic3_AC \<subseteq> ext:M_ZFC2_trans "M[G]"
  using ground_replacements3 replacement_assm_MG
  by unfold_locales simp_all

lemma (in forcing_data1) forces_neq_apply_imp_incompatible:
  assumes
    "p \<tturnstile> \<cdot>0`1 is 2\<cdot> [f,a,b\<^sup>v]"
    "q \<tturnstile> \<cdot>0`1 is 2\<cdot> [f,a,b'\<^sup>v]"
    "b \<noteq> b'"
    \<comment> \<open>More general version: taking general names
       \<^term>\<open>b\<^sup>v\<close> and \<^term>\<open>b'\<^sup>v\<close>, satisfying
       \<^term>\<open>p \<tturnstile> \<cdot>\<not>\<cdot>0 = 1\<cdot>\<cdot> [b\<^sup>v, b'\<^sup>v]\<close> and
       \<^term>\<open>q \<tturnstile> \<cdot>\<not>\<cdot>0 = 1\<cdot>\<cdot> [b\<^sup>v, b'\<^sup>v]\<close>.\<close>
    and
    types:"f\<in>M" "a\<in>M" "b\<in>M" "b'\<in>M" "p\<in>\<bbbP>" "q\<in>\<bbbP>"
  shows
    "p \<bottom> q"
proof -
  {
    fix G
    assume "M_generic(G)"
    then
    interpret G_generic1 _ _ _ _ _ G by unfold_locales
    include G_generic1_lemmas
    assume "q\<in>G"
    with assms \<open>M_generic(G)\<close>
    have "M[G], map(val(G),[f,a,b'\<^sup>v]) \<Turnstile> \<cdot>0`1 is 2\<cdot>"
      using truth_lemma[of "\<cdot>0`1 is 2\<cdot>" "[f,a,b'\<^sup>v]"]
      by (auto simp add:ord_simp_union arity_fun_apply_fm
          fun_apply_type)
    with \<open>b \<noteq> b'\<close> types
    have "M[G], map(val(G),[f,a,b\<^sup>v]) \<Turnstile> \<cdot>\<not>\<cdot>0`1 is 2\<cdot>\<cdot>"
      using GenExtI by auto
  }
  with types
  have "q \<tturnstile> \<cdot>\<not>\<cdot>0`1 is 2\<cdot>\<cdot> [f,a,b\<^sup>v]"
    using definition_of_forcing[where \<phi>="\<cdot>\<not>\<cdot>0`1 is 2\<cdot>\<cdot>" ]
    by (auto simp add:ord_simp_union arity_fun_apply_fm)
  with \<open>p \<tturnstile> \<cdot>0`1 is 2\<cdot> [f,a,b\<^sup>v]\<close> and types
  show "p \<bottom> q"
    using inconsistent_imp_incompatible
    by (simp add:ord_simp_union arity_fun_apply_fm fun_apply_type)
qed

context M_ctm2_AC
begin

\<comment> \<open>Simplifying simp rules (because of the occurrence of
   \<^term>\<open>setclass\<close>)\<close>
lemmas sharp_simps = Card_rel_Union Card_rel_cardinal_rel Collect_abs
  Cons_abs Cons_in_M_iff Diff_closed Equal_abs Equal_in_M_iff Finite_abs
  Forall_abs Forall_in_M_iff Inl_abs Inl_in_M_iff Inr_abs Inr_in_M_iff
  Int_closed Inter_abs Inter_closed M_nat Member_abs Member_in_M_iff
  Memrel_closed Nand_abs Nand_in_M_iff Nil_abs Nil_in_M Ord_cardinal_rel
  Pow_rel_closed Un_closed Union_abs Union_closed and_abs and_closed
  apply_abs apply_closed bij_rel_closed bijection_abs bool_of_o_abs
  bool_of_o_closed cadd_rel_0 cadd_rel_closed cardinal_rel_0_iff_0
  cardinal_rel_closed cardinal_rel_idem cartprod_abs cartprod_closed
  cmult_rel_0 cmult_rel_1 cmult_rel_closed comp_closed composition_abs
  cons_abs cons_closed converse_abs converse_closed csquare_lam_closed
  csquare_rel_closed depth_closed domain_abs domain_closed eclose_abs
  eclose_closed empty_abs field_abs field_closed finite_funspace_closed
  finite_ordinal_abs fst_closed function_abs function_space_rel_closed
  hd_abs image_abs image_closed inj_rel_closed injection_abs inter_abs
  irreflexive_abs is_eclose_n_abs is_funspace_abs
  iterates_closed length_closed lepoll_rel_refl
  limit_ordinal_abs linear_rel_abs
  mem_bij_abs mem_eclose_abs mem_inj_abs membership_abs
  minimum_closed nat_case_abs nat_case_closed nonempty not_abs
  not_closed number1_abs number2_abs number3_abs omega_abs
  or_abs or_closed order_isomorphism_abs ordermap_closed
  ordertype_closed ordinal_abs pair_abs pair_in_M_iff powerset_abs
  pred_closed pred_set_abs quasilist_abs quasinat_abs radd_closed
  rall_abs range_abs range_closed relation_abs restrict_closed
  restriction_abs rex_abs rmult_closed rtrancl_abs rtrancl_closed
  rvimage_closed separation_closed setdiff_abs singleton_abs
  singleton_in_M_iff snd_closed strong_replacement_closed subset_abs
  succ_in_M_iff successor_abs successor_ordinal_abs sum_abs sum_closed
  surj_rel_closed surjection_abs tl_abs trancl_abs trancl_closed
  transitive_rel_abs transitive_set_abs typed_function_abs union_abs
  upair_abs upair_in_M_iff vimage_abs vimage_closed well_ord_abs
  nth_closed Aleph_rel_closed csucc_rel_closed
  Card_rel_Aleph_rel

declare sharp_simps[simp del, simplified setclass_iff, simp]

lemmas sharp_intros = nat_into_M Aleph_rel_closed Card_rel_Aleph_rel

declare sharp_intros[rule del, simplified setclass_iff, intro]

end \<comment> \<open>\<^locale>\<open>M_ctm2_AC\<close>\<close>

context G_generic3_AC begin

context
  includes G_generic1_lemmas
begin

lemmas mg_sharp_simps = ext.Card_rel_Union ext.Card_rel_cardinal_rel
  ext.Collect_abs ext.Cons_abs ext.Cons_in_M_iff ext.Diff_closed
  ext.Equal_abs ext.Equal_in_M_iff ext.Finite_abs ext.Forall_abs
  ext.Forall_in_M_iff ext.Inl_abs ext.Inl_in_M_iff ext.Inr_abs
  ext.Inr_in_M_iff ext.Int_closed ext.Inter_abs ext.Inter_closed
  ext.M_nat ext.Member_abs ext.Member_in_M_iff ext.Memrel_closed
  ext.Nand_abs ext.Nand_in_M_iff ext.Nil_abs ext.Nil_in_M
  ext.Ord_cardinal_rel ext.Pow_rel_closed ext.Un_closed
  ext.Union_abs ext.Union_closed ext.and_abs ext.and_closed
  ext.apply_abs ext.apply_closed ext.bij_rel_closed
  ext.bijection_abs ext.bool_of_o_abs ext.bool_of_o_closed
  ext.cadd_rel_0 ext.cadd_rel_closed ext.cardinal_rel_0_iff_0
  ext.cardinal_rel_closed ext.cardinal_rel_idem ext.cartprod_abs
  ext.cartprod_closed ext.cmult_rel_0 ext.cmult_rel_1
  ext.cmult_rel_closed ext.comp_closed ext.composition_abs
  ext.cons_abs ext.cons_closed ext.converse_abs ext.converse_closed
  ext.csquare_lam_closed ext.csquare_rel_closed ext.depth_closed
  ext.domain_abs ext.domain_closed ext.eclose_abs ext.eclose_closed
  ext.empty_abs ext.field_abs ext.field_closed
  ext.finite_funspace_closed ext.finite_ordinal_abs
  ext.fst_closed ext.function_abs ext.function_space_rel_closed
  ext.hd_abs ext.image_abs ext.image_closed ext.inj_rel_closed
  ext.injection_abs ext.inter_abs ext.irreflexive_abs
  ext.is_eclose_n_abs ext.is_funspace_abs
  ext.iterates_closed ext.length_closed
  ext.lepoll_rel_refl ext.limit_ordinal_abs ext.linear_rel_abs
  ext.mem_bij_abs ext.mem_eclose_abs
  ext.mem_inj_abs ext.membership_abs
  ext.nat_case_abs ext.nat_case_closed
  ext.nonempty ext.not_abs ext.not_closed
  ext.number1_abs ext.number2_abs ext.number3_abs ext.omega_abs
  ext.or_abs ext.or_closed ext.order_isomorphism_abs
  ext.ordermap_closed ext.ordertype_closed ext.ordinal_abs
  ext.pair_abs ext.pair_in_M_iff ext.powerset_abs ext.pred_closed
  ext.pred_set_abs ext.quasilist_abs ext.quasinat_abs
  ext.radd_closed ext.rall_abs ext.range_abs ext.range_closed
  ext.relation_abs ext.restrict_closed ext.restriction_abs
  ext.rex_abs ext.rmult_closed ext.rtrancl_abs ext.rtrancl_closed
  ext.rvimage_closed ext.separation_closed ext.setdiff_abs
  ext.singleton_abs ext.singleton_in_M_iff ext.snd_closed
  ext.strong_replacement_closed ext.subset_abs ext.succ_in_M_iff
  ext.successor_abs ext.successor_ordinal_abs ext.sum_abs
  ext.sum_closed ext.surj_rel_closed ext.surjection_abs ext.tl_abs
  ext.trancl_abs ext.trancl_closed ext.transitive_rel_abs
  ext.transitive_set_abs ext.typed_function_abs ext.union_abs
  ext.upair_abs ext.upair_in_M_iff ext.vimage_abs ext.vimage_closed
  ext.well_ord_abs ext.nth_closed ext.Aleph_rel_closed
  ext.csucc_rel_closed ext.Card_rel_Aleph_rel

\<comment> \<open>The following was motivated by the fact that
    @{thm [source] ext.apply_closed} did not simplify appropriately.\<close>
declare mg_sharp_simps[simp del, simplified setclass_iff, simp]

lemmas mg_sharp_intros = ext.nat_into_M ext.Aleph_rel_closed
  ext.Card_rel_Aleph_rel

declare mg_sharp_intros[rule del, simplified setclass_iff, intro]

\<comment> \<open>Kunen IV.2.31\<close>
lemma forces_below_filter:
  assumes "M[G], map(val(G),env) \<Turnstile> \<phi>" "p \<in> G"
    "arity(\<phi>) \<le> length(env)" "\<phi> \<in> formula" "env \<in> list(M)"
  shows "\<exists>q\<in>G. q \<preceq> p \<and> q \<tturnstile> \<phi> env"
proof -
  note assms
  moreover from this
  obtain r where "r \<tturnstile> \<phi> env" "r\<in>G"
    using generic truth_lemma[of \<phi> env]
    by blast
  moreover from this and \<open>p\<in>G\<close>
  obtain q where "q \<preceq> p" "q \<preceq> r" "q \<in> G" by auto
  ultimately
  show ?thesis
    using strengthening_lemma[of r \<phi> _ env] by blast
qed

subsection\<open>Preservation by ccc forcing notions\<close>

lemma ccc_fun_closed_lemma_aux:
  assumes "f_dot\<in>M" "p\<in>M" "a\<in>M" "b\<in>M"
  shows "{q \<in> \<bbbP> . q \<preceq> p \<and> (M, [q, \<bbbP>, leq, \<one>, f_dot, a\<^sup>v, b\<^sup>v] \<Turnstile> forces(\<cdot>0`1 is 2\<cdot> ))} \<in> M"
  using separation_forces[where env="[f_dot, a\<^sup>v, b\<^sup>v]" and \<phi>="\<cdot>0`1 is 2\<cdot>",simplified]
    assms G_subset_M[THEN subsetD] generic
    separation_in lam_replacement_constant lam_replacement_identity
    lam_replacement_product
    separation_conj arity_fun_apply_fm union_abs1
  by simp_all

lemma ccc_fun_closed_lemma_aux2:
  assumes "B\<in>M" "f_dot\<in>M" "p\<in>M" "a\<in>M"
  shows "(##M)(\<lambda>b\<in>B. {q \<in> \<bbbP> . q \<preceq> p \<and> (M, [q, \<bbbP>, leq, \<one>, f_dot, a\<^sup>v, b\<^sup>v] \<Turnstile> forces(\<cdot>0`1 is 2\<cdot> ))})"
proof -
  have "separation(##M, \<lambda>z. M, [snd(z), \<bbbP>, leq, \<one>, f_dot, \<tau>, fst(z)\<^sup>v] \<Turnstile> forces(\<cdot>0`1 is 2\<cdot> ))"
    if "\<tau>\<in>M" for \<tau>
  proof -
    let ?f_fm="snd_fm(1,0)"
    let ?g_fm="hcomp_fm(check_fm(6),fst_fm,2,0)"
    note assms
    moreover
    have "arity(forces(\<cdot>0`1 is 2\<cdot> )) \<le> 7"
      using arity_fun_apply_fm union_abs1 arity_forces[of "\<cdot>0`1 is 2\<cdot> "]
      by simp
    moreover
    have "?f_fm \<in> formula" "arity(?f_fm) \<le> 7" "?g_fm \<in> formula" "arity(?g_fm) \<le> 8"
      using ord_simp_union
      unfolding hcomp_fm_def
      by (simp_all add:arity)
    ultimately
    show ?thesis
      using separation_sat_after_function assms that sats_fst_fm
        snd_abs sats_snd_fm sats_check_fm check_abs fst_abs
      unfolding hcomp_fm_def
      by simp
  qed
  with assms
  show ?thesis
    using lam_replacement_imp_lam_closed separation_conj separation_in
      lam_replacement_product lam_replacement_constant transitivity[of _ B]
      lam_replacement_snd lam_replacement_Collect' ccc_fun_closed_lemma_aux
    by simp
qed

lemma ccc_fun_closed_lemma:
  assumes "A\<in>M" "B\<in>M" "f_dot\<in>M" "p\<in>M"
  shows "(\<lambda>a\<in>A. {b\<in>B. \<exists>q\<in>\<bbbP>. q \<preceq> p \<and> (q \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, a\<^sup>v, b\<^sup>v])}) \<in> M"
proof -
  have "separation(##M, \<lambda>z. M, [snd(z), \<bbbP>, leq, \<one>, f_dot, fst(fst(z))\<^sup>v, snd(fst(z))\<^sup>v] \<Turnstile> forces(\<cdot>0`1 is 2\<cdot> ))"
  proof -
    let ?f_fm="snd_fm(1,0)"
    let ?g="\<lambda>z . fst(fst(fst(z)))\<^sup>v"
    let ?g_fm="hcomp_fm(check_fm(6),hcomp_fm(fst_fm,fst_fm),2,0)"
    let ?h_fm="hcomp_fm(check_fm(7),hcomp_fm(snd_fm,fst_fm),3,0)"
    note assms
    moreover
    have "arity(forces(\<cdot>0`1 is 2\<cdot> )) \<le> 7"
      using arity_fun_apply_fm union_abs1 arity_forces[of "\<cdot>0`1 is 2\<cdot> "]
      by simp
    moreover
    have "?f_fm \<in> formula" "arity(?f_fm) \<le> 6" "?g_fm \<in> formula" "arity(?g_fm) \<le> 7"
      "?h_fm \<in> formula" "arity(?h_fm) \<le> 8"
      using ord_simp_union
      unfolding hcomp_fm_def
      by (simp_all add:arity)
    ultimately
    show ?thesis
      using separation_sat_after_function3 assms sats_check_fm check_abs
        fst_abs snd_abs
      unfolding hcomp_fm_def
      by simp
  qed
  moreover
  have 1:"separation(##M, \<lambda>z. M, [snd(z), \<bbbP>, leq, \<one>, f_dot, \<tau>, fst(z)\<^sup>v] \<Turnstile> forces(\<cdot>0`1 is 2\<cdot> ))"
    if "\<tau>\<in>M" for \<tau>
  proof -
    let ?f_fm="snd_fm(1,0)"
    let ?g_fm="hcomp_fm(check_fm(6),fst_fm,2,0)"
    note assms
    moreover
    have "arity(forces(\<cdot>0`1 is 2\<cdot> )) \<le> 7"
      using arity_forces[of "\<cdot>0`1 is 2\<cdot> "] arity_fun_apply_fm union_abs1
      by simp
    moreover
    have "?f_fm \<in> formula" "arity(?f_fm) \<le> 7" "?g_fm \<in> formula" "arity(?g_fm) \<le> 8"
      using ord_simp_union
      unfolding hcomp_fm_def
      by (simp_all add:arity)
    ultimately
    show ?thesis
      using separation_sat_after_function that fst_abs snd_abs sats_check_fm check_abs
      unfolding hcomp_fm_def
      by simp
  qed
  moreover note assms
  ultimately
  show ?thesis
    using lam_replacement_imp_lam_closed lam_replacement_Collect' transitivity[of _ A]
      lam_replacement_constant lam_replacement_identity lam_replacement_snd
      lam_replacement_product separation_conj separation_in separation_bex separation_iff'
    by simp
qed

\<comment> \<open>Kunen IV.3.5\<close>
lemma ccc_fun_approximation_lemma:
  notes le_trans[trans]
  assumes "ccc\<^bsup>M\<^esup>(\<bbbP>,leq)" "A\<in>M" "B\<in>M" "f\<in>M[G]" "f : A \<rightarrow> B"
  shows
    "\<exists>F\<in>M. F : A \<rightarrow> Pow\<^bsup>M\<^esup>(B) \<and> (\<forall>a\<in>A. f`a \<in> F`a \<and> |F`a|\<^bsup>M\<^esup> \<le> \<omega>)"
proof -
  from \<open>f\<in>M[G]\<close>
  obtain f_dot where "f = val(G,f_dot)" "f_dot\<in>M" using GenExtD by force
  with assms
  obtain p where "p \<tturnstile> \<cdot>0:1\<rightarrow>2\<cdot> [f_dot, A\<^sup>v, B\<^sup>v]" "p\<in>G" "p\<in>M"
    using G_subset_M truth_lemma[of "\<cdot>0:1\<rightarrow>2\<cdot>" "[f_dot, A\<^sup>v, B\<^sup>v]"]
    by (auto simp add:ord_simp_union arity_typed_function_fm
        \<comment> \<open>NOTE: type-checking is not performed here by the Simplifier\<close>
        typed_function_type)
  define F where "F\<equiv>\<lambda>a\<in>A. {b\<in>B. \<exists>q\<in>\<bbbP>. q \<preceq> p \<and> (q \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, a\<^sup>v, b\<^sup>v])}"
  from assms \<open>f_dot\<in>_\<close> \<open>p\<in>M\<close>
  have "F \<in> M"
    unfolding F_def using ccc_fun_closed_lemma by simp
  moreover from calculation
  have "f`a \<in> F`a" if "a \<in> A" for a
  proof -
    note \<open>f: A \<rightarrow> B\<close> \<open>a \<in> A\<close>
    moreover from this
    have "f ` a \<in> B" by simp
    moreover
    note \<open>f\<in>M[G]\<close> \<open>A\<in>M\<close>
    moreover from calculation
    have "M[G], [f, a, f`a] \<Turnstile> \<cdot>0`1 is 2\<cdot>"
      by (auto dest:transitivity)
    moreover
    note \<open>B\<in>M\<close> \<open>f = val(G,f_dot)\<close>
    moreover from calculation
    have "a\<in>M" "val(G, f_dot)`a\<in>M"
      by (auto dest:transitivity)
    moreover
    note \<open>f_dot\<in>M\<close> \<open>p\<in>G\<close>
    ultimately
    obtain q where "q \<preceq> p" "q \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, a\<^sup>v, (f`a)\<^sup>v]" "q\<in>G"
      using forces_below_filter[of "\<cdot>0`1 is 2\<cdot>" "[f_dot, a\<^sup>v, (f`a)\<^sup>v]" p]
      by (auto simp add: ord_simp_union arity_fun_apply_fm
          fun_apply_type)
    with \<open>f`a \<in> B\<close>
    have "f`a \<in> {b\<in>B . \<exists>q\<in>\<bbbP>. q \<preceq> p \<and> q \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, a\<^sup>v, b\<^sup>v]}"
      by blast
    with \<open>a\<in>A\<close>
    show ?thesis unfolding F_def by simp
  qed
  moreover
  have "|F`a|\<^bsup>M\<^esup> \<le> \<omega> \<and> F`a\<in>M" if "a \<in> A" for a
  proof -
    let ?Q="\<lambda>b. {q\<in>\<bbbP>. q \<preceq> p \<and> (q \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, a\<^sup>v, b\<^sup>v])}"
    from \<open>F \<in> M\<close> \<open>a\<in>A\<close> \<open>A\<in>M\<close>
    have "F`a \<in> M" "a\<in>M"
      using transitivity[OF _ \<open>A\<in>M\<close>] by simp_all
    moreover
    have 2:"\<And>x. x\<in>F`a \<Longrightarrow> x\<in>M"
      using transitivity[OF _ \<open>F`a\<in>M\<close>] by simp
    moreover
    have 3:"\<And>x. x\<in>F`a \<Longrightarrow> (##M)(?Q(x))"
      using ccc_fun_closed_lemma_aux[OF \<open>f_dot\<in>M\<close> \<open>p\<in>M\<close> \<open>a\<in>M\<close> 2] transitivity[of _ "F`a"]
      by simp
    moreover
    have 4:"lam_replacement(##M,\<lambda>b. {q \<in> \<bbbP> . q \<preceq> p \<and> (M, [q, \<bbbP>, leq, \<one>, f_dot, a\<^sup>v, b\<^sup>v] \<Turnstile> forces(\<cdot>0`1 is 2\<cdot> ))})"
      using ccc_fun_closed_lemma_aux2[OF _ \<open>f_dot\<in>M\<close> \<open>p\<in>M\<close> \<open>a\<in>M\<close>]
        lam_replacement_iff_lam_closed[THEN iffD2]
        ccc_fun_closed_lemma_aux[OF  \<open>f_dot\<in>M\<close> \<open>p\<in>M\<close> \<open>a\<in>M\<close>]
      by simp
    ultimately
    interpret M_Pi_assumptions_choice "##M" "F`a" ?Q
      using Pi_replacement1[OF _ 3] lam_replacement_Sigfun[OF 4]
        lam_replacement_imp_strong_replacement
        ccc_fun_closed_lemma_aux[OF \<open>f_dot\<in>M\<close> \<open>p\<in>M\<close> \<open>a\<in>M\<close>]
        lam_replacement_hcomp2[OF lam_replacement_constant 4 _ _
          lam_replacement_minimum,unfolded lam_replacement_def]
      by unfold_locales simp_all
    from \<open>F`a \<in> M\<close>
    interpret M_Pi_assumptions2 "##M" "F`a" ?Q "\<lambda>_ . \<bbbP>"
      using lam_replacement_imp_strong_replacement[OF
          lam_replacement_Sigfun[OF lam_replacement_constant]]
        Pi_replacement1 transitivity[of _ "F`a"]
      by unfold_locales simp_all
    from \<open>p \<tturnstile> \<cdot>0:1\<rightarrow>2\<cdot> [f_dot, A\<^sup>v, B\<^sup>v]\<close> \<open>a\<in>A\<close>
    have "\<exists>y. y \<in> ?Q(b)" if "b \<in> F`a" for b
      using that unfolding F_def by auto
    then
    obtain q where "q \<in> Pi\<^bsup>M\<^esup>(F`a,?Q)" "q\<in>M" using AC_Pi_rel by auto
    moreover
    note \<open>F`a \<in> M\<close>
    moreover from calculation
    have "q : F`a \<rightarrow>\<^bsup>M\<^esup> \<bbbP>"
      using Pi_rel_weaken_type def_function_space_rel by auto
    moreover from calculation
    have "q : F`a \<rightarrow> range(q)" "q : F`a \<rightarrow> \<bbbP>" "q : F`a \<rightarrow>\<^bsup>M\<^esup> range(q)"
      using mem_function_space_rel_abs range_of_fun by simp_all
    moreover
    have "q`b \<bottom> q`c" if "b \<in> F`a" "c \<in> F`a" "b \<noteq> c"
      \<comment> \<open>For the next step, if the premise \<^term>\<open>b \<noteq> c\<close> is first,
        the proof breaks down badly\<close>
      for b c
    proof -
      from \<open>b \<in> F`a\<close> \<open>c \<in> F`a\<close> \<open>q \<in> Pi\<^bsup>M\<^esup>(F`a,?Q)\<close> \<open>q\<in>M\<close>
      have "q`b \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, a\<^sup>v, b\<^sup>v]"
        "q`c \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, a\<^sup>v, c\<^sup>v]"
        using mem_Pi_rel_abs[of q] apply_type[of _ _  ?Q]
        by simp_all
      with \<open>b \<noteq> c\<close> \<open>q : F`a \<rightarrow> \<bbbP>\<close> \<open>a\<in>A\<close> \<open>b\<in>_\<close> \<open>c\<in>_\<close>
        \<open>A\<in>M\<close> \<open>f_dot\<in>M\<close> \<open>F`a\<in>M\<close>
      show ?thesis
        using forces_neq_apply_imp_incompatible
          transitivity[of _ A] transitivity[of _ "F`a"]
        by auto
    qed
    moreover from calculation
    have "antichain(\<bbbP>,leq,range(q))"
      using Pi_range_eq[of _  _ "\<lambda>_ . \<bbbP>"]
      unfolding antichain_def compat_in_def by auto
    moreover from this and \<open>q\<in>M\<close>
    have "antichain\<^bsup>M\<^esup>(\<bbbP>,leq,range(q))"
      by (simp add:absolut del:P_in_M)
    moreover from calculation
    have "q`b \<noteq> q`c" if "b \<noteq> c" "b \<in> F`a" "c \<in> F`a" for b c
      using that Incompatible_imp_not_eq apply_type
        mem_function_space_rel_abs by simp
    ultimately
    have "q \<in> inj\<^bsup>M\<^esup>(F`a,range(q))"
      using def_inj_rel by auto
    with \<open>F`a \<in> M\<close> \<open>q\<in>M\<close>
    have "|F`a|\<^bsup>M\<^esup> \<le> |range(q)|\<^bsup>M\<^esup>"
      using def_lepoll_rel
      by (rule_tac lepoll_rel_imp_cardinal_rel_le) auto
    also from \<open>antichain\<^bsup>M\<^esup>(\<bbbP>,leq,range(q))\<close> \<open>ccc\<^bsup>M\<^esup>(\<bbbP>,leq)\<close> \<open>q\<in>M\<close>
    have "|range(q)|\<^bsup>M\<^esup> \<le> \<omega>"
      using def_ccc_rel by simp
    finally
    show ?thesis using \<open>F`a\<in>M\<close> by auto
  qed
  moreover from this
  have "F`a\<in>M" if "a\<in>A" for a
    using that by simp
  moreover from this \<open>B\<in>M\<close>
  have "F : A \<rightarrow> Pow\<^bsup>M\<^esup>(B)"
    using Pow_rel_char
    unfolding F_def by (rule_tac lam_type) auto
  ultimately
  show ?thesis by auto
qed

end \<comment> \<open>G\_generic1\_lemmas bundle\<close>

end \<comment> \<open>\<^locale>\<open>G_generic3_AC\<close>\<close>

end


(*  Title:      HOL/Proofs/Lambda/StrongNorm.thy
    Author:     Stefan Berghofer
    Copyright   2000 TU Muenchen
*)

section {* Strong normalization for simply-typed lambda calculus *}

theory StrongNorm imports LambdaType InductTermi begin

text {*
Formalization by Stefan Berghofer. Partly based on a paper proof by
Felix Joachimski and Ralph Matthes @{cite "Matthes-Joachimski-AML"}.
*}

subsection {* Properties of @{text IT} *}

lemma lift_IT [intro!]: "IT t \<Longrightarrow> IT (lift t i)"
  apply (induct arbitrary: i set: IT)
    apply (simp (no_asm))
    apply (rule conjI)
     apply
      (rule impI,
       rule IT.Var,
       erule listsp.induct,
       simp (no_asm),
       simp (no_asm),
       rule listsp.Cons,
       blast,
       assumption)+
     apply auto
   done

lemma lifts_IT: "listsp IT ts \<Longrightarrow> listsp IT (map (\<lambda>t. lift t 0) ts)"
  by (induct ts) auto

lemma subst_Var_IT: "IT r \<Longrightarrow> IT (r[Var i/j])"
  apply (induct arbitrary: i j set: IT)
    txt {* Case @{term Var}: *}
    apply (simp (no_asm) add: subst_Var)
    apply
    ((rule conjI impI)+,
      rule IT.Var,
      erule listsp.induct,
      simp (no_asm),
      simp (no_asm),
      rule listsp.Cons,
      fast,
      assumption)+
   txt {* Case @{term Lambda}: *}
   apply atomize
   apply simp
   apply (rule IT.Lambda)
   apply fast
  txt {* Case @{term Beta}: *}
  apply atomize
  apply (simp (no_asm_use) add: subst_subst [symmetric])
  apply (rule IT.Beta)
   apply auto
  done

lemma Var_IT: "IT (Var n)"
  apply (subgoal_tac "IT (Var n \<degree>\<degree> [])")
   apply simp
  apply (rule IT.Var)
  apply (rule listsp.Nil)
  done

lemma app_Var_IT: "IT t \<Longrightarrow> IT (t \<degree> Var i)"
  apply (induct set: IT)
    apply (subst app_last)
    apply (rule IT.Var)
    apply simp
    apply (rule listsp.Cons)
     apply (rule Var_IT)
    apply (rule listsp.Nil)
   apply (rule IT.Beta [where ?ss = "[]", unfolded foldl_Nil [THEN eq_reflection]])
    apply (erule subst_Var_IT)
   apply (rule Var_IT)
  apply (subst app_last)
  apply (rule IT.Beta)
   apply (subst app_last [symmetric])
   apply assumption
  apply assumption
  done

subsection {* Well-typed substitution preserves termination *}

lemma subst_type_IT:
  "\<And>t e T u i. IT t \<Longrightarrow> e\<langle>i:U\<rangle> \<turnstile> t : T \<Longrightarrow>
    IT u \<Longrightarrow> e \<turnstile> u : U \<Longrightarrow> IT (t[u/i])"
  (is "PROP ?P U" is "\<And>t e T u i. _ \<Longrightarrow> PROP ?Q t e T u i U")
proof (induct U)
  fix T t
  assume MI1: "\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> PROP ?P T1"
  assume MI2: "\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> PROP ?P T2"
  assume "IT t"
  thus "\<And>e T' u i. PROP ?Q t e T' u i T"
  proof induct
    fix e T' u i
    assume uIT: "IT u"
    assume uT: "e \<turnstile> u : T"
    {
      case (Var rs n e1 T'1 u1 i1)
      assume nT: "e\<langle>i:T\<rangle> \<turnstile> Var n \<degree>\<degree> rs : T'"
      let ?ty = "\<lambda>t. \<exists>T'. e\<langle>i:T\<rangle> \<turnstile> t : T'"
      let ?R = "\<lambda>t. \<forall>e T' u i.
        e\<langle>i:T\<rangle> \<turnstile> t : T' \<longrightarrow> IT u \<longrightarrow> e \<turnstile> u : T \<longrightarrow> IT (t[u/i])"
      show "IT ((Var n \<degree>\<degree> rs)[u/i])"
      proof (cases "n = i")
        case True
        show ?thesis
        proof (cases rs)
          case Nil
          with uIT True show ?thesis by simp
        next
          case (Cons a as)
          with nT have "e\<langle>i:T\<rangle> \<turnstile> Var n \<degree> a \<degree>\<degree> as : T'" by simp
          then obtain Ts
              where headT: "e\<langle>i:T\<rangle> \<turnstile> Var n \<degree> a : Ts \<Rrightarrow> T'"
              and argsT: "e\<langle>i:T\<rangle> \<tturnstile> as : Ts"
            by (rule list_app_typeE)
          from headT obtain T''
              where varT: "e\<langle>i:T\<rangle> \<turnstile> Var n : T'' \<Rightarrow> Ts \<Rrightarrow> T'"
              and argT: "e\<langle>i:T\<rangle> \<turnstile> a : T''"
            by cases simp_all
          from varT True have T: "T = T'' \<Rightarrow> Ts \<Rrightarrow> T'"
            by cases auto
          with uT have uT': "e \<turnstile> u : T'' \<Rightarrow> Ts \<Rrightarrow> T'" by simp
          from T have "IT ((Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0)
            (map (\<lambda>t. t[u/i]) as))[(u \<degree> a[u/i])/0])"
          proof (rule MI2)
            from T have "IT ((lift u 0 \<degree> Var 0)[a[u/i]/0])"
            proof (rule MI1)
              have "IT (lift u 0)" by (rule lift_IT [OF uIT])
              thus "IT (lift u 0 \<degree> Var 0)" by (rule app_Var_IT)
              show "e\<langle>0:T''\<rangle> \<turnstile> lift u 0 \<degree> Var 0 : Ts \<Rrightarrow> T'"
              proof (rule typing.App)
                show "e\<langle>0:T''\<rangle> \<turnstile> lift u 0 : T'' \<Rightarrow> Ts \<Rrightarrow> T'"
                  by (rule lift_type) (rule uT')
                show "e\<langle>0:T''\<rangle> \<turnstile> Var 0 : T''"
                  by (rule typing.Var) simp
              qed
              from Var have "?R a" by cases (simp_all add: Cons)
              with argT uIT uT show "IT (a[u/i])" by simp
              from argT uT show "e \<turnstile> a[u/i] : T''"
                by (rule subst_lemma) simp
            qed
            thus "IT (u \<degree> a[u/i])" by simp
            from Var have "listsp ?R as"
              by cases (simp_all add: Cons)
            moreover from argsT have "listsp ?ty as"
              by (rule lists_typings)
            ultimately have "listsp (\<lambda>t. ?R t \<and> ?ty t) as"
              by simp
            hence "listsp IT (map (\<lambda>t. lift t 0) (map (\<lambda>t. t[u/i]) as))"
              (is "listsp IT (?ls as)")
            proof induct
              case Nil
              show ?case by fastforce
            next
              case (Cons b bs)
              hence I: "?R b" by simp
              from Cons obtain U where "e\<langle>i:T\<rangle> \<turnstile> b : U" by fast
              with uT uIT I have "IT (b[u/i])" by simp
              hence "IT (lift (b[u/i]) 0)" by (rule lift_IT)
              hence "listsp IT (lift (b[u/i]) 0 # ?ls bs)"
                by (rule listsp.Cons) (rule Cons)
              thus ?case by simp
            qed
            thus "IT (Var 0 \<degree>\<degree> ?ls as)" by (rule IT.Var)
            have "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<turnstile> Var 0 : Ts \<Rrightarrow> T'"
              by (rule typing.Var) simp
            moreover from uT argsT have "e \<tturnstile> map (\<lambda>t. t[u/i]) as : Ts"
              by (rule substs_lemma)
            hence "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<tturnstile> ?ls as : Ts"
              by (rule lift_types)
            ultimately show "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<turnstile> Var 0 \<degree>\<degree> ?ls as : T'"
              by (rule list_app_typeI)
            from argT uT have "e \<turnstile> a[u/i] : T''"
              by (rule subst_lemma) (rule refl)
            with uT' show "e \<turnstile> u \<degree> a[u/i] : Ts \<Rrightarrow> T'"
              by (rule typing.App)
          qed
          with Cons True show ?thesis
            by (simp add: comp_def)
        qed
      next
        case False
        from Var have "listsp ?R rs" by simp
        moreover from nT obtain Ts where "e\<langle>i:T\<rangle> \<tturnstile> rs : Ts"
          by (rule list_app_typeE)
        hence "listsp ?ty rs" by (rule lists_typings)
        ultimately have "listsp (\<lambda>t. ?R t \<and> ?ty t) rs"
          by simp
        hence "listsp IT (map (\<lambda>x. x[u/i]) rs)"
        proof induct
          case Nil
          show ?case by fastforce
        next
          case (Cons a as)
          hence I: "?R a" by simp
          from Cons obtain U where "e\<langle>i:T\<rangle> \<turnstile> a : U" by fast
          with uT uIT I have "IT (a[u/i])" by simp
          hence "listsp IT (a[u/i] # map (\<lambda>t. t[u/i]) as)"
            by (rule listsp.Cons) (rule Cons)
          thus ?case by simp
        qed
        with False show ?thesis by (auto simp add: subst_Var)
      qed
    next
      case (Lambda r e1 T'1 u1 i1)
      assume "e\<langle>i:T\<rangle> \<turnstile> Abs r : T'"
        and "\<And>e T' u i. PROP ?Q r e T' u i T"
      with uIT uT show "IT (Abs r[u/i])"
        by fastforce
    next
      case (Beta r a as e1 T'1 u1 i1)
      assume T: "e\<langle>i:T\<rangle> \<turnstile> Abs r \<degree> a \<degree>\<degree> as : T'"
      assume SI1: "\<And>e T' u i. PROP ?Q (r[a/0] \<degree>\<degree> as) e T' u i T"
      assume SI2: "\<And>e T' u i. PROP ?Q a e T' u i T"
      have "IT (Abs (r[lift u 0/Suc i]) \<degree> a[u/i] \<degree>\<degree> map (\<lambda>t. t[u/i]) as)"
      proof (rule IT.Beta)
        have "Abs r \<degree> a \<degree>\<degree> as \<rightarrow>\<^sub>\<beta> r[a/0] \<degree>\<degree> as"
          by (rule apps_preserves_beta) (rule beta.beta)
        with T have "e\<langle>i:T\<rangle> \<turnstile> r[a/0] \<degree>\<degree> as : T'"
          by (rule subject_reduction)
        hence "IT ((r[a/0] \<degree>\<degree> as)[u/i])"
          using uIT uT by (rule SI1)
        thus "IT (r[lift u 0/Suc i][a[u/i]/0] \<degree>\<degree> map (\<lambda>t. t[u/i]) as)"
          by (simp del: subst_map add: subst_subst subst_map [symmetric])
        from T obtain U where "e\<langle>i:T\<rangle> \<turnstile> Abs r \<degree> a : U"
          by (rule list_app_typeE) fast
        then obtain T'' where "e\<langle>i:T\<rangle> \<turnstile> a : T''" by cases simp_all
        thus "IT (a[u/i])" using uIT uT by (rule SI2)
      qed
      thus "IT ((Abs r \<degree> a \<degree>\<degree> as)[u/i])" by simp
    }
  qed
qed

subsection {* Well-typed terms are strongly normalizing *}

lemma type_implies_IT:
  assumes "e \<turnstile> t : T"
  shows "IT t"
  using assms
proof induct
  case Var
  show ?case by (rule Var_IT)
next
  case Abs
  show ?case by (rule IT.Lambda) (rule Abs)
next
  case (App e s T U t)
  have "IT ((Var 0 \<degree> lift t 0)[s/0])"
  proof (rule subst_type_IT)
    have "IT (lift t 0)" using `IT t` by (rule lift_IT)
    hence "listsp IT [lift t 0]" by (rule listsp.Cons) (rule listsp.Nil)
    hence "IT (Var 0 \<degree>\<degree> [lift t 0])" by (rule IT.Var)
    also have "Var 0 \<degree>\<degree> [lift t 0] = Var 0 \<degree> lift t 0" by simp
    finally show "IT \<dots>" .
    have "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> Var 0 : T \<Rightarrow> U"
      by (rule typing.Var) simp
    moreover have "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> lift t 0 : T"
      by (rule lift_type) (rule App.hyps)
    ultimately show "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> Var 0 \<degree> lift t 0 : U"
      by (rule typing.App)
    show "IT s" by fact
    show "e \<turnstile> s : T \<Rightarrow> U" by fact
  qed
  thus ?case by simp
qed

theorem type_implies_termi: "e \<turnstile> t : T \<Longrightarrow> termip beta t"
proof -
  assume "e \<turnstile> t : T"
  hence "IT t" by (rule type_implies_IT)
  thus ?thesis by (rule IT_implies_termi)
qed

end


(*<*)
theory CT_Proofs
imports Three_Step_MRU "../HO_Transition_System" Heard_Of.Majorities "../Quorums" CT_Defs
begin
(*>*)

subsection \<open>Proofs\<close>
type_synonym ct_TS_state = "(nat \<times> (process \<Rightarrow> (val pstate)))"

definition CT_TS ::
  "(round \<Rightarrow> process HO)
  \<Rightarrow> (round \<Rightarrow> process HO)
  \<Rightarrow> (round \<Rightarrow> process \<Rightarrow> process)
  \<Rightarrow> ct_TS_state TS"
where
  "CT_TS HOs SHOs crds = CHO_to_TS CT_Alg HOs SHOs crds"

lemmas CT_TS_defs = CT_TS_def CHO_to_TS_def CT_Alg_def CHOinitConfig_def
  CT_initState_def

definition CT_trans_step where
  "CT_trans_step HOs SHOs crds nxt_f snd_f stp \<equiv> \<Union>r \<mu>.
    {((r, cfg), (Suc r, cfg'))|cfg cfg'. three_step r = stp  \<and> (\<forall>p.
      \<mu> p \<in> get_msgs (snd_f r) cfg (HOs r) (SHOs r) p
      \<and> nxt_f r p (cfg p) (\<mu> p) (crds r p) (cfg' p)
    )}"

lemma three_step_less_D:
  "0 < three_step r \<Longrightarrow> three_step r = 1 \<or> three_step r = 2"
  by(unfold three_step_def, arith)

lemma CT_trans:
  "CSHO_trans_alt CT_sendMsg CT_nextState HOs SHOs crds =
  CT_trans_step HOs SHOs crds next0 send0 0
  \<union> CT_trans_step HOs SHOs crds next1 send1 1
  \<union> CT_trans_step HOs SHOs crds next2 send2 2
  "
proof(rule equalityI)
  show "CSHO_trans_alt CT_sendMsg CT_nextState HOs SHOs crds
    \<subseteq> CT_trans_step HOs SHOs crds next0 send0 0 \<union>
       CT_trans_step HOs SHOs crds next1 send1 1 \<union>
       CT_trans_step HOs SHOs crds next2 send2 2"
  by(force simp add: CSHO_trans_alt_def CT_sendMsg_def CT_nextState_def
    CT_trans_step_def K_def dest!: three_step_less_D)
next
  show "CT_trans_step HOs SHOs crds next0 send0 0 \<union>
    CT_trans_step HOs SHOs crds next1 send1 1 \<union>
    CT_trans_step HOs SHOs crds next2 send2 2
    \<subseteq> CSHO_trans_alt CT_sendMsg CT_nextState HOs SHOs crds"
  by(force simp add: CSHO_trans_alt_def CT_sendMsg_def CT_nextState_def
    CT_trans_step_def K_def)
qed

type_synonym rHO = "nat \<Rightarrow> process HO"

subsubsection \<open>Refinement\<close>
(******************************************************************************)

definition ct_ref_rel :: "(three_step_mru_state \<times> ct_TS_state)set" where
  "ct_ref_rel = {(sa, (r, sc)).
    opt_mru_state.next_round sa = r
    \<and> opt_mru_state.decisions sa = pstate.decide o sc
    \<and> opt_mru_state.mru_vote sa = pstate.mru_vote o sc
    \<and> (three_step r = Suc 0 \<longrightarrow> three_step_mru_state.candidates sa = {commt (sc (coord r))})
  }"

text \<open>Now we need to use the fact that SHOs = HOs (i.e. the setting is non-Byzantine), and
  also the fact that the coordinator receives enough messages in each round\<close>

lemma mru_vote_evolution0:
  "\<forall>p. next0 r p (s p) (msgs p) (crd p) (s' p) \<Longrightarrow> mru_vote o s' = mru_vote o s"
  apply(rule_tac[!] ext, rename_tac x, erule_tac[!] x=x in allE)
  by(auto simp add: next0_def next2_def Let_def)

lemma mru_vote_evolution2:
  "\<forall>p. next2 r p (s p) (msgs p) (crd p) (s' p) \<Longrightarrow> mru_vote o s' = mru_vote o s"
  apply(rule_tac[!] ext, rename_tac x, erule_tac[!] x=x in allE)
  by(auto simp add: next0_def next2_def Let_def)

lemma decide_evolution:
  "\<forall>p. next0 r p (s p) (msgs p) (crd p) (s' p) \<Longrightarrow> decide o s = decide o s'"
  "\<forall>p. next1 r p (s p) (msgs p) (crd p) (s' p) \<Longrightarrow> decide o s = decide o s'"
  apply(rule_tac[!] ext, rename_tac x, erule_tac[!] x=x in allE)
  by(auto simp add: next0_def next1_def Let_def)

lemma msgs_mru_vote:
  assumes
  "\<mu> (coord r) \<in> get_msgs (send0 r) cfg (HOs r) (HOs r) (coord r)" (is "\<mu> ?p \<in> _")
  shows "((msgs_to_lvs (\<mu> ?p)) |` HOs r ?p) = (mru_vote o cfg) |` HOs r ?p" using assms
  by(auto simp add: get_msgs_benign send0_def restrict_map_def msgs_to_lvs_def
      mru_vote_to_msg_def map_comp_def intro!: ext split: option.split)

context
  fixes
    HOs :: "nat \<Rightarrow> process \<Rightarrow> process set"
    and crds :: "nat \<Rightarrow> process \<Rightarrow>process"
  assumes
    per_rd: "\<forall>r. CT_commPerRd r (HOs r) (crds r)"
begin

lemma step0_ref:
  "{ct_ref_rel}
    (\<Union>r C. majorities.opt_mru_step0 r C),
    CT_trans_step HOs HOs crds next0 send0 0 {> ct_ref_rel}"
proof(clarsimp simp add: PO_rhoare_defs CT_trans_step_def all_conj_distrib)
  fix r sa sc sc' \<mu>
  assume R: "(sa, (r, sc)) \<in> ct_ref_rel"
    and r: "three_step r = 0"
    and \<mu>: "\<forall>p. \<mu> p \<in> get_msgs (send0 r) sc (HOs r) (HOs r) p"
        and nxt: "\<forall>p. next0 r p (sc p) (\<mu> p) (crds r p) (sc' p)"
  note \<mu>nxt = \<mu> nxt
  have r_phase_step: "nr_steps * three_phase r = r" using r three_phase_step[of r]
    by(auto)
  from r have same_coord: "coord (Suc r) = coord r"
    by(auto simp add: three_step_phase_Suc intro: coord_phase)
  define cand where "cand = commt (sc' (coord (Suc r)))"
  define C where "C = {cand}"
  have guard: "\<forall>cand\<in>C. \<exists>Q. majorities.opt_mru_guard (mru_vote \<circ> sc) Q cand"
  proof(simp add: C_def)
    let ?Q = "HOs r (coord r)"
    let ?lvs0 = "mru_vote o sc"
    have "?Q \<in> majs" using per_rd \<mu>nxt[THEN spec, where x="coord r"]
      per_rd[simplified CT_commPerRd_def, rule_format, OF r]
      by(auto simp add: Let_def majs_def next0_def same_coord get_msgs_dom r_phase_step)
    moreover have
      "map_option snd (option_Max_by fst (ran (?lvs |` ?Q))) \<in> {None, Some cand}"
      using nxt[THEN spec, where x="coord r"]
      msgs_mru_vote[where HOs=HOs and \<mu>=\<mu>, OF \<mu>[THEN spec, where x="coord r"]]
      get_msgs_dom[OF \<mu>[THEN spec, of "coord r"]]
      by(auto simp add: next0_def Let_def cand_def same_coord split: option.split_asm)
    ultimately have "majorities.opt_mru_guard ?lvs0 ?Q cand"
      by(auto simp add: majorities.opt_mru_guard_def Let_def majorities.opt_mru_vote_def)
    thus "\<exists>Q. majorities.opt_mru_guard ?lvs0 Q cand"
      by blast
  qed

  define sa' where "sa' = sa\<lparr>
      next_round := Suc r,
      candidates := C
    \<rparr>"
  have "(sa, sa') \<in> majorities.opt_mru_step0 r C" using R r nxt guard
    by(auto simp add: majorities.opt_mru_step0_def sa'_def ct_ref_rel_def)
  moreover have "(sa', (Suc r, sc')) \<in> ct_ref_rel" using R nxt
    apply(auto simp add: sa'_def ct_ref_rel_def intro!:
      mru_vote_evolution0[OF nxt, symmetric] decide_evolution(1)[OF nxt])
       apply(auto simp add: Let_def C_def cand_def o_def intro!: ext)
    done
  ultimately show
    "\<exists>sa'. (\<exists>r C. (sa, sa') \<in> majorities.opt_mru_step0 r C)
        \<and> (sa', Suc r, sc') \<in> ct_ref_rel"
    by blast
qed

lemma step1_ref:
  "{ct_ref_rel}
    (\<Union>r S v. majorities.opt_mru_step1 r S v),
    CT_trans_step HOs HOs crds next1 send1 (Suc 0) {> ct_ref_rel}"
proof(clarsimp  simp add: PO_rhoare_defs CT_trans_step_def all_conj_distrib)
  fix r sa sc sc' \<mu>
  assume R: "(sa, (r, sc)) \<in> ct_ref_rel"
    and r: "three_step r = Suc 0"
    and \<mu>: "\<forall>p. \<mu> p \<in> get_msgs (send1 r) sc (HOs r) (HOs r) p"
        and nxt: "\<forall>p. next1 r p (sc p) (\<mu> p) (crds r p) (sc' p)"
  note \<mu>nxt = \<mu> nxt

  define v where "v = commt (sc (coord r))"
  define S where "S = {p. coord r \<in> HOs r p}"
  define sa' where "sa' = sa\<lparr> next_round := Suc r,
    opt_mru_state.mru_vote := opt_mru_state.mru_vote sa ++ const_map (three_phase r, v) S
  \<rparr>"
  have "(sa, sa') \<in> majorities.opt_mru_step1 r S v" using r R
    by(clarsimp simp add: majorities.opt_mru_step1_def sa'_def  S_def v_def
      ct_ref_rel_def)
  moreover have "(sa', (Suc r, sc')) \<in> ct_ref_rel" using r R
  proof-
    have "mru_vote o sc' = ((mru_vote \<circ> sc) ++ const_map (three_phase r, v) S)"
    proof(rule ext, simp)
      fix p
      show "mru_vote (sc' p) = ((mru_vote \<circ> sc) ++ const_map (three_phase r, v) S) p"
        using \<mu>nxt[THEN spec, of p]
        by(auto simp add: get_msgs_benign next1_def send1_def S_def v_def map_add_def
          const_map_is_None const_map_is_Some restrict_map_def isVote_def split: option.split)
    qed
    thus ?thesis using R r nxt
      by(force simp add: ct_ref_rel_def sa'_def three_step_Suc intro: decide_evolution)
  qed
  ultimately show
    "\<exists>sa'. (\<exists>r S v. (sa, sa') \<in> majorities.opt_mru_step1 r S v)
        \<and> (sa', Suc r, sc') \<in> ct_ref_rel"
    by blast
qed

  define dec_f
    where "dec_f p = (if decide (sc' p) \<noteq> decide (sc p) then decide (sc' p) else None)" for p

  have dec_f: "(decide \<circ> sc) ++ dec_f = decide \<circ> sc'"
  proof
    fix p
    show "((decide \<circ> sc) ++ dec_f) p = (decide \<circ> sc') p" using nxt[THEN spec, of p]
      by(auto simp add: map_add_def dec_f_def next2_def split: option.split intro!: ext)
  qed

  define sa' where "sa' = sa\<lparr>
    next_round := Suc r,
    decisions := decisions sa ++ dec_f
  \<rparr>"

  have "(sa', (Suc r, sc')) \<in> ct_ref_rel" using R r nxt
    by(auto simp add: ct_ref_rel_def sa'_def dec_f three_step_Suc
      mru_vote_evolution2[OF nxt])
  moreover have "(sa, sa') \<in> majorities.opt_mru_step2 r dec_f" using r R
  proof-
    define sc_r_votes where "sc_r_votes p = (if (\<exists>v. mru_vote (sc p) = Some (three_phase r, v))
        then map_option snd (mru_vote (sc p))
        else None)" for p
    have sc_r_votes: "sc_r_votes = majorities.r_votes sa r" using R r
      by(auto simp add: ct_ref_rel_def sc_r_votes_def majorities.r_votes_def intro!: ext)
    have "majorities.step2_d_guard dec_f sc_r_votes"
    proof(clarsimp simp add: majorities.step2_d_guard_def)
      fix p v
      assume d_f_p: "dec_f p = Some v"
      let ?Qv = "votes_rcvd (\<mu> p)"
      have Qv: "card ?Qv > N div 2"
        "v = the_rcvd_vote (\<mu> p)" using nxt[THEN spec, of p] d_f_p
        by(auto simp add: next2_def dec_f_def)

      hence "v \<in> snd ` votes_rcvd (\<mu> p)"
        by(fastforce simp add: the_rcvd_vote_def ex_in_conv[symmetric]
          dest!: card_gt_0_iff[THEN iffD1, OF le_less_trans[OF le0]] elim!: imageI intro: someI)
      moreover have "?Qv = map_graph (sc_r_votes) \<inter> (HOs r p \<times> UNIV)" using \<mu>[THEN spec, of p]
        by(auto simp add: get_msgs_benign send2_def restrict_map_def votes_rcvd_def
          sc_r_votes_def image_def split: option.split_asm)
      ultimately show "v \<in> ran sc_r_votes \<and> dom sc_r_votes \<in> majs" using Qv(1)
        by(auto simp add: majs_def inj_on_def map_graph_def fun_graph_def sc_r_votes_def
          the_rcvd_vote_def majs_def intro: ranI
          elim!: less_le_trans intro!: card_inj_on_le[where f=fst])
    qed

    thus ?thesis using r R
      by(auto simp add: majorities.opt_mru_step2_def sa'_def ct_ref_rel_def sc_r_votes)
  qed

  ultimately show
    "\<exists>sa'. (\<exists>r dec_f. (sa, sa') \<in> majorities.opt_mru_step2 r dec_f)
        \<and> (sa', Suc r, sc') \<in> ct_ref_rel"
    by blast

qed

lemma CT_Refines_ThreeStep_MRU:
  "PO_refines ct_ref_rel majorities.ts_mru_TS (CT_TS HOs HOs crds)"
proof(rule refine_basic)
  show "init (CT_TS HOs HOs crds) \<subseteq> ct_ref_rel `` init majorities.ts_mru_TS"
    by(auto simp add: CT_TS_defs majorities.ts_mru_TS_defs ct_ref_rel_def)
next
  show
    "{ct_ref_rel} TS.trans majorities.ts_mru_TS,
      TS.trans (CT_TS HOs HOs crds) {> ct_ref_rel}"
    apply(simp add: majorities.ts_mru_TS_defs CT_TS_defs)
    apply(auto simp add: CHO_trans_alt CT_trans intro!: step0_ref step1_ref step2_ref)
    done
qed

end (* HO context *)

subsubsection \<open>Termination\<close>
(******************************************************************************)

theorem CT_termination:
  assumes run: "CHORun CT_Alg rho HOs crds"
      and commR: "\<forall>r. CHOcommPerRd CT_M r (HOs r) (crds r)"
      and commG: "CHOcommGlobal CT_M HOs crds"
  shows "\<exists>r v. decide (rho r p) = Some v"
proof -
  from commG commR obtain ph c where
    HOs:
       "coord (nr_steps*ph) = c
         \<and> (\<forall>p. c \<in> HOs (nr_steps*ph+1) p)
         \<and> (\<forall>p. card (HOs (nr_steps*ph+2) p) > N div 2)"
    by(auto simp add: CT_CHOMachine_def CT_commGlobal_def CT_commPerRd_def three_step_def)

  \<comment> \<open>The tedious bit: obtain three consecutive rounds linked by send/next functions\<close>
  define r0 where "r0 = nr_steps * ph"
  define cfg0 where "cfg0 = rho r0"
  define r1 where "r1 = Suc r0"
  define cfg1 where "cfg1 = rho r1"
  define r2 where "r2 = Suc r1"
  define cfg2 where "cfg2 = rho r2"
  define cfg3 where "cfg3 = rho (Suc r2)"

  from
    run[simplified CHORun_def, THEN CSHORun_step, THEN spec, where x="r0"]
    run[simplified CHORun_def, THEN CSHORun_step, THEN spec, where x="r1"]
    run[simplified CHORun_def, THEN CSHORun_step, THEN spec, where x="r2"]
    obtain \<mu>0 \<mu>1 \<mu>2 where
    send0: "\<forall>p. \<mu>0 p \<in> get_msgs (send0 r0) cfg0 (HOs r0) (HOs r0) p"
    and three_step0: "\<forall>p. next0 r0 p (cfg0 p) (\<mu>0 p) (crds (Suc r0) p) (cfg1 p)"
    and send1: "\<forall>p. \<mu>1 p \<in> get_msgs (send1 r1) cfg1 (HOs r1) (HOs r1) p"
    and three_step1: "\<forall>p. next1 r1 p (cfg1 p) (\<mu>1 p) (crds (Suc r1) p) (cfg2 p)"
    and send2: "\<forall>p. \<mu>2 p \<in> get_msgs (send2 r2) cfg2 (HOs r2) (HOs r2) p"
    and three_step2: "\<forall>p. next2 r2 p (cfg2 p) (\<mu>2 p) (crds (Suc r2) p) (cfg3 p)"
    apply(auto simp add: CT_Alg_def three_step_def CT_nextState_def CT_sendMsg_def all_conj_distrib
      r0_def r1_def r2_def
      cfg0_def cfg1_def cfg2_def cfg3_def mod_Suc
      )
    done

  \<comment> \<open>The proof: the coordinator hears enough messages in r0 and thus selects a value.\<close>

  obtain dec_v where dec_v: "commt (cfg1 c) = dec_v"
    by simp

  have step_r0: "three_step r0 = 0"
    by(auto simp add: r0_def three_step_def)
  hence same_coord:
    "coord r1 = coord r0"
    "coord r2 = coord r0"
    by(auto simp add: three_step_phase_Suc r2_def r1_def r0_def intro!: coord_phase)

  \<comment> \<open>All processes hear from the coordinator, and thus set their vote to @{term dec_v}.\<close>
  hence all_vote: "\<forall>p. mru_vote (cfg2 p) = Some (three_phase r2, dec_v)"
    using HOs three_step1 send1 step_r0 dec_v
    by(auto simp add: next1_def Let_def get_msgs_benign send1_def restrict_map_def isVote_def
      r2_def r1_def r0_def[symmetric] same_coord[simplified r2_def r1_def] three_step_phase_Suc)

  \<comment> \<open>And finally, everybody will also decide @{term dec_v}.\<close>
  have all_decide: "\<forall>p. decide (cfg3 p) = Some dec_v"
  proof
    fix p
    have "votes_rcvd (\<mu>2 p) = HOs r2 p \<times> {dec_v}" using send2[THEN spec, where x=p] all_vote
      by(auto simp add: send2_def get_msgs_benign votes_rcvd_def restrict_map_def image_def o_def)

    moreover from HOs have "N div 2 < card (HOs r2 p)"
      by(auto simp add: r2_def r1_def r0_def)

    moreover then have "HOs r2 p \<noteq> {}"
      by (metis card_empty less_nat_zero_code)
    ultimately show "decide (cfg3 p) = Some dec_v"
    using three_step2[THEN spec, where x=p] send2[THEN spec, where x=p] all_vote
      by(auto simp add: next2_def send2_def Let_def get_msgs_benign
        the_rcvd_vote_def restrict_map_def image_def o_def)
  qed

  thus ?thesis
    by(auto simp add: cfg3_def)

qed

end


(*
 * Lazy lists.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

(*<*)
theory LList
imports
  HOLCF
  Nats
begin
(*>*)

section\<open>The fully-lazy list type.\<close>

text\<open>The list can contain anything that is a predomain.\<close>

default_sort predomain

domain 'a llist =
    lnil ("lnil")
  | lcons (lazy "'a") (lazy "'a llist") (infixr ":@" 65)

(*<*)
(* Why aren't these in the library? *)

lemma llist_map_eval_simps[simp]:
  "llist_map\<cdot>f\<cdot>\<bottom> = \<bottom>"
  "llist_map\<cdot>f\<cdot>lnil = lnil"
  "llist_map\<cdot>f\<cdot>(x :@ xs) = f\<cdot>x :@ llist_map\<cdot>f\<cdot>xs"
    apply (subst llist_map_unfold)
    apply simp
   apply (subst llist_map_unfold)
   apply (simp add: lnil_def)
  apply (subst llist_map_unfold)
  apply (simp add: lcons_def)
  done
(*>*)

lemma llist_case_distr_strict:
  "f\<cdot>\<bottom> = \<bottom> \<Longrightarrow> f\<cdot>(llist_case\<cdot>g\<cdot>h\<cdot>xxs) = llist_case\<cdot>(f\<cdot>g)\<cdot>(\<Lambda> x xs. f\<cdot>(h\<cdot>x\<cdot>xs))\<cdot>xxs"
  by (cases xxs) simp_all

fixrec lsingleton :: "('a::predomain) \<rightarrow> 'a llist"
where
  "lsingleton\<cdot>x = x :@ lnil"

fixrec lappend :: "'a llist \<rightarrow> 'a llist \<rightarrow> 'a llist"
where
  "lappend\<cdot>lnil\<cdot>ys = ys"
| "lappend\<cdot>(x :@ xs)\<cdot>ys = x :@ (lappend\<cdot>xs\<cdot>ys)"

abbreviation
  lappend_syn :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist" (infixr ":++" 65) where
  "xs :++ ys \<equiv> lappend\<cdot>xs\<cdot>ys"

lemma lappend_strict': "lappend\<cdot>\<bottom> = (\<Lambda> a. \<bottom>)"
  by fixrec_simp

text\<open>This gives us that @{thm lappend_strict'}.\<close>

text \<open>This is where we use @{thm inst_cfun_pcpo}\<close>
lemma lappend_strict[simp]: "lappend\<cdot>\<bottom> = \<bottom>"
  by (rule cfun_eqI) (simp add: lappend_strict')

lemma lappend_assoc: "(xs :++ ys) :++ zs = xs :++ (ys :++ zs)"
  by (induct xs, simp_all)

lemma lappend_lnil_id_left[simp]: "lappend\<cdot>lnil = ID"
  by (rule cfun_eqI) simp

lemma lappend_lnil_id_right[simp]: "xs :++ lnil = xs"
  by (induct xs) simp_all

fixrec lconcat :: "'a llist llist \<rightarrow> 'a llist"
where
  "lconcat\<cdot>lnil = lnil"
| "lconcat\<cdot>(x :@ xs) = x :++ lconcat\<cdot>xs"

lemma lconcat_strict[simp]: "lconcat\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

fixrec lall :: "('a \<rightarrow> tr) \<rightarrow> 'a llist \<rightarrow> tr"
where
  "lall\<cdot>p\<cdot>lnil = TT"
| "lall\<cdot>p\<cdot>(x :@ xs) = (p\<cdot>x andalso lall\<cdot>p\<cdot>xs)"

lemma lall_strict[simp]: "lall\<cdot>p\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

fixrec lfilter :: "('a \<rightarrow> tr) \<rightarrow> 'a llist \<rightarrow> 'a llist"
where
  "lfilter\<cdot>p\<cdot>lnil = lnil"
| "lfilter\<cdot>p\<cdot>(x :@ xs) = If p\<cdot>x then x :@ lfilter\<cdot>p\<cdot>xs else lfilter\<cdot>p\<cdot>xs"

lemma lfilter_strict[simp]: "lfilter\<cdot>p\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

lemma lfilter_const_true: "lfilter\<cdot>(\<Lambda> x. TT)\<cdot>xs = xs"
  by (induct xs, simp_all)

lemma lfilter_lnil: "(lfilter\<cdot>p\<cdot>xs = lnil) = (lall\<cdot>(neg oo p)\<cdot>xs = TT)"
proof(induct xs)
  fix a l assume indhyp: "(lfilter\<cdot>p\<cdot>l = lnil) = (lall\<cdot>(Tr.neg oo p)\<cdot>l = TT)"
  thus "(lfilter\<cdot>p\<cdot>(a :@ l) = lnil) = (lall\<cdot>(Tr.neg oo p)\<cdot>(a :@ l) = TT)"
    by (cases "p\<cdot>a" rule: trE, simp_all)
qed simp_all

lemma filter_filter: "lfilter\<cdot>p\<cdot>(lfilter\<cdot>q\<cdot>xs) = lfilter\<cdot>(\<Lambda> x. q\<cdot>x andalso p\<cdot>x)\<cdot>xs"
proof(induct xs)
  fix a l assume "lfilter\<cdot>p\<cdot>(lfilter\<cdot>q\<cdot>l) = lfilter\<cdot>(\<Lambda>(x::'a). q\<cdot>x andalso p\<cdot>x)\<cdot>l"
  thus "lfilter\<cdot>p\<cdot>(lfilter\<cdot>q\<cdot>(a :@ l)) = lfilter\<cdot>(\<Lambda>(x::'a). q\<cdot>x andalso p\<cdot>x)\<cdot>(a :@ l)"
    by (cases "q\<cdot>a" rule: trE, simp_all)
qed simp_all

fixrec ldropWhile :: "('a \<rightarrow> tr) \<rightarrow> 'a llist \<rightarrow> 'a llist"
where
  "ldropWhile\<cdot>p\<cdot>lnil = lnil"
| "ldropWhile\<cdot>p\<cdot>(x :@ xs) = If p\<cdot>x then ldropWhile\<cdot>p\<cdot>xs else x :@ xs"

lemma ldropWhile_strict[simp]: "ldropWhile\<cdot>p\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

lemma ldropWhile_lnil: "(ldropWhile\<cdot>p\<cdot>xs = lnil) = (lall\<cdot>p\<cdot>xs = TT)"
proof(induct xs)
  fix a l assume "(ldropWhile\<cdot>p\<cdot>l = lnil) = (lall\<cdot>p\<cdot>l = TT)"
  thus "(ldropWhile\<cdot>p\<cdot>(a :@ l) = lnil) = (lall\<cdot>p\<cdot>(a :@ l) = TT)"
    by (cases "p\<cdot>a" rule: trE, simp_all)
qed simp_all

fixrec literate :: "('a \<rightarrow> 'a) \<rightarrow> 'a \<rightarrow> 'a llist"
where
  "literate\<cdot>f\<cdot>x = x :@ literate\<cdot>f\<cdot>(f\<cdot>x)"

declare literate.simps[simp del]

text\<open>This order of tests is convenient for the nub proof. I can
imagine the other would be convenient for other proofs...\<close>

fixrec lmember :: "('a \<rightarrow> 'a \<rightarrow> tr) \<rightarrow> 'a \<rightarrow> 'a llist \<rightarrow> tr"
where
  "lmember\<cdot>eq\<cdot>x\<cdot>lnil = FF"
| "lmember\<cdot>eq\<cdot>x\<cdot>(lcons\<cdot>y\<cdot>ys) = (lmember\<cdot>eq\<cdot>x\<cdot>ys orelse eq\<cdot>y\<cdot>x)"

lemma lmember_strict[simp]: "lmember\<cdot>eq\<cdot>x\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

fixrec llength :: "'a llist \<rightarrow> Nat"
where
  "llength\<cdot>lnil = 0"
| "llength\<cdot>(lcons\<cdot>x\<cdot>xs) = 1 + llength\<cdot>xs"

lemma llength_strict[simp]: "llength\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

fixrec lmap :: "('a \<rightarrow> 'b) \<rightarrow> 'a llist \<rightarrow> 'b llist"
where
  "lmap\<cdot>f\<cdot>lnil = lnil"
| "lmap\<cdot>f\<cdot>(x :@ xs) = f\<cdot>x :@ lmap\<cdot>f\<cdot>xs"

lemma lmap_strict[simp]: "lmap\<cdot>f\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

lemma lmap_lmap:
  "lmap\<cdot>f\<cdot>(lmap\<cdot>g\<cdot>xs) = lmap\<cdot>(f oo g)\<cdot>xs"
  by (induct xs) simp_all

text \<open>The traditional list monad uses lconcatMap as its bind.\<close>

definition
  "lconcatMap \<equiv> (\<Lambda> f. lconcat oo lmap\<cdot>f)"

lemma lconcatMap_comp_simps[simp]:
  "lconcatMap\<cdot>f\<cdot>\<bottom> = \<bottom>"
  "lconcatMap\<cdot>f\<cdot>lnil = lnil"
  "lconcatMap\<cdot>f\<cdot>(x :@ xs) = f\<cdot>x :++ lconcatMap\<cdot>f\<cdot>xs"
  by (simp_all add: lconcatMap_def)

lemma lconcatMap_lsingleton[simp]:
  "lconcatMap\<cdot>lsingleton\<cdot>x = x"
  by (induct x) (simp_all add: lconcatMap_def)

text\<open>This @{term "zipWith"} function is only fully defined if the
lists have the same length.\<close>

fixrec lzipWith0 :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> 'a llist \<rightarrow> 'b llist \<rightarrow> 'c llist"
where
  "lzipWith0\<cdot>f\<cdot>(a :@ as)\<cdot>(b :@ bs) = f\<cdot>a\<cdot>b :@ lzipWith0\<cdot>f\<cdot>as\<cdot>bs"
| "lzipWith0\<cdot>f\<cdot>lnil\<cdot>lnil = lnil"

lemma lzipWith0_stricts [simp]:
  "lzipWith0\<cdot>f\<cdot>\<bottom>\<cdot>ys = \<bottom>"
  "lzipWith0\<cdot>f\<cdot>lnil\<cdot>\<bottom> = \<bottom>"
  "lzipWith0\<cdot>f\<cdot>(x :@ xs)\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp+

lemma lzipWith0_undefs [simp]:
  "lzipWith0\<cdot>f\<cdot>lnil\<cdot>(y :@ ys) = \<bottom>"
  "lzipWith0\<cdot>f\<cdot>(x :@ xs)\<cdot>lnil = \<bottom>"
  by fixrec_simp+

text\<open>This @{term "zipWith"} function follows Haskell's in being more
permissive: zipping uneven lists results in a list as long as the
shortest one. This is what the backtracking monad expects.\<close>

fixrec lzipWith :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> 'a llist \<rightarrow> 'b llist \<rightarrow> 'c llist"
where
  "lzipWith\<cdot>f\<cdot>(a :@ as)\<cdot>(b :@ bs) = f\<cdot>a\<cdot>b :@ lzipWith\<cdot>f\<cdot>as\<cdot>bs"
| (unchecked) "lzipWith\<cdot>f\<cdot>xs\<cdot>ys = lnil"

lemma lzipWith_simps [simp]:
  "lzipWith\<cdot>f\<cdot>(x :@ xs)\<cdot>(y :@ ys) = f\<cdot>x\<cdot>y :@ lzipWith\<cdot>f\<cdot>xs\<cdot>ys"
  "lzipWith\<cdot>f\<cdot>(x :@ xs)\<cdot>lnil = lnil"
  "lzipWith\<cdot>f\<cdot>lnil\<cdot>(y :@ ys) = lnil"
  "lzipWith\<cdot>f\<cdot>lnil\<cdot>lnil = lnil"
  by fixrec_simp+

lemma lzipWith_stricts [simp]:
  "lzipWith\<cdot>f\<cdot>\<bottom>\<cdot>ys = \<bottom>"
  "lzipWith\<cdot>f\<cdot>(x :@ xs)\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp+

text\<open>Homomorphism properties, see Bird's life's work.\<close>

lemma lmap_lappend_dist:
  "lmap\<cdot>f\<cdot>(xs :++ ys) = lmap\<cdot>f\<cdot>xs :++ lmap\<cdot>f\<cdot>ys"
  by (induct xs) simp_all

lemma lconcat_lappend_dist:
  "lconcat\<cdot>(xs :++ ys) = lconcat\<cdot>xs :++ lconcat\<cdot>ys"
  by (induct xs) (simp_all add: lappend_assoc)

lemma lconcatMap_assoc:
  "lconcatMap\<cdot>h\<cdot>(lconcatMap\<cdot>g\<cdot>f) = lconcatMap\<cdot>(\<Lambda> v. lconcatMap\<cdot>h\<cdot>(g\<cdot>v))\<cdot>f"
  by (induct f) (simp_all add: lmap_lappend_dist lconcat_lappend_dist lconcatMap_def)

lemma lconcatMap_lappend_dist:
  "lconcatMap\<cdot>f\<cdot>(xs :++ ys) = lconcatMap\<cdot>f\<cdot>xs :++ lconcatMap\<cdot>f\<cdot>ys"
  unfolding lconcatMap_def by (simp add: lconcat_lappend_dist lmap_lappend_dist)

(* The following avoid some case_tackery. *)

lemma lmap_not_bottoms[simp]:
  "x \<noteq> \<bottom> \<Longrightarrow> lmap\<cdot>f\<cdot>x \<noteq> \<bottom>"
  by (cases x) simp_all

lemma lsingleton_not_bottom[simp]:
  "lsingleton\<cdot>x \<noteq> \<bottom>"
  by simp

lemma lappend_not_bottom[simp]:
  "\<lbrakk> xs \<noteq> \<bottom>; xs = lnil \<Longrightarrow> ys \<noteq> \<bottom> \<rbrakk> \<Longrightarrow> xs :++ ys \<noteq> \<bottom>"
  apply (cases xs)
  apply simp_all
  done

default_sort "domain"

(*<*)
end
(*>*)


section \<open>Refined Code Generation for Test Suites\<close>

text \<open>This theory provides alternative code equations for selected functions on test suites.
      Currently only Mapping via RBT is supported.\<close>

theory Test_Suite_Representations_Refined
imports Test_Suite_Representations "../Prefix_Tree_Refined" "../Util_Refined"
begin

declare [[code drop: Test_Suite_Representations.test_suite_from_io_tree]]

lemma test_suite_from_io_tree_refined[code] :
  fixes M :: "('a,'b :: ccompare, 'c :: ccompare) fsm"
    and m :: "(('b\<times>'c), ('b\<times>'c) prefix_tree) mapping_rbt"
  shows "test_suite_from_io_tree M q (MPT (RBT_Mapping m))
          = (case ID CCOMPARE(('b \<times> 'c)) of
              None \<Rightarrow> Code.abort (STR ''test_suite_from_io_tree RBT_set: ccompare = None'') (\<lambda>_ . test_suite_from_io_tree M q (MPT (RBT_Mapping m))) |
              Some _ \<Rightarrow> MPT (Mapping.tabulate (map (\<lambda>((x,y),t) . ((x,y),h_obs M q x y \<noteq> None)) (RBT_Mapping2.entries m)) (\<lambda> ((x,y),b) . case h_obs M q x y of None \<Rightarrow> Prefix_Tree.empty | Some q' \<Rightarrow> test_suite_from_io_tree M q' (case RBT_Mapping2.lookup m (x,y) of Some t' \<Rightarrow> t'))))"
proof (cases "ID CCOMPARE(('b \<times> 'c))")
  case None
  then show ?thesis by auto
next
  case (Some a)
  then have "ID CCOMPARE(('b \<times> 'c)) \<noteq> None"
    using Some by auto

  have "distinct (map fst (RBT_Mapping2.entries m))"
    apply transfer
    using linorder.distinct_entries[OF ID_ccompare[OF Some]]
          ord.is_rbt_rbt_sorted
          Some
    by auto

  have "\<And> a b . (RBT_Mapping2.lookup m a = Some b) = ((a,b) \<in> List.set (RBT_Mapping2.entries m))"
    using map_of_entries[OF \<open>ID CCOMPARE(('b \<times> 'c)) \<noteq> None\<close>, of m]
    using map_of_eq_Some_iff[OF \<open>distinct (map fst (RBT_Mapping2.entries m))\<close>] by auto

  let ?f2 = "Mapping.tabulate (map (\<lambda>((x,y),t) . ((x,y),h_obs M q x y \<noteq> None)) (RBT_Mapping2.entries m)) (\<lambda> ((x,y),b) . case h_obs M q x y of None \<Rightarrow> Prefix_Tree.empty | Some q' \<Rightarrow> test_suite_from_io_tree M q' (case RBT_Mapping2.lookup m (x,y) of Some t' \<Rightarrow> t'))"
  let ?f1 = "\<lambda> xs . \<lambda> ((x,y),b) . case map_of xs (x,y) of
    None \<Rightarrow> None |
    Some t \<Rightarrow> (case h_obs M q x y of
      None \<Rightarrow> (if b then None else Some empty) |
      Some q' \<Rightarrow> (if b then Some (test_suite_from_io_tree M q' t) else None))"

  have "Mapping.lookup ?f2 = ?f1 (RBT_Mapping2.entries m)"
  proof
    fix k
    show "Mapping.lookup ?f2 k = ?f1 (RBT_Mapping2.entries m) k"
    proof -
      obtain x y b where "k = ((x,y),b)"
        by (metis prod.exhaust_sel)

      show ?thesis proof (cases "RBT_Mapping2.lookup m (x,y)")
        case None

        then have "((x,y),b) \<notin> List.set (map (\<lambda>((x,y),t) . ((x,y),h_obs M q x y \<noteq> None)) (RBT_Mapping2.entries m))"
          using \<open>\<And> a b . (RBT_Mapping2.lookup m a = Some b) = ((a,b) \<in> List.set (RBT_Mapping2.entries m))\<close>[of "(x,y)"]
          by auto
        then have "Mapping.lookup ?f2 ((x,y),b) = None"
          by (metis (mono_tags, lifting) Mapping.lookup.rep_eq map_of_map_Pair_key tabulate.rep_eq)
        moreover have "?f1 (RBT_Mapping2.entries m) ((x,y),b) = None"
          using \<open>\<And> a b . (RBT_Mapping2.lookup m a = Some b) = ((a,b) \<in> List.set (RBT_Mapping2.entries m))\<close>[of "(x,y)"]
                None
          by (metis (no_types, lifting) map_of_SomeD not_None_eq old.prod.case option.simps(4))
        ultimately show ?thesis
          unfolding \<open>k = ((x,y),b)\<close> by simp
      next
        case (Some t')
        then have "((x,y),t') \<in> List.set (RBT_Mapping2.entries m)"
          using \<open>\<And> a b . (RBT_Mapping2.lookup m a = Some b) = ((a,b) \<in> List.set (RBT_Mapping2.entries m))\<close> by auto

        show ?thesis proof (cases "h_obs M q x y")
          case None

          show ?thesis proof (cases b)
            case True

            then have "((x,y),b) \<notin> List.set (map (\<lambda>((x,y),t) . ((x,y),h_obs M q x y \<noteq> None)) (RBT_Mapping2.entries m))"
              using None by auto
            then have "Mapping.lookup ?f2 ((x,y),b) = None"
              by (metis (mono_tags, lifting) Mapping.lookup.rep_eq map_of_map_Pair_key tabulate.rep_eq)
            moreover have "?f1 (RBT_Mapping2.entries m) ((x,y),b) = None"
              using Some None True
              using \<open>((x, y), t') \<in> list.set (RBT_Mapping2.entries m)\<close> \<open>distinct (map fst (RBT_Mapping2.entries m))\<close>
              by auto
            ultimately show ?thesis
              unfolding \<open>k = ((x,y),b)\<close> by simp
          next
            case False

            then have "((x,y),b) \<in> List.set (map (\<lambda>((x,y),t) . ((x,y),h_obs M q x y \<noteq> None)) (RBT_Mapping2.entries m))"
              using None \<open>((x,y),t') \<in> List.set (RBT_Mapping2.entries m)\<close> by force
            then have "Mapping.lookup ?f2 ((x,y),b) = Some empty"
            proof -
              have "\<And>p ps f. (p::('b \<times> 'c) \<times> bool) \<notin> list.set ps \<or> Mapping.lookup (Mapping.tabulate ps f) p = Some (f p::(('b \<times> 'c) \<times> bool) prefix_tree)"
                by (simp add: Mapping.lookup.rep_eq map_of_map_Pair_key tabulate.rep_eq)
              then show ?thesis
                using None \<open>((x, y), b) \<in> list.set (map (\<lambda>((x, y), t). ((x, y), h_obs M q x y \<noteq> None)) (RBT_Mapping2.entries m))\<close> by auto
            qed
            moreover have "?f1 (RBT_Mapping2.entries m) ((x,y),b) = Some empty"
              using Some None False
              using \<open>((x, y), t') \<in> list.set (RBT_Mapping2.entries m)\<close>
              using \<open>distinct (map fst (RBT_Mapping2.entries m))\<close> by auto
            ultimately show ?thesis
              unfolding \<open>k = ((x,y),b)\<close> by simp
          qed
        next
          case (Some q')
          show ?thesis proof (cases b)
            case True
            then have "((x,y),b) \<in> List.set (map (\<lambda>((x,y),t) . ((x,y),h_obs M q x y \<noteq> None)) (RBT_Mapping2.entries m))"
              using Some \<open>((x,y),t') \<in> List.set (RBT_Mapping2.entries m)\<close> by force
            then have "Mapping.lookup ?f2 ((x,y),b) = Some (test_suite_from_io_tree M q' t')"
            proof -
              have "\<And>p ps f. (p::('b \<times> 'c) \<times> bool) \<notin> list.set ps \<or> Mapping.lookup (Mapping.tabulate ps f) p = Some (f p::(('b \<times> 'c) \<times> bool) prefix_tree)"
                by (simp add: Mapping.lookup.rep_eq map_of_map_Pair_key tabulate.rep_eq)
              then show ?thesis
                using Some \<open>RBT_Mapping2.lookup m (x, y) = Some t'\<close> \<open>((x, y), b) \<in> list.set (map (\<lambda>((x, y), t). ((x, y), h_obs M q x y \<noteq> None)) (RBT_Mapping2.entries m))\<close> by auto
            qed
            moreover have "?f1 (RBT_Mapping2.entries m) ((x,y),b) = Some (test_suite_from_io_tree M q' t')"
              using Some \<open>RBT_Mapping2.lookup m (x, y) = Some t'\<close> True
              using \<open>((x, y), t') \<in> list.set (RBT_Mapping2.entries m)\<close>
              using \<open>distinct (map fst (RBT_Mapping2.entries m))\<close> by auto
            ultimately show ?thesis
              unfolding \<open>k = ((x,y),b)\<close> by simp
          next
            case False
            then have "((x,y),b) \<notin> List.set (map (\<lambda>((x,y),t) . ((x,y),h_obs M q x y \<noteq> None)) (RBT_Mapping2.entries m))"
              using Some by auto
            then have "Mapping.lookup ?f2 ((x,y),b) = None"
              by (metis (mono_tags, lifting) Mapping.lookup.rep_eq map_of_map_Pair_key tabulate.rep_eq)
            moreover have "?f1 (RBT_Mapping2.entries m) ((x,y),b) = None"
              using Some \<open>RBT_Mapping2.lookup m (x, y) = Some t'\<close> False
              using \<open>((x, y), t') \<in> list.set (RBT_Mapping2.entries m)\<close> \<open>distinct (map fst (RBT_Mapping2.entries m))\<close>
              by auto
            ultimately show ?thesis
              unfolding \<open>k = ((x,y),b)\<close> by simp
          qed
        qed
      qed
    qed
  qed

  obtain m' where "test_suite_from_io_tree M q (MPT (RBT_Mapping m)) = MPT m'"
    by (simp add: test_suite_from_io_tree_MPT)
  then have "test_suite_from_io_tree M q (MPT (RBT_Mapping m)) = PT (Mapping.lookup m')"
    using MPT_def by simp
  have "Mapping.lookup m' = (\<lambda> ((x,y),b) . case RBT_Mapping2.lookup m (x,y) of
    None \<Rightarrow> None |
    Some t \<Rightarrow> (case h_obs M q x y of
      None \<Rightarrow> (if b then None else Some empty) |
      Some q' \<Rightarrow> (if b then Some (test_suite_from_io_tree M q' t) else None)))"
  proof -
    have "test_suite_from_io_tree M q (PT (Mapping.lookup (RBT_Mapping m))) = PT (Mapping.lookup m')"
      by (metis MPT_def \<open>test_suite_from_io_tree M q (MPT (RBT_Mapping m)) = PT (Mapping.lookup m')\<close>)
    then have "Mapping.lookup m' = (\<lambda>((b, c), ba). case Mapping.lookup (RBT_Mapping m) (b, c) of None \<Rightarrow> None | Some p \<Rightarrow> (case h_obs M q b c of None \<Rightarrow> if ba then None else Some Prefix_Tree.empty | Some a \<Rightarrow> if ba then Some (test_suite_from_io_tree M a p) else None))"
      by auto
    then show ?thesis
      by (metis (no_types) lookup_Mapping_code(2))
  qed
  then have "Mapping.lookup m' = ?f1 (RBT_Mapping2.entries m)"
    unfolding map_of_entries[OF \<open>ID CCOMPARE(('b \<times> 'c)) \<noteq> None\<close>, of m] by simp
  then have "Mapping.lookup ?f2 = Mapping.lookup m'"
    using \<open>Mapping.lookup ?f2 = ?f1 (RBT_Mapping2.entries m)\<close> by simp
  then show ?thesis
    using Some unfolding \<open>test_suite_from_io_tree M q (MPT (RBT_Mapping m)) = MPT m'\<close>
    by (simp add: MPT_def)
qed

end


section \<open> Relational Hoare calculus \<close>

theory utp_hoare
  imports
    utp_rel_laws
    utp_theory
    utp_frame
begin

subsection \<open> Hoare Triple Definitions and Tactics \<close>

definition hoare_r :: "'\<alpha> cond \<Rightarrow> ('\<alpha>, '\<beta>) urel \<Rightarrow> '\<beta> cond \<Rightarrow> bool" ("\<lbrace>_\<rbrace>/ _/ \<lbrace>_\<rbrace>\<^sub>u") where
"\<lbrace>p\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u = ((\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>r\<rceil>\<^sub>>) \<sqsubseteq> Q)"

notation hoare_r ("\<^bold>{_\<^bold>}/ _/ \<^bold>{_\<^bold>}")

utp_lift_notation hoare_r (1)

translations "\<^bold>{b\<^bold>}P\<^bold>{c\<^bold>}" <= "\<^bold>{U(b)\<^bold>}P\<^bold>{U(c)\<^bold>}"

declare hoare_r_def [upred_defs]

named_theorems hoare and hoare_safe

method hoare_split uses hr =
  ((simp add: assigns_comp assigns_cond usubst)?, \<comment> \<open> Combine Assignments where possible \<close>
   (auto
    intro: hoare intro!: hoare_safe hr
    simp add: conj_comm conj_assoc usubst unrest))[1] \<comment> \<open> Apply Hoare logic laws \<close>

method hoare_auto uses hr = (hoare_split hr: hr; (rel_simp')?, auto?)

subsection \<open> Basic Laws \<close>

lemma hoare_meaning:
  "\<lbrace>P\<rbrace>S\<lbrace>Q\<rbrace>\<^sub>u = (\<forall> s s'. \<lbrakk>P\<rbrakk>\<^sub>e s \<and> \<lbrakk>S\<rbrakk>\<^sub>e (s, s') \<longrightarrow> \<lbrakk>Q\<rbrakk>\<^sub>e s')"
  by (rel_auto)

lemma hoare_alt_def: "\<lbrace>b\<rbrace>P\<lbrace>c\<rbrace>\<^sub>u \<longleftrightarrow> (P ;; ?[c]) \<sqsubseteq> (?[b] ;; P)"
  by (rel_auto)

lemma hoare_assume: "\<lbrace>P\<rbrace>S\<lbrace>Q\<rbrace>\<^sub>u \<Longrightarrow> ?[P] ;; S = ?[P] ;; S ;; ?[Q]"
  by (rel_auto)

lemma hoare_pre_assume_1: "\<lbrace>b \<and> c\<rbrace>P\<lbrace>d\<rbrace>\<^sub>u = \<lbrace>c\<rbrace>?[b] ;; P\<lbrace>d\<rbrace>\<^sub>u"
  by (rel_auto)

lemma hoare_pre_assume_2: "\<lbrace>b \<and> c\<rbrace>P\<lbrace>d\<rbrace>\<^sub>u = \<lbrace>b\<rbrace>?[c] ;; P\<lbrace>d\<rbrace>\<^sub>u"
  by (rel_auto)

lemma hoare_test [hoare_safe]: "`p \<and> b \<Rightarrow> q` \<Longrightarrow> \<lbrace>p\<rbrace>?[b]\<lbrace>q\<rbrace>\<^sub>u"
  by (rel_simp)

lemma hoare_gcmd [hoare_safe]: "\<lbrace>p \<and> b\<rbrace>P\<lbrace>q\<rbrace>\<^sub>u \<Longrightarrow> \<lbrace>p\<rbrace>b \<longrightarrow>\<^sub>r P\<lbrace>q\<rbrace>\<^sub>u"
  by (rel_auto)

lemma hoare_r_conj [hoare_safe]: "\<lbrakk> \<lbrace>p\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u; \<lbrace>p\<rbrace>Q\<lbrace>s\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>Q\<lbrace>r \<and> s\<rbrace>\<^sub>u"
  by rel_auto

lemma hoare_r_weaken_pre [hoare]:
  "\<lbrace>p\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u \<Longrightarrow> \<lbrace>p \<and> q\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u"
  "\<lbrace>q\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u \<Longrightarrow> \<lbrace>p \<and> q\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u"
  by rel_auto+

lemma hoare_r_conseq: "\<lbrakk> \<lbrace>p\<^sub>2\<rbrace>S\<lbrace>q\<^sub>2\<rbrace>\<^sub>u; `p\<^sub>1 \<Rightarrow> p\<^sub>2`; `q\<^sub>2 \<Rightarrow> q\<^sub>1` \<rbrakk> \<Longrightarrow> \<lbrace>p\<^sub>1\<rbrace>S\<lbrace>q\<^sub>1\<rbrace>\<^sub>u"
  by rel_auto

lemma hoare_r_cut:
  assumes "\<^bold>{b\<^bold>}P\<^bold>{b\<^bold>}" "\<^bold>{b \<and> c\<^bold>}P\<^bold>{c\<^bold>}"
  shows "\<^bold>{b \<and> c\<^bold>}P\<^bold>{b \<and> c\<^bold>}"
  using assms by rel_auto

lemma hoare_r_cut_simple:
  assumes "\<^bold>{b\<^bold>}P\<^bold>{b\<^bold>}" "\<^bold>{c\<^bold>}P\<^bold>{c\<^bold>}"
  shows "\<^bold>{b \<and> c\<^bold>}P\<^bold>{b \<and> c\<^bold>}"
  using assms by rel_auto

subsection \<open> Sequence Laws \<close>

lemma seq_hoare_r: "\<lbrakk> \<lbrace>p\<rbrace>Q\<^sub>1\<lbrace>s\<rbrace>\<^sub>u ; \<lbrace>s\<rbrace>Q\<^sub>2\<lbrace>r\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>Q\<^sub>1 ;; Q\<^sub>2\<lbrace>r\<rbrace>\<^sub>u"
  by rel_auto

lemma seq_hoare_invariant [hoare_safe]: "\<lbrakk> \<lbrace>p\<rbrace>Q\<^sub>1\<lbrace>p\<rbrace>\<^sub>u ; \<lbrace>p\<rbrace>Q\<^sub>2\<lbrace>p\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>Q\<^sub>1 ;; Q\<^sub>2\<lbrace>p\<rbrace>\<^sub>u"
  by rel_auto

lemma seq_hoare_stronger_pre_1 [hoare_safe]:
  "\<lbrakk> \<lbrace>p \<and> q\<rbrace>Q\<^sub>1\<lbrace>p \<and> q\<rbrace>\<^sub>u ; \<lbrace>p \<and> q\<rbrace>Q\<^sub>2\<lbrace>q\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p \<and> q\<rbrace>Q\<^sub>1 ;; Q\<^sub>2\<lbrace>q\<rbrace>\<^sub>u"
  by rel_auto

lemma seq_hoare_stronger_pre_2 [hoare_safe]:
  "\<lbrakk> \<lbrace>p \<and> q\<rbrace>Q\<^sub>1\<lbrace>p \<and> q\<rbrace>\<^sub>u ; \<lbrace>p \<and> q\<rbrace>Q\<^sub>2\<lbrace>p\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p \<and> q\<rbrace>Q\<^sub>1 ;; Q\<^sub>2\<lbrace>p\<rbrace>\<^sub>u"
  by rel_auto

lemma seq_hoare_inv_r_2 [hoare]: "\<lbrakk> \<lbrace>p\<rbrace>Q\<^sub>1\<lbrace>q\<rbrace>\<^sub>u ; \<lbrace>q\<rbrace>Q\<^sub>2\<lbrace>q\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>Q\<^sub>1 ;; Q\<^sub>2\<lbrace>q\<rbrace>\<^sub>u"
  by rel_auto

lemma seq_hoare_inv_r_3 [hoare]: "\<lbrakk> \<lbrace>p\<rbrace>Q\<^sub>1\<lbrace>p\<rbrace>\<^sub>u ; \<lbrace>p\<rbrace>Q\<^sub>2\<lbrace>q\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>Q\<^sub>1 ;; Q\<^sub>2\<lbrace>q\<rbrace>\<^sub>u"
  by rel_auto

subsection \<open> Assignment Laws \<close>

lemma assigns_hoare_r [hoare_safe]: "`p \<Rightarrow> \<sigma> \<dagger> q` \<Longrightarrow> \<lbrace>p\<rbrace>\<langle>\<sigma>\<rangle>\<^sub>a\<lbrace>q\<rbrace>\<^sub>u"
  by rel_auto

lemma assigns_backward_hoare_r:
  "\<lbrace>\<sigma> \<dagger> p\<rbrace>\<langle>\<sigma>\<rangle>\<^sub>a\<lbrace>p\<rbrace>\<^sub>u"
  by rel_auto

lemma assigns_init_hoare [hoare_safe]:
  "\<lbrakk> vwb_lens x; x \<sharp> p; x \<sharp> v; \<lbrace>&x = v \<and> p\<rbrace>S\<lbrace>q\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>x := v ;; S\<lbrace>q\<rbrace>\<^sub>u"
  by (rel_auto)

lemma assigns_init_hoare_general:
  "\<lbrakk> vwb_lens x; \<And> x\<^sub>0. \<lbrace>&x = v\<lbrakk>\<guillemotleft>x\<^sub>0\<guillemotright>/&x\<rbrakk> \<and> p\<lbrakk>\<guillemotleft>x\<^sub>0\<guillemotright>/&x\<rbrakk>\<rbrace>S\<lbrace>q\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>x := v ;; S\<lbrace>q\<rbrace>\<^sub>u"
  by (rule seq_hoare_r, rule assign_floyd_hoare_r, simp, rel_auto)

lemma assigns_final_hoare [hoare_safe]:
  "\<lbrace>p\<rbrace>S\<lbrace>\<sigma> \<dagger> q\<rbrace>\<^sub>u \<Longrightarrow> \<lbrace>p\<rbrace>S ;; \<langle>\<sigma>\<rangle>\<^sub>a\<lbrace>q\<rbrace>\<^sub>u"
  by (rel_auto)

lemma ndet_assign_hoare_r [hoare_safe]:
  "`U(p \<Rightarrow> (\<forall> v. q\<lbrakk>\<guillemotleft>v\<guillemotright>/&x\<rbrakk>))` \<Longrightarrow> \<lbrace>p\<rbrace>x := *\<lbrace>q\<rbrace>\<^sub>u"
  by (rel_auto)

lemma ndet_assign_bwd: "\<lbrace>\<forall> v. p\<lbrakk>\<guillemotleft>v\<guillemotright>/&x\<rbrakk>\<rbrace>x := *\<lbrace>p\<rbrace>\<^sub>u"
  by (rel_auto)

lemma skip_hoare_r [hoare_safe]: "\<lbrace>p\<rbrace>II\<lbrace>p\<rbrace>\<^sub>u"
  by rel_auto

lemma skip_hoare_impl_r [hoare_safe]: "`p \<Rightarrow> q` \<Longrightarrow> \<lbrace>p\<rbrace>II\<lbrace>q\<rbrace>\<^sub>u"
  by rel_auto

subsection \<open> Conditional Laws \<close>

lemma cond_hoare_r [hoare_safe]: "\<lbrakk> \<lbrace>b \<and> p\<rbrace>S\<lbrace>q\<rbrace>\<^sub>u ; \<lbrace>\<not>b \<and> p\<rbrace>T\<lbrace>q\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>S \<triangleleft> b \<triangleright>\<^sub>r T\<lbrace>q\<rbrace>\<^sub>u"
  by rel_auto

lemma cond_hoare_r_wp:
  assumes "\<lbrace>p'\<rbrace>S\<lbrace>q\<rbrace>\<^sub>u" and "\<lbrace>p''\<rbrace>T\<lbrace>q\<rbrace>\<^sub>u"
  shows "\<lbrace>(b \<and> p') \<or> (\<not>b \<and> p'')\<rbrace>S \<triangleleft> b \<triangleright>\<^sub>r T\<lbrace>q\<rbrace>\<^sub>u"
  using assms by pred_simp

lemma cond_hoare_r_sp:
  assumes \<open>\<lbrace>b \<and> p\<rbrace>S\<lbrace>q\<rbrace>\<^sub>u\<close> and \<open>\<lbrace>\<not>b \<and> p\<rbrace>T\<lbrace>s\<rbrace>\<^sub>u\<close>
  shows \<open>\<lbrace>p\<rbrace>S \<triangleleft> b \<triangleright>\<^sub>r T\<lbrace>q \<or> s\<rbrace>\<^sub>u\<close>
  using assms by pred_simp

lemma hoare_ndet [hoare_safe]:
  assumes "\<lbrace>pre\<rbrace>P\<lbrace>post\<rbrace>\<^sub>u" "\<lbrace>pre\<rbrace>Q\<lbrace>post\<rbrace>\<^sub>u"
  shows "\<lbrace>pre\<rbrace>(P \<sqinter> Q)\<lbrace>post\<rbrace>\<^sub>u"
  using assms by (rel_auto)

lemma hoare_disj [hoare_safe]:
  assumes "\<lbrace>pr\<rbrace>P\<lbrace>post\<rbrace>\<^sub>u" "\<lbrace>pr\<rbrace>Q\<lbrace>post\<rbrace>\<^sub>u"
  shows "\<lbrace>pr\<rbrace>(P \<or> Q)\<lbrace>post\<rbrace>\<^sub>u"
  using assms by (rel_auto)

lemma hoare_UINF [hoare_safe]:
  assumes "\<And> i. i \<in> A \<Longrightarrow> \<lbrace>pre\<rbrace>P(i)\<lbrace>post\<rbrace>\<^sub>u"
  shows "\<lbrace>pre\<rbrace>(\<Sqinter> i \<in> A \<bullet> P(i))\<lbrace>post\<rbrace>\<^sub>u"
  using assms by (rel_auto)

subsection \<open> Recursion Laws \<close>

lemma nu_hoare_r_partial:
  assumes induct_step:
    "\<And> st P. \<lbrace>p\<rbrace>P\<lbrace>q\<rbrace>\<^sub>u \<Longrightarrow> \<lbrace>p\<rbrace>F P\<lbrace>q\<rbrace>\<^sub>u"
  shows "\<lbrace>p\<rbrace>\<nu> F \<lbrace>q\<rbrace>\<^sub>u"
  by (meson hoare_r_def induct_step lfp_lowerbound order_refl)

lemma mu_hoare_r:
  assumes WF: "wf R"
  assumes M:"mono F"
  assumes induct_step:
    "\<And> st P. \<lbrace>p \<and> (e,\<guillemotleft>st\<guillemotright>) \<in> \<guillemotleft>R\<guillemotright>\<rbrace>P\<lbrace>q\<rbrace>\<^sub>u \<Longrightarrow> \<lbrace>p \<and> e = \<guillemotleft>st\<guillemotright>\<rbrace>F P\<lbrace>q\<rbrace>\<^sub>u"
  shows "\<lbrace>p\<rbrace>\<mu> F \<lbrace>q\<rbrace>\<^sub>u"
  unfolding hoare_r_def
proof (rule mu_rec_total_utp_rule[OF WF M , of _ e ], goal_cases)
  case (1 st)
  then show ?case
    using induct_step[unfolded hoare_r_def, of "(\<lceil>p\<rceil>\<^sub>< \<and> (\<lceil>e\<rceil>\<^sub><, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright> \<Rightarrow> \<lceil>q\<rceil>\<^sub>>)" st]
    by (simp add: alpha)
qed

lemma mu_hoare_r':
  assumes WF: "wf R"
  assumes M:"mono F"
  assumes induct_step:
    "\<And> st P. \<lbrace>p \<and> (e,\<guillemotleft>st\<guillemotright>) \<in> \<guillemotleft>R\<guillemotright>\<rbrace> P \<lbrace>q\<rbrace>\<^sub>u \<Longrightarrow> \<lbrace>p \<and> e = \<guillemotleft>st\<guillemotright>\<rbrace> F P \<lbrace>q\<rbrace>\<^sub>u"
  assumes I0: "`p' \<Rightarrow> p`"
  shows "\<lbrace>p'\<rbrace> \<mu> F \<lbrace>q\<rbrace>\<^sub>u"
  by (meson I0 M WF induct_step mu_hoare_r pre_str_hoare_r)

subsection \<open> Iteration Rules \<close>

lemma iter_hoare_r [hoare_safe]: "\<lbrace>P\<rbrace>S\<lbrace>P\<rbrace>\<^sub>u \<Longrightarrow> \<lbrace>P\<rbrace>S\<^sup>\<star>\<lbrace>P\<rbrace>\<^sub>u"
  by (rel_simp', metis (mono_tags, opaque_lifting) mem_Collect_eq rtrancl_induct)

lemma while_hoare_r [hoare_safe]:
  assumes "\<lbrace>p \<and> b\<rbrace>S\<lbrace>p\<rbrace>\<^sub>u"
  shows "\<lbrace>p\<rbrace>while b do S od\<lbrace>\<not>b \<and> p\<rbrace>\<^sub>u"
  using assms
  by (simp add: while_top_def hoare_r_def, rule_tac lfp_lowerbound) (rel_auto)

lemma while_invr_hoare_r [hoare_safe]:
  assumes "\<lbrace>p \<and> b\<rbrace>S\<lbrace>p\<rbrace>\<^sub>u" "`pre \<Rightarrow> p`" "`(\<not>b \<and> p) \<Rightarrow> post`"
  shows "\<lbrace>pre\<rbrace>while b invr p do S od\<lbrace>post\<rbrace>\<^sub>u"
  by (metis assms hoare_r_conseq while_hoare_r while_inv_def)

lemma while_r_minimal_partial:
  assumes seq_step: "`p \<Rightarrow> invar`"
  assumes induct_step: "\<lbrace>invar\<and> b\<rbrace> C \<lbrace>invar\<rbrace>\<^sub>u"
  shows "\<lbrace>p\<rbrace>while b do C od\<lbrace>\<not>b \<and> invar\<rbrace>\<^sub>u"
  using induct_step pre_str_hoare_r seq_step while_hoare_r by blast

lemma approx_chain:
  "(\<Sqinter>n::nat. \<lceil>p \<and> v <\<^sub>u \<guillemotleft>n\<guillemotright>\<rceil>\<^sub><) = \<lceil>p\<rceil>\<^sub><"
  by (rel_auto)

text \<open> Total correctness law for Hoare logic, based on constructive chains. This is limited to
  variants that have naturals numbers as their range. \<close>

lemma while_term_hoare_r:
  assumes "\<And> z::nat. \<lbrace>p \<and> b \<and> v = \<guillemotleft>z\<guillemotright>\<rbrace>S\<lbrace>p \<and> v < \<guillemotleft>z\<guillemotright>\<rbrace>\<^sub>u"
  shows "\<lbrace>p\<rbrace>while\<^sub>\<bottom> b do S od\<lbrace>\<not>b \<and> p\<rbrace>\<^sub>u"
proof -
  have "(\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>\<not> b \<and> p\<rceil>\<^sub>>) \<sqsubseteq> (\<mu> X \<bullet> S ;; X \<triangleleft> b \<triangleright>\<^sub>r II)"
  proof (rule mu_refine_intro)

    from assms show "(\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>\<not> b \<and> p\<rceil>\<^sub>>) \<sqsubseteq> S ;; (\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>\<not> b \<and> p\<rceil>\<^sub>>) \<triangleleft> b \<triangleright>\<^sub>r II"
      by (rel_auto)

    let ?E = "\<lambda> n. \<lceil>p \<and> v <\<^sub>u \<guillemotleft>n\<guillemotright>\<rceil>\<^sub><"
    show "(\<lceil>p\<rceil>\<^sub>< \<and> (\<mu> X \<bullet> S ;; X \<triangleleft> b \<triangleright>\<^sub>r II)) = (\<lceil>p\<rceil>\<^sub>< \<and> (\<nu> X \<bullet> S ;; X \<triangleleft> b \<triangleright>\<^sub>r II))"
    proof (rule constr_fp_uniq[where E="?E"])

      show "(\<Sqinter>n. ?E(n)) = \<lceil>p\<rceil>\<^sub><"
        by (rel_auto)

      show "mono (\<lambda>X. S ;; X \<triangleleft> b \<triangleright>\<^sub>r II)"
        by (simp add: cond_mono monoI seqr_mono)

      show "constr (\<lambda>X. S ;; X \<triangleleft> b \<triangleright>\<^sub>r II) ?E"
      proof (rule constrI)

        show "chain ?E"
        proof (rule chainI)
          show "\<lceil>p \<and> v <\<^sub>u \<guillemotleft>0\<guillemotright>\<rceil>\<^sub>< = false"
            by (rel_auto)
          show "\<And>i. \<lceil>p \<and> v <\<^sub>u \<guillemotleft>Suc i\<guillemotright>\<rceil>\<^sub>< \<sqsubseteq> \<lceil>p \<and> v <\<^sub>u \<guillemotleft>i\<guillemotright>\<rceil>\<^sub><"
            by (rel_auto)
        qed

        from assms
        show "\<And>X n. (S ;; X \<triangleleft> b \<triangleright>\<^sub>r II \<and> \<lceil>p \<and> v <\<^sub>u \<guillemotleft>n + 1\<guillemotright>\<rceil>\<^sub><) =
                     (S ;; (X \<and> \<lceil>p \<and> v <\<^sub>u \<guillemotleft>n\<guillemotright>\<rceil>\<^sub><) \<triangleleft> b \<triangleright>\<^sub>r II \<and> \<lceil>p \<and> v <\<^sub>u \<guillemotleft>n + 1\<guillemotright>\<rceil>\<^sub><)"
          apply (rel_auto)
          using less_antisym less_trans apply blast
          done
      qed
    qed
  qed

  thus ?thesis
    by (simp add: hoare_r_def while_bot_def)
qed

lemma while_vrt_hoare_r [hoare_safe]:
  assumes "\<And> z::nat. \<lbrace>p \<and> b \<and> v = \<guillemotleft>z\<guillemotright>\<rbrace>S\<lbrace>p \<and> v < \<guillemotleft>z\<guillemotright>\<rbrace>\<^sub>u" "`pre \<Rightarrow> p`" "`(\<not>b \<and> p) \<Rightarrow> post`"
  shows "\<lbrace>pre\<rbrace>while b invr p vrt v do S od\<lbrace>post\<rbrace>\<^sub>u"
  apply (rule hoare_r_conseq[OF _ assms(2) assms(3)])
  apply (simp add: while_vrt_def)
  apply (rule while_term_hoare_r[where v="v", OF assms(1)])
  done

text \<open> General total correctness law based on well-founded induction \<close>

lemma while_wf_hoare_r:
  assumes WF: "wf R"
  assumes I0: "`pre \<Rightarrow> p`"
  assumes induct_step:"\<And> st. \<lbrace>b \<and> p \<and> e = \<guillemotleft>st\<guillemotright>\<rbrace>Q\<lbrace>p \<and> (e, \<guillemotleft>st\<guillemotright>) \<in> \<guillemotleft>R\<guillemotright>\<rbrace>\<^sub>u"
  assumes PHI:"`(\<not>b \<and> p) \<Rightarrow> post`"
  shows "\<lbrace>pre\<rbrace>while\<^sub>\<bottom> b invr p do Q od\<lbrace>post\<rbrace>\<^sub>u"
unfolding hoare_r_def while_inv_bot_def while_bot_def
proof (rule pre_weak_rel[of _ "\<lceil>p\<rceil>\<^sub><" ])
  from I0 show "`\<lceil>pre\<rceil>\<^sub>< \<Rightarrow> \<lceil>p\<rceil>\<^sub><`"
    by rel_auto
  show "(\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>post\<rceil>\<^sub>>) \<sqsubseteq> (\<mu> X \<bullet> Q ;; X \<triangleleft> b \<triangleright>\<^sub>r II)"
  proof (rule mu_rec_total_utp_rule[where e=e, OF WF])
    show "Monotonic (\<lambda>X. Q ;; X \<triangleleft> b \<triangleright>\<^sub>r II)"
      by (simp add: closure)
    have induct_step': "\<And> st. (\<lceil>b \<and> p \<and>  e =\<^sub>u \<guillemotleft>st\<guillemotright> \<rceil>\<^sub>< \<Rightarrow> (\<lceil>p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright> \<rceil>\<^sub>> )) \<sqsubseteq> Q"
      using induct_step by rel_auto
    with PHI
    show "\<And>st. (\<lceil>p\<rceil>\<^sub>< \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st\<guillemotright> \<Rightarrow> \<lceil>post\<rceil>\<^sub>>) \<sqsubseteq> Q ;; (\<lceil>p\<rceil>\<^sub>< \<and> (\<lceil>e\<rceil>\<^sub><, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright> \<Rightarrow> \<lceil>post\<rceil>\<^sub>>) \<triangleleft> b \<triangleright>\<^sub>r II"
      by (rel_auto)
  qed
qed

subsection \<open> Frame Rules \<close>

text \<open> Frame rule: If starting $S$ in a state satisfying $p establishes q$ in the final state, then
  we can insert an invariant predicate $r$ when $S$ is framed by $a$, provided that $r$ does not
  refer to variables in the frame, and $q$ does not refer to variables outside the frame. \<close>

lemma frame_hoare_r:
  assumes "vwb_lens a" "a \<sharp> r" "a \<natural> q" "\<lbrace>p\<rbrace>P\<lbrace>q\<rbrace>\<^sub>u"
  shows "\<lbrace>p \<and> r\<rbrace>a:[P]\<lbrace>q \<and> r\<rbrace>\<^sub>u"
  using assms
  by (rel_auto, metis)

lemma frame_strong_hoare_r [hoare_safe]:
  assumes "vwb_lens a" "a \<sharp> r" "a \<natural> q" "\<lbrace>p \<and> r\<rbrace>S\<lbrace>q\<rbrace>\<^sub>u"
  shows "\<lbrace>p \<and> r\<rbrace>a:[S]\<lbrace>q \<and> r\<rbrace>\<^sub>u"
  using assms by (rel_auto, metis)

lemma frame_hoare_r' [hoare_safe]:
  assumes "vwb_lens a" "a \<sharp> r" "a \<natural> q" "\<lbrace>r \<and> p\<rbrace>S\<lbrace>q\<rbrace>\<^sub>u"
  shows "\<lbrace>r \<and> p\<rbrace>a:[S]\<lbrace>r \<and> q\<rbrace>\<^sub>u"
  using assms
  by (simp add: frame_strong_hoare_r utp_pred_laws.inf.commute)

lemma antiframe_hoare_r:
  assumes "vwb_lens a" "a \<natural> r" "a \<sharp> q" "\<lbrace>p\<rbrace>P\<lbrace>q\<rbrace>\<^sub>u"
  shows "\<lbrace>p \<and> r\<rbrace> a:\<lbrakk>P\<rbrakk> \<lbrace>q \<and> r\<rbrace>\<^sub>u"
  using assms by (rel_auto, metis)

lemma antiframe_strong_hoare_r:
  assumes "vwb_lens a" "a \<natural> r" "a \<sharp> q" "\<lbrace>p \<and> r\<rbrace>P\<lbrace>q\<rbrace>\<^sub>u"
  shows "\<lbrace>p \<and> r\<rbrace> a:\<lbrakk>P\<rbrakk> \<lbrace>q \<and> r\<rbrace>\<^sub>u"
  using assms by (rel_auto, metis)

lemma nmods_invariant:
  assumes "S nmods a" "a \<natural> p"
  shows "\<^bold>{p\<^bold>}S\<^bold>{p\<^bold>}"
  using assms by (rel_auto, metis)

lemma hoare_r_ghost:
  assumes "vwb_lens x" "x \<sharp> p" "x \<sharp> q" "S nuses x" "\<^bold>{p\<^bold>}x := e;; S\<^bold>{q\<^bold>}"
  shows "\<^bold>{p\<^bold>}S\<^bold>{q\<^bold>}"
proof -
  have "\<^bold>{p\<^bold>}x := e;; rrestr x S\<^bold>{q\<^bold>}"
    by (simp add: Healthy_if assms(4) assms(5))
  with assms(1-3) have "\<^bold>{p\<^bold>}rrestr x S\<^bold>{q\<^bold>}"
    by (rel_simp,metis mwb_lens.put_put vwb_lens_mwb)
  thus ?thesis
    by (simp add: Healthy_if assms(4))
qed

end


theory Impl_List_Playground
imports "../TopoS_Impl"
begin

text{*The executbale models and the composition theory. We can build examples here*}

abbreviation "V\<equiv>TopoS_Vertices.V"

definition testGraph :: "vString list_graph" where
  "testGraph \<equiv> \<lparr> nodesL = [V ''Master'', V ''Slave1'', V ''Slave2'', V ''other1'', V ''other2''],
                 edgesL = [(V ''Master'', V ''Slave1'')] \<rparr>"

lemma "valid_list_graph testGraph" by eval

definition req1 ::"(vString SecurityInvariant)" where
  "req1 \<equiv> new_configured_list_SecurityInvariant SINVAR_SecGwExt_impl.SINVAR_LIB_SecurityGatewayExtended \<lparr>
      node_properties = [V ''Master'' \<mapsto> SecurityGateway,
                         V ''Slave1'' \<mapsto> DomainMember,
                         V ''Slave2'' \<mapsto> DomainMember],
      model_global_properties = ()
      \<rparr>"

definition "req2 \<equiv> new_configured_list_SecurityInvariant SINVAR_NoRefl_impl.SINVAR_LIB_NoRefl \<lparr>
      node_properties = [V ''Master'' \<mapsto> Refl,
                         V ''other1'' \<mapsto> Refl,
                         V ''other2'' \<mapsto> Refl],
      model_global_properties = ()
      \<rparr>"

definition "reqs = [req1, req2]"

definition "max_network = generate_valid_topology reqs
      \<lparr>nodesL = nodesL testGraph, edgesL = List.product (nodesL testGraph) (nodesL testGraph) \<rparr>"

value "max_network"

ML{*
vizualize_graph @{context} @{term "reqs"} @{term "max_network"};
*}

end