(*  Title:      HOL/SET_Protocol/Message_SET.thy
    Author:     Giampaolo Bella
    Author:     Fabio Massacci
    Author:     Lawrence C Paulson
*)

section\<open>The Message Theory, Modified for SET\<close>

theory Message_SET
imports Main "HOL-Library.Nat_Bijection"
begin

subsection\<open>General Lemmas\<close>

text\<open>Needed occasionally with \<open>spy_analz_tac\<close>, e.g. in
     \<open>analz_insert_Key_newK\<close>\<close>

lemma Un_absorb3 [simp] : "A \<union> (B \<union> A) = B \<union> A"
by blast

text\<open>Collapses redundant cases in the huge protocol proofs\<close>
lemmas disj_simps = disj_comms disj_left_absorb disj_assoc

text\<open>Effective with assumptions like \<^term>\<open>K \<notin> range pubK\<close> and
   \<^term>\<open>K \<notin> invKey`range pubK\<close>\<close>
lemma notin_image_iff: "(y \<notin> f`I) = (\<forall>i\<in>I. f i \<noteq> y)"
by blast

text\<open>Effective with the assumption \<^term>\<open>KK \<subseteq> - (range(invKey o pubK))\<close>\<close>
lemma disjoint_image_iff: "(A \<subseteq> - (f`I)) = (\<forall>i\<in>I. f i \<notin> A)"
by blast

type_synonym key = nat

consts
  all_symmetric :: bool        \<comment> \<open>true if all keys are symmetric\<close>
  invKey        :: "key\<Rightarrow>key"  \<comment> \<open>inverse of a symmetric key\<close>

specification (invKey)
  invKey [simp]: "invKey (invKey K) = K"
  invKey_symmetric: "all_symmetric \<longrightarrow> invKey = id"
    by (rule exI [of _ id], auto)

text\<open>The inverse of a symmetric key is itself; that of a public key
      is the private key and vice versa\<close>

definition symKeys :: "key set" where
  "symKeys == {K. invKey K = K}"

text\<open>Agents. We allow any number of certification authorities, cardholders
            merchants, and payment gateways.\<close>
datatype
  agent = CA nat | Cardholder nat | Merchant nat | PG nat | Spy

text\<open>Messages\<close>
datatype
     msg = Agent  agent     \<comment> \<open>Agent names\<close>
         | Number nat       \<comment> \<open>Ordinary integers, timestamps, ...\<close>
         | Nonce  nat       \<comment> \<open>Unguessable nonces\<close>
         | Pan    nat       \<comment> \<open>Unguessable Primary Account Numbers (??)\<close>
         | Key    key       \<comment> \<open>Crypto keys\<close>
         | Hash   msg       \<comment> \<open>Hashing\<close>
         | MPair  msg msg   \<comment> \<open>Compound messages\<close>
         | Crypt  key msg   \<comment> \<open>Encryption, public- or shared-key\<close>

(*Concrete syntax: messages appear as \<open>\<lbrace>A,B,NA\<rbrace>\<close>, etc...*)
syntax
  "_MTuple"      :: "['a, args] \<Rightarrow> 'a * 'b"       ("(2\<lbrace>_,/ _\<rbrace>)")
translations
  "\<lbrace>x, y, z\<rbrace>"   == "\<lbrace>x, \<lbrace>y, z\<rbrace>\<rbrace>"
  "\<lbrace>x, y\<rbrace>"      == "CONST MPair x y"

definition nat_of_agent :: "agent \<Rightarrow> nat" where
   "nat_of_agent == case_agent (curry prod_encode 0)
                               (curry prod_encode 1)
                               (curry prod_encode 2)
                               (curry prod_encode 3)
                               (prod_encode (4,0))"
    \<comment> \<open>maps each agent to a unique natural number, for specifications\<close>

text\<open>The function is indeed injective\<close>
lemma inj_nat_of_agent: "inj nat_of_agent"
by (simp add: nat_of_agent_def inj_on_def curry_def prod_encode_eq split: agent.split)

definition
  (*Keys useful to decrypt elements of a message set*)
  keysFor :: "msg set \<Rightarrow> key set"
  where "keysFor H = invKey ` {K. \<exists>X. Crypt K X \<in> H}"

subsubsection\<open>Inductive definition of all "parts" of a message.\<close>

inductive_set
  parts :: "msg set \<Rightarrow> msg set"
  for H :: "msg set"
  where
    Inj [intro]:               "X \<in> H ==> X \<in> parts H"
  | Fst:         "\<lbrace>X,Y\<rbrace>   \<in> parts H ==> X \<in> parts H"
  | Snd:         "\<lbrace>X,Y\<rbrace>   \<in> parts H ==> Y \<in> parts H"
  | Body:        "Crypt K X \<in> parts H ==> X \<in> parts H"

(*Monotonicity*)
lemma parts_mono: "G\<subseteq>H ==> parts(G) \<subseteq> parts(H)"
apply auto
apply (erule parts.induct)
apply (auto dest: Fst Snd Body)
done

subsubsection\<open>Inverse of keys\<close>

(*Equations hold because constructors are injective; cannot prove for all f*)
lemma Key_image_eq [simp]: "(Key x \<in> Key`A) = (x\<in>A)"
by auto

lemma Nonce_Key_image_eq [simp]: "(Nonce x \<notin> Key`A)"
by auto

lemma Cardholder_image_eq [simp]: "(Cardholder x \<in> Cardholder`A) = (x \<in> A)"
by auto

lemma CA_image_eq [simp]: "(CA x \<in> CA`A) = (x \<in> A)"
by auto

lemma Pan_image_eq [simp]: "(Pan x \<in> Pan`A) = (x \<in> A)"
by auto

lemma Pan_Key_image_eq [simp]: "(Pan x \<notin> Key`A)"
by auto

lemma Nonce_Pan_image_eq [simp]: "(Nonce x \<notin> Pan`A)"
by auto

lemma invKey_eq [simp]: "(invKey K = invKey K') = (K=K')"
apply safe
apply (drule_tac f = invKey in arg_cong, simp)
done

subsection\<open>keysFor operator\<close>

lemma keysFor_empty [simp]: "keysFor {} = {}"
by (unfold keysFor_def, blast)

lemma keysFor_Un [simp]: "keysFor (H \<union> H') = keysFor H \<union> keysFor H'"
by (unfold keysFor_def, blast)

lemma keysFor_UN [simp]: "keysFor (\<Union>i\<in>A. H i) = (\<Union>i\<in>A. keysFor (H i))"
by (unfold keysFor_def, blast)

(*Monotonicity*)
lemma keysFor_mono: "G\<subseteq>H ==> keysFor(G) \<subseteq> keysFor(H)"
by (unfold keysFor_def, blast)

lemma keysFor_insert_Agent [simp]: "keysFor (insert (Agent A) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Nonce [simp]: "keysFor (insert (Nonce N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Number [simp]: "keysFor (insert (Number N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Key [simp]: "keysFor (insert (Key K) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Pan [simp]: "keysFor (insert (Pan A) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Hash [simp]: "keysFor (insert (Hash X) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_MPair [simp]: "keysFor (insert \<lbrace>X,Y\<rbrace> H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Crypt [simp]:
    "keysFor (insert (Crypt K X) H) = insert (invKey K) (keysFor H)"
by (unfold keysFor_def, auto)

lemma keysFor_image_Key [simp]: "keysFor (Key`E) = {}"
by (unfold keysFor_def, auto)

lemma Crypt_imp_invKey_keysFor: "Crypt K X \<in> H ==> invKey K \<in> keysFor H"
by (unfold keysFor_def, blast)

subsection\<open>Inductive relation "parts"\<close>

lemma MPair_parts:
     "[| \<lbrace>X,Y\<rbrace> \<in> parts H;
         [| X \<in> parts H; Y \<in> parts H |] ==> P |] ==> P"
by (blast dest: parts.Fst parts.Snd)

declare MPair_parts [elim!]  parts.Body [dest!]
text\<open>NB These two rules are UNSAFE in the formal sense, as they discard the
     compound message.  They work well on THIS FILE.
  \<open>MPair_parts\<close> is left as SAFE because it speeds up proofs.
  The Crypt rule is normally kept UNSAFE to avoid breaking up certificates.\<close>

lemma parts_increasing: "H \<subseteq> parts(H)"
by blast

lemmas parts_insertI = subset_insertI [THEN parts_mono, THEN subsetD]

lemma parts_empty [simp]: "parts{} = {}"
apply safe
apply (erule parts.induct, blast+)
done

lemma parts_emptyE [elim!]: "X\<in> parts{} ==> P"
by simp

(*WARNING: loops if H = {Y}, therefore must not be repeated!*)
lemma parts_singleton: "X\<in> parts H ==> \<exists>Y\<in>H. X\<in> parts {Y}"
by (erule parts.induct, fast+)

subsubsection\<open>Unions\<close>

lemma parts_Un_subset1: "parts(G) \<union> parts(H) \<subseteq> parts(G \<union> H)"
by (intro Un_least parts_mono Un_upper1 Un_upper2)

lemma parts_Un_subset2: "parts(G \<union> H) \<subseteq> parts(G) \<union> parts(H)"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_Un [simp]: "parts(G \<union> H) = parts(G) \<union> parts(H)"
by (intro equalityI parts_Un_subset1 parts_Un_subset2)

lemma parts_insert: "parts (insert X H) = parts {X} \<union> parts H"
apply (subst insert_is_Un [of _ H])
apply (simp only: parts_Un)
done

(*TWO inserts to avoid looping.  This rewrite is better than nothing.
  Not suitable for Addsimps: its behaviour can be strange.*)
lemma parts_insert2:
     "parts (insert X (insert Y H)) = parts {X} \<union> parts {Y} \<union> parts H"
apply (simp add: Un_assoc)
apply (simp add: parts_insert [symmetric])
done

(*Added to simplify arguments to parts, analz and synth.*)

text\<open>This allows \<open>blast\<close> to simplify occurrences of
  \<^term>\<open>parts(G\<union>H)\<close> in the assumption.\<close>
declare parts_Un [THEN equalityD1, THEN subsetD, THEN UnE, elim!]

lemma parts_insert_subset: "insert X (parts H) \<subseteq> parts(insert X H)"
by (blast intro: parts_mono [THEN [2] rev_subsetD])

subsubsection\<open>Idempotence and transitivity\<close>

lemma parts_partsD [dest!]: "X\<in> parts (parts H) ==> X\<in> parts H"
by (erule parts.induct, blast+)

lemma parts_idem [simp]: "parts (parts H) = parts H"
by blast

lemma parts_trans: "[| X\<in> parts G;  G \<subseteq> parts H |] ==> X\<in> parts H"
by (drule parts_mono, blast)

(*Cut*)
lemma parts_cut:
     "[| Y\<in> parts (insert X G);  X\<in> parts H |] ==> Y\<in> parts (G \<union> H)"
by (erule parts_trans, auto)

lemma parts_cut_eq [simp]: "X\<in> parts H ==> parts (insert X H) = parts H"
by (force dest!: parts_cut intro: parts_insertI)

subsubsection\<open>Rewrite rules for pulling out atomic messages\<close>

lemmas parts_insert_eq_I = equalityI [OF subsetI parts_insert_subset]

lemma parts_insert_Agent [simp]:
     "parts (insert (Agent agt) H) = insert (Agent agt) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Nonce [simp]:
     "parts (insert (Nonce N) H) = insert (Nonce N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Number [simp]:
     "parts (insert (Number N) H) = insert (Number N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Key [simp]:
     "parts (insert (Key K) H) = insert (Key K) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Pan [simp]:
     "parts (insert (Pan A) H) = insert (Pan A) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Hash [simp]:
     "parts (insert (Hash X) H) = insert (Hash X) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Crypt [simp]:
     "parts (insert (Crypt K X) H) =
          insert (Crypt K X) (parts (insert X H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (erule parts.induct)
apply (blast intro: parts.Body)+
done

lemma parts_insert_MPair [simp]:
     "parts (insert \<lbrace>X,Y\<rbrace> H) =
          insert \<lbrace>X,Y\<rbrace> (parts (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (erule parts.induct)
apply (blast intro: parts.Fst parts.Snd)+
done

lemma parts_image_Key [simp]: "parts (Key`N) = Key`N"
apply auto
apply (erule parts.induct, auto)
done

lemma parts_image_Pan [simp]: "parts (Pan`A) = Pan`A"
apply auto
apply (erule parts.induct, auto)
done

(*In any message, there is an upper bound N on its greatest nonce.*)
lemma msg_Nonce_supply: "\<exists>N. \<forall>n. N\<le>n \<longrightarrow> Nonce n \<notin> parts {msg}"
apply (induct_tac "msg")
apply (simp_all (no_asm_simp) add: exI parts_insert2)
(*MPair case: blast_tac works out the necessary sum itself!*)
prefer 2 apply (blast elim!: add_leE)
(*Nonce case*)
apply (rename_tac nat)
apply (rule_tac x = "N + Suc nat" in exI)
apply (auto elim!: add_leE)
done

(* Ditto, for numbers.*)
lemma msg_Number_supply: "\<exists>N. \<forall>n. N\<le>n \<longrightarrow> Number n \<notin> parts {msg}"
apply (induct_tac "msg")
apply (simp_all (no_asm_simp) add: exI parts_insert2)
prefer 2 apply (blast elim!: add_leE)
apply (rename_tac nat)
apply (rule_tac x = "N + Suc nat" in exI, auto)
done

subsection\<open>Inductive relation "analz"\<close>

text\<open>Inductive definition of "analz" -- what can be broken down from a set of
    messages, including keys.  A form of downward closure.  Pairs can
    be taken apart; messages decrypted with known keys.\<close>

inductive_set
  analz :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro,simp] :    "X \<in> H ==> X \<in> analz H"
  | Fst:     "\<lbrace>X,Y\<rbrace> \<in> analz H ==> X \<in> analz H"
  | Snd:     "\<lbrace>X,Y\<rbrace> \<in> analz H ==> Y \<in> analz H"
  | Decrypt [dest]:
             "[|Crypt K X \<in> analz H; Key(invKey K) \<in> analz H|] ==> X \<in> analz H"

(*Monotonicity; Lemma 1 of Lowe's paper*)
lemma analz_mono: "G\<subseteq>H ==> analz(G) \<subseteq> analz(H)"
apply auto
apply (erule analz.induct)
apply (auto dest: Fst Snd)
done

text\<open>Making it safe speeds up proofs\<close>
lemma MPair_analz [elim!]:
     "[| \<lbrace>X,Y\<rbrace> \<in> analz H;
             [| X \<in> analz H; Y \<in> analz H |] ==> P
          |] ==> P"
by (blast dest: analz.Fst analz.Snd)

lemma analz_increasing: "H \<subseteq> analz(H)"
by blast

lemma analz_subset_parts: "analz H \<subseteq> parts H"
apply (rule subsetI)
apply (erule analz.induct, blast+)
done

lemmas analz_into_parts = analz_subset_parts [THEN subsetD]

lemmas not_parts_not_analz = analz_subset_parts [THEN contra_subsetD]

lemma parts_analz [simp]: "parts (analz H) = parts H"
apply (rule equalityI)
apply (rule analz_subset_parts [THEN parts_mono, THEN subset_trans], simp)
apply (blast intro: analz_increasing [THEN parts_mono, THEN subsetD])
done

lemma analz_parts [simp]: "analz (parts H) = parts H"
apply auto
apply (erule analz.induct, auto)
done

lemmas analz_insertI = subset_insertI [THEN analz_mono, THEN [2] rev_subsetD]

subsubsection\<open>General equational properties\<close>

lemma analz_empty [simp]: "analz{} = {}"
apply safe
apply (erule analz.induct, blast+)
done

(*Converse fails: we can analz more from the union than from the
  separate parts, as a key in one might decrypt a message in the other*)
lemma analz_Un: "analz(G) \<union> analz(H) \<subseteq> analz(G \<union> H)"
by (intro Un_least analz_mono Un_upper1 Un_upper2)

lemma analz_insert: "insert X (analz H) \<subseteq> analz(insert X H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsubsection\<open>Rewrite rules for pulling out atomic messages\<close>

lemmas analz_insert_eq_I = equalityI [OF subsetI analz_insert]

lemma analz_insert_Agent [simp]:
     "analz (insert (Agent agt) H) = insert (Agent agt) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Nonce [simp]:
     "analz (insert (Nonce N) H) = insert (Nonce N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Number [simp]:
     "analz (insert (Number N) H) = insert (Number N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Hash [simp]:
     "analz (insert (Hash X) H) = insert (Hash X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

(*Can only pull out Keys if they are not needed to decrypt the rest*)
lemma analz_insert_Key [simp]:
    "K \<notin> keysFor (analz H) ==>
          analz (insert (Key K) H) = insert (Key K) (analz H)"
apply (unfold keysFor_def)
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_MPair [simp]:
     "analz (insert \<lbrace>X,Y\<rbrace> H) =
          insert \<lbrace>X,Y\<rbrace> (analz (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct)
apply (blast intro: analz.Fst analz.Snd)+
done

(*Can pull out enCrypted message if the Key is not known*)
lemma analz_insert_Crypt:
     "Key (invKey K) \<notin> analz H
      ==> analz (insert (Crypt K X) H) = insert (Crypt K X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Pan [simp]:
     "analz (insert (Pan A) H) = insert (Pan A) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma lemma1: "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) \<subseteq>
               insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule_tac x = x in analz.induct, auto)
done

lemma lemma2: "Key (invKey K) \<in> analz H ==>
               insert (Crypt K X) (analz (insert X H)) \<subseteq>
               analz (insert (Crypt K X) H)"
apply auto
apply (erule_tac x = x in analz.induct, auto)
apply (blast intro: analz_insertI analz.Decrypt)
done

lemma analz_insert_Decrypt:
     "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) =
               insert (Crypt K X) (analz (insert X H))"
by (intro equalityI lemma1 lemma2)

(*Case analysis: either the message is secure, or it is not!
  Effective, but can cause subgoals to blow up!
  Use with if_split;  apparently split_tac does not cope with patterns
  such as "analz (insert (Crypt K X) H)" *)
lemma analz_Crypt_if [simp]:
     "analz (insert (Crypt K X) H) =
          (if (Key (invKey K) \<in> analz H)
           then insert (Crypt K X) (analz (insert X H))
           else insert (Crypt K X) (analz H))"
by (simp add: analz_insert_Crypt analz_insert_Decrypt)

(*This rule supposes "for the sake of argument" that we have the key.*)
lemma analz_insert_Crypt_subset:
     "analz (insert (Crypt K X) H) \<subseteq>
           insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule analz.induct, auto)
done

lemma analz_image_Key [simp]: "analz (Key`N) = Key`N"
apply auto
apply (erule analz.induct, auto)
done

lemma analz_image_Pan [simp]: "analz (Pan`A) = Pan`A"
apply auto
apply (erule analz.induct, auto)
done

subsubsection\<open>Idempotence and transitivity\<close>

lemma analz_analzD [dest!]: "X\<in> analz (analz H) ==> X\<in> analz H"
by (erule analz.induct, blast+)

lemma analz_idem [simp]: "analz (analz H) = analz H"
by blast

lemma analz_trans: "[| X\<in> analz G;  G \<subseteq> analz H |] ==> X\<in> analz H"
by (drule analz_mono, blast)

(*Cut; Lemma 2 of Lowe*)
lemma analz_cut: "[| Y\<in> analz (insert X H);  X\<in> analz H |] ==> Y\<in> analz H"
by (erule analz_trans, blast)

(*Cut can be proved easily by induction on
   "Y: analz (insert X H) ==> X: analz H \<longrightarrow> Y: analz H"
*)

(*This rewrite rule helps in the simplification of messages that involve
  the forwarding of unknown components (X).  Without it, removing occurrences
  of X can be very complicated. *)
lemma analz_insert_eq: "X\<in> analz H ==> analz (insert X H) = analz H"
by (blast intro: analz_cut analz_insertI)

text\<open>A congruence rule for "analz"\<close>

lemma analz_subset_cong:
     "[| analz G \<subseteq> analz G'; analz H \<subseteq> analz H'
               |] ==> analz (G \<union> H) \<subseteq> analz (G' \<union> H')"
apply clarify
apply (erule analz.induct)
apply (best intro: analz_mono [THEN subsetD])+
done

lemma analz_cong:
     "[| analz G = analz G'; analz H = analz H'
               |] ==> analz (G \<union> H) = analz (G' \<union> H')"
by (intro equalityI analz_subset_cong, simp_all)

lemma analz_insert_cong:
     "analz H = analz H' ==> analz(insert X H) = analz(insert X H')"
by (force simp only: insert_def intro!: analz_cong)

(*If there are no pairs or encryptions then analz does nothing*)
lemma analz_trivial:
     "[| \<forall>X Y. \<lbrace>X,Y\<rbrace> \<notin> H;  \<forall>X K. Crypt K X \<notin> H |] ==> analz H = H"
apply safe
apply (erule analz.induct, blast+)
done

subsection\<open>Inductive relation "synth"\<close>

text\<open>Inductive definition of "synth" -- what can be built up from a set of
    messages.  A form of upward closure.  Pairs can be built, messages
    encrypted with known keys.  Agent names are public domain.
    Numbers can be guessed, but Nonces cannot be.\<close>

inductive_set
  synth :: "msg set \<Rightarrow> msg set"
  for H :: "msg set"
  where
    Inj    [intro]:   "X \<in> H ==> X \<in> synth H"
  | Agent  [intro]:   "Agent agt \<in> synth H"
  | Number [intro]:   "Number n  \<in> synth H"
  | Hash   [intro]:   "X \<in> synth H ==> Hash X \<in> synth H"
  | MPair  [intro]:   "[|X \<in> synth H;  Y \<in> synth H|] ==> \<lbrace>X,Y\<rbrace> \<in> synth H"
  | Crypt  [intro]:   "[|X \<in> synth H;  Key(K) \<in> H|] ==> Crypt K X \<in> synth H"

(*Monotonicity*)
lemma synth_mono: "G\<subseteq>H ==> synth(G) \<subseteq> synth(H)"
apply auto
apply (erule synth.induct)
apply (auto dest: Fst Snd Body)
done

(*NO Agent_synth, as any Agent name can be synthesized.  Ditto for Number*)
inductive_cases Nonce_synth [elim!]: "Nonce n \<in> synth H"
inductive_cases Key_synth   [elim!]: "Key K \<in> synth H"
inductive_cases Hash_synth  [elim!]: "Hash X \<in> synth H"
inductive_cases MPair_synth [elim!]: "\<lbrace>X,Y\<rbrace> \<in> synth H"
inductive_cases Crypt_synth [elim!]: "Crypt K X \<in> synth H"
inductive_cases Pan_synth   [elim!]: "Pan A \<in> synth H"

lemma synth_increasing: "H \<subseteq> synth(H)"
by blast

subsubsection\<open>Unions\<close>

(*Converse fails: we can synth more from the union than from the
  separate parts, building a compound message using elements of each.*)
lemma synth_Un: "synth(G) \<union> synth(H) \<subseteq> synth(G \<union> H)"
by (intro Un_least synth_mono Un_upper1 Un_upper2)

lemma synth_insert: "insert X (synth H) \<subseteq> synth(insert X H)"
by (blast intro: synth_mono [THEN [2] rev_subsetD])

subsubsection\<open>Idempotence and transitivity\<close>

lemma synth_synthD [dest!]: "X\<in> synth (synth H) ==> X\<in> synth H"
by (erule synth.induct, blast+)

lemma synth_idem: "synth (synth H) = synth H"
by blast

lemma synth_trans: "[| X\<in> synth G;  G \<subseteq> synth H |] ==> X\<in> synth H"
by (drule synth_mono, blast)

(*Cut; Lemma 2 of Lowe*)
lemma synth_cut: "[| Y\<in> synth (insert X H);  X\<in> synth H |] ==> Y\<in> synth H"
by (erule synth_trans, blast)

lemma Agent_synth [simp]: "Agent A \<in> synth H"
by blast

lemma Number_synth [simp]: "Number n \<in> synth H"
by blast

lemma Nonce_synth_eq [simp]: "(Nonce N \<in> synth H) = (Nonce N \<in> H)"
by blast

lemma Crypt_synth_eq [simp]: "Key K \<notin> H ==> (Crypt K X \<in> synth H) = (Crypt K X \<in> H)"
by blast

lemma Pan_synth_eq [simp]: "(Pan A \<in> synth H) = (Pan A \<in> H)"
by blast

lemma keysFor_synth [simp]:
    "keysFor (synth H) = keysFor H \<union> invKey`{K. Key K \<in> H}"
by (unfold keysFor_def, blast)

subsubsection\<open>Combinations of parts, analz and synth\<close>

lemma parts_synth [simp]: "parts (synth H) = parts H \<union> synth H"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct)
apply (blast intro: synth_increasing [THEN parts_mono, THEN subsetD]
                    parts.Fst parts.Snd parts.Body)+
done

lemma analz_analz_Un [simp]: "analz (analz G \<union> H) = analz (G \<union> H)"
apply (intro equalityI analz_subset_cong)+
apply simp_all
done

lemma analz_synth_Un [simp]: "analz (synth G \<union> H) = analz (G \<union> H) \<union> synth G"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct)
prefer 5 apply (blast intro: analz_mono [THEN [2] rev_subsetD])
apply (blast intro: analz.Fst analz.Snd analz.Decrypt)+
done

lemma analz_synth [simp]: "analz (synth H) = analz H \<union> synth H"
apply (cut_tac H = "{}" in analz_synth_Un)
apply (simp (no_asm_use))
done

subsubsection\<open>For reasoning about the Fake rule in traces\<close>

lemma parts_insert_subset_Un: "X\<in> G ==> parts(insert X H) \<subseteq> parts G \<union> parts H"
by (rule subset_trans [OF parts_mono parts_Un_subset2], blast)

(*More specifically for Fake.  Very occasionally we could do with a version
  of the form  parts{X} \<subseteq> synth (analz H) \<union> parts H *)
lemma Fake_parts_insert: "X \<in> synth (analz H) ==>
      parts (insert X H) \<subseteq> synth (analz H) \<union> parts H"
apply (drule parts_insert_subset_Un)
apply (simp (no_asm_use))
apply blast
done

lemma Fake_parts_insert_in_Un:
     "[|Z \<in> parts (insert X H);  X \<in> synth (analz H)|]
      ==> Z \<in>  synth (analz H) \<union> parts H"
by (blast dest: Fake_parts_insert [THEN subsetD, dest])

(*H is sometimes (Key ` KK \<union> spies evs), so can't put G=H*)
lemma Fake_analz_insert:
     "X\<in> synth (analz G) ==>
      analz (insert X H) \<subseteq> synth (analz G) \<union> analz (G \<union> H)"
apply (rule subsetI)
apply (subgoal_tac "x \<in> analz (synth (analz G) \<union> H) ")
prefer 2 apply (blast intro: analz_mono [THEN [2] rev_subsetD] analz_mono [THEN synth_mono, THEN [2] rev_subsetD])
apply (simp (no_asm_use))
apply blast
done

lemma analz_conj_parts [simp]:
     "(X \<in> analz H \<and> X \<in> parts H) = (X \<in> analz H)"
by (blast intro: analz_subset_parts [THEN subsetD])

lemma analz_disj_parts [simp]:
     "(X \<in> analz H | X \<in> parts H) = (X \<in> parts H)"
by (blast intro: analz_subset_parts [THEN subsetD])

(*Without this equation, other rules for synth and analz would yield
  redundant cases*)
lemma MPair_synth_analz [iff]:
     "(\<lbrace>X,Y\<rbrace> \<in> synth (analz H)) =
      (X \<in> synth (analz H) \<and> Y \<in> synth (analz H))"
by blast

lemma Crypt_synth_analz:
     "[| Key K \<in> analz H;  Key (invKey K) \<in> analz H |]
       ==> (Crypt K X \<in> synth (analz H)) = (X \<in> synth (analz H))"
by blast

lemma Hash_synth_analz [simp]:
     "X \<notin> synth (analz H)
      ==> (Hash\<lbrace>X,Y\<rbrace> \<in> synth (analz H)) = (Hash\<lbrace>X,Y\<rbrace> \<in> analz H)"
by blast

(*We do NOT want Crypt... messages broken up in protocols!!*)
declare parts.Body [rule del]

text\<open>Rewrites to push in Key and Crypt messages, so that other messages can
    be pulled out using the \<open>analz_insert\<close> rules\<close>

lemmas pushKeys =
  insert_commute [of "Key K" "Agent C"]
  insert_commute [of "Key K" "Nonce N"]
  insert_commute [of "Key K" "Number N"]
  insert_commute [of "Key K" "Pan PAN"]
  insert_commute [of "Key K" "Hash X"]
  insert_commute [of "Key K" "MPair X Y"]
  insert_commute [of "Key K" "Crypt X K'"]
  for K C N PAN X Y K'

lemmas pushCrypts =
  insert_commute [of "Crypt X K" "Agent C"]
  insert_commute [of "Crypt X K" "Nonce N"]
  insert_commute [of "Crypt X K" "Number N"]
  insert_commute [of "Crypt X K" "Pan PAN"]
  insert_commute [of "Crypt X K" "Hash X'"]
  insert_commute [of "Crypt X K" "MPair X' Y"]
  for X K C N PAN X' Y

text\<open>Cannot be added with \<open>[simp]\<close> -- messages should not always be
  re-ordered.\<close>
lemmas pushes = pushKeys pushCrypts

subsection\<open>Tactics useful for many protocol proofs\<close>
(*<*)
ML
\<open>
(*Analysis of Fake cases.  Also works for messages that forward unknown parts,
  but this application is no longer necessary if analz_insert_eq is used.
  DEPENDS UPON "X" REFERRING TO THE FRADULENT MESSAGE *)

fun impOfSubs th = th RSN (2, @{thm rev_subsetD})

(*Apply rules to break down assumptions of the form
  Y \<in> parts(insert X H)  and  Y \<in> analz(insert X H)
*)
fun Fake_insert_tac ctxt =
    dresolve_tac ctxt [impOfSubs @{thm Fake_analz_insert},
                  impOfSubs @{thm Fake_parts_insert}] THEN'
    eresolve_tac ctxt [asm_rl, @{thm synth.Inj}];

fun Fake_insert_simp_tac ctxt i =
  REPEAT (Fake_insert_tac ctxt i) THEN asm_full_simp_tac ctxt i;

fun atomic_spy_analz_tac ctxt =
  SELECT_GOAL
    (Fake_insert_simp_tac ctxt 1 THEN
      IF_UNSOLVED
        (Blast.depth_tac (ctxt addIs [@{thm analz_insertI},
            impOfSubs @{thm analz_subset_parts}]) 4 1));

fun spy_analz_tac ctxt i =
  DETERM
   (SELECT_GOAL
     (EVERY
      [  (*push in occurrences of X...*)
       (REPEAT o CHANGED)
         (Rule_Insts.res_inst_tac ctxt [((("x", 1), Position.none), "X")] []
          (insert_commute RS ssubst) 1),
       (*...allowing further simplifications*)
       simp_tac ctxt 1,
       REPEAT (FIRSTGOAL (resolve_tac ctxt [allI,impI,notI,conjI,iffI])),
       DEPTH_SOLVE (atomic_spy_analz_tac ctxt 1)]) i);
\<close>
(*>*)

(*By default only o_apply is built-in.  But in the presence of eta-expansion
  this means that some terms displayed as (f o g) will be rewritten, and others
  will not!*)
declare o_def [simp]

lemma Crypt_notin_image_Key [simp]: "Crypt K X \<notin> Key ` A"
by auto

lemma Hash_notin_image_Key [simp] :"Hash X \<notin> Key ` A"
by auto

lemma synth_analz_mono: "G\<subseteq>H ==> synth (analz(G)) \<subseteq> synth (analz(H))"
by (simp add: synth_mono analz_mono)

lemma Fake_analz_eq [simp]:
     "X \<in> synth(analz H) ==> synth (analz (insert X H)) = synth (analz H)"
apply (drule Fake_analz_insert[of _ _ "H"])
apply (simp add: synth_increasing[THEN Un_absorb2])
apply (drule synth_mono)
apply (simp add: synth_idem)
apply (blast intro: synth_analz_mono [THEN [2] rev_subsetD])
done

text\<open>Two generalizations of \<open>analz_insert_eq\<close>\<close>
lemma gen_analz_insert_eq [rule_format]:
     "X \<in> analz H ==> \<forall>G. H \<subseteq> G \<longrightarrow> analz (insert X G) = analz G"
by (blast intro: analz_cut analz_insertI analz_mono [THEN [2] rev_subsetD])

lemma synth_analz_insert_eq [rule_format]:
     "X \<in> synth (analz H)
      \<Longrightarrow> \<forall>G. H \<subseteq> G \<longrightarrow> (Key K \<in> analz (insert X G)) = (Key K \<in> analz G)"
apply (erule synth.induct)
apply (simp_all add: gen_analz_insert_eq subset_trans [OF _ subset_insertI])
done

lemma Fake_parts_sing:
     "X \<in> synth (analz H) ==> parts{X} \<subseteq> synth (analz H) \<union> parts H"
apply (rule subset_trans)
 apply (erule_tac [2] Fake_parts_insert)
apply (simp add: parts_mono)
done

lemmas Fake_parts_sing_imp_Un = Fake_parts_sing [THEN [2] rev_subsetD]

method_setup spy_analz = \<open>
    Scan.succeed (SIMPLE_METHOD' o spy_analz_tac)\<close>
    "for proving the Fake case when analz is involved"

method_setup atomic_spy_analz = \<open>
    Scan.succeed (SIMPLE_METHOD' o atomic_spy_analz_tac)\<close>
    "for debugging spy_analz"

method_setup Fake_insert_simp = \<open>
    Scan.succeed (SIMPLE_METHOD' o Fake_insert_simp_tac)\<close>
    "for debugging spy_analz"

end


(*  Title:      FMap.thy
    Author:     Ludovic Henrio and Florian Kammuller, 2006

Finite maps for Sigma-calculus
Idea use axiomatic type classes to preserve
usability of datatype afterwards, i.e. definition
of an object as a finite map of labels to fields in
a datatype.
*)

section \<open>Finite maps with axclasses\<close>

theory FMap imports ListPre begin

type_synonym ('a, 'b) fmap = "('a :: finite) \<rightharpoonup> 'b" (infixl "-~>" 50)

class inftype =
assumes infinite: "\<not>finite UNIV"

theorem fset_induct:
  "P {} \<Longrightarrow> (\<And>x (F::('a::finite)set). x \<notin> F \<Longrightarrow> P F \<Longrightarrow> P (insert x F)) \<Longrightarrow> P F"
proof (rule_tac P=P and F=F in finite_induct)
  from finite_subset[OF subset_UNIV] show "finite F" by auto
next
  assume "P {}" thus "P {}" by simp
next
  fix x F
  assume "\<And>x F. \<lbrakk> x \<notin> F; P F \<rbrakk> \<Longrightarrow> P (insert x F)" and "x \<notin> F" and "P F"
  thus "P (insert x F)" by simp
qed

theorem fmap_unique: "x = y \<Longrightarrow> (f::('a,'b)fmap) x = f y"
  by (erule ssubst, rule refl)

(* define the witness as a constant function so it may be used in the proof of
the induction scheme below *)
definition
  set_fmap :: "'a -~> 'b \<Rightarrow> ('a * 'b)set" where
  "set_fmap F = {(x, y). x \<in> dom F \<and> F x = Some y}"

definition
  pred_set_fmap :: "(('a -~> 'b) \<Rightarrow> bool) \<Rightarrow> (('a * 'b)set) \<Rightarrow> bool" where
  "pred_set_fmap P = (\<lambda>S. P (\<lambda>x. if x \<in> fst ` S
                                  then (THE y. (\<exists>z. y = Some z \<and> (x, z) \<in> S))
                                  else None))"

definition
  fmap_minus_direct :: "[('a -~> 'b), ('a * 'b)] \<Rightarrow> ('a -~> 'b)" (infixl "--" 50) where
  "F -- x = (\<lambda>z. if (fst x = z \<and> ((F (fst x)) = Some (snd x)))
                   then None
                   else (F z))"

lemma insert_lem : "insert x A = B \<Longrightarrow> x \<in> B"
  by auto

lemma fmap_minus_fmap:
  fixes F x a b
  assumes "(F -- x) a = Some b"
  shows "F a = Some b"
proof (rule ccontr, cases "F a")
  case None hence "a \<notin> dom F" by auto
  hence "(F -- x) a = None"
    unfolding fmap_minus_direct_def by auto
  with \<open>(F -- x) a = Some b\<close> show False by simp
next
  assume "F a \<noteq> Some b"
  case (Some y) thus False
  proof (cases "fst x = a")
    case True thus False
    proof (cases "snd x = y")
      case True with \<open>F a = Some y\<close> \<open>fst x = a\<close>
      have "(F -- x) a = None" unfolding fmap_minus_direct_def by auto
      with \<open>(F -- x) a = Some b\<close> show False by simp
    next
      case False with \<open>F a = Some y\<close> \<open>fst x = a\<close>
      have "F (fst x) \<noteq> Some (snd x)" by auto
      with \<open>(F -- x) a = Some b\<close> have "F a = Some b"
        unfolding fmap_minus_direct_def by auto
      with \<open>F a \<noteq> Some b\<close> show False by simp
    qed
  next
    case False with \<open>(F -- x) a = Some b\<close>
    have "F a = Some b" unfolding fmap_minus_direct_def by auto
    with \<open>F a \<noteq> Some b\<close> show False by simp
  qed
qed

lemma set_fmap_minus_iff:
  "set_fmap ((F::(('a::finite) -~> 'b)) -- x) = set_fmap F - {x}"
  unfolding set_fmap_def
proof (auto)
  fix a b assume "(F -- x) a = Some b" from fmap_minus_fmap[OF this]
  show "\<exists>y. F a = Some y" by blast
next
  fix a b assume "(F -- x) a = Some b" from fmap_minus_fmap[OF this]
  show "F a = Some b" by assumption
next
  fix a b assume "(F -- (a, b)) a = Some b"
  with fmap_minus_fmap[OF this] show False
    unfolding fmap_minus_direct_def by auto
next
  fix a b assume "(a,b) \<noteq> x" and "F a = Some b"
  hence "fst x \<noteq> a \<or> F (fst x) \<noteq> Some (snd x)" by auto
  with \<open>F a = Some b\<close> show "\<exists>y. (F -- x) a = Some y"
    unfolding fmap_minus_direct_def by (rule_tac x = b in exI, simp)
next
  fix a b assume "(a,b) \<noteq> x" and "F a = Some b"
  hence "fst x \<noteq> a \<or> F (fst x) \<noteq> Some (snd x)" by auto
  with \<open>F a = Some b\<close> show "(F -- x) a = Some b"
    unfolding fmap_minus_direct_def by simp
qed

lemma set_fmap_minus_insert:
  fixes F :: "('a::finite * 'b)set" and  F':: "('a::finite) -~> 'b" and x
  assumes "x \<notin> F" and "insert x F = set_fmap F'"
  shows "F = set_fmap (F' -- x)"
proof -
  from \<open>x \<notin> F\<close> sym[OF \<open>insert x F = set_fmap F'\<close>] set_fmap_minus_iff[of F' x]
  show ?thesis by simp
qed

lemma notin_fmap_minus: "x \<notin> set_fmap ((F::(('a::finite) -~> 'b)) -- x)"
  by (auto simp: set_fmap_minus_iff)

lemma fst_notin_fmap_minus_dom:
  fixes F x and F' :: "('a::finite) -~> 'b"
  assumes "insert x F = set_fmap F'"
  shows "fst x \<notin> dom (F' -- x)"
proof (rule ccontr, auto)
  fix y assume "(F' -- x) (fst x) = Some y"
  with notin_fmap_minus[of x F']
  have "y \<noteq> snd x"
    unfolding set_fmap_def by auto
  moreover
  from insert_lem[OF \<open>insert x F = set_fmap F'\<close>]
  have "F' (fst x) = Some (snd x)"
    unfolding set_fmap_def by auto
  ultimately show False
    using fmap_minus_fmap[OF \<open>(F' -- x) (fst x) = Some y\<close>]
    by simp
qed

lemma  set_fmap_pair:
  "x \<in> set_fmap F \<Longrightarrow> (fst x \<in> dom F \<and> snd x = the (F (fst x)))"
  by (simp add: set_fmap_def, auto)

lemma  set_fmap_inv1:
  "\<lbrakk> fst x \<in> dom F; snd x = the (F (fst x)) \<rbrakk> \<Longrightarrow> (F -- x)(fst x \<mapsto> snd x) = F"
proof (rule ext)
  fix xa assume "fst x \<in> dom F" and "snd x = the (F (fst x))"
  thus "((F -- x)(fst x \<mapsto> snd x)) xa = F xa"
    unfolding fmap_minus_direct_def
    by (case_tac "xa = fst x", auto)
qed

lemma set_fmap_inv2:
  "fst x \<notin> dom F \<Longrightarrow> insert x (set_fmap F) = set_fmap (F(fst x \<mapsto> snd x))"
  unfolding set_fmap_def
proof
  assume "fst x \<notin> dom F"
  thus
    "insert x {(x, y). x \<in> dom F \<and> F x = Some y} \<subseteq>
    {(xa, y). xa \<in> dom (F(fst x \<mapsto> snd x)) \<and> (F(fst x \<mapsto> snd x)) xa = Some y}"
    by force
next
  have
    "\<And>z. z \<in> {(xa, y). xa \<in> dom (F(fst x \<mapsto> snd x))
                     \<and> (F(fst x \<mapsto> snd x)) xa = Some y}
    \<Longrightarrow> z \<in> insert x {(x, y). x \<in> dom F \<and> F x = Some y}"
    proof -
      fix z
      assume
        z: "z \<in> {(xa, y). xa \<in> dom (F(fst x \<mapsto> snd x))
                     \<and> (F(fst x \<mapsto> snd x)) xa = Some y}"
      hence "z = x \<or> ((fst z) \<in> dom F \<and> F (fst z) = Some (snd z))"
      proof (cases "fst x = fst z")
        case True thus ?thesis using z by auto
      next
        case False thus ?thesis using z by auto
      qed
      thus "z \<in> insert x {(x, y). x \<in> dom F \<and> F x = Some y}" by fastforce
    qed
  thus
    "{(xa, y). xa \<in> dom (F(fst x \<mapsto> snd x)) \<and> (F(fst x \<mapsto> snd x)) xa = Some y} \<subseteq>
    insert x {(x, y). x \<in> dom F \<and> F x = Some y}" by auto
qed

lemma rep_fmap_base: "P (F::('a  -~> 'b)) = (pred_set_fmap P)(set_fmap F)"
  unfolding pred_set_fmap_def set_fmap_def
proof (rule_tac f = P in arg_cong)
  have
    "\<And>x. F x =
         (\<lambda>x. if x \<in> fst ` {(x, y). x \<in> dom F \<and> F x = Some y}
               then THE y. \<exists>z. y = Some z
                             \<and> (x, z) \<in> {(x, y). x \<in> dom F \<and> F x = Some y}
               else None) x"
  proof auto
    fix a b
    assume "F a = Some b"
    hence "\<exists>!x. x = Some b \<and> a \<in> dom F"
    proof (rule_tac a = "F a" in ex1I)
      assume "F a = Some b"
      thus "F a = Some b \<and> a \<in> dom F"
        by (simp add: dom_def)
    next
      fix x assume "F a = Some b" and "x = Some b \<and> a \<in> dom F"
      thus "x = F a" by simp
    qed
    hence "(THE y. y = Some b \<and> a \<in> dom F) = Some b \<and> a \<in> dom F"
      by (rule theI')
    thus "Some b = (THE y. y = Some b \<and> a \<in> dom F)"
      by simp
  next
    fix x assume nin_x: "x \<notin> fst ` {(x, y). x \<in> dom F \<and> F x = Some y}"
    thus "F x = None"
    proof (cases "F x")
      case None thus ?thesis by assumption
    next
      case (Some a)
      hence "x \<in> fst ` {(x, y). x \<in> dom F \<and> F x = Some y}"
        by (simp add: image_def dom_def)
      with nin_x show ?thesis by simp
    qed
  qed
  thus
    "F = (\<lambda>x. if x \<in> fst ` {(x, y). x \<in> dom F \<and> F x = Some y}
               then THE y. \<exists>z. y = Some z
                             \<and> (x, z) \<in> {(x, y). x \<in> dom F \<and> F x = Some y}
               else None)"
    by (rule ext)
qed

lemma rep_fmap:
  "\<exists>(Fp ::('a * 'b)set) (P'::('a * 'b)set \<Rightarrow> bool). P (F::('a -~> 'b)) = P' Fp"
proof -
  from rep_fmap_base show ?thesis by blast
qed

theorem finite_fsets: "finite (F::('a::finite)set)"
proof -
  from finite_subset[OF subset_UNIV] show "finite F" by auto
qed

lemma finite_dom_fmap: "finite (dom (F::('a -~> 'b))::('a::finite)set)"
  by (rule finite_fsets)

lemma finite_fmap_ran: "finite (ran (F::(('a::finite) -~> 'b)))"
  unfolding ran_def
proof -
  from finite_dom_fmap finite_imageI
  have "finite ((\<lambda>x. the (F x)) ` (dom F))"
    by blast
  moreover
  have "{b. \<exists>a. F a = Some b} = (\<lambda>x. the (F x)) ` (dom F)"
    unfolding image_def dom_def by force
  ultimately
  show "finite {b. \<exists>a. F a = Some b}"  by simp
qed

lemma finite_fset_map: "finite (set_fmap (F::(('a::finite) -~> 'b)))"
proof -
  from finite_cartesian_product[OF finite_dom_fmap finite_fmap_ran]
  have "finite (dom F \<times> ran F)" .
  moreover
  have "set_fmap F \<subseteq> dom F \<times> ran F"
    unfolding set_fmap_def dom_def ran_def by fastforce
  ultimately
  show ?thesis using finite_subset by auto
qed

lemma rep_fmap_imp:
  "\<forall>F x z. x \<notin> dom (F::('a -~> 'b)) \<longrightarrow> P F \<longrightarrow> P (F(x \<mapsto> z))
  \<Longrightarrow> (\<forall>F x z. x \<notin> fst ` (set_fmap F) \<longrightarrow> (pred_set_fmap P)(set_fmap F)
        \<longrightarrow> (pred_set_fmap P) (insert (x,z) (set_fmap F)))"
proof (clarify)
  fix P F x z
  assume
    "\<forall>F x z. x \<notin> dom (F::('a -~> 'b)) \<longrightarrow> P F \<longrightarrow> P (F(x \<mapsto> z))" and
    "x \<notin> fst ` set_fmap F" and "(pred_set_fmap P)(set_fmap F)"
  hence notin: "x \<notin> dom F"
    unfolding set_fmap_def image_def dom_def by simp
  moreover
  from \<open>pred_set_fmap P (set_fmap F)\<close> have "P F" by (simp add: rep_fmap_base)
  ultimately
  have "P (F(x \<mapsto> z))" using \<open>\<forall>F x z. x \<notin> dom F \<longrightarrow> P F \<longrightarrow> P (F(x \<mapsto> z))\<close>
    by blast
  hence "(pred_set_fmap P) (set_fmap (F(x \<mapsto> z)))"
    by (simp add: rep_fmap_base)
  moreover
  from notin
  have "(insert (x,z) (set_fmap F)) = (set_fmap (F(fst (x,z) \<mapsto> snd (x,z))))"
    by (simp add: set_fmap_inv2)
  ultimately
  show "(pred_set_fmap P) (insert (x,z) (set_fmap F))" by simp
qed

theorem fmap_induct[rule_format, case_names empty insert]:
  fixes  P  :: "(('a :: finite) -~> 'b) \<Rightarrow> bool" and  F' :: "('a  -~> 'b)"
  assumes
  "P Map.empty" and
  "\<forall>(F::('a -~> 'b)) x z. x \<notin> dom F \<longrightarrow> P F \<longrightarrow> P (F(x \<mapsto> z))"
  shows "P F'"
proof -
  {
    fix F :: "('a \<times> 'b) set" assume "finite F"
    hence "\<forall>F'. F = set_fmap F' \<longrightarrow> pred_set_fmap P (set_fmap F')"
    proof (induct F)
      case empty thus ?case
      proof (intro strip)
        fix F' :: "'a -~> 'b" assume "{} = set_fmap F'"
        hence "\<And>a. F' a = None" unfolding set_fmap_def by auto
        hence "F' = Map.empty" by (rule ext)
        with \<open>P Map.empty\<close> rep_fmap_base[of P Map.empty]
        show "pred_set_fmap P (set_fmap F')" by simp
      qed
    next
      case (insert x Fa) thus ?case
      proof (intro strip)
        fix Fb :: "'a -~> 'b"
        assume "insert x Fa = set_fmap Fb"
        from
          set_fmap_minus_insert[OF \<open>x \<notin> Fa\<close> this]
          \<open>\<forall>F'. Fa = set_fmap F' \<longrightarrow> pred_set_fmap P (set_fmap F')\<close>
          rep_fmap_base[of P "Fb -- x"]
        have "P (Fb -- x)" by blast
        with
          \<open>\<forall>F x z. x \<notin> dom F \<longrightarrow> P F \<longrightarrow> P (F(x \<mapsto> z))\<close>
          fst_notin_fmap_minus_dom[OF \<open>insert x Fa = set_fmap Fb\<close>]
        have "P ((Fb -- x)(fst x \<mapsto> snd x))" by blast
        moreover
        from
          insert_absorb[OF insert_lem[OF \<open>insert x Fa = set_fmap Fb\<close>]]
          set_fmap_minus_iff[of Fb x]
          set_fmap_inv2[OF
           fst_notin_fmap_minus_dom[OF \<open>insert x Fa = set_fmap Fb\<close>]]
        have "set_fmap Fb = set_fmap ((Fb -- x)(fst x \<mapsto> snd x))"
          by simp
        ultimately
        show "pred_set_fmap P (set_fmap Fb)"
          using rep_fmap_base[of P "(Fb -- x)(fst x \<mapsto> snd x)"]
          by simp
      qed
    qed
  }
  from this[OF finite_fset_map[of F']]
       rep_fmap_base[of P F']
  show "P F'" by blast
qed

lemma fmap_induct3[consumes 2, case_names empty insert]:
  "\<And>(F2::('a::finite) -~> 'b) (F3::('a -~> 'b)).
   \<lbrakk> dom (F1::('a -~> 'b)) = dom F2; dom F3 = dom F1;
     P Map.empty Map.empty Map.empty;
     \<And>x a b c (F1::('a -~> 'b)) (F2::('a -~> 'b)) (F3::('a -~> 'b)).
     \<lbrakk> P F1 F2 F3; dom F1 = dom F2; dom F3 = dom F1; x \<notin> dom F1 \<rbrakk>
     \<Longrightarrow> P (F1(x \<mapsto> a)) (F2(x \<mapsto> b)) (F3(x \<mapsto> c)) \<rbrakk>
  \<Longrightarrow> P F1 F2 F3"
proof (induct F1 rule: fmap_induct)
  case empty
  from \<open>dom Map.empty = dom F2\<close> have "F2 = Map.empty" by (simp add: empty_dom)
  moreover
  from \<open>dom F3 = dom Map.empty\<close> have "F3 = Map.empty" by (simp add: empty_dom)
  ultimately
  show ?case using \<open>P Map.empty Map.empty Map.empty\<close> by simp
next
  case (insert F x y) thus ?case
  proof (cases "F2 = Map.empty")
    case True with \<open>dom (F(x \<mapsto> y)) = dom F2\<close>
    have "dom (F(x \<mapsto> y)) = {}" by auto
    thus ?thesis by auto
  next
    case False thus ?thesis
    proof (cases "F3 = Map.empty")
      case True with \<open>dom F3 = dom (F(x \<mapsto> y))\<close>
      have "dom (F(x \<mapsto> y)) = {}" by simp
      thus ?thesis by simp
    next
      case False thus ?thesis
      proof -
        from \<open>F2 \<noteq> Map.empty\<close>
        have "\<forall>l\<in>dom F2. \<exists>f'. F2 = f'(l \<mapsto> the (F2 l)) \<and> l \<notin> dom f'"
          by (simp add: one_more_dom)
        moreover
        from \<open>dom (F(x \<mapsto> y)) = dom F2\<close> have "x \<in> dom F2" by force
        ultimately have "\<exists>f'. F2 = f'(x \<mapsto> the (F2 x)) \<and> x \<notin> dom f'" by blast
        then obtain F2' where "F2 = F2'(x \<mapsto> the (F2 x))" and "x \<notin> dom F2'"
          by auto

        from \<open>F3 \<noteq> Map.empty\<close>
        have "\<forall>l\<in>dom F3. \<exists>f'. F3 = f'(l \<mapsto> the (F3 l)) \<and> l \<notin> dom f'"
          by (simp add: one_more_dom)
        moreover from \<open>dom F3 = dom (F(x \<mapsto> y))\<close> have "x \<in> dom F3" by force
        ultimately have "\<exists>f'. F3 = f'(x \<mapsto> the (F3 x)) \<and> x \<notin> dom f'" by blast
        then obtain F3' where "F3 = F3'(x \<mapsto> the (F3 x))" and "x \<notin> dom F3'"
          by auto

        show ?thesis
        proof -
          from \<open>dom (F(x \<mapsto> y)) = dom F2\<close> \<open>F2 = F2'(x \<mapsto> the (F2 x))\<close>
          have "dom (F(x \<mapsto> y)) = dom (F2'(x \<mapsto> the (F2 x)))" by simp
          with \<open>x \<notin> dom F\<close> \<open>x \<notin> dom F2'\<close> have "dom F = dom F2'" by auto

          moreover
          from \<open>dom F3 = dom (F(x \<mapsto> y))\<close> \<open>F3 = F3'(x \<mapsto> the (F3 x))\<close>
          have "dom (F(x \<mapsto> y)) = dom (F3'(x \<mapsto> the (F3 x)))" by simp
          with \<open>x \<notin> dom F\<close> \<open>x \<notin> dom F3'\<close> have "dom F3' = dom F" by auto

          ultimately have "P F F2' F3'" using insert by simp

          with
            \<open>\<And>F1 F2 F3 x a b c.
              \<lbrakk> P F1 F2 F3; dom F1 = dom F2; dom F3 = dom F1; x \<notin> dom F1 \<rbrakk>
              \<Longrightarrow> P (F1(x \<mapsto> a)) (F2(x \<mapsto> b)) (F3(x \<mapsto> c))\<close>
            \<open>dom F = dom F2'\<close>
            \<open>dom F3' = dom F\<close>
            \<open>x \<notin> dom F\<close>
          have "P (F(x \<mapsto> y)) (F2'(x \<mapsto> the (F2 x))) (F3'(x \<mapsto> the (F3 x)))"
            by simp
          with \<open>F2 = F2'(x \<mapsto> the (F2 x))\<close> \<open>F3 = F3'(x \<mapsto> the (F3 x))\<close>
          show "P (F(x \<mapsto> y)) F2 F3" by simp
        qed
      qed
    qed
  qed
qed

lemma fmap_ex_cof2:
  "\<And>(P::'c \<Rightarrow> 'c \<Rightarrow> 'b option \<Rightarrow> 'b option \<Rightarrow> 'a \<Rightarrow> bool)
     (f'::('a::finite) -~> 'b).
  \<lbrakk> dom f' = dom (f::('a -~> 'b));
    \<forall>l\<in>dom f. (\<exists>L. finite L
                  \<and> (\<forall>s p. s \<notin> L \<and> p \<notin> L \<and> s \<noteq> p
                      \<longrightarrow> P s p (f l) (f' l) l)) \<rbrakk>
  \<Longrightarrow> \<exists>L. finite L \<and> (\<forall>l\<in>dom f. (\<forall>s p. s \<notin> L \<and> p \<notin> L \<and> s \<noteq> p
                                   \<longrightarrow> P s p (f l) (f' l) l))"
proof (induct f rule: fmap_induct)
  case empty thus ?case by blast
next
  case (insert f l t P f') note imp = this(2) and pred = this(4)
  define pred_cof where "pred_cof L b b' l \<longleftrightarrow> (\<forall>s p. s \<notin> L \<and> p \<notin> L \<and> s \<noteq> p \<longrightarrow> P s p b b' l)"
    for L b b' l
  from
    map_upd_nonempty[of f l t] \<open>dom f' = dom (f(l \<mapsto> t))\<close>
    one_more_dom[of l f']
  obtain f'a where
    "f' = f'a(l \<mapsto> the(f' l))" and "l \<notin> dom f'a" and
    "dom (f'a(l \<mapsto> the(f' l))) = dom (f(l \<mapsto> t))"
    by auto
  from \<open>l \<notin> dom f\<close>
  have
    fla: "\<forall>la\<in>dom f. f la = (f(l \<mapsto> t)) la" and
    "\<forall>la\<in>dom f. f'a la = (f'a(l \<mapsto> the(f' l))) la"
    by auto
  with \<open>f' = f'a(l \<mapsto> the(f' l))\<close>
  have f'ala: "\<forall>la\<in>dom f. f'a la = f' la" by simp
  have "\<exists>L. finite L \<and> (\<forall>la\<in>dom f. pred_cof L (f la) (f'a la) la)"
    unfolding pred_cof_def
  proof
    (intro imp[OF insert_dom_less_eq[OF \<open>l \<notin> dom f'a\<close> \<open>l \<notin> dom f\<close>
                                        \<open>dom (f'a(l \<mapsto> the(f' l))) = dom (f(l \<mapsto> t))\<close>]],
      intro strip)
    fix la assume "la \<in> dom f"
    with fla f'ala
    have
      "la \<in> dom (f(l \<mapsto> t))" and
      "f la = (f(l \<mapsto> t)) la" and "f'a la = f' la"
      by auto
    with pred
    show "\<exists>L. finite L \<and> (\<forall>s p. s \<notin> L \<and> p \<notin> L \<and> s \<noteq> p \<longrightarrow> P s p (f la) (f'a la) la)"
      by (elim ssubst, blast)
  qed
  with fla f'ala obtain L where
    "finite L" and predf: "\<forall>la\<in>dom f. pred_cof L ((f(l \<mapsto> t)) la) (f' la) la"
    by auto
  moreover
  have "l \<in> dom (f(l \<mapsto> t))" by simp
  with pred obtain L' where
    "finite L'" and predfl: "pred_cof L' ((f(l \<mapsto> t)) l) (f' l) l"
    unfolding pred_cof_def
    by blast
  ultimately show ?case
  proof (rule_tac x = "L \<union> L'" in exI,
      intro conjI, simp, intro strip)
    fix s p la assume
      sp: "s \<notin> L \<union> L' \<and> p \<notin> L \<union> L' \<and> s \<noteq> p" and indom: "la \<in> dom (f(l \<mapsto> t))"
    show "P s p ((f(l \<mapsto> t)) la) (f' la) la"
    proof (cases "la = l")
      case True with sp predfl show ?thesis
        unfolding pred_cof_def
        by simp
    next
      case False with indom sp predf show ?thesis
        unfolding pred_cof_def
        by force
    qed
  qed
qed

lemma fmap_ex_cof:
  fixes
  P :: "'c \<Rightarrow> 'c \<Rightarrow> 'b option \<Rightarrow> ('a::finite) \<Rightarrow> bool"
  assumes
  "\<forall>l\<in>dom (f::('a -~> 'b)).
  (\<exists>L. finite L \<and> (\<forall>s p. s \<notin> L \<and> p \<notin> L \<and> s \<noteq> p \<longrightarrow> P s p (f l) l))"
  shows
  "\<exists>L. finite L \<and> (\<forall>l\<in>dom f. (\<forall>s p. s \<notin> L \<and> p \<notin> L \<and> s \<noteq> p \<longrightarrow> P s p (f l) l))"
  using assms fmap_ex_cof2[of f f  "\<lambda>s p b b' l. P s p b l"] by auto

lemma fmap_ball_all2:
  fixes
  Px :: "'c \<Rightarrow> 'd \<Rightarrow> bool" and
  P :: "'c \<Rightarrow> 'd \<Rightarrow> 'b option \<Rightarrow> bool"
  assumes
  "\<forall>l\<in>dom (f::('a::finite) -~> 'b). \<forall>(x::'c) (y::'d). Px x y \<longrightarrow> P x y (f l)"
  shows
  "\<forall>x y. Px x y \<longrightarrow> (\<forall>l\<in>dom f. P x y (f l))"
proof (intro strip)
  fix x y l assume "Px x y" and "l \<in> dom f"
  with assms show "P x y (f l)" by blast
qed

lemma fmap_ball_all2':
  fixes
  Px :: "'c \<Rightarrow> 'd \<Rightarrow> bool" and
  P :: "'c \<Rightarrow> 'd \<Rightarrow> 'b option \<Rightarrow> ('a::finite) \<Rightarrow> bool"
  assumes
  "\<forall>l\<in>dom (f::('a -~> 'b)). \<forall>(x::'c) (y::'d). Px x y \<longrightarrow> P x y (f l) l"
  shows
  "\<forall>x y. Px x y \<longrightarrow> (\<forall>l\<in>dom f. P x y (f l) l)"
proof (intro strip)
  fix x y l assume "Px x y" and "l \<in> dom f"
  with assms show "P x y (f l) l" by blast
qed

lemma fmap_ball_all3:
  fixes
  Px :: "'c \<Rightarrow> 'd \<Rightarrow> 'e \<Rightarrow> bool" and
  P :: "'c \<Rightarrow> 'd \<Rightarrow> 'e \<Rightarrow> 'b option \<Rightarrow> 'b option \<Rightarrow> bool" and
  f :: "('a::finite) -~> 'b" and f' :: "'a -~> 'b"
  assumes
  "dom f' = dom f" and
  "\<forall>l\<in>dom f.
     \<forall>(x::'c) (y::'d) (z::'e). Px x y z \<longrightarrow> P x y z (f l) (f' l)"
  shows
  "\<forall>x y z. Px x y z \<longrightarrow> (\<forall>l\<in>dom f. P x y z (f l) (f' l))"
proof (intro strip)
  fix x y z l assume "Px x y z" and "l \<in> dom f"
  with assms show "P x y z (f l) (f' l)" by blast
qed

lemma fmap_ball_all4':
  fixes
  Px :: "'c \<Rightarrow> 'd \<Rightarrow> 'e \<Rightarrow> 'f \<Rightarrow> bool" and
  P :: "'c \<Rightarrow> 'd \<Rightarrow> 'e \<Rightarrow> 'f \<Rightarrow> 'b option \<Rightarrow> ('a::finite) \<Rightarrow> bool"
  assumes
  "\<forall>l\<in>dom (f::('a -~> 'b)).
    \<forall>(x::'c) (y::'d) (z::'e) (a::'f). Px x y z a \<longrightarrow> P x y z a (f l) l"
  shows
  "\<forall>x y z a. Px x y z a \<longrightarrow> (\<forall>l\<in>dom f. P x y z a (f l) l)"
proof (intro strip)
  fix x y z a l assume "Px x y z a" and "l \<in> dom f"
  with assms show "P x y z a (f l) l" by blast
qed

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Further set algebra and other miscellaneous results\<close>
theory CZH_Sets_Sets
  imports CZH_Sets_Introduction
begin

subsection\<open>Background\<close>

text\<open>
This section presents further set algebra and various elementary properties
of sets.

Many of the results that are presented in this section
were carried over (with amendments) from the theories \<^text>\<open>Set\<close>
and \<^text>\<open>Complete_Lattices\<close> in the main library.
\<close>

declare elts_sup_iff[simp del]

subsection\<open>Further notation\<close>

subsubsection\<open>Set membership\<close>

abbreviation vmember :: "V \<Rightarrow> V \<Rightarrow> bool" ("(_/ \<in>\<^sub>\<circ> _)" [51, 51] 50)
  where "vmember x A \<equiv> (x \<in> elts A)"
notation vmember ("'(\<in>\<^sub>\<circ>')")
  and vmember ("(_/ \<in>\<^sub>\<circ> _)" [51, 51] 50)

abbreviation not_vmember :: "V \<Rightarrow> V \<Rightarrow> bool" ("(_/ \<notin>\<^sub>\<circ> _)" [51, 51] 50)
  where "not_vmember x A \<equiv> (x \<notin> elts A)"
notation
  not_vmember ("'(\<notin>\<^sub>\<circ>')") and
  not_vmember ("(_/ \<notin>\<^sub>\<circ> _)" [51, 51] 50)

subsubsection\<open>Subsets\<close>

abbreviation vsubset :: "V \<Rightarrow> V \<Rightarrow> bool"
  where "vsubset \<equiv> less"
abbreviation vsubset_eq :: "V \<Rightarrow> V \<Rightarrow> bool"
  where "vsubset_eq \<equiv> less_eq"

notation vsubset ("'(\<subset>\<^sub>\<circ>')")
  and vsubset ("(_/ \<subset>\<^sub>\<circ> _)" [51, 51] 50)
  and vsubset_eq ("'(\<subseteq>\<^sub>\<circ>')")
  and vsubset_eq ("(_/ \<subseteq>\<^sub>\<circ> _)" [51, 51] 50)

subsubsection\<open>Ball\<close>

syntax
  "_VBall" :: "pttrn \<Rightarrow> V \<Rightarrow> bool \<Rightarrow> bool" ("(3\<forall>(_/\<in>\<^sub>\<circ>_)./ _)" [0, 0, 10] 10)
  "_VBex" :: "pttrn \<Rightarrow> V \<Rightarrow> bool \<Rightarrow> bool" ("(3\<exists>(_/\<in>\<^sub>\<circ>_)./ _)" [0, 0, 10] 10)
  "_VBex1" :: "pttrn \<Rightarrow> V \<Rightarrow> bool \<Rightarrow> bool" ("(3\<exists>!(_/\<in>\<^sub>\<circ>_)./ _)" [0, 0, 10] 10)

translations
  "\<forall>x\<in>\<^sub>\<circ>A. P" \<rightleftharpoons> "CONST Ball (CONST elts A) (\<lambda>x. P)"
  "\<exists>x\<in>\<^sub>\<circ>A. P" \<rightleftharpoons> "CONST Bex (CONST elts A) (\<lambda>x. P)"
  "\<exists>!x\<in>\<^sub>\<circ>A. P" \<rightharpoonup> "\<exists>!x. x \<in>\<^sub>\<circ> A \<and> P"

subsubsection\<open>\<open>VLambda\<close>\<close>

text\<open>The following notation was adapted from \<^cite>\<open>"paulson_hereditarily_2013"\<close>.\<close>

syntax "_vlam" :: "[pttrn, V, V] \<Rightarrow> V" (\<open>(3\<lambda>_\<in>\<^sub>\<circ>_./ _)\<close> 10)
translations "\<lambda>x\<in>\<^sub>\<circ>A. f" \<rightleftharpoons> "CONST VLambda A (\<lambda>x. f)"

subsubsection\<open>Intersection and union\<close>

abbreviation vintersection :: "V \<Rightarrow> V \<Rightarrow> V" (infixl "\<inter>\<^sub>\<circ>" 70)
  where "(\<inter>\<^sub>\<circ>) \<equiv> (\<sqinter>)"
notation vintersection (infixl "\<inter>\<^sub>\<circ>" 70)

abbreviation vunion :: "V \<Rightarrow> V \<Rightarrow> V"  (infixl "\<union>\<^sub>\<circ>" 65)
  where "vunion \<equiv> sup"
notation vunion (infixl "\<union>\<^sub>\<circ>" 65)

abbreviation VInter :: "V \<Rightarrow> V" (\<open>\<Inter>\<^sub>\<circ>\<close>)
  where "\<Inter>\<^sub>\<circ> A \<equiv> \<Sqinter> (elts A)"
notation VInter (\<open>\<Inter>\<^sub>\<circ>\<close>)

abbreviation VUnion :: "V \<Rightarrow> V" (\<open>\<Union>\<^sub>\<circ>\<close>)
  where "\<Union>\<^sub>\<circ>A \<equiv> \<Squnion> (elts A)"
notation VUnion (\<open>\<Union>\<^sub>\<circ>\<close>)

subsubsection\<open>Miscellaneous\<close>

notation app (\<open>_\<lparr>_\<rparr>\<close> [999, 50] 999)
notation vtimes (infixr "\<times>\<^sub>\<circ>" 80)

subsection\<open>Elementary results.\<close>

lemma vempty_nin[simp]: "a \<notin>\<^sub>\<circ> 0" by simp

lemma vemptyE:
  assumes "A \<noteq> 0"
  obtains x where "x \<in>\<^sub>\<circ> A"
  using assms trad_foundation by auto

lemma in_set_CollectI:
  assumes "P x" and "small {x. P x}"
  shows "x \<in>\<^sub>\<circ> set {x. P x}"
  using assms by simp

lemma small_setcompr2:
  assumes "small {f x y | x y. P x y}" and "a \<in>\<^sub>\<circ> set {f x y | x y. P x y}"
  obtains x' y' where "a = f x' y'" and "P x' y'"
  using assms by auto

lemma in_small_setI:
  assumes "small A" and "x \<in> A"
  shows "x \<in>\<^sub>\<circ> set A"
  using assms by simp

lemma in_small_setD:
  assumes "x \<in>\<^sub>\<circ> set A" and "small A"
  shows "x \<in> A"
  using assms by simp

lemma in_small_setE:
  assumes "a \<in>\<^sub>\<circ> set A" and "small A"
  obtains "a \<in> A"
  using assms by auto

lemma small_set_vsubset:
  assumes "small A" and "A \<subseteq> elts B"
  shows "set A \<subseteq>\<^sub>\<circ> B"
  using assms by auto

lemma some_in_set_if_set_neq_vempty[simp]:
  assumes "A \<noteq> 0"
  shows "(SOME x. x \<in>\<^sub>\<circ> A) \<in>\<^sub>\<circ> A"
  by (meson assms someI_ex vemptyE)

lemma small_vsubset_set[intro, simp]:
  assumes "small B" and "A \<subseteq> B"
  shows "set A \<subseteq>\<^sub>\<circ> set B"
  using assms by (auto simp: subset_iff_less_eq_V)

lemma vset_neq_1:
  assumes "b \<notin>\<^sub>\<circ> A" and "a \<in>\<^sub>\<circ> A"
  shows "b \<noteq> a"
  using assms by auto

lemma vset_neq_2:
  assumes "b \<in>\<^sub>\<circ> A" and "a \<notin>\<^sub>\<circ> A"
  shows "b \<noteq> a"
  using assms by auto

lemma nin_vinsertI:
  assumes "a \<noteq> b" and "a \<notin>\<^sub>\<circ> A"
  shows "a \<notin>\<^sub>\<circ> vinsert b A"
  using assms by clarsimp

lemma vsubset_if_subset:
  assumes "elts A \<subseteq> elts B"
  shows "A \<subseteq>\<^sub>\<circ> B"
  using assms by auto

lemma small_set_comprehension[simp]: "small {A i | i. i \<in>\<^sub>\<circ> I}"
proof(rule smaller_than_small)
  show "small (A ` elts I)" by auto
qed auto

subsection\<open>\<open>VBall\<close>\<close>

lemma vball_cong:
  assumes "A = B" and "\<And>x. x \<in>\<^sub>\<circ> B \<Longrightarrow> P x \<longleftrightarrow> Q x"
  shows "(\<forall>x\<in>\<^sub>\<circ>A. P x) \<longleftrightarrow> (\<forall>x\<in>\<^sub>\<circ>B. Q x)"
  by (simp add: assms)

lemma vball_cong_simp[cong]:
  assumes "A = B" and "\<And>x. x \<in>\<^sub>\<circ> B =simp=> P x \<longleftrightarrow> Q x "
  shows "(\<forall>x\<in>\<^sub>\<circ>A. P x) \<longleftrightarrow> (\<forall>x\<in>\<^sub>\<circ>B. Q x)"
  using assms by (simp add: simp_implies_def)

subsection\<open>\<open>VBex\<close>\<close>

lemma vbex_cong:
  assumes "A = B" and  "\<And>x. x \<in>\<^sub>\<circ> B \<Longrightarrow> P x \<longleftrightarrow> Q x"
  shows "(\<exists>x\<in>\<^sub>\<circ>A. P x) \<longleftrightarrow> (\<exists>x\<in>\<^sub>\<circ>B. Q x)"
  using assms by (simp cong: conj_cong)

lemma vbex_cong_simp[cong]:
  assumes "A = B" and "\<And>x. x \<in>\<^sub>\<circ> B =simp=> P x \<longleftrightarrow> Q x "
  shows "(\<exists>x\<in>\<^sub>\<circ>A. P x) \<longleftrightarrow> (\<exists>x\<in>\<^sub>\<circ>B. Q x)"
  using assms by (simp add:  simp_implies_def)

subsection\<open>Subset\<close>

text\<open>Rules.\<close>

lemma vsubset_antisym:
  assumes "A \<subseteq>\<^sub>\<circ> B" and "B \<subseteq>\<^sub>\<circ> A"
  shows "A = B"
  using assms by simp

lemma vsubsetI:
  assumes "\<And>x. x \<in>\<^sub>\<circ> A \<Longrightarrow> x \<in>\<^sub>\<circ> B"
  shows "A \<subseteq>\<^sub>\<circ> B"
  using assms by auto

lemma vpsubsetI:
  assumes "A \<subseteq>\<^sub>\<circ> B" and "x \<notin>\<^sub>\<circ> A" and "x \<in>\<^sub>\<circ> B"
  shows "A \<subset>\<^sub>\<circ> B"
  using assms unfolding less_V_def by auto

lemma vsubsetD:
  assumes "A \<subseteq>\<^sub>\<circ> B"
  shows "\<And>x. x \<in>\<^sub>\<circ> A \<Longrightarrow> x \<in>\<^sub>\<circ> B"
  using assms by auto

lemma vsubsetE:
  assumes "A \<subseteq>\<^sub>\<circ> B" and "(\<And>x. x \<in>\<^sub>\<circ> A \<Longrightarrow> x \<in>\<^sub>\<circ> B) \<Longrightarrow> P"
  shows P
  using assms by auto

lemma vpsubsetE:
  assumes "A \<subset>\<^sub>\<circ> B"
  obtains x where "A \<subseteq>\<^sub>\<circ> B" and "x \<notin>\<^sub>\<circ> A" and "x \<in>\<^sub>\<circ> B"
  using assms unfolding less_V_def by (meson V_equalityI vsubsetE)

lemma vsubset_iff: "A \<subseteq>\<^sub>\<circ> B \<longleftrightarrow> (\<forall>t. t \<in>\<^sub>\<circ> A \<longrightarrow> t \<in>\<^sub>\<circ> B)" by blast

text\<open>Elementary properties.\<close>

lemma vsubset_eq: "A \<subseteq>\<^sub>\<circ> B \<longleftrightarrow> (\<forall>x\<in>\<^sub>\<circ>A. x \<in>\<^sub>\<circ> B)" by auto

lemma vsubset_transitive[intro]:
  assumes "A \<subseteq>\<^sub>\<circ> B" and "B \<subseteq>\<^sub>\<circ> C"
  shows "A \<subseteq>\<^sub>\<circ> C"
  using assms by simp

lemma vsubset_reflexive: "A \<subseteq>\<^sub>\<circ> A" by simp

text\<open>Set operations.\<close>

lemma vsubset_vempty: "0 \<subseteq>\<^sub>\<circ> A" by simp

lemma vsubset_vsingleton_left: "set {a} \<subseteq>\<^sub>\<circ> A \<longleftrightarrow> a \<in>\<^sub>\<circ> A" by auto

lemmas vsubset_vsingleton_leftD[dest] = vsubset_vsingleton_left[THEN iffD1]
  and vsubset_vsingleton_leftI[intro] = vsubset_vsingleton_left[THEN iffD2]

lemma vsubset_vsingleton_right: "A \<subseteq>\<^sub>\<circ> set {a} \<longleftrightarrow> A = set {a} \<or> A = 0"
  by (auto intro!: vsubset_antisym)

lemmas vsubset_vsingleton_rightD[dest] = vsubset_vsingleton_right[THEN iffD1]
  and vsubset_vsingleton_rightI[intro] = vsubset_vsingleton_right[THEN iffD2]

lemma vsubset_vdoubleton_leftD[dest]:
  assumes "set {a, b} \<subseteq>\<^sub>\<circ> A"
  shows "a \<in>\<^sub>\<circ> A" and "b \<in>\<^sub>\<circ> A"
  using assms by auto

lemma vsubset_vdoubleton_leftI[intro]:
  assumes "a \<in>\<^sub>\<circ> A" and "b \<in>\<^sub>\<circ> A"
  shows "set {a, b} \<subseteq>\<^sub>\<circ> A"
  using assms by auto

lemma vsubset_vinsert_leftD[dest]:
  assumes "vinsert a A \<subseteq>\<^sub>\<circ> B"
  shows "A \<subseteq>\<^sub>\<circ> B"
  using assms by auto

lemma vsubset_vinsert_leftI[intro]:
  assumes "A \<subseteq>\<^sub>\<circ> B" and "a \<in>\<^sub>\<circ> B"
  shows "vinsert a A \<subseteq>\<^sub>\<circ> B"
  using assms by auto

lemma vsubset_vinsert_vinsertI[intro]:
  assumes "A \<subseteq>\<^sub>\<circ> vinsert b B"
  shows "vinsert b A \<subseteq>\<^sub>\<circ> vinsert b B"
  using assms by auto

lemma vsubset_vinsert_rightI[intro]:
  assumes "A \<subseteq>\<^sub>\<circ> B"
  shows "A \<subseteq>\<^sub>\<circ> vinsert b B"
  using assms by auto

lemmas vsubset_VPow = VPow_le_VPow_iff

lemmas vsubset_VPowD = vsubset_VPow[THEN iffD1]
  and vsubset_VPowI = vsubset_VPow[THEN iffD2]

text\<open>Special properties.\<close>

lemma vsubset_contraD:
  assumes "A \<subseteq>\<^sub>\<circ> B" and "c \<notin>\<^sub>\<circ> B"
  shows "c \<notin>\<^sub>\<circ> A"
  using assms by auto

subsection\<open>Equality\<close>

text\<open>Rules.\<close>

lemma vequalityD1:
  assumes "A = B"
  shows "A \<subseteq>\<^sub>\<circ> B"
  using assms by simp

lemma vequalityD2:
  assumes "A = B"
  shows "B \<subseteq>\<^sub>\<circ> A"
  using assms by simp

lemma vequalityE:
  assumes "A = B" and "\<lbrakk> A \<subseteq>\<^sub>\<circ> B; B \<subseteq>\<^sub>\<circ> A \<rbrakk> \<Longrightarrow> P"
  shows P
  using assms by simp

lemma vequalityCE[elim]:
  assumes "A = B" and "\<lbrakk> c \<in>\<^sub>\<circ> A; c \<in>\<^sub>\<circ> B \<rbrakk> \<Longrightarrow> P" and "\<lbrakk> c \<notin>\<^sub>\<circ> A; c \<notin>\<^sub>\<circ> B \<rbrakk> \<Longrightarrow> P"
  shows P
  using assms by auto

subsection\<open>Binary intersection\<close>

lemma vintersection_def: "A \<inter>\<^sub>\<circ> B = set {x. x \<in>\<^sub>\<circ> A \<and> x \<in>\<^sub>\<circ> B}"
  by (metis Int_def inf_V_def)

lemma small_vintersection_set[simp]: "small {x. x \<in>\<^sub>\<circ> A \<and> x \<in>\<^sub>\<circ> B}"
  by (rule down[of _ A]) auto

text\<open>Rules.\<close>

lemma vintersection_iff[simp]: "x \<in>\<^sub>\<circ> A \<inter>\<^sub>\<circ> B \<longleftrightarrow> x \<in>\<^sub>\<circ> A \<and> x \<in>\<^sub>\<circ> B"
  unfolding vintersection_def by simp

lemma vintersectionI[intro!]:
  assumes "x \<in>\<^sub>\<circ> A" and "x \<in>\<^sub>\<circ> B"
  shows "x \<in>\<^sub>\<circ> A \<inter>\<^sub>\<circ> B"
  using assms by simp

lemma vintersectionD1[dest]:
  assumes "x \<in>\<^sub>\<circ> A \<inter>\<^sub>\<circ> B"
  shows "x \<in>\<^sub>\<circ> A"
  using assms by simp

lemma vintersectionD2[dest]:
  assumes "x \<in>\<^sub>\<circ> A \<inter>\<^sub>\<circ> B"
  shows "x \<in>\<^sub>\<circ> B"
  using assms by simp

lemma vintersectionE[elim!]:
  assumes "x \<in>\<^sub>\<circ> A \<inter>\<^sub>\<circ> B" and "x \<in>\<^sub>\<circ> A \<Longrightarrow> x \<in>\<^sub>\<circ> B \<Longrightarrow> P"
  shows P
  using assms by simp

text\<open>Elementary properties.\<close>

lemma vintersection_intersection: "A \<inter>\<^sub>\<circ> B = set (elts A \<inter> elts B)"
  unfolding inf_V_def by simp

lemma vintersection_assoc: "A \<inter>\<^sub>\<circ> (B \<inter>\<^sub>\<circ> C) = (A \<inter>\<^sub>\<circ> B) \<inter>\<^sub>\<circ> C" by auto

lemma vintersection_commute: "A \<inter>\<^sub>\<circ> B = B \<inter>\<^sub>\<circ> A" by auto

text\<open>Previous set operations.\<close>

lemma vsubset_vintersection_right: "A \<subseteq>\<^sub>\<circ> (B \<inter>\<^sub>\<circ> C) = (A \<subseteq>\<^sub>\<circ> B \<and> A \<subseteq>\<^sub>\<circ> C)"
  by clarsimp

lemma vsubset_vintersection_rightD[dest]:
  assumes "A \<subseteq>\<^sub>\<circ> (B \<inter>\<^sub>\<circ> C)"
  shows "A \<subseteq>\<^sub>\<circ> B" and "A \<subseteq>\<^sub>\<circ> C"
  using assms by auto

lemma vsubset_vintersection_rightI[intro]:
  assumes "A \<subseteq>\<^sub>\<circ> B" and "A \<subseteq>\<^sub>\<circ> C"
  shows "A \<subseteq>\<^sub>\<circ> (B \<inter>\<^sub>\<circ> C)"
  using assms by auto

text\<open>Set operations.\<close>

lemma vintersection_vempty: "0 \<subseteq>\<^sub>\<circ> A" by simp

lemma vintersection_vsingleton: "a \<in>\<^sub>\<circ> set {a}" by simp

lemma vintersection_vdoubleton: "a \<in>\<^sub>\<circ> set {a, b}" and "b \<in>\<^sub>\<circ> set {a, b}"
  by simp_all

lemma vintersection_VPow[simp]: "VPow (A \<inter>\<^sub>\<circ> B) = VPow A \<inter>\<^sub>\<circ> VPow B" by auto

text\<open>Special properties.\<close>

lemma vintersection_function_mono:
  assumes "mono f"
  shows "f (A \<inter>\<^sub>\<circ> B) \<subseteq>\<^sub>\<circ> f A \<inter>\<^sub>\<circ> f B"
  using assms by (fact mono_inf)

subsection\<open>Binary union\<close>

lemma small_vunion_set: "small {x. x \<in>\<^sub>\<circ> A \<or> x \<in>\<^sub>\<circ> B}"
  by (rule down[of _ \<open>A \<union>\<^sub>\<circ> B\<close>]) (auto simp: elts_sup_iff)

text\<open>Rules.\<close>

lemma vunion_def: "A \<union>\<^sub>\<circ> B = set {x. x \<in>\<^sub>\<circ> A \<or> x \<in>\<^sub>\<circ> B}"
  unfolding Un_def sup_V_def by simp

lemma vunion_iff[simp]: "x \<in>\<^sub>\<circ> A \<union>\<^sub>\<circ> B \<longleftrightarrow> x \<in>\<^sub>\<circ> A \<or> x \<in>\<^sub>\<circ> B"
  by (simp add: elts_sup_iff)

lemma vunionI1:
  assumes "a \<in>\<^sub>\<circ> A"
  shows "a \<in>\<^sub>\<circ> A \<union>\<^sub>\<circ> B"
  using assms by simp

lemma vunionI2:
  assumes "a \<in>\<^sub>\<circ> B"
  shows "a \<in>\<^sub>\<circ> A \<union>\<^sub>\<circ> B"
  using assms by simp

lemma vunionCI[intro!]:
  assumes "x \<notin>\<^sub>\<circ> B \<Longrightarrow> x \<in>\<^sub>\<circ> A"
  shows "x \<in>\<^sub>\<circ> A \<union>\<^sub>\<circ> B"
  using assms by clarsimp

lemma vunionE[elim!]:
  assumes "x \<in>\<^sub>\<circ> A \<union>\<^sub>\<circ> B" and "x \<in>\<^sub>\<circ> A \<Longrightarrow> P" and "x \<in>\<^sub>\<circ> B \<Longrightarrow> P"
  shows P
  using assms by auto

text\<open>Elementary properties.\<close>

lemma vunion_union: "A \<union>\<^sub>\<circ> B = set (elts A \<union> elts B)" by auto

lemma vunion_assoc: "A \<union>\<^sub>\<circ> (B \<union>\<^sub>\<circ> C) = (A \<union>\<^sub>\<circ> B) \<union>\<^sub>\<circ> C" by auto

lemma vunion_commute: "A \<union>\<^sub>\<circ> B = B \<union>\<^sub>\<circ> A" by auto

text\<open>Previous set operations.\<close>

lemma vsubset_vunion_left: "(A \<union>\<^sub>\<circ> B) \<subseteq>\<^sub>\<circ> C \<longleftrightarrow> (A \<subseteq>\<^sub>\<circ> C \<and> B \<subseteq>\<^sub>\<circ> C)" by simp

lemma vsubset_vunion_leftD[dest]:
  assumes "(A \<union>\<^sub>\<circ> B) \<subseteq>\<^sub>\<circ> C"
  shows "A \<subseteq>\<^sub>\<circ> C" and "B \<subseteq>\<^sub>\<circ> C"
  using assms by auto

lemma vsubset_vunion_leftI[intro]:
  assumes "A \<subseteq>\<^sub>\<circ> C" and "B \<subseteq>\<^sub>\<circ> C"
  shows "(A \<union>\<^sub>\<circ> B) \<subseteq>\<^sub>\<circ> C"
  using assms by auto

lemma vintersection_vunion_left: "(A \<union>\<^sub>\<circ> B) \<inter>\<^sub>\<circ> C = (A \<inter>\<^sub>\<circ> C) \<union>\<^sub>\<circ> (B \<inter>\<^sub>\<circ> C)"
  by auto

lemma vintersection_vunion_right: "A \<inter>\<^sub>\<circ> (B \<union>\<^sub>\<circ> C) = (A \<inter>\<^sub>\<circ> B) \<union>\<^sub>\<circ> (A \<inter>\<^sub>\<circ> C)"
  by auto

text\<open>Set operations.\<close>

lemmas vunion_vempty_left = sup_V_0_left
  and vunion_vempty_right = sup_V_0_right

lemma vunion_vsingleton[simp]: "set {a} \<union>\<^sub>\<circ> A = vinsert a A" by auto

lemma vunion_vdoubleton[simp]: "set {a, b} \<union>\<^sub>\<circ> A = vinsert a (vinsert b A)"
  by auto

lemma vunion_vinsert_comm_left:
  "(vinsert a A) \<union>\<^sub>\<circ> B = A \<union>\<^sub>\<circ> (vinsert a B)"
  by auto

lemma vunion_vinsert_comm_right:
  "A \<union>\<^sub>\<circ> (vinsert a B) = (vinsert a A) \<union>\<^sub>\<circ> B"
  by auto

lemma vinsert_def: "vinsert y B = set {x. x = y} \<union>\<^sub>\<circ> B" by auto

lemma vunion_vinsert_left: "(vinsert a A) \<union>\<^sub>\<circ> B = vinsert a (A \<union>\<^sub>\<circ> B)" by auto

lemma vunion_vinsert_right: "A \<union>\<^sub>\<circ> (vinsert a B) = vinsert a (A \<union>\<^sub>\<circ> B)" by auto

text\<open>Special properties.\<close>

lemma vunion_fun_mono:
  assumes "mono f"
  shows "f A \<union>\<^sub>\<circ> f B \<subseteq>\<^sub>\<circ> f (A \<union>\<^sub>\<circ> B)"
  using assms by (fact mono_sup)

subsection\<open>Set difference\<close>

definition vdiff :: "V \<Rightarrow> V \<Rightarrow> V" (infixl \<open>-\<^sub>\<circ>\<close> 65)
  where "A -\<^sub>\<circ> B = set {x. x \<in>\<^sub>\<circ> A \<and> x \<notin>\<^sub>\<circ> B}"
notation vdiff (infixl "-\<^sub>\<circ>" 65)

lemma small_set_vdiff[simp]: "small {x. x \<in>\<^sub>\<circ> A \<and> x \<notin>\<^sub>\<circ> B}"
  by (rule down[of _ A]) simp

text\<open>Rules.\<close>

lemma vdiff_iff[simp]: "x \<in>\<^sub>\<circ> A -\<^sub>\<circ> B \<longleftrightarrow> x \<in>\<^sub>\<circ> A \<and> x \<notin>\<^sub>\<circ> B"
  unfolding vdiff_def by simp

lemma vdiffI[intro!]:
  assumes "x \<in>\<^sub>\<circ> A" and "x \<notin>\<^sub>\<circ> B"
  shows "x \<in>\<^sub>\<circ> A -\<^sub>\<circ> B"
  using assms by simp

lemma vdiffD1:
  assumes "x \<in>\<^sub>\<circ> A -\<^sub>\<circ> B"
  shows "x \<in>\<^sub>\<circ> A"
  using assms by simp

lemma vdiffD2:
  assumes "x \<in>\<^sub>\<circ> A -\<^sub>\<circ> B" and "x \<in>\<^sub>\<circ> B"
  shows P
  using assms by simp

lemma vdiffE[elim!]:
  assumes "x \<in>\<^sub>\<circ> A -\<^sub>\<circ> B" and "\<lbrakk> x \<in>\<^sub>\<circ> A; x \<notin>\<^sub>\<circ> B \<rbrakk> \<Longrightarrow> P"
  shows P
  using assms by simp

text\<open>Previous set operations.\<close>

lemma vsubset_vdiff:
  assumes "A \<subseteq>\<^sub>\<circ> B -\<^sub>\<circ> C"
  shows "A \<subseteq>\<^sub>\<circ> B"
  using assms by auto

lemma vinsert_vdiff_nin[simp]:
  assumes "a \<notin>\<^sub>\<circ> B"
  shows "vinsert a (A -\<^sub>\<circ> B) = vinsert a A -\<^sub>\<circ> B"
  using assms by auto

text\<open>Set operations.\<close>

lemma vdiff_vempty_left[simp]: "0 -\<^sub>\<circ> A = 0" by auto

lemma vdiff_vempty_right[simp]: "A -\<^sub>\<circ> 0 = A" by auto

lemma vdiff_vsingleton_vinsert[simp]: "set {a} -\<^sub>\<circ> vinsert a A = 0" by auto

lemma vdiff_vsingleton_in[simp]:
  assumes "a \<in>\<^sub>\<circ> A"
  shows "set {a} -\<^sub>\<circ> A = 0"
  using assms by auto

lemma vdiff_vsingleton_nin[simp]:
  assumes "a \<notin>\<^sub>\<circ> A"
  shows "set {a} -\<^sub>\<circ> A = set {a}"
  using assms by auto

lemma vdiff_vinsert_vsingleton[simp]: "vinsert a A -\<^sub>\<circ> set {a} = A -\<^sub>\<circ> set {a}"
  by auto

lemma vdiff_vsingleton[simp]:
  assumes "a \<notin>\<^sub>\<circ> A"
  shows "A -\<^sub>\<circ> set {a} = A"
  using assms by auto

lemma vdiff_vsubset:
  assumes "A \<subseteq>\<^sub>\<circ> B" and "D \<subseteq>\<^sub>\<circ> C"
  shows "A -\<^sub>\<circ> C \<subseteq>\<^sub>\<circ> B -\<^sub>\<circ> D"
  using assms by auto

lemma vdiff_vinsert_left_in[simp]:
  assumes "a \<in>\<^sub>\<circ> B"
  shows "(vinsert a A) -\<^sub>\<circ> B = A -\<^sub>\<circ> B"
  using assms by auto

lemma vdiff_vinsert_left_nin:
  assumes "a \<notin>\<^sub>\<circ> B"
  shows "(vinsert a A) -\<^sub>\<circ> B = vinsert a (A -\<^sub>\<circ> B)"
  using assms by auto

lemma vdiff_vinsert_right_in: "A -\<^sub>\<circ> (vinsert a B) = A -\<^sub>\<circ> B -\<^sub>\<circ> set {a}" by auto

lemma vdiff_vinsert_right_nin[simp]:
  assumes "a \<notin>\<^sub>\<circ> A"
  shows "A -\<^sub>\<circ> (vinsert a B) = A -\<^sub>\<circ> B"
  using assms by auto

lemma vdiff_vintersection_left: "(A \<inter>\<^sub>\<circ> B) -\<^sub>\<circ> C = (A -\<^sub>\<circ> C) \<inter>\<^sub>\<circ> (B -\<^sub>\<circ> C)" by auto

lemma vdiff_vunion_left: "(A \<union>\<^sub>\<circ> B) -\<^sub>\<circ> C = (A -\<^sub>\<circ> C) \<union>\<^sub>\<circ> (B -\<^sub>\<circ> C)" by auto

text\<open>Special properties.\<close>

lemma complement_vsubset: "I -\<^sub>\<circ> J \<subseteq>\<^sub>\<circ> I" by auto

lemma vintersection_complement: "(I -\<^sub>\<circ> J) \<inter>\<^sub>\<circ> J = 0" by auto

lemma vunion_complement:
  assumes "J \<subseteq>\<^sub>\<circ> I"
  shows "I -\<^sub>\<circ> J \<union>\<^sub>\<circ> J = I"
  using assms by auto

subsection\<open>Augmenting a set with an element\<close>

lemma vinsert_compr: "vinsert y A = set {x. x = y \<or> x \<in>\<^sub>\<circ> A}"
  unfolding vunion_def vinsert_def by simp_all

text\<open>Rules.\<close>

lemma vinsert_iff[simp]: "x \<in>\<^sub>\<circ> vinsert y A \<longleftrightarrow> x = y \<or> x \<in>\<^sub>\<circ> A" by simp

lemma vinsertI1: "x \<in>\<^sub>\<circ> vinsert x A" by simp

lemma vinsertI2:
  assumes "x \<in>\<^sub>\<circ> A"
  shows "x \<in>\<^sub>\<circ> vinsert y A"
  using assms by simp

lemma vinsertE1[elim!]:
  assumes "x \<in>\<^sub>\<circ> vinsert y A" and "x = y \<Longrightarrow> P" and "x \<in>\<^sub>\<circ> A \<Longrightarrow> P"
  shows P
  using assms unfolding vinsert_def by auto

lemma vinsertCI[intro!]:
  assumes "x \<notin>\<^sub>\<circ> A \<Longrightarrow> x = y"
  shows "x \<in>\<^sub>\<circ> vinsert y A"
  using assms by clarsimp

text\<open>Elementary properties.\<close>

lemma vinsert_insert: "vinsert a A = set (insert a (elts A))" by auto

lemma vinsert_commute: "vinsert a (vinsert b C) = vinsert b (vinsert a C)"
  by auto

lemma vinsert_ident:
  assumes "x \<notin>\<^sub>\<circ> A" and "x \<notin>\<^sub>\<circ> B"
  shows "vinsert x A = vinsert x B \<longleftrightarrow> A = B"
  using assms by force

lemmas vinsert_identD[dest] = vinsert_ident[THEN iffD1, rotated 2]
  and vinsert_identI[intro] = vinsert_ident[THEN iffD2]

text\<open>Set operations.\<close>

lemma vinsert_vempty: "vinsert a 0 = set {a}" by auto

lemma vinsert_vsingleton: "vinsert a (set {b}) = set {a, b}" by auto

lemma vinsert_vdoubleton: "vinsert a (set {b, c}) = set {a, b, c}" by auto

lemma vinsert_vinsert: "vinsert a (vinsert b C) = set {a, b} \<union>\<^sub>\<circ> C" by auto

lemma vinsert_vunion_left: "vinsert a (A \<union>\<^sub>\<circ> B) = vinsert a A \<union>\<^sub>\<circ> B" by auto

lemma vinsert_vunion_right: "vinsert a (A \<union>\<^sub>\<circ> B) = A \<union>\<^sub>\<circ> vinsert a B" by auto

lemma vinsert_vintersection: "vinsert a (A \<inter>\<^sub>\<circ> B) = vinsert a A \<inter>\<^sub>\<circ> vinsert a B"
  by auto

text\<open>Special properties.\<close>

lemma vinsert_set_insert_empty_anyI:
  assumes "P (vinsert a 0)"
  shows "P (set (insert a {}))"
  using assms by (simp add: vinsert_def)

lemma vinsert_set_insert_anyI:
  assumes "small B" and "P (vinsert a (set (insert b B)))"
  shows "P (set (insert a (insert b B)))"
  using assms by (simp add: ZFC_in_HOL.vinsert_def)

lemma vinsert_set_insert_eq:
  assumes "small B"
  shows "set (insert a (insert b B)) = vinsert a (set (insert b B))"
  using assms by (simp add: ZFC_in_HOL.vinsert_def)

lemma vsubset_vinsert:
  "A \<subseteq>\<^sub>\<circ> vinsert x B \<longleftrightarrow> (if x \<in>\<^sub>\<circ> A then A -\<^sub>\<circ> set {x} \<subseteq>\<^sub>\<circ> B else A \<subseteq>\<^sub>\<circ> B)"
  by auto

lemma vinsert_obtain_ne:
  assumes "A \<noteq> 0"
  obtains a A' where "A = vinsert a A'" and "a \<notin>\<^sub>\<circ> A'"
proof-
  from assms mem_not_refl obtain a where "a \<in>\<^sub>\<circ> A"
    by (auto intro!: vsubset_antisym)
  with \<open>a \<in>\<^sub>\<circ> A\<close> have "A = vinsert a (A -\<^sub>\<circ> set {a})" by auto
  then show ?thesis using that by auto
qed

subsection\<open>Power set\<close>

text\<open>Rules.\<close>

lemma VPowI:
  assumes "A \<subseteq>\<^sub>\<circ> B"
  shows "A \<in>\<^sub>\<circ> VPow B"
  using assms by simp

lemma VPowD:
  assumes "A \<in>\<^sub>\<circ> VPow B"
  shows "A \<subseteq>\<^sub>\<circ> B"
  using assms by (simp add: Pow_def)

lemma VPowE[elim]:
  assumes "A \<in>\<^sub>\<circ> VPow B" and "A \<subseteq>\<^sub>\<circ> B \<Longrightarrow> P"
  shows P
  using assms by auto

text\<open>Elementary properties.\<close>

lemma VPow_bottom: "0 \<in>\<^sub>\<circ> VPow B" by simp

lemma VPow_top: "A \<in>\<^sub>\<circ> VPow A" by simp

text\<open>Set operations.\<close>

lemma VPow_vempty[simp]: "VPow 0 = set {0}" by auto

lemma VPow_vsingleton[simp]: "VPow (set {a}) = set {0, set {a}}"
  by (rule vsubset_antisym; rule vsubsetI) auto

lemma VPow_not_vempty: "VPow A \<noteq> 0" by auto

lemma VPow_mono:
  assumes "A \<subseteq>\<^sub>\<circ> B"
  shows "VPow A \<subseteq>\<^sub>\<circ> VPow B"
  using assms by simp

lemma VPow_vunion_subset: "VPow A \<union>\<^sub>\<circ> VPow B \<subseteq>\<^sub>\<circ> VPow (A \<union>\<^sub>\<circ> B)" by simp

subsection\<open>Singletons, using insert\<close>

text\<open>Rules.\<close>

lemma vsingletonI[intro!]: "x \<in>\<^sub>\<circ> set {x}" by auto

lemma vsingletonD[dest!]:
  assumes "y \<in>\<^sub>\<circ> set {x}"
  shows "y = x"
  using assms by auto

lemma vsingleton_iff: "y \<in>\<^sub>\<circ> set {x} \<longleftrightarrow> y = x" by simp

text\<open>Previous set operations.\<close>

lemma VPow_vdoubleton[simp]:
  "VPow (set {a, b}) = set {0, set {a}, set {b}, set {a, b}}"
  by (intro vsubset_antisym vsubsetI)
    (auto intro!: vsubset_antisym simp: vinsert_set_insert_eq)

lemma vsubset_vinsertI:
  assumes "A -\<^sub>\<circ> set {x} \<subseteq>\<^sub>\<circ> B"
  shows "A \<subseteq>\<^sub>\<circ> vinsert x B"
  using assms by auto

text\<open>Special properties.\<close>

lemma vsingleton_inject:
  assumes "set {x} = set {y}"
  shows "x = y"
  using assms by simp

lemma vsingleton_insert_inj_eq[iff]:
  "set {y} = vinsert x A \<longleftrightarrow> x = y \<and> A \<subseteq>\<^sub>\<circ> set {y}"
  by auto

lemma vsingleton_insert_inj_eq'[iff]:
  "vinsert x A = set {y} \<longleftrightarrow> x = y \<and> A \<subseteq>\<^sub>\<circ> set {y}"
  by auto

lemma vsubset_vsingletonD:
  assumes "A \<subseteq>\<^sub>\<circ> set {x}"
  shows "A = 0 \<or> A = set {x}"
  using assms by auto

lemma vsubset_vsingleton_iff: "a \<subseteq>\<^sub>\<circ> set {x} \<longleftrightarrow> a = 0 \<or> a = set {x}" by auto

lemma vsubset_vdiff_vinsert: "A \<subseteq>\<^sub>\<circ> B -\<^sub>\<circ> vinsert x C \<longleftrightarrow> A \<subseteq>\<^sub>\<circ> B -\<^sub>\<circ> C \<and> x \<notin>\<^sub>\<circ> A"
  by auto

lemma vunion_vsingleton_iff:
  "A \<union>\<^sub>\<circ> B = set {x} \<longleftrightarrow>
    A = 0 \<and> B = set {x} \<or> A = set {x} \<and> B = 0 \<or> A = set {x} \<and> B = set {x}"
  by
    (
      metis
        vsubset_vsingletonD inf_sup_ord(4) sup.idem sup_V_0_right sup_commute
    )

lemma vsingleton_Un_iff:
  "set {x} = A \<union>\<^sub>\<circ> B \<longleftrightarrow>
    A = 0 \<and> B = set {x} \<or> A = set {x} \<and> B = 0 \<or> A = set {x} \<and> B = set {x}"
  by (metis vunion_vsingleton_iff sup_V_0_left sup_V_0_right sup_idem)

lemma VPow_vsingleton_iff[simp]: "VPow X = set {Y} \<longleftrightarrow> X = 0 \<and> Y = 0"
  by (auto intro!: vsubset_antisym)

subsection\<open>Intersection of elements\<close>

lemma small_VInter[simp]:
  assumes "A \<noteq> 0"
  shows "small {a. \<forall>x \<in>\<^sub>\<circ> A. a \<in>\<^sub>\<circ> x}"
  by (metis (no_types, lifting) assms down eq0_iff mem_Collect_eq subsetI)

lemma VInter_def: "\<Inter>\<^sub>\<circ> A = (if A = 0 then 0 else set {a. \<forall>x \<in>\<^sub>\<circ> A. a \<in>\<^sub>\<circ> x})"
proof(cases \<open>A = 0\<close>)
  case True show ?thesis unfolding True Inf_V_def by simp
next
  case False
  from False have "(\<Inter> (elts ` elts A)) = {a. \<forall>x \<in>\<^sub>\<circ> A. a \<in>\<^sub>\<circ> x}" by auto
  with False show ?thesis unfolding Inf_V_def by auto
qed

text\<open>Rules.\<close>

lemma VInter_iff[simp]:
  assumes [simp]: "A \<noteq> 0"
  shows "a \<in>\<^sub>\<circ> \<Inter>\<^sub>\<circ> A \<longleftrightarrow> (\<forall>x\<in>\<^sub>\<circ>A. a \<in>\<^sub>\<circ> x)"
  unfolding VInter_def by auto

lemma VInterI[intro]:
  assumes "A \<noteq> 0" and "\<And>x. x \<in>\<^sub>\<circ> A \<Longrightarrow> a \<in>\<^sub>\<circ> x"
  shows "a \<in>\<^sub>\<circ> \<Inter>\<^sub>\<circ> A"
  using assms by auto

lemma VInter0I[intro]:
  assumes "A = 0"
  shows "\<Inter>\<^sub>\<circ> A = 0"
  using assms unfolding VInter_def by simp

lemma VInterD[dest]:
  assumes "a \<in>\<^sub>\<circ> \<Inter>\<^sub>\<circ> A" and "x \<in>\<^sub>\<circ> A"
  shows "a \<in>\<^sub>\<circ> x"
  using assms by (cases \<open>A = 0\<close>) auto

lemma VInterE1[elim]:
  assumes "a \<in>\<^sub>\<circ> \<Inter>\<^sub>\<circ> A" and "x \<notin>\<^sub>\<circ> A \<Longrightarrow> R" and "a \<in>\<^sub>\<circ> x \<Longrightarrow> R"
  shows R
  using assms elts_0 unfolding Inter_eq by blast

lemma VInterE2[elim]:
  assumes "a \<in>\<^sub>\<circ> \<Inter>\<^sub>\<circ> A"
  obtains x where "a \<in>\<^sub>\<circ> x" and "x \<in>\<^sub>\<circ> A"
proof(cases \<open>A = 0\<close>)
  show "(\<And>x. a \<in>\<^sub>\<circ> x \<Longrightarrow> x \<in>\<^sub>\<circ> A \<Longrightarrow> thesis) \<Longrightarrow> A = 0 \<Longrightarrow> thesis"
    using assms unfolding Inf_V_def by auto
  show "(\<And>x. a \<in>\<^sub>\<circ> x \<Longrightarrow> x \<in>\<^sub>\<circ> A \<Longrightarrow> thesis) \<Longrightarrow> A \<noteq> 0 \<Longrightarrow> thesis"
    using assms by (meson assms VInterE1 that trad_foundation)
qed

lemma VInterE3: (*not elim*)
  assumes "a \<in>\<^sub>\<circ> \<Inter>\<^sub>\<circ> A" and "(\<And>y. y \<in>\<^sub>\<circ> A \<Longrightarrow> a \<in>\<^sub>\<circ> y) \<Longrightarrow> P"
  shows P
  using assms by auto

text\<open>Elementary properties.\<close>

lemma VInter_Inter: "\<Inter>\<^sub>\<circ> A = set (\<Inter> (elts ` (elts A)))"
  by (simp add: Inf_V_def ext)

lemma VInter_eq:
  assumes [simp]: "A \<noteq> 0"
  shows "\<Inter>\<^sub>\<circ> A = set {a. \<forall>x \<in>\<^sub>\<circ> A. a \<in>\<^sub>\<circ> x}"
  unfolding VInter_def by auto

text\<open>Set operations.\<close>

lemma VInter_vempty[simp]: "\<Inter>\<^sub>\<circ> 0 = 0" using VInter0I by auto

lemma VInf_vempty[simp]: "\<Sqinter>{} = (0::V)" by (simp add: Inf_V_def)

lemma VInter_vdoubleton: "\<Inter>\<^sub>\<circ> (set {a, b}) = a \<inter>\<^sub>\<circ> b"
proof(intro vsubset_antisym vsubsetI)
  show "x \<in>\<^sub>\<circ> \<Inter>\<^sub>\<circ> (set {a, b}) \<Longrightarrow> x \<in>\<^sub>\<circ> a \<inter>\<^sub>\<circ> b" for x by (elim VInterE3) auto
  show "x \<in>\<^sub>\<circ> a \<inter>\<^sub>\<circ> b \<Longrightarrow> x \<in>\<^sub>\<circ> \<Inter>\<^sub>\<circ> (set {a, b})" for x by (intro VInterI) force+
qed

lemma VInter_antimono:
  assumes "B \<noteq> 0" and "B \<subseteq>\<^sub>\<circ> A"
  shows "\<Inter>\<^sub>\<circ> A \<subseteq>\<^sub>\<circ> \<Inter>\<^sub>\<circ> B"
  using assms by blast

lemma VInter_vsubset:
  assumes "\<And>x. x \<in>\<^sub>\<circ> A \<Longrightarrow> x \<subseteq>\<^sub>\<circ> B" and "A \<noteq> 0"
  shows "\<Inter>\<^sub>\<circ> A \<subseteq>\<^sub>\<circ> B"
  using assms by auto

lemma VInter_vinsert:
  assumes "A \<noteq> 0"
  shows "\<Inter>\<^sub>\<circ> (vinsert a A) = a \<inter>\<^sub>\<circ> \<Inter>\<^sub>\<circ> A"
  using assms by (blast intro!: vsubset_antisym)

lemma VInter_vunion:
  assumes "A \<noteq> 0" and "B \<noteq> 0"
  shows "\<Inter>\<^sub>\<circ>(A \<union>\<^sub>\<circ> B) = \<Inter>\<^sub>\<circ>A \<inter>\<^sub>\<circ> \<Inter>\<^sub>\<circ>B"
  using assms by (blast intro!: vsubset_antisym)

lemma VInter_vintersection:
  assumes "A \<inter>\<^sub>\<circ> B \<noteq> 0"
  shows "\<Inter>\<^sub>\<circ> A \<union>\<^sub>\<circ> \<Inter>\<^sub>\<circ> B \<subseteq>\<^sub>\<circ> \<Inter>\<^sub>\<circ> (A \<inter>\<^sub>\<circ> B)"
  using assms by auto

lemma VInter_VPow: "\<Inter>\<^sub>\<circ> (VPow A) \<subseteq>\<^sub>\<circ> VPow (\<Inter>\<^sub>\<circ> A)" by auto

text\<open>Elementary properties.\<close>

lemma VInter_lower:
  assumes "x \<in>\<^sub>\<circ> A"
  shows "\<Inter>\<^sub>\<circ> A \<subseteq>\<^sub>\<circ> x"
  using assms by auto

lemma VInter_greatest:
  assumes "A \<noteq> 0" and "\<And>x. x \<in>\<^sub>\<circ> A \<Longrightarrow> B \<subseteq>\<^sub>\<circ> x"
  shows "B \<subseteq>\<^sub>\<circ> \<Inter>\<^sub>\<circ> A"
  using assms by auto

subsection\<open>Union of elements\<close>

lemma Union_eq_VUnion: "\<Union>(elts ` elts A) = {a. \<exists>x \<in>\<^sub>\<circ> A. a \<in>\<^sub>\<circ> x}" by auto

lemma small_VUnion[simp]: "small {a. \<exists>x \<in>\<^sub>\<circ> A. a \<in>\<^sub>\<circ> x}"
  by (fold Union_eq_VUnion) simp

lemma VUnion_def: "\<Union>\<^sub>\<circ>A = set {a. \<exists>x \<in>\<^sub>\<circ> A. a \<in>\<^sub>\<circ> x}"
  unfolding Sup_V_def by auto

text\<open>Rules.\<close>

lemma VUnion_iff[simp]: "A \<in>\<^sub>\<circ> \<Union>\<^sub>\<circ>C \<longleftrightarrow> (\<exists>x\<in>\<^sub>\<circ>C. A \<in>\<^sub>\<circ> x)" by auto

lemma VUnionI[intro]:
  assumes "x \<in>\<^sub>\<circ> A" and "a \<in>\<^sub>\<circ> x"
  shows "a \<in>\<^sub>\<circ> \<Union>\<^sub>\<circ>A"
  using assms by auto

lemma VUnionE[elim!]:
  assumes "a \<in>\<^sub>\<circ> \<Union>\<^sub>\<circ>A" and "\<And>x. a \<in>\<^sub>\<circ> x \<Longrightarrow> x \<in>\<^sub>\<circ> A \<Longrightarrow> R"
  shows R
  using assms by clarsimp

text\<open>Elementary properties.\<close>

lemma VUnion_Union: "\<Union>\<^sub>\<circ>A = set (\<Union> (elts ` (elts A)))"
  by (simp add: Inf_V_def ext)

text\<open>Set operations.\<close>

lemma VUnion_vempty[simp]: "\<Union>\<^sub>\<circ>0 = 0" by simp

lemma VUnion_vsingleton[simp]: "\<Union>\<^sub>\<circ>(set {a}) = a" by simp

lemma VUnion_vdoubleton[simp]: "\<Union>\<^sub>\<circ>(set {a, b}) = a \<union>\<^sub>\<circ> b" by auto

lemma VUnion_mono:
  assumes "A \<subseteq>\<^sub>\<circ> B"
  shows "\<Union>\<^sub>\<circ>A \<subseteq>\<^sub>\<circ> \<Union>\<^sub>\<circ>B"
  using assms by auto

lemma VUnion_vinsert: "\<Union>\<^sub>\<circ>(vinsert x A) = x \<union>\<^sub>\<circ> \<Union>\<^sub>\<circ>A" by auto

lemma VUnion_vintersection: "\<Union>\<^sub>\<circ>(A \<inter>\<^sub>\<circ> B) \<subseteq>\<^sub>\<circ> \<Union>\<^sub>\<circ>A \<inter>\<^sub>\<circ> \<Union>\<^sub>\<circ>B" by auto

lemma VUnion_vunion[simp]: "\<Union>\<^sub>\<circ>(A \<union>\<^sub>\<circ> B) = \<Union>\<^sub>\<circ>A \<union>\<^sub>\<circ> \<Union>\<^sub>\<circ>B" by auto

lemma VUnion_VPow[simp]: "\<Union>\<^sub>\<circ>(VPow A) = A" by auto

text\<open>Special properties.\<close>

lemma VUnion_vempty_conv_left: "0 = \<Union>\<^sub>\<circ>A \<longleftrightarrow> (\<forall>x\<in>\<^sub>\<circ>A. x = 0)" by auto

lemma VUnion_vempty_conv_right: "\<Union>\<^sub>\<circ>A = 0 \<longleftrightarrow> (\<forall>x\<in>\<^sub>\<circ>A. x = 0)" by auto

lemma vsubset_VPow_VUnion: "A \<subseteq>\<^sub>\<circ> VPow (\<Union>\<^sub>\<circ>A)" by auto

lemma VUnion_vsubsetI:
  assumes "\<And>x. x \<in>\<^sub>\<circ> A \<Longrightarrow> \<exists>y. y \<in>\<^sub>\<circ> B \<and> x \<subseteq>\<^sub>\<circ> y"
  shows "\<Union>\<^sub>\<circ>A \<subseteq>\<^sub>\<circ> \<Union>\<^sub>\<circ>B"
  using assms by auto

lemma VUnion_upper:
  assumes "x \<in>\<^sub>\<circ> A"
  shows "x \<subseteq>\<^sub>\<circ> \<Union>\<^sub>\<circ>A"
  using assms by auto

lemma VUnion_least:
  assumes "\<And>x. x \<in>\<^sub>\<circ> A \<Longrightarrow> x \<subseteq>\<^sub>\<circ> B"
  shows "\<Union>\<^sub>\<circ>A \<subseteq>\<^sub>\<circ> B"
  using assms by (fact Sup_least)

subsection\<open>Pairs\<close>

subsubsection\<open>Further results\<close>

lemma small_elts_of_set[simp, intro]:
  assumes "small x"
  shows "elts (set x) = x"
  by (simp add: assms)

lemma small_vpair[intro, simp]:
  assumes "small {a. P a}"
  shows "small {\<langle>a, b\<rangle> | a. P a}"
  by (subgoal_tac \<open>{\<langle>a, b\<rangle> | a. P a} = (\<lambda>a. \<langle>a, b\<rangle>) ` {a. P a}\<close>)
    (auto simp: assms)

subsubsection\<open>\<open>vpairs\<close>\<close>

definition vpairs :: "V \<Rightarrow> V" where
  "vpairs r = set {x. x \<in>\<^sub>\<circ> r \<and> (\<exists>a b. x = \<langle>a, b\<rangle>)}"

lemma small_vpairs[simp]: "small {\<langle>a, b\<rangle> | a b. \<langle>a, b\<rangle> \<in>\<^sub>\<circ> r}"
  by (rule down[of _ r]) clarsimp

text\<open>Rules.\<close>

lemma vpairsI[intro]:
  assumes "x \<in>\<^sub>\<circ> r" and "x = \<langle>a, b\<rangle>"
  shows "x \<in>\<^sub>\<circ> vpairs r"
  using assms unfolding vpairs_def by auto

lemma vpairsD[dest]:
  assumes "x \<in>\<^sub>\<circ> vpairs r"
  shows "x \<in>\<^sub>\<circ> r" and "\<exists>a b. x = \<langle>a, b\<rangle>"
  using assms unfolding vpairs_def by auto

lemma vpairsE[elim]:
  assumes "x \<in>\<^sub>\<circ> vpairs r"
  obtains a b where "x = \<langle>a, b\<rangle>" and "\<langle>a, b\<rangle> \<in>\<^sub>\<circ> r"
  using assms unfolding vpairs_def by auto

lemma vpairs_iff: "x \<in>\<^sub>\<circ> vpairs r \<longleftrightarrow> x \<in>\<^sub>\<circ> r \<and> (\<exists>a b. x = \<langle>a, b\<rangle>)" by auto

text\<open>Elementary properties.\<close>

lemma vpairs_iff_elts: "\<langle>a, b\<rangle> \<in>\<^sub>\<circ> vpairs r \<longleftrightarrow> \<langle>a, b\<rangle> \<in>\<^sub>\<circ> r" by auto

lemma vpairs_iff_pairs: "\<langle>a, b\<rangle> \<in>\<^sub>\<circ> vpairs r \<longleftrightarrow> (a, b) \<in> pairs r"
  by (simp add: vpairs_iff_elts pairs_iff_elts)

text\<open>Set operations.\<close>

lemma vpairs_vempty[simp]: "vpairs 0 = 0" by auto

lemma vpairs_vsingleton[simp]: "vpairs (set {\<langle>a, b\<rangle>}) = set {\<langle>a, b\<rangle>}" by auto

lemma vpairs_vinsert: "vpairs (vinsert \<langle>a, b\<rangle> A) = set {\<langle>a, b\<rangle>} \<union>\<^sub>\<circ> vpairs A"
  by auto

lemma vpairs_mono:
  assumes "r \<subseteq>\<^sub>\<circ> s"
  shows "vpairs r \<subseteq>\<^sub>\<circ> vpairs s"
  using assms by blast

lemma vpairs_vunion: "vpairs (A \<union>\<^sub>\<circ> B) = vpairs A \<union>\<^sub>\<circ> vpairs B" by auto

lemma vpairs_vintersection: "vpairs (A \<inter>\<^sub>\<circ> B) = vpairs A \<inter>\<^sub>\<circ> vpairs B" by auto

lemma vpairs_vdiff: "vpairs (A -\<^sub>\<circ> B) = vpairs A -\<^sub>\<circ> vpairs B" by auto

text\<open>Special properties.\<close>

lemma vpairs_ex_vfst:
  assumes "x \<in>\<^sub>\<circ> vpairs r"
  shows "\<exists>b. \<langle>vfst x, b\<rangle> \<in>\<^sub>\<circ> r"
  using assms by force

lemma vpairs_ex_vsnd:
  assumes "y \<in>\<^sub>\<circ> vpairs r"
  shows "\<exists>a. \<langle>a, vsnd y\<rangle> \<in>\<^sub>\<circ> r"
  using assms by force

subsection\<open>Cartesian products\<close>

text\<open>
The following lemma is based on Theorem 6.2 from
\<^cite>\<open>"takeuti_introduction_1971"\<close>.
\<close>

lemma vtimes_vsubset_VPowVPow: "A \<times>\<^sub>\<circ> B \<subseteq>\<^sub>\<circ> VPow (VPow (A \<union>\<^sub>\<circ> B))"
proof(intro vsubsetI)
  fix x assume "x \<in>\<^sub>\<circ> A \<times>\<^sub>\<circ> B"
  then obtain a b where x_def: "x = \<langle>a, b\<rangle>" and "a \<in>\<^sub>\<circ> A" and "b \<in>\<^sub>\<circ> B" by clarsimp
  then show "x \<in>\<^sub>\<circ> VPow (VPow (A \<union>\<^sub>\<circ> B))"
    unfolding x_def vpair_def by auto
qed

subsection\<open>Pairwise\<close>

definition vpairwise :: "(V \<Rightarrow> V \<Rightarrow> bool) \<Rightarrow> V \<Rightarrow> bool"
  where "vpairwise R S \<longleftrightarrow> (\<forall>x\<in>\<^sub>\<circ>S. \<forall>y\<in>\<^sub>\<circ>S. x \<noteq> y \<longrightarrow> R x y)"

text\<open>Rules.\<close>

lemma vpairwiseI[intro?]:
  assumes "\<And>x y. x \<in>\<^sub>\<circ> S \<Longrightarrow> y \<in>\<^sub>\<circ> S \<Longrightarrow> x \<noteq> y \<Longrightarrow> R x y"
  shows "vpairwise R S"
  using assms by (simp add: vpairwise_def)

lemma vpairwiseD[dest]:
  assumes "vpairwise R S" and "x \<in>\<^sub>\<circ> S" and "y \<in>\<^sub>\<circ> S" and "x \<noteq> y"
  shows "R x y" and "R y x"
  using assms unfolding vpairwise_def by auto

text\<open>Elementary properties.\<close>

lemma vpairwise_trivial[simp]: "vpairwise (\<lambda>i j. j \<noteq> i) I"
  by (auto simp: vpairwise_def)

text\<open>Set operations.\<close>

lemma vpairwise_vempty[simp]: "vpairwise P 0" by (force intro: vpairwiseI)

lemma vpairwise_vsingleton[simp]: "vpairwise P (set {A})"
  by (simp add: vpairwise_def)

lemma vpairwise_vinsert:
  "vpairwise r (vinsert x s) \<longleftrightarrow>
    (\<forall>y. y \<in>\<^sub>\<circ> s \<and> y \<noteq> x \<longrightarrow> r x y \<and> r y x) \<and> vpairwise r s"
  by (intro iffI conjI allI impI; (elim conjE | tactic\<open>all_tac\<close>))
    (auto simp: vpairwise_def)

lemma vpairwise_vsubset:
  assumes "vpairwise P S" and "T \<subseteq>\<^sub>\<circ> S"
  shows "vpairwise P T"
  using assms by (metis less_eq_V_def subset_eq vpairwiseD(2) vpairwiseI)

lemma vpairwise_mono:
  assumes "vpairwise P A" and "\<And>x y. P x y \<Longrightarrow> Q x y" and "B \<subseteq>\<^sub>\<circ> A"
  shows "vpairwise Q B"
  using assms by (simp add: less_eq_V_def subset_eq vpairwiseD(2) vpairwiseI)

subsection\<open>Disjoint sets\<close>

abbreviation vdisjnt :: "V \<Rightarrow> V \<Rightarrow> bool"
  where "vdisjnt A B \<equiv> A \<inter>\<^sub>\<circ> B = 0"

text\<open>Elementary properties.\<close>

lemma vdisjnt_sym:
  assumes "vdisjnt A B"
  shows "vdisjnt B A"
  using assms by blast

lemma vdisjnt_iff: "vdisjnt A B \<longleftrightarrow> (\<forall>x. ~ (x \<in>\<^sub>\<circ> A \<and> x \<in>\<^sub>\<circ> B))" by auto

text\<open>Set operations.\<close>

lemma vdisjnt_vempty1[simp]: "vdisjnt 0 A"
  and vdisjnt_vempty2[simp]: "vdisjnt A 0"
  by auto

lemma vdisjnt_singleton0[simp]: "vdisjnt (set {a}) (set {b}) \<longleftrightarrow> a \<noteq> b"
  and vdisjnt_singleton1[simp]: "vdisjnt (set {a}) A \<longleftrightarrow> a \<notin>\<^sub>\<circ> A"
  and vdisjnt_singleton2[simp]: "vdisjnt A (set {a}) \<longleftrightarrow> a \<notin>\<^sub>\<circ> A"
  by force+

lemma vdisjnt_vinsert_left: "vdisjnt (vinsert a X) Y \<longleftrightarrow> a \<notin>\<^sub>\<circ> Y \<and> vdisjnt X Y"
  by (metis vdisjnt_iff vdisjnt_sym vinsertE1 vinsertI2 vinsert_iff)

lemma vdisjnt_vinsert_right: "vdisjnt Y (vinsert a X) \<longleftrightarrow> a \<notin>\<^sub>\<circ> Y \<and> vdisjnt Y X"
  using vdisjnt_sym vdisjnt_vinsert_left by meson

lemma vdisjnt_vsubset_left:
  assumes "vdisjnt X Y" and "Z \<subseteq>\<^sub>\<circ> X"
  shows "vdisjnt Z Y"
  using assms by (auto intro!: vsubset_antisym)

lemma vdisjnt_vsubset_right:
  assumes "vdisjnt X Y" and "Z \<subseteq>\<^sub>\<circ> Y"
  shows "vdisjnt X Z"
  using assms by (auto intro!: vsubset_antisym)

lemma vdisjnt_vunion_left: "vdisjnt (A \<union>\<^sub>\<circ> B) C \<longleftrightarrow> vdisjnt A C \<and> vdisjnt B C"
  by auto

lemma vdisjnt_vunion_right: "vdisjnt C (A \<union>\<^sub>\<circ> B) \<longleftrightarrow> vdisjnt C A \<and> vdisjnt C B"
  by auto

text\<open>Special properties.\<close>

lemma vdisjnt_vemptyI[intro]:
  assumes "\<And>x. x \<in>\<^sub>\<circ> A \<Longrightarrow> x \<in>\<^sub>\<circ> B \<Longrightarrow> False"
  shows "vdisjnt A B"
  using assms by (auto intro!: vsubset_antisym)

lemma vdisjnt_self_iff_vempty[simp]: "vdisjnt S S \<longleftrightarrow> S = 0" by auto

lemma vdisjntI:
  assumes "\<And>x y. x \<in>\<^sub>\<circ> A \<Longrightarrow> y \<in>\<^sub>\<circ> B \<Longrightarrow> x \<noteq> y"
  shows "vdisjnt A B"
  using assms by auto

lemma vdisjnt_nin_right:
  assumes "vdisjnt A B" and "a \<in>\<^sub>\<circ> A"
  shows "a \<notin>\<^sub>\<circ> B"
  using assms by auto

lemma vdisjnt_nin_left:
  assumes "vdisjnt B A" and "a \<in>\<^sub>\<circ> A"
  shows "a \<notin>\<^sub>\<circ> B"
  using assms by auto

text\<open>\newpage\<close>

end