section \<open>Implementation of Heaps with Arrays\<close>
theory IICF_Impl_Heap
imports
  IICF_Abs_Heap
  "../IICF_Array"
  "../IICF_Array_List"
begin

  (* TODO: Move *)

  term al_assn

  (* TODO: Move *)
  lemma size_mset_param[param]: "(size,size)\<in>\<langle>A\<rangle>mset_rel \<rightarrow> nat_rel"
    by (auto simp: mset_rel_def p2rel_def rel_mset_size)

  (* TODO: Move *)
  lemma rdomp_ref_mk_assn_iff[simp]: "rdomp \<upharpoonleft>(mk_assn A) = rdomp A"
    by (auto simp: rdomp_def)

  thm vcg_prep_ext_rules

  find_theorems pure_part

  lemma rdomp_arl_assn_len:
    assumes "rdomp \<upharpoonleft>(arl_assn:: ('a::llvm_rep list, 'l::len2 word \<times> 'l word \<times> 'a ptr) dr_assn) xs"
    shows "length xs < max_snat LENGTH('l)"
    using assms
    by (auto
      simp: rdomp_def arl_assn_def arl_assn'_def sep_algebra_simps pred_lift_extract_simps
      simp: snat.assn_def
      )

  find_theorems vassn_tag hn_refine

    (* TODO: Move*)
    lemma snat_imp_bound[simp,arith]: "(c::'l::len2 word,a)\<in>snat_rel \<Longrightarrow> l=LENGTH('l) \<Longrightarrow> a<max_snat l"
      unfolding snat_rel_def snat.rel_def in_br_conv
      unfolding snat_def max_snat_def
      apply auto
      using sint_range' by blast

  (* TODO: Very specialized workaround lemma, to work around invalid-recombination
    problem for case that B is pure
  *)
  lemma workaround_invalid_recombine_pure2: "is_pure B \<Longrightarrow> hn_ctxt (invalid_assn A \<times>\<^sub>a B) ax px \<turnstile> hn_invalid (A \<times>\<^sub>a B) ax px"
    unfolding hn_ctxt_def invalid_assn_def prod_assn_def entails_def
    by (auto split: prod.split elim!: is_pureE
      simp: sep_algebra_simps pure_part_pure_conj_eq)
    argo

  (* TODO: Move
    TODO: Should be generic algorithm!
  *)
  lemma mop_list_swap_unfold: "mop_list_swap xs i j = do {
    xi \<leftarrow> mop_list_get xs i;
    xj \<leftarrow> mop_list_get xs j;
    xs \<leftarrow> mop_list_set xs i xj;
    mop_list_set xs j xi
  }"
  by (auto simp: pw_eq_iff refine_pw_simps swap_def)

  text \<open>We implement the heap data structure by an array.
    The implementation is automatically synthesized by the Sepref-tool.
    \<close>
  subsection \<open>Setup of the Sepref-Tool\<close>

  (* TODO: Move *)
  lemma mset_rel_id: "\<langle>Id\<rangle>mset_rel = Id"
    unfolding mset_rel_def apply (simp add: rel2p multiset.rel_eq)
    by (simp only: p2rel)

  locale heap_impl = heapstruct prio for prio :: "'e \<Rightarrow> 'p::linorder" +
    fixes prio_assn :: "'p \<Rightarrow> 'pi::llvm_rep \<Rightarrow> assn"
      and elem_assn :: "'e \<Rightarrow> 'ei::llvm_rep \<Rightarrow> assn"
      and prio_impl le_prio_impl lt_prio_impl
      and ltype :: "'l::len2 itself"
    assumes prio_is_pure[safe_constraint_rules]: "is_pure prio_assn"
    assumes elem_is_pure[safe_constraint_rules]: "is_pure elem_assn"
    assumes prio_impl_refine[sepref_fr_rules]: "(prio_impl, RETURN o prio)\<in>elem_assn\<^sup>k \<rightarrow>\<^sub>a prio_assn"
    assumes le_prio_impl_refine[sepref_fr_rules]:
      "(uncurry le_prio_impl, uncurry (RETURN oo (\<le>))) \<in> prio_assn\<^sup>k *\<^sub>a prio_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
    assumes lt_prio_impl_refine[sepref_fr_rules]:
      "(uncurry lt_prio_impl, uncurry (RETURN oo (<))) \<in> prio_assn\<^sup>k *\<^sub>a prio_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"

    fixes N defines "N\<equiv>LENGTH('l)"
    (*assumes l_len[simp,arith]: "4 < LENGTH('l)"*)
  begin

    abbreviation "assn \<equiv> al_assn' TYPE('l) elem_assn"
    abbreviation "idx_assn \<equiv> snat_assn' TYPE('l)"
    definition "heap_assn \<equiv> hr_comp (al_assn elem_assn) heap_rel1"

    lemma mk_free_heap_assn[sepref_frame_free_rules]: "MK_FREE heap_assn arl_free"
      unfolding heap_assn_def
      by (rule sepref_frame_free_rules)+

    (*context
      assumes l_len_pre: "(4 < LENGTH('l))"
    begin
      private lemma l_len: "4 < LENGTH('l)" using l_len_pre unfolding vcg_tag_defs by auto
    *)

      sepref_register prio

      sepref_register "(\<le>) :: 'p \<Rightarrow> 'p \<Rightarrow> bool"
      sepref_register "(<) :: 'p \<Rightarrow> 'p \<Rightarrow> bool"

      lemma l_len_bound[simp,arith]: "4 < LENGTH('l) \<Longrightarrow> 16 \<le> max_snat LENGTH('l)"
        unfolding max_snat_def
      proof -
        assume "4<LENGTH('l)"
        hence "4\<le>LENGTH('l)-1" by simp
        hence "(2::nat)^4 \<le> 2^(LENGTH('l)-1)"
          by (rule power_increasing) auto
        thus "(16::nat) \<le> 2^(LENGTH('l)-1)" by auto
      qed

      lemmas [sepref_frame_free_rules] =
        mk_free_is_pure[OF prio_is_pure]
        mk_free_is_pure[OF elem_is_pure]

      sepref_register update_op
      sepref_definition update_impl is "uncurry2 update_op"
        :: "assn\<^sup>d *\<^sub>a idx_assn\<^sup>k *\<^sub>a elem_assn\<^sup>k \<rightarrow>\<^sub>a assn"
        unfolding update_op_def[abs_def]
        apply (annot_snat_const "TYPE('l)")
        by sepref
      lemmas [sepref_fr_rules] = update_impl.refine

      sepref_register val_of_op
      sepref_definition val_of_impl is "uncurry val_of_op" :: "assn\<^sup>k *\<^sub>a idx_assn\<^sup>k \<rightarrow>\<^sub>a elem_assn"
        unfolding val_of_op_def[abs_def]
        apply (annot_snat_const "TYPE('l)")
        by sepref
      lemmas [sepref_fr_rules] = val_of_impl.refine

      sepref_register exch_op
      sepref_definition exch_impl is "uncurry2 exch_op" :: "assn\<^sup>d *\<^sub>a idx_assn\<^sup>k *\<^sub>a idx_assn\<^sup>k \<rightarrow>\<^sub>a assn"
        unfolding exch_op_def[abs_def] mop_list_swap_unfold
        apply (annot_snat_const "TYPE('l)")
        by sepref

      lemmas [sepref_fr_rules] = exch_impl.refine

      sepref_register valid
      sepref_definition valid_impl is "uncurry (RETURN oo valid)" :: "assn\<^sup>k *\<^sub>a idx_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
        unfolding valid_def[abs_def]
        apply (annot_snat_const "TYPE('l)")
        by sepref
      lemmas [sepref_fr_rules] = valid_impl.refine

      sepref_register prio_of_op
      sepref_definition prio_of_impl is "uncurry (PR_CONST prio_of_op)" :: "assn\<^sup>k *\<^sub>a idx_assn\<^sup>k \<rightarrow>\<^sub>a prio_assn"
        unfolding prio_of_op_def[abs_def] PR_CONST_def
        by sepref
      lemmas [sepref_fr_rules] = prio_of_impl.refine

      sepref_definition append_impl is "uncurry mop_list_append"
        :: "[\<lambda>(xs,_). length xs + 1 < max_snat LENGTH('l)]\<^sub>a assn\<^sup>d *\<^sub>a elem_assn\<^sup>k \<rightarrow> assn"
        by sepref
      lemmas [sepref_fr_rules] = append_impl.refine

      sepref_register swim_op
      sepref_definition swim_impl is
        "uncurry (PR_CONST swim_op)" :: "[\<lambda>_. 4<LENGTH('l)]\<^sub>a assn\<^sup>d *\<^sub>a idx_assn\<^sup>k \<rightarrow> assn"
        unfolding swim_op_def[abs_def] parent_def PR_CONST_def
        apply (annot_snat_const "TYPE('l)")
        (* TODO: Workaround/Hack *)
        supply [sepref_frame_match_rules] = workaround_invalid_recombine_pure2[where B=snat_assn, simplified]
        by sepref_dbg_keep

      lemmas [sepref_fr_rules] = swim_impl.refine

      lemma overflow_safe_hbound_check: "2*k\<le>n \<longleftrightarrow> k\<le>n div 2" for k n :: nat by auto

      (* TODO: Move *)
      lemma al_assn_len_bound: "rdomp (al_assn' TYPE('l) A) xs \<Longrightarrow> length xs < max_snat LENGTH('l)"
        unfolding al_assn_def
        by (auto simp: rdomp_hrcomp_conv dest!: rdomp_arl_assn_len list_rel_imp_same_length)

      lemma bound_aux1: "rdomp assn xs \<Longrightarrow> j\<le>length xs div 2 \<Longrightarrow> 2*j < max_snat LENGTH('l)"
        apply (drule al_assn_len_bound)
        by simp

      lemma bound_aux2: "\<lbrakk>rdomp assn a1'; 2 * a2' < length a1'\<rbrakk>
        \<Longrightarrow> Suc (2 * a2') < max_snat LENGTH('l)"
        apply (drule al_assn_len_bound)
        by auto

      sepref_register sink_op
      sepref_definition sink_impl is "uncurry (PR_CONST sink_op)" :: "[\<lambda>_. 4<LENGTH('l)]\<^sub>a assn\<^sup>d *\<^sub>a idx_assn\<^sup>k \<rightarrow> assn"
        unfolding sink_op_opt_def[abs_def] sink_op_opt_eq[symmetric,abs_def]  PR_CONST_def
        unfolding overflow_safe_hbound_check Suc_eq_plus1
        (* TODO: Workaround/Hack *)
        supply [sepref_frame_match_rules] = workaround_invalid_recombine_pure2[where B=snat_assn, simplified]
        supply [simp] = bound_aux1 bound_aux2
        apply (annot_snat_const "TYPE('l)")
        by sepref

      lemmas [sepref_fr_rules] = sink_impl.refine

      lemma prenorm_heaprel1_len: "(h,m)\<in>heap_rel1 \<Longrightarrow> length h = size m"
        unfolding heap_rel1_def in_br_conv
        by auto
      lemma max_snat_param: "(max_snat,max_snat)\<in>nat_rel \<rightarrow> nat_rel" by simp

      context
        notes [fcomp_norm_unfold] = heap_assn_def[symmetric] list_rel_id_simp mset_rel_id
        notes [fcomp_prenorm_simps] = prenorm_heaprel1_len
        notes [param] = IdI[of N] max_snat_param
      begin

        sepref_definition empty_impl is "uncurry0 empty_op" :: "[\<lambda>_. 4<N]\<^sub>a unit_assn\<^sup>k \<rightarrow> assn"
          unfolding empty_op_def N_def
          apply (rewrite al_fold_custom_empty[where 'l='l])
          by sepref
        sepref_decl_impl (no_register) heap_empty: empty_impl.refine[FCOMP empty_op_refine]
          uses op_mset_empty.fref[of Id] .

        sepref_definition is_empty_impl is "is_empty_op" :: "assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
          unfolding is_empty_op_def[abs_def]
          apply (annot_snat_const "TYPE('l)")
          by sepref
        sepref_decl_impl heap_is_empty: is_empty_impl.refine[FCOMP is_empty_op_refine]
          uses op_mset_is_empty.fref[of Id] .

        sepref_definition insert_impl
          is "uncurry insert_op" :: "[\<lambda>(_,xs). 4<N \<and> length xs+1 < max_snat N]\<^sub>a elem_assn\<^sup>k *\<^sub>a assn\<^sup>d \<rightarrow> assn"
          unfolding insert_op_def[abs_def] append_op_def N_def
          by sepref
        sepref_decl_impl heap_insert: insert_impl.refine[FCOMP insert_op_refine]
          uses op_mset_insert.fref[of Id] .

        sepref_definition pop_min_impl is "pop_min_op" :: "[\<lambda>_. 4<N]\<^sub>a assn\<^sup>d \<rightarrow> elem_assn \<times>\<^sub>a assn"
          unfolding pop_min_op_def[abs_def] butlast_op_def N_def
          apply (annot_snat_const "TYPE('l)")
          by sepref
        sepref_decl_impl (no_mop) heap_pop_min: pop_min_impl.refine[FCOMP pop_min_op_refine]
          uses op_prio_pop_min.fref[of Id] .

        sepref_definition peek_min_impl is "peek_min_op" :: "assn\<^sup>k \<rightarrow>\<^sub>a elem_assn"
          unfolding peek_min_op_def[abs_def]
          apply (annot_snat_const "TYPE('l)")
          by sepref
        sepref_decl_impl (no_mop) heap_peek_min: peek_min_impl.refine[FCOMP peek_min_op_refine]
          uses op_prio_peek_min.fref[of Id] .

      end
    (*end        *)

  end

  find_theorems snat_rel ll_icmp_ult

  sepref_definition foo is "uncurry (\<lambda>a b. RETURN (a<b))" :: "(snat_assn' TYPE('l::len2))\<^sup>k *\<^sub>a (snat_assn' TYPE('l::len2))\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
    by sepref

  global_interpretation heap_impl id snat_assn snat_assn return ll_icmp_sle ll_icmp_slt "TYPE('l::len2)" "LENGTH('l)"
    defines h_update_impl = update_impl
        and h_val_of_impl = val_of_impl
        and h_exch_impl = exch_impl
        and h_valid_impl = valid_impl
        and h_prio_of_impl = prio_of_impl
        and h_append_impl = append_impl
        and h_swim_impl = swim_impl
        and h_sink_impl = sink_impl
        and h_empty_impl = empty_impl
        and h_is_empty_impl = is_empty_impl
        and h_insert_impl = insert_impl
        and h_pop_min_impl = pop_min_impl
        and h_peek_min_impl = peek_min_impl

    apply unfold_locales
    apply (rule pure_pure)
    apply sepref
    apply sepref
    apply sepref
    apply simp
    done

  lemmas heap_impl_inlines =
    heap_impl.valid_impl_def[OF heap_impl_axioms]
    heap_impl.prio_of_impl_def[OF heap_impl_axioms]
    heap_impl.val_of_impl_def[OF heap_impl_axioms]
    heap_impl.append_impl_def[OF heap_impl_axioms]
    heap_impl.exch_impl_def[OF heap_impl_axioms]
    heap_impl.empty_impl_def[OF heap_impl_axioms]
    heap_impl.is_empty_impl_def[OF heap_impl_axioms]
    heap_impl.insert_impl_def[OF heap_impl_axioms]
    heap_impl.pop_min_impl_def[OF heap_impl_axioms]
    heap_impl.peek_min_impl_def[OF heap_impl_axioms]

    h_swim_impl_def[symmetric]
    h_sink_impl_def[symmetric]

  lemmas [llvm_inline] = update_impl_def
  lemmas [llvm_inline] = val_of_impl_def
  lemmas [llvm_inline] = exch_impl_def
  lemmas [llvm_inline] = h_valid_impl_def[unfolded heap_impl_inlines]
  lemmas [llvm_inline] = h_prio_of_impl_def[unfolded heap_impl_inlines]
  lemmas [llvm_inline] = h_append_impl_def[unfolded heap_impl_inlines]
  lemmas [llvm_code] = h_swim_impl_def[unfolded heap_impl.swim_impl_def[OF heap_impl_axioms], unfolded heap_impl_inlines]
  lemmas [llvm_code] = h_sink_impl_def[unfolded heap_impl.sink_impl_def[OF heap_impl_axioms], unfolded heap_impl_inlines]
  lemmas [llvm_inline] = h_empty_impl_def[unfolded heap_impl_inlines]
  lemmas [llvm_inline] = h_is_empty_impl_def[unfolded heap_impl_inlines]
  lemmas [llvm_inline] = h_insert_impl_def[unfolded heap_impl_inlines]
  lemmas [llvm_inline] = h_pop_min_impl_def[unfolded heap_impl_inlines]
  lemmas [llvm_inline] = h_peek_min_impl_def[unfolded heap_impl_inlines]

  definition [simp]: "op_heap_custom_empty (_::'a::len2 itself) (_::'l::len2 itself) \<equiv> op_mset_empty"
  context fixes Q T :: "_::len2 itself" begin sepref_register "op_heap_custom_empty Q T" end

  lemma op_heap_custom_empty_hnr[sepref_fr_rules]:
    shows "(
      uncurry0 (empty_impl::('a::len2 word,'l)array_list llM ),
      uncurry0 (RETURN (PR_CONST (op_heap_custom_empty TYPE('a) TYPE('l))))) \<in> [\<lambda>_. 4<LENGTH('l::len2)]\<^sub>a unit_assn\<^sup>k \<rightarrow> heap_assn"
    unfolding op_heap_custom_empty_def PR_CONST_def
    by (rule heap_empty_hnr[unfolded PRECOND_def])

  lemma heap_fold_custom_empty:
    "{#} = op_heap_custom_empty TYPE('a::len2) TYPE('l::len2)"
    "op_mset_empty = op_heap_custom_empty TYPE('a::len2) TYPE('l::len2)"
    "mop_mset_empty = RETURN (op_heap_custom_empty TYPE('a::len2) TYPE('l::len2))"
    by auto

definition "sort_by_prio l\<^sub>0 \<equiv> do {
  q \<leftarrow> nfoldli l\<^sub>0 (\<lambda>_. True) (\<lambda>x q. do { ASSERT (size q < length l\<^sub>0); mop_mset_insert x q }) {#};
  ASSERT (q = mset l\<^sub>0);
  (l,q) \<leftarrow> WHILEIT (\<lambda>(l,q). sorted l \<and> (\<forall>x\<in>set l. \<forall>y\<in>#q. x\<le>y) \<and> mset l + q = mset l\<^sub>0)
    (\<lambda>(l,q). \<not>op_mset_is_empty q) (\<lambda>(l,q).
  do {
    (x,q) \<leftarrow> mop_prio_pop_min id q;
    ASSERT (size l < length l\<^sub>0);
    RETURN (l@[x],q)
  }) (op_list_empty,q);
  RETURN l
}"

lemma sort_by_prio_correct: "sort_by_prio l \<le> SPEC (\<lambda>l'. sorted l' \<and> mset l' = mset l)"
  unfolding sort_by_prio_def mop_prio_pop_min_def

  apply (refine_vcg
    nfoldli_rule[where I="\<lambda>ll _ q. q = mset ll"]
    WHILEIT_rule[where R="measure (\<lambda>(l,q). size q)"]
    )
  apply (auto 0 3 dest: in_diffD simp: size_Diff1_less sorted_append_bigger)
  subgoal by (metis add_cancel_right_right le_add1 nat_less_le size_eq_0_iff_empty size_mset size_union)
  subgoal by (metis insert_DiffM union_iff)
  done

(* TODO: Move  *)
function list_intv_induction where
  "list_intv_induction l u = (if l<u then list_intv_induction (Suc l) u else ())"
  by pat_completeness auto

termination
  apply (relation "measure (\<lambda>(l,u). u-l)")
  by auto

lemma nfoldli_range_to_while: "nfoldli [l..<u] c f \<sigma> = do {
    (_,\<sigma>) \<leftarrow> WHILET
      (\<lambda>(i,\<sigma>). i<u \<and> c \<sigma>)
      (\<lambda>(i,\<sigma>). do { \<sigma> \<leftarrow> f i \<sigma>; ASSERT (i<u); RETURN (i+1,\<sigma>) })
      (l,\<sigma>);
    RETURN \<sigma>
  }"
proof (induction l u arbitrary: \<sigma> rule: list_intv_induction.induct)
  case (1 l u)
  show ?case proof (cases "l<u")
    case False thus ?thesis
      by (rewrite WHILET_unfold) simp

  next
    case True
    thm "1.IH"[OF True, abs_def]
    thus ?thesis
      by (rewrite WHILET_unfold) (simp add: upt_conv_Cons "1.IH"[OF True, abs_def])
  qed
qed

sepref_definition sort_impl [llvm_code] is
  "sort_by_prio" :: "[\<lambda>l. length l < max_snat LENGTH(64)]\<^sub>a (al_assn' TYPE(64) (snat_assn' TYPE(64)))\<^sup>k \<rightarrow> al_assn' TYPE(64) (snat_assn' TYPE(64))"
  unfolding sort_by_prio_def[abs_def]
  apply (rewrite nfoldli_by_idx)
  apply (rewrite nfoldli_range_to_while)
  apply (rewrite heap_fold_custom_empty[where 'l=64 and 'a="64"])
  apply (rewrite at op_list_empty al_fold_custom_empty[where 'l=64])
  apply (annot_snat_const "TYPE(64)")
  by sepref

export_llvm
  sort_impl is "sort"
  "arl_new_raw :: (64 word,64) array_list llM" is "arl_new"
  "arl_push_back :: _ \<Rightarrow> _ \<Rightarrow> (64 word,64) array_list llM" is "arl_push_back"
  (*file "sort.ll" *)
  (* CAREFUL: The calling conventions generated by this LLVM code are hard/impossible to
    interface from C !? *)

end


theory Trace
  imports Semantics
begin

section \<open>Trace\<close>

text \<open>
Given the small-step semantics for a language,
define the possible traces that a program may generate.
\<close>

inductive rep\<^sub>i
  where
    n[intro]: "rep\<^sub>i s []" |
    s[intro]: "rep\<^sub>i s t\<^sub>1 \<Longrightarrow> t\<^sub>2 \<in> s \<Longrightarrow> rep\<^sub>i s (t\<^sub>2 @ t\<^sub>1)"

inductive inter\<^sub>i
  where
    e[intro]: "inter\<^sub>i [] [] []" |
    l[intro]: "inter\<^sub>i l\<^sub>1 l\<^sub>2 t \<Longrightarrow> inter\<^sub>i (x#l\<^sub>1) l\<^sub>2 (x#t)" |
    r[intro]: "inter\<^sub>i l\<^sub>1 l\<^sub>2 t \<Longrightarrow> inter\<^sub>i l\<^sub>1 (x#l\<^sub>2) (x#t)"

type_synonym 'b Trace = "'b list"

inductive_set trace :: "('a Stmt \<times> 'a Trace \<times> 'a Stmt) set"
  and trace_abv :: "'a Stmt \<Rightarrow> 'a Trace \<Rightarrow> 'a Stmt \<Rightarrow> bool" ("_ \<mapsto>_\<^sup>* _" [50,40,40] 70)
  where
  "trace_abv P t P' \<equiv> (P, t, P') \<in> trace"
  | lift[intro]:    "c \<mapsto>[]\<^sup>* c"
  | rewrite[intro]: "c\<^sub>1 \<leadsto> c\<^sub>2 \<Longrightarrow> c\<^sub>2 \<mapsto>t\<^sup>* c\<^sub>3 \<Longrightarrow> c\<^sub>1 \<mapsto>t\<^sup>* c\<^sub>3"
  | prepend[intro]: "c\<^sub>1 \<mapsto>\<^sub>\<alpha> c\<^sub>2 \<Longrightarrow> c\<^sub>2 \<mapsto>t\<^sup>* c\<^sub>3 \<Longrightarrow> c\<^sub>1 \<mapsto>\<alpha>#t\<^sup>* c\<^sub>3"

section \<open>Properties\<close>

lemma inter\<^sub>i_I1 [intro]:
  shows "inter\<^sub>i [] l l"
  by (induct l) auto

lemma inter\<^sub>i_I2 [intro]:
  shows "inter\<^sub>i l [] l"
  by (induct l) auto

lemma interE [elim]:
  assumes "inter\<^sub>i t\<^sub>1 t\<^sub>2 []"
  obtains "t\<^sub>1 = []" "t\<^sub>2 = []"
  using assms
  by (induct t\<^sub>1 t\<^sub>2 "[] :: 'a list" rule: inter\<^sub>i.induct) auto

lemma inter\<^sub>i_E2 [elim]:
  assumes "inter\<^sub>i [] t t'"
  obtains "t = t'"
  using assms
  by (induct "[] :: 'a list" t t' rule: inter\<^sub>i.induct) auto

subsection \<open>Trace Properties\<close>

lemma trace_concat [intro]:
  assumes "P\<^sub>1 \<mapsto>t\<^sub>1\<^sup>* P\<^sub>2"
  assumes "P\<^sub>2 \<mapsto>t\<^sub>2\<^sup>* P\<^sub>3"
  shows "P\<^sub>1 \<mapsto>t\<^sub>1@t\<^sub>2\<^sup>* P\<^sub>3"
  using assms by induct auto

lemma trace_pre [intro]:
  assumes "P\<^sub>1 \<mapsto>[x]\<^sup>* P\<^sub>2"
  assumes "P\<^sub>2 \<mapsto>t\<^sup>* P\<^sub>3"
  shows "P\<^sub>1 \<mapsto>x#t\<^sup>* P\<^sub>3"
  using trace_concat[OF assms] by auto

lemma trace_concatE [elim]:
  assumes "P\<^sub>1 \<mapsto>t\<^sub>1@t\<^sub>2\<^sup>* P\<^sub>3"
  obtains P\<^sub>2 where "P\<^sub>1 \<mapsto>t\<^sub>1\<^sup>* P\<^sub>2" "P\<^sub>2 \<mapsto>t\<^sub>2\<^sup>* P\<^sub>3"
  using assms
proof (induct P\<^sub>1 "t\<^sub>1 @t\<^sub>2" P\<^sub>3 arbitrary: t\<^sub>1 t\<^sub>2)
  case (prepend c\<^sub>1 \<alpha> c\<^sub>2 t c\<^sub>3)
  then show ?case by (cases t\<^sub>1) auto
qed blast+

lemma trace_preE [elim]:
  assumes "P\<^sub>1 \<mapsto>x#t\<^sub>2\<^sup>* P\<^sub>3"
  obtains P\<^sub>2 where "P\<^sub>1 \<mapsto>[x]\<^sup>* P\<^sub>2" "P\<^sub>2 \<mapsto>t\<^sub>2\<^sup>* P\<^sub>3"
  using assms by (metis append_Cons append_Nil trace_concatE)

lemma trace_par [intro]:
  assumes "c\<^sub>1 \<mapsto>t\<^sup>* c\<^sub>1'"
  shows "c\<^sub>1 || c\<^sub>2 \<mapsto>t\<^sup>* c\<^sub>1' || c\<^sub>2" "c\<^sub>2 || c\<^sub>1 \<mapsto>t\<^sup>* c\<^sub>2 || c\<^sub>1'"
  using assms by induct auto

lemma trace_seq [intro]:
  assumes "P\<^sub>1 \<mapsto>t\<^sub>1\<^sup>* P\<^sub>2"
  shows "P\<^sub>1 ;; P\<^sub>3 \<mapsto>t\<^sub>1\<^sup>* P\<^sub>2 ;; P\<^sub>3"
  using assms by induct blast+

subsection \<open>Trace Elimination\<close>

subsubsection \<open>Skip Properties\<close>

lemma trace_skipE [elim]:
  assumes "Skip \<mapsto>t\<^sup>* P"
  obtains "P = Skip" "t = []"
  using assms by (induct "Skip :: 'a Stmt" t P rule: trace.induct) blast+

subsubsection \<open>Act Properties\<close>

lemma trace_actE [elim]:
  assumes "Basic \<alpha> \<mapsto>t\<^sup>* P"
  obtains "t = [\<alpha>]" "P = Skip" | "t = []" "P = Basic \<alpha>"
  using assms by (induct "Basic \<alpha>" t P) blast+

subsubsection \<open>Seq Properties\<close>

lemma trace_seqE [elim]:
  assumes "P\<^sub>1 ;; P\<^sub>2 \<mapsto>t\<^sup>* P\<^sub>3"
  obtains t\<^sub>1 t\<^sub>2 P\<^sub>1' P\<^sub>2' where "P\<^sub>1 \<mapsto>t\<^sub>1\<^sup>* P\<^sub>1'" "P\<^sub>2 \<mapsto>t\<^sub>2\<^sup>* P\<^sub>2'" "t = t\<^sub>1@t\<^sub>2" "P\<^sub>1' ;; P\<^sub>2' \<mapsto>[]\<^sup>* P\<^sub>3"
  using assms
proof (induct "P\<^sub>1 ;; P\<^sub>2" t P\<^sub>3 arbitrary: P\<^sub>1 P\<^sub>2)
  case lift
  then show ?case by blast
next
  case (rewrite c\<^sub>2 t c\<^sub>3)
  then show ?case
  proof (cases )
    case (seq c\<^sub>1')
    then show ?thesis using rewrite by blast
  next
    case seqE
    then show ?thesis using rewrite by force
  qed
next
  case (prepend \<alpha> c\<^sub>2 t c\<^sub>3)
  then show ?case
  proof (cases)
    case (seq c\<^sub>1')
    then show ?thesis
      using prepend(2,4) prepend(3)[OF seq(1)]
      by (metis Cons_eq_appendI trace.prepend)
  qed
qed

lemma traces_seq_skipI [intro]:
  shows "Skip ;; Skip \<mapsto>[]\<^sup>* Skip"
  by auto

lemma traces_seq_skipE [elim]:
  assumes "c\<^sub>1 ;; c\<^sub>2 \<mapsto>[]\<^sup>* Skip"
  obtains "c\<^sub>1 \<mapsto>[]\<^sup>* Skip" "c\<^sub>2 \<mapsto>[]\<^sup>* Skip"
  using assms
  by (induct "c\<^sub>1 ;; c\<^sub>2" "[] :: 'a Trace" "Skip :: 'a Stmt" arbitrary: c\<^sub>1 c\<^sub>2 rule: trace.induct)
      blast+

lemma trace_seq_fullE [elim]:
  assumes "P\<^sub>1 ;; P\<^sub>2 \<mapsto>t\<^sup>* Skip"
  obtains t\<^sub>1 t\<^sub>2 where "P\<^sub>1 \<mapsto>t\<^sub>1\<^sup>* Skip" "P\<^sub>2 \<mapsto>t\<^sub>2\<^sup>* Skip" "t = t\<^sub>1@t\<^sub>2"
  using assms
proof (cases rule: trace_seqE)
  case (1 t\<^sub>1 t\<^sub>2 P\<^sub>1' P\<^sub>2')
  then show ?thesis using traces_seq_skipE[OF 1(4)] that trace_concat by fastforce
qed

lemma traces_seq_fullI [intro]:
  assumes "P\<^sub>1 \<mapsto>t\<^sub>1\<^sup>* Skip" "P\<^sub>2 \<mapsto>t\<^sub>2\<^sup>* Skip"
  shows "P\<^sub>1 ;; P\<^sub>2 \<mapsto>t\<^sub>1@t\<^sub>2\<^sup>* Skip"
  using assms by blast

subsubsection \<open>Choice Properties\<close>

lemma trace_choiceE [elim]:
  assumes "P\<^sub>1 \<sqinter> P\<^sub>2 \<mapsto>t\<^sup>* P\<^sub>3"
  obtains "P\<^sub>1 \<mapsto>t\<^sup>* P\<^sub>3" | "P\<^sub>2 \<mapsto>t\<^sup>* P\<^sub>3" | "P\<^sub>3 = P\<^sub>1 \<sqinter> P\<^sub>2" "t = []"
  using assms by (induct "P\<^sub>1 \<sqinter> P\<^sub>2" t P\<^sub>3) blast+

subsubsection \<open>Loop Properties\<close>

lemma trace_loopE [elim]:
  assumes "P\<^sub>1* \<mapsto>t\<^sup>* P\<^sub>3"
  obtains n where "unroll n P\<^sub>1 \<mapsto>t\<^sup>* P\<^sub>3" | "P\<^sub>3 = (P\<^sub>1*)" "t = []"
  using assms by (induct "P\<^sub>1*" t P\<^sub>3) blast+

lemma trace_loop_zeroI [intro]:
  "c* \<mapsto>[]\<^sup>* Skip"
proof
  show "c* \<leadsto> unroll 0 c" by blast
next
  show "unroll 0 c \<mapsto>[]\<^sup>* Skip" by auto
qed

lemma trace_loop_sucI [intro]:
  "c* \<mapsto>t\<^sub>1\<^sup>* Skip \<Longrightarrow> c \<mapsto>t\<^sub>2\<^sup>* Skip \<Longrightarrow> c* \<mapsto>t\<^sub>2@t\<^sub>1\<^sup>* Skip"
proof -
  assume a: "c* \<mapsto>t\<^sub>1\<^sup>* Skip" "c \<mapsto>t\<^sub>2\<^sup>* Skip"
  then obtain n where "unroll n c \<mapsto>t\<^sub>1\<^sup>* Skip" by blast
  then have "unroll (Suc n) c \<mapsto>t\<^sub>2@t\<^sub>1\<^sup>* Skip" using a(2) by auto
  thus ?thesis by blast
qed

lemma trace_loop_fullE [elim]:
  assumes "P\<^sub>1* \<mapsto>t\<^sup>* Skip"
  obtains n where "unroll n P\<^sub>1 \<mapsto>t\<^sup>* Skip"
  using assms by auto

subsubsection \<open>Parallel Properties\<close>

lemma trace_parE [elim]:
  assumes "P\<^sub>1 || P\<^sub>2 \<mapsto>t\<^sup>* P\<^sub>3"
  obtains t\<^sub>1 t\<^sub>2 P\<^sub>1' P\<^sub>2' where "P\<^sub>1 \<mapsto>t\<^sub>1\<^sup>* P\<^sub>1'" "P\<^sub>2 \<mapsto>t\<^sub>2\<^sup>* P\<^sub>2'" "inter\<^sub>i t\<^sub>1 t\<^sub>2 t" "P\<^sub>1' || P\<^sub>2' \<mapsto>[]\<^sup>* P\<^sub>3"
  using assms
proof (induct "P\<^sub>1 || P\<^sub>2" t P\<^sub>3 arbitrary: P\<^sub>1 P\<^sub>2)
  case (rewrite c\<^sub>2 t c\<^sub>3)
  then show ?case
  proof (cases rule: rw_parE)
    case par1E
    then show ?thesis using rewrite(1,2) rewrite(4)[of "[]"] by blast
  next
    case par2E
    then show ?thesis using rewrite(1,2) rewrite(4)[of t] by blast
  qed blast+
qed blast+

lemma trace_parI [intro]:
  assumes "inter\<^sub>i t\<^sub>1 t\<^sub>2 t" "c\<^sub>1 \<mapsto>t\<^sub>1\<^sup>* c\<^sub>1'" "c\<^sub>2 \<mapsto>t\<^sub>2\<^sup>* c\<^sub>2'"
  shows "c\<^sub>1 || c\<^sub>2 \<mapsto>t\<^sup>* c\<^sub>1' || c\<^sub>2'"
  using assms
proof (induct arbitrary: c\<^sub>1 c\<^sub>2)
  case e
  then show ?case by (metis (no_types, lifting) Nil_is_append_conv trace_par trace_concat)
next
  case (l l\<^sub>1 l\<^sub>2 t x)
  then obtain c where "c\<^sub>1 \<mapsto>[x]\<^sup>* c" "c \<mapsto>l\<^sub>1\<^sup>* c\<^sub>1'" by blast
  thus ?case using l by auto
next
  case (r l\<^sub>1 l\<^sub>2 t x)
  then obtain c where "c\<^sub>2 \<mapsto>[x]\<^sup>* c" "c \<mapsto>l\<^sub>2\<^sup>* c\<^sub>2'" by blast
  thus ?case using r by auto
qed

lemma traces_par_skipI [intro]:
  shows "Skip || Skip \<mapsto>[]\<^sup>* Skip"
  by auto

lemma traces_par_skipE [elim]:
  assumes "c\<^sub>1 || c\<^sub>2 \<mapsto>[]\<^sup>* Skip"
  obtains "c\<^sub>1 \<mapsto>[]\<^sup>* Skip" "c\<^sub>2 \<mapsto>[]\<^sup>* Skip"
  using assms
  by (induct "c\<^sub>1 || c\<^sub>2" "[] :: 'a Trace" "Skip :: 'a Stmt" arbitrary: c\<^sub>1 c\<^sub>2 rule: trace.induct)
      blast+

lemma trace_par_fullE [elim]:
  assumes "P\<^sub>1 || P\<^sub>2 \<mapsto>t\<^sup>* Skip"
  obtains t\<^sub>1 t\<^sub>2 where "P\<^sub>1 \<mapsto>t\<^sub>1\<^sup>* Skip" "P\<^sub>2 \<mapsto>t\<^sub>2\<^sup>* Skip" "inter\<^sub>i t\<^sub>1 t\<^sub>2 t"
  using assms
proof (cases rule: trace_parE)
  case (1 t\<^sub>1 t\<^sub>2 P\<^sub>1' P\<^sub>2')
  thus ?thesis using trace_concat that by (elim traces_par_skipE) force
qed

lemma traces_par_fullI [intro]:
  assumes "P\<^sub>1 \<mapsto>t\<^sub>1\<^sup>* Skip" "P\<^sub>2 \<mapsto>t\<^sub>2\<^sup>* Skip" "inter\<^sub>i t\<^sub>1 t\<^sub>2 t"
  shows "P\<^sub>1 || P\<^sub>2 \<mapsto>t\<^sup>* Skip"
proof -
  have "P\<^sub>1 || P\<^sub>2 \<mapsto>t\<^sup>* Skip || Skip" using assms by auto
  thus ?thesis using traces_par_skipI trace_concat append_Nil2 by force
qed

subsection \<open>Properties over sets of traces\<close>

definition traces
  where "traces c\<^sub>1 = {t. c\<^sub>1 \<mapsto>t\<^sup>* Skip}"

definition cat
  where "cat s\<^sub>1 s\<^sub>2 \<equiv> {t\<^sub>1 @ t\<^sub>2 |t\<^sub>1 t\<^sub>2. t\<^sub>1 \<in> s\<^sub>1 \<and> t\<^sub>2 \<in> s\<^sub>2}"

definition rep
  where "rep s \<equiv> Collect (rep\<^sub>i s)"

definition inter
  where "inter s\<^sub>1 s\<^sub>2 = {t. \<exists>t\<^sub>1 t\<^sub>2. t\<^sub>1 \<in> s\<^sub>1 \<and> t\<^sub>2 \<in> s\<^sub>2 \<and> inter\<^sub>i t\<^sub>1 t\<^sub>2 t}"

subsection \<open>Trace Lemmas\<close>

lemma traces_skip [simp]:
  "traces Skip = {[]}"
  by (auto simp: traces_def)

lemma traces_act [simp]:
  "traces (Basic \<alpha>) = {[\<alpha>]}"
  by (auto simp: traces_def)

lemma traces_seq [simp]:
  "traces (c\<^sub>1 ;; c\<^sub>2) = cat (traces c\<^sub>1) (traces c\<^sub>2)"
  unfolding cat_def traces_def by blast

lemma traces_choice [simp]:
  "traces (c\<^sub>1 \<sqinter> c\<^sub>2) = traces c\<^sub>1 \<union> traces c\<^sub>2"
  by (auto simp: traces_def)

lemma traces_par [simp]:
  "traces (c\<^sub>1 || c\<^sub>2) = inter (traces c\<^sub>1) (traces c\<^sub>2)"
  unfolding traces_def inter_def by blast

lemma traces_loop [simp]:
  "traces (c*) = rep (traces c)"
  unfolding traces_def rep_def
proof (auto)
  fix x assume "c* \<mapsto>x\<^sup>* Skip"
  then obtain n where "unroll n c \<mapsto>x\<^sup>* Skip" by auto
  thus "rep\<^sub>i {t. c \<mapsto>t\<^sup>* Skip} x" by (induct n arbitrary: x) auto
next
  fix x
  show "rep\<^sub>i {t. c \<mapsto>t\<^sup>* Skip} x \<Longrightarrow> c* \<mapsto>x\<^sup>* Skip"
    by (induct "{t. c \<mapsto>t\<^sup>* Skip}" x rule: rep\<^sub>i.induct) auto
qed

lemma trace_det:
  assumes "c \<mapsto>t\<^sup>* c'" "c \<mapsto>t\<^sup>* c''"
  shows "c'' = c'"
  using assms
proof (induct arbitrary: c'')
  case (lift c)
  then show ?case sorry
next
  case (rewrite c\<^sub>1 c\<^sub>2 t c\<^sub>3)
  then show ?case sorry
next
  case (prepend c\<^sub>1 \<alpha> c\<^sub>2 t c\<^sub>3)
  then show ?case sorry
qed

end


(*  Title:      HOL/Auth/n_mutualEx_on_inis.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_mutualEx Protocol Case Study*}

theory n_mutualEx_on_inis imports n_mutualEx_on_ini
begin
lemma on_inis:
  assumes b1: "f \<in> (invariants N)" and b2: "ini \<in> {andList (allInitSpecs N)}" and b3: "formEval ini s"
  shows "formEval f s"
  proof -
  have c1: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__1  p__Inv3 p__Inv4)\<or>
    (\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__2  p__Inv4)\<or>
    (\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__3  p__Inv3 p__Inv4)\<or>
    (\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__4  p__Inv4)\<or>
    (\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__5  p__Inv3 p__Inv4)"
  apply (cut_tac b1, simp) done
    moreover {
      assume d1: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__1  p__Inv3 p__Inv4)"
      have "formEval f s"
      apply (rule iniImply_inv__1)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__2  p__Inv4)"
      have "formEval f s"
      apply (rule iniImply_inv__2)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__3  p__Inv3 p__Inv4)"
      have "formEval f s"
      apply (rule iniImply_inv__3)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__4  p__Inv4)"
      have "formEval f s"
      apply (rule iniImply_inv__4)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

    moreover {
      assume d1: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__5  p__Inv3 p__Inv4)"
      have "formEval f s"
      apply (rule iniImply_inv__5)
      apply (cut_tac d1, assumption)
      apply (cut_tac b2 b3, blast) done
    }

  ultimately show "formEval f s"
  by satx
qed

end


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

section \<open>Sequential Composition\<close>

theory Sequential_Composition
  imports "Basic_Modules/Component_Types/Electoral_Module"
begin

text
\<open>The sequential composition creates a new electoral module from
two electoral modules. In a sequential composition, the second
electoral module makes decisions over alternatives deferred by
the first electoral module.\<close>

subsection \<open>Definition\<close>

fun sequential_composition :: "'a Electoral_Module \<Rightarrow> 'a Electoral_Module \<Rightarrow>
        'a Electoral_Module" where
  "sequential_composition m n A p vs =
    (let new_A = defer m A p vs;
        new_p = limit_profile new_A p;
        new_vs =  limit_pair_vectors new_A vs in (
                  (elect m A p vs) \<union> (elect n new_A new_p new_vs),
                  (reject m A p vs) \<union> (reject n new_A new_p new_vs),
                  defer n new_A new_p new_vs))"

abbreviation sequence ::
  "'a Electoral_Module \<Rightarrow> 'a Electoral_Module \<Rightarrow> 'a Electoral_Module"
     (infix "\<triangleright>" 50) where
  "m \<triangleright> n == sequential_composition m n"

lemma seq_comp_presv_disj:
  assumes module_m: "electoral_module m" and
          module_n: "electoral_module n" and
          f_prof:  "finite_profile A p" and
          f_vec: "finite_pair_vectors A vs"
  shows "disjoint3 ((m \<triangleright> n) A p vs)"
proof -
  let ?new_A = "defer m A p vs"
  let ?new_p = "limit_profile ?new_A p"
  let ?new_vs = "limit_pair_vectors ?new_A vs"
  have fin_def: "finite (defer m A p vs)"
    using def_presv_fin_prof f_prof module_m f_vec
    by metis
  have prof_def_lim:
    "profile (defer m A p vs) (limit_profile (defer m A p vs) p)"
    using def_presv_fin_prof f_prof module_m f_vec
    by metis
  have vec_def_lim:
    "vector_pair (defer m A p vs) (limit_pair_vectors (defer m A p vs) vs)"
    using f_prof module_m f_vec def_presv_fin_vector_pair
    by metis
  have defer_in_A:
    "\<forall>prof f a A vs.
      (profile A prof \<and> finite A \<and> vector_pair A vs \<and> electoral_module f \<and>
        (a::'a) \<in> defer f A prof vs) \<longrightarrow>
          a \<in> A"
    using UnCI result_presv_alts
    by (metis (mono_tags))
  from module_m f_prof f_vec
  have disjoint_m: "disjoint3 (m A p vs)"
    using electoral_module_def well_formed.simps
    by blast
  from module_m module_n def_presv_fin_prof f_prof
  have disjoint_n:
    "(disjoint3 (n ?new_A ?new_p ?new_vs))"
    using electoral_module_def well_formed.simps
    by (metis def_presv_fin_vector_pair f_vec)
  have disj_n:
    "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 f_prof module_m f_vec
    by (simp add: result_disj)
  from f_prof module_m module_n f_vec
  have rej_n_in_def_m:
    "reject n (defer m A p vs)
      (limit_profile (defer m A p vs) p) (limit_pair_vectors (defer m A p vs) vs)  \<subseteq> defer m A p vs"
    using def_presv_fin_prof reject_in_alts  def_presv_fin_vector_pair
    by metis
  with disjoint_m module_m module_n f_prof f_vec
  have 0:
    "(elect m A p vs \<inter> reject n ?new_A ?new_p ?new_vs) = {}"
    using disj_n
    by (simp add: disjoint_iff_not_equal subset_eq)
  from f_prof module_m module_n f_vec
  have elec_n_in_def_m:
    "elect n (defer m A p vs)
      (limit_profile (defer m A p vs) p) (limit_pair_vectors (defer m A p vs) vs) \<subseteq> defer m A p vs"
    using def_presv_fin_prof elect_in_alts def_presv_fin_vector_pair
    by metis
  from disjoint_m disjoint_n def_presv_fin_prof f_prof f_vec
       module_m module_n def_presv_fin_vector_pair
  have 1:
    "(elect m A p vs \<inter> defer n ?new_A ?new_p ?new_vs) = {}"
  proof -
    obtain sf :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a" where
      "\<forall>a b.
        (\<exists>c. c \<in> b \<and> (\<exists>d. d \<in> a \<and> c = d)) =
          (sf a b \<in> b \<and>
            (\<exists>e. e \<in> a \<and> sf a b = e))"
      by moura
    then obtain sf2 :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a" where
      "\<forall>A B.
        (A \<inter> B \<noteq> {} \<or> (\<forall>a. a \<notin> A \<or> (\<forall>b. b \<notin> B \<or> a \<noteq> b))) \<and>
          (A \<inter> B = {} \<or> sf B A \<in> A \<and> sf2 B A \<in> B \<and>
            sf B A = sf2 B A)"
      by auto
    thus ?thesis
      using defer_in_A disj_n fin_def module_n prof_def_lim vec_def_lim
      by (metis (no_types))
  qed
  from disjoint_m disjoint_n def_presv_fin_prof f_prof f_vec
       module_m module_n
  have 2:
    "(reject m A p vs \<inter> reject n ?new_A ?new_p ?new_vs) = {}"
    using disjoint_iff_not_equal reject_in_alts
          set_rev_mp result_disj Int_Un_distrib2
          Un_Diff_Int boolean_algebra_cancel.inf2
          inf.order_iff inf_sup_aci(1) subsetD
          rej_n_in_def_m disj_n
    by auto
  have "\<forall>A Aa. \<not> (A::'a set) \<subseteq> Aa \<or> A = A \<inter> Aa"
    by blast
  with disjoint_m disjoint_n def_presv_fin_prof f_prof
       module_m module_n elec_n_in_def_m
  have 3:
    "(reject m A p vs \<inter> elect n ?new_A ?new_p ?new_vs) = {}"
    using disj_n
    by blast
  have
    "(elect m A p vs \<union> elect n ?new_A ?new_p ?new_vs) \<inter>
          (reject m A p vs \<union> reject n ?new_A ?new_p ?new_vs) = {}"
  proof (safe)
    fix x :: "'a"
    assume
      elec_x: "x \<in> elect m A p vs" and
      rej_x: "x \<in> reject m A p vs"
    from elec_x rej_x
    have "x \<in> elect m A p vs \<inter> reject m A p vs"
      by simp
    thus "x \<in> {}"
      using disj_n
      by simp
  next
    fix x :: "'a"
    assume
      elec_x: "x \<in> elect m A p vs" and
      rej_lim_x:
      "x \<in> reject n (defer m A p vs)
        (limit_profile (defer m A p vs) p) (limit_pair_vectors (defer m A p vs) vs)"
    from elec_x rej_lim_x
    show "x \<in> {}"
      using "0"
      by blast
  next
    fix x :: "'a"
    assume
      elec_lim_x:
      "x \<in> elect n (defer m A p vs) (limit_profile (defer m A p vs) p)
          (limit_pair_vectors (defer m A p vs) vs)" and
      rej_x: "x \<in> reject m A p vs"
    from elec_lim_x rej_x
    show "x \<in> {}"
      using "3"
      by blast
  next
    fix x :: "'a"
    assume
      elec_lim_x:
      "x \<in> elect n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs)" and
      rej_lim_x:
      "x \<in> reject n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs)"
    from elec_lim_x rej_lim_x
    show "x \<in> {}"
      using disjoint_iff_not_equal elec_lim_x fin_def vec_def_lim
            module_n prof_def_lim rej_lim_x result_disj
      by metis
  qed
  moreover from 0 1 2 3 disjoint_n module_m module_n f_prof f_vec
  have
    "(elect m A p vs \<union> elect n ?new_A ?new_p ?new_vs) \<inter>
          (defer n ?new_A ?new_p ?new_vs) = {}"
    using Int_Un_distrib2 Un_empty def_presv_fin_prof result_disj vec_def_lim
    by metis
  moreover from 0 1 2 3 f_prof disjoint_m disjoint_n module_m module_n
  have
    "(reject m A p vs \<union> reject n ?new_A ?new_p ?new_vs) \<inter>
          (defer n ?new_A ?new_p ?new_vs) = {}"
(*    using Int_Un_distrib2 defer_in_alts distrib_imp2
          def_presv_fin_prof result_disj subset_Un_eq
          sup_inf_distrib1 *)
  proof (safe)
    fix x :: "'a"
    assume
      elec_rej_disj:
      "elect m A p vs \<inter>
        reject n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs) = {}" and
      elec_def_disj:
      "elect m A p vs \<inter>
        defer n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs) = {}" and
      rej_rej_disj:
      "reject m A p vs \<inter>
        reject n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs) = {}" and
      rej_elec_disj:
      "reject m A p vs \<inter>
        elect n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs) = {}" and
      disj_p: "disjoint3 (m A p vs)" and
      disj_limit:
      "disjoint3 (n (defer m A p vs) (limit_profile (defer m A p vs) p)
      (limit_pair_vectors (defer m A p vs) vs))" and
      mod_m: "electoral_module m" and
      mod_n: "electoral_module n" and
      fin_A: "finite A" and
      prof_A: "profile A p" and
      x_in_def:
      "x \<in> defer n (defer m A p vs) (limit_profile (defer m A p vs) p)
      (limit_pair_vectors (defer m A p vs) vs)" and
      x_in_rej: "x \<in> reject m A p vs"
    from x_in_def
    have "x \<in> defer m A p vs"
      using defer_in_A fin_def module_n prof_def_lim vec_def_lim
      by blast
    with x_in_rej
    have "x \<in> reject m A p vs \<inter> defer m A p vs"
      by fastforce
    thus "x \<in> {}"
      using disj_n
      by blast
  next
    fix x :: "'a"
    assume
      elec_rej_disj:
      "elect m A p vs \<inter>
        reject n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs) = {}" and
      elec_def_disj:
      "elect m A p vs \<inter>
        defer n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs) = {}" and
      rej_rej_disj:
      "reject m A p vs \<inter>
        reject n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs) = {}" and
      rej_elec_disj:
      "reject m A p vs \<inter>
        elect n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs) = {}" and
      disj_p: "disjoint3 (m A p vs)" and
      disj_limit:
      "disjoint3 (n (defer m A p vs) (limit_profile (defer m A p vs) p)
      (limit_pair_vectors (defer m A p vs) vs))" and
      mod_m: "electoral_module m" and
      mod_n: "electoral_module n" and
      fin_A: "finite A" and
      prof_A: "profile A p" and
      x_in_def:
      "x \<in> defer n (defer m A p vs) (limit_profile (defer m A p vs) p)
      (limit_pair_vectors (defer m A p vs) vs)" and
      x_in_rej:
      "x \<in> reject n (defer m A p vs) (limit_profile (defer m A p vs) p)
      (limit_pair_vectors (defer m A p vs) vs)"
    from x_in_def x_in_rej
    show "x \<in> {}"
      using fin_def module_n prof_def_lim reject_not_elec_or_def vec_def_lim
       Diff_iff by fastforce
  qed
  ultimately have
    "disjoint3 (elect m A p vs \<union> elect n ?new_A ?new_p ?new_vs,
                reject m A p vs \<union> reject n ?new_A ?new_p ?new_vs,
                defer n ?new_A ?new_p ?new_vs)"
    by simp
  thus ?thesis
    using sequential_composition.simps
    by metis
qed

lemma seq_comp_presv_alts:
  assumes module_m: "electoral_module m" and
          module_n: "electoral_module n" and
          f_prof:  "finite_profile A p" and
          f_vec: "finite_pair_vectors A vs"
  shows "set_equals_partition A ((m \<triangleright> n) A p vs)"
proof -
  let ?new_A = "defer m A p vs"
  let ?new_p = "limit_profile ?new_A p"
  let ?new_vs = "(limit_pair_vectors ?new_A vs)"
  from module_m f_prof f_vec have "set_equals_partition A (m A p vs)"
    by (simp add: electoral_module_def)
  with module_m f_prof f_vec have 0:
    "elect m A p vs \<union> reject m A p vs \<union> ?new_A = A"
    by (simp add: result_presv_alts)
  from module_n def_presv_fin_prof f_prof f_vec module_m have
    "set_equals_partition ?new_A (n ?new_A ?new_p ?new_vs)"
    using electoral_module_def well_formed.simps def_presv_fin_vector_pair
    by metis
  with module_m module_n f_prof f_vec have 1:
    "elect n ?new_A ?new_p ?new_vs \<union>
        reject n ?new_A ?new_p ?new_vs \<union>
        defer n ?new_A ?new_p ?new_vs = ?new_A"
    using def_presv_fin_prof result_presv_alts def_presv_fin_vector_pair
    by metis
  from 0 1 have
    "(elect m A p vs \<union> elect n ?new_A ?new_p ?new_vs) \<union>
        (reject m A p vs \<union> reject n ?new_A ?new_p ?new_vs) \<union>
         defer n ?new_A ?new_p ?new_vs = A"
    by blast
  hence
    "set_equals_partition A
      (elect m A p vs \<union> elect n ?new_A ?new_p ?new_vs,
      reject m A p vs \<union> reject n ?new_A ?new_p ?new_vs,
      defer n ?new_A ?new_p ?new_vs)"
    by simp
  thus ?thesis
    using sequential_composition.simps
    by metis
qed

subsection \<open>Soundness\<close>

theorem seq_comp_sound[simp]:
  assumes module_m: "electoral_module m" and
          module_n: "electoral_module n"
        shows "electoral_module (m \<triangleright> n)"
  unfolding electoral_module_def
proof (safe)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs :: "'a Pair_Vectors"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs"
  have "\<forall>r. well_formed (A::'a set) r =
          (disjoint3 r \<and> set_equals_partition A r)"
    by simp
  thus "well_formed A ((m \<triangleright> n) A p vs)"
    using module_m module_n seq_comp_presv_disj
          seq_comp_presv_alts fin_A prof_A vec_A
    by metis
qed

subsection \<open>Lemmata\<close>

lemma seq_comp_dec_only_def:
  assumes
    module_m: "electoral_module m" and
    module_n: "electoral_module n" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs" and
    empty_defer: "defer m A p vs = {}"
  shows "(m \<triangleright> n) A p vs =  m A p vs"
proof
  have
    "\<forall>f A prof vs.
      (electoral_module f \<and> finite_profile A prof \<and> finite_pair_vectors A vs) \<longrightarrow>
        finite_pair_vectors (defer f A prof vs) (limit_pair_vectors (defer f A prof vs) vs)"
    using def_presv_fin_prof def_presv_fin_vector_pair
    by metis
  hence vec_no_alt: "vector_pair {} (limit_pair_vectors (defer m A p vs) vs)"
    using empty_defer f_prof f_vec module_m by fastforce
  have
    "\<forall>f A prof vs.
      (electoral_module f \<and> finite_profile A prof \<and> finite_pair_vectors A vs) \<longrightarrow>
        finite_profile (defer f A prof vs)
          (limit_profile (defer f A prof vs) prof)"
    using def_presv_fin_prof
    by metis
  hence prof_no_alt:
    "profile {} (limit_profile (defer m A p vs) p)"
    using empty_defer f_prof module_m f_vec
    by metis
  hence
    "(elect m A p vs) \<union>
      (elect n (defer m A p vs)
        (limit_profile (defer m A p vs) p) (limit_pair_vectors (defer m A p vs) vs))
    = elect m A p vs"
    using elect_in_alts empty_defer module_n vec_no_alt
    by fastforce
  thus "elect (m \<triangleright> n) A p vs = elect m A p vs"
    using fst_conv sequential_composition.simps
    by metis
next
  have rej_empty:
    "\<forall>f prof vs.
      (electoral_module f \<and> profile ({}::'a set) prof) \<and> vector_pair ({}::'a set) vs\<longrightarrow>
        reject f {} prof vs = {}"
    using bot.extremum_uniqueI infinite_imp_nonempty reject_in_alts
    by metis
  have prof_no_alt:
    "profile {} (limit_profile (defer m A p vs) p)"
    using empty_defer f_prof module_m limit_profile_sound
    by auto
  have vec_no_alt:
    "vector_pair {} (limit_pair_vectors (defer m A p vs) vs)"
    using empty_defer f_prof f_vec module_m limit_profile_sound limit_pair_vectors_sound prof_no_alt
     by (simp add: vector_pair_def empty_defer)
  hence
    "(reject m A p vs, defer n {} (limit_profile {} p) (limit_pair_vectors {} vs)) =
        snd (m A p vs)"
    using bot.extremum_uniqueI defer_in_alts empty_defer
          infinite_imp_nonempty module_n prod.collapse vec_no_alt prof_no_alt
    by (metis (no_types))
  thus "snd ((m \<triangleright> n) A p vs) = snd (m A p vs)"
    using rej_empty empty_defer module_n prof_no_alt vec_no_alt
    by auto
qed

lemma seq_comp_def_then_elect:
  assumes
    n_electing_m: "non_electing m" and
    def_one_m: "defers 1 m" and
    electing_n: "electing n" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows "elect (m \<triangleright> n) A p vs = defer m A p vs"
proof cases
  assume "A = {}"
  with electing_n n_electing_m f_prof
  show ?thesis
    using bot.extremum_uniqueI defer_in_alts elect_in_alts
          electing_def non_electing_def seq_comp_sound f_vec
    by metis
next
  assume assm: "A \<noteq> {}"
  from n_electing_m f_prof f_vec
  have ele: "elect m A p vs = {}"
    using non_electing_def
    by blast
  from assm def_one_m f_prof finite f_vec
  have def_card:
    "card (defer m A p vs) = 1"
    by (simp add: Suc_leI card_gt_0_iff defers_def)
  with n_electing_m f_prof
  have def:
    "\<exists>a \<in> A. defer m A p vs = {a}"
    using card_1_singletonE defer_in_alts
          non_electing_def singletonI subsetCE f_vec
    by metis
  from ele def n_electing_m
  have rej:
    "\<exists>a \<in> A. reject m A p vs = A-{a}"
    using Diff_empty def_one_m defers_def
          f_prof reject_not_elec_or_def f_vec
    by metis
  from ele rej def n_electing_m f_prof
  have res_m:
    "\<exists>a \<in> A. m A p vs = ({}, A-{a}, {a})"
    using Diff_empty combine_ele_rej_def non_electing_def
          reject_not_elec_or_def f_vec
    by metis
  hence
    "\<exists>a \<in> A. elect (m \<triangleright> n) A p vs  =
        elect n {a} (limit_profile {a} p) (limit_pair_vectors (defer m A p vs) vs)"
    using prod.sel(1) prod.sel(2) sequential_composition.simps
          sup_bot.left_neutral
    by metis
  with def_card def electing_n n_electing_m f_prof
  have
    "\<exists>a \<in> A. elect (m \<triangleright> n) A p vs = {a}"
    using electing_for_only_alt non_electing_def prod.sel
          sequential_composition.simps def_presv_fin_prof
          sup_bot.left_neutral def_presv_fin_vector_pair f_vec
    by metis
  with def def_card electing_n n_electing_m f_prof res_m f_vec
  show ?thesis
    using def_presv_fin_prof electing_for_only_alt fst_conv
          non_electing_def sequential_composition.simps
          sup_bot.left_neutral def_presv_fin_vector_pair
    by metis
qed

lemma seq_comp_def_card_bounded:
  assumes
    module_m: "electoral_module m" and
    module_n: "electoral_module n" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows "card (defer (m \<triangleright> n) A p vs) \<le> card (defer m A p vs)"
  using card_mono defer_in_alts module_m module_n f_prof f_vec
        sequential_composition.simps def_presv_fin_prof snd_conv
        def_presv_fin_vector_pair
  by metis

lemma seq_comp_def_set_bounded:
  assumes
    module_m: "electoral_module m" and
    module_n: "electoral_module n" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows "defer (m \<triangleright> n) A p vs \<subseteq> defer m A p vs"
  using defer_in_alts module_m module_n prod.sel(2) f_prof def_presv_fin_vector_pair
        sequential_composition.simps def_presv_fin_prof f_vec
  by metis

lemma seq_comp_defers_def_set:
  assumes
    module_m: "electoral_module m" and
    module_n: "electoral_module n" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows
    "defer (m \<triangleright> n) A p vs =
      defer n (defer m A p vs) (limit_profile (defer m A p vs) p)
    (limit_pair_vectors (defer m A p vs) vs)"
  using sequential_composition.simps snd_conv
  by metis

lemma seq_comp_def_then_elect_elec_set:
  assumes
    module_m: "electoral_module m" and
    module_n: "electoral_module n" and
    f_prof: "finite_profile A p" and
    f_vec: "finite_pair_vectors A vs"
  shows
    "elect (m \<triangleright> n) A p vs =
      elect n (defer m A p vs) (limit_profile (defer m A p vs) p)
      (limit_pair_vectors (defer m A p vs) vs) \<union> (elect m A p vs)"
  using Un_commute fst_conv sequential_composition.simps
  by metis

lemma seq_comp_elim_one_red_def_set:
  assumes
    module_m: "electoral_module m" and
    module_n: "eliminates 1 n" and
    f_prof: "finite_profile A p" and
    enough_leftover: "card (defer m A p vs) > 1" and
    f_vec: "finite_pair_vectors A vs"
  shows "defer (m \<triangleright> n) A p vs \<subset> defer m A p vs"
  using enough_leftover module_m module_n f_prof
        sequential_composition.simps def_presv_fin_prof
        single_elim_imp_red_def_set snd_conv f_vec def_presv_fin_vector_pair
  by metis

lemma seq_comp_def_set_sound:
  assumes
    "electoral_module m" and
    "electoral_module n" and
    "finite_profile A p" and
    "finite_pair_vectors A vs"
  shows "defer (m \<triangleright> n) A p vs \<subseteq> defer m A p vs"
proof -
  have "\<forall>A p vs. finite_profile A p \<and> finite_pair_vectors A vs
        \<longrightarrow> well_formed A (n A p vs)"
    using assms(2) electoral_module_def
    by auto
  hence
    "finite_profile (defer m A p vs) (limit_profile (defer m A p vs) p) \<and>
     finite_pair_vectors (defer m A p vs) (limit_pair_vectors (defer m A p vs) vs) \<longrightarrow>
        well_formed (defer m A p vs)
          (n (defer m A p vs) (limit_profile (defer m A p vs) p)
      (limit_pair_vectors (defer m A p vs) vs))"
    by simp
  hence
    "well_formed (defer m A p vs) (n (defer m A p vs)
      (limit_profile (defer m A p vs) p) (limit_pair_vectors (defer m A p vs) vs))"
    using assms(1) assms(3) assms(4) def_presv_fin_prof def_presv_fin_vector_pair
    by metis
  thus ?thesis
    using assms seq_comp_def_set_bounded
    by blast
qed

lemma seq_comp_def_set_trans:
  assumes
    "a \<in> (defer (m \<triangleright> n) A p vs)" and
    "electoral_module m \<and> electoral_module n" and
    "finite_profile A p" and
    "finite_pair_vectors A vs"
  shows
    "a \<in> defer n (defer m A p vs)
      (limit_profile (defer m A p vs) p) (limit_pair_vectors (defer m A p vs) vs) \<and>
      a \<in> defer m A p vs"
  using seq_comp_def_set_bounded assms(1) assms(2)
        assms(3) assms(4) in_mono seq_comp_defers_def_set
  by (smt (verit, ccfv_threshold))

subsection \<open>Composition Rules\<close>

(*The sequential composition preserves the non-blocking property.*)
theorem seq_comp_presv_non_blocking[simp]:
  assumes
    non_blocking_m: "non_blocking m" and
    non_blocking_n: "non_blocking n"
  shows "non_blocking (m \<triangleright> n)"
proof -
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs :: "'a Pair_Vectors"
  let ?input_sound = "((A::'a set) \<noteq> {} \<and> finite_profile A p \<and>
      finite_pair_vectors A vs)"
  from non_blocking_m have
    "?input_sound \<longrightarrow> reject m A p vs \<noteq> A"
    by (simp add: non_blocking_def)
  with non_blocking_m have 0:
    "?input_sound \<longrightarrow> A - reject m A p vs \<noteq> {}"
    using Diff_eq_empty_iff non_blocking_def
          reject_in_alts subset_antisym
    by metis
  from non_blocking_m have
    "?input_sound \<longrightarrow> well_formed A (m A p vs)"
    by (simp add: electoral_module_def non_blocking_def)
  hence
    "?input_sound \<longrightarrow>
        elect m A p vs \<union> defer m A p vs = A - reject m A p vs"
    using non_blocking_def non_blocking_m elec_and_def_not_rej
    by metis
  with 0 have
    "?input_sound \<longrightarrow> elect m A p vs \<union> defer m A p vs \<noteq> {}"
    by auto
  hence "?input_sound \<longrightarrow> (elect m A p vs \<noteq> {} \<or> defer m A p vs \<noteq> {})"
    by simp
  with non_blocking_m non_blocking_n
  show ?thesis
  proof (unfold non_blocking_def)
    assume
      emod_reject_m:
      "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)" and
      emod_reject_n:
      "electoral_module n \<and>
        (\<forall>A p vs. A \<noteq> {} \<and> finite_profile A p \<and> finite_pair_vectors A vs \<longrightarrow>
          reject n A p vs \<noteq> A)"
    show
      "electoral_module (m \<triangleright> n) \<and>
        (\<forall>A p vs.
          A \<noteq> {} \<and> finite_profile A p \<and> finite_pair_vectors A vs \<longrightarrow>
            reject (m \<triangleright> n) A p vs \<noteq> A)"
    proof (safe)
      show "electoral_module (m \<triangleright> n)"
        using emod_reject_m emod_reject_n
        by simp
    next
      fix
        A :: "'a set" and
        p :: "'a Profile" and
        vs :: "'a Pair_Vectors" and
        x :: "'a"
      assume
        fin_A: "finite A" and
        prof_A: "profile A p" and
        vec_A: "vector_pair A vs" and
        rej_mn: "reject (m \<triangleright> n) A p vs = A" and
        x_in_A: "x \<in> A"
      from emod_reject_m fin_A prof_A vec_A
      have fin_defer:
        "finite_profile (defer m A p vs) (limit_profile (defer m A p vs) p)"
        using def_presv_fin_prof
        by (metis (no_types))
      from emod_reject_m fin_A prof_A vec_A
      have fin_defer2:
        "finite_pair_vectors (defer m A p vs) (limit_pair_vectors (defer m A p vs) vs)"
        using def_presv_fin_prof def_presv_fin_vector_pair
        by (metis (no_types))
      from emod_reject_m emod_reject_n fin_A prof_A vec_A
      have seq_elect:
        "elect (m \<triangleright> n) A p vs =
          elect n (defer m A p vs) (limit_profile (defer m A p vs) p)
          (limit_pair_vectors (defer m A p vs) vs) \<union>
            elect m A p vs"
        using seq_comp_def_then_elect_elec_set
        by metis
      from emod_reject_n emod_reject_m fin_A prof_A vec_A
      have def_limit:
        "defer (m \<triangleright> n) A p vs =
          defer n (defer m A p vs) (limit_profile (defer m A p vs) p)
          (limit_pair_vectors (defer m A p vs) vs)"
        using seq_comp_defers_def_set
        by metis
      from emod_reject_n emod_reject_m fin_A prof_A vec_A
      have
        "elect (m \<triangleright> n) A p vs \<union> defer (m \<triangleright> n) A p vs = A - reject (m \<triangleright> n) A p vs"
        using elec_and_def_not_rej seq_comp_sound
        by metis
      hence elect_def_disj:
        "elect n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs) \<union>
        elect m A p vs \<union>
        defer n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs) = {}"
        using def_limit seq_elect Diff_cancel rej_mn
        by auto
      have rej_def_eq_set:
        "defer n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs) -
        defer n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs) = {} \<longrightarrow>
        reject n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs) =
              defer m A p vs"
        using elect_def_disj emod_reject_n fin_defer fin_defer2
        by (simp add: reject_not_elec_or_def)
      have
        "defer n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs) -
          defer n (defer m A p vs) (limit_profile (defer m A p vs) p)
        (limit_pair_vectors (defer m A p vs) vs) = {} \<longrightarrow>
            elect m A p vs = elect m A p vs \<inter> defer m A p vs"
        using elect_def_disj
        by blast
      thus "x \<in> {}"
        using rej_def_eq_set result_disj fin_defer
        using Diff_cancel Diff_empty emod_reject_m emod_reject_n
              fin_A prof_A vec_A reject_not_elec_or_def x_in_A fin_defer2
        by metis
    qed
  qed
qed

(*Sequential composition preserves the non-electing property.*)
theorem seq_comp_presv_non_electing[simp]:
  assumes
    m_elect: "non_electing m" and
    n_elect: "non_electing n"
  shows "non_electing (m \<triangleright> n)"
  unfolding non_electing_def
proof (safe)
  from m_elect n_elect
  have "electoral_module m \<and> electoral_module n"
    unfolding non_electing_def
    by blast
  thus "electoral_module (m \<triangleright> n)"
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    x :: "'a" and
    vs :: "'a Pair_Vectors"
  assume
    "finite A" and
    "profile A p" and
    "vector_pair A vs" and
    "x \<in> elect (m \<triangleright> n) A p vs"
  with m_elect n_elect
  show "x \<in> {}"
    unfolding non_electing_def
    using seq_comp_def_then_elect_elec_set def_presv_fin_prof
          Diff_empty Diff_partition empty_subsetI def_presv_fin_vector_pair
    by metis
qed

(*
   Composing an electoral module that defers exactly 1 alternative
   in sequence after an electoral module that is electing
   results (still) in an electing electoral module.
*)
theorem seq_comp_electing[simp]:
  assumes def_one_m1:  "defers 1 m1" and
          electing_m2: "electing m2"
  shows "electing (m1 \<triangleright> m2)"
proof -
  have
    "\<forall>A p vs. (card A \<ge> 1 \<and> finite_profile A p \<and> finite_pair_vectors A vs) \<longrightarrow>
        card (defer m1 A p vs) = 1"
    using def_one_m1 defers_def
    by blast
  hence def_m1_not_empty:
    "\<forall>A p vs. (A \<noteq> {} \<and> finite_profile A p \<and> finite_pair_vectors A vs) \<longrightarrow>
        defer m1 A p vs \<noteq> {}"
    using One_nat_def Suc_leI card_eq_0_iff
          card_gt_0_iff zero_neq_one
    by metis
  thus ?thesis
    using Un_empty def_one_m1 defers_def electing_def
          electing_m2 seq_comp_def_then_elect_elec_set
          seq_comp_sound def_presv_fin_prof
  proof -
    have def_card_one:
      "electoral_module m1 \<and>
        (\<forall>A prof vs.
          (1 \<le> card A \<and> finite A \<and> profile A prof \<and> vector_pair A vs) \<longrightarrow>
            card (defer m1 A prof vs) = 1)"
      using def_one_m1 defers_def
      by blast
   (* hence "electoral_module (m1 \<triangleright> m2)"
      using  seq_comp_sound
      by metis*)
    with  def_card_one
    show ?thesis
      using seq_comp_def_then_elect_elec_set def_presv_fin_prof
            def_m1_not_empty bot_eq_sup_iff def_presv_fin_vector_pair
      by (smt (z3) electing_def electing_m2 seq_comp_sound)
  qed
qed

lemma def_lift_inv_seq_comp_help:
  assumes
    monotone_m: "defer_lift_invariance m" and
    monotone_n: "defer_lift_invariance n" and
    f_vec: "finite_pair_vectors A vs" and
    def_and_lifted: "a \<in> (defer (m \<triangleright> n) A p vs) \<and> lifted A p q a"
  shows "(m \<triangleright> n) A p vs = (m \<triangleright> n) A q vs"
proof -
  let ?new_Ap = "defer m A p vs"
  let ?new_Aq = "defer m A q vs"
  let ?new_p = "limit_profile ?new_Ap p"
  let ?new_q = "limit_profile ?new_Aq q"
  let ?new_vsp = "limit_pair_vectors ?new_Ap vs"
  let ?new_vsq = "limit_pair_vectors ?new_Aq vs"
  from monotone_m monotone_n have modules:
    "electoral_module m \<and> electoral_module n"
    unfolding defer_lift_invariance_def
    by simp
  hence "finite_profile A p \<and> finite_pair_vectors A vs
    \<longrightarrow> defer (m \<triangleright> n) A p vs \<subseteq> defer m A p vs"
    using seq_comp_def_set_bounded
    by metis
  moreover have profile_p: "lifted A p q a \<longrightarrow> finite_profile A p"
    unfolding lifted_def
    by simp
 ultimately have defer_subset: "defer (m \<triangleright> n) A p vs \<subseteq> defer m A p vs"
    using def_and_lifted f_vec
    by blast
  hence mono_m: "m A p vs = m A q vs"
    using monotone_m defer_lift_invariance_def def_and_lifted
          modules profile_p seq_comp_def_set_trans f_vec
    by metis
  hence new_A_eq: "?new_Ap = ?new_Aq"
    by presburger
  have defer_eq:
    "defer (m \<triangleright> n) A p vs = defer n ?new_Ap ?new_p ?new_vsp"
    using sequential_composition.simps snd_conv
    by metis
  hence mono_n:
    "n ?new_Ap ?new_p ?new_vsp = n ?new_Aq ?new_q ?new_vsq"
  proof cases
    have m0: "finite (defer m A p vs)"
      by (metis def_and_lifted defer_in_alts f_vec modules profile_p rev_finite_subset)
    have m1: "vector_pair ?new_Ap ?new_vsp"
      using f_vec vector_pair_def profile_p def_and_lifted defer_in_alts
      by (smt (verit, ccfv_SIG) limit_pair_vectors_sound modules)

    have m2: "finite_pair_vectors ?new_Ap ?new_vsp" using m0 m1 by simp

    assume "lifted ?new_Ap ?new_p ?new_q a"
    thus ?thesis
      using defer_eq mono_m monotone_n
            defer_lift_invariance_def def_and_lifted m2 (*f_vec lifted_finite_vectors*)
      by (metis (no_types, lifting))
  next
    assume a2: "\<not>lifted ?new_Ap ?new_p ?new_q a"
    from def_and_lifted
    have "finite_profile A q"
      by (simp add: lifted_def)
    with modules new_A_eq
    have 1:
      "finite_profile ?new_Ap ?new_q"
      using def_presv_fin_prof f_vec
      by (metis)
    moreover from modules profile_p def_and_lifted
    have 0:
      "finite_profile ?new_Ap ?new_p"
      using def_presv_fin_prof
      by (metis def_and_lifted f_vec profile_p)
    moreover from defer_subset def_and_lifted
    have 2: "a \<in> ?new_Ap"
      by blast
    moreover from def_and_lifted
    have eql_lengths:
      "length ?new_p = length ?new_q"
      by (simp add: lifted_def)
    ultimately have 0:
      "(\<forall>i::nat. i < length ?new_p \<longrightarrow>
          \<not>Preference_Relation.lifted ?new_Ap (?new_p!i) (?new_q!i) a) \<or>
       (\<exists>i::nat. i < length ?new_p \<and>
          \<not>Preference_Relation.lifted ?new_Ap (?new_p!i) (?new_q!i) a \<and>
              (?new_p!i) \<noteq> (?new_q!i))"
      using a2 lifted_def
      by (metis (no_types, lifting))
    from def_and_lifted modules have
      "\<forall>i. (0 \<le> i \<and> i < length ?new_p) \<longrightarrow>
          (Preference_Relation.lifted A (p!i) (q!i) a \<or> (p!i) = (q!i))"
      using defer_in_alts Profile.lifted_def limit_prof_presv_size f_vec
      by metis
    with def_and_lifted modules mono_m have
      "\<forall>i. (0 \<le> i \<and> i < length ?new_p) \<longrightarrow>
          (Preference_Relation.lifted ?new_Ap (?new_p!i) (?new_q!i) a \<or>
           (?new_p!i) = (?new_q!i))"
      using limit_lifted_imp_eq_or_lifted defer_in_alts
            Profile.lifted_def limit_prof_presv_size
            limit_profile.simps nth_map f_vec
      by (metis (no_types, lifting))
    with 0 eql_lengths mono_m
    show ?thesis
      using leI not_less_zero nth_equalityI
      by metis
  qed
  from mono_m mono_n
  show ?thesis
    using sequential_composition.simps
    by (metis (full_types))
qed

(*Sequential composition preserves the property defer-lift-invariance.*)
theorem seq_comp_presv_def_lift_inv[simp]:
  assumes
    monotone_m: "defer_lift_invariance m" and
    monotone_n: "defer_lift_invariance n"
  shows "defer_lift_invariance (m \<triangleright> n)"
  using monotone_m monotone_n def_lift_inv_seq_comp_help
        seq_comp_sound defer_lift_invariance_def
  by (smt (z3))

(*
   Composing a non-blocking, non-electing electoral module
   in sequence with an electoral module that defers exactly
   one alternative results in an electoral module that defers
   exactly one alternative.
*)
theorem seq_comp_def_one[simp]:
  assumes
    non_blocking_m: "non_blocking m" and
    non_electing_m: "non_electing m" and
    def_1_n: "defers 1 n"
  shows "defers 1 (m \<triangleright> n)"
  unfolding defers_def
proof (safe)
  have electoral_mod_m: "electoral_module m"
    using non_electing_m
    by (simp add: non_electing_def)
  have electoral_mod_n: "electoral_module n"
    using def_1_n
    by (simp add: defers_def)
  show "electoral_module (m \<triangleright> n)"
    using electoral_mod_m electoral_mod_n
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs :: "'a Pair_Vectors"
  assume
    pos_card: "1 \<le> card A" and
    fin_A: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs"
  from pos_card have
    "A \<noteq> {}"
    by auto
  with fin_A prof_A vec_A have m_non_blocking:
    "reject m A p vs \<noteq> A"
    using non_blocking_m non_blocking_def
    by metis
  hence
    "\<exists>a. a \<in> A \<and> a \<notin> reject m A p vs"
    using pos_card non_electing_def non_electing_m
          reject_in_alts subset_antisym subset_iff
          fin_A prof_A vec_A subsetI
    by metis
  hence "defer m A p vs \<noteq> {}"
    using electoral_mod_defer_elem empty_iff pos_card
          non_electing_def non_electing_m fin_A prof_A vec_A
    by (metis (no_types))
  hence defer_non_empty:
    "card (defer m A p vs) \<ge> 1"
    using One_nat_def Suc_leI card_gt_0_iff pos_card fin_A prof_A vec_A
          non_blocking_def non_blocking_m def_presv_fin_prof
    by metis
  have defer_fun:
    "defer (m \<triangleright> n) A p vs =
      defer n (defer m A p vs) (limit_profile (defer m A p vs) p)
      (limit_pair_vectors (defer m A p vs) vs)"
    using def_1_n defers_def fin_A non_blocking_def non_blocking_m
          prof_A vec_A seq_comp_defers_def_set
    by (metis (no_types, hide_lams))
  have
    "\<forall>n f. defers n f =
      (electoral_module f \<and>
        (\<forall>A prof vs.
          (\<not> n \<le> card (A::'a set) \<or> infinite A \<or>
            \<not> profile A prof \<or> \<not> vector_pair A vs) \<or>
          card (defer f A prof vs) = n))"
    using defers_def
    by blast
  hence
    "card (defer n (defer m A p vs)
      (limit_profile (defer m A p vs) p)
      (limit_pair_vectors (defer m A p vs) vs)) = 1"
    using defer_non_empty def_1_n
          fin_A prof_A vec_A non_blocking_def
          non_blocking_m def_presv_fin_prof def_presv_fin_vector_pair
    by metis
  thus "card (defer (m \<triangleright> n) A p vs) = 1"
    using defer_fun
    by auto
qed

(*
   Sequentially composing electoral modules after compatible
   electoral modules does not break their compatibility.
*)
theorem disj_compat_seq[simp]:
  assumes
    compatible: "disjoint_compatibility m n" and
    module_m2: "electoral_module m2"
  shows "disjoint_compatibility (m \<triangleright> m2) n"
  unfolding disjoint_compatibility_def
proof (safe)
  show "electoral_module (m \<triangleright> m2)"
    using compatible disjoint_compatibility_def
          module_m2 seq_comp_sound
  proof -
    have "electoral_module m"
      using compatible disjoint_compatibility_def by blast
    then show ?thesis
      by (meson module_m2 seq_comp_sound)
  qed
next
  show "electoral_module n"
    using compatible disjoint_compatibility_def by blast
next
  fix
    S :: "'a set" (*and
    vs :: "'a Pair_Vectors"*)
  assume
    fin_S: "finite S" (*and
    vec_A: "vector_pair S vs"*)
  have modules:
    "electoral_module (m \<triangleright> m2) \<and> electoral_module n"
    using compatible disjoint_compatibility_def
          module_m2 seq_comp_sound
    by auto

 obtain A where A:
    "A \<subseteq> S \<and>
      (\<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))"
    using compatible disjoint_compatibility_def fin_S (*vec_A*)
    by (metis (no_types, lifting))
  show "\<exists>A\<subseteq>S.
          (\<forall>a\<in>A. indep_of_alt (m \<triangleright> m2) S a \<and>
            (\<forall>p vs. finite_profile S p \<and> vector_pair S vs \<longrightarrow> a \<in> reject (m \<triangleright> m2) 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)) "
    (*"\<exists>A \<subseteq> S.
      (\<forall>a \<in> A. indep_of_alt (m \<triangleright> m2) S a \<and>
        (\<forall>p vs. finite_profile S p \<and> finite_pair_vectors S vs
        \<longrightarrow> a \<in> reject (m \<triangleright> m2) S p vs)) \<and>
      (\<forall>a \<in> S-A. indep_of_alt n S a \<and>
        (\<forall>p vs. finite_profile S p \<and> finite_pair_vectors S vs
        \<longrightarrow> a \<in> reject n S p vs))"*)
  proof
    (*have
      "\<forall>a p q.
        a \<in> A \<and> equiv_prof_except_a S p q a \<and>
      finite_pair_vectors S p vs \<and> finite_pair_vectors S q vs \<longrightarrow>
          (m \<triangleright> m2) S p vs = (m \<triangleright> m2) S q vs"*)
     have t0:
      "\<forall>a \<in> A. \<forall>p vs. finite_profile S p \<and> vector_pair S vs \<longrightarrow> a \<in> reject (m \<triangleright> m2) S p vs"
      using A UnI1 prod.sel sequential_composition.simps
      by metis
    have
      "\<forall>a p q vs.
        a \<in> A \<and> equiv_prof_except_a S p q a \<and> finite_pair_vectors S vs\<longrightarrow>
          (m \<triangleright> m2) S p vs = (m \<triangleright> m2) S q vs"
    proof (safe)
      fix
        a :: "'a" and
        p :: "'a Profile" and
        q :: "'a Profile" and
        vs :: "'a Pair_Vectors"
      assume
        a: "a \<in> A" and
        b: "equiv_prof_except_a S p q a" and
        c1: "finite S" and
        c2: "vector_pair S vs"
      have c: "finite_pair_vectors S vs" using c1 c2 by simp
      have eq_def:
        "defer m S p vs = defer m S q vs"
        using A a b c indep_of_alt_def
        by metis
      from a b have profiles:
        "finite_profile S p \<and> finite_profile S q"
        using equiv_prof_except_a_def
        by fastforce
      hence "(defer m S p vs) \<subseteq> S"
        using compatible defer_in_alts disjoint_compatibility_def c by blast
      hence
        "limit_profile (defer m S p vs) p =
          limit_profile (defer m S q vs) q"
        using A DiffD2 a b compatible defer_not_elec_or_rej
              disjoint_compatibility_def eq_def profiles
              negl_diff_imp_eq_limit_prof c
        by (metis (no_types, lifting))
      with eq_def have 0:
        "m2 (defer m S p vs) (limit_profile (defer m S p vs) p)
          (limit_pair_vectors (defer m S p vs) vs) =
          m2 (defer m S q vs) (limit_profile (defer m S q vs) q)
      (limit_pair_vectors (defer m S q vs) vs)"
        by simp
      moreover have "m S p vs = m S q vs"
        using A a b indep_of_alt_def c
        by metis
      ultimately have "(m \<triangleright> m2) S p vs = (m \<triangleright> m2) S q vs"
        using sequential_composition.simps c
        by (metis (full_types))
      then show
        "(m \<triangleright> m2) S p vs = (m \<triangleright> m2) S q vs"
        using c
        by (metis (full_types))
    qed
    then have "(\<forall>a \<in> A. indep_of_alt (m \<triangleright> m2) S a)"
      using modules indep_of_alt_def unfolding indep_of_alt_def
      by blast
     (*have "A \<subseteq> S \<and> (\<forall>a \<in> A. electoral_module (m \<triangleright> m2) \<and> (\<forall>p q vs. equiv_prof_except_a A p q a
      \<longrightarrow> (m \<triangleright> m2) A p vs = (m \<triangleright> m2) A q vs))" sorry*)
    then show
      "A \<subseteq> S \<and>
        (\<forall>a \<in> A. indep_of_alt (m \<triangleright> m2) S a \<and>
          (\<forall>p vs. finite_profile S p \<and> vector_pair S vs \<longrightarrow> a \<in> reject (m \<triangleright> m2) 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))"
      using A indep_of_alt_def modules compatible fin_S  disjoint_compatibility_def t0 by auto
      (*by (metis (mono_tags, lifting))*)
  qed
qed

(*
   Composing a defer-lift invariant and a non-electing
   electoral module that defers exactly one alternative
   in sequence with an electing electoral module
   results in a monotone electoral module.
*)
theorem seq_comp_mono[simp]:
  assumes
    def_monotone_m: "defer_lift_invariance m" and
    non_ele_m: "non_electing m" and
    def_one_m: "defers 1 m" and
    electing_n: "electing n"
  shows "monotonicity (m \<triangleright> n)"
  unfolding monotonicity_def
proof (safe)
  have electoral_mod_m: "electoral_module m"
    using non_ele_m
    by (simp add: non_electing_def)
  have electoral_mod_n: "electoral_module n"
    using electing_n
    by (simp add: electing_def)
  show "electoral_module (m \<triangleright> n)"
    using electoral_mod_m electoral_mod_n
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    q :: "'a Profile" and
    vs :: "'a Pair_Vectors" and
    w :: "'a"
  assume
    fin_A: "finite A" and
    elect_w_in_p: "w \<in> elect (m \<triangleright> n) A p vs" and
    lifted_w: "Profile.lifted A p q w" and
    vec_f: "vector_pair A vs"

  have
    "finite_profile A p \<and> finite_profile A q"
    using lifted_w lifted_def
    by metis
  thus "w \<in> elect (m \<triangleright> n) A q vs"
    using seq_comp_def_then_elect defer_lift_invariance_def
          elect_w_in_p lifted_w def_monotone_m non_ele_m
          def_one_m electing_n vec_f
    by (smt (verit, del_insts))
    (*by metis *)
qed

(*
   Composing a defer-invariant-monotone electoral module in sequence before
   a non-electing, defer-monotone electoral module that defers exactly
   1 alternative results in a defer-lift-invariant electoral module.
*)
theorem def_inv_mono_imp_def_lift_inv[simp]:
  assumes
    strong_def_mon_m: "defer_invariant_monotonicity m" and
    non_electing_n: "non_electing n" and
    defers_1: "defers 1 n" and
    defer_monotone_n: "defer_monotonicity n"
  shows "defer_lift_invariance (m \<triangleright> n)"
  unfolding defer_lift_invariance_def
proof (safe)
  have electoral_mod_m: "electoral_module m"
    using defer_invariant_monotonicity_def
          strong_def_mon_m
    by auto
  have electoral_mod_n: "electoral_module n"
    using defers_1 defers_def
    by auto
  show "electoral_module (m \<triangleright> n)"
    using electoral_mod_m electoral_mod_n
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    q :: "'a Profile" and
    vs :: "'a Pair_Vectors" and
    a :: "'a"
  assume
  defer_a_p: "a \<in> defer (m \<triangleright> n) A p vs" and
  lifted_a: "Profile.lifted A p q a" and
  vec_A: "vector_pair A vs"
  from strong_def_mon_m
  have non_electing_m: "non_electing m"
    by (simp add: defer_invariant_monotonicity_def)
  have electoral_mod_m: "electoral_module m"
    using strong_def_mon_m defer_invariant_monotonicity_def
    by auto
  have electoral_mod_n: "electoral_module n"
    using defers_1 defers_def
    by auto
  have finite_profile_q: "finite_profile A q"
    using lifted_a
    by (simp add: Profile.lifted_def)
  have finite_profile_p: "profile A p"
    using lifted_a
    by (simp add: Profile.lifted_def)
  show "(m \<triangleright> n) A p vs = (m \<triangleright> n) A q vs"
  proof cases
    assume not_unchanged: "defer m A q vs \<noteq> defer m A p vs"
    from not_unchanged
    have a_single_defer: "{a} = defer m A q vs"
      using strong_def_mon_m electoral_mod_n defer_a_p
            defer_invariant_monotonicity_def lifted_a
            seq_comp_def_set_trans finite_profile_p
            finite_profile_q vec_A
      by metis
    moreover have
      "{a} = defer m A q vs \<longrightarrow> defer (m \<triangleright> n) A q vs \<subseteq> {a}"
      using finite_profile_q electoral_mod_m electoral_mod_n
            seq_comp_def_set_sound vec_A
      by (metis)
    ultimately have
      "(a \<in> defer m A p vs) \<longrightarrow> defer (m \<triangleright> n) A q vs \<subseteq> {a}"
      by blast (* lifted defer-subset of a *)
    moreover have def_card_one:
      "(a \<in> defer m A p vs) \<longrightarrow> card (defer (m \<triangleright> n) A q vs) = 1"
      using One_nat_def a_single_defer card_eq_0_iff
            card_insert_disjoint defers_1 defers_def
            electoral_mod_m empty_iff finite.emptyI
            seq_comp_defers_def_set order_refl
            def_presv_fin_prof finite_profile_q vec_A
            def_presv_fin_vector_pair
      by (smt (verit))
    moreover have defer_a_in_m_p:
      "a \<in> defer m A p vs"
      using electoral_mod_m electoral_mod_n defer_a_p
            seq_comp_def_set_bounded finite_profile_p
            finite_profile_q
      by (metis (no_types, lifting) insert_Diff insert_subset vec_A)
    ultimately have
      "defer (m \<triangleright> n) A q vs = {a}" (* lifted defer set = a *)
      using Collect_mem_eq card_1_singletonE empty_Collect_eq
            insertCI subset_singletonD
      by metis
    moreover have
      "defer (m \<triangleright> n) A p vs = {a}" (* regular defer set = a *)
    proof (safe)
      fix x :: "'a"
      assume
      defer_x: "x \<in> defer (m \<triangleright> n) A p vs" and
      x_exists: "x \<notin> {}"
      show "x = a"
      proof -
        have fin_defer:
          "\<forall>f (A::'a set) prof vs.
            (electoral_module f \<and> finite A \<and> profile A prof \<and> vector_pair A vs) \<longrightarrow>
              finite_profile (defer f A prof vs)
                (limit_profile (defer f A prof vs) prof)"
          using def_presv_fin_prof
          by (metis (no_types))
        have "finite_profile (defer m A p vs) (limit_profile (defer m A p vs) p)"
          using electoral_mod_m finite_profile_p finite_profile_q fin_defer vec_A
          by blast
        hence "Suc (card (defer m A p vs - {a})) = card (defer m A p vs)"
          using card_Suc_Diff1 defer_a_in_m_p
          by metis
        hence min_card:
          "Suc 0 \<le> card (defer m A p vs)"
          by linarith
        have emod_n_then_mn:
          "electoral_module n \<longrightarrow> electoral_module (m \<triangleright> n)"
          using electoral_mod_m
          by simp
        have "defers (Suc 0) n"
          using defers_1
          by auto
        hence defer_card_one:
          "electoral_module n \<and>
            (\<forall>A prof vs.
              (Suc 0 \<le> card A \<and> finite A \<and> profile A prof \<and> finite_pair_vectors A vs) \<longrightarrow>
                card (defer n A prof vs) = Suc 0)"
          by (simp add: defers_def)
        hence emod_mn: "electoral_module (m \<triangleright> n)"
          using emod_n_then_mn
          by blast
        have nat_diff:
          "\<forall> (i::nat) j. i \<le> j \<longrightarrow> i - j = 0"
          by auto
        have nat_comp:
          "\<forall> (i::nat) j k.
            i \<le> j \<and> j \<le> k \<or>
              j \<le> i \<and> i \<le> k \<or>
              i \<le> k \<and> k \<le> j \<or>
              k \<le> j \<and> j \<le> i \<or>
              j \<le> k \<and> k \<le> i \<or>
              k \<le> i \<and> i \<le> j"
          using le_cases3
          by linarith
        have fin_diff_card:
          "\<forall>A a.
            (finite A \<and> (a::'a) \<in> A) \<longrightarrow>
              card (A - {a}) = card A - 1"
          using card_Diff_singleton
          by metis
        have m1:"vector_pair A vs \<Longrightarrow> Profile.lifted A p q a \<Longrightarrow> finite_pair_vectors A vs"
          by (simp add: finite_profile_q)
        have fin_vec_defer:
          "\<forall>f (A::'a set) prof vs.
            (electoral_module f \<and> finite A \<and> profile A prof \<and> vector_pair A vs) \<longrightarrow>
              finite_pair_vectors (defer f A prof vs) (limit_pair_vectors (defer f A prof vs) vs)"
          using def_presv_fin_vector_pair
          by (metis (no_types))
        with fin_defer defer_card_one min_card
         have "card (defer (m \<triangleright> n) A p vs) = Suc 0"
          using electoral_mod_m seq_comp_defers_def_set electoral_mod_n
                finite_profile_p finite_profile_q m1 fin_vec_defer vec_A
          by metis
        with fin_diff_card nat_comp nat_diff emod_mn fin_defer
        have "{a} = {x}"
          using One_nat_def card_1_singletonE singletonD
                defer_a_p defer_x
          by metis
        thus ?thesis
          by force
      qed
    next
      show "a \<in> defer (m \<triangleright> n) A p vs"
        using defer_a_p
        by linarith
    qed
    ultimately have (* defer sets equal *)
      mm3: "defer (m \<triangleright> n) A p vs = defer (m \<triangleright> n) A q vs"
      by blast
    moreover have (* elect sets sets equal *)
      "elect (m \<triangleright> n) A p vs = elect (m \<triangleright> n) A q vs"
      using finite_profile_p finite_profile_q
            non_electing_m non_electing_n
            seq_comp_presv_non_electing
            non_electing_def vec_A lifted_a
            finite_profile_q
      by metis (* elect sets equal *)
    thus ?thesis (*(m \<triangleright> n) A p vs = (m \<triangleright> n) A q vs*)
        proof -
      have f1: "electoral_module (m \<triangleright> n)"
        by (meson electoral_mod_m electoral_mod_n seq_comp_sound)
      have "vector_pair A vs"
        by (meson finite_profile_q lifted_a vec_A)
      then show ?thesis
        using f1 \<open>elect (m \<triangleright> n) A p vs = elect (m \<triangleright> n) A q vs\<close>
          eq_def_and_elect_imp_eq finite_profile_p finite_profile_q mm3 vec_A by blast
    qed
  next
    assume not_different_alternatives:
      "\<not>(defer m A q vs \<noteq> defer m A p vs)"
    have "elect m A p vs = {}"
      using non_electing_m finite_profile_p finite_profile_q vec_A
      by (simp add: non_electing_def)
    moreover have "elect m A q vs = {}"
      using non_electing_m finite_profile_q finite_profile_p lifted_a vec_A non_electing_def
       finite_profile_q by metis
    ultimately have elect_m_equal:
      "elect m A p vs = elect m A q vs"
      by simp (* m elects the same stuff *)
    from not_different_alternatives
    have same_alternatives: "defer m A q vs = defer m A p vs"
      by simp
    hence
      "(limit_profile (defer m A p vs) p) =
        (limit_profile (defer m A p vs) q) \<or>
          lifted (defer m A q vs)
            (limit_profile (defer m A p vs) p)
              (limit_profile (defer m A p vs) q) a"
      using defer_in_alts electoral_mod_m
            lifted_a finite_profile_q
            limit_prof_eq_or_lifted vec_A
      by metis
    thus ?thesis
    proof
      assume
        "limit_profile (defer m A p vs) p =
          limit_profile (defer m A p vs) q"
      hence same_profile:
        "limit_profile (defer m A p vs) p =
          limit_profile (defer m A q vs) q"
        using same_alternatives
        by simp
      hence results_equal_n:
        "n (defer m A q vs) (limit_profile (defer m A q vs) q) =
          n (defer m A p vs) (limit_profile (defer m A p vs) p)"
        by (simp add: same_alternatives)
      moreover have results_equal_m: "m A p vs = m A q vs"
        using elect_m_equal same_alternatives
              finite_profile_p finite_profile_q vec_A lifted_a
        by (simp add: electoral_mod_m eq_def_and_elect_imp_eq)
      hence "(m \<triangleright> n) A p vs = (m \<triangleright> n) A q vs"
        using same_profile
        by auto
      thus ?thesis
        by blast
    next
      assume still_lifted:
        "lifted (defer m A q vs) (limit_profile (defer m A p vs) p)
          (limit_profile (defer m A p vs) q) a"
      hence a_in_def_p:
        "a \<in> defer n (defer m A p vs)
          (limit_profile (defer m A p vs) p) (limit_pair_vectors (defer m A p vs) vs)"
        using electoral_mod_m electoral_mod_n
              finite_profile_p defer_a_p
              seq_comp_def_set_trans
              finite_profile_q vec_A
        by metis
      hence a_still_deferred_p:
        "{a} \<subseteq> defer n (defer m A p vs)
          (limit_profile (defer m A p vs) p) (limit_pair_vectors (defer m A p vs) vs)"
        by simp
      have card_le_1_p: "card (defer m A p vs) \<ge> 1"
        using One_nat_def Suc_leI card_gt_0_iff
              electoral_mod_m electoral_mod_n
              equals0D finite_profile_p defer_a_p
              seq_comp_def_set_trans def_presv_fin_prof
              finite_profile_q vec_A
        by metis
      hence
        "card (defer n (defer m A p vs)
          (limit_profile (defer m A p vs) p) (limit_pair_vectors (defer m A p vs) vs)) = 1"
        using defers_1 defers_def electoral_mod_m
              finite_profile_p def_presv_fin_prof
              finite_profile_q vec_A lifted_a def_presv_fin_vector_pair
        by metis
      hence def_set_is_a_p:
        "{a} = defer n (defer m A p vs) (limit_profile (defer m A p vs) p)
          (limit_pair_vectors (defer m A p vs) vs)"
        using a_still_deferred_p card_1_singletonE
              insert_subset singletonD
        by metis
      have a_still_deferred_q:
        "a \<in> defer n (defer m A q vs)
          (limit_profile (defer m A p vs) q) (limit_pair_vectors (defer m A p vs) vs)"
        using still_lifted a_in_def_p
              defer_monotonicity_def
              defer_monotone_n electoral_mod_m
              same_alternatives
              def_presv_fin_prof finite_profile_q finite_profile_p
              def_presv_fin_vector_pair vec_A
        by metis
      have "card (defer m A q vs) \<ge> 1"
        using card_le_1_p same_alternatives
        by auto
      hence
        "card (defer n (defer m A q vs)
          (limit_profile (defer m A q vs) q) (limit_pair_vectors (defer m A q vs) vs)) = 1"
        using defers_1 defers_def electoral_mod_m
              finite_profile_q def_presv_fin_prof vec_A lifted_a def_presv_fin_vector_pair
        by metis
      hence def_set_is_a_q:
        "{a} =
          defer n (defer m A q vs)
            (limit_profile (defer m A q vs) q) (limit_pair_vectors (defer m A q vs) vs)"
        using a_still_deferred_q card_1_singletonE
              same_alternatives singletonD
        by metis
      have
        "defer n (defer m A p vs)
          (limit_profile (defer m A p vs) p) (limit_pair_vectors (defer m A p vs) vs)=
            defer n (defer m A q vs)
              (limit_profile (defer m A q vs) q) (limit_pair_vectors (defer m A q vs) vs)"
        using def_set_is_a_q def_set_is_a_p
        by auto
      thus ?thesis
        using seq_comp_presv_non_electing
              eq_def_and_elect_imp_eq non_electing_def
              finite_profile_p finite_profile_q
              non_electing_m non_electing_n
              seq_comp_defers_def_set vec_A lifted_a
        by metis
    qed
  qed
qed

end


theory addMul

imports Main
        "../Naturals"

begin

(*hipster add mul*)

lemma l01 [thy_expl] : "mul x Z = Z"
by hipster_induct_simp_metis

lemma l02 [thy_expl] : "add x Z = x"
by hipster_induct_simp_metis

lemma l03 [thy_expl] : "add (add x y) z = add x (add y z)"
by hipster_induct_simp_metis
(* by (tactic {* Simp_Tacs.routine_tac @{context} *}) *)

lemma l04 [thy_expl] : "add x (S y) = S (add x y)"
by hipster_induct_simp_metis

lemma l05 [thy_expl] : "add x (add y x) = add y (add x x)"
by hipster_induct_simp_metis

lemma l06 [thy_expl] : "add x (add y y) = add y (add y x)"
by hipster_induct_simp_metis

lemma l07 [thy_expl] : "add x (S y) = S (add y x)"
by hipster_induct_simp_metis

lemma l08' [thy_expl] : "add (mul x y) x = mul x (S y)"
by (hipster_induct_simp_metis l03 l04)

(*lemma l08 [thy_expl] : "add (mul x y) x = mul x (S y)"
(*apply (hipster_induct_schemes add.simps mul.simps l07 l03 l04)*)
(*apply (tactic {* Hipster_Explore.explore_goal @{context} ["Naturals.add", "Naturals.mul"] *})*)
sorry (*by (hipster_induct_schemes add.simps mul.simps l07 l03 l04)*)*)

lemma t01 : "add (add x y) x = add x (add x y)"
by hipster_induct_simp_metis

lemma t02 : "add (add x y) y = add x (add y y)"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma l09 [thy_expl] : "mul (add x x) y = mul x (add y y)"
by hipster_induct_simp_metis

lemma l10 [thy_expl] : "mul (add x x) y = mul y (add x x)"
by hipster_induct_simp_metis

lemma l11 [thy_expl] : "add (mul x x) y = add y (mul x x)"
by hipster_induct_simp_metis

lemma t03 : "add (add x x) y = add x (add x y)"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma t04 : "add (add x x) y = add y (add x x)"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma l12 [thy_expl] : "add (S x) y = S (add y x)"
by hipster_induct_simp_metis

lemma t05  : "add x (mul x x) = mul x (S x)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)  (* follows from the incomplete one *)

lemma t06 : "add x (S x) = S (add x x)"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma t07 : "mul (mul x x) x = mul x (mul x x)"
by hipster_induct_simp_metis

lemma t07b : "mul (add x x) x = mul x (add x x)"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma t08 : "mul (S x) x = mul x (S x)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t09 : "add (mul x x) x = mul x (S x)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t10 : "add (add x x) x = add x (add x x)"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma l13 [thy_expl] : "add (mul x y) (mul x z) = mul x (add y z)"
by hipster_induct_simp_metis

lemma l14 [thy_expl] : "add (mul x y) (mul y z) = mul y (add x z)"
by hipster_induct_simp_metis

lemma l15 [thy_expl] : "add (mul x y) (mul x z) = mul x (add z y)"
by hipster_induct_simp_metis

lemma t11 : "add (mul x y) (mul z y) = mul y (add x z)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t12 : "add (mul x y) (mul z x) = mul x (add z y)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t13 : "add (mul x y) (mul z y) = mul y (add z x)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t14 : "add (add x y) (mul x z) = add (mul x z) (add x y)"
by hipster_induct_simp_metis

lemma t15 : "add (add x y) (mul y z) = add (mul y z) (add x y)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t16 : "add (add x y) (mul z y) = add (mul z y) (add x y)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t17 : "add (add x y) (add x z) = add (add x z) (add x y)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t18 : "add (add x y) (add z y) = add (add x z) (add y y)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t19 : "add (add x y) (add z z) = add (add x z) (add z y)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t20 : "add (add x y) (S z) = add (add x z) (S y)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t21 : "add (add x y) (mul z x) = add (mul z x) (add x y)"
by hipster_induct_simp_metis

lemma t22 : "add (add x y) (add z x) = add (add z x) (add x y)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t23 : "add (add x y) (add z y) = add (add z x) (add y y)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t24 : "add (add x y) (add z z) = add (add z x) (add z y)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t25 : "add (add x y) (S z) = add (add z x) (S y)"
by hipster_induct_simp_metis

lemma t26 : "mul (mul x x) (add y z) = mul (add y z) (mul x x)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t27 : "mul (mul x x) (mul y z) = mul (mul y z) (mul x x)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma l16 : "mul (add x x) (add y z) = mul (add y z) (add x x)"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma t28 : "mul (add x x) (mul y z) = mul (mul y z) (add x x)"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma t29 : "mul (S x) (mul y z) = mul (mul y z) (S x)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t30 : "mul (S x) (add y z) = mul (add y z) (S x)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t31 : "add (mul x x) (mul y z) = add (mul y z) (mul x x)"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma t32 : "add (mul x x) (add y z) = add (add y z) (mul x x)"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma t33 : "add (add x x) (mul y z) = add (mul y z) (add x x)"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma t34 : "add (add x x) (add y z) = add (add x y) (add x z)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t35 : "add (add x x) (add y z) = add (add y x) (add x z)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t36 : "add (add x x) (add y z) = add (add y z) (add x x)"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma t37 : "add (S x) (mul y z) = add (mul y z) (S x)"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma t38 : "add (S x) (add y z) = add (add x y) (S z)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t39 : "add (S x) (add y z) = add (add y x) (S z)"
by hipster_induct_simp_metis

lemma l17 [thy_expl] : "add (S x) (add y z) = add (add y z) (S x)"
by hipster_induct_simp_metis

lemma t40 : "mul (mul x y) Z = Z"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma t41 : "mul (add x y) Z = Z"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma l18 [thy_expl]  : "mul (add x y) (mul x y) = mul (mul x y) (add x y)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t42 : "add (mul x y) Z = mul x y"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma t43 : "add (mul x y) (mul x y) = mul x (add y y)"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma t44 : "add (mul x y) (mul x x) = mul x (add x y)"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma t45 : "add (mul x y) (mul y y) = mul y (add x y)"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma t46 : "add (add x y) Z = add x y"
by (tactic \<open>Simp_Tacs.routine_tac @{context}\<close>)

lemma t47 : "add (add x y) (mul x y) = add (mul x y) (add x y)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma t48 : "mul (mul x x) (mul x y) = mul (mul x y) (mul x x)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

lemma l19 [thy_expl] : "mul (mul x x) (add x y) = mul (add x y) (mul x x)"
by (tactic \<open>Ind_Schemes_Tacs.routine_tac @{context}\<close>)

end