theory Collecting1
imports Collecting
begin

subsection "A small step semantics on annotated commands"

text{* The idea: the state is propagated through the annotated command as an
annotation @{term "{s}"}, all other annotations are @{term "{}"}. It is easy
to show that this semantics approximates the collecting semantics. *}

lemma step_preserves_le:
  "\<lbrakk> step S cs = cs; S' \<subseteq> S; cs' \<le> cs \<rbrakk> \<Longrightarrow>
   step S' cs' \<le> cs"
by (metis mono2_step)

lemma steps_empty_preserves_le: assumes "step S cs = cs"
shows "cs' \<le> cs \<Longrightarrow> (step {} ^^ n) cs' \<le> cs"
proof(induction n arbitrary: cs')
  case 0 thus ?case by simp
next
  case (Suc n) thus ?case
    using Suc.IH[OF step_preserves_le[OF assms empty_subsetI Suc.prems]]
    by(simp add:funpow_swap1)
qed

definition steps :: "state \<Rightarrow> com \<Rightarrow> nat \<Rightarrow> state set acom" where
"steps s c n = ((step {})^^n) (step {s} (annotate (\<lambda>p. {}) c))"

lemma steps_approx_fix_step: assumes "step S cs = cs" and "s:S"
shows "steps s (strip cs) n \<le> cs"
proof-
  let ?bot = "annotate (\<lambda>p. {}) (strip cs)"
  have "?bot \<le> cs" by(induction cs) auto
  from step_preserves_le[OF assms(1)_ this, of "{s}"] `s:S`
  have 1: "step {s} ?bot \<le> cs" by simp
  from steps_empty_preserves_le[OF assms(1) 1]
  show ?thesis by(simp add: steps_def)
qed

theorem steps_approx_CS: "steps s c n \<le> CS c"
by (metis CS_unfold UNIV_I steps_approx_fix_step strip_CS)

end


theory Ranking_Order
  imports
    Bipartite_Matching_LP
    Order_Relations
begin

sledgehammer_params [provers = cvc4 vampire verit e spass z3 zipperposition]

definition step :: "('a \<times> 'a) set \<Rightarrow> 'a graph \<Rightarrow> 'a graph \<Rightarrow> 'a \<Rightarrow> 'a graph" where
  "step r G M j = (
    let ns = {i. i \<notin> Vs M \<and> {i, j} \<in> G} in
      if ns \<noteq> {} \<and> j \<notin> Vs M
      then let i = min_on_rel ns r in insert {i, j} M
      else M
  )"

definition "ranking' r G M \<equiv> foldl (step r G) M"
abbreviation "ranking r G \<equiv> ranking' r G {}"

lemma step_cases'[case_names no_neighbor j_matched new_match]:
  assumes "{i. i \<notin> Vs M \<and> {i,j} \<in> G} = {} \<Longrightarrow> P"
  assumes "j \<in> Vs M \<Longrightarrow> P"
  assumes "{i. i \<notin> Vs M \<and> {i,j} \<in> G} \<noteq> {} \<Longrightarrow> j \<notin> Vs M \<Longrightarrow> P"
  shows "P"
  using assms
  by blast

lemma finite_unmatched_neighbors[intro]:
  "finite (Vs G) \<Longrightarrow> finite {i. i \<notin> Vs M \<and> {i,j} \<in> G}"
  by (rule finite_subset[of _ "Vs G"]) (auto intro: vs_member_intro)

lemma step_cases[consumes 2, case_names no_neighbor j_matched new_match]:
  fixes G M j
  defines "ns \<equiv> {i. i \<notin> Vs M \<and> {i, j} \<in> G}"
  assumes "preorder_on' {i. {i,j} \<in> G} r" and "finite (Vs G)"
  assumes "{i. i \<notin> Vs M \<and> {i, j} \<in> G} = {} \<Longrightarrow> P"
  assumes "j \<in> Vs M \<Longrightarrow> P"
  assumes
    "\<lbrakk>ns \<noteq> {}; j \<notin> Vs M; min_on_rel ns r \<in> ns;
      \<not>(\<exists>i' \<in> ns. (i', min_on_rel ns r) \<in> r \<and> (min_on_rel ns r, i') \<notin> r)\<rbrakk> \<Longrightarrow> P"
  shows "P"
proof (cases M j G rule: step_cases')
  case new_match

  have "min_on_rel ns r \<in> ns"
  proof (intro min_if_finite, goal_cases)
    case 1
    from \<open>preorder_on' {i. {i,j} \<in> G} r\<close> show ?case
      unfolding ns_def
      by (auto intro: preorder_on'_subset)
  next
    case 2
    from \<open>finite (Vs G)\<close> show ?case
      unfolding ns_def
      by blast
  next
    case 3
    from new_match show ?case
      unfolding ns_def
      by blast
  qed

  have "\<not>(\<exists>i'\<in>ns. (i', min_on_rel ns r) \<in> r \<and> (min_on_rel ns r, i') \<notin> r)"
  proof (intro min_if_finite, goal_cases)
    case 1
    from \<open>preorder_on' {i. {i,j} \<in> G} r\<close> show ?case
      unfolding ns_def
      by (auto intro: preorder_on'_subset)
  next
    case 2
    from \<open>finite (Vs G)\<close> show ?case
      unfolding ns_def
      by blast
  next
    case 3
    from new_match show ?case
      unfolding ns_def
      by blast
  qed

  with new_match \<open>min_on_rel ns r \<in> ns\<close> assms show ?thesis
    by blast
qed (use assms in \<open>blast+\<close>)

lemma ranking_Nil[simp]: "ranking' r G M [] = M"
  unfolding ranking'_def by simp

lemma ranking_Cons: "ranking' r G M (j#js) = ranking' r G (step r G M j) js"
  unfolding ranking'_def
  by simp

lemma ranking_append: "ranking' r G M (js@js') = ranking' r G (ranking' r G M js) js'"
  unfolding ranking'_def
  by simp

lemma step_insertI:
  assumes "{i. i \<notin> Vs M \<and> {i,j} \<in> G} \<noteq> {}" "j \<notin> Vs M"
  assumes "i = min_on_rel {i. i \<notin> Vs M \<and> {i,j} \<in> G} r"
  shows "step r G M j = insert {i,j} M"
  using assms
  by (simp add: step_def)

lemma step_online:
  "step r G M j = step r {e \<in> G. j \<in> e} M j"
  unfolding step_def
  by simp

lemma step_subgraph:
  assumes fin: "finite (Vs G)"
  assumes preorder: "preorder_on' {i. {i,j} \<in> G} r"
  assumes "M \<subseteq> G"
  shows "step r G M j \<subseteq> G"
  using preorder fin
  by (cases rule: step_cases[where M = M]) (use assms in \<open>simp_all add: step_def\<close>)

lemma ranking_subgraph:
  assumes "finite (Vs G)"
  assumes "\<forall>j\<in>set js. preorder_on' {i. {i,j} \<in> G} r"
  assumes "M \<subseteq> G"
  shows "ranking' r G M js \<subseteq> G"
  using assms
  by (induction js arbitrary: M)
     (auto simp: ranking_Cons dest: step_subgraph)

lemma matching_step:
  assumes fin: "finite (Vs G)"
  assumes preorder: "preorder_on' {i. {i,j} \<in> G} r"
  assumes "matching M"
  shows "matching (step r G M j)"
  using preorder fin
  by (cases rule: step_cases[where M = M])
     (use assms in \<open>auto simp: step_def intro: matching_insert\<close>)

lemma matching_ranking:
  assumes "finite (Vs G)"
  assumes "\<forall>j\<in>set js. preorder_on' {i. {i,j} \<in> G} r"
  assumes "matching M"
  shows "matching (ranking' r G M js)"
  using assms
  by (induction js arbitrary: M)
     (auto simp: ranking_Cons dest: matching_step)

lemma step_mono:
  assumes "e \<in> M"
  shows "e \<in> step r G M j"
  using assms
  by (cases M j G rule: step_cases')
     (auto simp: step_def)

lemma ranking_mono:
  assumes "e \<in> M"
  shows "e \<in> ranking' r G M js"
  using assms
  by (induction js arbitrary: M)
     (auto simp: ranking_Cons dest: step_mono)

lemma ranking_mono_vs:
  assumes "v \<in> Vs M"
  shows "v \<in> Vs (ranking' r G M js)"
  using assms
  by (auto simp: vs_member dest: ranking_mono)

lemma edge_in_step:
  assumes "e \<in> step r G M j"
  shows "e \<in> M \<or> j \<in> e"
  using assms
  by (auto simp: step_def split: if_splits)

lemma edge_in_ranking:
  assumes "e \<in> ranking' r G M js"
  shows "e \<in> M \<or> (\<exists>j \<in> set js. j \<in> e)"
  using assms
  by (induction js arbitrary: M)
     (auto dest: edge_in_step simp: ranking_Cons)

lemma edge_in_rankingE:
  assumes "e \<in> ranking' r G M js"
  obtains "e \<in> M" | j where "j \<in> set js" "j \<in> e"
  using assms
  by (auto dest: edge_in_ranking)

lemma step_matches_if_possible:
  assumes "j \<notin> Vs M"
  assumes "{i,j} \<in> G"
  assumes "i \<notin> Vs M"
  shows "j \<in> Vs (step r G M j)"
  using assms
  by (cases M j G rule: step_cases')
     (auto simp: step_def vs_insert)

context bipartite_matching_lp
begin

lemma finite_vs_subgraph: "H \<subseteq> G \<Longrightarrow> finite (Vs H)"
  using finite_vs
  by (auto intro: finite_subset dest: Vs_subset)

lemma finite_subsets: "finite {M. M \<subseteq> G}"
  using finite_graph by blast

lemma neighbors_right_subset_left: "H \<subseteq> G \<Longrightarrow> j \<in> R \<Longrightarrow> {i. {i,j} \<in> H} \<subseteq> L"
  using bipartite_graph
  by (auto dest: bipartite_edgeD)

lemma neighbors_right_subset_left_remove_vertices: "j \<in> R \<Longrightarrow> {i. {i,j} \<in> G \<setminus> X} \<subseteq> L - X"
  by (auto dest: neighbors_right_subset_left[OF remove_vertices_subgraph] edges_are_Vs intro: remove_vertices_not_vs')

lemma preorder_on_neighborsI[intro]:
  assumes "H \<subseteq> G"
  assumes "preorder_on L r"
  assumes "j \<in> R"
  shows "preorder_on' {i. {i,j} \<in> H} r"
  using assms
  by (auto dest: preorder_on_imp_preorder_on' neighbors_right_subset_left intro: preorder_on'_subset)

lemma preorder_on_neighborsI_remove_vertices[intro]:
  assumes "preorder_on (L - X) r"
  assumes "j \<in> R"
  shows "preorder_on' {i. {i,j} \<in> G \<setminus> X} r"
  using assms
  by (auto dest: preorder_on_imp_preorder_on' neighbors_right_subset_left_remove_vertices intro: preorder_on'_subset)

lemma linorder_on_neighborsI[intro]:
  assumes "H \<subseteq> G"
  assumes "linorder_on L r"
  assumes "j \<in> R"
  shows "linorder_on' {i. {i,j} \<in> H} r"
  using assms
  by (auto dest: linorder_on_imp_linorder_on' neighbors_right_subset_left intro: linorder_on'_subset)

lemma linorder_on_neighborsI_remove_vertices[intro]:
  assumes "linorder_on (L - X) r"
  assumes "j \<in> R"
  shows "linorder_on' {i. {i,j} \<in> G \<setminus> X} r"
  using assms
  by (auto dest: linorder_on_imp_linorder_on' neighbors_right_subset_left_remove_vertices intro: linorder_on'_subset)

lemma finite_neighbors:
  "H \<subseteq> G \<Longrightarrow> finite {i. {i,j} \<in> H}"
  by (rule finite_subset[of _ "Vs G"])
     (auto simp: graph intro: vs_member_intro)

lemma finite_unmatched_neighbors:
  "H \<subseteq> G \<Longrightarrow> finite {i. i \<notin> Vs M \<and> {i,j} \<in> H}"
  by (rule finite_subset[of _ "Vs G"])
     (auto simp: graph intro: vs_member_intro)

lemma unmatched_neighbors_L:
  assumes "H \<subseteq> G"
  assumes "j \<in> R"
  shows "{i. i \<notin> Vs M \<and> {i,j} \<in> H} \<subseteq> L"
  using assms bipartite_graph
  by (auto dest: bipartite_edgeD)

lemma min_in_L:
  assumes "H \<subseteq> G"
  assumes "preorder_on' {i. {i,j} \<in> H} r"
  assumes "j \<in> R"
  assumes "i \<notin> Vs M" "{i,j} \<in> H"
  shows "min_on_rel {i. i \<notin> Vs M \<and> {i, j} \<in> H} r \<in> L" (is "min_on_rel ?S r \<in> L")
proof -
  from assms have "min_on_rel ?S r \<in> ?S"
    by (intro min_if_finite finite_unmatched_neighbors)
       (auto intro: preorder_on'_subset)

  with \<open>H \<subseteq> G\<close> \<open>j \<in> R\<close> bipartite_graph show ?thesis
    by (auto dest: bipartite_edgeD bipartite_subgraph)
qed

lemma unmatched_R_in_step_if:
  assumes "H \<subseteq> G"
  assumes preorder: "preorder_on' {i. {i,j'} \<in> H} r"
  assumes "j' \<in> R" "j' \<noteq> j"
  assumes "j \<notin> L" "j \<notin> Vs M"
  shows "j \<notin> Vs (step r H M j')"
  using assms
  by (cases M j' H rule: step_cases')
     (auto simp: step_def vs_insert dest: min_in_L)

lemma unmatched_R_in_ranking_if:
  assumes "H \<subseteq> G"
  assumes "\<forall>j \<in> set js. preorder_on' {i. {i,j} \<in> H} r"
  assumes "set js \<subseteq> R"
  assumes "j \<notin> L" "j \<notin> set js"
  assumes "j \<notin> Vs M"
  shows "j \<notin> Vs (ranking' r H M js)"
  using assms
proof (induction js arbitrary: M)
  case (Cons j' js)

  then have "j \<notin> Vs (step r H M j')"
    by (intro unmatched_R_in_step_if) auto

  with Cons show ?case
    by (simp add: ranking_Cons)
qed simp

lemma bipartite_step:
  assumes subgraph: "H \<subseteq> G"
  assumes preorder: "preorder_on' {i. {i,j} \<in> H} r"
  assumes "bipartite M L R"
  assumes "j \<in> R"
  shows "bipartite (step r H M j) L R"
  using preorder finite_vs_subgraph[OF subgraph]
  by (cases rule: step_cases[where M = M])
     (use assms in \<open>auto simp: step_def intro!: bipartite_insertI dest: neighbors_right_subset_left\<close>)

lemma bipartite_ranking:
  assumes "H \<subseteq> G"
  assumes "\<forall>j\<in>set js. preorder_on' {i. {i,j} \<in> H} r"
  assumes "set js \<subseteq> R"
  assumes "bipartite M L R"
  shows "bipartite (ranking' r H M js) L R"
  using assms
  by (induction js arbitrary: M)
     (auto simp: ranking_Cons dest: bipartite_step)

lemma ranking_subgraph:
  assumes "H \<subseteq> G"
  assumes "preorder_on L r"
  assumes "set js \<subseteq> R"
  shows "ranking r H js \<subseteq> H"
  using assms graph
  by (intro ranking_subgraph)
     (auto intro: ranking_subgraph finite_vs_subgraph)

lemma ranking_subgraph':
  assumes "H \<subseteq> G"
  assumes "preorder_on L r"
  assumes "set js \<subseteq> R"
  shows "e \<in> ranking r H js \<Longrightarrow> e \<in> H"
  using assms
  by (auto dest: ranking_subgraph)

lemma the_ranking_match_left:
  assumes "H \<subseteq> G"
  assumes "\<forall>j\<in>set js. preorder_on' {i. {i,j} \<in> H} r"
  assumes "matching M"
  assumes "bipartite M L R"
  assumes j_matched: "j \<in> Vs (ranking' r H M js)"
  assumes "j \<in> R"
  assumes "set js \<subseteq> R"
  shows "{THE i. {i,j} \<in> ranking' r H M js, j} \<in> ranking' r H M js"
    "(THE i. {i,j} \<in> ranking' r H M js) \<in> L"
proof -
  from j_matched obtain e where e: "e \<in> ranking' r H M js" "j \<in> e"
    by (auto elim: vs_member_elim)

  from assms have bipartite: "bipartite (ranking' r H M js) L R"
    by (auto intro: bipartite_ranking)

  with e obtain u v where uv: "e = {u,v}" "u \<noteq> v" "u \<in> L" "v \<in> R"
    by (auto elim: bipartite_edgeE)

  with bipartite \<open>j \<in> R\<close> e have "v = j"
    by (auto intro: bipartite_eqI)

  with e uv assms have "(THE i. {i,j} \<in> ranking' r H M js) = u"
    by (intro the_match matching_ranking finite_subset[OF Vs_subset finite_vs])
        auto

  with e uv \<open>v = j\<close> show "{THE i. {i, j} \<in> ranking' r H M js, j} \<in> ranking' r H M js"
    "(THE i. {i, j} \<in> ranking' r H M js) \<in> L"
    by auto
qed

lemma step_remove_unmatched_eq:
  assumes linorder: "linorder_on L r" \<comment> \<open>required because of \<^term>\<open>Eps\<close> in \<^term>\<open>min_on_rel\<close>\<close>

  assumes "i \<in> L" "j \<in> R"
  assumes "i \<notin> Vs (step r G M j)"
  shows "step r (G \<setminus> {i}) M j = step r G M j"
proof -
  from linorder \<open>j \<in> R\<close> have "preorder_on' {i. {i,j} \<in> G} r"
    by (auto dest: linorder_on_imp_preorder_on)

  from this finite_vs
  show ?thesis
  proof (cases rule: step_cases[where M = M])
    case new_match
    let ?ns = "{i'. i' \<notin> Vs M \<and> {i',j} \<in> G}"
    and ?ns' = "{i'. i' \<notin> Vs M \<and> {i',j} \<in> G \<setminus> {i}}"

    let ?min = "min_on_rel ?ns r"
    and ?min' = "min_on_rel ?ns' r"

    from \<open>j \<in> R\<close> have "?ns \<subseteq> L" "?ns' \<subseteq> ?ns"
      by (auto dest: remove_vertices_subgraph' neighbors_right_subset_left[OF subset_refl])

    then have "?ns' \<subseteq> L"
      by blast

    from new_match have step_eq: "step r G M j = insert {?min, j} M"
      by (simp add: step_def)

    with \<open>i \<notin> Vs (step r G M j)\<close> have "?min \<noteq> i" "j \<noteq> i"
      by (auto simp: vs_insert)

    with \<open>?min \<in> ?ns\<close> have "?ns' \<noteq> {}"
      by (auto intro: in_remove_verticesI)

    have "?min' = ?min"
    proof (intro min_on_rel_linorder_eq, goal_cases)
      case 1
      from linorder \<open>?ns' \<subseteq> L\<close> show ?case
        by (auto dest: linorder_on_imp_linorder_on' intro: linorder_on'_subset)
    next
      case 2
      from \<open>?min \<in> ?ns\<close> \<open>?min \<noteq> i\<close> \<open>j \<noteq> i\<close> show ?case
        by (auto intro: in_remove_verticesI)
    next
      case 3
      from \<open>?ns' \<subseteq> ?ns\<close> \<open>preorder_on' {i. {i,j} \<in> G} r\<close> show ?case
      proof (intro ballI min_on_rel_least, goal_cases)
        case 1
        from linorder \<open>?ns \<subseteq> L\<close> show ?case
          by (auto dest: linorder_on_imp_linorder_on' intro: linorder_on'_subset)
      next
        case 2
        show ?case
          by (auto intro: finite_subset)
      next
        case 3
        from new_match show ?case by blast
      next
        case (4 y)
        with \<open>?ns' \<subseteq> ?ns\<close> show ?case
          by blast
      qed
    qed

    with \<open>j \<notin> Vs M\<close> \<open>?ns' \<noteq> {}\<close> show ?thesis
      by (subst step_eq) (simp add: step_def)
  qed (use assms in \<open>auto simp: step_def dest: remove_vertices_subgraph'\<close>)
qed

lemma ranking_remove_unmatched_eq:
  assumes linorder: "linorder_on L r"

  assumes "i \<in> L" and "set js \<subseteq> R"
  assumes "i \<notin> Vs (ranking' r G M js)"
  shows "ranking' r (G \<setminus> {i}) M js = ranking' r G M js"
  using assms
proof (induction js arbitrary: M)
  case (Cons j js)

  from Cons.prems have "step r (G \<setminus> {i}) M j = step r G M j"
    by (intro step_remove_unmatched_eq)
       (auto simp: ranking_Cons dest: ranking_mono_vs)

  with Cons show ?case
    by (simp add: ranking_Cons)
qed simp

lemma dominance_order_matched:
  assumes linorder: "linorder_on L r"

  assumes "i \<in> L" "j \<in> R"
  assumes "set js = R"
  assumes "{i,j} \<in> G"

  assumes "{i',j} \<in> ranking r (G \<setminus> {i}) js"
  assumes less: "(i,i') \<in> r" "(i',i) \<notin> r"
  shows "i \<in> Vs (ranking r G js)"
proof -
  from \<open>set js = R\<close> \<open>j \<in> R\<close> obtain pre suff where js_split: "js = pre @ j # suff" "j \<notin> set pre"
    by (auto dest: split_list_first)

  with linorder \<open>set js = R\<close> \<open>j \<in> R\<close>
  have j_unmatched_pre: "j \<notin> Vs (ranking r (G \<setminus> {i}) pre) \<and> j \<notin> Vs (ranking r G pre)"
    by (intro unmatched_R_in_ranking_if conjI)
       (auto dest: remove_vertices_subgraph' linorder_on_imp_preorder_on)

  from linorder \<open>set js = R\<close> have preorder_neighbors:
    "j' \<in> set js \<Longrightarrow> preorder_on' {i'. {i', j'} \<in> G \<setminus> {i}} r" for j'
    by (auto dest: linorder_on_imp_preorder_on remove_vertices_subgraph')

  with \<open>set js = R\<close> linorder have bipartite_js: "bipartite (ranking r (G \<setminus> {i}) js) L R"
    by (intro bipartite_ranking)
       (auto dest: remove_vertices_subgraph')

  with \<open>{i',j} \<in> ranking r (G \<setminus> {i}) js\<close> \<open>j \<in> R\<close> have \<open>i' \<in> L\<close>
    by (auto dest: bipartite_edgeD)

  from preorder_neighbors have "matching (ranking r (G \<setminus> {i}) js)"
    by (auto intro!: matching_ranking)

  from \<open>i \<in> L\<close> \<open>i' \<in> L\<close> \<open>j \<in> R\<close> have "i \<noteq> j" "i' \<noteq> j"
    by auto

  from less have "i \<noteq> i'"
    by auto

  from linorder \<open>set js = R\<close> have "{i',j} \<in> G \<setminus> {i}"
    by (auto dest: linorder_on_imp_preorder_on remove_vertices_subgraph'
             intro!: ranking_subgraph'[OF _ _ _ \<open>{i',j} \<in> ranking r (G \<setminus> {i}) js\<close>])

  show ?thesis
  proof (cases "i \<in> Vs (ranking r G pre)")
    case True
    with js_split show ?thesis
      by (auto simp: ranking_append dest: ranking_mono_vs)
  next
    case False

    have i'_unmatched_pre: "i' \<notin> Vs (ranking r (G \<setminus> {i}) pre)"
    proof (rule ccontr, simp only: not_not)
      assume "i' \<in> Vs (ranking r (G \<setminus> {i}) pre)"
      then obtain e where e: "e \<in> ranking r (G \<setminus> {i}) pre" "i' \<in> e"
        by (auto elim: vs_member_elim)

      from e js_split have "e \<in> ranking r (G \<setminus> {i}) js"
        by (auto simp: ranking_append intro: ranking_mono)

      from e obtain j' where "j' \<in> e" "j' \<in> set pre"
        by (auto elim: edge_in_rankingE)

      with js_split \<open>set js = R\<close> have "j' \<in> R" "j' \<noteq> j"
        by auto

      with \<open>i' \<in> L\<close> \<open>j \<in> R\<close> \<open>i' \<in> e\<close> \<open>j' \<in> e\<close> have "e \<noteq> {i',j}" "e \<inter> {i',j} \<noteq> {}"
        by auto

      with \<open>{i',j} \<in> ranking r (G \<setminus> {i}) js\<close> \<open>e \<in> ranking r (G \<setminus> {i}) js\<close>
      have "\<not>matching (ranking r (G \<setminus> {i}) js)"
        unfolding matching_def
        by force

      with \<open>matching (ranking r (G \<setminus> {i}) js)\<close> show False
        by blast
    qed

    from assms False js_split have ranking_pre_eq: "ranking r (G \<setminus> {i}) pre = ranking r G pre"
      by (intro ranking_remove_unmatched_eq) auto

    let ?ns = "{i. i \<notin> Vs (ranking r G pre) \<and> {i,j} \<in> G}"
    and ?ns' = "{i'. i' \<notin> Vs (ranking r (G \<setminus> {i}) pre) \<and> {i',j} \<in> G \<setminus> {i}}"

    from False \<open>i \<noteq> j\<close> \<open>{i,j} \<in> G\<close> have *: "?ns = insert i ?ns'"
      by (auto intro: in_remove_vertices_vsI in_remove_verticesI
               dest: edges_are_Vs remove_vertices_subgraph'
               simp: ranking_pre_eq)

    from i'_unmatched_pre \<open>{i',j} \<in> G \<setminus> {i}\<close> have "i' \<in> ?ns'"
      by auto

    have **: "min_on_rel ?ns' r = i'"
    proof (rule ccontr)
      assume "min_on_rel ?ns' r \<noteq> i'"
      then obtain i'' where i'': "i'' = min_on_rel ?ns' r" "i'' \<noteq> i'"
        by blast

      with \<open>i' \<in> ?ns'\<close> j_unmatched_pre have "step r (G \<setminus> {i}) (ranking r (G \<setminus> {i}) pre) j = insert {i'',j} (ranking r (G \<setminus> {i}) pre)"
        by (auto simp: step_def)

      with js_split have "{i'',j} \<in> ranking r (G \<setminus> {i}) js"
        by (auto simp: ranking_append ranking_Cons intro: ranking_mono)

      with \<open>{i',j} \<in> ranking r (G \<setminus> {i}) js\<close> \<open>i'' \<noteq> i'\<close> \<open>i' \<noteq> j\<close> have "\<not>matching (ranking r (G \<setminus> {i}) js)"
        unfolding matching_def
        by fast

      with \<open>matching (ranking r (G \<setminus> {i}) js)\<close> show False
        by blast
    qed

    have "min_on_rel ?ns r = i"
    proof (intro min_on_rel_linorder_eq ballI, goal_cases)
      case 1
      from linorder \<open>j \<in> R\<close> show ?case
        by (auto intro: linorder_on'_subset[OF _ unmatched_neighbors_L] unmatched_neighbors_L
                 dest: linorder_on_imp_linorder_on')
    next
      case 2
      from * show ?case
        by blast
    next
      case (3 y)
      have "\<lbrakk>i'' \<notin> Vs (ranking r (G \<setminus> {i}) pre); {i'',j} \<in> G \<setminus> {i}\<rbrakk> \<Longrightarrow> (i',i'') \<in> r" for i''
      proof (subst **[symmetric], intro min_on_rel_least, goal_cases)
        case 1
        from linorder \<open>j \<in> R\<close> show ?case
          by (auto intro: linorder_on'_subset[OF _ unmatched_neighbors_L]
                   dest: linorder_on_imp_linorder_on' remove_vertices_subgraph')
      next
        case 2
        then show ?case
          by (auto intro: finite_unmatched_neighbors dest: remove_vertices_subgraph')
      qed blast+

      with 3 linorder \<open>(i,i') \<in> r\<close> \<open>i \<in> L\<close> show ?case
        unfolding *
        by (auto dest: linorder_on_imp_linorder_on' linorder_on'_transD transD linorder_on'_refl_on'D refl_on'D)
    qed

    with False \<open>{i,j} \<in> G\<close> \<open>i' \<in> ?ns'\<close> j_unmatched_pre have "step r G (ranking r G pre) j = insert {i,j} (ranking r G pre)"
      by (auto simp: step_def)

    with js_split show ?thesis
      by (auto simp: ranking_append ranking_Cons vs_insert intro: ranking_mono_vs)
  qed
qed

lemma dominance_order_unmatched:
  assumes linorder: "linorder_on L r"

  assumes "i \<in> L"
  assumes "j \<in> set js"
  assumes "set js \<subseteq> R"

  assumes "{i,j} \<in> G"
  assumes "j \<notin> Vs (ranking r (G \<setminus> {i}) js)"
  shows "i \<in> Vs (ranking r G js)"
proof -
  from \<open>j \<in> set js\<close> obtain pre suff where js_split: "js = pre @ j # suff"
    by (auto dest: split_list)

  from \<open>j \<in> set js\<close> \<open>set js \<subseteq> R\<close> have "j \<in> R"
    by blast

  with \<open>i \<in> L\<close> have "i \<noteq> j"
    by auto

  from js_split \<open>j \<notin> Vs (ranking r (G \<setminus> {i}) js)\<close> have j_not_pre:  "j \<notin> Vs (ranking r (G \<setminus> {i}) pre)"
    by (auto simp: ranking_append dest: ranking_mono_vs)

  show ?thesis
  proof (cases "i \<in> Vs (ranking r G pre)")
    case True
    with js_split show ?thesis
      by (auto simp: ranking_append dest: ranking_mono_vs)
  next
    case False

    with assms js_split have pre_eq: "ranking r (G \<setminus> {i}) pre = ranking r G pre"
      by (intro ranking_remove_unmatched_eq) auto

    have "step r G (ranking r G pre) j = insert {i,j} (ranking r G pre)"
    proof (intro step_insertI, goal_cases)
      case 1
      from False \<open>{i,j} \<in> G\<close> show ?case
        by blast
    next
      case 2
      from j_not_pre show ?case
        by (simp add: pre_eq)
    next
      case 3
      have "{i'. i' \<notin> Vs (ranking r (G \<setminus> {i}) pre) \<and> {i',j} \<in> G \<setminus> {i}} = {}"
      proof (rule ccontr)
        let ?ns' = "{i'. i' \<notin> Vs (ranking r (G \<setminus> {i}) pre) \<and> {i',j} \<in> G \<setminus> {i}}"
        assume "?ns' \<noteq> {}"

        with j_not_pre have "step r (G \<setminus> {i}) (ranking r (G \<setminus> {i}) pre) j =
          insert {min_on_rel ?ns' r, j} (ranking r (G \<setminus> {i}) pre)"
          by (auto simp: step_def)

        with js_split have "j \<in> Vs (ranking r (G \<setminus> {i}) js)"
          by (auto simp: ranking_append ranking_Cons vs_insert intro: ranking_mono_vs)

        with \<open>j \<notin> Vs (ranking r (G \<setminus> {i}) js)\<close> show False
          by blast
      qed

      with False \<open>{i,j} \<in> G\<close> \<open>i \<noteq> j\<close> have "{i. i \<notin> Vs (ranking r G pre) \<and> {i,j} \<in> G} = {i}"
        by (auto simp: pre_eq intro: in_remove_verticesI)

      then show ?case
        by (simp flip: min_on_rel_singleton)
    qed

    with js_split show ?thesis
      by (auto simp: ranking_append ranking_Cons vs_insert intro: ranking_mono_vs)
  qed
qed

lemma dominance_order:
  assumes linorder: "linorder_on L r"

  assumes "i \<in> L" and "j \<in> R"
  assumes "set js = R"
  assumes "{i, j} \<in> G"

  defines "i' \<equiv> (THE i'. {i', j} \<in> ranking r (G \<setminus> {i}) js)"
  assumes "j \<in> Vs (ranking r (G \<setminus> {i}) js) \<Longrightarrow>  (i, i') \<in> r \<and> (i', i) \<notin> r"
  shows "i \<in> Vs (ranking r G js)"
proof (cases "j \<in> Vs (ranking r (G \<setminus> {i}) js)")
  case True
  then obtain e where e: "e \<in> ranking r (G \<setminus> {i}) js" "j \<in> e"
    by (auto elim: vs_member_elim)

  interpret G': graph_abs "G \<setminus> {i}"
    by (rule graph_abs_subgraph[of G])
       (auto simp: graph_abs_axioms dest: remove_vertices_subgraph')

  have "e \<in> G \<setminus> {i}"
    by (rule ranking_subgraph')
       (use linorder e \<open>set js = R\<close> in \<open>auto dest: remove_vertices_subgraph' linorder_on_imp_preorder_on preorder_on_imp_preorder_on'\<close>)

  with \<open>j \<in> e\<close> G'.graph obtain i' where "e = {i',j}"
    by fast

  from G'.graph linorder \<open>j \<in> R\<close> \<open>set js = R\<close> have "matching (ranking r (G \<setminus> {i}) js)"
    by (auto intro!: matching_ranking intro: preorder_on'_subset[OF _ neighbors_right_subset_left]
             dest: linorder_on_imp_preorder_on preorder_on_imp_preorder_on' remove_vertices_subgraph')

  with e \<open>e = {i',j}\<close> have the_i': "(THE i'. {i',j} \<in> ranking r (G \<setminus> {i}) js) = i'"
    by (auto dest: the_match)

  from assms True e \<open>e = {i',j}\<close> show ?thesis
    by (intro dominance_order_matched) (auto simp: the_i')
next
  case False
  with assms show ?thesis
    by (auto intro: dominance_order_unmatched)
qed

lemma monotonicity_order_step:
  assumes "i \<in> L" "j \<in> R"

  assumes "j \<notin> Vs M" "j \<notin> Vs M'"

  assumes linorder: "linorder_on' {i. {i, j} \<in> G} r"
  assumes subset_before: "L - {i} - Vs M' \<subseteq> L - Vs M"
  shows "L - {i} - Vs (step r (G \<setminus> {i}) M' j) \<subseteq> L - Vs (step r G M j)"
  using linorder_on'_imp_preorder_on'[OF linorder] finite_vs
proof (cases rule: step_cases[where M = M])
  case no_neighbor
  with bipartite_graph subset_before \<open>i \<in> L\<close> \<open>j \<in> R\<close> have "{i'. i' \<notin> Vs M' \<and> {i',j} \<in> G \<setminus> {i}} = {}"
    apply auto
    by (smt (verit, best) Diff_iff bipartite_edgeD(4) edges_are_Vs(1) remove_vertices_not_vs remove_vertices_subgraph' subset_iff)

  with no_neighbor subset_before show ?thesis
    by (simp add: step_def)
next
  case new_match
  note new_match_orig = this

  let ?min = "min_on_rel {i. i \<notin> Vs M \<and> {i,j} \<in> G} r"

  from new_match \<open>i \<in> L\<close> \<open>j \<in> R\<close> have min_available_if: "?min \<notin> Vs M' \<Longrightarrow> ?min \<noteq> i \<Longrightarrow> ?min \<in> {i'. i' \<notin> Vs M' \<and> {i',j} \<in> G \<setminus> {i}}"
    by (auto intro: in_remove_verticesI)

  from linorder have "preorder_on' {i'. {i', j} \<in> G \<setminus> {i}} r" "finite (Vs (G \<setminus> {i}))"
    by (auto intro: preorder_on'_subset dest: remove_vertices_subgraph' linorder_on'_imp_preorder_on')

  then show ?thesis
  proof (cases rule: step_cases[where M = M'])
    case no_neighbor

    with min_available_if subset_before new_match \<open>j \<in> R\<close> show ?thesis
      by (auto simp: step_def vs_insert)
  next
    case j_matched
    with \<open>j \<notin> Vs M'\<close> show ?thesis
      by blast
  next
    case new_match

    let ?min' = "min_on_rel {i'. i' \<notin> Vs M' \<and> {i',j} \<in> G \<setminus> {i}} r"

    from new_match have "?min' \<in> {i. i \<notin> Vs M \<and> {i,j} \<in> G}"
      apply (auto dest: remove_vertices_subgraph')
      by (smt (verit) DiffE DiffI assms(2) bipartite_edgeD(4) bipartite_graph edges_are_Vs(1) in_mono remove_vertices_not_vs remove_vertices_subgraph' subset_before)

    have "?min \<in> {i'. i' \<notin> Vs M' \<and> {i',j} \<in> G \<setminus> {i}} \<Longrightarrow> ?min = ?min'"
    proof -
      assume "?min \<in> {i'. i' \<notin> Vs M' \<and> {i',j} \<in> G \<setminus> {i}}"

      with linorder have "(?min', ?min) \<in> r"
        by (intro min_on_rel_least linorder_on'_subset[where S = "{i. {i,j} \<in> G}" and T = "{i'. i' \<notin> Vs M' \<and> {i', j} \<in> G \<setminus> {i}}"])
           (auto dest: remove_vertices_subgraph' intro: finite_vs_subgraph)

      from linorder \<open>?min' \<in> {i. i \<notin> Vs M \<and> {i,j} \<in> G}\<close> have "(?min, ?min') \<in> r"
        by (intro min_on_rel_least linorder_on'_subset[where S = "{i. {i,j} \<in> G}" and T = "{i. i \<notin> Vs M \<and> {i,j} \<in> G}"])
           (auto intro: finite_vs_subgraph)

      with linorder \<open>(?min', ?min) \<in> r\<close> show "?min = ?min'"
        unfolding linorder_on'_def antisym_def
        by blast
    qed

    with new_match new_match_orig subset_before min_available_if show ?thesis
      by (auto simp: step_def vs_insert)
  qed
qed (use \<open>j \<notin> Vs M\<close> in blast)

lemma monotonicity_order_ranking:
  assumes "i \<in> L"
  assumes "set js \<subseteq> R" "distinct js"
  assumes "set js \<inter> Vs M = {}" "set js \<inter> Vs M' = {}"
  assumes "\<forall>j \<in> set js. linorder_on' {i. {i,j} \<in> G} r"

  assumes "L - {i} - Vs M' \<subseteq> L - Vs M"
  shows "L - {i} - (Vs (ranking' r (G \<setminus> {i}) M' js)) \<subseteq> L - (Vs (ranking' r G M js))"
  using assms
proof (induction js arbitrary: M' M)
  case (Cons j js)

  from Cons.prems have mono_step: "L - {i} - Vs (step r (G \<setminus> {i}) M' j) \<subseteq> L - Vs (step r G M j)"
    by (intro monotonicity_order_step) auto

  from Cons.prems have j'_not_in_step: "j' \<in> set js \<Longrightarrow> j' \<notin> Vs (step r G M j)" for j'
    by (intro unmatched_R_in_step_if)
       (auto intro: linorder_on'_imp_preorder_on')

  from Cons.prems have "j' \<in> set js \<Longrightarrow> j' \<notin> Vs (step r (G \<setminus> {i}) M' j)" for j'
    by (intro unmatched_R_in_step_if)
       (auto intro: linorder_on'_imp_preorder_on' preorder_on'_subset dest: remove_vertices_subgraph')

  with Cons.prems mono_step j'_not_in_step show ?case
    by (simp only: ranking_Cons, intro Cons.IH unmatched_R_in_step_if)
       auto
qed simp

lemma monotonicity_order_matched_matched:
  assumes linorder: "linorder_on L r"
  assumes "{i,j} \<in> G"
  assumes "i \<in> L" "j \<in> set js"
  assumes "set js \<subseteq> R" "distinct js"
  assumes "set js \<inter> Vs M = {}" "set js \<inter> Vs M' = {}"

  assumes "j \<notin> Vs M" "j \<notin> Vs M'"
  assumes "L - {i} - Vs M' \<subseteq> L - Vs M"

  assumes "matching M" "matching M'"

  assumes i'j: "{i',j} \<in> ranking' r G M js"
  assumes i''j: "{i'',j} \<in> (ranking' r (G \<setminus> {i}) M' js)"
  shows "(i', i'') \<in> r"
  using assms
proof -
  from \<open>j \<in> set js\<close> \<open>distinct js\<close> obtain pre suff where js_decomp: "js = pre @ j # suff"
    by (auto dest: split_list)

  from \<open>j \<in> set js\<close> \<open>set js \<subseteq> R\<close> have "j \<in> R"
    by blast

  let ?ranking_pre = "ranking' r G M pre"
  and ?ranking_pre' = "ranking' r (G \<setminus> {i}) M' pre"

  from js_decomp assms have "L - {i} - Vs ?ranking_pre' \<subseteq> L - Vs ?ranking_pre"
    by (intro monotonicity_order_ranking) auto

  from linorder js_decomp \<open>distinct js\<close> \<open>set js \<subseteq> R\<close> \<open>j \<notin> Vs M\<close> have j_unmatched_pre: "j \<notin> Vs ?ranking_pre"
    by (intro unmatched_R_in_ranking_if)
       (auto dest: linorder_on_imp_preorder_on)

  let ?ns = "{i. i \<notin> Vs ?ranking_pre \<and> {i,j} \<in> G}"
  let ?min = "min_on_rel ?ns r"

  have "?ns \<noteq> {}"
  proof (rule ccontr, simp only: not_not)
    assume "?ns = {}"
    then have "step r G ?ranking_pre j = ?ranking_pre"
      by (simp add: step_def)

    with linorder j_unmatched_pre js_decomp \<open>distinct js\<close> \<open>set js \<subseteq> R\<close> have "j \<notin> Vs (ranking' r G M js)"
      by (simp only: ranking_append ranking_Cons)
         (rule unmatched_R_in_ranking_if, auto dest: linorder_on_imp_preorder_on)

    with i'j show False
      by (auto dest: edges_are_Vs)
  qed

  with linorder \<open>j \<in> R\<close> have "?min \<in> ?ns"
    by (intro min_if_finite)
       (auto dest: linorder_on_imp_preorder_on preorder_on_imp_preorder_on' intro: preorder_on'_subset)

  with j_unmatched_pre have "step r G ?ranking_pre j = insert {?min, j} ?ranking_pre"
    by (auto simp: step_def)

  with js_decomp have "{?min, j} \<in> ranking' r G M js"
    by (auto simp: ranking_append ranking_Cons intro: ranking_mono)

  with i'j linorder \<open>set js \<subseteq> R\<close> \<open>matching M\<close> have "i' = ?min"
    by (auto intro: matching_partner_eqI matching_ranking dest: linorder_on_imp_preorder_on)

  from linorder js_decomp \<open>distinct js\<close> \<open>set js \<subseteq> R\<close> \<open>j \<notin> Vs M'\<close> have j_unmatched_pre': "j \<notin> Vs ?ranking_pre'"
    by (intro unmatched_R_in_ranking_if)
       (auto dest: remove_vertices_subgraph' linorder_on_imp_preorder_on)

  let ?ns' = "{i'. i' \<notin> Vs ?ranking_pre' \<and> {i',j} \<in> G \<setminus> {i}}"
  let ?min' = "min_on_rel ?ns' r"

  have "?ns' \<noteq> {}"
  proof (rule ccontr, simp only: not_not)
    assume "?ns' = {}"
    then have "step r (G \<setminus> {i}) ?ranking_pre' j = ?ranking_pre'"
      by (simp add: step_def)

    with linorder j_unmatched_pre' js_decomp \<open>distinct js\<close> \<open>set js \<subseteq> R\<close> have "j \<notin> Vs (ranking' r (G \<setminus> {i}) M' js)"
      by (simp only: ranking_append ranking_Cons)
         (rule unmatched_R_in_ranking_if, auto dest: linorder_on_imp_preorder_on remove_vertices_subgraph')

    with i''j show False
      by (auto dest: edges_are_Vs)
  qed

  with linorder \<open>j \<in> R\<close> have "?min' \<in> ?ns'"
    by (intro min_if_finite)
       (auto dest: linorder_on_imp_preorder_on preorder_on_imp_preorder_on' remove_vertices_subgraph'
             intro: preorder_on'_subset)

  with j_unmatched_pre' have "step r (G \<setminus> {i}) ?ranking_pre' j = insert {?min', j} ?ranking_pre'"
    by (auto simp: step_def)

  with js_decomp have "{?min', j} \<in> ranking' r (G \<setminus> {i}) M' js"
    by (auto simp: ranking_append ranking_Cons intro: ranking_mono)

  with linorder \<open>set js \<subseteq> R\<close> \<open>matching M'\<close> have "i'' = ?min'"
    by (auto intro: matching_partner_eqI[OF _ i''j] matching_ranking
             dest: linorder_on_imp_preorder_on remove_vertices_subgraph')

  from \<open>?min' \<in> ?ns'\<close> have "?min' \<in> ?ns"
    apply (auto dest: remove_vertices_subgraph')
    apply (smt (verit) DiffE DiffI \<open>L - {i} - Vs (ranking' r (G \<setminus> {i}) M' pre) \<subseteq> L - Vs (ranking' r G M pre)\<close> \<open>j \<in> R\<close> bipartite_edgeD(4) bipartite_graph edges_are_Vs(1) remove_vertices_not_vs remove_vertices_subgraph' subsetD)
    done

  with linorder \<open>?min \<in> ?ns\<close> \<open>j \<in> R\<close> have "(?min, ?min') \<in> r"
    by (intro min_on_rel_least)
       (auto dest: linorder_on_imp_linorder_on' intro: linorder_on'_subset)

  with \<open>i' = ?min\<close> \<open>i'' = ?min'\<close> show "(i',i'') \<in> r"
    by simp
qed

lemma online_matched_mono:
  assumes linorder: "linorder_on L r"
  assumes perm: "\<pi> \<in> permutations_of_set R"
  assumes "i \<in> L" "j \<in> R"
  assumes "j \<in> Vs (ranking r (G \<setminus> {i}) \<pi>)"
  shows "j \<in> Vs (ranking r G \<pi>)"
proof -
  let ?M' = "ranking r (G \<setminus> {i}) \<pi>"

  from perm \<open>j \<in> R\<close> obtain pre suff where \<pi>_decomp: "\<pi> = pre @ j # suff"
    by (metis permutations_of_setD(1) split_list)

  let ?ranking_pre = "ranking r G pre"
  let ?ranking_pre' = "ranking r (G \<setminus> {i}) pre"

  from \<pi>_decomp perm linorder \<open>j \<in> R\<close> have j_unmatched_pre: "j \<notin> Vs ?ranking_pre"
    by (intro unmatched_R_in_ranking_if ballI preorder_on_neighborsI)
       (auto dest: permutations_of_setD linorder_on_imp_preorder_on)

  from \<pi>_decomp perm linorder \<open>j \<in> R\<close> have j_unmatched_pre': "j \<notin> Vs ?ranking_pre'"
    by (intro unmatched_R_in_ranking_if ballI preorder_on_neighborsI)
       (auto dest: permutations_of_setD remove_vertices_subgraph' linorder_on_imp_preorder_on)

  let ?ns = "{i. i \<notin> Vs ?ranking_pre \<and> {i,j} \<in> G}"
  and ?ns' = "{i'. i' \<notin> Vs ?ranking_pre' \<and> {i',j} \<in> G \<setminus> {i}}"

  from \<open>j \<in> R\<close> have "?ns \<subseteq> L"
    by (intro unmatched_neighbors_L subset_refl)

  from \<open>j \<in> R\<close> have "?ns' \<subseteq> L - {i}"
    by (auto dest: neighbors_right_subset_left[OF remove_vertices_subgraph] edges_are_Vs intro: remove_vertices_not_vs')

  have "?ns' \<noteq> {}"
  proof (rule ccontr, simp only: not_not)
    assume "?ns' = {}"

    then have step_eq: "step r (G \<setminus> {i}) ?ranking_pre' j = ?ranking_pre'"
      by (simp add: step_def)

    from j_unmatched_pre' \<pi>_decomp perm linorder \<open>j \<in> R\<close> have "j \<notin> Vs ?M'"
      by (simp only: \<pi>_decomp ranking_append ranking_Cons step_eq,
          intro unmatched_R_in_ranking_if[where M = ?ranking_pre'] ballI preorder_on_neighborsI)
         (auto dest: remove_vertices_subgraph' permutations_of_setD linorder_on_imp_preorder_on)

    with \<open>j \<in> Vs ?M'\<close> show False
      by blast
  qed

  from linorder perm \<pi>_decomp \<open>i \<in> L\<close> have "L - {i} - Vs ?ranking_pre' \<subseteq> L - Vs ?ranking_pre"
    by (intro monotonicity_order_ranking ballI linorder_on_neighborsI)
       (auto dest: permutations_of_setD)

  with \<open>?ns \<subseteq> L\<close> \<open>?ns' \<subseteq> L - {i}\<close> have "?ns' \<subseteq> ?ns"
    by (auto dest: remove_vertices_subgraph')

  with \<open>?ns' \<noteq> {}\<close> obtain i' where "i' \<in> ?ns"
    by blast

  then have "{i',j} \<in> G" "i' \<notin> Vs ?ranking_pre"
    by auto

  with j_unmatched_pre have "j \<in> Vs (step r G ?ranking_pre j)"
    by (intro step_matches_if_possible[OF j_unmatched_pre \<open>{i',j} \<in> G\<close>])
       auto

  with \<pi>_decomp show "j \<in> Vs (ranking r G \<pi>)"
    by (auto simp: ranking_append ranking_Cons intro: ranking_mono_vs)
qed

lemma step_Restr_to_vertices:
  assumes "j \<in> R"
  shows "step (Restr r (L - X)) (G \<setminus> X) M j = step r (G \<setminus> X) M j"
proof (cases M j "G \<setminus> X" rule: step_cases')
  case new_match
  from bipartite_graph \<open>j \<in> R\<close> have "{i. i \<notin> Vs M \<and> {i, j} \<in> G \<setminus> X} \<subseteq> L - X"
    by (auto dest: remove_vertices_subgraph' bipartite_edgeD edges_are_Vs intro: remove_vertices_not_vs')

  then have "Restr (Restr r (L - X)) {i. i \<notin> Vs M \<and> {i, j} \<in> G \<setminus> X} = Restr r {i. i \<notin> Vs M \<and> {i,j} \<in> G \<setminus> X}"
    by blast
  with new_match show ?thesis
    by (simp add: step_def min_on_rel_def)
qed (simp_all add: step_def)

lemma ranking_Restr_to_vertices:
  assumes "set js \<subseteq> R"
  shows "ranking' (Restr r (L - X)) (G \<setminus> X) M js = ranking' r (G \<setminus> X) M js"
  using assms
  by (induction js arbitrary: M) (simp_all add: ranking_Cons step_Restr_to_vertices)

end
end


theory CSimplification
imports Main
begin

lemma "\<lbrakk> xs @ zs = ys @ xs; [] @ xs = [] @ [] \<rbrakk> \<Longrightarrow> ys = zs"
apply simp (* Applies x = [] *)
done

lemma "\<forall>x. f x = g (f (g x)) \<Longrightarrow> f [] = f [] @ []"
apply (simp (no_asm)) (* No assumptions \<rightarrow> prevent nontermination *)
done

definition xor :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"xor A B \<equiv> (A \<and> \<not>B) \<or> (\<not>A \<and> B)"

lemma "xor A (\<not>A)"
(*
apply (simp only: xor_def)
apply (simp only: or_def)
apply (simp only: not_def)
apply (simp only: and_def)
... ?
*)
(*
apply (simp only: xor_def) (* unfold xor *)
apply simp
*)
apply (simp add: xor_def)
done

(* Apply simplification plus Let_def *)
lemma "(let xs = [] in xs @ ys @ xs) = ys"
apply (simp add: Let_def)
done

(* Add Let_def to simplification and apply simplification *)
declare Lef_def [simp]
lemma "(let xs = [] in xs @ ys @ xs) = ys"
apply simp
done

(* Remove Let_def from simplification *)
(* Why doesn't this work? *)
(*
declare Let_def [simp del]
\<Longrightarrow>
Rewrite rule not in simpset:
Let ?s ?f \<equiv> ?f ?s
*)

(* Conditional equations *)
lemma hd_Cons_tl [simp]: "xs \<noteq> [] \<Longrightarrow> hd xs # tl xs = xs"
apply (case_tac xs, simp, simp)
done (* Duplicate rule of List.hd_Cons_tl *)

lemma "xs \<noteq> [] \<Longrightarrow> hd (rev xs) # tl (rev xs) = rev xs"
apply simp
done

(* Automatic case split *)
lemma "\<forall>xs. if xs = [] then rev xs = [] else rev xs \<noteq> []"
(* Split with the theorem to split ifs. *)
apply (split split_if) (* Not strictly necessary because it's already done by simp. *)
apply simp
done

lemma "(case xs of [] \<Rightarrow> zs | y # ys \<Rightarrow> y # ys @ zs) = xs @ zs"
(* Split with theorem to split lists. *)
(*
apply (split list.split)
apply simp
*)
apply (simp split: list.split) (* Combined above *)
done

lemma "(if xs = [] then ys \<noteq> [] else ys = []) \<Longrightarrow> xs @ ys \<noteq> []"
(* Apply split_if to the assumptions only *)
apply (split split_if_asm)
(*
apply simp
apply simp
*)
apply simp_all (* simplify all subgoals *)
done

(*
lemma "rev [a] = []"
using [[simp_trace=true]] (* Enable the Trace Simplifier *)
apply simp
done
*)

end


(*  Title:      HOL/Proofs/Extraction/QuotRem.thy
    Author:     Stefan Berghofer, TU Muenchen
*)

section \<open>Quotient and remainder\<close>

theory QuotRem
imports Util
begin

text \<open>Derivation of quotient and remainder using program extraction.\<close>

theorem division: "\<exists>r q. a = Suc b * q + r \<and> r \<le> b"
proof (induct a)
  case 0
  have "0 = Suc b * 0 + 0 \<and> 0 \<le> b" by simp
  then show ?case by iprover
next
  case (Suc a)
  then obtain r q where I: "a = Suc b * q + r" and "r \<le> b" by iprover
  from nat_eq_dec show ?case
  proof
    assume "r = b"
    with I have "Suc a = Suc b * (Suc q) + 0 \<and> 0 \<le> b" by simp
    then show ?case by iprover
  next
    assume "r \<noteq> b"
    with \<open>r \<le> b\<close> have "r < b" by (simp add: order_less_le)
    with I have "Suc a = Suc b * q + (Suc r) \<and> (Suc r) \<le> b" by simp
    then show ?case by iprover
  qed
qed

extract division

text \<open>
  The program extracted from the above proof looks as follows
  @{thm [display] division_def [no_vars]}
  The corresponding correctness theorem is
  @{thm [display] division_correctness [no_vars]}
\<close>

lemma "division 9 2 = (0, 3)" by eval

end


theory mRepl
  imports mMem
begin

context GZF_Model begin

lemma mRepl_eq :
  assumes "x : mSet" "P : mReplPred x"
  shows "mRepl x P = <set, { b | \<exists> a \<in> snd x. P a b \<and> b : mSetMem }>"
  unfolding mRepl_def mRepl'_def tex_def msetmem_iff
  using assms by auto

lemma mreplpred_replpred :
  assumes x : "<set,x'> : mSet" and P : "P : mReplPred <set,x'>"
  shows "(\<lambda>a b. P a b \<and> b : mSetMem) : ReplPred x'"
  unfolding ReplPred_def
proof (rule tyI, auto)
  fix a assume "a \<in> x'"
  hence "a m <set,x'>" using mmemI[OF x] by auto
  hence uniq:"m\<exists>\<^sub>\<le>\<^sub>1 b : mSetMem. P a b"
     using P mmem_m
     unfolding mReplPred_def has_ty_def mall_def tall_def by auto
  thus "\<exists>\<^sub>\<le>\<^sub>1 b : SetMem. P a b \<and> b : mSetMem"
   unfolding mtuniq_def muniq_def tuniq_def Uniq_def
   using msmem_smem msmem_m by auto
qed

lemma mreplpred_cong :
  "\<And>x. x : M \<Longrightarrow> (\<And>fun1 fun2.
      (\<And>x. x : M \<Longrightarrow> (\<And>xa. xa : M \<Longrightarrow> fun1 x xa = fun2 x xa))
        \<Longrightarrow> mReplPred x fun1 = mReplPred x fun2)"
  using mset_m[OF mmem_mset]
  unfolding mReplPred_def mall_def tall_def
            mtuniq_def tuniq_def muniq_def Uniq_def by blast

lemma mrank_memfun :
  assumes x : "x : SetOf M"
  shows "mrank : x \<leadsto> Ord"
  by (rule mem_funI, erule mrank_ord[OF setof_mem[OF x]])

lemma mrank_repfun :
  assumes x : "x : SetOf M"
  shows "i \<in> {mrank b | b \<in> x} \<longleftrightarrow> (\<exists>b\<in>x. i = mrank b)"
  unfolding repfun_iff[OF setof_set[OF x]] bex_def rex_def
  using ord_setmem[OF mem_funE[OF mrank_memfun[OF x]]] by auto

lemma mrank_repfun_setof :
  assumes x:"x : SetOf M"
  shows "{mrank b | b \<in> x} : SetOf Ord"
  using repfun_setof[OF setof_set[OF x] mrank_memfun[OF x]] .

lemma setof_m_tier :
  assumes x : "x' : SetOf M"
  obtains i where
    "i : Ord" "x' \<subseteq> Tier i"
proof -
  let ?i = "supOrd {mrank b | b \<in> x'}"
  have i:"?i : Ord" and "\<forall>b\<in>x'. mrank b \<le> ?i"
    using supord_iff[OF mrank_repfun_setof[OF x] repfunI[OF setof_set[OF x] _ ord_setmem]]
          supord_ord[OF mrank_repfun_setof[OF x]] mrank_ord[OF setof_mem[OF x]] by auto
  moreover have "\<forall>b\<in>x'. b \<in> Tier (mrank b)"
    using mrank_tier[OF setof_mem[OF x]] by auto
  ultimately have x':"x' \<subseteq> Tier ?i"
    using tier_increasing_leq[OF mrank_ord[OF setof_mem[OF x]] \<open>?i : Ord\<close>] by blast
  from i x' show ?thesis ..
qed

lemma setof_mset :
  assumes x:"x' : SetOf M" and b:"\<forall>b\<in>x'. \<not> Excluded set b"
  shows "<set, x'> : mSet"
proof (rule msetI, rule setof_m_tier[OF x])
  fix i assume "i : Ord" and "x' \<subseteq> Tier i"
  hence "\<forall>b \<in> x'. b \<in> Tier i \<ominus> set"
    using exsetI[OF tier_set[OF \<open>i : Ord\<close>]] b by auto
  thus "<set,x'> : M"
    using mI_mset[OF \<open>i : Ord\<close> setof_set[OF x]] by auto
qed

lemma mrepl_typ :
  "mRepl : (\<Pi> x:mSet. mReplPred x \<rightarrow> mSet)"
proof (rule depfunI, rule funI)
  fix x P
  assume x : "x : mSet" and P: "P : mReplPred x"
  then obtain x' where x':"x = <set,x'>" "x' : Set"
    using msetE by auto
  hence Px':"(\<lambda>a b . P a b \<and> b : mSetMem) : ReplPred x'"
    using mreplpred_replpred P x by auto

  let ?R = \<open>{ b | \<exists>a\<in>x'. P a b \<and> b : mSetMem }\<close>
  have mrepl_eq: "mRepl x P = <set,?R>"
    using mRepl_eq[OF x P]
    unfolding x' mset_snd_eq'[OF x'(2)] by auto
  show "mRepl x P : mSet"
    unfolding mrepl_eq
  proof (rule setof_mset, rule setofI[OF repl_set[OF x'(2) Px']],
         rule_tac [2] ballI)
    fix b assume "b \<in> ?R"
    hence  "b : mSetMem"
      using replaceE[OF x'(2) Px'] by blast
    thus "b : M" "\<not> Excluded set b"
      using msmem_m msmem_not_excluded by auto
   qed
qed

lemmas mrepl_mset = funE[OF depfunE[OF mrepl_typ]]

lemma mrepl_iff :
  assumes x : "x : mSet" and P : "P : mReplPred x"
  shows "b m mRepl x P \<longleftrightarrow> (\<exists>a. a m x \<and> P a b \<and> b : mSetMem)"
proof -
  obtain x' where x' : "x = <set,x'>" "x' : Set"
    using msetE[OF x] by auto
  have Px' : "(\<lambda>a b. P a b \<and> b : mSetMem) : ReplPred x'"
    using mreplpred_replpred P x unfolding x' by auto
  have mrepl_eq : "mRepl x P = <set, { b | \<exists>a\<in>x'. P a b \<and> b : mSetMem }>"
    using mRepl_eq[OF x P]
    unfolding x' mset_snd_eq'[OF x'(2)] by auto

  show ?thesis
    unfolding
      mmem_iff_eq[OF mrepl_mset[OF x P] mrepl_eq]
      replace_iff[OF x'(2) Px'] mmem_iff_eq[OF x x'(1)]
    using msmem_smem
    by auto
qed

lemma mrepl_cong' :
  assumes x : "x : mSet"
      and P : "P : mReplPred x"
      and Q : "Q : mReplPred x"
      and iff : "\<And>a b. a : M \<Longrightarrow> b : M \<Longrightarrow> P a b \<longleftrightarrow> Q a b"
    shows "mRepl' x P = mRepl' x Q"
    unfolding mRepl'_def
proof (rule pair_eqI[OF refl],
       rule replace_cong[OF mset_snd_set[OF x] _ mset_snd_set[OF x] _ refl])
  obtain x' where x':"x = <set, x'>" "x' : Set"
    using msetE[OF x] .
  show "(\<lambda>a b. P a b \<and> b : mSetMem) : ReplPred (\<pi> x)"
       "(\<lambda>a b. Q a b \<and> b : mSetMem) : ReplPred (\<pi> x)"
       using x mreplpred_replpred P Q
       unfolding x' mset_snd_eq'[OF x'(2)] msetmem_iff
       by auto
  fix a b assume "a \<in> \<pi> x"
  hence "a m x" using mmemI x x' mset_snd_eq by auto
  hence "a : M" using mmem_m by auto
  thus "(P a b \<and> b : mSetMem) \<longleftrightarrow> (Q a b \<and> b : mSetMem)"
    using iff mmem_m msetmem_iff by auto
qed

lemma mrepl_cong :
  assumes iff:"\<And>a b. a : M \<Longrightarrow> b : M \<Longrightarrow> P a b \<longleftrightarrow> Q a b"
  shows "m\<R> x P = m\<R> x Q"
proof -
  have pq:"P : mReplPred x \<longleftrightarrow> Q : mReplPred x"
    using iff[OF mmem_m msmem_m]
    unfolding mReplPred_def has_ty_def mtuniq_def muniq_def tuniq_def Uniq_def
              mall_def by blast
  show ?thesis
  proof (cases \<open>x : mSet \<and> P : mReplPred x\<close>)
    case h:True
    hence x:"x : mSet" and P: "P : mReplPred x" by auto
    hence Q:"Q : mReplPred x" using pq by auto
    have "mRepl' x P = mRepl' x Q"
      using mrepl_cong'[OF x P Q] iff by auto
    thus ?thesis
      unfolding mRepl_def using x P Q by auto
  next
    case False
    then show ?thesis
      unfolding mRepl_def pq by auto
  qed
qed

lemma mrepl_m :
  "m\<R> x P : M"
  using mset_m[OF mrepl_mset] GZF_Model_mdefault_m
  unfolding mRepl_def by auto

theorem mrepl_ax :
 "m\<forall>x:mSet. \<forall>P : mReplPred x. m\<forall>b. (b m m\<R> x P) = (m\<exists>a. a m x \<and> P a b \<and> b : mSetMem)"
  using mrepl_iff mmem_m
  unfolding mall_def mtall_def mall_def tall_def mtex_def tex_def mex_def
  by blast

theorem mrepl_rsp :
  assumes x : "x : M" and iff:"\<And>x y. x : M \<Longrightarrow> y : M \<Longrightarrow> P x y \<longleftrightarrow> Q x y"
  shows "m\<R> x P : M \<and> (m\<R> x P = m\<R> x Q)"
  using mrepl_m mrepl_cong iff by blast

end
end


theory Helper
imports Main
begin

section\<open>Hilfslemmata\<close>

lemma helper_sum_int_if: \<open>a \<notin> set P \<Longrightarrow>
(\<Sum>x\<in>set P. int (if a = x then A1 x else A2 x) * B x) =
  (\<Sum>x\<in>set P. int (A2 x) * B x)\<close>
  apply(rule sum.cong, simp)
  by fastforce

lemma sum_list_map_eq_sum_count_int:
  fixes f :: \<open>'a \<Rightarrow> int\<close>
  shows \<open>sum_list (map f xs) = sum (\<lambda>x. (int (count_list xs x)) * f x) (set xs)\<close>
proof(induction \<open>xs\<close>)
  case (Cons x xs)
  show \<open>?case\<close> (is \<open>?l = ?r\<close>)
  proof cases
    assume \<open>x \<in> set xs\<close>
    have XXX: \<open>(\<Sum>xa\<in>set xs - {x}. int (if x = xa then count_list xs xa + 1 else count_list xs xa) * f xa)
  = (\<Sum>xa\<in>set xs - {x}. int (count_list xs xa) * f xa)\<close>
      thm helper_sum_int_if
      apply(rule sum.cong, simp)
      by auto
    have \<open>?l = f x + (\<Sum>x\<in>set xs. (int (count_list xs x)) * f x)\<close> by (simp add: Cons.IH)
    also have \<open>set xs = insert x (set xs - {x})\<close> using \<open>x \<in> set xs\<close>by blast
    also have \<open>f x + (\<Sum>x\<in>insert x (set xs - {x}). (int (count_list xs x)) * f x) = ?r\<close>
      apply(simp add: sum.insert_remove XXX)
      by (simp add: mult.commute ring_class.ring_distribs(1))
    finally show \<open>?thesis\<close> .
  next
    assume \<open>x \<notin> set xs\<close>
    hence \<open>\<And>xa. xa \<in> set xs \<Longrightarrow> x \<noteq> xa\<close> by blast
    thus \<open>?thesis\<close> by (simp add: Cons.IH \<open>x \<notin> set xs\<close>)
  qed
qed simp

lemma count_list_distinct: \<open>distinct P \<Longrightarrow> x \<in> set P \<Longrightarrow> count_list P x = 1\<close>
  apply(induction \<open>P\<close>)
   apply(simp; fail)
  by(auto)

lemma is_singleton_the_elem_as_set: \<open>is_singleton A \<Longrightarrow> the_elem A = a \<longleftrightarrow> A = {a}\<close>
  apply(rule iffI)
   apply (simp add: is_singleton_the_elem)
  apply(simp add: the_elem_def)
  done

(*the simplifier loops with this one, sometimes. If it loops, apply(elim is_singletonE) first.*)
lemma singleton_set_to_all: \<open>{a \<in> A. P a} = {b} \<longleftrightarrow> (\<forall>a. (a \<in> A \<and> P a) = (a = b))\<close>
  by fastforce

lemma singleton_set_to_all2: \<open>A = {b} \<longleftrightarrow> (\<forall>a. (a \<in> A) = (a = b))\<close>
  by fastforce

lemma is_singleton_bij_image: \<open>bij f \<Longrightarrow> is_singleton (f ` A) = is_singleton A\<close>
  by (metis bij_betw_same_card bij_betw_subset is_singleton_altdef subset_UNIV)

text\<open>For some reason, I like \<^const>\<open>List.map_filter\<close>. But standard library support is poor.\<close>
lemma List_map_filter_as_comprehension:
  \<open>List.map_filter f xs = [the (f x). x \<leftarrow> xs, f x \<noteq> None]\<close>
  by(induction \<open>xs\<close>) (simp add: List.map_filter_def)+
lemma List_map_filter_as_foldr:
  \<open>List.map_filter f xs = foldr (\<lambda>x acc. case f x of Some a \<Rightarrow> a#acc | None \<Rightarrow> acc) xs []\<close>
  apply(induction \<open>xs\<close>)
  apply(simp add: List.map_filter_def)
  apply(simp add: List.map_filter_def)
  apply(safe, simp)
  done

lemma concat_map_if: \<open>concat (map (\<lambda>x. if P x then [x] else []) xs) = filter P xs\<close>
  by(induction \<open>xs\<close>) auto

lemma fold_fun_update_call_helper:
  \<open>p \<notin> set xs \<Longrightarrow> fold (\<lambda>x acc. acc(x := f x)) xs start p = start p\<close>
  by(induction \<open>xs\<close> arbitrary: \<open>start\<close>) simp+

lemma fold_fun_update_call:
  \<open>p \<in> set xs \<Longrightarrow> distinct xs \<Longrightarrow> fold (\<lambda>x acc. acc(x := f x)) xs start p = f p\<close>
  apply(induction \<open>xs\<close> arbitrary: \<open>start\<close>)
   apply(simp; fail)
  apply(simp)
  apply(safe)
   apply(simp add: fold_fun_update_call_helper; fail)
  apply(simp)
  done

lemma fold_enum_fun_update_call:
  \<open>fold (\<lambda>x acc. acc(x := f x)) Enum.enum start p = f p\<close>
  apply(rule fold_fun_update_call)
   apply(simp add: enum_class.enum_UNIV)
  apply(simp add: enum_class.enum_distinct)
  done

lemma fold_enum_fun_update:
  \<open>fold (\<lambda>x acc. acc(x := f x)) Enum.enum start = f\<close>
  using fold_enum_fun_update_call by auto
end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>\<open>SemiCAT\<close> as a digraph\label{sec:dg_SemiCAT}\<close>
theory CZH_DG_SemiCAT
  imports
    CZH_SMC_Semifunctor
    CZH_DG_Small_Digraph
begin

subsection\<open>Background\<close>

text\<open>
\<open>SemiCAT\<close> is usually defined as a category of semicategories and semifunctors
(e.g., see \<^cite>\<open>"noauthor_nlab_nodate"\<close>\footnote{
\url{https://ncatlab.org/nlab/show/semicategory}
}).
However, there is little that can prevent one from exposing \<open>SemiCAT\<close>
as a digraph and provide additional structure gradually in
subsequent theories. Thus, in this section, \<open>\<alpha>\<close>-\<open>SemiCAT\<close> is defined as a
digraph of semicategories and semifunctors in \<open>V\<^sub>\<alpha>\<close>.
\<close>

named_theorems dg_SemiCAT_simps
named_theorems dg_SemiCAT_intros

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

definition dg_SemiCAT :: "V \<Rightarrow> V"
  where "dg_SemiCAT \<alpha> =
    [
      set {\<CC>. semicategory \<alpha> \<CC>},
      all_smcfs \<alpha>,
      (\<lambda>\<FF>\<in>\<^sub>\<circ>all_smcfs \<alpha>. \<FF>\<lparr>HomDom\<rparr>),
      (\<lambda>\<FF>\<in>\<^sub>\<circ>all_smcfs \<alpha>. \<FF>\<lparr>HomCod\<rparr>)
    ]\<^sub>\<circ>"

text\<open>Components.\<close>

lemma dg_SemiCAT_components:
  shows "dg_SemiCAT \<alpha>\<lparr>Obj\<rparr> = set {\<CC>. semicategory \<alpha> \<CC>}"
    and "dg_SemiCAT \<alpha>\<lparr>Arr\<rparr> = all_smcfs \<alpha>"
    and "dg_SemiCAT \<alpha>\<lparr>Dom\<rparr> = (\<lambda>\<FF>\<in>\<^sub>\<circ>all_smcfs \<alpha>. \<FF>\<lparr>HomDom\<rparr>)"
    and "dg_SemiCAT \<alpha>\<lparr>Cod\<rparr> = (\<lambda>\<FF>\<in>\<^sub>\<circ>all_smcfs \<alpha>. \<FF>\<lparr>HomCod\<rparr>)"
  unfolding dg_SemiCAT_def dg_field_simps by (simp_all add: nat_omega_simps)

subsection\<open>Object\<close>

lemma dg_SemiCAT_ObjI:
  assumes "semicategory \<alpha> \<AA>"
  shows "\<AA> \<in>\<^sub>\<circ> dg_SemiCAT \<alpha>\<lparr>Obj\<rparr>"
  using assms unfolding dg_SemiCAT_components by auto

lemma dg_SemiCAT_ObjD:
  assumes "\<AA> \<in>\<^sub>\<circ> dg_SemiCAT \<alpha>\<lparr>Obj\<rparr>"
  shows "semicategory \<alpha> \<AA>"
  using assms unfolding dg_SemiCAT_components by auto

lemma dg_SemiCAT_ObjE:
  assumes "\<AA> \<in>\<^sub>\<circ> dg_SemiCAT \<alpha>\<lparr>Obj\<rparr>"
  obtains "semicategory \<alpha> \<AA>"
  using assms unfolding dg_SemiCAT_components by auto

lemma dg_SemiCAT_Obj_iff[dg_SemiCAT_simps]:
  "\<AA> \<in>\<^sub>\<circ> dg_SemiCAT \<alpha>\<lparr>Obj\<rparr> \<longleftrightarrow> semicategory \<alpha> \<AA>"
  unfolding dg_SemiCAT_components by auto

subsection\<open>Domain and codomain\<close>

lemma [dg_SemiCAT_simps]:
  assumes "\<FF> \<in>\<^sub>\<circ> all_smcfs \<alpha>"
  shows dg_SemiCAT_Dom_app: "dg_SemiCAT \<alpha>\<lparr>Dom\<rparr>\<lparr>\<FF>\<rparr> = \<FF>\<lparr>HomDom\<rparr>"
    and dg_SemiCAT_Cod_app: "dg_SemiCAT \<alpha>\<lparr>Cod\<rparr>\<lparr>\<FF>\<rparr> = \<FF>\<lparr>HomCod\<rparr>"
  using assms unfolding dg_SemiCAT_components by auto

subsection\<open>\<open>SemiCAT\<close> is a digraph\<close>

lemma (in \<Z>) tiny_digraph_dg_SemiCAT:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "tiny_digraph \<beta> (dg_SemiCAT \<alpha>)"
proof(intro tiny_digraphI)
  show "vfsequence (dg_SemiCAT \<alpha>)" unfolding dg_SemiCAT_def by simp
  show "vcard (dg_SemiCAT \<alpha>) = 4\<^sub>\<nat>"
    unfolding dg_SemiCAT_def by (simp add: nat_omega_simps)
  show "\<R>\<^sub>\<circ> (dg_SemiCAT \<alpha>\<lparr>Dom\<rparr>) \<subseteq>\<^sub>\<circ> dg_SemiCAT \<alpha>\<lparr>Obj\<rparr>"
  proof(intro vsubsetI)
    fix \<AA> assume "\<AA> \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (dg_SemiCAT \<alpha>\<lparr>Dom\<rparr>)"
    then obtain \<FF>
      where "\<FF> \<in>\<^sub>\<circ> all_smcfs \<alpha>" and \<AA>_def: "\<AA> = \<FF>\<lparr>HomDom\<rparr>"
      unfolding dg_SemiCAT_components by auto
    then obtain \<BB> \<FF> where "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
      unfolding dg_SemiCAT_components by auto
    then interpret is_semifunctor \<alpha> \<AA> \<BB> \<FF> .
    show "\<AA> \<in>\<^sub>\<circ> dg_SemiCAT \<alpha>\<lparr>Obj\<rparr>"
      by (simp add: dg_SemiCAT_components HomDom.semicategory_axioms)
  qed
  show "\<R>\<^sub>\<circ> (dg_SemiCAT \<alpha>\<lparr>Cod\<rparr>) \<subseteq>\<^sub>\<circ> dg_SemiCAT \<alpha>\<lparr>Obj\<rparr>"
  proof(intro vsubsetI)
    fix \<BB> assume "\<BB> \<in>\<^sub>\<circ> \<R>\<^sub>\<circ> (dg_SemiCAT \<alpha>\<lparr>Cod\<rparr>)"
    then obtain \<FF> where "\<FF> \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (dg_SemiCAT \<alpha>\<lparr>Cod\<rparr>)" and "\<BB> = \<FF>\<lparr>HomCod\<rparr>"
      unfolding dg_SemiCAT_components by auto
    then obtain \<AA> \<FF>
      where \<FF>: "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>" and \<AA>_def: "\<BB> = \<FF>\<lparr>HomCod\<rparr>"
      unfolding dg_SemiCAT_components by auto
    have "\<BB> = \<FF>\<lparr>HomCod\<rparr>" unfolding \<AA>_def by simp
    interpret is_semifunctor \<alpha> \<AA> \<BB> \<FF> by (rule \<FF>)
    show "\<BB> \<in>\<^sub>\<circ> dg_SemiCAT \<alpha>\<lparr>Obj\<rparr>"
      by (simp add: HomCod.semicategory_axioms dg_SemiCAT_components)
  qed
  show "dg_SemiCAT \<alpha>\<lparr>Obj\<rparr> \<in>\<^sub>\<circ> Vset \<beta>"
    unfolding dg_SemiCAT_components by (rule semicategories_in_Vset[OF assms])
  show "dg_SemiCAT \<alpha>\<lparr>Arr\<rparr> \<in>\<^sub>\<circ> Vset \<beta>"
    unfolding dg_SemiCAT_components by (rule all_smcfs_in_Vset[OF assms])
qed (simp_all add: assms dg_SemiCAT_components)

subsection\<open>Arrow with a domain and a codomain\<close>

lemma dg_SemiCAT_is_arrI:
  assumes "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
  shows "\<FF> : \<AA> \<mapsto>\<^bsub>dg_SemiCAT \<alpha>\<^esub> \<BB>"
proof(intro is_arrI, unfold dg_SemiCAT_components(2))
  interpret is_semifunctor \<alpha> \<AA> \<BB> \<FF> by (rule assms)
  from assms show "\<FF> \<in>\<^sub>\<circ> all_smcfs \<alpha>" by auto
  with assms show "dg_SemiCAT \<alpha>\<lparr>Dom\<rparr>\<lparr>\<FF>\<rparr> = \<AA>" "dg_SemiCAT \<alpha>\<lparr>Cod\<rparr>\<lparr>\<FF>\<rparr> = \<BB>"
    by (simp_all add: smc_cs_simps dg_SemiCAT_components)
qed

lemma dg_SemiCAT_is_arrD:
  assumes "\<FF> : \<AA> \<mapsto>\<^bsub>dg_SemiCAT \<alpha>\<^esub> \<BB>"
  shows "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
  using assms by (elim is_arrE) (auto simp: dg_SemiCAT_components)

lemma dg_SemiCAT_is_arrE:
  assumes "\<FF> : \<AA> \<mapsto>\<^bsub>dg_SemiCAT \<alpha>\<^esub> \<BB>"
  obtains "\<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
  using assms by (simp add: dg_SemiCAT_is_arrD)

lemma dg_SemiCAT_is_arr_iff[dg_SemiCAT_simps]:
  "\<FF> : \<AA> \<mapsto>\<^bsub>dg_SemiCAT \<alpha>\<^esub> \<BB> \<longleftrightarrow> \<FF> : \<AA> \<mapsto>\<mapsto>\<^sub>S\<^sub>M\<^sub>C\<^bsub>\<alpha>\<^esub> \<BB>"
  by (auto intro: dg_SemiCAT_is_arrI dest: dg_SemiCAT_is_arrD)

text\<open>\newpage\<close>

end