(*  Title:      ZF/Univ.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge

Standard notation for Vset(i) is V(i), but users might want V for a
variable.

NOTE: univ(A) could be a translation; would simplify many proofs!
  But Ind_Syntax.univ refers to the constant "Univ.univ"
*)

section{*The Cumulative Hierarchy and a Small Universe for Recursive Types*}

theory Univ imports Epsilon Cardinal begin

definition
  Vfrom       :: "[i,i]=>i"  where
    "Vfrom(A,i) == transrec(i, %x f. A \<union> (\<Union>y\<in>x. Pow(f`y)))"

abbreviation
  Vset :: "i=>i" where
  "Vset(x) == Vfrom(0,x)"

definition
  Vrec        :: "[i, [i,i]=>i] =>i"  where
    "Vrec(a,H) == transrec(rank(a), %x g. \<lambda>z\<in>Vset(succ(x)).
                           H(z, \<lambda>w\<in>Vset(x). g`rank(w)`w)) ` a"

definition
  Vrecursor   :: "[[i,i]=>i, i] =>i"  where
    "Vrecursor(H,a) == transrec(rank(a), %x g. \<lambda>z\<in>Vset(succ(x)).
                                H(\<lambda>w\<in>Vset(x). g`rank(w)`w, z)) ` a"

definition
  univ        :: "i=>i"  where
    "univ(A) == Vfrom(A,nat)"

subsection{*Immediate Consequences of the Definition of @{term "Vfrom(A,i)"}*}

text{*NOT SUITABLE FOR REWRITING -- RECURSIVE!*}
lemma Vfrom: "Vfrom(A,i) = A \<union> (\<Union>j\<in>i. Pow(Vfrom(A,j)))"
by (subst Vfrom_def [THEN def_transrec], simp)

subsubsection{* Monotonicity *}

lemma Vfrom_mono [rule_format]:
     "A<=B ==> \<forall>j. i<=j \<longrightarrow> Vfrom(A,i) \<subseteq> Vfrom(B,j)"
apply (rule_tac a=i in eps_induct)
apply (rule impI [THEN allI])
apply (subst Vfrom [of A])
apply (subst Vfrom [of B])
apply (erule Un_mono)
apply (erule UN_mono, blast)
done

lemma VfromI: "[| a \<in> Vfrom(A,j);  j<i |] ==> a \<in> Vfrom(A,i)"
by (blast dest: Vfrom_mono [OF subset_refl le_imp_subset [OF leI]])

subsubsection{* A fundamental equality: Vfrom does not require ordinals! *}

lemma Vfrom_rank_subset1: "Vfrom(A,x) \<subseteq> Vfrom(A,rank(x))"
proof (induct x rule: eps_induct)
  fix x
  assume "\<forall>y\<in>x. Vfrom(A,y) \<subseteq> Vfrom(A,rank(y))"
  thus "Vfrom(A, x) \<subseteq> Vfrom(A, rank(x))"
    by (simp add: Vfrom [of _ x] Vfrom [of _ "rank(x)"],
        blast intro!: rank_lt [THEN ltD])
qed

lemma Vfrom_rank_subset2: "Vfrom(A,rank(x)) \<subseteq> Vfrom(A,x)"
apply (rule_tac a=x in eps_induct)
apply (subst Vfrom)
apply (subst Vfrom, rule subset_refl [THEN Un_mono])
apply (rule UN_least)
txt{*expand @{text "rank(x1) = (\<Union>y\<in>x1. succ(rank(y)))"} in assumptions*}
apply (erule rank [THEN equalityD1, THEN subsetD, THEN UN_E])
apply (rule subset_trans)
apply (erule_tac [2] UN_upper)
apply (rule subset_refl [THEN Vfrom_mono, THEN subset_trans, THEN Pow_mono])
apply (erule ltI [THEN le_imp_subset])
apply (rule Ord_rank [THEN Ord_succ])
apply (erule bspec, assumption)
done

lemma Vfrom_rank_eq: "Vfrom(A,rank(x)) = Vfrom(A,x)"
apply (rule equalityI)
apply (rule Vfrom_rank_subset2)
apply (rule Vfrom_rank_subset1)
done

subsection{* Basic Closure Properties *}

lemma zero_in_Vfrom: "y:x ==> 0 \<in> Vfrom(A,x)"
by (subst Vfrom, blast)

lemma i_subset_Vfrom: "i \<subseteq> Vfrom(A,i)"
apply (rule_tac a=i in eps_induct)
apply (subst Vfrom, blast)
done

lemma A_subset_Vfrom: "A \<subseteq> Vfrom(A,i)"
apply (subst Vfrom)
apply (rule Un_upper1)
done

lemmas A_into_Vfrom = A_subset_Vfrom [THEN subsetD]

lemma subset_mem_Vfrom: "a \<subseteq> Vfrom(A,i) ==> a \<in> Vfrom(A,succ(i))"
by (subst Vfrom, blast)

subsubsection{* Finite sets and ordered pairs *}

lemma singleton_in_Vfrom: "a \<in> Vfrom(A,i) ==> {a} \<in> Vfrom(A,succ(i))"
by (rule subset_mem_Vfrom, safe)

lemma doubleton_in_Vfrom:
     "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i) |] ==> {a,b} \<in> Vfrom(A,succ(i))"
by (rule subset_mem_Vfrom, safe)

lemma Pair_in_Vfrom:
    "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i) |] ==> <a,b> \<in> Vfrom(A,succ(succ(i)))"
apply (unfold Pair_def)
apply (blast intro: doubleton_in_Vfrom)
done

lemma succ_in_Vfrom: "a \<subseteq> Vfrom(A,i) ==> succ(a) \<in> Vfrom(A,succ(succ(i)))"
apply (intro subset_mem_Vfrom succ_subsetI, assumption)
apply (erule subset_trans)
apply (rule Vfrom_mono [OF subset_refl subset_succI])
done

subsection{* 0, Successor and Limit Equations for @{term Vfrom} *}

lemma Vfrom_0: "Vfrom(A,0) = A"
by (subst Vfrom, blast)

lemma Vfrom_succ_lemma: "Ord(i) ==> Vfrom(A,succ(i)) = A \<union> Pow(Vfrom(A,i))"
apply (rule Vfrom [THEN trans])
apply (rule equalityI [THEN subst_context,
                       OF _ succI1 [THEN RepFunI, THEN Union_upper]])
apply (rule UN_least)
apply (rule subset_refl [THEN Vfrom_mono, THEN Pow_mono])
apply (erule ltI [THEN le_imp_subset])
apply (erule Ord_succ)
done

lemma Vfrom_succ: "Vfrom(A,succ(i)) = A \<union> Pow(Vfrom(A,i))"
apply (rule_tac x1 = "succ (i)" in Vfrom_rank_eq [THEN subst])
apply (rule_tac x1 = i in Vfrom_rank_eq [THEN subst])
apply (subst rank_succ)
apply (rule Ord_rank [THEN Vfrom_succ_lemma])
done

(*The premise distinguishes this from Vfrom(A,0);  allowing X=0 forces
  the conclusion to be Vfrom(A,\<Union>(X)) = A \<union> (\<Union>y\<in>X. Vfrom(A,y)) *)
lemma Vfrom_Union: "y:X ==> Vfrom(A,\<Union>(X)) = (\<Union>y\<in>X. Vfrom(A,y))"
apply (subst Vfrom)
apply (rule equalityI)
txt{*first inclusion*}
apply (rule Un_least)
apply (rule A_subset_Vfrom [THEN subset_trans])
apply (rule UN_upper, assumption)
apply (rule UN_least)
apply (erule UnionE)
apply (rule subset_trans)
apply (erule_tac [2] UN_upper,
       subst Vfrom, erule subset_trans [OF UN_upper Un_upper2])
txt{*opposite inclusion*}
apply (rule UN_least)
apply (subst Vfrom, blast)
done

subsection{* @{term Vfrom} applied to Limit Ordinals *}

(*NB. limit ordinals are non-empty:
      Vfrom(A,0) = A = A \<union> (\<Union>y\<in>0. Vfrom(A,y)) *)
lemma Limit_Vfrom_eq:
    "Limit(i) ==> Vfrom(A,i) = (\<Union>y\<in>i. Vfrom(A,y))"
apply (rule Limit_has_0 [THEN ltD, THEN Vfrom_Union, THEN subst], assumption)
apply (simp add: Limit_Union_eq)
done

lemma Limit_VfromE:
    "[| a \<in> Vfrom(A,i);  ~R ==> Limit(i);
        !!x. [| x<i;  a \<in> Vfrom(A,x) |] ==> R
     |] ==> R"
apply (rule classical)
apply (rule Limit_Vfrom_eq [THEN equalityD1, THEN subsetD, THEN UN_E])
  prefer 2 apply assumption
 apply blast
apply (blast intro: ltI Limit_is_Ord)
done

lemma singleton_in_VLimit:
    "[| a \<in> Vfrom(A,i);  Limit(i) |] ==> {a} \<in> Vfrom(A,i)"
apply (erule Limit_VfromE, assumption)
apply (erule singleton_in_Vfrom [THEN VfromI])
apply (blast intro: Limit_has_succ)
done

lemmas Vfrom_UnI1 =
    Un_upper1 [THEN subset_refl [THEN Vfrom_mono, THEN subsetD]]
lemmas Vfrom_UnI2 =
    Un_upper2 [THEN subset_refl [THEN Vfrom_mono, THEN subsetD]]

text{*Hard work is finding a single j:i such that {a,b}<=Vfrom(A,j)*}
lemma doubleton_in_VLimit:
    "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i) |] ==> {a,b} \<in> Vfrom(A,i)"
apply (erule Limit_VfromE, assumption)
apply (erule Limit_VfromE, assumption)
apply (blast intro:  VfromI [OF doubleton_in_Vfrom]
                     Vfrom_UnI1 Vfrom_UnI2 Limit_has_succ Un_least_lt)
done

lemma Pair_in_VLimit:
    "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i) |] ==> <a,b> \<in> Vfrom(A,i)"
txt{*Infer that a, b occur at ordinals x,xa < i.*}
apply (erule Limit_VfromE, assumption)
apply (erule Limit_VfromE, assumption)
txt{*Infer that @{term"succ(succ(x \<union> xa)) < i"} *}
apply (blast intro: VfromI [OF Pair_in_Vfrom]
                    Vfrom_UnI1 Vfrom_UnI2 Limit_has_succ Un_least_lt)
done

lemma product_VLimit: "Limit(i) ==> Vfrom(A,i) * Vfrom(A,i) \<subseteq> Vfrom(A,i)"
by (blast intro: Pair_in_VLimit)

lemmas Sigma_subset_VLimit =
     subset_trans [OF Sigma_mono product_VLimit]

lemmas nat_subset_VLimit =
     subset_trans [OF nat_le_Limit [THEN le_imp_subset] i_subset_Vfrom]

lemma nat_into_VLimit: "[| n: nat;  Limit(i) |] ==> n \<in> Vfrom(A,i)"
by (blast intro: nat_subset_VLimit [THEN subsetD])

subsubsection{* Closure under Disjoint Union *}

lemmas zero_in_VLimit = Limit_has_0 [THEN ltD, THEN zero_in_Vfrom]

lemma one_in_VLimit: "Limit(i) ==> 1 \<in> Vfrom(A,i)"
by (blast intro: nat_into_VLimit)

lemma Inl_in_VLimit:
    "[| a \<in> Vfrom(A,i); Limit(i) |] ==> Inl(a) \<in> Vfrom(A,i)"
apply (unfold Inl_def)
apply (blast intro: zero_in_VLimit Pair_in_VLimit)
done

lemma Inr_in_VLimit:
    "[| b \<in> Vfrom(A,i); Limit(i) |] ==> Inr(b) \<in> Vfrom(A,i)"
apply (unfold Inr_def)
apply (blast intro: one_in_VLimit Pair_in_VLimit)
done

lemma sum_VLimit: "Limit(i) ==> Vfrom(C,i)+Vfrom(C,i) \<subseteq> Vfrom(C,i)"
by (blast intro!: Inl_in_VLimit Inr_in_VLimit)

lemmas sum_subset_VLimit = subset_trans [OF sum_mono sum_VLimit]

subsection{* Properties assuming @{term "Transset(A)"} *}

lemma Transset_Vfrom: "Transset(A) ==> Transset(Vfrom(A,i))"
apply (rule_tac a=i in eps_induct)
apply (subst Vfrom)
apply (blast intro!: Transset_Union_family Transset_Un Transset_Pow)
done

lemma Transset_Vfrom_succ:
     "Transset(A) ==> Vfrom(A, succ(i)) = Pow(Vfrom(A,i))"
apply (rule Vfrom_succ [THEN trans])
apply (rule equalityI [OF _ Un_upper2])
apply (rule Un_least [OF _ subset_refl])
apply (rule A_subset_Vfrom [THEN subset_trans])
apply (erule Transset_Vfrom [THEN Transset_iff_Pow [THEN iffD1]])
done

lemma Transset_Pair_subset: "[| <a,b> \<subseteq> C; Transset(C) |] ==> a: C & b: C"
by (unfold Pair_def Transset_def, blast)

lemma Transset_Pair_subset_VLimit:
     "[| <a,b> \<subseteq> Vfrom(A,i);  Transset(A);  Limit(i) |]
      ==> <a,b> \<in> Vfrom(A,i)"
apply (erule Transset_Pair_subset [THEN conjE])
apply (erule Transset_Vfrom)
apply (blast intro: Pair_in_VLimit)
done

lemma Union_in_Vfrom:
     "[| X \<in> Vfrom(A,j);  Transset(A) |] ==> \<Union>(X) \<in> Vfrom(A, succ(j))"
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (unfold Transset_def, blast)
done

lemma Union_in_VLimit:
     "[| X \<in> Vfrom(A,i);  Limit(i);  Transset(A) |] ==> \<Union>(X) \<in> Vfrom(A,i)"
apply (rule Limit_VfromE, assumption+)
apply (blast intro: Limit_has_succ VfromI Union_in_Vfrom)
done

(*** Closure under product/sum applied to elements -- thus Vfrom(A,i)
     is a model of simple type theory provided A is a transitive set
     and i is a limit ordinal
***)

text{*General theorem for membership in Vfrom(A,i) when i is a limit ordinal*}
lemma in_VLimit:
  "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i);
      !!x y j. [| j<i; 1:j; x \<in> Vfrom(A,j); y \<in> Vfrom(A,j) |]
               ==> \<exists>k. h(x,y) \<in> Vfrom(A,k) & k<i |]
   ==> h(a,b) \<in> Vfrom(A,i)"
txt{*Infer that a, b occur at ordinals x,xa < i.*}
apply (erule Limit_VfromE, assumption)
apply (erule Limit_VfromE, assumption, atomize)
apply (drule_tac x=a in spec)
apply (drule_tac x=b in spec)
apply (drule_tac x="x \<union> xa \<union> 2" in spec)
apply (simp add: Un_least_lt_iff lt_Ord Vfrom_UnI1 Vfrom_UnI2)
apply (blast intro: Limit_has_0 Limit_has_succ VfromI)
done

subsubsection{* Products *}

lemma prod_in_Vfrom:
    "[| a \<in> Vfrom(A,j);  b \<in> Vfrom(A,j);  Transset(A) |]
     ==> a*b \<in> Vfrom(A, succ(succ(succ(j))))"
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (unfold Transset_def)
apply (blast intro: Pair_in_Vfrom)
done

lemma prod_in_VLimit:
  "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i);  Transset(A) |]
   ==> a*b \<in> Vfrom(A,i)"
apply (erule in_VLimit, assumption+)
apply (blast intro: prod_in_Vfrom Limit_has_succ)
done

subsubsection{* Disjoint Sums, or Quine Ordered Pairs *}

lemma sum_in_Vfrom:
    "[| a \<in> Vfrom(A,j);  b \<in> Vfrom(A,j);  Transset(A);  1:j |]
     ==> a+b \<in> Vfrom(A, succ(succ(succ(j))))"
apply (unfold sum_def)
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (unfold Transset_def)
apply (blast intro: zero_in_Vfrom Pair_in_Vfrom i_subset_Vfrom [THEN subsetD])
done

lemma sum_in_VLimit:
  "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i);  Transset(A) |]
   ==> a+b \<in> Vfrom(A,i)"
apply (erule in_VLimit, assumption+)
apply (blast intro: sum_in_Vfrom Limit_has_succ)
done

subsubsection{* Function Space! *}

lemma fun_in_Vfrom:
    "[| a \<in> Vfrom(A,j);  b \<in> Vfrom(A,j);  Transset(A) |] ==>
          a->b \<in> Vfrom(A, succ(succ(succ(succ(j)))))"
apply (unfold Pi_def)
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (rule Collect_subset [THEN subset_trans])
apply (subst Vfrom)
apply (rule subset_trans [THEN subset_trans])
apply (rule_tac [3] Un_upper2)
apply (rule_tac [2] succI1 [THEN UN_upper])
apply (rule Pow_mono)
apply (unfold Transset_def)
apply (blast intro: Pair_in_Vfrom)
done

lemma fun_in_VLimit:
  "[| a \<in> Vfrom(A,i);  b \<in> Vfrom(A,i);  Limit(i);  Transset(A) |]
   ==> a->b \<in> Vfrom(A,i)"
apply (erule in_VLimit, assumption+)
apply (blast intro: fun_in_Vfrom Limit_has_succ)
done

lemma Pow_in_Vfrom:
    "[| a \<in> Vfrom(A,j);  Transset(A) |] ==> Pow(a) \<in> Vfrom(A, succ(succ(j)))"
apply (drule Transset_Vfrom)
apply (rule subset_mem_Vfrom)
apply (unfold Transset_def)
apply (subst Vfrom, blast)
done

lemma Pow_in_VLimit:
     "[| a \<in> Vfrom(A,i);  Limit(i);  Transset(A) |] ==> Pow(a) \<in> Vfrom(A,i)"
by (blast elim: Limit_VfromE intro: Limit_has_succ Pow_in_Vfrom VfromI)

subsection{* The Set @{term "Vset(i)"} *}

lemma Vset: "Vset(i) = (\<Union>j\<in>i. Pow(Vset(j)))"
by (subst Vfrom, blast)

lemmas Vset_succ = Transset_0 [THEN Transset_Vfrom_succ]
lemmas Transset_Vset = Transset_0 [THEN Transset_Vfrom]

subsubsection{* Characterisation of the elements of @{term "Vset(i)"} *}

lemma VsetD [rule_format]: "Ord(i) ==> \<forall>b. b \<in> Vset(i) \<longrightarrow> rank(b) < i"
apply (erule trans_induct)
apply (subst Vset, safe)
apply (subst rank)
apply (blast intro: ltI UN_succ_least_lt)
done

lemma VsetI_lemma [rule_format]:
     "Ord(i) ==> \<forall>b. rank(b) \<in> i \<longrightarrow> b \<in> Vset(i)"
apply (erule trans_induct)
apply (rule allI)
apply (subst Vset)
apply (blast intro!: rank_lt [THEN ltD])
done

lemma VsetI: "rank(x)<i ==> x \<in> Vset(i)"
by (blast intro: VsetI_lemma elim: ltE)

text{*Merely a lemma for the next result*}
lemma Vset_Ord_rank_iff: "Ord(i) ==> b \<in> Vset(i) \<longleftrightarrow> rank(b) < i"
by (blast intro: VsetD VsetI)

lemma Vset_rank_iff [simp]: "b \<in> Vset(a) \<longleftrightarrow> rank(b) < rank(a)"
apply (rule Vfrom_rank_eq [THEN subst])
apply (rule Ord_rank [THEN Vset_Ord_rank_iff])
done

text{*This is rank(rank(a)) = rank(a) *}
declare Ord_rank [THEN rank_of_Ord, simp]

lemma rank_Vset: "Ord(i) ==> rank(Vset(i)) = i"
apply (subst rank)
apply (rule equalityI, safe)
apply (blast intro: VsetD [THEN ltD])
apply (blast intro: VsetD [THEN ltD] Ord_trans)
apply (blast intro: i_subset_Vfrom [THEN subsetD]
                    Ord_in_Ord [THEN rank_of_Ord, THEN ssubst])
done

lemma Finite_Vset: "i \<in> nat ==> Finite(Vset(i))"
apply (erule nat_induct)
 apply (simp add: Vfrom_0)
apply (simp add: Vset_succ)
done

subsubsection{* Reasoning about Sets in Terms of Their Elements' Ranks *}

lemma arg_subset_Vset_rank: "a \<subseteq> Vset(rank(a))"
apply (rule subsetI)
apply (erule rank_lt [THEN VsetI])
done

lemma Int_Vset_subset:
    "[| !!i. Ord(i) ==> a \<inter> Vset(i) \<subseteq> b |] ==> a \<subseteq> b"
apply (rule subset_trans)
apply (rule Int_greatest [OF subset_refl arg_subset_Vset_rank])
apply (blast intro: Ord_rank)
done

subsubsection{* Set Up an Environment for Simplification *}

lemma rank_Inl: "rank(a) < rank(Inl(a))"
apply (unfold Inl_def)
apply (rule rank_pair2)
done

lemma rank_Inr: "rank(a) < rank(Inr(a))"
apply (unfold Inr_def)
apply (rule rank_pair2)
done

lemmas rank_rls = rank_Inl rank_Inr rank_pair1 rank_pair2

subsubsection{* Recursion over Vset Levels! *}

text{*NOT SUITABLE FOR REWRITING: recursive!*}
lemma Vrec: "Vrec(a,H) = H(a, \<lambda>x\<in>Vset(rank(a)). Vrec(x,H))"
apply (unfold Vrec_def)
apply (subst transrec, simp)
apply (rule refl [THEN lam_cong, THEN subst_context], simp add: lt_def)
done

text{*This form avoids giant explosions in proofs.  NOTE USE OF == *}
lemma def_Vrec:
    "[| !!x. h(x)==Vrec(x,H) |] ==>
     h(a) = H(a, \<lambda>x\<in>Vset(rank(a)). h(x))"
apply simp
apply (rule Vrec)
done

text{*NOT SUITABLE FOR REWRITING: recursive!*}
lemma Vrecursor:
     "Vrecursor(H,a) = H(\<lambda>x\<in>Vset(rank(a)). Vrecursor(H,x),  a)"
apply (unfold Vrecursor_def)
apply (subst transrec, simp)
apply (rule refl [THEN lam_cong, THEN subst_context], simp add: lt_def)
done

text{*This form avoids giant explosions in proofs.  NOTE USE OF == *}
lemma def_Vrecursor:
     "h == Vrecursor(H) ==> h(a) = H(\<lambda>x\<in>Vset(rank(a)). h(x),  a)"
apply simp
apply (rule Vrecursor)
done

subsection{* The Datatype Universe: @{term "univ(A)"} *}

lemma univ_mono: "A<=B ==> univ(A) \<subseteq> univ(B)"
apply (unfold univ_def)
apply (erule Vfrom_mono)
apply (rule subset_refl)
done

lemma Transset_univ: "Transset(A) ==> Transset(univ(A))"
apply (unfold univ_def)
apply (erule Transset_Vfrom)
done

subsubsection{* The Set @{term"univ(A)"} as a Limit *}

lemma univ_eq_UN: "univ(A) = (\<Union>i\<in>nat. Vfrom(A,i))"
apply (unfold univ_def)
apply (rule Limit_nat [THEN Limit_Vfrom_eq])
done

lemma subset_univ_eq_Int: "c \<subseteq> univ(A) ==> c = (\<Union>i\<in>nat. c \<inter> Vfrom(A,i))"
apply (rule subset_UN_iff_eq [THEN iffD1])
apply (erule univ_eq_UN [THEN subst])
done

lemma univ_Int_Vfrom_subset:
    "[| a \<subseteq> univ(X);
        !!i. i:nat ==> a \<inter> Vfrom(X,i) \<subseteq> b |]
     ==> a \<subseteq> b"
apply (subst subset_univ_eq_Int, assumption)
apply (rule UN_least, simp)
done

lemma univ_Int_Vfrom_eq:
    "[| a \<subseteq> univ(X);   b \<subseteq> univ(X);
        !!i. i:nat ==> a \<inter> Vfrom(X,i) = b \<inter> Vfrom(X,i)
     |] ==> a = b"
apply (rule equalityI)
apply (rule univ_Int_Vfrom_subset, assumption)
apply (blast elim: equalityCE)
apply (rule univ_Int_Vfrom_subset, assumption)
apply (blast elim: equalityCE)
done

subsection{* Closure Properties for @{term "univ(A)"}*}

lemma zero_in_univ: "0 \<in> univ(A)"
apply (unfold univ_def)
apply (rule nat_0I [THEN zero_in_Vfrom])
done

lemma zero_subset_univ: "{0} \<subseteq> univ(A)"
by (blast intro: zero_in_univ)

lemma A_subset_univ: "A \<subseteq> univ(A)"
apply (unfold univ_def)
apply (rule A_subset_Vfrom)
done

lemmas A_into_univ = A_subset_univ [THEN subsetD]

subsubsection{* Closure under Unordered and Ordered Pairs *}

lemma singleton_in_univ: "a: univ(A) ==> {a} \<in> univ(A)"
apply (unfold univ_def)
apply (blast intro: singleton_in_VLimit Limit_nat)
done

lemma doubleton_in_univ:
    "[| a: univ(A);  b: univ(A) |] ==> {a,b} \<in> univ(A)"
apply (unfold univ_def)
apply (blast intro: doubleton_in_VLimit Limit_nat)
done

lemma Pair_in_univ:
    "[| a: univ(A);  b: univ(A) |] ==> <a,b> \<in> univ(A)"
apply (unfold univ_def)
apply (blast intro: Pair_in_VLimit Limit_nat)
done

lemma Union_in_univ:
     "[| X: univ(A);  Transset(A) |] ==> \<Union>(X) \<in> univ(A)"
apply (unfold univ_def)
apply (blast intro: Union_in_VLimit Limit_nat)
done

lemma product_univ: "univ(A)*univ(A) \<subseteq> univ(A)"
apply (unfold univ_def)
apply (rule Limit_nat [THEN product_VLimit])
done

subsubsection{* The Natural Numbers *}

lemma nat_subset_univ: "nat \<subseteq> univ(A)"
apply (unfold univ_def)
apply (rule i_subset_Vfrom)
done

text{* n:nat ==> n:univ(A) *}
lemmas nat_into_univ = nat_subset_univ [THEN subsetD]

subsubsection{* Instances for 1 and 2 *}

lemma one_in_univ: "1 \<in> univ(A)"
apply (unfold univ_def)
apply (rule Limit_nat [THEN one_in_VLimit])
done

text{*unused!*}
lemma two_in_univ: "2 \<in> univ(A)"
by (blast intro: nat_into_univ)

lemma bool_subset_univ: "bool \<subseteq> univ(A)"
apply (unfold bool_def)
apply (blast intro!: zero_in_univ one_in_univ)
done

lemmas bool_into_univ = bool_subset_univ [THEN subsetD]

subsubsection{* Closure under Disjoint Union *}

lemma Inl_in_univ: "a: univ(A) ==> Inl(a) \<in> univ(A)"
apply (unfold univ_def)
apply (erule Inl_in_VLimit [OF _ Limit_nat])
done

lemma Inr_in_univ: "b: univ(A) ==> Inr(b) \<in> univ(A)"
apply (unfold univ_def)
apply (erule Inr_in_VLimit [OF _ Limit_nat])
done

lemma sum_univ: "univ(C)+univ(C) \<subseteq> univ(C)"
apply (unfold univ_def)
apply (rule Limit_nat [THEN sum_VLimit])
done

lemmas sum_subset_univ = subset_trans [OF sum_mono sum_univ]

lemma Sigma_subset_univ:
  "[|A \<subseteq> univ(D); \<And>x. x \<in> A \<Longrightarrow> B(x) \<subseteq> univ(D)|] ==> Sigma(A,B) \<subseteq> univ(D)"
apply (simp add: univ_def)
apply (blast intro: Sigma_subset_VLimit del: subsetI)
done

(*Closure under binary union -- use Un_least
  Closure under Collect -- use  Collect_subset [THEN subset_trans]
  Closure under RepFun -- use   RepFun_subset *)

subsection{* Finite Branching Closure Properties *}

subsubsection{* Closure under Finite Powerset *}

lemma Fin_Vfrom_lemma:
     "[| b: Fin(Vfrom(A,i));  Limit(i) |] ==> \<exists>j. b \<subseteq> Vfrom(A,j) & j<i"
apply (erule Fin_induct)
apply (blast dest!: Limit_has_0, safe)
apply (erule Limit_VfromE, assumption)
apply (blast intro!: Un_least_lt intro: Vfrom_UnI1 Vfrom_UnI2)
done

lemma Fin_VLimit: "Limit(i) ==> Fin(Vfrom(A,i)) \<subseteq> Vfrom(A,i)"
apply (rule subsetI)
apply (drule Fin_Vfrom_lemma, safe)
apply (rule Vfrom [THEN ssubst])
apply (blast dest!: ltD)
done

lemmas Fin_subset_VLimit = subset_trans [OF Fin_mono Fin_VLimit]

lemma Fin_univ: "Fin(univ(A)) \<subseteq> univ(A)"
apply (unfold univ_def)
apply (rule Limit_nat [THEN Fin_VLimit])
done

subsubsection{* Closure under Finite Powers: Functions from a Natural Number *}

lemma nat_fun_VLimit:
     "[| n: nat;  Limit(i) |] ==> n -> Vfrom(A,i) \<subseteq> Vfrom(A,i)"
apply (erule nat_fun_subset_Fin [THEN subset_trans])
apply (blast del: subsetI
    intro: subset_refl Fin_subset_VLimit Sigma_subset_VLimit nat_subset_VLimit)
done

lemmas nat_fun_subset_VLimit = subset_trans [OF Pi_mono nat_fun_VLimit]

lemma nat_fun_univ: "n: nat ==> n -> univ(A) \<subseteq> univ(A)"
apply (unfold univ_def)
apply (erule nat_fun_VLimit [OF _ Limit_nat])
done

subsubsection{* Closure under Finite Function Space *}

text{*General but seldom-used version; normally the domain is fixed*}
lemma FiniteFun_VLimit1:
     "Limit(i) ==> Vfrom(A,i) -||> Vfrom(A,i) \<subseteq> Vfrom(A,i)"
apply (rule FiniteFun.dom_subset [THEN subset_trans])
apply (blast del: subsetI
             intro: Fin_subset_VLimit Sigma_subset_VLimit subset_refl)
done

lemma FiniteFun_univ1: "univ(A) -||> univ(A) \<subseteq> univ(A)"
apply (unfold univ_def)
apply (rule Limit_nat [THEN FiniteFun_VLimit1])
done

text{*Version for a fixed domain*}
lemma FiniteFun_VLimit:
     "[| W \<subseteq> Vfrom(A,i); Limit(i) |] ==> W -||> Vfrom(A,i) \<subseteq> Vfrom(A,i)"
apply (rule subset_trans)
apply (erule FiniteFun_mono [OF _ subset_refl])
apply (erule FiniteFun_VLimit1)
done

lemma FiniteFun_univ:
    "W \<subseteq> univ(A) ==> W -||> univ(A) \<subseteq> univ(A)"
apply (unfold univ_def)
apply (erule FiniteFun_VLimit [OF _ Limit_nat])
done

lemma FiniteFun_in_univ:
     "[| f: W -||> univ(A);  W \<subseteq> univ(A) |] ==> f \<in> univ(A)"
by (erule FiniteFun_univ [THEN subsetD], assumption)

text{*Remove @{text "\<subseteq>"} from the rule above*}
lemmas FiniteFun_in_univ' = FiniteFun_in_univ [OF _ subsetI]

subsection{** For QUniv.  Properties of Vfrom analogous to the "take-lemma" **}

text{* Intersecting a*b with Vfrom... *}

text{*This version says a, b exist one level down, in the smaller set Vfrom(X,i)*}
lemma doubleton_in_Vfrom_D:
     "[| {a,b} \<in> Vfrom(X,succ(i));  Transset(X) |]
      ==> a \<in> Vfrom(X,i)  &  b \<in> Vfrom(X,i)"
by (drule Transset_Vfrom_succ [THEN equalityD1, THEN subsetD, THEN PowD],
    assumption, fast)

text{*This weaker version says a, b exist at the same level*}
lemmas Vfrom_doubleton_D = Transset_Vfrom [THEN Transset_doubleton_D]

(** Using only the weaker theorem would prove <a,b> \<in> Vfrom(X,i)
      implies a, b \<in> Vfrom(X,i), which is useless for induction.
    Using only the stronger theorem would prove <a,b> \<in> Vfrom(X,succ(succ(i)))
      implies a, b \<in> Vfrom(X,i), leaving the succ(i) case untreated.
    The combination gives a reduction by precisely one level, which is
      most convenient for proofs.
**)

lemma Pair_in_Vfrom_D:
    "[| <a,b> \<in> Vfrom(X,succ(i));  Transset(X) |]
     ==> a \<in> Vfrom(X,i)  &  b \<in> Vfrom(X,i)"
apply (unfold Pair_def)
apply (blast dest!: doubleton_in_Vfrom_D Vfrom_doubleton_D)
done

lemma product_Int_Vfrom_subset:
     "Transset(X) ==>
      (a*b) \<inter> Vfrom(X, succ(i)) \<subseteq> (a \<inter> Vfrom(X,i)) * (b \<inter> Vfrom(X,i))"
by (blast dest!: Pair_in_Vfrom_D)

ML
{*
val rank_ss =
  simpset_of (@{context} addsimps [@{thm VsetI}]
    addsimps @{thms rank_rls} @ (@{thms rank_rls} RLN (2, [@{thm lt_trans}])));
*}

end


(*  File:       Electoral_Module.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>

chapter \<open>Component Types\<close>

section \<open>Electoral Module\<close>

theory Electoral_Module
  imports "Social_Choice_Types/Preference_Relation"
          "Social_Choice_Types/Profile"
          "Social_Choice_Types/Result"
          "Social_Choice_Types/Vectors"

begin

text
\<open>Electoral modules are the principal component type of the composable modules
voting framework, as they are a generalization of voting rules in the sense of
social choice functions.
These are only the types used for electoral modules. Further restrictions are
encompassed by the electoral-module predicate.

An electoral module does not need to make final decisions for all alternatives,
but can instead defer the decision for some or all of them to other modules.
Hence, electoral modules partition the received (possibly empty) set of
alternatives into elected, rejected and deferred alternatives. In particular,
any of those sets, e.g., the set of winning (elected) alternatives, may also
be left empty, as long as they collectively still hold all the received
alternatives. Just like a voting rule, an electoral module also receives a
profile which holds the voters’ preferences, which, unlike a voting rule,
consider only the (sub-)set of alternatives that the module receives.\<close>

subsection \<open>Definition\<close>

(*An electoral module maps a set of alternatives and a profile to a result.*)
type_synonym 'a Electoral_Module = "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Pair_Vectors \<Rightarrow> 'a Result"
(*type_synonym 'a Electoral_Module = "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Result"*)

subsection \<open>Auxiliary Definitions\<close>

(*
   Electoral modules partition a given set of alternatives A into a set of
   elected alternatives e, a set of rejected alternatives r, and a set of
   deferred alternatives d, using a profile.
   e, r, and d partition A.
   Electoral modules can be used as voting rules. They can also be composed
   in multiple structures to create more complex electoral modules.
*)
definition electoral_module :: " 'a Electoral_Module \<Rightarrow> bool" where
  "electoral_module m \<equiv> \<forall>A p vs. finite_profile A p \<and> finite_pair_vectors A vs
    \<longrightarrow> well_formed A (m A p vs)"

lemma electoral_modI:
  "((\<And>A p vs. \<lbrakk> finite_profile A p \<rbrakk> \<Longrightarrow> finite_pair_vectors A vs \<Longrightarrow> well_formed A (m A p vs))
     \<Longrightarrow> electoral_module m)"
  unfolding electoral_module_def
  by auto

(*
   The next three functions take an electoral module and turn it into a
   function only outputting the elect, reject, or defer set respectively.
*)
abbreviation elect ::
  "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Pair_Vectors \<Rightarrow> 'a set" where
  "elect m A p vs \<equiv> elect_r (m A p vs)"

abbreviation reject ::
  "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Pair_Vectors \<Rightarrow> 'a set" where
  "reject m A p vs \<equiv> reject_r (m A p vs)"

abbreviation "defer" ::
  "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Pair_Vectors \<Rightarrow> 'a set" where
  "defer m A p vs \<equiv> defer_r (m A p vs)"

(*
   "defers n" is true for all electoral modules that defer exactly
   n alternatives, whenever there are n or more alternatives.
*)
definition defers :: "nat \<Rightarrow> 'a Electoral_Module \<Rightarrow> bool" where
  "defers n m \<equiv>
    electoral_module m \<and>
      (\<forall>A p vs. (card A \<ge> n \<and> finite_profile A p \<and> finite_pair_vectors A vs) \<longrightarrow>
          card (defer m A p vs) = n)"

(*
   "rejects n" is true for all electoral modules that reject exactly
   n alternatives, whenever there are n or more alternatives.
*)
definition rejects :: "nat \<Rightarrow> 'a Electoral_Module \<Rightarrow> bool" where
  "rejects n m \<equiv>
    electoral_module m \<and>
      (\<forall>A p vs. (card A \<ge> n \<and> finite_profile A p \<and> finite_pair_vectors A vs)
      \<longrightarrow> card (reject m A p vs) = n)"

(*
   As opposed to "rejects", "eliminates" allows to stop rejecting if no
   alternatives were to remain.
*)
definition eliminates :: "nat \<Rightarrow> 'a Electoral_Module \<Rightarrow> bool" where
  "eliminates n m \<equiv>
    electoral_module m \<and>
      (\<forall>A p vs. (card A > n \<and> finite_profile A p \<and> finite_pair_vectors A vs)
      \<longrightarrow> card (reject m A p vs) = n)"

(*
   "elects n" is true for all electoral modules that
   elect exactly n alternatives, whenever there are n or more alternatives.
*)
definition elects :: "nat \<Rightarrow> 'a Electoral_Module \<Rightarrow> bool" where
  "elects n m \<equiv>
    electoral_module m \<and>
      (\<forall>A p vs. (card A \<ge> n \<and> finite_profile A p \<and> finite_pair_vectors A vs)
      \<longrightarrow> card (elect m A p vs) = n)"

(*
(*
   An Electoral module m is rejecting iff at least one alternative gets
   rejected when possible
*)
definition rejecting :: "'a Electoral_Module \<Rightarrow> bool" where
  "
  "rejecting m \<equiv> \<forall>A . card A > 1 \<longrightarrow> (\<exists>n . (n > 0 \<and> rejects n m))"

(*WRONG definition, choose `n > card A` and already it is always true.*)
(*An electoral module m is eliminating iff the following holds*)
(*
   If there is at least one alternative that can be rejected,
   at least one alternative gets rejected.
*)
definition eliminating :: "'a Electoral_Module \<Rightarrow> bool" where
  "eliminating m \<equiv>  \<exists> n . (n > 0 \<and> eliminates n m)"
*)

(*
   An electoral module is independent of an alternative a iff
   a's ranking does not influence the outcome.
*)
definition indep_of_alt :: "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> bool" where
  "indep_of_alt m A a \<equiv>
    electoral_module m \<and> (\<forall>p q vs. equiv_prof_except_a A p q a \<and> finite_pair_vectors A vs
      \<longrightarrow> m A p vs = m A q vs)"

subsection \<open>Equivalence Definitions\<close>

definition prof_contains_result :: "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Pair_Vectors \<Rightarrow>
                                    'a Profile \<Rightarrow> 'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "prof_contains_result m A vs p q a \<equiv>
    electoral_module m \<and> finite_profile A p \<and> finite_profile A q \<and> a \<in> A \<and>
    finite_pair_vectors A vs \<and>
    (a \<in> elect m A p vs \<longrightarrow> a \<in> elect m A q vs) \<and>
    (a \<in> reject m A p vs \<longrightarrow> a \<in> reject m A q vs) \<and>
    (a \<in> defer m A p vs \<longrightarrow> a \<in> defer m A q vs)"

definition prof_leq_result :: "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Pair_Vectors \<Rightarrow>
                                  'a Profile \<Rightarrow> 'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "prof_leq_result m A vs p q a \<equiv>
    electoral_module m \<and> finite_profile A p \<and> finite_profile A q \<and> a \<in> A
    \<and> finite_pair_vectors A vs \<and>
    (a \<in> reject m A p vs \<longrightarrow> a \<in> reject m A q vs) \<and>
    (a \<in> defer m A p vs \<longrightarrow> a \<notin> elect m A q vs)"

definition prof_geq_result :: "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Pair_Vectors \<Rightarrow>
                                  'a Profile \<Rightarrow> 'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "prof_geq_result m A vs p q a \<equiv>
    electoral_module m \<and> finite_profile A p \<and> finite_profile A q \<and> a \<in> A
    \<and> finite_pair_vectors A vs \<and>
    (a \<in> elect m A p vs \<longrightarrow> a \<in> elect m A q vs) \<and>
    (a \<in> defer m A p vs \<longrightarrow> a \<notin> reject m A q vs)"

definition mod_contains_result :: "'a Electoral_Module \<Rightarrow> 'a Electoral_Module \<Rightarrow>
                                      'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Pair_Vectors \<Rightarrow>
                                      'a \<Rightarrow> bool" where
  "mod_contains_result m n A p vs a \<equiv>
    electoral_module m \<and> electoral_module n \<and> finite_profile A p \<and> a \<in> A \<and>
    finite_pair_vectors A vs \<and>
    (a \<in> elect m A p vs \<longrightarrow> a \<in> elect n A p vs) \<and>
    (a \<in> reject m A p vs \<longrightarrow> a \<in> reject n A p vs) \<and>
    (a \<in> defer m A p vs \<longrightarrow> a \<in> defer n A p vs)"

subsection \<open>Auxiliary Lemmata\<close>

lemma combine_ele_rej_def:
  assumes
    ele: "elect m A p vs = e" and
    rej: "reject m A p vs = r" and
    def: "defer m A p vs = d"
  shows "m A p vs = (e, r, d)"
  using def ele rej
  by auto

lemma par_comp_result_sound:
  assumes
    mod_m: "electoral_module m" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows "well_formed A (m A p vs)"
  using electoral_module_def mod_m f_prof f_vec
  by auto

lemma result_presv_alts:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows "(elect m A p vs) \<union> (reject m A p vs) \<union> (defer m A p vs) = A"
proof (safe)
  fix
    x :: "'a"
  assume
    asm: "x \<in> elect m A p vs"
  have partit:
    "\<forall>A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists>B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  from e_mod f_prof f_vec have set_partit:
    "set_equals_partition A (m A p vs)"
    using electoral_module_def
    by auto
  thus "x \<in> A"
    using UnI1 asm fstI set_partit partit
    by (metis (no_types))
next
  fix
    x :: "'a"
  assume
    asm: "x \<in> reject m A p vs"
  have partit:
    "\<forall>A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists>B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  from e_mod f_prof f_vec have set_partit:
    "set_equals_partition A (m A p vs)"
    using electoral_module_def
    by auto
  thus "x \<in> A"
    using UnI1 asm fstI set_partit partit
          sndI subsetD sup_ge2
    by metis
next
  fix
    x :: "'a"
  assume
    asm: "x \<in> defer m A p vs"
  have partit:
    "\<forall>A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists>B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  from e_mod f_prof f_vec have set_partit:
    "set_equals_partition A (m A p vs)"
    using electoral_module_def
    by auto
  thus "x \<in> A"
    using asm set_partit partit sndI subsetD sup_ge2
    by metis
next
  fix
    x :: "'a"
  assume
    asm1: "x \<in> A" and
    asm2: "x \<notin> defer m A p vs" and
    asm3: "x \<notin> reject m A p vs"
  have partit:
    "\<forall>A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists>B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  from e_mod f_prof f_vec have set_partit:
    "set_equals_partition A (m A p vs)"
    using electoral_module_def
    by auto
  show "x \<in> elect m A p vs"
    using asm1 asm2 asm3 fst_conv partit
          set_partit snd_conv Un_iff
    by metis
qed

lemma result_disj:
  assumes
    module: "electoral_module m" and
    profile: "finite_profile A p" and
    vectors: "finite_pair_vectors A vs"
  shows
    "(elect m A p vs) \<inter> (reject m A p vs) = {} \<and>
        (elect m A p vs) \<inter> (defer m A p vs) = {} \<and>
        (reject m A p vs) \<inter> (defer m A p vs) = {}"
proof (safe, simp_all)
  fix
    x :: "'a"
  assume
    asm1: "x \<in> elect m A p vs" and
    asm2: "x \<in> reject m A p vs"
  have partit:
    "\<forall>A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists>B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  from module profile vectors have set_partit:
    "set_equals_partition A (m A p vs)"
    using electoral_module_def
    by auto
  from profile have prof_p:
    "finite A \<and> profile A p"
    by simp
  from module prof_p vectors have wf_A_m:
    "well_formed A (m A p vs)"
    using electoral_module_def
    by metis
  show "False"
    using prod.exhaust_sel DiffE UnCI asm1 asm2
          module profile result_imp_rej wf_A_m
          prof_p set_partit partit
    by (metis (no_types))
next
  fix
    x :: "'a"
  assume
    asm1: "x \<in> elect m A p vs" and
    asm2: "x \<in> defer m A p vs"
  have partit:
    "\<forall>A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists>B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  have disj:
    "\<forall>p. \<not> disjoint3 p \<or>
      (\<exists>B C D. p = (B::'a set, C, D) \<and>
        B \<inter> C = {} \<and> B \<inter> D = {} \<and> C \<inter> D = {})"
    by simp
  from profile have prof_p:
    "finite A \<and> profile A p"
    by simp
  from module prof_p vectors have wf_A_m:
    "well_formed A (m A p vs)"
    using electoral_module_def
    by metis
  hence wf_A_m_0:
    "disjoint3 (m A p vs) \<and> set_equals_partition A (m A p vs)"
    by simp
  hence disj3:
    "disjoint3 (m A p vs)"
    by simp
  have set_partit:
    "set_equals_partition A (m A p vs)"
    using wf_A_m_0
    by simp
  from disj3 obtain
    AA :: "'a Result \<Rightarrow> 'a set" and
    AAa :: "'a Result \<Rightarrow> 'a set" and
    AAb :: "'a Result \<Rightarrow> 'a set"
    where
    "m A p vs =
      (AA (m A p vs), AAa (m A p vs), AAb (m A p vs)) \<and>
        AA (m A p vs) \<inter> AAa (m A p vs) = {} \<and>
        AA (m A p vs) \<inter> AAb (m A p vs) = {} \<and>
        AAa (m A p vs) \<inter> AAb (m A p vs) = {}"
    using asm1 asm2 disj
    by metis
  hence "((elect m A p vs) \<inter> (reject m A p vs) = {}) \<and>
          ((elect m A p vs) \<inter> (defer m A p vs) = {}) \<and>
          ((reject m A p vs) \<inter> (defer m A p vs) = {})"
    using disj3 eq_snd_iff fstI
    by metis
  thus "False"
    using asm1 asm2 module profile wf_A_m prof_p
          set_partit partit disjoint_iff_not_equal
    by (metis (no_types))
next
  fix
    x :: "'a"
  assume
    asm1: "x \<in> reject m A p vs" and
    asm2: "x \<in> defer m A p vs"
  have partit:
    "\<forall>A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists>B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  from module profile vectors have set_partit:
    "set_equals_partition A (m A p vs)"
    using electoral_module_def
    by auto
  from profile have prof_p:
    "finite A \<and> profile A p"
    by simp
  from module prof_p vectors have wf_A_m:
    "well_formed A (m A p vs)"
    using electoral_module_def
    by metis
  show "False"
    using prod.exhaust_sel DiffE UnCI asm1 asm2
          module profile result_imp_rej wf_A_m
          prof_p set_partit partit
    by (metis (no_types))
qed

lemma elect_in_alts:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows "elect m A p vs \<subseteq> A"
  using le_supI1 e_mod f_prof f_vec result_presv_alts sup_ge1
  by metis

lemma reject_in_alts:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows "reject m A p vs \<subseteq> A"
  using le_supI1 e_mod f_prof f_vec result_presv_alts sup_ge2
  by fastforce

lemma defer_in_alts:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows "defer m A p vs \<subseteq> A"
  using e_mod f_prof f_vec result_presv_alts
  by blast

lemma def_presv_fin_prof:
  assumes module:  "electoral_module m" and
          f_prof: "finite_profile A p" and
          f_vec: "finite_pair_vectors A vs"
  shows
    "let new_A = defer m A p vs in
        finite_profile new_A (limit_profile new_A p)"
  using defer_in_alts infinite_super
        limit_profile_sound module f_prof f_vec
  by metis

lemma def_presv_fin_vector_pair:
  assumes module:  "electoral_module m" and
          f_prof: "finite_profile A p" and
          f_vec: "finite_pair_vectors A vs"
  shows
    "let new_A = defer m A p vs in
        finite_pair_vectors new_A (limit_pair_vectors new_A vs)"
proof-
  have 0:"let new_A = defer m A p vs in finite new_A"
    by (metis def_presv_fin_prof f_prof f_vec module)
  have 1:"let new_A = defer m A p vs in vector_pair new_A (limit_pair_vectors new_A vs)"
    by (meson defer_in_alts f_prof f_vec limit_pair_vectors_sound module)
  show "let new_A = defer m A p vs in
        finite_pair_vectors new_A (limit_pair_vectors new_A vs)"
    using 0 1 by simp
qed

(*
   An electoral module can never reject, defer or elect more than
   |A| alternatives.
*)
lemma upper_card_bounds_for_result:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p" and
    f_vec: "vector_pair A vs"
  shows
    "card (elect m A p vs) \<le> card A \<and>
      card (reject m A p vs) \<le> card A \<and>
      card (defer m A p vs) \<le> card A "
  by (simp add: card_mono defer_in_alts elect_in_alts
                e_mod f_prof f_vec reject_in_alts)

lemma reject_not_elec_or_def:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows "reject m A p vs = A - (elect m A p vs) - (defer m A p vs)"
proof -
  from e_mod f_prof f_vec have 0: "well_formed A (m A p vs)"
    by (simp add: electoral_module_def)
  with e_mod f_prof f_vec
    have "(elect m A p vs) \<union> (reject m A p vs) \<union> (defer m A p vs) = A"
      using result_presv_alts
      by blast
    moreover from 0 have
      "(elect m A p vs) \<inter> (reject m A p vs) = {} \<and>
          (reject m A p vs) \<inter> (defer m A p vs) = {}"
    using e_mod f_prof f_vec result_disj
    by blast
  ultimately show ?thesis
    by blast
qed

lemma elec_and_def_not_rej:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows "elect m A p vs \<union> defer m A p vs = A - (reject m A p vs)"
proof -
  from e_mod f_prof f_vec have 0: "well_formed A (m A p vs)"
    by (simp add: electoral_module_def)
  hence
    "disjoint3 (m A p vs) \<and> set_equals_partition A (m A p vs)"
    by simp
  with e_mod f_prof f_vec
  have "(elect m A p vs) \<union> (reject m A p vs) \<union> (defer m A p vs) = A"
    using e_mod f_prof result_presv_alts
    by blast
  moreover from 0 have
    "(elect m A p vs) \<inter> (reject m A p vs) = {} \<and>
        (reject m A p vs) \<inter> (defer m A p vs) = {}"
    using e_mod f_prof f_vec result_disj
    by blast
  ultimately show ?thesis
    by blast
qed

lemma defer_not_elec_or_rej:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows "defer m A p vs = A - (elect m A p vs) - (reject m A p vs)"
proof -
  from e_mod f_prof f_vec have 0: "well_formed A (m A p vs)"
    by (simp add: electoral_module_def)
  hence "(elect m A p vs) \<union> (reject m A p vs) \<union> (defer m A p vs) = A"
    using e_mod f_prof f_vec result_presv_alts
    by blast
  moreover from 0 have
    "(elect m A p vs) \<inter> (defer m A p vs) = {} \<and>
        (reject m A p vs) \<inter> (defer m A p vs) = {}"
      using e_mod f_prof f_vec result_disj
      by blast
  ultimately show ?thesis
    by blast
qed

lemma electoral_mod_defer_elem:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs" and
    alternative: "x \<in> A" and
    not_elected: "x \<notin> elect m A p vs" and
    not_rejected: "x \<notin> reject m A p vs"
  shows "x \<in> defer m A p vs"
  using DiffI e_mod f_prof f_vec alternative
        not_elected not_rejected
        reject_not_elec_or_def
  by metis

lemma mod_contains_result_comm:
  assumes "mod_contains_result m n A p vs a"
  shows "mod_contains_result n m A p vs a"
  unfolding mod_contains_result_def
proof (safe)
  show "electoral_module n"
    using assms mod_contains_result_def
    by metis
next
  show "electoral_module m"
    using assms mod_contains_result_def
    by metis
next
  show "finite A"
    using assms mod_contains_result_def
    by metis
next
  show "profile A p"
    using assms mod_contains_result_def
    by metis
next
  show "a \<in> A"
    using assms mod_contains_result_def
    by metis
next
  show "vector_pair A vs"
    using assms mod_contains_result_def
    by metis
next
  show "finite A"
    using assms mod_contains_result_def
    by metis
next
  assume "a \<in> elect n A p vs"
  thus "a \<in> elect m A p vs"
    using IntI assms electoral_mod_defer_elem empty_iff
          mod_contains_result_def result_disj
    by (metis (mono_tags, lifting))
next
  assume "a \<in> reject n A p vs"
  thus "a \<in> reject m A p vs"
    using IntI assms electoral_mod_defer_elem empty_iff
          mod_contains_result_def result_disj
    by (metis (mono_tags, lifting))
next
  assume "a \<in> defer n A p vs"
  thus "a \<in> defer m A p vs"
    using IntI assms electoral_mod_defer_elem empty_iff
          mod_contains_result_def result_disj
    by (metis (mono_tags, lifting))
qed

lemma not_rej_imp_elec_or_def:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p" and
    alternative: "x \<in> A" and
    not_rejected: "x \<notin> reject m A p vs" and
    f_vec: "finite_pair_vectors A vs"
  shows "x \<in> elect m A p vs \<or> x \<in> defer m A p vs"
  using alternative electoral_mod_defer_elem
        e_mod not_rejected f_prof f_vec
  by metis

lemma single_elim_imp_red_def_set:
  assumes
    eliminating: "eliminates 1 m" and
    leftover_alternatives: "card A > 1" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows "defer m A p vs \<subset> A"
  using Diff_eq_empty_iff Diff_subset card_eq_0_iff defer_in_alts
        eliminates_def eliminating eq_iff leftover_alternatives
        not_one_le_zero f_prof psubsetI reject_not_elec_or_def f_vec
  by metis

lemma eq_alts_in_profs_imp_eq_results:
  assumes
    eq: "\<forall>a \<in> A. prof_contains_result m A vs p q a" and
    (*for empty A*)
    input: "electoral_module m \<and> finite_profile A p \<and> finite_profile A q \<and>
    vector_pair A vs"
  shows "m A p vs = m A q vs"
proof -
  have "\<forall>a \<in> elect m A p vs. a \<in> elect m A q vs"
    using elect_in_alts eq prof_contains_result_def input in_mono
    by metis
  moreover have "\<forall>a \<in> elect m A q vs. a \<in> elect m A p vs"
    using contra_subsetD disjoint_iff_not_equal elect_in_alts
          electoral_mod_defer_elem eq prof_contains_result_def input
          result_disj
  proof -
    fix aa :: 'a
    have "\<forall> A Aa. (Aa::'a set) \<inter> A = {} \<or> Aa \<noteq> {}"
      by blast
    moreover have f1: "elect m A q vs - A = {}"
      using Diff_eq_empty_iff elect_in_alts input
      by metis
    moreover have f2: "defer m A q vs \<inter> elect m A q vs = {}"
      using disjoint_iff_not_equal input result_disj
      by (metis (no_types))
    moreover have f3: "reject m A q vs \<inter> elect m A q vs = {}"
      using disjoint_iff_not_equal input result_disj
      by (metis (no_types))
    ultimately have f4:
      "(\<exists> Aa. Aa \<inter> elect m A q vs = {} \<and> aa \<in> Aa) \<or>
          aa \<notin> elect m A q vs \<or> aa \<in> elect m A p vs"
      using DiffI electoral_mod_defer_elem eq prof_contains_result_def
      by (metis (no_types))
    hence f5:
      "aa \<notin> elect m A q vs \<or> aa \<in> elect m A p vs"
      using disjoint_iff_not_equal
      by metis
    from f1 f2 f3
    show ?thesis
      using Diff_iff Int_iff empty_iff eq not_rej_imp_elec_or_def
            prof_contains_result_def
      by metis
  qed
  moreover have
    "\<forall>a \<in> reject m A p vs. a \<in> reject m A q vs"
    using reject_in_alts eq prof_contains_result_def input in_mono
    by fastforce
  moreover have
    "\<forall>a \<in> reject m A q vs. a \<in> reject m A p vs"
  proof -
    {
      fix aa :: 'a
      have ff1:
        "\<forall> f. reject f A q vs \<subseteq> A \<or> \<not> electoral_module f"
        using input reject_in_alts
        by metis
      have ff2:
        "\<forall> f. reject f A q vs \<inter> defer f A q vs = {} \<or> \<not> electoral_module f"
        using input result_disj
        by metis
      have "electoral_module m \<and> profile A p \<and> finite_profile A q"
        using input
        by blast
      hence ff3:
        "elect m A q vs \<inter> reject m A q vs = {} \<and> elect m A q vs \<inter> defer m A q vs = {} \<and>
          reject m A q vs \<inter> defer m A q vs = {}"
        using input
        by (simp add: result_disj)
      hence
        "aa \<in> elect m A q vs \<longrightarrow> aa \<notin> reject m A q vs \<or> aa \<in> reject m A p vs"
        using disjoint_iff_not_equal ff3
        by metis
      hence "aa \<notin> reject m A q vs \<or> aa \<in> reject m A p vs"
        using ff2 ff1 electoral_mod_defer_elem eq
              input prof_contains_result_def
        by fastforce
    }
    thus ?thesis
      by metis
  qed
  moreover have "\<forall>a \<in> defer m A p vs. a \<in> defer m A q vs"
    using defer_in_alts eq prof_contains_result_def input in_mono
    by fastforce
  moreover have "\<forall>a \<in> defer m A q vs. a \<in> defer m A p vs"
  proof (safe)
    fix a :: "'a"
    assume "a \<in> defer m A q vs"
    thus "a \<in> defer m A p vs"
      using calculation defer_not_elec_or_rej
            input subsetI subset_antisym
      by (metis)
  qed
  ultimately show ?thesis
    using prod.collapse subsetI subset_antisym
    by (metis)
qed

lemma eq_def_and_elect_imp_eq:
  assumes
    "electoral_module m" and
    "electoral_module n" and
    "finite_profile A p" and
    "finite_profile A q" and
    "finite_pair_vectors A vs" and
    "elect m A p vs = elect n A q vs" and
    "defer m A p vs = defer n A q vs"
  shows "m A p vs = n A q vs"
proof -
  have disj_m:
    "disjoint3 (m A p vs)"
    using assms(1) assms(3) assms(5) electoral_module_def
    by auto
  have disj_n:
    "disjoint3 (n A q vs)"
    using assms(2) assms(4) assms(5) electoral_module_def
    by auto
  have set_partit_m:
    "set_equals_partition A ((elect m A p vs), (reject m A p vs), (defer m A p vs))"
    using assms(1) assms(3) assms(5) electoral_module_def
    by auto
  moreover have
    "disjoint3 ((elect m A p vs),(reject m A p vs),(defer m A p vs))"
    using disj_m prod.collapse
    by metis
  have set_partit_n:
    "set_equals_partition A ((elect n A q vs), (reject n A q vs), (defer n A q vs))"
    using assms(2) assms(4) assms(5) electoral_module_def
    by auto
  moreover have
    "disjoint3 ((elect n A q vs),(reject n A q vs),(defer n A q vs))"
    using disj_n prod.collapse
    by metis
  have reject_p:
    "reject m A p vs = A - ((elect m A p vs) \<union> (defer m A p vs))"
    using assms(1) assms(3) assms(5) combine_ele_rej_def
          electoral_module_def result_imp_rej
    by metis
  have reject_q:
    "reject n A q vs = A - ((elect n A q vs) \<union> (defer n A q vs))"
    using assms(2) assms(4) assms(5) combine_ele_rej_def
          electoral_module_def result_imp_rej
    by metis
  from reject_p reject_q
  show ?thesis
    by (simp add: assms(6) assms(7) prod_eqI)
qed

subsection \<open>Non-Blocking\<close>

(*
   An electoral module is non-blocking iff
   this module never rejects all alternatives.
*)
definition non_blocking :: "'a Electoral_Module \<Rightarrow> bool" where
  "non_blocking m \<equiv>
    electoral_module m \<and>
      (\<forall>A p vs.
          ((A \<noteq> {} \<and> finite_profile A p \<and> finite_pair_vectors A vs) \<longrightarrow> reject m A p vs \<noteq> A))"

subsection \<open>Electing\<close>

(*
   An electoral module is electing iff
   it always elects at least one alternative.
*)
definition electing :: "'a Electoral_Module \<Rightarrow> bool" where
  "electing m \<equiv>
    electoral_module m \<and>
      (\<forall>A p vs. (A \<noteq> {} \<and> finite_profile A p \<and> finite_pair_vectors A vs) \<longrightarrow> elect m A p vs \<noteq> {})"

lemma electing_for_only_alt:
  assumes
    one_alt: "card A = 1" and
    electing: "electing m" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows "elect m A p vs = A"
proof (safe)
  fix x :: "'a"
  assume
    electX: "x \<in> elect m A p vs"
  have
    "\<not> electoral_module m \<or> elect m A p vs \<subseteq> A"
    using elect_in_alts f_prof f_vec
    by (simp add: elect_in_alts)
  with electing have "elect m A p vs \<subseteq> A"
    unfolding electing_def
    by metis
  with electX show "x \<in> A"
    by auto
next
  fix x :: "'a"
  assume "x \<in> A"
  with electing f_prof f_vec one_alt
  show "x \<in> elect m A p vs"
    unfolding electing_def
    using One_nat_def Suc_leI card_seteq
          card_gt_0_iff elect_in_alts
          infinite_super
    by metis
qed

theorem electing_imp_non_blocking:
  assumes electing: "electing m"
  shows "non_blocking m"
  unfolding non_blocking_def
proof (safe)
  from electing
  show "electoral_module m"
    using electing_def
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs :: "'a Pair_Vectors" and
    x :: "'a"
  assume
    finA: "finite A" and
    profA: "profile A p" and
    vecA: "vector_pair A vs" and
    rejA: "reject m A p vs = A" and
    xInA: "x \<in> A"
  from electing have
    "electoral_module m \<and>
      (\<forall>A rs vs. A = {} \<or> infinite A \<or>
        \<not> profile A rs \<or> \<not> finite_pair_vectors A vs \<or> elect m A rs vs \<noteq> {})"
    unfolding electing_def
    by metis
  hence f1: "A = {}"
    using Diff_cancel Un_empty
          elec_and_def_not_rej
          finA profA rejA vecA
    by (metis (no_types))
  from  xInA
  have "x \<in> A"
    by metis
  with f1 show "x \<in> {}"
    by metis
qed

subsection \<open>Properties\<close>

(*
   An electoral module is non-electing iff
   it never elects an alternative.
*)
definition non_electing :: "'a Electoral_Module \<Rightarrow> bool" where
  "non_electing m \<equiv>
    electoral_module m \<and>
    (\<forall>A p vs. finite_profile A p \<and> finite_pair_vectors A vs \<longrightarrow> elect m A p vs = {})"

lemma single_elim_decr_def_card:
  assumes
    rejecting: "rejects 1 m" and
    not_empty: "A \<noteq> {}" and
    non_electing: "non_electing m" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows "card (defer m A p vs) = card A - 1"
proof -
  have "rejects 1 m"
    using One_nat_def rejecting
    by metis
  moreover have
    "electoral_module m \<and>
      (\<forall> A rs vs. infinite A \<or> \<not> profile A rs \<or>
      \<not> finite_pair_vectors A vs \<or> elect m A rs vs = {})"
    using non_electing
    unfolding non_electing_def
    by metis
  moreover from this have
    "reject m A p vs \<subseteq> A"
    using f_prof f_vec reject_in_alts
    by metis
  ultimately show ?thesis
    using f_prof f_vec not_empty
    by (simp add: Suc_leI card_Diff_subset card_gt_0_iff
                  defer_not_elec_or_rej finite_subset
                  rejects_def)
qed

lemma single_elim_decr_def_card2:
  assumes
    eliminating: "eliminates 1 m" and
    not_empty: "card A > 1" and
    non_electing: "non_electing m" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows "card (defer m A p vs) = card A - 1"
proof -
  have
    "\<forall>f. (non_electing f \<or>
            (\<exists>A rs vs. ({}::'a set) \<noteq> elect f A rs vs \<and> profile A rs \<and> vector_pair A vs \<and> finite A) \<or>
            \<not> electoral_module f) \<and>
          ((\<forall>A rs vs. {} = elect f A rs vs \<or> \<not> profile A rs \<or> \<not> vector_pair A vs \<or> infinite A) \<and>
            electoral_module f \<or> \<not> non_electing f)"
    using non_electing_def
    by metis
  moreover from this have
    "electoral_module m \<and>
      (\<forall>A rs vs. infinite A \<or> \<not> profile A rs \<or> \<not> vector_pair A vs \<or> elect m A rs vs = {})"
    using non_electing
    by (metis (no_types))
  moreover from this have
    "reject m A p vs \<subseteq> A"
    using f_prof f_vec reject_in_alts
    by metis
  moreover have "1 < card A"
    using not_empty
    by presburger
  moreover have "eliminates 1 m"
    using One_nat_def eliminating
    by presburger
  moreover have "eliminates 1 m"
    using eliminating
    by force
  ultimately show ?thesis
    using f_prof f_vec
    by (simp add: card_Diff_subset defer_not_elec_or_rej
                  eliminates_def finite_subset)
qed

(*
   An electoral module is defer-deciding iff
   this module chooses exactly 1 alternative to defer and
   rejects any other alternative.
   Note that `rejects n-1 m` can be omitted due to the
   well-formedness property.
*)
definition defer_deciding :: "'a Electoral_Module \<Rightarrow> bool" where
  "defer_deciding m \<equiv>
    electoral_module m \<and> non_electing m \<and> defers 1 m"

(*
   An electoral module decrements iff
   this module rejects at least one alternative whenever possible (|A|>1).
*)
definition decrementing :: "'a Electoral_Module \<Rightarrow> bool" where
  "decrementing m \<equiv>
    electoral_module m \<and> (
      \<forall> A p vs. finite_profile A p \<and> finite_pair_vectors A vs \<longrightarrow>
          (card A > 1 \<longrightarrow> card (reject m A p vs) \<ge> 1))"

definition defer_condorcet_consistency :: "'a Electoral_Module \<Rightarrow> bool" where
  "defer_condorcet_consistency m \<equiv>
    electoral_module m \<and>
    (\<forall> A p w vs. condorcet_winner A p w \<and> finite A \<and> vector_pair A vs \<longrightarrow>
      (m A p vs =
        ({},
        A - (defer m A p vs),
        {d \<in> A. condorcet_winner A p d})))"

definition condorcet_compatibility :: "'a Electoral_Module \<Rightarrow> bool" where
  "condorcet_compatibility m \<equiv>
    electoral_module m \<and>
    (\<forall> A p w vs. condorcet_winner A p w \<and> finite A \<longrightarrow>
      (w \<notin> reject m A p vs \<and>
        (\<forall>l. \<not>condorcet_winner A p l \<longrightarrow> l \<notin> elect m A p vs) \<and>
          (w \<in> elect m A p vs \<longrightarrow>
            (\<forall>l. \<not>condorcet_winner A p l \<longrightarrow> l \<in> reject m A p vs))))"

(*
   An electoral module is defer-monotone iff,
   when a deferred alternative is lifted, this alternative remains deferred.
*)
definition defer_monotonicity :: "'a Electoral_Module \<Rightarrow> bool" where
  "defer_monotonicity m \<equiv>
    electoral_module m \<and>
      (\<forall>A p q w vs.
          (finite A \<and> w \<in> defer m A p vs \<and> finite_pair_vectors A vs \<and> lifted A p q w)
          \<longrightarrow> w \<in> defer m A q vs)"

(*
   An electoral module is defer-lift-invariant iff
   lifting a deferred alternative does not affect the outcome.
*)
definition defer_lift_invariance :: "'a Electoral_Module \<Rightarrow> bool" where
  "defer_lift_invariance m \<equiv>
    electoral_module m \<and>
      (\<forall>A p q a vs.
          (a \<in> (defer m A p vs) \<and> finite_pair_vectors A vs \<and> lifted A p q a)
              \<longrightarrow> m A p vs = m A q vs)"

(*
   Two electoral modules are disjoint-compatible if they only make decisions
   over disjoint sets of alternatives. Electoral modules reject alternatives
   for which they make no decision.
*)
definition disjoint_compatibility :: "'a Electoral_Module \<Rightarrow>
                                         'a Electoral_Module \<Rightarrow> bool" where
  "disjoint_compatibility m n \<equiv>
    electoral_module m \<and> electoral_module n \<and>
        (\<forall>S. finite S  \<longrightarrow>
          (\<exists>A \<subseteq> S.
            (\<forall>a \<in> A. indep_of_alt m S a \<and>
              (\<forall>p vs. finite_profile S p \<and> vector_pair S vs \<longrightarrow> a \<in> reject m S p vs)) \<and>
            (\<forall>a \<in> S-A. indep_of_alt n S a \<and>
              (\<forall>p vs. finite_profile S p  \<and> vector_pair S vs\<longrightarrow> a \<in> reject n S p vs))))"

(*
   Lifting an elected alternative a from an invariant-monotone
   electoral module either does not change the elect set, or
   makes a the only elected alternative.
*)
definition invariant_monotonicity :: "'a Electoral_Module \<Rightarrow> bool" where
  "invariant_monotonicity m \<equiv>
    electoral_module m \<and>
        (\<forall>A p q a vs. (a \<in> elect m A p vs \<and> lifted A p q a) \<longrightarrow>
          (elect m A q vs = elect m A p vs \<or> elect m A q vs = {a}))"

(*
   Lifting a deferred alternative a from a defer-invariant-monotone
   electoral module either does not change the defer set, or
   makes a the only deferred alternative.
*)
definition defer_invariant_monotonicity :: "'a Electoral_Module \<Rightarrow> bool" where
  "defer_invariant_monotonicity m \<equiv>
    electoral_module m \<and> non_electing m \<and>
        (\<forall>A p q a vs. (a \<in> defer m A p vs \<and> lifted A p q a) \<longrightarrow>
          (defer m A q vs = defer m A p vs \<or> defer m A q vs = {a}))"

subsection \<open>Inference Rules\<close>
(*
lemma ccomp_and_dd_imp_def_only_winner:
  assumes ccomp: "condorcet_compatibility m" and
          dd: "defer_deciding m" and
          winner: "condorcet_winner A p w" and
          f_vec: "finite_pair_vectors A p vs"
  shows "defer m A p vs = {w}"
proof (rule ccontr)
  assume not_w: "defer m A p vs \<noteq> {w}"
  from dd have def_1:
    "defers 1 m"
    using defer_deciding_def
    by metis
  hence c_win:
    "finite_profile A p \<and>  w \<in> A \<and> (\<forall>x \<in> A - {w} . wins w p x)"
    using winner
    by simp
  hence "card (defer m A p vs) = 1"
    using One_nat_def Suc_leI card_gt_0_iff
          def_1 defers_def equals0D
    by metis
  hence 0: "\<exists>x \<in> A . defer m A p vs = {x}"
    using card_1_singletonE dd defer_deciding_def
          defer_in_alts insert_subset c_win f_vec
    by metis
  with not_w have "\<exists>l \<in> A . l \<noteq> w \<and> defer m A p vs = {l}"
    by metis
  hence not_in_defer: "w \<notin> defer m A p vs"
    by auto
  have "non_electing m"
    using dd defer_deciding_def
    by metis
  hence not_in_elect: "w \<notin> elect m A p vs"
    using c_win equals0D non_electing_def f_vec
    by metis
  from not_in_defer not_in_elect f_vec have one_side:
    "w \<in> reject m A p vs"
    using ccomp condorcet_compatibility_def c_win
          electoral_mod_defer_elem
    by metis
  from ccomp f_vec have other_side: "w \<notin> reject m A p vs"
    using condorcet_compatibility_def c_win winner
    by (metis (no_types, hide_lams))
  thus False
    by (simp add: one_side)
qed

theorem ccomp_and_dd_imp_dcc[simp]:
  assumes ccomp: "condorcet_compatibility m" and
          dd: "defer_deciding m"
  shows "defer_condorcet_consistency m"
proof (unfold defer_condorcet_consistency_def, auto)
  show "electoral_module m"
    using dd defer_deciding_def
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs :: "'a Pair_Vectors" and
    w :: "'a"
  assume
    prof_A: "profile A p" and
    w_in_A: "w \<in> A" and
    finiteness: "finite A" and
    vec_A: "finite_pair_vectors A p vs" and
    assm: "\<forall>x\<in>A - {w}.
          card {i. i < length p \<and> (w, x) \<in> (p!i)} <
            card {i. i < length p \<and> (x, w) \<in> (p!i)}"
  have winner: "condorcet_winner A p w"
    using assm finiteness prof_A w_in_A
    by simp
  hence
    "m A p vs =
      ({},
        A - defer m A p vs,
        {d \<in> A. condorcet_winner A p d})"
  proof -
    (*Elect*)
    from dd have 0:
      "elect m A p vs = {}"
      using defer_deciding_def non_electing_def
            winner vec_A
      by fastforce
    (*Defers*)
    from dd ccomp have 1: "defer m A p vs = {w}"
      using ccomp_and_dd_imp_def_only_winner winner vec_A
      by metis
    (*Reject*)
    from 0 1 have 2: "reject m A p vs = A - defer m A p vs"
      using Diff_empty dd defer_deciding_def
            reject_not_elec_or_def winner vec_A
      by fastforce
    from 0 1 2 have 3: "m A p vs = ({}, A - defer m A p vs, {w})"
      using combine_ele_rej_def
      by metis
    have "{w} = {d \<in> A. condorcet_winner A p d}"
      using cond_winner_unique3 winner
      by metis
    thus ?thesis
      using "3"
      by auto
  qed
  hence
    "m A p vs =
      ({},
        A - defer m A p vs,
        {d \<in> A. \<forall>x\<in>A - {d}. wins d p x})"
    using finiteness prof_A winner Collect_cong
    by auto
  hence
    "m A p vs =
        ({},
          A - defer m A p vs,
          {d \<in> A. \<forall>x\<in>A - {d}.
            prefer_count p x d < prefer_count p d x})"
    by simp
  hence
    "m A p vs =
        ({},
          A - defer m A p vs,
          {d \<in> A. \<forall>x\<in>A - {d}.
            card {i. i < length p \<and> (let r = (p!i) in (d \<preceq>\<^sub>r x))} <
                card {i. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r d))}})"
    by simp
  thus
    "m A p vs =
        ({},
          A - defer m A p vs,
          {d \<in> A. \<forall>x\<in>A - {d}.
            card {i. i < length p \<and> (d, x) \<in> (p!i)} <
              card {i. i < length p \<and> (x, d) \<in> (p!i)}})"
    by simp
qed
*)
(*If m and n are disjoint compatible, so are n and m.*)
(*
theorem disj_compat_comm[simp]:
  assumes compatible: "disjoint_compatibility m n"
  shows "disjoint_compatibility n m"
proof -
  have
    "\<forall>S vs. finite S \<longrightarrow>
        (\<exists>A \<subseteq> S.
          (\<forall>a \<in> A. indep_of_alt n S vs a \<and>
            (\<forall>p vs. finite_profile S p \<and> finite_pair_vectors S p vs \<longrightarrow> a \<in> reject n S p vs)) \<and>
          (\<forall>a \<in> S-A. indep_of_alt m S vs a \<and>
            (\<forall>p vs. finite_profile S p \<and> finite_pair_vectors S p vs \<longrightarrow> a \<in> reject m S p vs)))"
  proof
    fix
      S :: "'a set" and
      vs :: "'a Pair_Vectors"
    obtain A where old_A:
      "finite S \<longrightarrow>
          (A \<subseteq> S \<and>
            (\<forall>a \<in> A. indep_of_alt m S vs a \<and>
              (\<forall>p vs. finite_profile S p \<and> finite_pair_vectors S p vs \<longrightarrow> a \<in> reject m S p vs)) \<and>
            (\<forall>a \<in> S-A. indep_of_alt n S vs a \<and>
              (\<forall>p vs. finite_profile S p \<and> finite_pair_vectors S p vs \<longrightarrow> a \<in> reject n S p vs)))"
      using compatible disjoint_compatibility_def
      by fastforce
    hence
      "finite S \<longrightarrow>
          (\<exists>A \<subseteq> S.
            (\<forall>a \<in> S-A. indep_of_alt n S vs a \<and>
              (\<forall>p vs. finite_profile S p \<and> finite_pair_vectors S p vs \<longrightarrow> a \<in> reject n S p vs)) \<and>
            (\<forall>a \<in> A. indep_of_alt m S vs a \<and>
              (\<forall>p vs. finite_profile S p \<and> finite_pair_vectors S p vs \<longrightarrow> a \<in> reject m S p vs)))"
      by auto
    hence
      "finite S \<longrightarrow>
          (\<exists>A \<subseteq> S.
            (\<forall>a \<in> S-A. indep_of_alt n S vs a \<and>
              (\<forall>p vs. finite_profile S p \<and> finite_pair_vectors S p vs \<longrightarrow> a \<in> reject n S p vs)) \<and>
            (\<forall>a \<in> S-(S-A). indep_of_alt m S vs a \<and>
              (\<forall>p vs. finite_profile S p \<and> finite_pair_vectors S p vs \<longrightarrow> a \<in> reject m S p vs)))"
      using double_diff order_refl
      by metis
    thus
      "finite S \<longrightarrow>
          (\<exists>A \<subseteq> S.
            (\<forall>a \<in> A. indep_of_alt n S vs a \<and>
              (\<forall>p vs. finite_profile S p \<and> finite_pair_vectors S p vs \<longrightarrow> a \<in> reject n S p vs)) \<and>
            (\<forall>a \<in> S-A. indep_of_alt m S vs a \<and>
              (\<forall>p vs. finite_profile S p \<and> finite_pair_vectors S p vs \<longrightarrow> a \<in> reject m S p vs)))"
      by fastforce
  qed
  moreover have "electoral_module m \<and> electoral_module n"
    using compatible disjoint_compatibility_def
    by auto
  ultimately show ?thesis
    by (simp add: disjoint_compatibility_def)
qed
*)
(*
   Every electoral module which is defer-lift-invariant is
   also defer-monotone.
*)
theorem dl_inv_imp_def_mono[simp]:
  assumes "defer_lift_invariance m"
  shows "defer_monotonicity m"
  using assms defer_monotonicity_def defer_lift_invariance_def
  by fastforce

subsection \<open>Social Choice Properties\<close>

subsubsection \<open>Condorcet Consistency\<close>

definition condorcet_consistency :: "'a Electoral_Module \<Rightarrow> bool" where
  "condorcet_consistency m \<equiv>
    electoral_module m \<and>
    (\<forall> A p w vs. condorcet_winner A p w \<and> vector_pair A vs \<longrightarrow>
      (m A p vs =
        ({e \<in> A. condorcet_winner A p e},
          A - (elect m A p vs),
          {})))"

lemma condorcet_consistency2:
  "condorcet_consistency m \<longleftrightarrow>
      electoral_module m \<and>
        (\<forall> A p w vs. condorcet_winner A p w \<and> vector_pair A vs \<longrightarrow>
            (m A p vs =
              ({w}, A - (elect m A p vs), {})))"
proof (safe)
  assume "condorcet_consistency m"
  thus "electoral_module m"
    using condorcet_consistency_def
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs :: "'a Pair_Vectors" and
    w :: "'a"
  assume
    cc: "condorcet_consistency m" and
    cwin: "condorcet_winner A p w" and
    vec_A: "vector_pair A vs"
  show
    "m A p vs = ({w}, A - elect m A p vs, {})"
    using cond_winner_unique3 condorcet_consistency_def cc cwin vec_A
    by (smt (verit))
next
  assume
    e_mod: "electoral_module m" and
    cwin:
    "\<forall>A p w vs. condorcet_winner A p w \<and> vector_pair A vs \<longrightarrow>
      m A p vs = ({w}, A - elect m A p vs, {})"
  have
    "\<forall>f. condorcet_consistency f =
      (electoral_module f \<and>
        (\<forall>A rs a vs. \<not> condorcet_winner A rs (a::'a) \<or> \<not> vector_pair A vs \<or>
          f A rs vs = ({a \<in> A. condorcet_winner A rs a},
                    A - elect f A rs vs, {})))"
    unfolding condorcet_consistency_def
    by blast
  moreover have
    "\<forall>A rs a. \<not> condorcet_winner A rs (a::'a) \<or>
        {a \<in> A. condorcet_winner A rs a} = {a}"
    using cond_winner_unique3
    by (metis (full_types))
  ultimately show
    "condorcet_consistency m"
    unfolding condorcet_consistency_def
    using e_mod cwin
    by (metis (no_types, lifting))
qed

subsubsection \<open>(Weak) Monotonicity\<close>

(*
   An electoral module is monotone iff
   when an elected alternative is lifted, this alternative remains elected.
*)
definition monotonicity :: "'a Electoral_Module \<Rightarrow> bool" where
  "monotonicity m \<equiv>
    electoral_module m \<and>
      (\<forall>A p q w vs.
          (finite A \<and> finite_pair_vectors A vs \<and> w \<in> elect m A p vs \<and> lifted A p q w)
            \<longrightarrow> w \<in> elect m A q vs)"

subsubsection \<open>Homogeneity\<close>

fun times :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "times n l = concat (replicate n l)"

definition homogeneity :: "'a Electoral_Module \<Rightarrow> bool" where
"homogeneity m \<equiv>
  electoral_module m \<and>
    (\<forall> A p n vs.
      (finite_profile A p \<and> finite_pair_vectors A vs \<and> n > 0 \<longrightarrow>
          (m A p vs = m A (times n p) (times n vs))))"

subsubsection \<open>Reinforcement\<close>

definition reinforcement:: "'a Electoral_Module \<Rightarrow> bool" where
"reinforcement m \<equiv> electoral_module m \<and>
(\<forall> A p1 p2 vs1 vs2. (finite_profile A p1 \<and> finite_pair_vectors A vs1 \<and> finite_profile A p2
\<and> finite_pair_vectors A vs2 \<longrightarrow>
(elect m A p1 vs1) \<inter> (elect m A p2 vs2) \<noteq> {} \<longrightarrow>
((elect m A p1 vs1) \<inter> (elect m A p2 vs2) = elect m A (p1 @ p2) (vs1@vs2))))"

definition reinforcement_defer:: "'a Electoral_Module \<Rightarrow> bool" where
"reinforcement_defer m \<equiv> electoral_module m \<and>
(\<forall> A p1 p2 vs1 vs2. (finite_profile A p1 \<and> finite_pair_vectors A vs1 \<and> finite_profile A p2
\<and> finite_pair_vectors A vs2 \<longrightarrow>
(defer m A p1 vs1) \<inter> (defer m A p2 vs2) \<noteq> {} \<longrightarrow>
((defer m A p1 vs1) \<inter> (defer m A p2 vs2) = defer m A (p1 @ p2) (vs1@vs2))))"

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Subdigraph\<close>
theory CZH_DG_Subdigraph
  imports
    CZH_DG_Digraph
    CZH_DG_DGHM
begin

subsection\<open>Background\<close>

text\<open>
In this body of work, a subdigraph is a natural generalization of the concept
of a subcategory, as defined in Chapter I-3 in \<^cite>\<open>"mac_lane_categories_2010"\<close>,
to digraphs.
It should be noted that a similar concept also exists in the conventional
graph theory, but further details are considered to be outside of the scope of
this work.
\<close>

named_theorems dg_sub_cs_intros
named_theorems dg_sub_bw_cs_intros
named_theorems dg_sub_fw_cs_intros
named_theorems dg_sub_bw_cs_simps

subsection\<open>Simple subdigraph\<close>

subsubsection\<open>Definition and elementary properties\<close>

locale subdigraph = sdg: digraph \<alpha> \<BB> + dg: digraph \<alpha> \<CC> for \<alpha> \<BB> \<CC> +
  assumes subdg_Obj_vsubset[dg_sub_fw_cs_intros]:
    "a \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr> \<Longrightarrow> a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and subdg_is_arr_vsubset[dg_sub_fw_cs_intros]:
      "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b \<Longrightarrow> f : a \<mapsto>\<^bsub>\<CC>\<^esub> b"

abbreviation is_subdigraph ("(_/ \<subseteq>\<^sub>D\<^sub>G\<index> _)" [51, 51] 50)
  where "\<BB> \<subseteq>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC> \<equiv> subdigraph \<alpha> \<BB> \<CC>"

lemmas [dg_sub_fw_cs_intros] =
  subdigraph.subdg_Obj_vsubset
  subdigraph.subdg_is_arr_vsubset

text\<open>Rules.\<close>

lemma (in subdigraph) subdigraph_axioms'[dg_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<BB>' = \<BB>"
  shows "\<BB>' \<subseteq>\<^sub>D\<^sub>G\<^bsub>\<alpha>'\<^esub> \<CC>"
  unfolding assms by (rule subdigraph_axioms)

lemma (in subdigraph) subdigraph_axioms''[dg_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<CC>' = \<CC>"
  shows "\<BB> \<subseteq>\<^sub>D\<^sub>G\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule subdigraph_axioms)

mk_ide rf subdigraph_def[unfolded subdigraph_axioms_def]
  |intro subdigraphI|
  |dest subdigraphD[dest]|
  |elim subdigraphE[elim!]|

lemmas [dg_sub_cs_intros] = subdigraphD(1,2)

text\<open>The opposite subdigraph.\<close>

lemma (in subdigraph) subdg_subdigraph_op_dg_op_dg: "op_dg \<BB> \<subseteq>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> op_dg \<CC>"
proof(rule subdigraphI)
  show "a \<in>\<^sub>\<circ> op_dg \<BB>\<lparr>Obj\<rparr> \<Longrightarrow> a \<in>\<^sub>\<circ> op_dg \<CC>\<lparr>Obj\<rparr>" for a
    by (auto simp: dg_op_simps subdg_Obj_vsubset)
  show "f : a \<mapsto>\<^bsub>op_dg \<BB>\<^esub> b \<Longrightarrow> f : a \<mapsto>\<^bsub>op_dg \<CC>\<^esub> b" for f a b
    by (auto simp: dg_op_simps subdg_is_arr_vsubset)
qed (auto simp: dg_op_simps intro: dg_op_intros)

lemmas subdg_subdigraph_op_dg_op_dg[dg_op_intros] =
  subdigraph.subdg_subdigraph_op_dg_op_dg

text\<open>Further rules.\<close>

lemma (in subdigraph) subdg_objD:
  assumes "a \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
  shows "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
  using assms by (auto intro: subdg_Obj_vsubset)

lemmas [dg_sub_fw_cs_intros] = subdigraph.subdg_objD

lemma (in subdigraph) subdg_arrD[dg_sub_fw_cs_intros]:
  assumes "f \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
  shows "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
proof-
  from assms obtain a b where "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b" by auto
  then show "f \<in>\<^sub>\<circ> \<CC>\<lparr>Arr\<rparr>"
    by (cs_concl cs_shallow cs_intro: subdg_is_arr_vsubset dg_cs_intros)
qed

lemmas [dg_sub_fw_cs_intros] = subdigraph.subdg_arrD

lemma (in subdigraph) subdg_dom_simp:
  assumes "f \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
  shows "\<BB>\<lparr>Dom\<rparr>\<lparr>f\<rparr> = \<CC>\<lparr>Dom\<rparr>\<lparr>f\<rparr>"
proof-
  from assms obtain a b where "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b" by auto
  then show "\<BB>\<lparr>Dom\<rparr>\<lparr>f\<rparr> = \<CC>\<lparr>Dom\<rparr>\<lparr>f\<rparr>"
    by (force dest: subdg_is_arr_vsubset simp: dg_cs_simps)
qed

lemmas [dg_sub_bw_cs_simps] = subdigraph.subdg_dom_simp

lemma (in subdigraph) subdg_cod_simp:
  assumes "f \<in>\<^sub>\<circ> \<BB>\<lparr>Arr\<rparr>"
  shows "\<BB>\<lparr>Cod\<rparr>\<lparr>f\<rparr> = \<CC>\<lparr>Cod\<rparr>\<lparr>f\<rparr>"
proof-
  from assms obtain a b where "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b" by auto
  then show "\<BB>\<lparr>Cod\<rparr>\<lparr>f\<rparr> = \<CC>\<lparr>Cod\<rparr>\<lparr>f\<rparr>"
    by (force dest: subdg_is_arr_vsubset simp: dg_cs_simps)
qed

lemmas [dg_sub_bw_cs_simps] = subdigraph.subdg_cod_simp

lemma (in subdigraph) subdg_is_arrD:
  assumes "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b"
  shows "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b"
  using assms subdg_is_arr_vsubset by simp

lemmas [dg_sub_fw_cs_intros] = subdigraph.subdg_is_arrD

subsubsection\<open>The subdigraph relation is a partial order\<close>

lemma subdg_refl:
  assumes "digraph \<alpha> \<AA>"
  shows "\<AA> \<subseteq>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<AA>"
proof-
  interpret digraph \<alpha> \<AA> by (rule assms)
  show ?thesis by unfold_locales simp
qed

lemma subdg_trans[trans]:
  assumes "\<AA> \<subseteq>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>" and "\<BB> \<subseteq>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<AA> \<subseteq>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<CC>"
proof-
  interpret \<AA>\<BB>: subdigraph \<alpha> \<AA> \<BB> by (rule assms(1))
  interpret \<BB>\<CC>: subdigraph \<alpha> \<BB> \<CC> by (rule assms(2))
  show ?thesis
    by  unfold_locales
      (
        insert \<AA>\<BB>.subdigraph_axioms,
        auto simp:
          \<BB>\<CC>.subdg_Obj_vsubset
          \<AA>\<BB>.subdg_Obj_vsubset
          subdigraph.subdg_is_arr_vsubset
          \<BB>\<CC>.subdg_is_arr_vsubset
      )
qed

lemma subdg_antisym:
  assumes "\<AA> \<subseteq>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<BB>" and "\<BB> \<subseteq>\<^sub>D\<^sub>G\<^bsub>\<alpha>\<^esub> \<AA>"
  shows "\<AA> = \<BB>"
proof-
  interpret \<AA>\<BB>: subdigraph \<alpha> \<AA> \<BB> by (rule assms(1))
  interpret \<BB>\<AA>: subdigraph \<alpha> \<BB> \<AA> by (rule assms(2))
  show ?thesis
  proof(rule dg_eqI)
    from assms show Arr: "\<AA>\<lparr>Arr\<rparr> = \<BB>\<lparr>Arr\<rparr>"
      by (intro vsubset_antisym vsubsetI)
        (auto simp: dg_sub_bw_cs_simps intro: dg_sub_fw_cs_intros)
    from assms show "\<AA>\<lparr>Obj\<rparr> = \<BB>\<lparr>Obj\<rparr>"
      by (intro vsubset_antisym vsubsetI)
        (auto simp: dg_sub_bw_cs_simps intro: dg_sub_fw_cs_intros)
    show "\<AA>\<lparr>Dom\<rparr> = \<BB>\<lparr>Dom\<rparr>"
      by (rule vsv_eqI) (auto simp: \<AA>\<BB>.subdg_dom_simp Arr dg_cs_simps)
    show "\<AA>\<lparr>Cod\<rparr> = \<BB>\<lparr>Cod\<rparr>"
      by (rule vsv_eqI) (auto simp: \<AA>\<BB>.subdg_cod_simp Arr dg_cs_simps)
  qed (cs_concl cs_shallow cs_intro: dg_cs_intros)+
qed

subsection\<open>Inclusion digraph homomorphism\<close>

subsubsection\<open>Definition and elementary properties\<close>

text\<open>See Chapter I-3 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

definition dghm_inc :: "V \<Rightarrow> V \<Rightarrow> V"
  where "dghm_inc \<BB> \<CC> = [vid_on (\<BB>\<lparr>Obj\<rparr>), vid_on (\<BB>\<lparr>Arr\<rparr>), \<BB>, \<CC>]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma dghm_inc_components:
  shows "dghm_inc \<BB> \<CC>\<lparr>ObjMap\<rparr> = vid_on (\<BB>\<lparr>Obj\<rparr>)"
    and "dghm_inc \<BB> \<CC>\<lparr>ArrMap\<rparr> = vid_on (\<BB>\<lparr>Arr\<rparr>)"
    and [dg_cs_simps]: "dghm_inc \<BB> \<CC>\<lparr>HomDom\<rparr> = \<BB>"
    and [dg_cs_simps]: "dghm_inc \<BB> \<CC>\<lparr>HomCod\<rparr> = \<CC>"
  unfolding dghm_inc_def dghm_field_simps by (simp_all add: nat_omega_simps)

subsubsection\<open>Object map\<close>

mk_VLambda dghm_inc_components(1)[folded VLambda_vid_on]
  |vsv dghm_inc_ObjMap_vsv[dg_cs_intros]|
  |vdomain dghm_inc_ObjMap_vdomain[dg_cs_simps]|
  |app dghm_inc_ObjMap_app[dg_cs_simps]|

subsubsection\<open>Arrow map\<close>

mk_VLambda dghm_inc_components(2)[folded VLambda_vid_on]
  |vsv dghm_inc_ArrMap_vsv[dg_cs_intros]|
  |vdomain dghm_inc_ArrMap_vdomain[dg_cs_simps]|
  |app dghm_inc_ArrMap_app[dg_cs_simps]|

subsubsection\<open>
Canonical inclusion digraph homomorphism associated with a subdigraph
\<close>

sublocale subdigraph \<subseteq> inc: is_ft_dghm \<alpha> \<BB> \<CC> \<open>dghm_inc \<BB> \<CC>\<close>
proof(intro is_ft_dghmI is_dghmI)
  show "vfsequence (dghm_inc \<BB> \<CC>)" unfolding dghm_inc_def by auto
  show "vcard (dghm_inc \<BB> \<CC>) = 4\<^sub>\<nat>"
    unfolding dghm_inc_def by (simp add: nat_omega_simps)
  show "\<R>\<^sub>\<circ> (dghm_inc \<BB> \<CC>\<lparr>ObjMap\<rparr>) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    unfolding dghm_inc_components by (auto dest: subdg_objD)
  show "dghm_inc \<BB> \<CC>\<lparr>ArrMap\<rparr>\<lparr>f\<rparr> :
    dghm_inc \<BB> \<CC>\<lparr>ObjMap\<rparr>\<lparr>a\<rparr> \<mapsto>\<^bsub>\<CC>\<^esub> dghm_inc \<BB> \<CC>\<lparr>ObjMap\<rparr>\<lparr>b\<rparr>"
    if "f : a \<mapsto>\<^bsub>\<BB>\<^esub> b" for a b f
    using that
    by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_sub_fw_cs_intros)
  show "v11 (dghm_inc \<BB> \<CC>\<lparr>ArrMap\<rparr> \<restriction>\<^sup>l\<^sub>\<circ> Hom \<BB> a b)"
    if "a \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" and "b \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" for a b
    using that unfolding dghm_inc_components by simp
qed (cs_concl cs_shallow cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+

lemmas (in subdigraph) subdg_dghm_inc_is_ft_dghm = inc.is_ft_dghm_axioms

subsubsection\<open>The inclusion digraph homomorphism for the opposite digraphs\<close>

lemma (in subdigraph) subdg_dghm_inc_op_dg_is_dghm[dg_sub_cs_intros]:
  "dghm_inc (op_dg \<BB>) (op_dg \<CC>) : op_dg \<BB> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>f\<^sub>a\<^sub>i\<^sub>t\<^sub>h\<^sub>f\<^sub>u\<^sub>l\<^bsub>\<alpha>\<^esub> op_dg \<CC>"
  by (intro subdigraph.subdg_dghm_inc_is_ft_dghm subdg_subdigraph_op_dg_op_dg)

lemmas [dg_sub_cs_intros] = subdigraph.subdg_dghm_inc_op_dg_is_dghm

lemma (in subdigraph) subdg_op_dg_dghm_inc[dg_op_simps]:
  "op_dghm (dghm_inc \<BB> \<CC>) = dghm_inc (op_dg \<BB>) (op_dg \<CC>)"
  by (rule dghm_eqI, unfold dg_op_simps dghm_inc_components id_def)
    (
      auto
        simp: subdg_dghm_inc_op_dg_is_dghm is_ft_dghmD
        intro: dg_op_intros dg_cs_intros
    )

lemmas [dg_op_simps] = subdigraph.subdg_op_dg_dghm_inc

subsection\<open>Full subdigraph\<close>

text\<open>See Chapter I-3 in \<^cite>\<open>"mac_lane_categories_2010"\<close>.\<close>

locale fl_subdigraph = subdigraph +
  assumes fl_subdg_is_fl_dghm_inc: "dghm_inc \<BB> \<CC> : \<BB> \<mapsto>\<mapsto>\<^sub>D\<^sub>G\<^sub>.\<^sub>f\<^sub>u\<^sub>l\<^sub>l\<^bsub>\<alpha>\<^esub> \<CC>"

abbreviation is_fl_subdigraph ("(_/ \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>f\<^sub>u\<^sub>l\<^sub>l\<index> _)" [51, 51] 50)
  where "\<BB> \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>f\<^sub>u\<^sub>l\<^sub>l\<^bsub>\<alpha>\<^esub> \<CC> \<equiv> fl_subdigraph \<alpha> \<BB> \<CC>"

sublocale fl_subdigraph \<subseteq> inc: is_fl_dghm \<alpha> \<BB> \<CC> \<open>dghm_inc \<BB> \<CC>\<close>
  by (rule fl_subdg_is_fl_dghm_inc)

text\<open>Rules.\<close>

lemma (in fl_subdigraph) fl_subdigraph_axioms'[dg_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<BB>' = \<BB>"
  shows "\<BB>' \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>f\<^sub>u\<^sub>l\<^sub>l\<^bsub>\<alpha>'\<^esub> \<CC>"
  unfolding assms by (rule fl_subdigraph_axioms)

lemma (in fl_subdigraph) fl_subdigraph_axioms''[dg_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<CC>' = \<CC>"
  shows "\<BB> \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>f\<^sub>u\<^sub>l\<^sub>l\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule fl_subdigraph_axioms)

mk_ide rf fl_subdigraph_def[unfolded fl_subdigraph_axioms_def]
  |intro fl_subdigraphI|
  |dest fl_subdigraphD[dest]|
  |elim fl_subdigraphE[elim!]|

lemmas [dg_sub_cs_intros] = fl_subdigraphD(1)

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

lemma (in fl_subdigraph) fl_subdg_Hom_eq:
  assumes "A \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>" and "B \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"
  shows "Hom \<BB> A B = Hom \<CC> A B"
proof-
  from assms have Arr_AB: "\<BB>\<lparr>Arr\<rparr> \<inter>\<^sub>\<circ> Hom \<BB> A B = Hom \<BB> A B"
    by
      (
        intro vsubset_antisym vsubsetI,
        unfold vintersection_iff in_Hom_iff;
        (elim conjE)?;
        (intro conjI)?
      )
      (auto intro: dg_cs_intros)
  from assms have A: "vid_on (\<BB>\<lparr>Obj\<rparr>)\<lparr>A\<rparr> = A" and B: "vid_on (\<BB>\<lparr>Obj\<rparr>)\<lparr>B\<rparr> = B"
    by simp_all
  from inc.fl_dghm_surj_on_Hom[OF assms, unfolded dghm_inc_components] show
    "Hom \<BB> A B = Hom \<CC> A B"
    by (auto simp: Arr_AB A B)
qed

subsection\<open>Wide subdigraph\<close>

subsubsection\<open>Definition and elementary properties\<close>

text\<open>
See \<^cite>\<open>"noauthor_nlab_nodate"\<close>\footnote{
\url{https://ncatlab.org/nlab/show/wide+subcategory}
}).
\<close>

locale wide_subdigraph = subdigraph +
  assumes wide_subdg_Obj[dg_sub_bw_cs_intros]: "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<Longrightarrow> a \<in>\<^sub>\<circ> \<BB>\<lparr>Obj\<rparr>"

abbreviation is_wide_subdigraph ("(_/ \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<index> _)" [51, 51] 50)
  where "\<BB> \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> \<CC> \<equiv> wide_subdigraph \<alpha> \<BB> \<CC>"

lemmas [dg_sub_bw_cs_intros] = wide_subdigraph.wide_subdg_Obj

text\<open>Rules.\<close>

lemma (in wide_subdigraph) wide_subdigraph_axioms'[dg_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<BB>' = \<BB>"
  shows "\<BB>' \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>'\<^esub> \<CC>"
  unfolding assms by (rule wide_subdigraph_axioms)

lemma (in wide_subdigraph) wide_subdigraph_axioms''[dg_cs_intros]:
  assumes "\<alpha>' = \<alpha>" and "\<CC>' = \<CC>"
  shows "\<BB> \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>'\<^esub> \<CC>'"
  unfolding assms by (rule wide_subdigraph_axioms)

mk_ide rf wide_subdigraph_def[unfolded wide_subdigraph_axioms_def]
  |intro wide_subdigraphI|
  |dest wide_subdigraphD[dest]|
  |elim wide_subdigraphE[elim!]|

lemmas [dg_sub_cs_intros] = wide_subdigraphD(1)

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

lemma (in wide_subdigraph) wide_subdg_obj_eq[dg_sub_bw_cs_simps]:
  "\<BB>\<lparr>Obj\<rparr> = \<CC>\<lparr>Obj\<rparr>"
  using subdg_Obj_vsubset wide_subdg_Obj by auto

lemmas [dg_sub_bw_cs_simps] = wide_subdigraph.wide_subdg_obj_eq

subsubsection\<open>The wide subdigraph relation is a partial order\<close>

lemma wide_subdg_refl:
  assumes "digraph \<alpha> \<AA>"
  shows "\<AA> \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> \<AA>"
proof-
  interpret digraph \<alpha> \<AA> by (rule assms)
  show ?thesis by unfold_locales simp
qed

lemma wide_subdg_trans[trans]:
  assumes "\<AA> \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> \<BB>" and "\<BB> \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> \<CC>"
  shows "\<AA> \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> \<CC>"
proof-
  interpret \<AA>\<BB>: wide_subdigraph \<alpha> \<AA> \<BB> by (rule assms(1))
  interpret \<BB>\<CC>: wide_subdigraph \<alpha> \<BB> \<CC> by (rule assms(2))
  interpret \<AA>\<CC>: subdigraph \<alpha> \<AA> \<CC>
    by (rule subdg_trans) (cs_concl cs_shallow cs_intro: dg_cs_intros)+
  show ?thesis
    by (cs_concl cs_intro: dg_sub_bw_cs_intros dg_cs_intros wide_subdigraphI)
qed

lemma wide_subdg_antisym:
  assumes "\<AA> \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> \<BB>" and "\<BB> \<subseteq>\<^sub>D\<^sub>G\<^sub>.\<^sub>w\<^sub>i\<^sub>d\<^sub>e\<^bsub>\<alpha>\<^esub> \<AA>"
  shows "\<AA> = \<BB>"
proof-
  interpret \<AA>\<BB>: wide_subdigraph \<alpha> \<AA> \<BB> by (rule assms(1))
  interpret \<BB>\<AA>: wide_subdigraph \<alpha> \<BB> \<AA> by (rule assms(2))
  show ?thesis
    by (rule subdg_antisym[OF \<AA>\<BB>.subdigraph_axioms \<BB>\<AA>.subdigraph_axioms])
qed

text\<open>\newpage\<close>

end


section \<open>Array List with Pure Refinement of Elements\<close>
*** must be done on sepref-level, or we need full while-rule setup etc

theory LLVM_DS_Array_List_Pure
imports LLVM_DS_List_Assn LLVM_DS_Array_List
begin
  (* TODO: Move *)

  definition "pure_list_assn A = mk_pure_assn (\<lambda>xs ys. is_pure A \<and> list_all2 (\<flat>\<^sub>pA) xs ys)"

  lemma pure_list_assn_empty_iff:
    "\<upharpoonleft>(pure_list_assn A) [] [] = \<up>(is_pure A)"
    unfolding pure_list_assn_def
    by (auto)

  lemma pure_list_assn_emptyI:
    "PRECOND (SOLVE_ASM (is_pure A)) \<Longrightarrow> \<box> \<turnstile> \<upharpoonleft>\<^sub>p(pure_list_assn A) [] []"
    unfolding vcg_tag_defs pure_list_assn_def
    by (auto simp: sep_algebra_simps)

  lemma pure_list_assn_split2:  "\<upharpoonleft>(pure_list_assn A) (x#xs) (ys)
      = (EXS y ys'. \<upharpoonleft>A x y ** \<upharpoonleft>(pure_list_assn A) xs ys' ** \<up>(ys=y#ys'))"
    apply (cases ys)
    unfolding pure_list_assn_def
    by (auto simp: sep_algebra_simps pred_lift_extract_simps extract_pure_assn fun_eq_iff)

  lemma pure_list_assn_split1: "\<upharpoonleft>(pure_list_assn A) (xs) (y#ys)
      = (EXS x xs'. \<upharpoonleft>A x y ** \<upharpoonleft>(pure_list_assn A) xs' ys ** \<up>(xs=x#xs'))"
    apply (cases xs)
    unfolding pure_list_assn_def
    by (auto simp: sep_algebra_simps pred_lift_extract_simps extract_pure_assn fun_eq_iff)

  lemmas pure_list_assn_simps = pure_list_assn_empty_iff pure_list_assn_split2 pure_list_assn_split1

  lemma pure_list_assn_pure_partD[vcg_prep_ext_rules]: "pure_part (\<upharpoonleft>(pure_list_assn A) xs ys)
    \<Longrightarrow> length xs = length ys \<and> is_pure A \<and> list_all2 (\<flat>\<^sub>pA) xs ys"
    unfolding pure_list_assn_def
    by (auto simp: list_all2_lengthD)

  lemma pure_list_assn_pure[is_pure_rule]: "is_pure (pure_list_assn A)"
    unfolding pure_list_assn_def by auto

  lemma pure_list_assn_extract:
    assumes "i < length xs"
    shows "\<upharpoonleft>(pure_list_assn A) xs ys \<turnstile> \<upharpoonleft>(pure_list_assn A) xs ys ** \<upharpoonleft>A (xs!i) (ys!i)"
    using assms
    unfolding pure_list_assn_def
    apply (auto simp: sep_algebra_simps entails_lift_extract_simps)
    by (simp add: extract_pure_assn list_all2_nthD pure_true_conv)

  lemma pure_list_assn_extract':
    assumes "PRECOND (SOLVE_ASM (\<flat>\<^sub>p(pure_list_assn A) xs ys))"
        and "PRECOND (SOLVE_AUTO_DEFER (i < length xs))"
    shows "\<box> \<turnstile> \<upharpoonleft>A (xs!i) (ys!i)"
    using assms
    by (simp add: vcg_tag_defs list_all2_nthD prepare_pure_assn pure_fri_rule pure_list_assn_def)

  lemma pure_list_assn_upd:
    assumes "i < length xs" "\<flat>\<^sub>pA x y"
    shows "\<upharpoonleft>(pure_list_assn A) xs ys \<turnstile> \<upharpoonleft>(pure_list_assn A) (xs[i:=x]) (ys[i:=y])"
    using assms
    unfolding pure_list_assn_def
    apply (auto simp: sep_algebra_simps entails_lift_extract_simps)
    by (simp add: list_all2_update_cong pure_true_conv)

  lemma pure_list_assn_upd':
    assumes "PRECOND (SOLVE_ASM (\<flat>\<^sub>p(pure_list_assn A) xs ys))"
        and "PRECOND (SOLVE_AUTO_DEFER (i < length xs))"
    shows "\<upharpoonleft>A x y \<turnstile> \<upharpoonleft>\<^sub>p(pure_list_assn A) (xs[i:=x]) (ys[i:=y])"
    using assms unfolding vcg_tag_defs
    by (smt bury_pure_assn dr_assn_pure_asm_prefix_def entails_eq_iff entails_lift_extract_simps(1) entails_pureI prepare_pure_assn pure_list_assn_def pure_list_assn_pure_partD pure_list_assn_upd sel_mk_pure_assn(1) sep_drule(1))

  lemma pure_list_assn_push_back':
    assumes "PRECOND (SOLVE_ASM (\<flat>\<^sub>p(pure_list_assn A) xs ys))"
    shows "\<upharpoonleft>A x y \<turnstile> \<upharpoonleft>\<^sub>p(pure_list_assn A) (xs@[x]) (ys@[y])"
    using assms unfolding vcg_tag_defs pure_list_assn_def
    by (auto simp: sep_algebra_simps entails_lift_extract_simps extract_pure_assn list_all2_appendI)

  lemma pure_list_assn_pop_back':
    assumes "PRECOND (SOLVE_ASM (\<flat>\<^sub>p(pure_list_assn A) xs ys))"
        and "PRECOND (SOLVE_AUTO_DEFER (xs \<noteq> []))"
      shows "\<box> \<turnstile> \<upharpoonleft>\<^sub>p(pure_list_assn A) (butlast xs) (butlast ys)"
    using assms unfolding vcg_tag_defs pure_list_assn_def
    apply (auto)
    by (metis PRECONDI SOLVE_DEFAULT_AUTOI butlast_conv_take fri_pure_rl list_all2_lengthD list_all2_takeI)

  lemma pure_list_assn_last':
    assumes "PRECOND (SOLVE_ASM (\<flat>\<^sub>p(pure_list_assn A) xs ys))"
        and "PRECOND (SOLVE_AUTO_DEFER (xs \<noteq> []))"
      shows "\<box> \<turnstile> \<upharpoonleft>A (last xs) (last ys)"
    using assms unfolding vcg_tag_defs pure_list_assn_def
    apply auto
    by (smt entails_eq_iff extract_pure_assn hd_rev list.rel_sel list_all2_rev pure_true_conv rev_is_Nil_conv)

  subsection \<open>Definition of Assertion\<close>
  definition "arl_pure_assn A \<equiv>
    mk_assn (\<lambda>xs p. EXS ys. \<upharpoonleft>arl_assn ys p ** \<upharpoonleft>(pure_list_assn A) xs ys)"

  lemma arl_pure_assn_init_pure:
    "PRECOND (SOLVE_AUTO (is_pure A)) \<Longrightarrow> PRECOND (SOLVE_AUTO (4 < LENGTH('l))) \<Longrightarrow>
      \<box> \<turnstile> \<upharpoonleft>(arl_pure_assn A) [] (init::(_,'l::len2)array_list)"
    unfolding arl_pure_assn_def vcg_tag_defs
    supply [fri_rules] = arl_assn_init_pure[simplified] pure_list_assn_emptyI
    supply [simp] = pure_list_assn_empty_iff
    apply clarsimp
    apply (rule ENTAILSD)
    by vcg

  subsection \<open>Operations\<close>

  lemma arlp_nth_rule[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>(arl_pure_assn A) al ali ** \<upharpoonleft>snat.assn i ii ** \<up>(i<length al))
    (arl_nth ali ii)
    (\<lambda>x. \<upharpoonleft>A (al!i) x ** \<upharpoonleft>(arl_pure_assn A) al ali)"
    unfolding arl_pure_assn_def
    supply [fri_rules] = pure_list_assn_extract'
    by vcg

  lemma array_of_arlp_nth_rule[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>(arl_pure_assn A) xs a ** \<upharpoonleft>snat.assn i ii ** \<up>(i < length xs))
    (array_nth (array_of_arl a) ii)
    (\<lambda>xi. \<upharpoonleft>(arl_pure_assn A) xs a ** \<upharpoonleft>A (xs!i) xi)"
    unfolding arl_pure_assn_def
    supply [fri_rules] = pure_list_assn_extract'
    by vcg

  lemma arlp_upd_rule[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>(arl_pure_assn A) al ali ** \<upharpoonleft>snat.assn i ii ** \<up>(i<length al) ** \<upharpoonleft>A x xi)
    (arl_upd ali ii xi)
    (\<lambda>ali. \<upharpoonleft>(arl_pure_assn A) (al[i:=x]) ali)"
    unfolding arl_pure_assn_def
    supply [fri_rules] = pure_list_assn_upd'
    by vcg

  lemma arlp_push_back_rule[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>(arl_pure_assn A) al (ali::(_,'l::len2)array_list) ** \<upharpoonleft>A x xi ** \<up>\<^sub>d(length al + 1 < max_snat LENGTH('l)))
    (arl_push_back ali xi)
    (\<lambda>ali. \<upharpoonleft>(arl_pure_assn A) (al@[x]) ali)"
    unfolding arl_pure_assn_def
    supply [fri_rules] = pure_list_assn_push_back'
    by vcg

  lemma arlp_pop_back_rule[vcg_rules]:
    "llvm_htriple
      (\<upharpoonleft>(arl_pure_assn A) al ali ** \<up>\<^sub>d(al\<noteq>[]))
      (arl_pop_back ali)
      (\<lambda>(xi,ali). \<upharpoonleft>(arl_pure_assn A) (butlast al) ali ** \<upharpoonleft>A (last al) xi)"
    unfolding arl_pure_assn_def
    supply [fri_rules] = pure_list_assn_pop_back' pure_list_assn_last'
    by vcg

  (* TODO: Why isn't pure part properly extracted from \<flat>\<^sub>ppure_list_assn?*)
  lemma list_assn_len_simp: "\<flat>\<^sub>p(pure_list_assn A) xs ys \<Longrightarrow> length ys = length xs"
    unfolding pure_list_assn_def by (auto dest: list_all2_lengthD)

  lemma arlp_len_rule[vcg_rules]:
    "llvm_htriple
      (\<upharpoonleft>(arl_pure_assn A) al ali)
      (arl_len ali)
      (\<lambda>li. \<upharpoonleft>(arl_pure_assn A) al ali ** \<upharpoonleft>snat.assn (length al) li)"
    unfolding arl_pure_assn_def
    (* TODO: Why isn't pure part properly extracted from \<flat>\<^sub>ppure_list_assn?*)
    supply [simp] = list_assn_len_simp
    by vcg

  lemma arlp_free_rl[vcg_rules]:
    "llvm_htriple
      (\<upharpoonleft>(arl_pure_assn A) al ali)
      (arl_free ali)
      (\<lambda>_. \<box>)"
    unfolding arl_pure_assn_def
    by vcg

end