(*  Title:       variants/a_norreqid/Aodv_Predicates.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
    Author:      Peter Höfner, NICTA
*)

section "Invariant assumptions and properties"

theory A_Aodv_Predicates
imports A_Aodv
begin

text \<open>Definitions for expression assumptions on incoming messages and properties of
      outgoing messages.\<close>

abbreviation not_Pkt :: "msg \<Rightarrow> bool"
where "not_Pkt m \<equiv> case m of Pkt _ _ _ \<Rightarrow> False | _ \<Rightarrow> True"

definition msg_sender :: "msg \<Rightarrow> ip"
where "msg_sender m \<equiv> case m of Rreq _ _ _ _ _ _ ipc \<Rightarrow> ipc
                              | Rrep _ _ _ _ ipc \<Rightarrow> ipc
                              | Rerr _ ipc \<Rightarrow> ipc
                              | Pkt _ _ ipc \<Rightarrow> ipc"

lemma msg_sender_simps [simp]:
  "\<And>hops dip dsn dsk oip osn sip.
                          msg_sender (Rreq hops dip dsn dsk oip osn sip) = sip"
  "\<And>hops dip dsn oip sip. msg_sender (Rrep hops dip dsn oip sip) = sip"
  "\<And>dests sip.            msg_sender (Rerr dests sip) = sip"
  "\<And>d dip sip.            msg_sender (Pkt d dip sip) = sip"
  unfolding msg_sender_def by simp_all

definition msg_zhops :: "msg \<Rightarrow> bool"
where "msg_zhops m \<equiv> case m of
                                 Rreq hopsc dipc _ _ oipc _ sipc \<Rightarrow> hopsc = 0 \<longrightarrow> oipc = sipc
                               | Rrep hopsc dipc _ _ sipc \<Rightarrow> hopsc = 0 \<longrightarrow> dipc = sipc
                               | _ \<Rightarrow> True"

lemma msg_zhops_simps [simp]:
  "\<And>hops dip dsn dsk oip osn sip.
           msg_zhops (Rreq hops dip dsn dsk oip osn sip) = (hops = 0 \<longrightarrow> oip = sip)"
  "\<And>hops dip dsn oip sip. msg_zhops (Rrep hops dip dsn oip sip) = (hops = 0 \<longrightarrow> dip = sip)"
  "\<And>dests sip.            msg_zhops (Rerr dests sip)        = True"
  "\<And>d dip.                msg_zhops (Newpkt d dip)          = True"
  "\<And>d dip sip.            msg_zhops (Pkt d dip sip)         = True"
  unfolding msg_zhops_def by simp_all

definition rreq_rrep_sn :: "msg \<Rightarrow> bool"
where "rreq_rrep_sn m \<equiv> case m of Rreq  _ _ _ _ _ osnc _ \<Rightarrow> osnc \<ge> 1
                                | Rrep _ _ dsnc _ _ \<Rightarrow> dsnc \<ge> 1
                                | _ \<Rightarrow> True"

lemma rreq_rrep_sn_simps [simp]:
  "\<And>hops dip dsn dsk oip osn sip.
           rreq_rrep_sn (Rreq hops dip dsn dsk oip osn sip) = (osn \<ge> 1)"
  "\<And>hops dip dsn oip sip. rreq_rrep_sn (Rrep hops dip dsn oip sip) = (dsn \<ge> 1)"
  "\<And>dests sip.            rreq_rrep_sn (Rerr dests sip) = True"
  "\<And>d dip.                rreq_rrep_sn (Newpkt d dip)   = True"
  "\<And>d dip sip.            rreq_rrep_sn (Pkt d dip sip)  = True"
  unfolding rreq_rrep_sn_def by simp_all

definition rreq_rrep_fresh :: "rt \<Rightarrow> msg \<Rightarrow> bool"
where "rreq_rrep_fresh crt m \<equiv> case m of Rreq hopsc  _ _ _ oipc osnc ipcc \<Rightarrow> (ipcc \<noteq> oipc \<longrightarrow>
                                                oipc\<in>kD(crt) \<and> (sqn crt oipc > osnc
                                                                \<or> (sqn crt oipc = osnc
                                                                   \<and> the (dhops crt oipc) \<le> hopsc
                                                                   \<and> the (flag crt oipc) = val)))
                                | Rrep hopsc dipc dsnc _ ipcc \<Rightarrow> (ipcc \<noteq> dipc \<longrightarrow>
                                                                    dipc\<in>kD(crt)
                                                                  \<and> sqn crt dipc = dsnc
                                                                  \<and> the (dhops crt dipc) = hopsc
                                                                  \<and> the (flag crt dipc) = val)
                                | _ \<Rightarrow> True"

lemma rreq_rrep_fresh [simp]:
  "\<And>hops dip dsn dsk oip osn sip.
           rreq_rrep_fresh crt (Rreq hops dip dsn dsk oip osn sip) =
                               (sip \<noteq> oip \<longrightarrow> oip\<in>kD(crt)
                                            \<and> (sqn crt oip > osn
                                               \<or> (sqn crt oip = osn
                                                  \<and> the (dhops crt oip) \<le> hops
                                                  \<and> the (flag crt oip) = val)))"
  "\<And>hops dip dsn oip sip. rreq_rrep_fresh crt (Rrep hops dip dsn oip sip) =
                               (sip \<noteq> dip \<longrightarrow> dip\<in>kD(crt)
                                              \<and> sqn crt dip = dsn
                                              \<and> the (dhops crt dip) = hops
                                              \<and> the (flag crt dip) = val)"
  "\<And>dests sip.            rreq_rrep_fresh crt (Rerr dests sip) = True"
  "\<And>d dip.                rreq_rrep_fresh crt (Newpkt d dip)   = True"
  "\<And>d dip sip.            rreq_rrep_fresh crt (Pkt d dip sip)  = True"
  unfolding rreq_rrep_fresh_def by simp_all

definition rerr_invalid :: "rt \<Rightarrow> msg \<Rightarrow> bool"
where "rerr_invalid crt m \<equiv> case m of Rerr destsc _ \<Rightarrow> (\<forall>ripc\<in>dom(destsc).
                                            (ripc\<in>iD(crt) \<and> the (destsc ripc) = sqn crt ripc))
                                | _ \<Rightarrow> True"

lemma rerr_invalid [simp]:
  "\<And>hops dip dsn dsk oip osn sip.
                           rerr_invalid crt (Rreq hops dip dsn dsk oip osn sip) = True"
  "\<And>hops dip dsn oip sip. rerr_invalid crt (Rrep hops dip dsn oip sip) = True"
  "\<And>dests sip.            rerr_invalid crt (Rerr dests sip) = (\<forall>rip\<in>dom(dests).
                                                 rip\<in>iD(crt) \<and> the (dests rip) = sqn crt rip)"
  "\<And>d dip.                rerr_invalid crt (Newpkt d dip)   = True"
  "\<And>d dip sip.            rerr_invalid crt (Pkt d dip sip)  = True"
  unfolding rerr_invalid_def by simp_all

definition
  initmissing :: "(nat \<Rightarrow> state option) \<times> 'a \<Rightarrow> (nat \<Rightarrow> state) \<times> 'a"
where
  "initmissing \<sigma> = (\<lambda>i. case (fst \<sigma>) i of None \<Rightarrow> aodv_init i | Some s \<Rightarrow> s, snd \<sigma>)"

lemma not_in_net_ips_fst_init_missing [simp]:
  assumes "i \<notin> net_ips \<sigma>"
    shows "fst (initmissing (netgmap fst \<sigma>)) i = aodv_init i"
  using assms unfolding initmissing_def by simp

lemma fst_initmissing_netgmap_pair_fst [simp]:
  "fst (initmissing (netgmap (\<lambda>(p, q). (fst (id p), snd (id p), q)) s))
                                               = fst (initmissing (netgmap fst s))"
  unfolding initmissing_def by auto

text \<open>We introduce a streamlined alternative to @{term initmissing} with @{term netgmap}
        to simplify invariant statements and thus facilitate their comprehension and
        presentation.\<close>

lemma fst_initmissing_netgmap_default_aodv_init_netlift:
  "fst (initmissing (netgmap fst s)) = default aodv_init (netlift fst s)"
  unfolding initmissing_def default_def
  by (simp add: fst_netgmap_netlift del: One_nat_def)

definition
  netglobal :: "((nat \<Rightarrow> state) \<Rightarrow> bool) \<Rightarrow> ((state \<times> 'b) \<times> 'c) net_state \<Rightarrow> bool"
where
  "netglobal P \<equiv> (\<lambda>s. P (default aodv_init (netlift fst s)))"

end


theory ZF_Typing_Examples
  imports Nat_ZF Soft_Types
begin

subsection \<open> Type of sets \<close>
definition Set :: "i type"
  where "Set \<equiv> Type (\<lambda>x::i. (x == x))"

lemma Set_TypeI: "(x::i) ::: Set"
  unfolding Set_def has_type_Type .

subsection \<open> Type of elements of a given set \<close>

definition set :: "i \<Rightarrow> i type"
  where "set A == Type (%x. Trueprop (x \<in> A))"

lemma set_typeI: "x \<in> A \<Longrightarrow> x ::: set A"
  unfolding set_def has_type_Type .

lemma set_typeE: "x ::: set A \<Longrightarrow> x \<in> A"
  unfolding set_def has_type_Type .

subsection \<open> Type of object-level propositions \<close>

definition o :: "o type"
  where "o \<equiv> Type (\<lambda>x::o. (x == x))"

lemma o_TypeI: "(P::o) ::: o"
  unfolding o_def has_type_Type .

subsection \<open> Type declarations for basic material \<close>

lemma eq[type]: "((=)::(i \<Rightarrow> i \<Rightarrow> o)) ::: (x: A) \<Rightarrow> (y: A) \<Rightarrow> o"
  by (intro Pi_typeI o_TypeI)

text \<open> Example: Inferring types for list append \<close>

context
  fixes List :: "i \<Rightarrow> i"
    and Nil :: "i \<Rightarrow> i"
    and Cons :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i"
    and append :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i"
  assumes [type]: "Nil ::: (A: Set) \<Rightarrow> set (List A)"
    and [type]: "Cons ::: (A: Set) \<Rightarrow> (x: set A) \<Rightarrow> (xs : set (List A)) \<Rightarrow> set (List A)"
    and [type]: "append ::: (A: Set) \<Rightarrow> (xs: set (List A)) \<Rightarrow> (ys : set (List A)) \<Rightarrow> set (List A)"
begin

ML \<open>Soft_Type_Inference.print_inferred_types @{context} [
  @{term "Nil A = B"}
]\<close>

ML \<open>Soft_Type_Inference.print_inferred_types @{context} [
  @{term "%A. Nil A"}
]\<close>

ML \<open>Soft_Type_Inference.print_inferred_types @{context} [
  @{term "%A x xs. Cons A x xs"}
]\<close>

ML \<open>

Soft_Type_Inference.print_inferred_types @{context} [
  @{term "append A (Cons A x xs) ys = Cons A x (append A xs ys)"},
  @{term "append A (Nil A) ys = ys"}
]
\<close>

(*
ML \<open>

Soft_Type_Inference.print_inferred_types @{context} [
  @{term "\<And>A x xs ys. append A (Cons A x xs) ys = Cons A x (append A xs ys)"},
  @{term "\<And>A ys. append A (Nil A) ys = ys"}
]
\<close>
*)

end

text \<open> Example: Inferring types for vectors of given length \<close>

context
  fixes Vec :: "i \<Rightarrow> i \<Rightarrow> i"
    and VNil :: "i \<Rightarrow> i"
    and VCons :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i"
    and add :: "i \<Rightarrow> i \<Rightarrow> i"
    and vappend :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i"
  assumes [type]: "Vec ::: (A: Set) \<Rightarrow> (n: set nat) \<Rightarrow> Set"
    and [type]: "VNil ::: (A: Set) \<Rightarrow> set (Vec A 0)"
    and [type]: "VCons ::: (A: Set) \<Rightarrow> (n: set nat) \<Rightarrow> (x: set A) \<Rightarrow> (xs : set (Vec A n)) \<Rightarrow> set (Vec A (succ n))"
    and [type]: "add ::: (n : set nat) \<Rightarrow> (m : set nat) \<Rightarrow> set nat"
    and [type]: "succ ::: (n : set nat) \<Rightarrow> set nat"
    and [type]: "0 ::: set nat"
    and [type]: "vappend ::: (A: Set) \<Rightarrow> (n: set nat) \<Rightarrow> (m: set nat) \<Rightarrow> (xs: set (Vec A n))
\<Rightarrow> (ys: set (Vec A m)) \<Rightarrow> set (Vec A (add n m))"
begin

(*

ML \<open> Soft_Type_Inference.print_inferred_types @{context} [
  @{term "vappend A (succ n) m (VCons A n x xs) ys
   = VCons A (add n m) x (vappend A n m xs ys)"}
]\<close>
*)

end

end


section{* Verification Component Based on KAD *}

theory VC_KAD_wf

imports VC_KAD "$AFP/KAD//Modal_Kleene_Algebra_Applications"

begin

subsection {* Relational Model of Divergence Kleene Algebras *}

definition rel_nabla :: "'a rel \<Rightarrow> 'a rel" where
  "rel_nabla X = \<Union> {P. P \<subseteq> relfdia X P}"

definition rel_nabla_bin :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" where
  "rel_nabla_bin X Q = \<Union> {P. P \<subseteq> relfdia X P \<union> rdom Q}"

lemma rel_nabla_d_closed [simp]:  "rdom (rel_nabla x) = rel_nabla x"
  by (auto simp: rel_nabla_def rel_antidomain_kleene_algebra.fdia_def rel_antidomain_kleene_algebra.ads_d_def rel_ad_def)

lemma rel_nabla_bin_d_closed [simp]:  "rdom (rel_nabla_bin x q) = rel_nabla_bin x q"
  by (auto simp: rel_nabla_bin_def rel_antidomain_kleene_algebra.fdia_def rel_antidomain_kleene_algebra.ads_d_def rel_ad_def)

lemma rel_nabla_bin_unfold: "rel_nabla_bin X Q \<subseteq> relfdia X (rel_nabla_bin X Q) \<union> rdom Q"
  by (simp add: rel_nabla_bin_def rel_ad_def rel_antidomain_kleene_algebra.fdia_def, blast)

lemma rel_nabla_coinduct_var: "P \<subseteq> relfdia X P \<Longrightarrow> P \<subseteq> rel_nabla X"
  by (simp add: rel_nabla_def rel_antidomain_kleene_algebra.fdia_def rel_ad_def, blast)

lemma rel_nabla_bin_coinduct: "P \<subseteq> relfdia X P \<union> rdom Q \<Longrightarrow> P \<subseteq> rel_nabla_bin X Q"
  by (simp add: rel_nabla_bin_def rel_antidomain_kleene_algebra.fdia_def rel_ad_def, blast)

text {* The two fusion lemmas are, in fact, hard-coded fixpoint fusion proofs. They might be replaced
by more generic fusion proofs eventually. *}

lemma nabla_fusion1: "rel_nabla X \<union> relfdia (X\<^sup>*) Q \<subseteq> rel_nabla_bin X Q"
proof -
  have "rel_nabla X \<union> relfdia (X\<^sup>*) Q \<subseteq> relfdia X (rel_nabla X) \<union> relfdia X (relfdia (X\<^sup>*) Q) \<union> rdom Q"
    by (metis (no_types, lifting) Un_mono inf_sup_aci(6) order_refl rel_antidomain_kleene_algebra.dka.fdia_star_unfold_var rel_nabla_unfold sup.commute)
  also have "... = relfdia X (rel_nabla X \<union> relfdia (X\<^sup>*) Q) \<union> rdom Q"
    by (simp add: rel_antidomain_kleene_algebra.dka.fdia_add1)
  finally show ?thesis
    using rel_nabla_bin_coinduct by blast
qed

lemma rel_ad_inter_seq: "rel_ad X \<inter> rel_ad Y = rel_ad X ; rel_ad Y"
  by (auto simp: rel_ad_def)

lemma fusion2_aux2: "rdom (rel_nabla_bin X Q) \<subseteq> rdom (rel_nabla_bin X Q \<inter> rel_ad (relfdia (X\<^sup>*) Q) \<union> relfdia (X\<^sup>*) Q)"
  apply (auto simp: rel_antidomain_kleene_algebra.ads_d_def rel_ad_def)
  by (metis pair_in_Id_conv r_into_rtrancl rel_antidomain_kleene_algebra.a_one rel_antidomain_kleene_algebra.a_star rel_antidomain_kleene_algebra.addual.ars_r_def rel_antidomain_kleene_algebra.dka.dns1'' rel_antidomain_kleene_algebra.dpdz.dom_one rel_antidomain_kleene_algebra.ds.ddual.rsr5 rel_antidomain_kleene_algebra.dual.conway.dagger_unfoldr_eq rel_antidomain_kleene_algebra.dual.tc_eq rel_nabla_bin_d_closed)

lemma nabla_fusion2: "rel_nabla_bin X Q \<subseteq> rel_nabla X \<union> relfdia (X\<^sup>*) Q"
proof -
  have "rel_nabla_bin X Q \<inter> rel_ad (relfdia (X\<^sup>*) Q)  \<subseteq> (relfdia X (rel_nabla_bin X Q) \<union> rdom Q) \<inter> rel_ad (relfdia (X\<^sup>*) Q)"
    by (meson Int_mono equalityD1 rel_nabla_bin_unfold)
  also have "... \<subseteq> (relfdia X (rel_nabla_bin X Q \<inter> rel_ad (relfdia (X\<^sup>*) Q) \<union> relfdia (X\<^sup>*) Q) \<union> rdom Q) \<inter> rel_ad (relfdia (X\<^sup>*) Q)"
    using fusion2_aux2 rel_antidomain_kleene_algebra.dka.fd_iso1 by blast
  also have "... = (relfdia X (rel_nabla_bin X Q \<inter> rel_ad (relfdia (X\<^sup>*) Q)) \<union> relfdia X (relfdia (X\<^sup>*) Q) \<union> rdom Q) \<inter> rel_ad (relfdia (X\<^sup>*) Q)"
    by (simp add: rel_antidomain_kleene_algebra.dka.fdia_add1)
  also have "... = (relfdia X (rel_nabla_bin X Q \<inter> rel_ad (relfdia (X\<^sup>*) Q)) \<union> relfdia (X\<^sup>*) Q) \<inter> rel_ad (relfdia (X\<^sup>*) Q)"
    using rel_antidomain_kleene_algebra.dka.fdia_star_unfold_var by blast
  finally have "rel_nabla_bin X Q \<inter> rel_ad (relfdia (X\<^sup>*) Q) \<subseteq> relfdia X ((rel_nabla_bin X Q) \<inter> rel_ad (relfdia (X\<^sup>*) Q))"
    by (metis (no_types, lifting) inf_commute order_trans_rules(23) rel_ad_inter_seq rel_antidomain_kleene_algebra.a_mult_add rel_antidomain_kleene_algebra.a_subid_aux1' rel_antidomain_kleene_algebra.addual.bdia_def rel_antidomain_kleene_algebra.ds.ddual.rsr5)
  hence "rdom (rel_nabla_bin X Q) ; rel_ad (relfdia (X\<^sup>*) Q) \<subseteq> rdom (rel_nabla X)"
    by (metis rel_ad_inter_seq rel_antidomain_kleene_algebra.addual.ars_r_def rel_nabla_bin_d_closed rel_nabla_coinduct_var rel_nabla_d_closed)
  thus ?thesis
    by (metis rel_antidomain_kleene_algebra.addual.ars_r_def rel_antidomain_kleene_algebra.addual.bdia_def rel_antidomain_kleene_algebra.d_a_galois1 rel_antidomain_kleene_algebra.dpdz.domain_invol rel_nabla_bin_d_closed rel_nabla_d_closed)
qed

lemma rel_nabla_coinduct: "P \<subseteq> relfdia X P \<union> rdom Q \<Longrightarrow> P \<subseteq> rel_nabla X \<union> relfdia (rtrancl X) Q"
  by (meson nabla_fusion2 order_trans rel_nabla_bin_coinduct)

interpretation rel_fdivka: fdivergence_kleene_algebra rel_ad "op \<union>" "op ; " Id "{}" "op \<subseteq>" "op \<subset>" rtrancl rel_nabla
proof
  fix x y z:: "'a rel"
  show "rdom (rel_nabla x) = rel_nabla x"
    by simp
  show "rel_nabla x \<subseteq> relfdia x (rel_nabla x)"
    by (simp add: rel_nabla_unfold)
  show "rdom y \<subseteq> relfdia x y \<union> rdom z \<Longrightarrow> rdom y \<subseteq> rel_nabla x \<union> relfdia (x\<^sup>*) z"
    by (simp add: rel_nabla_coinduct)
qed

subsection {* A Loop Verification Rule *}

context fdivergence_kleene_algebra
begin

text {* The rule is inspired by Arden' rule from language theory. *}

lemma fdia_arden: "\<nabla>x = 0 \<Longrightarrow> d p \<le> d q + |x\<rangle> p \<Longrightarrow> d p \<le> |x\<^sup>\<star>\<rangle> q"
proof -
  assume a1: "\<nabla>x = zero_class.zero"
  assume "d p \<le> d q + |x\<rangle> p"
  then have "ad (ad p) \<le> zero_class.zero + ad (ad (x\<^sup>\<star> \<cdot> q))"
    using a1 add_commute ads_d_def dka.fd_def nabla_coinduction by force
  then show ?thesis
    by (simp add: ads_d_def dka.fd_def)
qed

lemma fdia_arden_eq: "\<nabla>x = 0 \<Longrightarrow> d p = d q + |x\<rangle> p \<Longrightarrow> d p = |x\<^sup>\<star>\<rangle> q"
  by (simp add: fdia_arden dka.fdia_star_induct_eq eq_iff)

lemma fdia_arden_iff: "\<nabla>x = 0 \<Longrightarrow> (d p = d q + |x\<rangle> p \<longleftrightarrow> d p = |x\<^sup>\<star>\<rangle> q)"
  by (metis fdia_arden_eq dka.fdia_d_simp dka.fdia_star_unfold_var)

lemma fbox_ind: "d p \<le> d q \<cdot> |x] p \<Longrightarrow> d p \<le> |x\<^sup>\<star>] q"
proof -
assume h0: "d p \<le> d q \<cdot> |x] p"
hence h1: "d p \<le> d q" and h2: "d p \<le> |x] p"
apply (metis a_subid_aux2 dual_order.trans fbox_def)
using h0 dka.dom_subid_aux2 dual_order.trans by blast
hence "|x\<rangle> ad p \<le> ad p"
by (metis a_2_var addual.bbox_def ads_d_def dka.dsg4 ds.fd_def)
hence "|x\<^sup>\<star>\<rangle> ad p \<le> ad p"
by (smt a_2_var a_antitone' a_gla2 ads_d_def dka.fdia_star_induct_var fdia_def)
hence "d p \<le> |x\<^sup>\<star>] p"
by (simp add: h2 fbox_star_induct_var)
thus ?thesis
using h0 fbox_star_induct by blast
qed

lemma  "|x\<^sup>\<star>] p \<le> |x] p"
  by (simp add: fbox_antitone_var)

lemma fbox_arden:  "\<nabla>x = 0 \<Longrightarrow> d q \<cdot> |x] p \<le> d p \<Longrightarrow> |x\<^sup>\<star>] q \<le> d p"
proof -
assume h1: "\<nabla>x = 0" and "d q \<cdot> |x] p \<le> d p"
hence "ad p \<le> ad (d q \<cdot> |x] p)"
by (metis a_antitone' a_subid addual.ars_r_def dpdz.domain_subid dual_order.trans)
hence "ad p \<le> ad q + |x\<rangle> ad p"
by (simp add: a_6 addual.bbox_def ds.fd_def)
hence "ad p \<le> |x\<^sup>\<star>\<rangle> ad q"
by (metis fdia_arden h1 a_4 ads_d_def dpdz.dsg1  fdia_def meet_ord_def)
thus ?thesis
by (metis a_antitone' ads_d_def fbox_simp fdia_fbox_de_morgan_2)
qed

lemma fbox_arden_eq:  "\<nabla>x = 0 \<Longrightarrow> d q \<cdot> |x] p = d p \<Longrightarrow> |x\<^sup>\<star>] q = d p"
  by (simp add: fbox_arden antisym fbox_star_induct_eq)

lemma fbox_arden_iff: "\<nabla>x = 0 \<Longrightarrow> (d p = d q \<cdot> |x] p \<longleftrightarrow> d p = |x\<^sup>\<star>] q)"
  by (metis fbox_arden_eq fbox_simp fbox_star_unfold_var)

lemma fbox_arden_while_iff: "\<nabla> (d t \<cdot> x) = 0 \<Longrightarrow> (d p = (d t + d q) \<cdot> |d t \<cdot> x] p \<longleftrightarrow> d p = |while t do x od] q)"
  by (metis fbox_arden_iff dka.dom_add_closed fbox_export3 while_def)

lemma fbox_arden_whilei: "\<nabla> (d t \<cdot> x) = 0 \<Longrightarrow> (d i = (d t + d q) \<cdot> |d t \<cdot> x] i \<Longrightarrow> d i = |while t inv i do x od] q)"
  using fbox_arden_while_iff whilei_def by auto

lemma fbox_arden_whilei_iff: "\<nabla> (d t \<cdot> x) = 0 \<Longrightarrow> (d i = (d t + d q) \<cdot> |d t \<cdot> x] i \<longleftrightarrow> d i = |while t inv i do x od] q)"
  using fbox_arden_while_iff whilei_def by auto

subsection {* Nabla and Noethericity *}

lemma noether_nabla: "Noetherian x \<Longrightarrow> \<nabla> x = 0"
  by (metis nabla_closure nabla_unfold noetherian_alt)

lemma nabla_noether_iff: "Noetherian x \<longleftrightarrow> \<nabla> x = 0"
  using nabla_noether noether_nabla by blast

lemma nabla_preloeb_iff: "\<nabla> x = 0 \<longleftrightarrow> PreLoebian x"
  using Noetherian_iff_PreLoebian nabla_noether noether_nabla by blast

end

lemma rel_nabla_prop: "rel_nabla R = {} \<longleftrightarrow> (\<forall>P. P \<subseteq> relfdia R P \<longrightarrow> P = {})"
  by (metis bot.extremum_uniqueI rel_nabla_coinduct_var rel_nabla_unfold)

lemma fdia_rel_im1: "s2r ((converse R) `` P) = relfdia R (s2r P)"
  by (auto simp: Id_on_def rel_antidomain_kleene_algebra.ads_d_def rel_ad_def rel_antidomain_kleene_algebra.fdia_def Image_def converse_def)

lemma fdia_rel_im2: "s2r ((converse R) `` (r2s (rdom P))) = relfdia R P"
  by (simp add: fdia_rel_im1 rsr)

lemma wf_nabla_aux: "(P \<subseteq> (converse R) `` P \<longrightarrow> P = {}) \<longleftrightarrow> (s2r P \<subseteq> relfdia R (s2r P) \<longrightarrow> s2r P = {})"
  apply (standard, metis Domain_Id_on Domain_mono Id_on_empty fdia_rel_im1)
  using fdia_rel_im1 by fastforce

text {* A relation is noeterian if its converse is wellfounded. *}

lemma wf_nabla:  "wf (converse R) \<longleftrightarrow> rel_nabla R = {}"
  by (metis (no_types, lifting) fdia_rel_im2 rel_fdivka.nabla_unfold_eq rel_nabla_prop rel_nabla_unfold wfE_pf wfI_pf wf_nabla_aux)

end


theory crdt_examples
  imports crdt_specs
begin

section "CRDT Examples"

text "Next we validate the specification on some examples"

subsection "Flags"

abbreviation "enable \<equiv> Call Enable default"
abbreviation "disable \<equiv> Call Disable default"

abbreviation "c1 \<equiv> CallId 1"
abbreviation "c2 \<equiv> CallId 2"
abbreviation "c3 \<equiv> CallId 3"
abbreviation "c4 \<equiv> CallId 4"

definition "example1 \<equiv> \<lparr>
  calls = Map.empty,
  happensBefore = {}
\<rparr>"

definition "example2 \<equiv> \<lparr>
  calls = [
    c1 \<mapsto> enable,
    c2 \<mapsto> disable
  ],
  happensBefore = {}
\<rparr>"

definition "example3 \<equiv> \<lparr>
  calls = [
    c1 \<mapsto> disable,
    c2 \<mapsto> disable,
    c3 \<mapsto> enable,
    c4 \<mapsto> enable
  ],
  happensBefore = {(c1,c3), (c2,c4)}
\<rparr>"

definition "example4 \<equiv> \<lparr>
  calls = [
    c1 \<mapsto> enable,
    c2 \<mapsto> enable,
    c3 \<mapsto> disable,
    c4 \<mapsto> disable
  ],
  happensBefore = {(c1,c3), (c2,c4)}
\<rparr>"

lemma "flag_ew_spec ReadFlag example1 False"
  by (auto simp add: flag_ew_spec_def latestOps_def example1_def cOp_def)
lemma "flag_sew_spec ReadFlag example1 False"
  by (auto simp add: flag_sew_spec_def latestOps_def example1_def cOp_def)
lemma "flag_dw_spec ReadFlag example1 False"
  by (auto simp add: flag_dw_spec_def latestOps_def example1_def cOp_def)
lemma "flag_sdw_spec ReadFlag example1 False"
  by (auto simp add: flag_sdw_spec_def latestOps_def example1_def cOp_def)

lemma "flag_ew_spec ReadFlag example2 True"
  by (auto simp add: flag_ew_spec_def latestOps_def example2_def cOp_def)
lemma "flag_sew_spec ReadFlag example2 True"
  by (auto simp add: flag_sew_spec_def latestOps_def example2_def cOp_def)
lemma "flag_dw_spec ReadFlag example2 False"
  by (auto simp add: flag_dw_spec_def latestOps_def example2_def cOp_def cong: conj_cong)
lemma "flag_sdw_spec ReadFlag example2 False"
  by (auto simp add: flag_sdw_spec_def latestOps_def example2_def cOp_def cong: conj_cong)

lemma "flag_ew_spec ReadFlag example3 True"
  by (auto simp add: flag_ew_spec_def latestOps_def example3_def cOp_def cong: conj_cong)
   (smt callId.inject)
lemma "flag_sew_spec ReadFlag example3 True"
  by (auto simp add: flag_sew_spec_def latestOps_def example3_def cOp_def cong: conj_cong)
   (smt callId.inject)
lemma "flag_dw_spec ReadFlag example3 True"
  by (auto simp add: flag_dw_spec_def latestOps_def example3_def cOp_def cong: conj_cong)
   (smt callId.inject)
lemma "flag_sdw_spec ReadFlag example3 False"
  by (auto simp add: flag_sdw_spec_def latestOps_def example3_def cOp_def cong: conj_cong)

lemma "flag_ew_spec ReadFlag example4 False"
  by (auto simp add: flag_ew_spec_def latestOps_def example4_def cOp_def cong: conj_cong)
lemma "flag_sew_spec ReadFlag example4 True"
  by (auto simp add: flag_sew_spec_def latestOps_def example4_def cOp_def cong: conj_cong)
lemma "flag_dw_spec ReadFlag example4 False"
  by (auto simp add: flag_dw_spec_def latestOps_def example4_def cOp_def cong: conj_cong)
lemma "flag_sdw_spec ReadFlag example4 False"
  by (auto simp add: flag_sdw_spec_def latestOps_def example4_def cOp_def cong: conj_cong)
   (smt callId.inject)+

subsection "Maps"

text \<open>We illustrate the different map semantics based on examples:\<close>

abbreviation "c \<equiv> CallId"

definition "hb r \<equiv> (\<lambda>(x,y). (c x, c y))`  r\<^sup>+"

definition "exampleA \<equiv> \<lparr>
  calls = [
    c 0 \<mapsto> Call (DeleteKey 1) default,
    c 1 \<mapsto> Call (DeleteKey 1) default,
    c 2 \<mapsto> Call (NestedOp 1 (Increment 1)) default
  ],
  happensBefore = hb {(0,2)}
\<rparr>"

definition "exampleB \<equiv> \<lparr>
  calls = [
    c 0 \<mapsto> Call (DeleteKey 1) default,
    c 1 \<mapsto> Call (DeleteKey 1) default,
    c 2 \<mapsto> Call (NestedOp 1 (Increment 1)) default,
    c 3 \<mapsto> Call (NestedOp 1 (Increment 1)) default
  ],
  happensBefore = hb {(0,2), (1,3)}
\<rparr>"

definition "exampleC \<equiv> \<lparr>
  calls = [
    c 0 \<mapsto> Call (NestedOp 1 (Increment 1)) default,
    c 1 \<mapsto> Call (NestedOp 1 (Increment 1)) default,
    c 2 \<mapsto> Call (DeleteKey 1) default
  ],
  happensBefore = hb {(0,2)}
\<rparr>"

definition "exampleD \<equiv> \<lparr>
  calls = [
    c 0 \<mapsto> Call (NestedOp 1 (Increment 1)) default,
    c 1 \<mapsto> Call (NestedOp 1 (Increment 1)) default,
    c 2 \<mapsto> Call (DeleteKey 1) default,
    c 3 \<mapsto> Call (DeleteKey 1) default
  ],
  happensBefore = hb {(0,2), (1,3)}
\<rparr>"

definition "dom_subset A m \<equiv> A \<inter> dom m"

lemma dom_subset_empty[simp]: "dom_subset {} m = {}"
  by (simp add: dom_subset_def)

lemma dom_subset_insert[simp]: "dom_subset (insert x A) m = (case m x of Some y \<Rightarrow> {x} | None \<Rightarrow> {}) \<union> dom_subset A m"
  by (auto simp add: dom_subset_def split: option.splits)

lemma dom_subset_ex:
  assumes "\<And>x y. m x \<triangleq> y \<Longrightarrow>  x \<in> {c 0, c 1, c 2, c 3}"
  shows "dom m = dom_subset {c 0, c 1, c 2, c 3} m"
  using assms by (auto simp add: dom_subset_def)

method eval_example_auto = (auto simp add: map_dw_spec_def map_spec_def
    counter_spec_def sub_context_def restrict_ctxt_op_def
    restrict_ctxt_def fmap_map_values_def ctxt_restrict_calls_def
    restrict_map_def deleted_calls_dw_def
    exampleA_def exampleB_def exampleC_def exampleD_def
    cOp_def hb_def
    is_update_counterOp_def sum_map_def map_uw_spec_def deleted_calls_uw_def
    option_bind_def trancl_insert  increments_def nested_op_on_key_def
    rtrancl_insert
    map_suw_spec_def deleted_calls_suw_def
    map_sdw_spec_def deleted_calls_sdw_def
    split: option.splits if_splits)

method eval_example = (eval_example_auto; (subst dom_subset_ex)?)+

lemma "map_uw_spec counter_spec (NestedOp 1 GetCount) exampleA (from_int 1)"
  by eval_example

lemma "map_suw_spec counter_spec (NestedOp 1 GetCount) exampleA (from_int 1)"
  by eval_example

lemma "map_dw_spec counter_spec (NestedOp 1 GetCount) exampleA (from_int 0)"
  by eval_example

lemma "map_sdw_spec counter_spec (NestedOp 1 GetCount) exampleA (from_int 0)"
  by eval_example
    (metis callId.inject)

lemma "map_uw_spec counter_spec (NestedOp 1 GetCount) exampleB (from_int 2)"
  by eval_example

lemma "map_suw_spec counter_spec (NestedOp 1 GetCount) exampleB (from_int 2)"
  by eval_example

lemma "map_dw_spec counter_spec (NestedOp 1 GetCount) exampleB (from_int 2)"
  by eval_example

lemma "map_sdw_spec counter_spec (NestedOp 1 GetCount) exampleB (from_int 0)"
  by eval_example
    (metis callId.inject)

lemma "map_uw_spec counter_spec (NestedOp 1 GetCount) exampleC (from_int 1)"
  by eval_example

lemma "map_suw_spec counter_spec (NestedOp 1 GetCount) exampleC (from_int 2)"
  by eval_example
    (smt callId.inject)

lemma "map_dw_spec counter_spec (NestedOp 1 GetCount) exampleC (from_int 0)"
  by eval_example

lemma "map_sdw_spec counter_spec (NestedOp 1 GetCount) exampleC (from_int 0)"
  by eval_example
    (smt callId.inject)+

lemma "map_uw_spec counter_spec (NestedOp 1 GetCount) exampleD (from_int 0)"
  by eval_example
    (smt callId.inject)

lemma "map_suw_spec counter_spec (NestedOp 1 GetCount) exampleD (from_int 2)"
  by eval_example
    (smt callId.inject)

lemma "map_dw_spec counter_spec (NestedOp 1 GetCount) exampleD (from_int 0)"
  by eval_example
    (smt callId.inject)+

lemma "map_sdw_spec counter_spec (NestedOp 1 GetCount) exampleD (from_int 0)"
  by eval_example
    (smt callId.inject)+

subsection \<open>Struct example\<close>

text \<open>This is a struct with two fields: a counter and a set.\<close>

datatype val =
    I int
  | Bool bool
  | ListVal "val list"

instance val :: countable
  by countable_datatype

definition [simp]: "uniqueIds_val_r (x::val) = ({}::uniqueId set)"

instantiation val :: valueType begin
definition [simp]: "uniqueIds_val \<equiv> uniqueIds_val_r"
definition [simp]: "default_val \<equiv> I 0"

instance by (standard, auto)
end

instantiation val :: from_bool begin
definition [simp]: "from_bool_val \<equiv> Bool"

instance by (standard, auto)
end

instantiation val :: from_int begin
definition [simp]: "from_int_val \<equiv> I"

instance by (standard, auto)
end

text_raw \<open>\DefineSnippet{struct_example1}{\<close>
datatype structOp =
    A counterOp
  | B \<open>int setOp\<close>
text_raw \<open>}%EndSnippet\<close>

text_raw \<open>\DefineSnippet{struct_example2}{\<close>
definition crdtSpec :: "(structOp, val) crdtSpec" where
"crdtSpec \<equiv>
      struct_field A counter_spec
  .\<or>. struct_field B set_rw_spec"
text_raw \<open>}%EndSnippet\<close>

end


section \<open> Concurrent Programming \<close>

theory utp_concurrency
  imports
    utp_hoare
    utp_rel
    utp_tactics
    utp_theory
begin

text \<open> In this theory we describe the UTP scheme for concurrency, \emph{parallel-by-merge},
  which provides a general parallel operator parametrised by a ``merge predicate'' that explains
  how to merge the after states of the composed predicates. It can thus be applied to many languages
  and concurrency schemes, with this theory providing a number of generic laws. The operator is
  explained in more detail in Chapter 7 of the UTP book~\cite{Hoare&98}. \<close>

subsection \<open> Variable Renamings \<close>

text \<open> In parallel-by-merge constructions, a merge predicate defines the behaviour following execution of
  of parallel processes, $P \parallel Q$, as a relation that merges the output of $P$ and $Q$. In order
  to achieve this we need to separate the variable values output from $P$ and $Q$, and in addition the
  variable values before execution. The following three constructs do these separations. The initial
  state-space before execution is @{typ "'\<alpha>"}, the final state-space after the first parallel process
  is @{typ "'\<beta>\<^sub>0"}, and the final state-space for the second is @{typ "'\<beta>\<^sub>1"}. These three functions
  lift variables on these three state-spaces, respectively.
\<close>

alphabet ('\<alpha>, '\<beta>\<^sub>0, '\<beta>\<^sub>1) mrg =
  mrg_prior :: "'\<alpha>"
  mrg_left  :: "'\<beta>\<^sub>0"
  mrg_right  :: "'\<beta>\<^sub>1"

text \<open> We set up syntax for the three variable classes. \<close>

syntax
  "_svarprior" :: "svid" ("<")
  "_svarl"     :: "svid" ("0")
  "_svarr"     :: "svid" ("1")

translations
  "_svarprior"   == "CONST mrg_prior"
  "_svarl"       == "CONST mrg_left"
  "_svarr"       == "CONST mrg_right"

subsection \<open> Merge Predicates \<close>

text \<open> A merge predicate is a relation whose input has three parts: the prior variables, the output
  variables of the left predicate, and the output of the right predicate. \<close>

type_synonym '\<alpha> merge = "(('\<alpha>, '\<alpha>, '\<alpha>) mrg, '\<alpha>) urel"

text \<open> skip is the merge predicate which ignores the output of both parallel predicates \<close>

definition skip\<^sub>m :: "'\<alpha> merge" where
[upred_defs]: "skip\<^sub>m = ($\<^bold>v\<acute> =\<^sub>u $<:\<^bold>v)"

text \<open> swap is a predicate that the swaps the left and right indices; it is used to specify
        commutativity of the parallel operator \<close>

definition swap\<^sub>m :: "(('\<alpha>, '\<beta>, '\<beta>) mrg) hrel" where
[upred_defs]: "swap\<^sub>m = (0:\<^bold>v,1:\<^bold>v) := (&1:\<^bold>v,&0:\<^bold>v)"

text \<open> A symmetric merge is one for which swapping the order of the merged concurrent predicates
  has no effect. We represent this by the following healthiness condition that states that
  @{term "swap\<^sub>m"} is a left-unit. \<close>

abbreviation SymMerge :: "'\<alpha> merge \<Rightarrow> '\<alpha> merge" where
"SymMerge(M) \<equiv> (swap\<^sub>m ;; M)"

subsection \<open> Separating Simulations \<close>

text \<open> U0 and U1 are relations modify the variables of the input state-space such that they become
  indexed with $0$ and $1$, respectively. \<close>

definition U0 :: "('\<beta>\<^sub>0, ('\<alpha>, '\<beta>\<^sub>0, '\<beta>\<^sub>1) mrg) urel" where
[upred_defs]: "U0 = ($0:\<^bold>v\<acute> =\<^sub>u $\<^bold>v)"

definition U1 :: "('\<beta>\<^sub>1, ('\<alpha>, '\<beta>\<^sub>0, '\<beta>\<^sub>1) mrg) urel" where
[upred_defs]: "U1 = ($1:\<^bold>v\<acute> =\<^sub>u $\<^bold>v)"

lemma U0_swap: "(U0 ;; swap\<^sub>m) = U1"
  by (rel_auto)

lemma U1_swap: "(U1 ;; swap\<^sub>m) = U0"
  by (rel_auto)

text \<open> As shown below, separating simulations can also be expressed using the following two
  alphabet extrusions \<close>

definition U0\<alpha> where [upred_defs]: "U0\<alpha> = (1\<^sub>L \<times>\<^sub>L mrg_left)"

definition U1\<alpha> where [upred_defs]: "U1\<alpha> = (1\<^sub>L \<times>\<^sub>L mrg_right)"

text \<open> We then create the following intuitive syntax for separating simulations. \<close>

abbreviation U0_alpha_lift ("\<lceil>_\<rceil>\<^sub>0") where "\<lceil>P\<rceil>\<^sub>0 \<equiv> P \<oplus>\<^sub>p U0\<alpha>"

abbreviation U1_alpha_lift ("\<lceil>_\<rceil>\<^sub>1") where "\<lceil>P\<rceil>\<^sub>1 \<equiv> P \<oplus>\<^sub>p U1\<alpha>"

text \<open> @{term "\<lceil>P\<rceil>\<^sub>0"} is predicate $P$ where all variables are indexed by $0$, and
  @{term "\<lceil>P\<rceil>\<^sub>1"} is where all variables are indexed by $1$. We can thus equivalently express separating
  simulations using alphabet extrusion. \<close>

lemma U0_as_alpha: "(P ;; U0) = \<lceil>P\<rceil>\<^sub>0"
  by (rel_auto)

lemma U1_as_alpha: "(P ;; U1) = \<lceil>P\<rceil>\<^sub>1"
  by (rel_auto)

lemma U0\<alpha>_vwb_lens [simp]: "vwb_lens U0\<alpha>"
  by (simp add: U0\<alpha>_def id_vwb_lens prod_vwb_lens)

lemma U1\<alpha>_vwb_lens [simp]: "vwb_lens U1\<alpha>"
  by (simp add: U1\<alpha>_def id_vwb_lens prod_vwb_lens)

lemma U0\<alpha>_indep_right_uvar [simp]: "vwb_lens x \<Longrightarrow> U0\<alpha> \<bowtie> out_var (x ;\<^sub>L mrg_right)"
  by (force intro: plus_pres_lens_indep fst_snd_lens_indep lens_indep_left_comp
            simp add: U0\<alpha>_def out_var_def prod_as_plus)

lemma U1\<alpha>_indep_left_uvar [simp]: "vwb_lens x \<Longrightarrow> U1\<alpha> \<bowtie> out_var (x ;\<^sub>L mrg_left)"
  by (force intro: plus_pres_lens_indep fst_snd_lens_indep lens_indep_left_comp
            simp add: U1\<alpha>_def out_var_def prod_as_plus)

lemma U0_alpha_lift_bool_subst [usubst]:
  "\<sigma>($0:x\<acute> \<mapsto>\<^sub>s true) \<dagger> \<lceil>P\<rceil>\<^sub>0 = \<sigma> \<dagger> \<lceil>P\<lbrakk>true/$x\<acute>\<rbrakk>\<rceil>\<^sub>0"
  "\<sigma>($0:x\<acute> \<mapsto>\<^sub>s false) \<dagger> \<lceil>P\<rceil>\<^sub>0 = \<sigma> \<dagger> \<lceil>P\<lbrakk>false/$x\<acute>\<rbrakk>\<rceil>\<^sub>0"
  by (pred_auto+)

lemma U1_alpha_lift_bool_subst [usubst]:
  "\<sigma>($1:x\<acute> \<mapsto>\<^sub>s true) \<dagger> \<lceil>P\<rceil>\<^sub>1 = \<sigma> \<dagger> \<lceil>P\<lbrakk>true/$x\<acute>\<rbrakk>\<rceil>\<^sub>1"
  "\<sigma>($1:x\<acute> \<mapsto>\<^sub>s false) \<dagger> \<lceil>P\<rceil>\<^sub>1 = \<sigma> \<dagger> \<lceil>P\<lbrakk>false/$x\<acute>\<rbrakk>\<rceil>\<^sub>1"
  by (pred_auto+)

lemma U0_alpha_out_var [alpha]: "\<lceil>$x\<acute>\<rceil>\<^sub>0 = $0:x\<acute>"
  by (rel_auto)

lemma U1_alpha_out_var [alpha]: "\<lceil>$x\<acute>\<rceil>\<^sub>1 = $1:x\<acute>"
  by (rel_auto)

lemma U0_skip [alpha]: "\<lceil>II\<rceil>\<^sub>0 = ($0:\<^bold>v\<acute> =\<^sub>u $\<^bold>v)"
  by (rel_auto)

lemma U0_seqr [alpha]: "\<lceil>P ;; Q\<rceil>\<^sub>0 = P ;; \<lceil>Q\<rceil>\<^sub>0"
  by (rel_auto)

lemma U1_seqr [alpha]: "\<lceil>P ;; Q\<rceil>\<^sub>1 = P ;; \<lceil>Q\<rceil>\<^sub>1"
  by (rel_auto)

lemma U0\<alpha>_comp_in_var [alpha]: "(in_var x) ;\<^sub>L U0\<alpha> = in_var x"
  by (simp add: U0\<alpha>_def alpha_in_var in_var_prod_lens)

lemma U0\<alpha>_comp_out_var [alpha]: "(out_var x) ;\<^sub>L U0\<alpha> = out_var (x ;\<^sub>L mrg_left)"
  by (simp add: U0\<alpha>_def alpha_out_var id_wb_lens out_var_prod_lens)

lemma U1\<alpha>_comp_in_var [alpha]: "(in_var x) ;\<^sub>L U1\<alpha> = in_var x"
  by (simp add: U1\<alpha>_def alpha_in_var in_var_prod_lens)

lemma U1\<alpha>_comp_out_var [alpha]: "(out_var x) ;\<^sub>L U1\<alpha> = out_var (x ;\<^sub>L mrg_right)"
  by (simp add: U1\<alpha>_def alpha_out_var id_wb_lens out_var_prod_lens)

subsection \<open> Associative Merges \<close>

text \<open> Associativity of a merge means that if we construct a three way merge from a two way merge
  and then rotate the three inputs of the merge to the left, then we get exactly the same three
  way merge back.

  We first construct the operator that constructs the three way merge by effectively wiring up
  the two way merge in an appropriate way.
\<close>

definition ThreeWayMerge :: "'\<alpha> merge \<Rightarrow> (('\<alpha>, '\<alpha>, ('\<alpha>, '\<alpha>, '\<alpha>) mrg) mrg, '\<alpha>) urel" ("\<^bold>M3'(_')") where
[upred_defs]: "ThreeWayMerge M = (($0:\<^bold>v\<acute> =\<^sub>u $0:\<^bold>v \<and> $1:\<^bold>v\<acute> =\<^sub>u $1:0:\<^bold>v \<and> $<:\<^bold>v\<acute> =\<^sub>u $<:\<^bold>v) ;; M ;; U0 \<and> $1:\<^bold>v\<acute> =\<^sub>u $1:1:\<^bold>v \<and> $<:\<^bold>v\<acute> =\<^sub>u $<:\<^bold>v) ;; M"

text \<open> The next definition rotates the inputs to a three way merge to the left one place. \<close>

abbreviation rotate\<^sub>m where "rotate\<^sub>m \<equiv> (0:\<^bold>v,1:0:\<^bold>v,1:1:\<^bold>v) := (&1:0:\<^bold>v,&1:1:\<^bold>v,&0:\<^bold>v)"

text \<open> Finally, a merge is associative if rotating the inputs does not effect the output. \<close>

definition AssocMerge :: "'\<alpha> merge \<Rightarrow> bool" where
[upred_defs]: "AssocMerge M = (rotate\<^sub>m ;; \<^bold>M3(M) = \<^bold>M3(M))"

subsection \<open> Parallel Operators \<close>

text \<open> We implement the following useful abbreviation for separating of two parallel processes and
  copying of the before variables, all to act as input to the merge predicate. \<close>

abbreviation par_sep (infixr "\<parallel>\<^sub>s" 85) where
"P \<parallel>\<^sub>s Q \<equiv> (P ;; U0) \<and> (Q ;; U1) \<and> $<\<acute> =\<^sub>u $\<^bold>v"

text \<open> The following implementation of parallel by merge is less general than the book version, in
  that it does not properly partition the alphabet into two disjoint segments. We could actually
  achieve this specifying lenses into the larger alphabet, but this would complicate the definition
  of programs. May reconsider later. \<close>

definition
  par_by_merge :: "('\<alpha>, '\<beta>) urel \<Rightarrow> (('\<alpha>, '\<beta>, '\<gamma>) mrg, '\<delta>) urel \<Rightarrow> ('\<alpha>, '\<gamma>) urel \<Rightarrow> ('\<alpha>, '\<delta>) urel"
  ("_ \<parallel>\<^bsub>_\<^esub> _" [85,0,86] 85)
where [upred_defs]: "P \<parallel>\<^bsub>M\<^esub> Q = (P \<parallel>\<^sub>s Q ;; M)"

lemma par_by_merge_alt_def: "P \<parallel>\<^bsub>M\<^esub> Q = (\<lceil>P\<rceil>\<^sub>0 \<and> \<lceil>Q\<rceil>\<^sub>1 \<and> $<:\<^bold>v\<acute> =\<^sub>u $\<^bold>v) ;; M"
  by (simp add: par_by_merge_def U0_as_alpha U1_as_alpha)

lemma shEx_pbm_left: "((\<^bold>\<exists> x \<bullet> P x) \<parallel>\<^bsub>M\<^esub> Q) = (\<^bold>\<exists> x \<bullet> (P x \<parallel>\<^bsub>M\<^esub> Q))"
  by (rel_auto)

lemma shEx_pbm_right: "(P \<parallel>\<^bsub>M\<^esub> (\<^bold>\<exists> x \<bullet> Q x)) = (\<^bold>\<exists> x \<bullet> (P \<parallel>\<^bsub>M\<^esub> Q x))"
  by (rel_auto)

subsection \<open> Unrestriction Laws \<close>

lemma unrest_in_par_by_merge [unrest]:
  "\<lbrakk> $x \<sharp> P; $<:x \<sharp> M; $x \<sharp> Q \<rbrakk> \<Longrightarrow> $x \<sharp> P \<parallel>\<^bsub>M\<^esub> Q"
  by (rel_auto, fastforce+)

lemma unrest_out_par_by_merge [unrest]:
  "\<lbrakk> $x\<acute> \<sharp> M \<rbrakk> \<Longrightarrow> $x\<acute> \<sharp> P \<parallel>\<^bsub>M\<^esub> Q"
  by (rel_auto)

lemma unrest_merge_vars [unrest]: "$1:x\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>0" "$<:x\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>0" "$0:x\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>1" "$<:x\<acute> \<sharp> \<lceil>P\<rceil>\<^sub>1"
  by (rel_auto)+

subsection \<open> Substitution laws \<close>

text \<open> Substitution is a little tricky because when we push the expression through the composition
  operator the alphabet of the expression must also change. Consequently for now we only support
  literal substitution, though this could be generalised with suitable alphabet coercsions. We
  need quite a number of variants to support this which are below. \<close>

lemma U0_seq_subst: "(P ;; U0)\<lbrakk>\<guillemotleft>v\<guillemotright>/$0:x\<acute>\<rbrakk> = (P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; U0)"
  by (rel_auto)

lemma U1_seq_subst: "(P ;; U1)\<lbrakk>\<guillemotleft>v\<guillemotright>/$1:x\<acute>\<rbrakk> = (P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; U1)"
  by (rel_auto)

lemma lit_pbm_subst [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s \<guillemotleft>v\<guillemotright>) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>\<guillemotleft>v\<guillemotright>/$<:x\<rbrakk>\<^esub> (Q\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s \<guillemotleft>v\<guillemotright>) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk>\<^esub> Q)"
  by (rel_auto)+

lemma bool_pbm_subst [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s false) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>false/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>false/$<:x\<rbrakk>\<^esub> (Q\<lbrakk>false/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s true) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>true/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>true/$<:x\<rbrakk>\<^esub> (Q\<lbrakk>true/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s false) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>false/$x\<acute>\<rbrakk>\<^esub> Q)"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s true) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>true/$x\<acute>\<rbrakk>\<^esub> Q)"
  by (rel_auto)+

lemma zero_one_pbm_subst [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 0) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>0/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>0/$<:x\<rbrakk>\<^esub> (Q\<lbrakk>0/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 1) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>1/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>1/$<:x\<rbrakk>\<^esub> (Q\<lbrakk>1/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 0) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>0/$x\<acute>\<rbrakk>\<^esub> Q)"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 1) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>1/$x\<acute>\<rbrakk>\<^esub> Q)"
  by (rel_auto)+

lemma numeral_pbm_subst [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s numeral n) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>numeral n/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>numeral n/$<:x\<rbrakk>\<^esub> (Q\<lbrakk>numeral n/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s numeral n) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>numeral n/$x\<acute>\<rbrakk>\<^esub> Q)"
  by (rel_auto)+

subsection \<open> Parallel-by-merge laws \<close>

lemma par_by_merge_false [simp]:
  "P \<parallel>\<^bsub>false\<^esub> Q = false"
  by (rel_auto)

lemma par_by_merge_left_false [simp]:
  "false \<parallel>\<^bsub>M\<^esub> Q = false"
  by (rel_auto)

lemma par_by_merge_right_false [simp]:
  "P \<parallel>\<^bsub>M\<^esub> false = false"
  by (rel_auto)

lemma par_by_merge_seq_add: "(P \<parallel>\<^bsub>M\<^esub> Q) ;; R = (P \<parallel>\<^bsub>M ;; R\<^esub> Q)"
  by (simp add: par_by_merge_def seqr_assoc)

text \<open> A skip parallel-by-merge yields a skip whenever the parallel predicates are both feasible. \<close>

lemma par_by_merge_skip:
  assumes "P ;; true = true" "Q ;; true = true"
  shows "P \<parallel>\<^bsub>skip\<^sub>m\<^esub> Q = II"
  using assms by (rel_auto)

lemma skip_merge_swap: "swap\<^sub>m ;; skip\<^sub>m = skip\<^sub>m"
  by (rel_auto)

lemma par_sep_swap: "P \<parallel>\<^sub>s Q ;; swap\<^sub>m = Q \<parallel>\<^sub>s P"
  by (rel_auto)

text \<open> Parallel-by-merge commutes when the merge predicate is unchanged by swap \<close>

lemma par_by_merge_commute_swap:
  shows "P \<parallel>\<^bsub>M\<^esub> Q = Q \<parallel>\<^bsub>swap\<^sub>m ;; M\<^esub> P"
proof -
  have "Q \<parallel>\<^bsub>swap\<^sub>m ;; M\<^esub> P = ((((Q ;; U0) \<and> (P ;; U1) \<and> $<:\<^bold>v\<acute> =\<^sub>u $\<^bold>v) ;; swap\<^sub>m) ;; M)"
    by (simp add: par_by_merge_def seqr_assoc)
  also have "... = (((Q ;; U0 ;; swap\<^sub>m) \<and> (P ;; U1 ;; swap\<^sub>m) \<and> $<:\<^bold>v\<acute> =\<^sub>u $\<^bold>v) ;; M)"
    by (rel_auto)
  also have "... = (((Q ;; U1) \<and> (P ;; U0) \<and> $<:\<^bold>v\<acute> =\<^sub>u $\<^bold>v) ;; M)"
    by (simp add: U0_swap U1_swap)
  also have "... = P \<parallel>\<^bsub>M\<^esub> Q"
    by (simp add: par_by_merge_def utp_pred_laws.inf.left_commute)
  finally show ?thesis ..
qed

theorem par_by_merge_commute:
  assumes "M is SymMerge"
  shows "P \<parallel>\<^bsub>M\<^esub> Q = Q \<parallel>\<^bsub>M\<^esub> P"
  by (metis Healthy_if assms par_by_merge_commute_swap)

lemma par_by_merge_mono_1:
  assumes "P\<^sub>1 \<sqsubseteq> P\<^sub>2"
  shows "P\<^sub>1 \<parallel>\<^bsub>M\<^esub> Q \<sqsubseteq> P\<^sub>2 \<parallel>\<^bsub>M\<^esub> Q"
  using assms by (rel_auto)

lemma par_by_merge_mono_2:
  assumes "Q\<^sub>1 \<sqsubseteq> Q\<^sub>2"
  shows "(P \<parallel>\<^bsub>M\<^esub> Q\<^sub>1) \<sqsubseteq> (P \<parallel>\<^bsub>M\<^esub> Q\<^sub>2)"
  using assms by (rel_blast)

lemma par_by_merge_mono:
  assumes "P\<^sub>1 \<sqsubseteq> P\<^sub>2" "Q\<^sub>1 \<sqsubseteq> Q\<^sub>2"
  shows "P\<^sub>1 \<parallel>\<^bsub>M\<^esub> Q\<^sub>1 \<sqsubseteq> P\<^sub>2 \<parallel>\<^bsub>M\<^esub> Q\<^sub>2"
  by (meson assms dual_order.trans par_by_merge_mono_1 par_by_merge_mono_2)

theorem par_by_merge_assoc:
  assumes "M is SymMerge" "AssocMerge M"
  shows "(P \<parallel>\<^bsub>M\<^esub> Q) \<parallel>\<^bsub>M\<^esub> R = P \<parallel>\<^bsub>M\<^esub> (Q \<parallel>\<^bsub>M\<^esub> R)"
proof -
  have "(P \<parallel>\<^bsub>M\<^esub> Q) \<parallel>\<^bsub>M\<^esub> R = ((P ;; U0) \<and> (Q ;; U0 ;; U1) \<and> (R ;; U1 ;; U1) \<and> $<:\<^bold>v\<acute> =\<^sub>u $\<^bold>v) ;; \<^bold>M3(M)"
    by (rel_blast)
  also have "... = ((P ;; U0) \<and> (Q ;; U0 ;; U1) \<and> (R ;; U1 ;; U1) \<and> $<:\<^bold>v\<acute> =\<^sub>u $\<^bold>v) ;; rotate\<^sub>m ;; \<^bold>M3(M)"
    using AssocMerge_def assms(2) by force
  also have "... = ((Q ;; U0) \<and> (R ;; U0 ;; U1) \<and> (P ;; U1 ;; U1) \<and> $<:\<^bold>v\<acute> =\<^sub>u $\<^bold>v) ;; \<^bold>M3(M)"
    by (rel_blast)
  also have "... = (Q \<parallel>\<^bsub>M\<^esub> R) \<parallel>\<^bsub>M\<^esub> P"
    by (rel_blast)
  also have "... = P \<parallel>\<^bsub>M\<^esub> (Q \<parallel>\<^bsub>M\<^esub> R)"
    by (simp add: assms(1) par_by_merge_commute)
  finally show ?thesis .
qed

theorem par_by_merge_choice_left:
  "(P \<sqinter> Q) \<parallel>\<^bsub>M\<^esub> R = (P \<parallel>\<^bsub>M\<^esub> R) \<sqinter> (Q \<parallel>\<^bsub>M\<^esub> R)"
  by (rel_auto)

theorem par_by_merge_choice_right:
  "P \<parallel>\<^bsub>M\<^esub> (Q \<sqinter> R) = (P \<parallel>\<^bsub>M\<^esub> Q) \<sqinter> (P \<parallel>\<^bsub>M\<^esub> R)"
  by (rel_auto)

theorem par_by_merge_or_left:
  "(P \<or> Q) \<parallel>\<^bsub>M\<^esub> R = (P \<parallel>\<^bsub>M\<^esub> R \<or> Q \<parallel>\<^bsub>M\<^esub> R)"
  by (rel_auto)

theorem par_by_merge_or_right:
  "P \<parallel>\<^bsub>M\<^esub> (Q \<or> R) = (P \<parallel>\<^bsub>M\<^esub> Q \<or> P \<parallel>\<^bsub>M\<^esub> R)"
  by (rel_auto)

theorem par_by_merge_USUP_mem_left:
  "(\<Sqinter> i\<in>I \<bullet> P(i)) \<parallel>\<^bsub>M\<^esub> Q = (\<Sqinter> i\<in>I \<bullet> P(i) \<parallel>\<^bsub>M\<^esub> Q)"
  by (rel_auto)

theorem par_by_merge_USUP_ind_left:
  "(\<Sqinter> i \<bullet> P(i)) \<parallel>\<^bsub>M\<^esub> Q = (\<Sqinter> i \<bullet> P(i) \<parallel>\<^bsub>M\<^esub> Q)"
  by (rel_auto)

theorem par_by_merge_USUP_mem_right:
  "P \<parallel>\<^bsub>M\<^esub> (\<Sqinter> i\<in>I \<bullet> Q(i)) = (\<Sqinter> i\<in>I \<bullet> P \<parallel>\<^bsub>M\<^esub> Q(i))"
  by (rel_auto)

theorem par_by_merge_USUP_ind_right:
  "P \<parallel>\<^bsub>M\<^esub> (\<Sqinter> i \<bullet> Q(i)) = (\<Sqinter> i \<bullet> P \<parallel>\<^bsub>M\<^esub> Q(i))"
  by (rel_auto)

subsection \<open> Example: Simple State-Space Division \<close>

text \<open> The following merge predicate divides the state space using a pair of independent lenses. \<close>

definition StateMerge :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('b \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> merge" ("M[_|_]\<^sub>\<sigma>") where
[upred_defs]: "M[a|b]\<^sub>\<sigma> = ($\<^bold>v\<acute> =\<^sub>u ($<:\<^bold>v \<oplus> $0:\<^bold>v on &a) \<oplus> $1:\<^bold>v on &b)"

lemma swap_StateMerge: "a \<bowtie> b \<Longrightarrow> (swap\<^sub>m ;; M[a|b]\<^sub>\<sigma>) = M[b|a]\<^sub>\<sigma>"
  by (rel_auto, simp_all add: lens_indep_comm)

abbreviation StateParallel :: "'\<alpha> hrel \<Rightarrow> ('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('b \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("_ |_|_|\<^sub>\<sigma> _" [85,0,0,86] 86)
where "P |a|b|\<^sub>\<sigma> Q \<equiv> P \<parallel>\<^bsub>M[a|b]\<^sub>\<sigma>\<^esub> Q"

lemma StateParallel_commute: "a \<bowtie> b \<Longrightarrow> P |a|b|\<^sub>\<sigma> Q = Q |b|a|\<^sub>\<sigma> P"
  by (metis par_by_merge_commute_swap swap_StateMerge)

lemma StateParallel_form:
  "P |a|b|\<^sub>\<sigma> Q = (\<^bold>\<exists> (st\<^sub>0, st\<^sub>1) \<bullet> P\<lbrakk>\<guillemotleft>st\<^sub>0\<guillemotright>/$\<^bold>v\<acute>\<rbrakk> \<and> Q\<lbrakk>\<guillemotleft>st\<^sub>1\<guillemotright>/$\<^bold>v\<acute>\<rbrakk> \<and> $\<^bold>v\<acute> =\<^sub>u ($\<^bold>v \<oplus> \<guillemotleft>st\<^sub>0\<guillemotright> on &a) \<oplus> \<guillemotleft>st\<^sub>1\<guillemotright> on &b)"
  by (rel_auto)

lemma StateParallel_form':
  assumes "vwb_lens a" "vwb_lens b" "a \<bowtie> b"
  shows "P |a|b|\<^sub>\<sigma> Q = {&a,&b}:[(P \<restriction>\<^sub>v {$\<^bold>v,$a\<acute>}) \<and> (Q \<restriction>\<^sub>v {$\<^bold>v,$b\<acute>})]"
  using assms
  apply (simp add: StateParallel_form, rel_auto)
     apply (metis vwb_lens_wb wb_lens_axioms_def wb_lens_def)
    apply (metis vwb_lens_wb wb_lens.get_put)
   apply (simp add: lens_indep_comm)
  apply (metis (no_types, opaque_lifting) lens_indep_comm vwb_lens_wb wb_lens_def weak_lens.put_get)
  done

text \<open> We can frame all the variables that the parallel operator refers to \<close>

lemma StateParallel_frame:
  assumes "vwb_lens a" "vwb_lens b" "a \<bowtie> b"
  shows "{&a,&b}:[P |a|b|\<^sub>\<sigma> Q] = P |a|b|\<^sub>\<sigma> Q"
  using assms
  apply (simp add: StateParallel_form, rel_auto)
  using lens_indep_comm apply fastforce+
  done

text \<open> Parallel Hoare logic rule. This employs something similar to separating conjunction in
  the postcondition, but we explicitly require that the two conjuncts only refer to variables
  on the left and right of the parallel composition explicitly. \<close>

theorem StateParallel_hoare [hoare]:
  assumes "\<lbrace>c\<rbrace>P\<lbrace>d\<^sub>1\<rbrace>\<^sub>u" "\<lbrace>c\<rbrace>Q\<lbrace>d\<^sub>2\<rbrace>\<^sub>u" "a \<bowtie> b" "a \<natural> d\<^sub>1" "b \<natural> d\<^sub>2"
  shows "\<lbrace>c\<rbrace>P |a|b|\<^sub>\<sigma> Q\<lbrace>d\<^sub>1 \<and> d\<^sub>2\<rbrace>\<^sub>u"
proof -
  \<comment> \<open> Parallelise the specification \<close>
  from assms(4,5)
  have 1:"(\<lceil>c\<rceil>\<^sub>< \<Rightarrow> \<lceil>d\<^sub>1 \<and> d\<^sub>2\<rceil>\<^sub>>) \<sqsubseteq> (\<lceil>c\<rceil>\<^sub>< \<Rightarrow> \<lceil>d\<^sub>1\<rceil>\<^sub>>) |a|b|\<^sub>\<sigma> (\<lceil>c\<rceil>\<^sub>< \<Rightarrow> \<lceil>d\<^sub>2\<rceil>\<^sub>>)" (is "?lhs \<sqsubseteq> ?rhs")
    by (simp add: StateParallel_form, rel_auto, metis assms(3) lens_indep_comm)
  \<comment> \<open> Prove Hoare rule by monotonicity of parallelism \<close>
  have 2:"?rhs \<sqsubseteq> P |a|b|\<^sub>\<sigma> Q"
  proof (rule par_by_merge_mono)
    show "(\<lceil>c\<rceil>\<^sub>< \<Rightarrow> \<lceil>d\<^sub>1\<rceil>\<^sub>>) \<sqsubseteq> P"
      using assms(1) hoare_r_def by auto
    show "(\<lceil>c\<rceil>\<^sub>< \<Rightarrow> \<lceil>d\<^sub>2\<rceil>\<^sub>>) \<sqsubseteq> Q"
      using assms(2) hoare_r_def by auto
  qed
  show ?thesis
    unfolding hoare_r_def using 1 2 order_trans by auto
qed

text \<open> Specialised version of the above law where an invariant expression referring to variables
  outside the frame is preserved. \<close>

theorem StateParallel_frame_hoare [hoare]:
  assumes "vwb_lens a" "vwb_lens b" "a \<bowtie> b" "a \<natural> d\<^sub>1" "b \<natural> d\<^sub>2" "a \<sharp> c\<^sub>1" "b \<sharp> c\<^sub>1" "\<lbrace>c\<^sub>1 \<and> c\<^sub>2\<rbrace>P\<lbrace>d\<^sub>1\<rbrace>\<^sub>u" "\<lbrace>c\<^sub>1 \<and> c\<^sub>2\<rbrace>Q\<lbrace>d\<^sub>2\<rbrace>\<^sub>u"
  shows "\<lbrace>c\<^sub>1 \<and> c\<^sub>2\<rbrace>P |a|b|\<^sub>\<sigma> Q\<lbrace>c\<^sub>1 \<and> d\<^sub>1 \<and> d\<^sub>2\<rbrace>\<^sub>u"
proof -
  have "\<lbrace>c\<^sub>1 \<and> c\<^sub>2\<rbrace>{&a,&b}:[P |a|b|\<^sub>\<sigma> Q]\<lbrace>c\<^sub>1 \<and> d\<^sub>1 \<and> d\<^sub>2\<rbrace>\<^sub>u"
    by (auto intro!: frame_hoare_r' StateParallel_hoare simp add: assms unrest plus_vwb_lens)
  thus ?thesis
    by (simp add: StateParallel_frame assms)
qed

end


(*
 * Copyright 2023, Proofcraft Pty Ltd
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "L4V-Internal Word Lemmas"

text \<open>
  This is a holding area for Word utility lemmas that are too specific or unpolished for the
  AFP, but which are reusable enough to be collected together for the rest of L4V. New
  utility lemmas that only prove facts about words should be added here (in preference to being
  kept where they were first needed).
\<close>

theory Word_Lemmas_Internal
imports Word_Lemmas More_Word_Operations Many_More Word_Syntax Syntax_Bundles
begin

(* this bundle doesn't survive theory merges from HOL.Main, because these simp/split rules
   are added there, so it may need to be unbundled or included locally more than once
*)
bundle l4v_word_context
begin
  declare bit_0 [simp del]
  declare split_of_bool_asm [split del]
end

unbundle bit_operations_syntax
unbundle bit_projection_infix_syntax
unbundle l4v_word_context

(* Override default word enum code generation setup, so that "value" and "eval"
   work with quantification over word. *)

lemmas shiftl_nat_def = push_bit_eq_mult[of _ a for a::nat, folded shiftl_def]
lemmas shiftr_nat_def = drop_bit_eq_div[of _ a for a::nat, folded shiftr_def]

declare bit_simps[simp]
lemmas bit_0_numeral[simp] = bit_0[of "numeral w" for w]

lemma signed_ge_zero_scast_eq_ucast:
 "0 <=s x \<Longrightarrow> scast x = ucast x"
  by (simp add: scast_eq_ucast word_sle_msb_le)

(* FIXME: move out of Word_Lib *)
lemma disjCI2:
  "(\<not> P \<Longrightarrow> Q) \<Longrightarrow> P \<or> Q"
  by blast

(* FIXME: move out of Word_Lib *)
lemma nat_diff_diff_le_lhs:
  "a + c - b \<le> d \<Longrightarrow> a - (b - c) \<le> (d :: nat)"
  by arith

lemma is_aligned_obvious_no_wrap':
  "\<lbrakk> is_aligned ptr sz; x = 2 ^ sz - 1 \<rbrakk>
   \<Longrightarrow> ptr \<le> ptr + x"
  by (fastforce simp: field_simps intro: is_aligned_no_overflow)

lemmas add_ge0_weak = add_increasing[where 'a=int and b=0]

lemmas aligned_sub_aligned = Aligned.aligned_sub_aligned'

lemma minus_minus_swap:
  "\<lbrakk> a \<le> c; b \<le> d; b \<le> a; d \<le> c ; (d :: nat) - b = c - a \<rbrakk>
   \<Longrightarrow> a - b = c - d"
  by arith

lemma minus_minus_swap':
  "\<lbrakk> c \<le> a; d \<le> b; b \<le> a; d \<le> c ; (b :: nat) - d = a - c \<rbrakk>
   \<Longrightarrow> a - b = c - d"
  by arith

lemmas word_le_mask_eq = le_mask_imp_and_mask

lemma int_and_leR:
  "0 \<le> b \<Longrightarrow> a AND b \<le> (b :: int)"
  by (rule AND_upper2)

lemma int_and_leL:
  "0 \<le> a \<Longrightarrow> a AND b \<le> (a :: int)"
  by (rule AND_upper1)

lemma if_then_1_else_0:
  "(if P then 1 else 0) = (0 :: 'a :: zero_neq_one) \<longleftrightarrow> \<not>P"
  by (simp split: if_split)

lemma if_then_0_else_1:
  "(if P then 0 else 1) = (0 :: 'a :: zero_neq_one) \<longleftrightarrow> P"
  by simp

lemmas if_then_simps = if_then_0_else_1 if_then_1_else_0

lemma createNewCaps_guard:
  fixes x :: "'a :: len word"
  shows "\<lbrakk> unat x = c; b < 2 ^ LENGTH('a) \<rbrakk>
         \<Longrightarrow> (n < of_nat b \<and> n < x) = (n < of_nat (min (min b c) c))"
  by (metis (no_types) min_less_iff_conj nat_neq_iff unat_less_helper unat_ucast_less_no_overflow
                       unsigned_less word_unat.Rep_inverse)

lemma bits_2_subtract_ineq:
  "i < (n :: ('a :: len) word)
   \<Longrightarrow> 2 ^ bits + 2 ^ bits * unat (n - (1 + i)) = unat (n - i) * 2 ^ bits"
  apply (simp add: unat_sub word_minus_one_le_leq)
  apply (subst unatSuc)
   apply clarsimp
   apply unat_arith
  apply (simp only: mult_Suc_right[symmetric])
  apply (rule trans[OF mult.commute], rule arg_cong2[where f="(*)"], simp_all)
  apply (simp add: word_less_nat_alt)
  done

lemmas double_neg_mask = neg_mask_combine

lemmas int_unat = uint_nat[symmetric]

lemmas word_sub_mono3 = word_plus_mcs_4'

lemma shift_distinct_helper:
  "\<lbrakk> (x :: 'a :: len word) < bnd; y < bnd; x \<noteq> y; x << n = y << n; n < LENGTH('a);
     bnd - 1 \<le> 2 ^ (LENGTH('a) - n) - 1 \<rbrakk>
   \<Longrightarrow> P"
  apply (cases "n = 0")
   apply simp
  apply (drule word_plus_mono_right[where x=1])
   apply simp_all
   apply (subst word_le_sub1)
    apply (rule power_not_zero)
    apply simp
   apply simp
  apply (drule(1) order_less_le_trans)+
  apply (clarsimp simp: bang_eq)
  apply (drule_tac x="na + n" in spec)
  apply (simp add: nth_shiftl)
  apply (case_tac "na + n < LENGTH('a)", simp_all)
  apply safe
   apply (drule(1) nth_bounded)
    apply simp
   apply simp
  apply (drule(1) nth_bounded)
   apply simp
  apply simp
  done

lemma of_nat_shift_distinct_helper:
  "\<lbrakk> x < bnd; y < bnd; x \<noteq> y; (of_nat x :: 'a :: len word) << n = of_nat y << n;
     n < LENGTH('a); bnd \<le> 2 ^ (LENGTH('a) - n) \<rbrakk>
   \<Longrightarrow> P"
  apply (cases "n = 0")
   apply (simp add: word_unat.Abs_inject unats_def)
  apply (subgoal_tac "bnd < 2 ^ LENGTH('a)")
   apply (erule(1) shift_distinct_helper[rotated, rotated, rotated])
      defer
      apply (erule(1) of_nat_mono_maybe[rotated])
     apply (erule(1) of_nat_mono_maybe[rotated])
    apply (simp add: word_unat.Abs_inject unats_def)
   apply (erule order_le_less_trans)
   apply (rule power_strict_increasing)
    apply simp
   apply simp
  apply (fastforce simp: unat_of_nat_minus_1 word_less_nat_alt)
  done

lemmas pre_helper2 = add_mult_in_mask_range[folded add_mask_fold]

lemma ptr_add_distinct_helper:
  "\<lbrakk> ptr_add (p :: 'a :: len word) (x * 2 ^ n) = ptr_add p (y * 2 ^ n); x \<noteq> y;
     x < bnd; y < bnd; n < LENGTH('a);
     bnd \<le> 2 ^ (LENGTH('a) - n) \<rbrakk>
   \<Longrightarrow> P"
  apply (clarsimp simp: ptr_add_def word_unat_power[symmetric]
                        shiftl_t2n[symmetric, simplified mult.commute])
  using of_nat_shift_distinct_helper
  by blast

lemma unat_sub_le_strg:
  "unat v \<le> v2 \<and> x \<le> v \<and> y \<le> v \<and> y < (x :: ('a :: len) word)
    \<longrightarrow> unat (x + (- 1 - y)) \<le> v2"
  apply clarsimp
  apply (erule order_trans[rotated])
  apply (fold word_le_nat_alt)
  apply (rule order_trans[rotated], assumption)
  apply (rule order_trans[rotated], rule word_sub_le[where y="y + 1"])
   apply (erule Word.inc_le)
  apply (simp add: field_simps)
  done

lemma multi_lessD:
  "\<lbrakk> (a :: nat) * b < c; 0 < a; 0 < b \<rbrakk>
   \<Longrightarrow> a < c \<and> b < c"
  by (cases a, simp_all,cases b,simp_all)

lemmas leq_high_bits_shiftr_low_bits_leq_bits =
  leq_high_bits_shiftr_low_bits_leq_bits_mask[unfolded mask_2pm1[of high_bits]]

lemmas unat_le_helper = word_unat_less_le

lemmas word_of_nat_plus = of_nat_add[where 'a="'a :: len word"]
lemmas word_of_nat_minus = of_nat_diff[where 'a="'a :: len word"]

(* this is a bit deceptive: 2 ^ len.. = 0, so really this is relying on 'word_n1_ge': ptr \<le> -1 *)
lemma word_up_bound:
  "(ptr :: 'a :: len word) \<le> 2 ^ LENGTH('a) - 1 "
  by auto

lemma base_length_minus_one_inequality:
  assumes foo: "wbase \<le> 2 ^ sz - 1"
    "1 \<le> (wlength :: ('a :: len) word)"
    "wlength \<le> 2 ^ sz - wbase"
    "sz < LENGTH ('a)"
  shows "wbase \<le> wbase + wlength - 1"
proof -

  note sz_less = power_strict_increasing[OF foo(4), where a=2]

  from foo have plus: "unat wbase + unat wlength < 2 ^ LENGTH('a)"
    apply -
    apply (rule order_le_less_trans[rotated], rule sz_less, simp)
    apply (simp add: unat_arith_simps split: if_split_asm)
    done

  from foo show ?thesis
   by (simp add: unat_arith_simps plus)
qed

lemmas from_bool_to_bool_and_1 = from_to_bool_last_bit[where x=r for r]

lemmas max_word_neq_0 = max_word_not_0

lemmas word_le_p2m1 = word_up_bound[where ptr=w for w]

lemma inj_ucast:
  "\<lbrakk> uc = ucast; is_up uc \<rbrakk>
   \<Longrightarrow> inj uc"
  using down_ucast_inj is_up_down by blast

lemma ucast_eq_0[OF refl]:
  "\<lbrakk> c = ucast; is_up c \<rbrakk>
   \<Longrightarrow> (c x = 0) = (x = 0)"
  by (metis uint_0_iff uint_up_ucast)

lemmas is_up_compose' = is_up_compose

lemma uint_is_up_compose:
  fixes uc :: "'a :: len word \<Rightarrow> 'b :: len word"
    and uc' :: "'b word \<Rightarrow> 'c :: len sword"
  assumes "uc = ucast"
    and "uc' = ucast"
    and " uuc = uc' \<circ> uc"
  shows "\<lbrakk> is_up uc; is_up uc' \<rbrakk>
         \<Longrightarrow> uint (uuc b) = uint b"
  apply (simp add: assms)
  apply (frule is_up_compose)
   apply (simp_all )
  apply (simp only: Word.uint_up_ucast)
  done

lemma uint_is_up_compose_pred:
  fixes uc :: "'a :: len word \<Rightarrow> 'b :: len word"
    and uc' :: "'b word \<Rightarrow> 'c :: len sword"
  assumes "uc = ucast" and "uc' = ucast" and " uuc = uc' \<circ> uc"
  shows "\<lbrakk> is_up uc; is_up uc' \<rbrakk>
         \<Longrightarrow> P (uint (uuc b)) \<longleftrightarrow> P( uint b)"
  apply (simp add: assms)
  apply (frule is_up_compose)
   apply (simp_all )
  apply (simp only: Word.uint_up_ucast)
 done

lemma is_down_up_sword:
  fixes uc :: "'a :: len word \<Rightarrow> 'b :: len sword"
  shows "\<lbrakk> uc = ucast; LENGTH('a) < LENGTH('b) \<rbrakk>
         \<Longrightarrow> is_up uc = (\<not> is_down uc)"
  by (simp add: target_size source_size  is_up_def is_down_def )

lemma is_not_down_compose:
  fixes uc :: "'a :: len word \<Rightarrow> 'b :: len word"
    and uc' :: "'b word \<Rightarrow> 'c :: len sword"
  shows "\<lbrakk> uc = ucast; uc' = ucast; LENGTH('a) < LENGTH('c) \<rbrakk>
         \<Longrightarrow> \<not> is_down (uc' \<circ> uc)"
  unfolding is_down_def
  by (simp add: Word.target_size Word.source_size)

lemma sint_ucast_uint:
  fixes uc :: "'a :: len word \<Rightarrow> 'b :: len word"
    and uc' :: "'b word \<Rightarrow> 'c :: len sword"
  assumes "uc = ucast" and " uc' = ucast" and "uuc=uc' \<circ> uc "
    and "LENGTH('a) < LENGTH('c signed)"
  shows "\<lbrakk> is_up uc; is_up uc'\<rbrakk>
         \<Longrightarrow> sint (uuc b) = uint b"
  apply (simp add: assms)
  apply (frule is_up_compose')
   apply simp_all
  apply (simp add: ucast_ucast_b)
  apply (rule sint_ucast_eq_uint)
  apply (insert assms)
  apply (simp add: is_down_def target_size source_size)
  done

lemma sint_ucast_uint_pred:
  fixes uc :: "'a :: len word \<Rightarrow> 'b :: len word"
    and uc' :: "'b word \<Rightarrow> 'c :: len sword"
    and uuc :: "'a word \<Rightarrow> 'c sword"
  assumes "uc = ucast" and " uc' = ucast" and "uuc=uc' \<circ> uc "
    and "LENGTH('a) < LENGTH('c )"
  shows "\<lbrakk> is_up uc; is_up uc' \<rbrakk>
         \<Longrightarrow> P (uint b) \<longleftrightarrow> P (sint (uuc b))"
  apply (simp add: assms )
  apply (insert sint_ucast_uint[where uc=uc and uc'=uc' and uuc=uuc and b = b])
  apply (simp add: assms)
 done

lemma sint_uucast_uint_uucast_pred:
  fixes uc :: "'a :: len word \<Rightarrow> 'b :: len word"
    and uc' :: "'b word \<Rightarrow> 'c :: len sword"
  assumes "uc = ucast" and " uc' = ucast" and "uuc=uc' \<circ> uc "
    and "LENGTH('a) < LENGTH('c )"
  shows "\<lbrakk> is_up uc; is_up uc' \<rbrakk>
         \<Longrightarrow> P (uint(uuc b)) \<longleftrightarrow> P (sint (uuc b))"
  apply (simp add: assms )
  apply (insert sint_ucast_uint[where uc=uc and uc'=uc' and uuc=uuc and b = b])
  apply (insert uint_is_up_compose_pred[where uc=uc and uc'=uc' and uuc=uuc and b=b])
  apply (simp add: assms uint_is_up_compose_pred)
 done

lemma unat_minus':
  fixes x :: "'a :: len word"
  shows "x \<noteq> 0 \<Longrightarrow> unat (-x) = 2 ^ LENGTH('a) - unat x"
  by (simp add: unat_minus wsst_TYs(3))

lemma word_nth_neq:
  "n < LENGTH('a) \<Longrightarrow> (~~ x :: 'a :: len word) !! n = (\<not> x !! n)"
  by (simp add: word_size word_ops_nth_size)

lemma word_wrap_of_natD:
  fixes x :: "'a :: len word"
  assumes wraps: "\<not> x \<le> x + of_nat n"
  shows   "\<exists>k. x + of_nat k = 0 \<and> k \<le> n"
proof -
  show ?thesis
  proof (rule exI [where x = "unat (- x)"], intro conjI)
    show "x + of_nat (unat (-x)) = 0"
      by simp
  next
    show "unat (-x) \<le> n"
    proof (subst unat_minus')
      from wraps show "x \<noteq> 0"
        by (rule contrapos_pn, simp add: not_le)
    next
      show "2 ^ LENGTH('a) - unat x \<le> n" using wraps
        apply (simp add: no_olen_add_nat le_diff_conv not_less)
        apply (erule order_trans)
        apply (simp add: unat_of_nat)
        done
    qed
  qed
qed

lemma two_bits_cases:
  "\<lbrakk> LENGTH('a) > 2; (x :: 'a :: len word) && 3 = 0 \<Longrightarrow> P; x && 3 = 1 \<Longrightarrow> P;
     x && 3 = 2 \<Longrightarrow> P; x && 3 = 3 \<Longrightarrow> P \<rbrakk>
   \<Longrightarrow> P"
  apply (frule and_mask_cases[where n=2 and x=x, simplified mask_eq])
  using upt_conv_Cons by auto[1]

lemma zero_OR_eq:
  "y = 0 \<Longrightarrow> (x || y) = x"
  by simp

declare is_aligned_neg_mask_eq[simp]
declare is_aligned_neg_mask_weaken[simp]

lemmas mask_in_range = neg_mask_in_mask_range[folded add_mask_fold]
lemmas aligned_range_offset_mem = aligned_offset_in_range[folded add_mask_fold]
lemmas range_to_bl' = mask_range_to_bl'[folded add_mask_fold]
lemmas range_to_bl = mask_range_to_bl[folded add_mask_fold]
lemmas aligned_ranges_subset_or_disjoint = aligned_mask_range_cases[folded add_mask_fold]
lemmas aligned_range_offset_subset = aligned_mask_range_offset_subset[folded add_mask_fold]
lemmas aligned_diff = aligned_mask_diff[unfolded mask_2pm1]
lemmas aligned_ranges_subset_or_disjoint_coroll = aligned_mask_ranges_disjoint[folded add_mask_fold]
lemmas distinct_aligned_addresses_accumulate = aligned_mask_ranges_disjoint2[folded add_mask_fold]

lemmas bang_big = test_bit_over

lemma unat_and_mask_le:
  "n < LENGTH('a) \<Longrightarrow> unat (x && mask n) \<le> 2^n" for x::"'a::len word"
  by (simp add: and_mask_less' order_less_imp_le unat_less_power)

lemma sign_extend_less_mask_idem:
  "\<lbrakk> w \<le> mask n; n < size w \<rbrakk> \<Longrightarrow> sign_extend n w = w"
  by (simp add: sign_extend_def le_mask_imp_and_mask le_mask_high_bits)

lemma word_and_le:
  "a \<le> c \<Longrightarrow> (a :: 'a :: len word) && b \<le> c"
  by (subst and.commute) (erule word_and_le')

lemma le_smaller_mask:
  "\<lbrakk> x \<le> mask n; n \<le> m \<rbrakk> \<Longrightarrow> x \<le> mask m" for x :: "'a::len word"
  by (erule (1) order.trans[OF _ mask_mono])

(* The strange phrasing and ordering of assumptions is to support using this as a
   conditional simp rule when y is a concrete value. For example, as a simp rule,
   it will solve a goal of the form:
     UCAST(8 \<rightarrow> 32) x < 0x20 \<Longrightarrow> unat x < 32
   This is used in an obscure corner of SimplExportAndRefine. *)
lemma upcast_less_unat_less:
  assumes less: "UCAST('a \<rightarrow> 'b) x < UCAST('a \<rightarrow> 'b) (of_nat y)"
  assumes len: "LENGTH('a::len) \<le> LENGTH('b::len)"
  assumes bound: "y < 2 ^ LENGTH('a)"
  shows "unat x < y"
  by (rule unat_mono[OF less, simplified unat_ucast_up_simp[OF len] unat_of_nat_eq[OF bound]])

lemma word_ctz_max:
  "word_ctz w \<le> size w"
  unfolding word_ctz_def
  by (rule order_trans[OF List.length_takeWhile_le], clarsimp simp: word_size)

lemma scast_of_nat_small:
  "x < 2 ^ (LENGTH('a) - 1) \<Longrightarrow> scast (of_nat x :: 'a :: len word) = (of_nat x :: 'b :: len word)"
  apply transfer
  apply simp
  by (metis One_nat_def id_apply int_eq_sint of_int_eq_id signed_of_nat)

lemmas casts_of_nat_small = ucast_of_nat_small scast_of_nat_small

\<comment>\<open>The conditions under which `takeWhile P xs = take n xs` and `dropWhile P xs = drop n xs`\<close>
definition list_while_len where
  "list_while_len P n xs \<equiv> (\<forall>i. i < n \<longrightarrow> i < length xs \<longrightarrow> P (xs ! i))
                            \<and> (n < length xs \<longrightarrow> \<not> P (xs ! n))"

lemma list_while_len_iff_takeWhile_eq_take:
  "list_while_len P n xs \<longleftrightarrow> takeWhile P xs = take n xs"
  unfolding list_while_len_def
  apply (rule iffI[OF takeWhile_eq_take_P_nth], simp+)
  apply (intro conjI allI impI)
   apply (rule takeWhile_take_has_property_nth, clarsimp)
  apply (drule_tac f=length in arg_cong, simp)
  apply (induct xs arbitrary: n; clarsimp split: if_splits)
  done

lemma list_while_len_exists:
  "\<exists>n. list_while_len P n xs"
  apply (induction xs; simp add: list_while_len_def)
  apply (rename_tac x xs)
  apply (erule exE)
  apply (case_tac "P x")
   apply (rule_tac x="Suc n" in exI, clarsimp)
   apply (case_tac i; simp)
  apply (rule_tac x=0 in exI, simp)
  done

lemma takeWhile_truncate:
  "length (takeWhile P xs) \<le> m
   \<Longrightarrow> takeWhile P (take m xs) = takeWhile P xs"
  apply (cut_tac list_while_len_exists[where P=P and xs=xs], clarsimp)
  apply (case_tac "n \<le> m")
   apply (subgoal_tac "list_while_len P n (take m xs)")
    apply(simp add: list_while_len_iff_takeWhile_eq_take)
   apply (clarsimp simp: list_while_len_def)
  apply (simp add: list_while_len_iff_takeWhile_eq_take)
  done

lemma word_clz_shiftr_1:
  fixes z::"'a::len word"
  assumes wordsize: "1 < LENGTH('a)"
  shows "z \<noteq> 0 \<Longrightarrow> word_clz (z >> 1) = word_clz z + 1"
  supply word_size [simp]
  apply (clarsimp simp: word_clz_def)
  using wordsize apply (subst bl_shiftr, simp)
  apply (subst takeWhile_append2; simp add: wordsize)
  apply (subst takeWhile_truncate)
  using word_clz_nonzero_max[where w=z]
   apply (clarsimp simp: word_clz_def)
   apply simp+
  done

lemma shiftr_Suc:
  fixes x::"'a::len word"
  shows "x >> (Suc n) = x >> n >> 1"
  by (clarsimp simp: shiftr_shiftr)

lemma word_clz_shiftr:
  fixes z :: "'a::len word"
  shows "n < LENGTH('a) \<Longrightarrow> mask n < z \<Longrightarrow> word_clz (z >> n) = word_clz z + n"
  apply (simp add: le_mask_iff Not_eq_iff[THEN iffD2, OF le_mask_iff, simplified not_le]
                   word_neq_0_conv)
  apply (induction n; simp)
  apply (subgoal_tac "0 < z >> n")
   apply (subst shiftr_Suc)
   apply (subst word_clz_shiftr_1; simp)
  apply (clarsimp simp: word_less_nat_alt shiftr_div_2n' div_mult2_eq)
  apply (case_tac "unat z div 2 ^ n = 0"; simp)
  apply (clarsimp simp: div_eq_0_iff)
  done

lemma mask_to_bl_exists_True:
  "x && mask n \<noteq> 0 \<Longrightarrow> \<exists>m. (rev (to_bl x)) ! m \<and> m < n"
  apply (subgoal_tac "\<not>(\<forall>m. m < n \<longrightarrow> \<not>(rev (to_bl x)) ! m)", fastforce)
  apply (intro notI)
  apply (subgoal_tac "x && mask n = 0", clarsimp)
  apply (clarsimp simp: eq_zero_set_bl in_set_conv_nth)
  apply (subst (asm) to_bl_nth, clarsimp simp: word_size)
  apply (clarsimp simp: word_size)
  by (meson nth_mask test_bit_bl word_and_nth)

lemma word_ctz_shiftr_1:
  fixes z::"'a::len word"
  assumes wordsize: "1 < LENGTH('a)"
  shows "z \<noteq> 0 \<Longrightarrow> 1 \<le> word_ctz z \<Longrightarrow> word_ctz (z >> 1) = word_ctz z - 1"
  supply word_size [simp]
  apply (clarsimp simp: word_ctz_def)
  using wordsize apply (subst bl_shiftr, simp)
  apply (simp add: rev_take )
  apply (subgoal_tac
         "length (takeWhile Not (rev (to_bl z))) - Suc 0
          = length (takeWhile Not (take 1 (rev (to_bl z)) @ drop 1 (rev (to_bl z)))) - Suc 0")
   apply (subst (asm) takeWhile_append2)
    apply clarsimp
    apply (case_tac "rev (to_bl z)"; simp)
   apply clarsimp
   apply (subgoal_tac "\<exists>m. (rev (to_bl z)) ! m \<and> m < LENGTH('a)", clarsimp)
    apply (case_tac m)
     apply (case_tac "rev (to_bl z)"; simp)
    apply (subst takeWhile_append1, subst in_set_conv_nth)
      apply (rule_tac x=nat in exI)
      apply (intro conjI)
       apply (clarsimp simp: wordsize)
       using wordsize apply linarith
      apply (rule refl, clarsimp)
    apply simp
   apply (rule mask_to_bl_exists_True, simp)
  apply simp
  done

lemma word_ctz_bound_below_helper:
  fixes x :: "'a::len word"
  assumes sz: "n \<le> LENGTH('a)"
  shows "x && mask n = 0
         \<Longrightarrow> to_bl x = (take (LENGTH('a) - n) (to_bl x) @ replicate n False)"
  apply (subgoal_tac "replicate n False = drop (LENGTH('a) - n) (to_bl x)")
   apply (subgoal_tac "True \<notin> set (drop (LENGTH('a) - n) (to_bl x))")
    apply (drule list_of_false, clarsimp simp: sz)
   apply (drule_tac sym[where t="drop n x" for n x], clarsimp)
  apply (rule sym)
  apply (rule is_aligned_drop; clarsimp simp: is_aligned_mask sz)
  done

lemma word_ctz_bound_below:
  fixes x :: "'a::len word"
  assumes sz[simp]: "n \<le> LENGTH('a)"
  shows "x && mask n = 0 \<Longrightarrow> n \<le> word_ctz x"
  apply (clarsimp simp: word_ctz_def)
  apply (subst word_ctz_bound_below_helper[OF sz]; simp)
  apply (subst takeWhile_append2; clarsimp)
  done

lemma word_ctz_bound_above:
  fixes x :: "'a::len word"
  shows "x && mask n \<noteq> 0 \<Longrightarrow> word_ctz x < n"
  apply (cases "n \<le> LENGTH('a)")
   apply (frule mask_to_bl_exists_True, clarsimp)
   apply (clarsimp simp: word_ctz_def)
   apply (subgoal_tac "m < length ((rev (to_bl x)))")
    apply (subst id_take_nth_drop[where xs="rev (to_bl x)"], assumption)
    apply (subst takeWhile_tail, simp)
    apply (rule order.strict_trans1)
     apply (rule List.length_takeWhile_le)
    apply simp
   apply (erule order.strict_trans2, clarsimp)
  apply (simp add: not_le)
  apply (erule le_less_trans[OF word_ctz_max, simplified word_size])
  done

lemma word_ctz_shiftr:
  fixes z::"'a::len word"
  assumes nz: "z \<noteq> 0"
  shows "n < LENGTH('a) \<Longrightarrow> n \<le> word_ctz z \<Longrightarrow> word_ctz (z >> n) = word_ctz z - n"
  apply (induction n; simp)
  apply (subst shiftr_Suc)
  apply (subst word_ctz_shiftr_1, simp)
    apply clarsimp
    apply (subgoal_tac "word_ctz z < n", clarsimp)
    apply (rule word_ctz_bound_above, clarsimp simp: word_size)
    apply (subst (asm) and_mask_eq_iff_shiftr_0[symmetric], clarsimp simp: nz)
   apply (rule word_ctz_bound_below, clarsimp simp: word_size)
   apply (rule mask_zero)
   apply (rule is_aligned_shiftr, simp add: is_aligned_mask)
   apply (case_tac "z && mask (Suc n) = 0", simp)
   apply (frule word_ctz_bound_above[rotated]; clarsimp simp: word_size)
  apply simp
  done

\<comment> \<open>Useful for solving goals of the form `(w::32 word) <= 0xFFFFFFFF` by simplification\<close>
lemma word_less_max_simp:
  fixes w :: "'a::len word"
  assumes "max_w = -1"
  shows "w \<le> max_w"
  unfolding assms by simp

lemma word_and_mask_word_ctz_zero:
  assumes "l = word_ctz w"
  shows "w && mask l = 0"
  unfolding word_ctz_def assms
  apply (word_eqI)
  apply (drule takeWhile_take_has_property_nth)
  apply (simp add: test_bit_bl)
  done

lemma word_ctz_len_word_and_mask_zero:
  fixes w :: "'a::len word"
  shows "word_ctz w = LENGTH('a) \<Longrightarrow> w = 0"
  by (drule sym, drule word_and_mask_word_ctz_zero, simp)

lemma word_le_1:
  fixes w :: "'a::len word"
  shows "w \<le> 1 \<longleftrightarrow> w = 0 \<or> w = 1"
  using dual_order.antisym lt1_neq0 word_zero_le by blast

lemma less_ucast_ucast_less':
  "x < UCAST('b \<rightarrow> 'a) y \<Longrightarrow> UCAST('a \<rightarrow> 'b) x < y"
  for x :: "'a::len word" and y :: "'b::len word"
  by (clarsimp simp: order.strict_iff_order dual_order.antisym le_ucast_ucast_le)

lemma ucast_up_less_bounded_implies_less_ucast_down':
  assumes len: "LENGTH('a::len) < LENGTH('b::len)"
  assumes bound: "y < 2 ^ LENGTH('a)"
  assumes less: "UCAST('a \<rightarrow> 'b) x < y"
  shows "x < UCAST('b \<rightarrow> 'a) y"
  apply (rule le_less_trans[OF _ ucast_mono[OF less bound]])
  using len by (simp add: is_down ucast_down_ucast_id)

lemma ucast_up_less_bounded_iff_less_ucast_down':
  assumes len: "LENGTH('a::len) < LENGTH('b::len)"
  assumes bound: "y < 2 ^ LENGTH('a)"
  shows "UCAST('a \<rightarrow> 'b) x < y \<longleftrightarrow> x < UCAST('b \<rightarrow> 'a) y"
  apply (rule iffI)
   prefer 2
   apply (simp add: less_ucast_ucast_less')
  using assms by (rule ucast_up_less_bounded_implies_less_ucast_down')

lemma word_of_int_word_of_nat_eqD:
  "\<lbrakk> word_of_int x = (word_of_nat y :: 'a :: len word); 0 \<le> x; x < 2^LENGTH('a); y < 2^LENGTH('a) \<rbrakk>
   \<Longrightarrow> nat x = y"
  by (metis nat_eq_numeral_power_cancel_iff of_nat_inj word_of_int_nat zless2p zless_nat_conj)

lemma ucast_down_0:
  "\<lbrakk> UCAST('a::len \<rightarrow> 'b::len) x = 0; unat x < 2^LENGTH('b) \<rbrakk> \<Longrightarrow> x = 0"
  by (metis Word.of_nat_unat unat_0 unat_eq_of_nat word_unat_eq_iff)

lemma uint_minus_1_eq:
  \<open>uint (- 1 :: 'a word) = 2 ^ LENGTH('a::len) - 1\<close>
  by transfer (simp add: mask_eq_exp_minus_1)

lemma FF_eq_minus_1:
  \<open>0xFF = (- 1 :: 8 word)\<close>
  by simp

lemmas shiftl_t2n' = shiftl_eq_mult[where x="w::'a::len word" for w]

(* candidates for moving to AFP Word_Lib: *)

lemma word_mask_shift_eqI:
  "\<lbrakk> x && mask n = y && mask n; x >> n = y >> n \<rbrakk> \<Longrightarrow> x = y"
  apply (subst mask_or_not_mask[of x n, symmetric])
  apply (subst mask_or_not_mask[of y n, symmetric])
  apply (rule arg_cong2[where f="(OR)"]; blast intro: shiftr_eq_neg_mask_eq)
  done

lemma mask_shiftr_mask_eq:
  "m \<le> m' + n \<Longrightarrow> (w && mask m >> n) && mask m' = w && mask m >> n" for w :: "'a::len word"
  by word_eqI_solve

lemma mask_split_aligned:
  assumes len: "m \<le> a + len_of TYPE('a)"
  assumes align: "is_aligned p a"
  shows "(p && ~~ mask m) + (ucast ((ucast (p && mask m >> a))::'a::len word) << a) = p"
  apply (insert align[simplified is_aligned_nth])
  apply (subst word_plus_and_or_coroll; word_eqI)
  apply (rule iffI)
   apply (erule disjE; clarsimp)
  apply (case_tac "n < m"; case_tac "n < a")
  using len by auto

lemma mask_split_aligned_neg:
  fixes x :: "'a::len word"
  fixes p :: "'b::len word"
  assumes len: "a + len_of TYPE('a) \<le> len_of TYPE('b)"
               "m = a + len_of TYPE('a)"
  assumes x: "x \<noteq> ucast (p && mask m >> a)"
  shows "(p && ~~ mask m) + (ucast x << a) = p \<Longrightarrow> False"
  apply (subst (asm) word_plus_and_or_coroll)
   apply word_eqI
   using len apply linarith
  apply (insert x)
  apply (erule notE)
  apply word_eqI
  subgoal for n
    using len
    apply (clarsimp)
    apply (drule_tac x="n + a" in spec)
    by (clarsimp simp: add.commute)
  done

lemma mask_alignment_ugliness:
  "\<lbrakk> x \<noteq> x + z && ~~ mask m;
     is_aligned (x + z && ~~ mask m) m;
     is_aligned x m;
     \<forall>n \<ge> m. \<not>z !! n\<rbrakk>
  \<Longrightarrow> False"
  apply (erule notE)
  apply (subst word_plus_and_or_coroll; word_eqI)
   apply (meson linorder_not_le)
  by (auto simp: le_def)

lemma word_and_mask_shift_eq_0:
  "n \<le> m \<Longrightarrow> x && mask n >> m = 0"
  by word_eqI

lemma word_mask_and_neg_shift_eq_0:
  "n < m \<Longrightarrow> - (1 << m) && mask n = 0"
  by (metis NOT_mask_AND_mask add.inverse_neutral leD less_imp_le mask_AND_NOT_mask mask_eqs(10)
            shiftl_1 t2n_mask_eq_if)

lemma aligned_mask_plus_bounded:
  "\<lbrakk> is_aligned x m; m < n; n < LENGTH('a) \<rbrakk> \<Longrightarrow> (x && mask n) + 2^m \<le> 2^n" for x :: "'a::len word"
  by (metis add_mask_fold and_mask_less' is_aligned_add_step_le is_aligned_after_mask is_aligned_mask
            leD leI order_less_imp_le t2n_mask_eq_if word_less_sub_1)

lemma aligned_mask_le_mask_minus:
  "\<lbrakk> is_aligned x m; m \<le> n; n < LENGTH('a)\<rbrakk> \<Longrightarrow> x && mask n \<le> mask n - mask m" for x :: "'a::len word"
  by (metis and_mask_less' is_aligned_after_mask is_aligned_neg_mask_eq'
           mask_2pm1 mask_sub neg_mask_mono_le word_less_sub_le)

end


section \<open>The case $y = new\_last$\<close>

theory Y_eq_new_last imports MengerInduction begin

text \<open>
  We may assume @{term "y \<noteq> v1"} now because @{thm ProofStepInduct_NonTrivial_P_k_pre.y_eq_v1_solves}
  shows that @{term "y = v1"} already gives us @{term "Suc sep_size"} many disjoint paths.

  We also assume that we have chosen the previous paths optimally in the sense that the distance
  from @{term new_last} to @{term v1} is minimal.
\<close>

locale ProofStepInduct_y_eq_new_last = ProofStepInduct_NonTrivial_P_k_pre +
  assumes y_neq_v1: "y \<noteq> v1" and y_eq_new_last: "y = new_last"
      and optimal_paths: "\<And>paths' P_new'.
            ProofStepInduct G v0 v1 paths' P_new' sep_size
            \<Longrightarrow> H.distance (last P_new) v1 \<le> H.distance (last P_new') v1"
begin

text \<open>Let @{term R} be a shortest path from @{term new_last} to @{term v1}.\<close>
definition R where "R \<equiv>
  SOME R. new_last \<leadsto>R\<leadsto>\<^bsub>H\<^esub> v1 \<and> (\<forall>R'. new_last \<leadsto>R'\<leadsto>\<^bsub>H\<^esub> v1 \<longrightarrow> length R \<le> length R')"

lemma R: "new_last \<leadsto>R\<leadsto>\<^bsub>H\<^esub> v1" "\<And>R'. new_last \<leadsto>R'\<leadsto>\<^bsub>H\<^esub> v1 \<Longrightarrow> length R \<le> length R'" proof-
  obtain R' where
    R': "new_last \<leadsto>R'\<leadsto>\<^bsub>H\<^esub> v1" "\<And>R''. new_last \<leadsto>R''\<leadsto>\<^bsub>H\<^esub> v1 \<Longrightarrow> length R' \<le> length R''"
    using arg_min_ex[OF new_last_to_v1] unfolding H_def by blast
  then show "new_last \<leadsto>R\<leadsto>\<^bsub>H\<^esub> v1" "\<And>R'. new_last \<leadsto>R'\<leadsto>\<^bsub>H\<^esub> v1 \<Longrightarrow> length R \<le> length R'"
    using someI[of "\<lambda>R. new_last \<leadsto>R\<leadsto>\<^bsub>H\<^esub> v1 \<and> (\<forall>R'. new_last \<leadsto>R'\<leadsto>\<^bsub>H\<^esub> v1 \<longrightarrow> length R \<le> length R')"]
      R_def by auto
qed

lemma v1_in_Q: "\<exists>Q_hit \<in> Q. v1 \<in> set Q_hit" proof-
  obtain xs where "xs \<in> Q" using Q(2) sep_size_not0 by fastforce
  then show ?thesis using Q.paths last_in_set by blast
qed

lemma R_hits_Q: "\<exists>z \<in> set R. Q.hitting_paths z" proof-
  have "v1 \<in> set R" using R(1) last_in_set by (metis path_from_to_def)
  then show ?thesis unfolding Q.hitting_paths_def using v0_neq_v1 by auto
qed

lemma R_decomp_exists:
  obtains R_pre z R_post
    where "R = R_pre @ z # R_post"
      and "Q.hitting_paths z"
      and "\<And>z'. z' \<in> set R_pre \<Longrightarrow> \<not>Q.hitting_paths z'"
  using R_hits_Q split_list_first_prop[of R Q.hitting_paths] by blast

text \<open>
  We open an anonymous context in order to hide all but the final lemma.  This also gives us the
  decomposition of @{term R} whose existence we established above.
\<close>

context fixes R_pre z R_post
  assumes R_decomp: "R = R_pre @ z # R_post"
      and z: "Q.hitting_paths z"
      and z_min: "\<And>z'. z' \<in> set R_pre \<Longrightarrow> \<not>Q.hitting_paths z'"
begin
  private lemma z_neq_v0: "z \<noteq> v0" using z Q.hitting_paths_def by auto

  private lemma z_neq_new_last: "z \<noteq> new_last" proof
    assume "z = new_last"
    then obtain Q_hit where Q_hit: "Q_hit \<in> Q" "new_last \<in> set Q_hit"
      using z Q.hitting_paths_def y_eq_new_last y_neq_v1 by auto
    then have "Q.path Q_hit" by (meson Q.paths path_from_to_def)
    then have "set Q_hit \<subseteq> V - {new_last}" using Q.walk_in_V H_x_def remove_vertex_V by simp
    then show False using Q_hit(2) by blast
  qed

  private lemma R_pre_neq_Nil: "R_pre \<noteq> Nil" using z_neq_new_last R_decomp R(1) by auto

  private lemma z_closer_than_new_last: "H.distance z v1 < H.distance new_last v1" proof-
    have "H.distance new_last v1 = length R" using H.distance_witness R by auto
    moreover have "z \<leadsto>(z # R_post)\<leadsto>\<^bsub>H\<^esub> v1" using R_decomp R(1)
      by (metis H.walk_decomp(2) distinct_append last_appendR list.sel(1)
          list.simps(3) path_from_to_def)
    moreover have "length R > length (z # R_post)"
      unfolding R_decomp using R_pre_neq_Nil by simp
    ultimately show ?thesis using H.distance_upper_bound by fastforce
  qed

  private definition R'_walk where "R'_walk \<equiv> P_k_pre @ R_pre @ [z]"

  private lemma R'_walk_not_Nil: "R'_walk \<noteq> Nil" using R'_walk_def R(1) by simp

  private lemma R'_walk_no_Q: "\<lbrakk> v \<in> set R'_walk; v \<noteq> z \<rbrakk> \<Longrightarrow> \<not>Q.hitting_paths v" proof-
    fix v assume "v \<in> set R'_walk" "v \<noteq> z"
    moreover have "v \<in> set P_k_pre \<Longrightarrow> \<not>Q.hitting_paths v"
      using Q.hitting_paths_def hitting_Q_or_new_last_def y_min v1_in_Q by auto
    moreover have "v \<in> set R_pre \<Longrightarrow> \<not>Q.hitting_paths v" using z_min by simp
    ultimately show "\<not>Q.hitting_paths v" unfolding R'_walk_def using R'_walk_def by auto
  qed

  text \<open>
    The original proof goes like this:
    ``Let @{term z} be the first vertex of @{term R} on some path in @{term Q}.
    Then the distance in @{term "H"} from @{term z} to @{term v1} is less than the distance
    from @{term new_last} to @{term v1}.  This contradicts the choice of @{term paths} and
    @{term P_new}.''

    It does not say exactly why it contradicts the choice of @{term paths} and @{term P_new}.
    It seems we can choose @{term Q} together with @{term R'_walk} as our new paths plus
    extrapath. But this seems to be wrong because we cannot show that @{term R'_walk} is a path:
    @{term P_k_pre} and @{term R_pre} could intersect.

    So we use @{thm walk_to_path} to transform @{term R'_walk} into a path @{term R'}.
\<close>
  private definition R' where
    "R' \<equiv> SOME R'. hd (tl R'_walk) \<leadsto>R'\<leadsto> z \<and> set R' \<subseteq> set (tl R'_walk)"

  private lemma R': "hd (tl R'_walk) \<leadsto>R'\<leadsto> z" "set R' \<subseteq> set (tl R'_walk)" proof-
    have "tl R'_walk \<noteq> Nil" by (simp add: P_k_pre_not_Nil R'_walk_def)
    moreover have "last R'_walk = z" unfolding R'_walk_def by simp
    moreover have "walk (tl R'_walk)"
      by (metis (no_types, lifting) path_from_toE walk_tl H_def P_k_decomp R'_walk_def R(1)
          R_decomp path_P_k y_eq_new_last hd_append list.sel(1) list.simps(3) path_decomp'
          remove_vertex_path_from_to_add walk_comp walk_decomp(1) walk_last_edge)
    ultimately obtain R'' where "hd (tl R'_walk) \<leadsto>R''\<leadsto> z" "set R'' \<subseteq> set (tl R'_walk)"
      using walk_to_path[of "tl R'_walk" "hd (tl R'_walk)" z] last_tl by force
    then show "hd (tl R'_walk) \<leadsto>R'\<leadsto> z" "set R' \<subseteq> set (tl R'_walk)" unfolding R'_def
      using someI[of "\<lambda>R'. hd (tl R'_walk) \<leadsto>R'\<leadsto> z \<and> set R' \<subseteq> set (tl R'_walk)"] by auto
  qed

  private lemma hd_R': "hd R' = hd (tl P_k)" proof-
    have "hd (tl R'_walk) = hd (tl P_k)" proof (cases)
      assume "tl P_k_pre = Nil"
      then show ?thesis unfolding R'_walk_def using P_k_decomp R(1) P_k_pre_not_Nil y_eq_new_last
        by (metis H.path_from_toE R_decomp hd_append list.sel(1) tl_append2)
    next
      assume "tl P_k_pre \<noteq> Nil"
      then show ?thesis unfolding R'_walk_def using P_k_pre_not_Nil by (simp add: P_k_decomp)
    qed
    then show ?thesis using R'(1) by auto
  qed

  private lemma R'_no_Q: "\<lbrakk> v \<in> set R'; v \<noteq> z \<rbrakk> \<Longrightarrow> \<not>Q.hitting_paths v"
    using R'_walk_no_Q by (meson R'(2) R'_walk_not_Nil list.set_sel(2) subsetCE)

  private lemma v0_R'_path: "v0 \<leadsto>(v0 # R')\<leadsto> z" proof-
    have "v0\<rightarrow>hd R'" using hd_R' hd_P_k_v0
      by (metis Nil_is_append_conv P_k_decomp P_k_pre_not_Nil path_P_k list.distinct(1)
          list.exhaust_sel path_first_edge' tl_append2)
    moreover have "v0 \<notin> set R'" proof-
      have "v0 \<notin> set R" using R(1) H_def H.path_in_V remove_vertex_V
        by (simp add: path_from_to_def subset_Diff_insert)
      then have "v0 \<notin> set R_pre" using R_decomp by simp
      moreover have "v0 \<notin> set (tl P_k_pre)" using hd_P_k_v0 path_P_k path_first_vertex
        by (metis P_k_decomp P_k_pre_not_Nil hd_append list.exhaust_sel path_decomp(1))
      ultimately show ?thesis using R'(2) unfolding R'_walk_def
        using P_k_pre_not_Nil z_neq_v0 by auto
    qed
    ultimately show ?thesis using path_cons
      by (metis R'(1) last.simps list.sel(1) list.simps(3) path_from_to_def)
  qed

  private corollary z_last_R': "z = last (v0 # R')" using v0_R'_path by auto

  private lemma z_eq_v1_solves:
    assumes "z = v1"
    shows "\<exists>paths. DisjointPaths G v0 v1 paths \<and> card paths = Suc sep_size"
  proof-
    interpret Q': DisjointPaths G v0 v1 Q
      using DisjointPaths_supergraph H_x_def Q.DisjointPaths_axioms by auto
    have "v0 \<leadsto>(v0 # R')\<leadsto> v1" using assms v0_R'_path by auto
    moreover {
      fix xs v assume "xs \<in> Q" "xs \<noteq> v0 # R'" "v \<in> set xs" "v \<in> set (v0 # R')"
      then have "v = v0 \<or> v = v1" using R'_no_Q Q.hitting_paths_def \<open>z = v1\<close> by auto
    }
    ultimately have "DisjointPaths G v0 v1 (insert (v0 # R') Q)"
      using Q'.DisjointPaths_extend by blast
    moreover have "card (insert (v0 # R') Q) = Suc sep_size"
      by (simp add: P_k(2) Q(2) Q.finite_paths Q.second_vertices_new_path hd_R')
    ultimately show ?thesis by blast
  qed

  private lemma z_neq_v1_solves:
    assumes "z \<noteq> v1"
    shows "\<exists>paths. DisjointPaths G v0 v1 paths \<and> card paths = Suc sep_size"
  proof-
    have "ProofStepInduct G v0 v1 Q (v0 # R') sep_size" proof (rule ProofStepInduct.intro)
      show "DisjointPathsPlusOne G v0 v1 Q (v0 # R')" proof (rule DisjointPathsPlusOne.intro)
        show "DisjointPaths G v0 v1 Q"
          using DisjointPaths_supergraph H_x_def Q.DisjointPaths_axioms by auto
        show "DisjointPathsPlusOne_axioms G v0 v1 Q (v0 # R')" proof
          show "v0 \<leadsto>(v0 # R')\<leadsto> last (v0 # R')" using v0_R'_path by blast
          show "tl (v0 # R') \<noteq> []" using R'(1) by auto
          show "hd (tl (v0 # R')) \<notin> Q.second_vertices" using hd_R' P_k(2) by auto
          show "Q.hitting_paths (last (v0 # R'))" using z z_last_R' by auto
        next
          fix v assume "v \<in> set (butlast (v0 # R'))"
          then show "\<not>Q.hitting_paths v" using R'_no_Q path_from_to_last[OF v0_R'_path]
            by (metis Q.hitting_paths_def in_set_butlastD set_ConsD)
        qed
      qed
      show "ProofStepInduct_axioms Q sep_size" using sep_size_not0 Q(2) by unfold_locales
    qed (insert NoSmallSeparationsInduct_axioms)
    then have "H.distance (last P_new) v1 \<le> H.distance (last (v0 # R')) v1"
      using H_def optimal_paths[of Q "v0 # R'"] by blast
    then have False using z_last_R' new_last_def z_closer_than_new_last by simp
    then show ?thesis by blast
  qed

  corollary with_optimal_paths_solves':
    shows "\<exists>paths. DisjointPaths G v0 v1 paths \<and> card paths = Suc sep_size"
    using optimal_paths z_eq_v1_solves z_neq_v1_solves by blast
end \<comment> \<open>anonymous context\<close>

corollary with_optimal_paths_solves:
  "\<exists>paths. DisjointPaths G v0 v1 paths \<and> card paths = Suc sep_size"
  using optimal_paths with_optimal_paths_solves' R_decomp_exists by blast

end \<comment> \<open>locale @{locale ProofStepInduct_y_eq_new_last}\<close>
end