Theory Prim

(* Title:      Prim's Minimum Spanning Tree Algorithm
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section ‹Prim's Minimum Spanning Tree Algorithm›

text ‹
In this theory we prove total correctness of Prim's minimum spanning tree algorithm.
The proof has the same overall structure as the total-correctness proof of Kruskal's algorithm cite"Guttmann2018c".
The partial-correctness proof of Prim's algorithm is discussed in cite"Guttmann2016c" and "Guttmann2018b".
›

theory Prim

imports "HOL-Hoare.Hoare_Logic" Aggregation_Algebras.Aggregation_Algebras

begin

context m_kleene_algebra
begin

abbreviation "component g r  rT * (--g)"
definition "spanning_tree t g r  forest t  t  (component g r)T * (component g r)  --g  component g r  rT * t  regular t"
definition "minimum_spanning_tree t g r  spanning_tree t g r  (u . spanning_tree u g r  sum (t  g)  sum (u  g))"
definition "prim_precondition g r  g = gT  injective r  vector r  regular r"
definition "prim_spanning_invariant t v g r  prim_precondition g r  vT = rT * t  spanning_tree t (v * vT  g) r"
definition "prim_invariant t v g r  prim_spanning_invariant t v g r  (w . minimum_spanning_tree w g r  t  w)"

lemma span_tree_split:
  assumes "vector r"
    shows "t  (component g r)T * (component g r)  --g  (t  (component g r)T  t  component g r  t  --g)"
proof -
  have "(component g r)T * (component g r) = (component g r)T  component g r"
    by (metis assms conv_involutive covector_mult_closed vector_conv_covector vector_covector)
  thus ?thesis
    by simp
qed

lemma span_tree_component:
  assumes "spanning_tree t g r"
    shows "component g r = component t r"
  using assms by (simp add: order.antisym mult_right_isotone star_isotone spanning_tree_def)

text ‹
We first show three verification conditions which are used in both correctness proofs.
›

lemma prim_vc_1:
  assumes "prim_precondition g r"
    shows "prim_spanning_invariant bot r g r"
proof (unfold prim_spanning_invariant_def, intro conjI)
  show "prim_precondition g r"
    using assms by simp
next
  show "rT = rT * bot"
    by (simp add: star_absorb)
next
  let ?ss = "r * rT  g"
  show "spanning_tree bot ?ss r"
  proof (unfold spanning_tree_def, intro conjI)
    show "injective bot"
      by simp
  next
    show "acyclic bot"
      by simp
  next
    show "bot  (component ?ss r)T * (component ?ss r)  --?ss"
      by simp
  next
    have "component ?ss r  component (r * rT) r"
      by (simp add: mult_right_isotone star_isotone)
    also have "...  rT * 1"
      using assms by (metis order.eq_iff p_antitone regular_one_closed star_sub_one prim_precondition_def)
    also have "... = rT * bot"
      by (simp add: star.circ_zero star_one)
    finally show "component ?ss r  rT * bot"
      .
  next
    show "regular bot"
      by simp
  qed
qed

lemma prim_vc_2:
  assumes "prim_spanning_invariant t v g r"
      and "v * -vT  g  bot"
    shows "prim_spanning_invariant (t  minarc (v * -vT  g)) (v  minarc (v * -vT  g)T * top) g r  card { x . regular x  x  component g r  x  -(v  minarc (v * -vT  g)T * top)T } < card { x . regular x  x  component g r  x  -vT }"
proof -
  let ?vcv = "v * -vT  g"
  let ?e = "minarc ?vcv"
  let ?t = "t  ?e"
  let ?v = "v  ?eT * top"
  let ?c = "component g r"
  let ?g = "--g"
  let ?n1 = "card { x . regular x  x  ?c  x  -vT }"
  let ?n2 = "card { x . regular x  x  ?c  x  -?vT }"
  have 1: "regular v  regular (v * vT)  regular (?v * ?vT)  regular (top * ?e)"
    using assms(1) by (metis prim_spanning_invariant_def spanning_tree_def prim_precondition_def regular_conv_closed regular_closed_star regular_mult_closed conv_involutive regular_closed_top regular_closed_sup minarc_regular)
  hence 2: "t  v * vT  ?g"
    using assms(1) by (metis prim_spanning_invariant_def spanning_tree_def inf_pp_commute inf.boundedE)
  hence 3: "t  v * vT"
    by simp
  have 4: "t  ?g"
    using 2 by simp
  have 5: "?e  v * -vT  ?g"
    using 1 by (metis minarc_below pp_dist_inf regular_mult_closed regular_closed_p)
  hence 6: "?e  v * -vT"
    by simp
  have 7: "vector v"
    using assms(1) prim_spanning_invariant_def prim_precondition_def by (simp add: covector_mult_closed vector_conv_covector)
  hence 8: "?e  v"
    using 6 by (metis conv_complement inf.boundedE vector_complement_closed vector_covector)
  have 9: "?e * t = bot"
    using 3 6 7 et(1) by blast
  have 10: "?e * tT = bot"
    using 3 6 7 et(2) by simp
  have 11: "arc ?e"
    using assms(2) minarc_arc by simp
  have "rT  rT * t"
    by (metis mult_right_isotone order_refl semiring.mult_not_zero star.circ_separate_mult_1 star_absorb)
  hence 12: "rT  vT"
    using assms(1) by (simp add: prim_spanning_invariant_def)
  have 13: "vector r  injective r  vT = rT * t"
    using assms(1) prim_spanning_invariant_def prim_precondition_def minimum_spanning_tree_def spanning_tree_def reachable_restrict by simp
  have "g = gT"
    using assms(1) prim_invariant_def prim_spanning_invariant_def prim_precondition_def by simp
  hence 14: "?gT = ?g"
    using conv_complement by simp
  show "prim_spanning_invariant ?t ?v g r  ?n2 < ?n1"
  proof (rule conjI)
    show "prim_spanning_invariant ?t ?v g r"
    proof (unfold prim_spanning_invariant_def, intro conjI)
      show "prim_precondition g r"
        using assms(1) prim_spanning_invariant_def by simp
    next
      show "?vT = rT * ?t"
        using assms(1) 6 7 9 by (simp add: reachable_inv prim_spanning_invariant_def prim_precondition_def spanning_tree_def)
    next
      let ?G = "?v * ?vT  g"
      show "spanning_tree ?t ?G r"
      proof (unfold spanning_tree_def, intro conjI)
        show "injective ?t"
          using assms(1) 10 11 by (simp add: injective_inv prim_spanning_invariant_def spanning_tree_def)
      next
        show "acyclic ?t"
          using assms(1) 3 6 7 acyclic_inv prim_spanning_invariant_def spanning_tree_def by simp
      next
        show "?t  (component ?G r)T * (component ?G r)  --?G"
          using 1 2 5 7 13 prim_subgraph_inv inf_pp_commute mst_subgraph_inv_2 by auto
      next
        show "component (?v * ?vT  g) r  rT * ?t"
        proof -
          have 15: "rT * (v * vT  ?g)  rT * t"
            using assms(1) 1 by (metis prim_spanning_invariant_def spanning_tree_def inf_pp_commute)
          have "component (?v * ?vT  g) r = rT * (?v * ?vT  ?g)"
            using 1 by simp
          also have "...  rT * ?t"
            using 2 6 7 11 12 13 14 15 by (metis span_inv)
          finally show ?thesis
            .
        qed
      next
        show "regular ?t"
          using assms(1) by (metis prim_spanning_invariant_def spanning_tree_def regular_closed_sup minarc_regular)
      qed
    qed
  next
    have 16: "top * ?e  ?c"
    proof -
      have "top * ?e = top * ?eT * ?e"
        using 11 by (metis arc_top_edge mult_assoc)
      also have "...  vT * ?e"
        using 7 8 by (metis conv_dist_comp conv_isotone mult_left_isotone symmetric_top_closed)
      also have "...  vT * ?g"
        using 5 mult_right_isotone by auto
      also have "... = rT * t * ?g"
        using 13 by simp
      also have "...  rT * ?g * ?g"
        using 4 by (simp add: mult_left_isotone mult_right_isotone star_isotone)
      also have "...  ?c"
        by (simp add: comp_associative mult_right_isotone star.right_plus_below_circ)
      finally show ?thesis
        by simp
    qed
    have 17: "top * ?e  -vT"
      using 6 7 by (simp add: schroeder_4_p vTeT)
    have 18: "¬ top * ?e  -(top * ?e)"
      by (metis assms(2) inf.orderE minarc_bot_iff conv_complement_sub_inf inf_p inf_top.left_neutral p_bot symmetric_top_closed vector_top_closed)
    have 19: "-?vT = -vT  -(top * ?e)"
      by (simp add: conv_dist_comp conv_dist_sup)
    hence 20: "¬ top * ?e  -?vT"
      using 18 by simp
    show "?n2 < ?n1"
      apply (rule psubset_card_mono)
      using finite_regular apply simp
      using 1 16 17 19 20 by auto
  qed
qed

lemma prim_vc_3:
  assumes "prim_spanning_invariant t v g r"
      and "v * -vT  g = bot"
    shows "spanning_tree t g r"
proof -
  let ?g = "--g"
  have 1: "regular v  regular (v * vT)"
    using assms(1) by (metis prim_spanning_invariant_def spanning_tree_def prim_precondition_def regular_conv_closed regular_closed_star regular_mult_closed conv_involutive)
  have 2: "v * -vT  ?g = bot"
    using assms(2) pp_inf_bot_iff pp_pp_inf_bot_iff by simp
  have 3: "vT = rT * t  vector v"
    using assms(1) by (simp add: covector_mult_closed prim_invariant_def prim_spanning_invariant_def vector_conv_covector prim_precondition_def)
  have 4: "t  v * vT  ?g"
    using assms(1) 1 by (metis prim_spanning_invariant_def inf_pp_commute spanning_tree_def inf.boundedE)
  have "rT * (v * vT  ?g)  rT * t"
    using assms(1) 1 by (metis prim_spanning_invariant_def inf_pp_commute spanning_tree_def)
  hence 5: "component g r = vT"
    using 1 2 3 4 by (metis span_post)
  have "regular (v * vT)"
    using assms(1) by (metis prim_spanning_invariant_def spanning_tree_def prim_precondition_def regular_conv_closed regular_closed_star regular_mult_closed conv_involutive)
  hence 6: "t  v * vT  ?g"
    by (metis assms(1) prim_spanning_invariant_def spanning_tree_def inf_pp_commute inf.boundedE)
  show "spanning_tree t g r"
    apply (unfold spanning_tree_def, intro conjI)
    using assms(1) prim_spanning_invariant_def spanning_tree_def apply simp
    using assms(1) prim_spanning_invariant_def spanning_tree_def apply simp
    using 5 6 apply simp
    using assms(1) 5 prim_spanning_invariant_def apply simp
    using assms(1) prim_spanning_invariant_def spanning_tree_def by simp
qed

text ‹
The following result shows that Prim's algorithm terminates and constructs a spanning tree.
We cannot yet show that this is a minimum spanning tree.
›

theorem prim_spanning:
  "VARS t v e
  [ prim_precondition g r ]
  t := bot;
  v := r;
  WHILE v * -vT  g  bot
    INV { prim_spanning_invariant t v g r }
    VAR { card { x . regular x  x  component g r  -vT } }
     DO e := minarc (v * -vT  g);
        t := t  e;
        v := v  eT * top
     OD
  [ spanning_tree t g r ]"
  apply vcg_tc_simp
  apply (simp add: prim_vc_1)
  using prim_vc_2 apply blast
  using prim_vc_3 by auto

text ‹
Because we have shown total correctness, we conclude that a spanning tree exists.
›

lemma prim_exists_spanning:
  "prim_precondition g r  t . spanning_tree t g r"
  using tc_extract_function prim_spanning by blast

text ‹
This implies that a minimum spanning tree exists, which is used in the subsequent correctness proof.
›

lemma prim_exists_minimal_spanning:
  assumes "prim_precondition g r"
    shows "t . minimum_spanning_tree t g r"
proof -
  let ?s = "{ t . spanning_tree t g r }"
  have "m?s . z?s . sum (m  g)  sum (z  g)"
    apply (rule finite_set_minimal)
    using finite_regular spanning_tree_def apply simp
    using assms prim_exists_spanning apply simp
    using sum_linear by simp
  thus ?thesis
    using minimum_spanning_tree_def by simp
qed

text ‹
Prim's minimum spanning tree algorithm terminates and is correct.
This is the same algorithm that is used in the previous correctness proof, with the same precondition and variant, but with a different invariant and postcondition.
›

theorem prim:
  "VARS t v e
  [ prim_precondition g r  (w . minimum_spanning_tree w g r) ]
  t := bot;
  v := r;
  WHILE v * -vT  g  bot
    INV { prim_invariant t v g r }
    VAR { card { x . regular x  x  component g r  -vT } }
     DO e := minarc (v * -vT  g);
        t := t  e;
        v := v  eT * top
     OD
  [ minimum_spanning_tree t g r ]"
proof vcg_tc_simp
  assume "prim_precondition g r  (w . minimum_spanning_tree w g r)"
  thus "prim_invariant bot r g r"
    using prim_invariant_def prim_vc_1 by simp
next
  fix t v
  let ?vcv = "v * -vT  g"
  let ?vv = "v * vT  g"
  let ?e = "minarc ?vcv"
  let ?t = "t  ?e"
  let ?v = "v  ?eT * top"
  let ?c = "component g r"
  let ?g = "--g"
  let ?n1 = "card { x . regular x  x  ?c  x  -vT }"
  let ?n2 = "card { x . regular x  x  ?c  x  -?vT }"
  assume 1: "prim_invariant t v g r  ?vcv  bot"
  hence 2: "regular v  regular (v * vT)"
    by (metis (no_types, opaque_lifting) prim_invariant_def prim_spanning_invariant_def spanning_tree_def prim_precondition_def regular_conv_closed regular_closed_star regular_mult_closed conv_involutive)
  have 3: "t  v * vT  ?g"
    using 1 2 by (metis (no_types, opaque_lifting) prim_invariant_def prim_spanning_invariant_def spanning_tree_def inf_pp_commute inf.boundedE)
  hence 4: "t  v * vT"
    by simp
  have 5: "t  ?g"
    using 3 by simp
  have 6: "?e  v * -vT  ?g"
    using 2 by (metis minarc_below pp_dist_inf regular_mult_closed regular_closed_p)
  hence 7: "?e  v * -vT"
    by simp
  have 8: "vector v"
    using 1 prim_invariant_def prim_spanning_invariant_def prim_precondition_def by (simp add: covector_mult_closed vector_conv_covector)
  have 9: "arc ?e"
    using 1 minarc_arc by simp
  from 1 obtain w where 10: "minimum_spanning_tree w g r  t  w"
    by (metis prim_invariant_def)
  hence 11: "vector r  injective r  vT = rT * t  forest w  t  w  w  ?cT * ?c  ?g  rT * (?cT * ?c  ?g)  rT * w"
    using 1 2 prim_invariant_def prim_spanning_invariant_def prim_precondition_def minimum_spanning_tree_def spanning_tree_def reachable_restrict by simp
  hence 12: "w * v  v"
    using predecessors_reachable reachable_restrict by auto
  have 13: "g = gT"
    using 1 prim_invariant_def prim_spanning_invariant_def prim_precondition_def by simp
  hence 14: "?gT = ?g"
    using conv_complement by simp
  show "prim_invariant ?t ?v g r  ?n2 < ?n1"
  proof (unfold prim_invariant_def, intro conjI)
    show "prim_spanning_invariant ?t ?v g r"
      using 1 prim_invariant_def prim_vc_2 by blast
  next
    show "w . minimum_spanning_tree w g r  ?t  w"
    proof
      let ?f = "w  v * -vT  top * ?e * wT"
      let ?p = "w  -v * -vT  top * ?e * wT"
      let ?fp = "w  -vT  top * ?e * wT"
      let ?w = "(w  -?fp)  ?pT  ?e"
      have 15: "regular ?f  regular ?fp  regular ?w"
        using 2 10 by (metis regular_conv_closed regular_closed_star regular_mult_closed regular_closed_top regular_closed_inf regular_closed_sup minarc_regular minimum_spanning_tree_def spanning_tree_def)
      show "minimum_spanning_tree ?w g r  ?t  ?w"
      proof (intro conjI)
        show "minimum_spanning_tree ?w g r"
        proof (unfold minimum_spanning_tree_def, intro conjI)
          show "spanning_tree ?w g r"
          proof (unfold spanning_tree_def, intro conjI)
            show "injective ?w"
              using 7 8 9 11 exchange_injective by blast
          next
            show "acyclic ?w"
              using 7 8 11 12 exchange_acyclic by blast
          next
            show "?w  ?cT * ?c  --g"
            proof -
              have 16: "w  -?fp  ?cT * ?c  --g"
                using 10 by (simp add: le_infI1 minimum_spanning_tree_def spanning_tree_def)
              have "?pT  wT"
                by (simp add: conv_isotone inf.sup_monoid.add_assoc)
              also have "...  (?cT * ?c  --g)T"
                using 11 conv_order by simp
              also have "... = ?cT * ?c  --g"
                using 2 14 conv_dist_comp conv_dist_inf by simp
              finally have 17: "?pT  ?cT * ?c  --g"
                .
              have "?e  ?cT * ?c  ?g"
                using 5 6 11 mst_subgraph_inv by auto
              thus ?thesis
                using 16 17 by simp
            qed
          next
            show "?c  rT * ?w"
            proof -
              have "?c  rT * w"
                using 10 minimum_spanning_tree_def spanning_tree_def by simp
              also have "...  rT * ?w"
                using 4 7 8 10 11 12 15 by (metis mst_reachable_inv)
              finally show ?thesis
                .
            qed
          next
            show "regular ?w"
              using 15 by simp
          qed
        next
          have 18: "?f  ?p = ?fp"
            using 2 8 epm_1 by fastforce
          have "arc (w  --v * -vT  top * ?e * wT)"
            using 5 6 8 9 11 12 reachable_restrict arc_edge by auto
          hence 19: "arc ?f"
            using 2 by simp
          hence "?f = bot  top = bot"
            by (metis mult_left_zero mult_right_zero)
          hence "?f  bot"
            using 1 le_bot by auto
          hence "?f  v * -vT  ?g  bot"
            using 2 11 by (simp add: inf.absorb1 le_infI1)
          hence "g  (?f  v * -vT)  bot"
            using inf_commute pp_inf_bot_iff by simp
          hence 20: "?f  ?vcv  bot"
            by (simp add: inf_assoc inf_commute)
          hence 21: "?f  g = ?f  ?vcv"
            using 2 by (simp add: inf_assoc inf_commute inf_left_commute)
          have 22: "?e  g = minarc ?vcv  ?vcv"
            using 7 by (simp add: inf.absorb2 inf.assoc inf.commute)
          hence 23: "sum (?e  g)  sum (?f  g)"
            using 15 19 20 21 by (simp add: minarc_min)
          have "?e  bot"
            using 20 comp_inf.semiring.mult_not_zero semiring.mult_not_zero by blast
          hence 24: "?e  g  bot"
            using 22 minarc_meet_bot by auto
          have "sum (?w  g) = sum (w  -?fp  g) + sum (?pT  g) + sum (?e  g)"
            using 7 8 10 by (metis sum_disjoint_3 epm_8 epm_9 epm_10 minimum_spanning_tree_def spanning_tree_def)
          also have "... = sum (((w  -?fp)  ?pT)  g) + sum (?e  g)"
            using 11 by (metis epm_8 sum_disjoint)
          also have "...  sum (((w  -?fp)  ?pT)  g) + sum (?f  g)"
            using 23 24 by (simp add: sum_plus_right_isotone)
          also have "... = sum (w  -?fp  g) + sum (?pT  g) + sum (?f  g)"
            using 11 by (metis epm_8 sum_disjoint)
          also have "... = sum (w  -?fp  g) + sum (?p  g) + sum (?f  g)"
            using 13 sum_symmetric by auto
          also have "... = sum (((w  -?fp)  ?p  ?f)  g)"
            using 2 8 by (metis sum_disjoint_3 epm_11 epm_12 epm_13)
          also have "... = sum (w  g)"
            using 2 8 15 18 epm_2 by force
          finally have "sum (?w  g)  sum (w  g)"
            .
          thus "u . spanning_tree u g r  sum (?w  g)  sum (u  g)"
            using 10 order_lesseq_imp minimum_spanning_tree_def by auto
        qed
      next
        show "?t  ?w"
          using 4 8 10 mst_extends_new_tree by simp
      qed
    qed
  next
    show "?n2 < ?n1"
      using 1 prim_invariant_def prim_vc_2 by auto
  qed
next
  fix t v
  let ?g = "--g"
  assume 25: "prim_invariant t v g r  v * -vT  g = bot"
  hence 26: "regular v"
    by (metis prim_invariant_def prim_spanning_invariant_def spanning_tree_def prim_precondition_def regular_conv_closed regular_closed_star regular_mult_closed conv_involutive)
  from 25 obtain w where 27: "minimum_spanning_tree w g r  t  w"
    by (metis prim_invariant_def)
  have "spanning_tree t g r"
    using 25 prim_invariant_def prim_vc_3 by blast
  hence "component g r = vT"
    by (metis 25 prim_invariant_def span_tree_component prim_spanning_invariant_def spanning_tree_def)
  hence 28: "w  v * vT"
    using 26 27 by (simp add: minimum_spanning_tree_def spanning_tree_def inf_pp_commute)
  have "vector r  injective r  forest w"
    using 25 27 by (simp add: prim_invariant_def prim_spanning_invariant_def prim_precondition_def minimum_spanning_tree_def spanning_tree_def)
  hence "w = t"
    using 25 27 28 prim_invariant_def prim_spanning_invariant_def mst_post by blast
  thus "minimum_spanning_tree t g r"
    using 27 by simp
qed

end

end