theory Desargues_2D
  imports Main Higher_Projective_Space_Rank_Axioms Matroid_Rank_Properties
begin

(* Author: Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk .*)

text \<open>
Contents:
\<^item> We prove Desargues's theorem: if two triangles ABC and A'B'C' are perspective from a point P (ie.
the lines AA', BB' and CC' are concurrent in P), then they are perspective from a line (ie. the points
\<open>\<alpha> = BC \<inter> B'C'\<close>, \<open>\<beta> = AC \<inter> A'C'\<close> and \<open>\<gamma> = AB \<inter> A'B'\<close> are collinear).
In this file we restrict ourself to the case where the two triangles ABC and A'B'C' are coplanar.
\<close>

section \<open>Desargues's Theorem: The Coplanar Case\<close>

context higher_projective_space_rank
begin

definition desargues_config_2D ::
  "['point, 'point, 'point, 'point, 'point, 'point, 'point, 'point, 'point, 'point] \<Rightarrow> bool"
  where "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma> \<equiv> rk {A, B, C} = 3 \<and> rk {A', B', C'} = 3 \<and>
rk {A, A', P} = 2 \<and> rk {B, B', P} = 2 \<and> rk {C, C', P} = 2 \<and> rk {A, B, \<gamma>} = 2 \<and> rk {A', B', \<gamma>} = 2 \<and>
rk {A, C, \<beta>} = 2 \<and> rk {A', C', \<beta>} = 2 \<and> rk {B, C, \<alpha>} = 2 \<and> rk {B', C', \<alpha>} = 2 \<and>
rk {A, B, C, A', B', C'} = 3 \<and>
\<comment> \<open>We add the following non-degeneracy conditions\<close>
rk {A, B, P} = 3 \<and> rk {A, C, P} = 3 \<and> rk {B, C, P} = 3 \<and>
rk {A, A'} = 2 \<and> rk {B, B'} = 2 \<and> rk {C, C'} = 2"

lemma coplanar_ABCA'B'C'P :
  assumes "rk {A, A'} = 2" and "rk {A, B, C, A', B', C'} = 3" and "rk {A, A', P} = 2"
  shows "rk {A, B, C, A', B', C', P} = 3"
proof-
  have "rk {A, B, C, A', B', C', P} + rk {A, A'} \<le> rk {A, B, C, A', B', C'} + rk {A, A', P}"
    using matroid_ax_3_alt[of "{A, A'}" "{A, B, C, A', B', C'}" "{A, A', P}"]
    by (simp add: insert_commute)
  then have "rk {A, B, C, A', B', C', P} \<le> 3"
    using assms(1) assms(2) assms(3)
    by linarith
  then show "rk {A, B, C, A', B', C', P} = 3"
    using assms(2) matroid_ax_2
    by (metis Un_insert_right Un_upper2 le_antisym sup_bot.right_neutral)
qed

lemma non_colinear_A'B'P :
  assumes "rk {A, B, P} = 3" and "rk {A, A', P} = 2" and "rk {B, B', P} = 2" and "rk {A', P} = 2"
and "rk {B', P} = 2"
  shows "rk {A', B', P} = 3"
proof-
  have f1:"rk {A', B', P} \<le> 3"
    using rk_triple_le by auto
  have "rk {A, B, A', B', P} \<ge> 3"
    using assms(1) matroid_ax_2
    by (metis insert_mono insert_subset subset_insertI)
  then have f2:"rk {A, B, A', B', P} = 3"
    using matroid_ax_3_alt[of "{P}" "{A, A', P}" "{B, B', P}"] assms(2) assms(3)
    by (simp add: insert_commute rk_singleton)
  have "rk {A, B, A', B', P} + rk {B', P} \<le> rk {A, A', B', P} + rk {B, B', P}"
    using matroid_ax_3_alt[of "{B', P}" "{A, A', B', P}" "{B, B', P}"]
    by (simp add: insert_commute)
  then have "rk {A, A', B', P} \<ge> 3"
    using f2 assms(3) assms(5) by linarith
  then have f3:"rk {A, A', B', P} = 3"
    using f2 matroid_ax_2
    by (metis eq_iff insert_commute subset_insertI)
  have "rk {A, A', B', P} + rk {A', P} \<le> rk {A', B', P} + rk {A, A', P}"
    using matroid_ax_3_alt[of "{A', P}" "{A', B', P}" "{A, A', P}"]
    by (simp add: insert_commute)
  then have "rk {A', B', P} \<ge> 3"
    using f3 assms(2) assms(4) by linarith
  thus "rk {A', B', P} = 3"
    using f1 by auto
qed

lemma desargues_config_2D_non_collinear_P :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A', P} = 2" and "rk {B', P} = 2"
and "rk {C', P} = 2"
  shows "rk {A', B', P} = 3" and "rk {A', C', P} = 3" and "rk {B', C', P} = 3"
proof-
  show "rk {A', B', P} = 3"
    using non_colinear_A'B'P assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(2)
      assms(3)
    by blast
  show "rk {A', C', P} = 3"
    using non_colinear_A'B'P assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(2)
      assms(4)
    by blast
  show "rk {B', C', P} = 3"
    using non_colinear_A'B'P assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(3)
      assms(4)
    by blast
qed

lemma rk_A'B'PQ :
  assumes "rk {A, A'} = 2" and "rk {A, B, C, A', B', C'} = 3" and "rk {A, A', P} = 2" and
"rk {A, B, P} = 3" and "rk {B, B', P} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and
"rk {A, B, C, A', B', C', P, Q} \<ge> 4"
  shows "rk {A', B', P, Q} = 4"
proof-
  have "card {A', B', P, Q} \<le> 4"
    by (smt One_nat_def Suc_numeral card.insert card.empty finite.emptyI finite_insert insert_absorb
        insert_not_empty linear nat_add_left_cancel_le numeral_3_eq_3 numeral_Bit0 numeral_code(3)
        numeral_le_one_iff numerals(1) one_plus_numeral semiring_norm(4) semiring_norm(69)
        semiring_norm(70) semiring_norm(8))
  then have f1:"rk {A', B', P, Q} \<le> 4"
    using matroid_ax_1b dual_order.trans by blast
  have "rk {A, B, C, A', B', C', P, Q} + rk {A', B', P} \<le> rk {A', B', P, Q} + rk {A, B, C, A', B', C', P}"
    using matroid_ax_3_alt[of "{A', B', P}" "{A', B', P, Q}" "{A, B, C, A', B', C', P}"]
    by (simp add: insert_commute)
  then have "rk {A', B', P, Q} \<ge> rk {A, B, C, A', B', C', P, Q} + rk {A', B', P} - rk {A, B, C, A', B', C', P}"
    using le_diff_conv
    by blast
  then have f2:"rk {A', B', P, Q} \<ge> 4"
    using assms non_colinear_A'B'P coplanar_ABCA'B'C'P
    by (smt diff_add_inverse2 le_trans)
  from f1 and f2 show "rk {A', B', P, Q} = 4"
    by (simp add: f1 eq_iff)
qed

lemma desargues_config_2D_rkA'B'PQ_rkA'C'PQ_rkB'C'PQ :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A', P} = 2" and "rk {B', P} = 2"
and "rk {C', P} = 2" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
  shows "rk {A', B', P, Q} = 4" and "rk {A', C', P, Q} = 4" and "rk {B', C', P, Q} = 4"
proof-
  show "rk {A', B', P, Q} = 4"
    using rk_A'B'PQ[of "A" "A'" "B" "C" "B'" "C'" "P" "Q"] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(2) assms(3) assms(5)
    by blast
  show "rk {A', C', P, Q} = 4"
    using rk_A'B'PQ[of "A" "A'" "C" "B" "C'" "B'" "P" "Q"] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(2) assms(4) assms(5)
    by (metis insert_commute)
  show "rk {B', C', P, Q} = 4"
    using rk_A'B'PQ[of "B" "B'" "C" "A" "C'" "A'" "P" "Q"] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(3) assms(4) assms(5)
    by (metis insert_commute)
qed

lemma rk_A'B'PR :
  assumes "rk {P, Q, R} = 2" and "rk {P, R} = 2" and "rk {A', B', P, Q} = 4"
shows "rk {A', B', P, R} = 4"
proof-
  have "card {A', B', P, R} \<le> 4"
    by (smt Suc_numeral assms(2) card.empty card_insert_disjoint dual_order.trans finite.emptyI
        finite_insert insert_absorb linear nat_add_left_cancel_le numeral_2_eq_2 numeral_3_eq_3
        numeral_Bit0 numeral_code(3) numeral_le_one_iff rk_singleton rk_triple_le semiring_norm(2)
        semiring_norm(69) semiring_norm(8))
  then have f1:"rk {A', B', P, R} \<le> 4"
    using dual_order.trans matroid_ax_1b
    by auto
  have f2:"rk {A', B', P, Q, R} + rk {P, R} \<le> rk {A', B', P, R} + rk {P, Q, R}"
    using matroid_ax_3_alt[of "{P, R}" "{A', B', P, R}" "{P, Q, R}"]
    by (simp add: insert_commute)
  have f3:"rk {A', B', P, Q, R} \<ge> 4"
    using matroid_ax_2 assms(3)
    by (metis insert_mono subset_insertI)
  from f2 and f3 have f4:"rk {A', B', P, R} \<ge> 4"
    using assms(1) assms(2)
    by linarith
  thus "rk {A', B', P, R} = 4"
    using f1 f4
    by (simp add: f1 le_antisym)
qed

lemma rk_A'C'PR :
  assumes "rk {P, Q, R} = 2" and "rk {P, R} = 2" and "rk {A', C', P, Q} = 4"
  shows "rk {A', C', P, R} = 4"
  using assms(1) assms(2) assms(3) rk_A'B'PR
  by blast

lemma rk_B'C'PR :
  assumes "rk {P, Q, R} = 2" and "rk {P, R} = 2" and "rk {B', C', P, Q} = 4"
  shows "rk {B', C', P, R} = 4"
  using assms(1) assms(2) assms(3) rk_A'C'PR
  by blast

lemma rk_ABA' :
  assumes "rk {A, B, P} = 3" and "rk {A, A'} = 2" and "rk {A, A', P} = 2"
  shows "rk {A, B, A'} = 3"
proof-
  have "rk {A, B, A', P} + rk {A, A'} \<le> rk {A, B, A'} + rk {A, A', P}"
    using matroid_ax_3_alt[of "{A, A'}" "{A, B, A'}" "{A, A', P}"]
    by (simp add: insert_commute)
  then have "rk {A, B, A'} \<ge> 3"
    using assms matroid_ax_2
    by (smt eq_iff insert_absorb2 insert_commute non_colinear_A'B'P rk_couple)
  thus "rk {A, B, A'} = 3"
    by (simp add: le_antisym rk_triple_le)
qed

lemma desargues_config_2D_non_collinear :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, A'} = 3" and "rk {A, B, B'} = 3" and "rk {A, C, C'} = 3"
proof-
  show "rk {A, B, A'} = 3"
    using assms desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] rk_ABA'
    by auto
  show "rk {A, B, B'} = 3"
    using assms desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] rk_ABA'
    by (smt insert_commute)
  show "rk {A, C, C'} = 3"
    using assms desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] rk_ABA'
    by (smt insert_commute)
qed

lemma rk_Aa :
  assumes "rk {A, B, P} = 3" and "rk {A, A'} = 2" and "rk {A, A', P} = 2" and "rk {Q, A', a} = 2"
and "rk {A, B, C, A', B', C', P, Q} \<ge> 4" and "rk {A, B, C, A', B', C'} \<le> 3"
  shows "rk {A, a} = 2"
proof-
  have "rk {Q, A', A, a} + rk {a} \<le> rk {Q, A', a} + rk {A, a}"
    using matroid_ax_3_alt[of "{a}" "{Q, A', a}" "{A, a}"]
    by (simp add: insert_commute)
  then have "rk {Q, A', A, a} \<le> rk {Q, A', a} + rk {A, a} - rk {a}"
    using add_le_imp_le_diff
    by blast
  then have "rk {Q, A', A, a} \<le> 2" if "rk {A, a} = 1"
    using assms(4)
    by (simp add: rk_singleton that)
  then have "rk {Q, A', A} \<le> 2" if "rk {A, a} = 1"
    using matroid_ax_2
    by (metis One_nat_def assms(4) le_numeral_extra(4) nat_add_left_cancel_le numeral_2_eq_2
        numeral_3_eq_3 one_add_one rk_couple rk_triple_le that)
  then have "rk {Q, A', A} = 2" if "rk {A, a} = 1"
    using assms(2) matroid_ax_2
    by (metis assms(4) numeral_eq_one_iff rk_couple semiring_norm(85) that)
  then have "rk {A, A', P, Q} = 2" if "rk {A, a} = 1"
    using assms(3) matroid_ax_3_alt'[of "{A, A'}" "P" "Q"]
    by (simp add: assms(2) insert_commute that)
  then have f1:"rk {A, A', B, P, Q} \<le> 3" if "rk {A, a} = 1"
    by (metis One_nat_def Un_insert_right add.right_neutral add_Suc_right insert_commute matroid_ax_2_alt
        numeral_2_eq_2 numeral_3_eq_3 sup_bot.right_neutral that)
  have "rk {A, B, C, A', B', C', P, Q} + rk {A, B, A'} \<le> rk {A, A', B, P, Q} + rk {A, B, C, A', B', C'}"
    using matroid_ax_3_alt[of "{A, B, A'}" "{A, A', B, P, Q}" "{A, B, C, A', B', C'}"]
    by (simp add: insert_commute)
  then have "rk {A, B, C, A', B', C', P, Q} \<le> rk {A, A', B, P, Q} + rk {A, B, C, A', B', C'} - rk {A, B, A'}"
    by linarith
  then have "rk {A, B, C, A', B', C', P, Q} \<le> 3" if "rk {A, a} = 1"
    using assms(1) assms(2) assms(3) assms(6) f1 rk_ABA'
    by (smt \<open>rk {A, B, C, A', B', C', P, Q} + rk {A, B, A'} \<le> rk {A, A', B, P, Q} + rk {A, B, C, A', B', C'}\<close>
        add_diff_cancel_right' add_leD2 le_less_trans not_le
        ordered_cancel_comm_monoid_diff_class.add_diff_inverse
        ordered_cancel_comm_monoid_diff_class.le_add_diff that)
  then have "\<not> (rk {A, a} = 1)"
    using assms(5)
    by linarith
  thus "rk {A, a} = 2"
    using rk_couple rk_singleton_bis
    by blast
qed

lemma desargues_config_2D_rkAa_rkBb_rkCc :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {Q, A', a} = 2" and "rk {Q, B', b} = 2" and "rk {Q, C', c} = 2"
  shows "rk {A, a} = 2" and "rk {B, b} = 2" and "rk {C, c} = 2"
proof-
  show "rk {A, a} = 2"
    using rk_Aa assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(2) assms(3)
    by (metis rk_triple_le)
  show "rk {B, b} = 2"
    using rk_Aa assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(2) assms(4)
    by (smt insert_commute rk_triple_le)
  show "rk {C, c} = 2"
    using rk_Aa[of "C" "A" "P" "C'" "Q" "c" "B" "B'" "A'"] assms(1)
      desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(2) assms(5)
    by (metis insert_commute rk_triple_le)
qed

lemma rk_ABPRa :
  assumes "rk {A, B, P} = 3" and "rk {A, B, C, A', B', C', P} = 3" and "rk {P, Q, R} = 2"
and "rk {P, R} = 2" and "rk {A', B', P, Q} = 4"
  shows "rk {A, B, P, R, a} \<ge> 4"
proof-
  have "rk {A', B', P, R, a, A, B} \<ge> rk {A', B', P, R}"
    using matroid_ax_2
    by auto
  then have f1:"rk {A', B', P, R, a, A, B} \<ge> 4"
    using rk_A'B'PR assms(3) assms(4) assms(5)
    by auto
  have f2:"rk {A', B', A, B, P} \<le> 3"
    using matroid_ax_2 assms(2)
    by (smt insertI1 insert_subset subset_insertI)
  have "rk {A', B', P, R, a, A, B} + rk {A, B, P} \<le> rk {A, B, P, R, a} + rk {A', B', A, B, P}"
    using matroid_ax_3_alt[of "{A, B, P}" "{A, B, P, R, a}" "{A', B', A, B, P}"]
    by (simp add: insert_commute)
  then have "rk {A, B, P, R, a} \<ge> rk {A', B', P, R, a, A, B} + rk {A, B, P} - rk {A', B', A, B, P}"
    by linarith
  thus "rk {A, B, P, R, a} \<ge> 4"
    using f1 assms(1) f2
    by linarith
qed

lemma rk_ABPa :
  assumes "rk {A, B, P} = 3" and "rk {A, A'} = 2" and "rk {A, A', P} = 2" and "rk {Q, A', a} = 2"
and "rk {A, B, C, A', B', C', P, Q} \<ge> 4" and "rk {A, B, C, A', B', C', P} = 3" and "rk {P, Q, R} = 2"
and "rk {P, R} = 2" and "rk {A', B', P, Q} = 4" and "rk {R, A, a} = 2"
  shows "rk {A, B, P, a} \<ge> 4"
proof-
  have "rk {A, B, C, A', B', C'} \<le> 3"
    using matroid_ax_2 assms(6)
    by (smt insert_iff subsetI)
  then have f1:"rk {A, a} = 2"
    using assms(1) assms(2) assms(3) assms(4) assms(5) rk_Aa
    by blast
  have f2:"rk {A, B, P, R, a} \<ge> 4"
    using assms(1) assms(6) assms(7) assms(8) assms(9) rk_ABPRa
    by blast
  have "rk {A, B, P, R, a} + rk {A, a} \<le> rk {A, B, P, a} + rk {R, A, a}"
    using matroid_ax_3_alt[of "{A, a}" "{A, B, P, a}" "{R, A, a}"]
    by (simp add: insert_commute)
  thus "rk {A, B, P, a} \<ge> 4"
    using f1 f2 assms(10)
    by (smt add_le_imp_le_diff diff_add_inverse2 order_trans)
qed

lemma desargues_config_2D_rkABPa_rkABPb_rkABPc :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {P, Q, R} = 2" and "rk {P, R} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and
"rk {Q, A', a} = 2" and "rk {R, A, a} = 2" and "rk {Q, B', b} = 2" and "rk {R, B, b} = 2" and
"rk {Q, C', c} = 2" and "rk {R, C, c} = 2"
  shows "rk {A, B, P, a} \<ge> 4" and "rk {A, B, P, b} \<ge> 4" and "rk {A, B, P, c} \<ge> 4"
proof-
  have f1:"rk {A, B, C, A', B', C', P} = 3"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_ABCA'B'C'P
    by auto
  have f2:"rk {A', B', P, Q} = 4"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(2) assms(5) assms(6)
      rk_A'B'PQ[of "A" "A'" "B" "C" "B'" "C'" "P" "Q"]
    by auto
  show "rk {A, B, P, a} \<ge> 4"
    using f1 f2 assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(7) assms(2) assms(3)
      assms(4) assms(8) rk_ABPa
    by auto
  show "rk {A, B, P, b} \<ge> 4"
    using f1 f2 assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(9) assms(2) assms(3)
      assms(4) assms(10) rk_ABPa[of "B" "A" "P" "B'" "Q" "b" "C" "A'" "C'" "R"]
    by (metis insert_commute)
  show "rk {A, B, P, c} \<ge> 4"
  proof-
    have f3:"rk {A, B, P, R, c} \<ge> 4"
      using rk_ABPRa[of A B P C A' B' C' Q R c] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
        f1 assms(3) assms(4) f2
      by auto
    have "{A, B, P, R, c} \<subseteq> {A, B, C, P, R, c}"
      by auto
    then have f4:"rk {A, B, C, P, R, c} \<ge> 4"
      using matroid_ax_2 f3
      by (meson dual_order.trans)
    have "rk {A, B, C, P, R, c} + rk {C, c} \<le> rk {A, B, C, P, c} + rk {R, C, c}"
      using matroid_ax_3_alt[of "{C,c}" "{A, B, C, P, c}" "{R, C, c}"]
      by (simp add: insert_commute)
    then have f5:"rk {A, B, C, P, c} \<ge> 4"
      using f4 assms(12) desargues_config_2D_rkAa_rkBb_rkCc assms(1) assms(9) assms(11) assms(2) assms(7)
      by auto
    have f6:"rk {A, B, C, P} \<le> 3"
      using matroid_ax_2 f1
      by (smt insert_iff subsetI)
    have "rk {A, B, C, P, c} + rk {A, B, P} \<le> rk {A, B, P, c} + rk {A, B, C, P}"
      using matroid_ax_3_alt[of "{A, B, P}" "{A, B, P, c}" "{A, B, C, P}"]
      by (simp add: insert_commute)
    then have "rk {A, B, P, c} \<ge> rk {A, B, C, P, c}"
      using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] f6
      by linarith
    thus "rk {A, B, P, c} \<ge> 4"
      using f5
      by linarith
  qed
qed

lemma rk_AA'C :
  assumes "rk {A, C, P} = 3" and "rk {A, A'} = 2" and "rk {A, A', P} = 2"
  shows "rk {A, A', C} \<ge> 3"
proof-
  have f1:"rk {A, C, A', P} \<ge> 3"
    using assms(1) matroid_ax_2
    by (metis insert_commute subset_insertI)
  have "rk {A, C, A', P} + rk {A, A'} \<le> rk {A, A', C} + rk {A, A', P}"
    using matroid_ax_3_alt[of "{A, A'}" "{A, A', C}" "{A, A', P}"]
    by (simp add: insert_commute)
  thus "rk {A, A', C} \<ge> 3"
    using f1 assms(2) assms(3)
    by linarith
qed

lemma rk_AA'C' :
  assumes "rk {A', C', P} = 3" and "rk {A, A'} = 2" and "rk {A, A', P} = 2"
  shows "rk {A, A', C'} \<ge> 3"
  by (smt assms(1) assms(2) assms(3) insert_commute rk_AA'C)

lemma rk_AA'Ca :
  assumes "rk {A, A', C} \<ge> 3" and "rk {A, B, P, a} \<ge> 4" and "rk {A, B, C, A', B', C', P} = 3"
  shows "rk {A, A', C, a} \<ge> 4"
proof-
  have f1:"rk {A, A', C, a, B, P} \<ge> 4"
    using assms(2) matroid_ax_2
    by (smt dual_order.trans insert_commute insert_mono insert_subset subset_insertI)
  have f2:"rk {A, B, C, P, A'} \<le> 3"
    using assms(3) matroid_ax_2
    by (smt empty_subsetI insert_commute insert_mono semiring_norm(3))
  have "rk {A, A', C, a, B, P} + rk {A, A', C} \<le> rk {A, A', C, a} + rk {A, B, C, P, A'}"
    using matroid_ax_3_alt[of "{A, A', C}" "{A, A', C, a}" "{A, B, C, P, A'}"]
    by (simp add: insert_commute)
  then have "rk {A, A', C, a} \<ge> rk {A, A', C, a, B, P} + rk {A, A', C} - rk {A, B, C, P, A'}"
    using le_diff_conv
    by blast
  thus "rk {A, A', C, a} \<ge> 4"
    using f1 assms(1) f2
    by linarith
qed

lemma rk_AA'C'a :
  assumes "rk {A, A', C'} \<ge> 3" and "rk {A, B, P, a} \<ge> 4" and "rk {A, B, C, A', B', C', P} = 3"
  shows "rk {A, A', C', a} \<ge> 4"
  by (smt assms(1) assms(2) assms(3) insert_commute rk_AA'Ca)

lemma rk_Ra :
  assumes "rk {Q, A', a} = 2" and "rk {P, Q, R} = 2" and "rk {R, Q} = 2" and "rk {A, A', P} = 2"
and "rk {A', P} = 2" and "rk {A, B, C, A', B', C', P} = 3" and "rk {A, B, A'} = 3" and
"rk {A, B, C, A', B', C', P, Q} \<ge> 4"
  shows "rk {R, a} = 2"
proof-
  have "R = a" if "rk {R, a} = 1"
    using rk_couple_to_singleton
    by (simp add: that)
  then have "rk {R, Q, A'} = 2" if "rk {R, a} = 1"
    using assms(1)
    by (simp add: insert_commute that)
  then have f1:"rk {P, Q, R, A'} = 2" if "rk {R, a} = 1"
    using assms(2) assms(3) matroid_ax_3_alt'
    by (metis Un_empty_right Un_insert_right insert_commute that)
  have "rk {P, Q, R, A', A} + rk {A', P} \<le> rk {A, A', P} + rk {P, Q, R, A'}"
    using matroid_ax_3_alt[of "{A', P}" "{A, A', P}" "{P, Q, R, A'}"]
    by (simp add: insert_commute)
  then have "rk {P, Q, R, A', A} = 2" if "rk {R, a} = 1"
    using assms(4) f1 assms(5)
    by (metis Un_insert_right add_le_cancel_right insert_is_Un le_antisym matroid_ax_2 subset_insertI that)
  then have f2:"rk {P, Q, R, A', A, B} \<le> 3" if "rk {R, a} = 1"
    using matroid_ax_2_alt[of "{P, Q, R, A', A}" "B"]
    by (simp add: insert_commute that)
  have f3:"rk {A, B, A', P} \<ge> 3"
    using assms(7) matroid_ax_2
    by (metis insert_commute subset_insertI)
  have "rk {P, Q, R, A', A, B, C, B', C'} + rk {A, B, A', P} \<le> rk {P, Q, R, A', A, B} + rk {A, B, C, A', B', C', P}"
    using matroid_ax_3_alt[of "{A, B, A', P}" "{P, Q, R, A', A, B}" "{A, B, C, A', B', C', P}"]
    by (simp add: insert_commute)
  then have f4:"rk {P, Q, R, A', A, B, C, B', C'} \<le> 3" if "rk {R, a} = 1"
    using f2 f3 assms(6) that
    by linarith
  have f5:"rk {P, Q, R, A', A, B, C, B', C'} \<ge> rk {A, B, C, A', B', C', P, Q}"
    using matroid_ax_2
    by auto
  thus "rk {R, a} = 2" using f4 f5 assms(8)
    by (smt Suc_1 Suc_le_eq add_Suc add_Suc_right nat_1_add_1 not_le numeral_2_eq_2 numeral_3_eq_3
        numeral_Bit0 order.trans rk_couple rk_singleton_bis)
qed

lemma desargues_config_2D_rkRa_rkRb_rkRc :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {P, Q, R} = 2" and "rk {Q, R} = 2" and "rk {Q, A', a} = 2" and "rk {Q, B', b} = 2" and
"rk {Q, C', c} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and "rk {C', P} = 2"
  shows "rk {R, a} = 2" and "rk {R, b} = 2" and "rk {R, c} = 2"
proof-
  have f1:"rk {A, B, C, A', B', C', P} = 3"
    using coplanar_ABCA'B'C'P assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by blast
  have f2:"rk {A, B, A'} = 3"
    using desargues_config_2D_non_collinear assms(1)
    by auto
  have f3:"rk {A, B, B'} = 3"
    using desargues_config_2D_non_collinear assms(1)
    by auto
  have f4:"rk {A, C, C'} = 3"
    using desargues_config_2D_non_collinear assms(1)
    by auto
  show "rk {R, a} = 2"
    using f1 f2 rk_Ra[of Q A' a P R A B C B' C'] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(2) assms(3) assms(4) assms(5) assms(8)
    by (metis insert_commute)
  show "rk {R, b} = 2"
    using f1 f3 rk_Ra[of Q B' b P R B A C A' C'] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(2) assms(3) assms(4) assms(6) assms(9)
    by (metis insert_commute)
  show "rk {R, c} = 2"
    using f1 f4 rk_Ra[of Q C' c P R C A B A' B'] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(2) assms(3) assms(4) assms(7) assms(10)
    by (metis insert_commute)
qed

lemma rk_acAC\<beta> :
  assumes "rk {R, A, a} = 2" and "rk {R, C, c} = 2" and "rk {A, C} = 2" and "rk {A, C, \<beta>} = 2"
and "rk {Q, A', a} = 2" and "rk {A, A', C, a} \<ge> 4"
  shows "rk {a, c, A, C, \<beta>} = 3"
proof-
  have "rk {a, c, A, C, R} + rk {R} \<le> rk {R, A, a} + rk {R, C, c}"
    using matroid_ax_3_alt[of "{R}" "{R, A, a}" "{R, C, c}"]
    by (simp add: insert_commute)
  then have f1:"rk {a, c, A, C, R} \<le> 3"
    using assms(1) assms(2)
    by (metis Suc_1 Suc_eq_plus1 Suc_le_mono add_Suc_right numeral_3_eq_3 numeral_nat(1) numerals(1)
        rk_singleton)
  have "rk {a, c, A, C, R, \<beta>} + rk {A, C} \<le> rk {a, c, A, C, R} + rk {A, C, \<beta>}"
    using matroid_ax_3_alt[of "{A, C}" "{a, c, A, C, R}" "{A, C, \<beta>}"]
    by (simp add: insert_commute)
  then have f2:"rk {a, c, A, C, R, \<beta>} \<le> 3"
    using f1 assms(3) assms(4)
    by linarith
  have "{a, c, A, C, \<beta>} \<subseteq> {a, c, A, C, R, \<beta>}"
    by auto
  then have f3:"rk {a, c, A, C, \<beta>} \<le> 3"
    using matroid_ax_2 f2
    by (meson order_trans)
  have f4:"rk {A, A', C, a, c, Q} \<ge> 4"
    using matroid_ax_2 assms(6)
    by (smt dual_order.trans insert_commute insert_mono insert_subset subset_insertI)
  have "rk {A, A', C, a, c, Q} + rk {a} \<le> rk {a, c, A, C} + rk {Q, A', a}"
    using matroid_ax_3_alt[of "{a}" "{a, c, A, C}" "{Q, A', a}"]
    by (simp add: insert_commute)
  then have "rk {a, c, A, C} \<ge> rk {A, A', C, a, c, Q} + rk {a} - rk {Q, A', a}"
    using le_diff_conv
    by blast
  then have "rk {a, c, A, C} \<ge> 3"
    using f4 assms(5)
    by (smt One_nat_def \<open>rk {A, A', C, a, c, Q} + rk {a} \<le> rk {a, c, A, C} + rk {Q, A', a}\<close>
        ab_semigroup_add_class.add_ac(1) add_2_eq_Suc' add_diff_cancel_right' add_le_imp_le_diff
        card.empty card.insert dual_order.antisym finite.intros(1) insert_absorb insert_not_empty
        matroid_ax_1b nat_1_add_1 numeral_3_eq_3 numeral_Bit0 order.trans rk_ax_singleton)
  then have "rk {a, c, A, C, \<beta>} \<ge> 3"
    using matroid_ax_2
    by (metis Un_insert_right Un_upper2 dual_order.trans sup_bot.comm_neutral)
  thus "rk {a, c, A, C, \<beta>} = 3"
    using f3 le_antisym
    by blast
qed

lemma rk_acA'C'\<beta> :
  assumes "rk {Q, A', a} = 2" and "rk {Q, C', c} = 2" and "rk {A', C'} = 2" and "rk {A', C', \<beta>} = 2"
and "rk {R, A, a} = 2" and "rk {A', A, C', a} \<ge> 4"
  shows "rk {a, c, A', C', \<beta>} = 3"
  using assms rk_acAC\<beta>
  by blast

lemma plane_representation_change :
  assumes "rk {A, B, C, P} = 3" and "rk {B, C, P} = 3" and "rk {A, B, C, Q} = 4"
  shows "rk {P, B, C, Q} = 4"
proof-
  have "rk {P, B, C, Q} \<le> 4" using assms(2) matroid_ax_2_alt[of "{B, C, P}" "Q"]
    by (simp add: insert_commute)
  have "rk {A, B, C, Q, P} + rk {B, C, P} \<le> rk {P, B, C, Q} + rk {A, B, C, P}"
    using matroid_ax_3_alt[of "{B, C, P}" "{P, B, C, Q}" "{A, B, C, P}"]
    by (simp add: insert_commute)
  then have "rk {P, B, C, Q} \<ge> 4"
    using assms
    by (smt add.commute dual_order.trans insert_commute matroid_ax_2 nat_add_left_cancel_le
        subset_insertI)
  thus "rk {P, B, C, Q} = 4"
    by (simp add: \<open>rk {P, B, C, Q} \<le> 4\<close> antisym)
qed

lemma desargues_config_2D_rkABCP :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {A, B, C, P} = 3"
proof-
  have "rk {A, B, C} = 3"
    using assms desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by auto
  then have f1:"rk {A, B, C, P} \<ge> 3"
    using matroid_ax_2
    by (metis empty_subsetI insert_mono)
  have f2:"rk {A, B, C, A', B', C', P} = 3"
    using assms desargues_config_2D_def[of A B C A' B' C' P] coplanar_ABCA'B'C'P
    by auto
  have "{A, B, C, P} \<subseteq> {A, B, C, A', B', C', P}"
    by auto
  then have "rk {A, B, C, P} \<le> 3"
    using matroid_ax_2 f2
    by metis
  thus "rk {A, B, C, P} = 3"
    using f1 antisym
    by blast
qed

lemma desargues_config_2D_rkABCabc :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {Q, A', a} = 2" and "rk {P, Q, R} = 2" and "rk {P, R} = 2" and "rk {R, A, a} = 2" and
"rk {A', P} = 2" and "rk {B', P} = 2"
  shows "rk {A, B, C, a, b, c} \<ge> 4"
proof-
  have f1:"rk {A, B, C, A', B', C', P} = 3"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_ABCA'B'C'P
    by auto
  have f2:"rk {A', B', P, Q} = 4"
    using rk_A'B'PQ[of A A' B C B' C' P Q] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(2) assms(7) assms(8)
    by auto
  from f1 and f2 have f3:"rk {A, B, P, a} \<ge> 4"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(2) assms(3) assms(4)
      assms(5) assms(6) rk_ABPa
    by auto
  have "{A, B, P, a} \<subseteq> {A, B, C, a, b, c, P}"
    by auto
  then have f4:"rk {A, B, C, a, b, c, P} \<ge> 4"
    using matroid_ax_2 f3
    by (meson dual_order.trans)
  have f5:"rk {A, B, C, P} = 3"
    using assms(1) desargues_config_2D_rkABCP
    by auto
  have "rk {A, B, C, a, b, c, P} + rk {A, B, C} \<le> rk {A, B, C, a, b, c} + rk {A, B, C, P}"
    using matroid_ax_3_alt[of "{A, B, C}" "{A, B, C, a, b, c}" "{A, B, C, P}"]
    by (simp add: insert_commute)
  thus "rk {A, B, C, a, b, c} \<ge> 4"
    using f4 assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] f5
    by linarith
qed

lemma rk_abc :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {Q, A', a} = 2" and "rk {Q, B', b} = 2" and "rk {Q, C', c} = 2" and "rk {P, Q, R} = 2" and
"rk {P, R} = 2" and "rk {Q, R} = 2" and "rk {R, A, a} = 2" and "rk {R, B, b} = 2" and
"rk {R, C, c} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and "rk {C', P} = 2"
  shows "rk {a, b, c} = 3"
proof-
  have "rk {a, b, c} \<le> 3"
    by (simp add: rk_triple_le)
  have "rk {A, B, C, a, b, c} \<ge> 4"
    using desargues_config_2D_rkABCabc assms(1) assms(13) assms(2) assms(3) assms(6) assms(7) assms(9)
      assms(12)
    by auto
  then have f1:"rk {A, B, C, R, a, b, c} \<ge> 4"
    using matroid_ax_2
    by (smt dual_order.trans insert_commute subset_insertI)
  have f2:"rk {A, B, C, A', B', C', P} = 3"
    using coplanar_ABCA'B'C'P assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by auto
  have f3:"rk {A, C, C'} = 3"
    using assms(1) desargues_config_2D_non_collinear(3)
    by auto
  from f2 and f3 have f4:"rk {R, c} = 2"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] assms(2) assms(5) assms(6)
      assms(8) assms(14) rk_Ra[of Q C' c P R C A B A' B']
    by (metis insert_commute)
  have "rk {A, B, C, R, a, b, c} + rk {R, c} \<le> rk {a, b, c, R, A, B} + rk {R, C, c}"
    using matroid_ax_3_alt[of "{R, c}" "{a, b, c, R, A, B}" "{R, C, c}"]
    by (simp add: insert_commute)
  then have f5:"rk {a, b, c, R, A, B} \<ge> 4"
    using f1 f4 assms(11)
    by linarith
  have "rk {A, B, B'} = 3"
    using assms(1) desargues_config_2D_non_collinear(2)
    by auto
  then have f6:"rk {R, b} = 2"
    using f2 assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      rk_Ra[of Q B' b P R B A C A' C'] assms(2) assms(4) assms(6) assms(8) assms(13)
    by (metis insert_commute)
  have "rk {a, b, c, R, A, B} + rk {R, b} \<le> rk {a, b, c, R, A} + rk {R, B, b}"
    using matroid_ax_3_alt[of "{R, b}" "{a, b, c, R, A}" "{R, B, b}"]
    by (simp add: insert_commute)
  then have f7:"rk {a, b, c, R, A} \<ge> 4"
    using f5 f6 assms(10)
    by linarith
  have "rk {a, b, c, R, A} + rk {a} \<le> rk {a, b, c} + rk {R, A, a}"
    using matroid_ax_3_alt[of "{a}" "{a, b, c}" "{R, A, a}"]
    by (simp add: insert_commute)
  then have "rk {a, b, c} \<ge> 3"
    using f7 assms(9)
    by (smt One_nat_def Suc_eq_plus1 Suc_le_mono Suc_numeral add.assoc card.empty card.insert
        dual_order.trans finite.intros(1) insert_absorb insert_not_empty le_antisym matroid_ax_1b
        one_add_one rk_ax_singleton semiring_norm(2) semiring_norm(8))
  thus "rk {a, b, c} = 3"
    by (simp add: \<open>rk {a, b, c} \<le> 3\<close> le_antisym)
qed

lemma rk_ac\<beta> :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {Q, A', a} = 2" and "rk {Q, B', b} = 2" and "rk {Q, C', c} = 2" and "rk {P, Q, R} = 2" and
"rk {P, R} = 2" and "rk {Q, R} = 2" and "rk {R, A, a} = 2" and "rk {R, B, b} = 2" and
"rk {R, C, c} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and "rk {C', P} = 2"
  shows "rk {a, c, \<beta>} = 2"
proof-
  have "rk {a, b, c} = 3"
    using rk_abc assms
    by auto
  then have "rk {a, c} = 2"
    by (metis insert_commute rk_triple_to_rk_couple)
  then have "rk {a, c, \<beta>} \<ge> 2"
    using matroid_ax_2
    by (metis empty_subsetI insert_mono)
  have f1:"rk {a, c, A, C, A', C', \<beta>} + rk {a, c, \<beta>} \<le> rk {a, c, A, C, \<beta>} + rk {a, c, A', C', \<beta>}"
    using matroid_ax_3_alt[of "{a, c, \<beta>}" "{a, c, A, C, \<beta>}" "{a, c, A', C', \<beta>}"]
    by (simp add: insert_commute)
  have f2:"rk {A, A', C} \<ge> 3"
    using rk_AA'C assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by auto
  have f3:"rk {A, B, C, A', B', C', P} = 3"
    using coplanar_ABCA'B'C'P assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by auto
  then have f4:"rk {A, B, P, a} \<ge> 4"
    using rk_ABPa assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (meson assms(12) assms(13) assms(14) assms(2) assms(3) assms(6) assms(7) assms(9)
        desargues_config_2D_rkA'B'PQ_rkA'C'PQ_rkB'C'PQ(1))
  have "rk {A, A', C, a} \<ge> 4"
    using f2 f3 f4 rk_AA'Ca[of A A' C B P a B' C']
    by auto
  then have f5:"rk {a, c, A, C, \<beta>} = 3"
    using rk_acAC\<beta>[of R A a C c \<beta> Q A'] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(9) assms(11) assms(3) rk_triple_to_rk_couple
    by blast
  have "rk {A', A, C', a} \<ge> 4"
    using rk_AA'C'a[of A A' C' B P a C B'] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (smt assms(12) assms(13) assms(14) desargues_config_2D_non_collinear_P(2) f3 f4 insert_commute
        rk_AA'C)
  then have f6:"rk {a, c, A', C', \<beta>} = 3"
    using rk_acA'C'\<beta>[of Q A' a C' c \<beta> R A] assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      assms(3) assms(5) assms(9)
    by (metis (full_types) insert_commute rk_triple_to_rk_couple)
  have "{A, A', C, a} \<subseteq> {a, c, A, C, A', C', \<beta>}"
    by auto
  then have f7:"rk {a, c, A, C, A', C', \<beta>} \<ge> 4"
    using matroid_ax_2
    by (meson \<open>4 \<le> rk {A, A', C, a}\<close> dual_order.trans)
  then have "rk {a, c, \<beta>} \<le> 2"
    using f1 f5 f6
    by linarith
  thus "rk {a, c, \<beta>} = 2"
    using \<open>2 \<le> rk {a, c, \<beta>}\<close> le_antisym
    by blast
qed

lemma rk_ab\<gamma> :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {Q, A', a} = 2" and "rk {Q, B', b} = 2" and "rk {Q, C', c} = 2" and "rk {P, Q, R} = 2" and
"rk {P, R} = 2" and "rk {Q, R} = 2" and "rk {R, A, a} = 2" and "rk {R, B, b} = 2" and
"rk {R, C, c} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and "rk {C', P} = 2"
  shows "rk {a, b, \<gamma>} = 2"
proof-
  have "desargues_config_2D A C B A' C' B' P \<alpha> \<gamma> \<beta>"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      desargues_config_2D_def[of A C B A' C' B' P \<alpha> \<gamma> \<beta>]
    by (metis insert_commute)
  thus "rk {a, b, \<gamma>} = 2"
    using rk_ac\<beta>[of A C B A' C' B' P \<alpha> \<gamma> \<beta> Q a c b R]
    by (metis assms(10) assms(11) assms(12) assms(13) assms(14) assms(2) assms(3) assms(4) assms(5)
        assms(6) assms(7) assms(8) assms(9) insert_commute)
qed

lemma rk_bc\<alpha> :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {Q, A', a} = 2" and "rk {Q, B', b} = 2" and "rk {Q, C', c} = 2" and "rk {P, Q, R} = 2" and
"rk {P, R} = 2" and "rk {Q, R} = 2" and "rk {R, A, a} = 2" and "rk {R, B, b} = 2" and
"rk {R, C, c} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and "rk {C', P} = 2"
  shows "rk {b, c, \<alpha>} = 2"
proof-
  have "desargues_config_2D B A C B' A' C' P \<beta> \<alpha> \<gamma>"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      desargues_config_2D_def[of B A C B' A' C' P \<beta> \<alpha> \<gamma>]
    by (metis insert_commute)
  thus "rk {b, c, \<alpha>} = 2"
    using rk_ac\<beta>[of B A C B' A' C' P \<beta> \<alpha> \<gamma> Q b a c R]
    by (metis assms(10) assms(11) assms(12) assms(13) assms(14) assms(2) assms(3) assms(4) assms(5)
        assms(6) assms(7) assms(8) assms(9) insert_commute)
qed

lemma rk_abc\<alpha>\<beta>\<gamma> :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {Q, A', a} = 2" and "rk {Q, B', b} = 2" and "rk {Q, C', c} = 2" and "rk {P, Q, R} = 2" and
"rk {P, R} = 2" and "rk {Q, R} = 2" and "rk {R, A, a} = 2" and "rk {R, B, b} = 2" and
"rk {R, C, c} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and "rk {C', P} = 2"
  shows "rk {a, b, c, \<alpha>, \<beta>, \<gamma>} = 3"
proof-
  have f1:"rk {a, b, \<gamma>} = 2"
    using rk_ab\<gamma>[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a b c R] assms
    by auto
  have f2:"rk {a, c, \<beta>} = 2"
    using rk_ac\<beta>[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a b c R] assms
    by auto
  have f3:"rk {b, c, \<alpha>} = 2"
    using rk_bc\<alpha>[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a b c R] assms
    by auto
  have "rk {a, b, c, \<beta>, \<gamma>} + rk {a} \<le> rk {a, b, \<gamma>} + rk {a, c, \<beta>}"
    using matroid_ax_3_alt[of "{a}" "{a, b, \<gamma>}" "{a, c, \<beta>}"]
    by (simp add: insert_commute)
  then have "rk {a, b, c, \<beta>, \<gamma>} \<le> 3"
    using f1 f2
    by (metis Suc_1 Suc_eq_plus1 Suc_le_mono add_Suc_right numeral_3_eq_3 numeral_nat(1) numerals(1)
        rk_singleton)
  then have f4:"rk {a, b, c, \<beta>, \<gamma>} = 3"
    using matroid_ax_2 rk_abc[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a b c R]
    by (metis Un_upper2 assms(1) assms(10) assms(11) assms(12) assms(13) assms(14) assms(2) assms(3)
        assms(4) assms(5) assms(6) assms(7) assms(8) assms(9) insert_mono le_antisym sup_bot.comm_neutral)
  have "rk {a, b, c} = 3"
    using rk_abc[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a b c R] assms(1) assms(10) assms(11) assms(12) assms(13)
      assms(14) assms(2) assms(3) assms(4) assms(5) assms(6) assms(7) assms(8) assms(9)
    by blast
  then have f5:"rk {b, c} = 2"
    using rk_triple_to_rk_couple rk_couple
    by force
  have "rk {a, b, c, \<alpha>, \<beta>, \<gamma>} + rk {b, c} \<le> rk {a, b, c, \<beta>, \<gamma>} + rk {b, c, \<alpha>}"
    using matroid_ax_3_alt[of "{b, c}" "{a, b, c, \<beta>, \<gamma>}" "{b, c, \<alpha>}"]
    by (simp add: insert_commute)
  then have "rk {a, b, c, \<alpha>, \<beta>, \<gamma>} \<le> 3"
    using f3 f4 f5
    by linarith
  thus "rk {a, b, c, \<alpha>, \<beta>, \<gamma>} = 3"
    using matroid_ax_2
    by (metis \<open>rk {a, b, c} = 3\<close> empty_subsetI insert_mono le_antisym)
qed

lemma rk_\<alpha>\<beta>\<gamma> :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
and "rk {Q, A', a} = 2" and "rk {Q, B', b} = 2" and "rk {Q, C', c} = 2" and "rk {P, Q, R} = 2" and
"rk {P, R} = 2" and "rk {Q, R} = 2" and "rk {R, A, a} = 2" and "rk {R, B, b} = 2" and
"rk {R, C, c} = 2" and "rk {A', P} = 2" and "rk {B', P} = 2" and "rk {C', P} = 2"
  shows "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
proof-
  have "rk {A, B, C, a, b, c} \<ge> 4"
    using desargues_config_2D_rkABCabc[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a R b c] assms
    by auto
  have "{A, B, C, a, b, c} \<subseteq> {A, B, C, a, b, c, \<alpha>, \<beta>, \<gamma>}"
    by auto
  then have f1:"rk {A, B, C, a, b, c, \<alpha>, \<beta>, \<gamma>} \<ge> 4"
    using matroid_ax_2
    by (meson \<open>4 \<le> rk {A, B, C, a, b, c}\<close> dual_order.trans)
  have "rk {A, B, C, a, b, c, \<alpha>, \<beta>, \<gamma>} + rk {\<alpha>, \<beta>, \<gamma>} \<le> rk {A, B, C, \<alpha>, \<beta>, \<gamma>} + rk {a, b, c, \<alpha>, \<beta>, \<gamma>}"
    using matroid_ax_3_alt[of "{\<alpha>, \<beta>, \<gamma>}" "{A, B, C, \<alpha>, \<beta>, \<gamma>}" "{a, b, c, \<alpha>, \<beta>, \<gamma>}"]
    by (simp add: insert_commute)
  thus "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
    using f1 rk_ABC\<alpha>\<beta>\<gamma>[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a b c R] rk_abc\<alpha>\<beta>\<gamma>[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a b c R]
    by (smt One_nat_def Suc_1 Suc_le_eq add_Suc_right add_le_imp_le_diff assms(1) assms(10) assms(11)
        assms(12) assms(13) assms(14) assms(2) assms(3) assms(4) assms(5) assms(6) assms(7) assms(8)
        assms(9) diff_add_inverse2 le_antisym nat_1_add_1 not_less numeral_3_eq_3 one_plus_numeral
        rk_triple_le semiring_norm(2) semiring_norm(4))
qed

lemma rk_\<alpha>\<beta>\<gamma>_special_case_1 :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {A', P} = 1"
  shows "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
proof-
  have "A' = P"
    by (simp add: assms(2) rk_couple_to_singleton)
  then have "rk {A', C', C, \<beta>} + rk {C', A'} \<le> rk {C, C', P} + rk {A', C', \<beta>}"
    using matroid_ax_3_alt[of "{C', A'}" "{C, C', P}" "{A', C', \<beta>}"]
    by (simp add: insert_commute)
  then have "rk {A', C', C, \<beta>} \<le> rk {A', C', \<beta>}"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (metis (full_types) add_le_cancel_right insert_commute rk_triple_to_rk_couple)
  then have f5:"rk {A', C', C, \<beta>} = 2"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (metis insert_commute le_antisym matroid_ax_2 subset_insertI)
  have "rk {A, A', C, a, C', \<beta>} + rk {A, C, \<beta>} \<le> rk {A, A', C', C, \<beta>} + rk {a, A, C, \<beta>}" for a
    using matroid_ax_3_alt[of "{A, C, \<beta>}" "{A, A', C', C, \<beta>}" "{a, A, C, \<beta>}"]
    by (simp add: insert_commute)
  then have f6:"rk {A, A', C', C, \<beta>} \<ge> 3"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] rk_AA'Ca rk_acAC\<beta>
    by (metis Un_insert_right Un_upper2 \<open>A' = P\<close> insert_commute matroid_ax_2 sup_bot.right_neutral)
  have "rk {A, A', C', C, \<beta>} + rk {\<beta>, C} \<le> rk {A, C, \<beta>} + rk {A', C', C, \<beta>}"
    using matroid_ax_3_alt[of "{\<beta>, C}" "{A, C, \<beta>}" "{A', C', C, \<beta>}"]
    by (simp add: insert_commute)
  then have "rk {\<beta>, C} \<le> 1"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] f5 f6
    by linarith
  then have "\<beta> = C"
    using rk_couple
    by force
  have "rk {A', B', B, \<gamma>} + rk {B', A'} \<le> rk {B, B', P} + rk {A', B', \<gamma>}"
    using matroid_ax_3_alt[of "{B', A'}" "{B, B', P}" "{A', B', \<gamma>}"]
    by (simp add: \<open>A' = P\<close> insert_commute)
  then have "rk {A', B', B, \<gamma>} \<le> rk {A', B', \<gamma>}"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (metis (full_types) add_le_cancel_right insert_commute rk_triple_to_rk_couple)
  then have f7:"rk {A', B', B, \<gamma>} = 2"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (metis insert_commute le_antisym matroid_ax_2 subset_insertI)
  have "rk {A, A', B, a, B', \<gamma>} + rk {A, B, \<gamma>} \<le> rk {A, A', B', B, \<gamma>} + rk {a, A, B, \<gamma>}" for a
    using matroid_ax_3_alt[of "{A, B, \<gamma>}" "{A, A', B', B, \<gamma>}" "{a, A, B, \<gamma>}"]
    by (simp add: insert_commute)
  then have f8:"rk {A, A', B', B, \<gamma>} \<ge> 3"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] rk_AA'Ca rk_acAC\<beta>
    by (metis Un_insert_right Un_upper2 \<open>A' = P\<close> insert_commute matroid_ax_2 sup_bot.right_neutral)
  have "rk {A, A', B', B, \<gamma>} + rk {\<gamma>, B} \<le> rk {A, B, \<gamma>} + rk {A', B', B, \<gamma>}"
    using matroid_ax_3_alt[of "{\<gamma>, B}" "{A, B, \<gamma>}" "{A', B', B, \<gamma>}"]
    by (simp add: insert_commute)
  then have "rk {\<gamma>, B} \<le> 1"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] f7 f8
    by linarith
  then have "\<gamma> = B"
    using rk_couple
    by force
  then have "rk {\<alpha>, \<beta>, \<gamma>} = rk {\<alpha>, C, B}"
    using \<open>\<beta> = C \<close>
    by auto
  thus "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (metis insert_commute order_refl)
qed

lemma rk_\<alpha>\<beta>\<gamma>_special_case_2 :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {B', P} = 1"
  shows "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
proof-
  have "desargues_config_2D B A C B' A' C' P \<beta> \<alpha> \<gamma>"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      desargues_config_2D_def[of B A C B' A' C' P \<beta> \<alpha> \<gamma>]
    by (metis insert_commute)
  thus "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
    using rk_\<alpha>\<beta>\<gamma>_special_case_1[of B A C B' A' C' P \<beta> \<alpha> \<gamma>] assms(2)
    by (simp add: insert_commute)
qed

lemma rk_\<alpha>\<beta>\<gamma>_special_case_3 :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>" and "rk {C', P} = 1"
  shows "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
proof-
  have "desargues_config_2D  C B A C' B' A' P \<gamma> \<beta> \<alpha>"
    using assms(1) desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
      desargues_config_2D_def[of C B A C' B' A' P \<gamma> \<beta> \<alpha>]
    by (metis insert_commute)
  thus "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
    using rk_\<alpha>\<beta>\<gamma>_special_case_1[of C B A C' B' A' P \<gamma> \<beta> \<alpha>] assms(2)
    by (simp add: insert_commute)
qed

theorem desargues_2D :
  assumes "desargues_config_2D A B C A' B' C' P \<alpha> \<beta> \<gamma>"
  shows "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
proof-
  have f1:"rk {A, B, C, A', B', C', P} = 3"
    using assms desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>] coplanar_ABCA'B'C'P
    by auto
  obtain Q where "rk {A, B, C, A', B', C', P, Q} \<ge> 4"
    using f1 rk_ext[of "{A, B, C, A', B', C', P}"]
    by (metis Un_insert_left add.commute one_plus_numeral order_refl semiring_norm(2) semiring_norm(4)
        sup_bot.left_neutral)
  obtain R where "rk {P, Q, R} = 2" and "rk {P, R} = 2" and "rk {Q, R} = 2"
    using rk_ax_3_pts
    by auto
  have "rk {Q, A', R, A, P} + rk {P} \<le> rk {P, Q, R} + rk {A, A', P}"
    using matroid_ax_3_alt[of "{P}" "{P, Q, R}" "{A, A', P}"]
    by (simp add: insert_commute)
  then have "rk {Q, A', R, A, P} \<le> 3"
    using rk_singleton assms desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (metis Suc_1 Suc_eq_plus1 Suc_le_mono \<open>rk {P, Q, R} = 2\<close> add_Suc_right eval_nat_numeral(3))
  then have f2:"rk {Q, A', R, A} \<le> 3"
    using matroid_ax_2
    by (metis (no_types, opaque_lifting) dual_order.trans insert_commute subset_insertI)
  obtain a where "rk {Q, A', a} = 2" and "rk {R, A, a} = 2"
    using f2 rk_ax_pasch
    by blast
  have "rk {Q, B', R, B, P} + rk {P} \<le> rk {P, Q, R} + rk {B, B', P}"
    using matroid_ax_3_alt[of "{P}" "{P, Q, R}" "{B, B', P}"]
    by (simp add: insert_commute)
  then have "rk {Q, B', R, B, P} \<le> 3"
    using rk_singleton assms desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (metis Suc_1 Suc_eq_plus1 Suc_le_mono \<open>rk {P, Q, R} = 2\<close> add_Suc_right eval_nat_numeral(3))
  then have f3:"rk {Q, B', R, B} \<le> 3"
    using matroid_ax_2
    by (metis (no_types, opaque_lifting) dual_order.trans insert_commute subset_insertI)
  obtain b where "rk {Q, B', b} = 2" and "rk {R, B, b} = 2"
    using f3 rk_ax_pasch
    by blast
  have "rk {Q, C', R, C, P} + rk {P} \<le> rk {P, Q, R} + rk {C, C', P}"
    using matroid_ax_3_alt[of "{P}" "{P, Q, R}" "{C, C', P}"]
    by (simp add: insert_commute)
  then have "rk {Q, C', R, C, P} \<le> 3"
    using rk_singleton assms desargues_config_2D_def[of A B C A' B' C' P \<alpha> \<beta> \<gamma>]
    by (metis Suc_1 Suc_eq_plus1 Suc_le_mono \<open>rk {P, Q, R} = 2\<close> add_Suc_right eval_nat_numeral(3))
  then have f4:"rk {Q, C', R, C} \<le> 3"
    using matroid_ax_2
    by (metis (no_types, opaque_lifting) dual_order.trans insert_commute subset_insertI)
  obtain c where "rk {Q, C', c} = 2" and "rk {R, C, c} = 2"
    using f4 rk_ax_pasch
    by blast
  then have "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2" if "rk {A', P} = 2" and "rk {B', P} = 2" and "rk {C', P} = 2"
    using rk_\<alpha>\<beta>\<gamma>[of A B C A' B' C' P \<alpha> \<beta> \<gamma> Q a b c R] \<open>4 \<le> rk {A, B, C, A', B', C', P, Q}\<close>
      \<open>rk {P, Q, R} = 2\<close> \<open>rk {P, R} = 2\<close> \<open>rk {Q, A', a} = 2\<close> \<open>rk {Q, B', b} = 2\<close> \<open>rk {Q, R} = 2\<close>
      \<open>rk {R, A, a} = 2\<close> \<open>rk {R, B, b} = 2\<close> assms that(1) that(2) that(3)
    by blast
  have "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2" if "rk {A', P} = 1"
    using rk_\<alpha>\<beta>\<gamma>_special_case_1 assms that
    by auto
  have "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2" if "rk {B', P} = 1"
    using rk_\<alpha>\<beta>\<gamma>_special_case_2 assms that
    by auto
  have "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2" if "rk {C', P} = 1"
    using rk_\<alpha>\<beta>\<gamma>_special_case_3 assms that
    by auto
  thus "rk {\<alpha>, \<beta>, \<gamma>} \<le> 2"
    using \<open>\<lbrakk>rk {A', P} = 2; rk {B', P} = 2; rk {C', P} = 2\<rbrakk> \<Longrightarrow> rk {\<alpha>, \<beta>, \<gamma>} \<le> 2\<close>
      \<open>rk {A', P} = 1 \<Longrightarrow> rk {\<alpha>, \<beta>, \<gamma>} \<le> 2\<close> \<open>rk {B', P} = 1 \<Longrightarrow> rk {\<alpha>, \<beta>, \<gamma>} \<le> 2\<close>
      rk_couple rk_singleton_bis
    by blast
qed
end

end


(*  Title:       variants/a_norreqid/Aodv_Data.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
    Author:      Peter Höfner, NICTA
*)

section "Predicates and functions used in the AODV model"

theory A_Aodv_Data
imports A_Norreqid
begin

subsection "Sequence Numbers"

text \<open>Sequence numbers approximate the relative freshness of routing information.\<close>

definition inc :: "sqn \<Rightarrow> sqn"
  where "inc sn \<equiv> if sn = 0 then sn else sn + 1"

lemma less_than_inc [simp]: "x \<le> inc x"
  unfolding inc_def by simp

lemma inc_minus_suc_0 [simp]:
  "inc x - Suc 0 = x"
  unfolding inc_def by simp

lemma inc_never_one' [simp, intro]: "inc x \<noteq> Suc 0"
  unfolding inc_def by simp

lemma inc_never_one [simp, intro]: "inc x \<noteq> 1"
  by simp

subsection "Modelling Routes"

text \<open>
  A route is a 6-tuple, @{term "(dsn, dsk, flag, hops, nhip, pre)"} where
  @{term dsn} is the `destination sequence number', @{term dsk} is the
  `destination-sequence-number status', @{term flag} is the route status,
  @{term hops} is the number of hops to the destination, @{term nhip} is the
  next hop toward the destination, and @{term pre} is the set of `precursor nodes'--those
  interested in hearing about changes to the route.
\<close>

type_synonym r = "sqn \<times> k \<times> f \<times> nat \<times> ip \<times> ip set"

definition proj2 :: "r \<Rightarrow> sqn" ("\<pi>\<^sub>2")
  where "\<pi>\<^sub>2 \<equiv> \<lambda>(dsn, _, _, _, _, _). dsn"

definition proj3 :: "r \<Rightarrow> k" ("\<pi>\<^sub>3")
  where "\<pi>\<^sub>3 \<equiv> \<lambda>(_, dsk, _, _, _, _). dsk"

definition proj4 :: "r \<Rightarrow> f" ("\<pi>\<^sub>4")
  where "\<pi>\<^sub>4 \<equiv> \<lambda>(_, _, flag, _, _, _). flag"

definition proj5 :: "r \<Rightarrow> nat" ("\<pi>\<^sub>5")
  where "\<pi>\<^sub>5 \<equiv> \<lambda>(_, _, _, hops, _, _). hops"

definition proj6 :: "r \<Rightarrow> ip" ("\<pi>\<^sub>6")
  where "\<pi>\<^sub>6 \<equiv> \<lambda>(_, _, _, _, nhip, _). nhip"

definition proj7 :: "r \<Rightarrow> ip set" ("\<pi>\<^sub>7")
  where "\<pi>\<^sub>7 \<equiv> \<lambda>(_, _, _, _, _, pre). pre"

lemma projs [simp]:
  "\<pi>\<^sub>2(dsn, dsk, flag, hops, nhip, pre) = dsn"
  "\<pi>\<^sub>3(dsn, dsk, flag, hops, nhip, pre) = dsk"
  "\<pi>\<^sub>4(dsn, dsk, flag, hops, nhip, pre) = flag"
  "\<pi>\<^sub>5(dsn, dsk, flag, hops, nhip, pre) = hops"
  "\<pi>\<^sub>6(dsn, dsk, flag, hops, nhip, pre) = nhip"
  "\<pi>\<^sub>7(dsn, dsk, flag, hops, nhip, pre) = pre"
  by (clarsimp simp: proj2_def proj3_def proj4_def
                     proj5_def proj6_def proj7_def)+

lemma proj3_pred [intro]: "\<lbrakk> P kno; P unk \<rbrakk> \<Longrightarrow> P (\<pi>\<^sub>3 x)"
  by (rule k.induct)

lemma proj4_pred [intro]: "\<lbrakk> P val; P inv \<rbrakk> \<Longrightarrow> P (\<pi>\<^sub>4 x)"
  by (rule f.induct)

subsection "Routing Tables"

text \<open>Routing tables map ip addresses to route entries.\<close>

type_synonym rt = "ip \<rightharpoonup> r"

syntax
  "_Sigma_route" :: "rt \<Rightarrow> ip \<rightharpoonup> r"  ("\<sigma>\<^bsub>route\<^esub>'(_, _')")

translations
 "\<sigma>\<^bsub>route\<^esub>(rt, dip)" => "rt dip"

definition sqn :: "rt \<Rightarrow> ip \<Rightarrow> sqn"
  where "sqn rt dip \<equiv> case \<sigma>\<^bsub>route\<^esub>(rt, dip) of Some r \<Rightarrow> \<pi>\<^sub>2(r) | None \<Rightarrow> 0"

definition sqnf :: "rt \<Rightarrow> ip \<Rightarrow> k"
  where "sqnf rt dip \<equiv> case \<sigma>\<^bsub>route\<^esub>(rt, dip) of Some r \<Rightarrow> \<pi>\<^sub>3(r) | None \<Rightarrow> unk"

abbreviation flag :: "rt \<Rightarrow> ip \<rightharpoonup> f"
  where "flag rt dip \<equiv> map_option \<pi>\<^sub>4 (\<sigma>\<^bsub>route\<^esub>(rt, dip))"

abbreviation dhops :: "rt \<Rightarrow> ip \<rightharpoonup> nat"
   where "dhops rt dip \<equiv> map_option \<pi>\<^sub>5 (\<sigma>\<^bsub>route\<^esub>(rt, dip))"

abbreviation nhop :: "rt \<Rightarrow> ip \<rightharpoonup> ip"
   where "nhop rt dip \<equiv> map_option \<pi>\<^sub>6 (\<sigma>\<^bsub>route\<^esub>(rt, dip))"

abbreviation precs :: "rt \<Rightarrow> ip \<rightharpoonup> ip set"
   where "precs rt dip \<equiv> map_option \<pi>\<^sub>7 (\<sigma>\<^bsub>route\<^esub>(rt, dip))"

definition vD :: "rt \<Rightarrow> ip set"
  where "vD rt \<equiv> {dip. flag rt dip = Some val}"

definition iD :: "rt \<Rightarrow> ip set"
  where "iD rt \<equiv> {dip. flag rt dip = Some inv}"

definition kD :: "rt \<Rightarrow> ip set"
  where "kD rt \<equiv> {dip. rt dip \<noteq> None}"

lemma kD_is_vD_and_iD: "kD rt = vD rt \<union> iD rt"
  unfolding kD_def vD_def iD_def by auto

lemma vD_iD_gives_kD [simp]:
   "\<And>ip rt. ip \<in> vD rt \<Longrightarrow> ip \<in> kD rt"
   "\<And>ip rt. ip \<in> iD rt \<Longrightarrow> ip \<in> kD rt"
  unfolding kD_is_vD_and_iD by simp_all

lemma kD_Some [dest]:
    fixes dip rt
  assumes "dip \<in> kD rt"
    shows "\<exists>dsn dsk flag hops nhip pre.
           \<sigma>\<^bsub>route\<^esub>(rt, dip) = Some (dsn, dsk, flag, hops, nhip, pre)"
  using assms unfolding kD_def by simp

lemma kD_None [dest]:
    fixes dip rt
  assumes "dip \<notin> kD rt"
    shows "\<sigma>\<^bsub>route\<^esub>(rt, dip) = None"
  using assms unfolding kD_def
  by (metis (mono_tags) mem_Collect_eq)

lemma vD_Some [dest]:
    fixes dip rt
  assumes "dip \<in> vD rt"
    shows "\<exists>dsn dsk hops nhip pre.
           \<sigma>\<^bsub>route\<^esub>(rt, dip) = Some (dsn, dsk, val, hops, nhip, pre)"
  using assms unfolding vD_def by simp

lemma vD_empty [simp]: "vD Map.empty = {}"
  unfolding vD_def by simp

lemma iD_Some [dest]:
    fixes dip rt
  assumes "dip \<in> iD rt"
    shows "\<exists>dsn dsk hops nhip pre.
           \<sigma>\<^bsub>route\<^esub>(rt, dip) = Some (dsn, dsk, inv, hops, nhip, pre)"
  using assms unfolding iD_def by simp

lemma val_is_vD [elim]:
    fixes ip rt
  assumes "ip\<in>kD(rt)"
      and "the (flag rt ip) = val"
    shows "ip\<in>vD(rt)"
  using assms unfolding vD_def by auto

lemma inv_is_iD [elim]:
    fixes ip rt
  assumes "ip\<in>kD(rt)"
      and "the (flag rt ip) = inv"
    shows "ip\<in>iD(rt)"
  using assms unfolding iD_def by auto

lemma iD_flag_is_inv [elim, simp]:
    fixes ip rt
  assumes "ip\<in>iD(rt)"
    shows "the (flag rt ip) = inv"
  proof -
    from \<open>ip\<in>iD(rt)\<close> have "ip\<in>kD(rt)" by auto
    with assms show ?thesis unfolding iD_def by auto
  qed

lemma kD_but_not_vD_is_iD [elim]:
    fixes ip rt
  assumes "ip\<in>kD(rt)"
      and "ip\<notin>vD(rt)"
    shows "ip\<in>iD(rt)"
  proof -
    from \<open>ip\<in>kD(rt)\<close> obtain dsn dsk f hops nhop pre
      where rtip: "rt ip = Some (dsn, dsk, f, hops, nhop, pre)"
       by (metis kD_Some)
    from \<open>ip\<notin>vD(rt)\<close> have "f \<noteq> val"
    proof (rule contrapos_nn)
      assume "f = val"
      with rtip have "the (flag rt ip) = val" by simp
      with \<open>ip\<in>kD(rt)\<close> show "ip\<in>vD(rt)" ..
    qed
    with rtip have "the (flag rt ip)= inv" by simp
    with \<open>ip\<in>kD(rt)\<close> show "ip\<in>iD(rt)" ..
  qed

lemma vD_or_iD [elim]:
    fixes ip rt
  assumes "ip\<in>kD(rt)"
      and "ip\<in>vD(rt) \<Longrightarrow> P rt ip"
      and "ip\<in>iD(rt) \<Longrightarrow> P rt ip"
    shows "P rt ip"
  proof -
    from \<open>ip\<in>kD(rt)\<close> have "ip\<in>vD(rt) \<union> iD(rt)"
      by (simp add: kD_is_vD_and_iD)
    thus ?thesis by (auto elim: assms(2-3))
  qed

lemma proj5_eq_dhops: "\<And>dip rt. dip\<in>kD(rt) \<Longrightarrow> \<pi>\<^sub>5(the (rt dip)) = the (dhops rt dip)"
  unfolding sqn_def by (drule kD_Some) clarsimp

lemma proj4_eq_flag: "\<And>dip rt. dip\<in>kD(rt) \<Longrightarrow> \<pi>\<^sub>4(the (rt dip)) = the (flag rt dip)"
  unfolding sqn_def by (drule kD_Some) clarsimp

lemma proj2_eq_sqn: "\<And>dip rt. dip\<in>kD(rt) \<Longrightarrow> \<pi>\<^sub>2(the (rt dip)) = sqn rt dip"
  unfolding sqn_def by (drule kD_Some) clarsimp

lemma kD_sqnf_is_proj3 [simp]:
  "\<And>ip rt. ip\<in>kD(rt) \<Longrightarrow> sqnf rt ip = \<pi>\<^sub>3(the (rt ip))"
  unfolding sqnf_def by auto

lemma vD_flag_val [simp]:
  "\<And>dip rt. dip \<in> vD (rt) \<Longrightarrow> the (flag rt dip) = val"
  unfolding vD_def by clarsimp

lemma kD_update [simp]:
  "\<And>rt nip v. kD (rt(nip \<mapsto> v)) = insert nip (kD rt)"
  unfolding kD_def by auto

lemma kD_empty [simp]: "kD Map.empty = {}"
  unfolding kD_def by simp

lemma ip_equal_or_known [elim]:
  fixes rt ip ip'
  assumes "ip = ip' \<or> ip\<in>kD(rt)"
      and "ip = ip' \<Longrightarrow> P rt ip ip'"
      and "\<lbrakk> ip \<noteq> ip'; ip\<in>kD(rt)\<rbrakk> \<Longrightarrow> P rt ip ip'"
    shows "P rt ip ip'"
  using assms by auto

subsection "Updating Routing Tables"

text \<open>Routing table entries are modified through explicit functions.
      The properties of these functions are important in invariant proofs.\<close>

subsubsection "Updating Precursor Lists"

definition addpre :: "r \<Rightarrow> ip set \<Rightarrow> r"
  where "addpre r npre \<equiv> let (dsn, dsk, flag, hops, nhip, pre) = r in
                          (dsn, dsk, flag, hops, nhip, pre \<union> npre)"

lemma proj2_addpre:
  fixes v pre
  shows "\<pi>\<^sub>2(addpre v pre) = \<pi>\<^sub>2(v)"
  unfolding addpre_def by (cases v) simp

lemma proj3_addpre:
  fixes v pre
  shows "\<pi>\<^sub>3(addpre v pre) = \<pi>\<^sub>3(v)"
  unfolding addpre_def by (cases v) simp

lemma proj4_addpre:
  fixes v pre
  shows "\<pi>\<^sub>4(addpre v pre) = \<pi>\<^sub>4(v)"
  unfolding addpre_def by (cases v) simp

lemma proj5_addpre:
  fixes v pre
  shows "\<pi>\<^sub>5(addpre v pre) = \<pi>\<^sub>5(v)"
  unfolding addpre_def by (cases v) simp

lemma proj6_addpre:
  fixes dsn dsk flag hops nhip pre npre
  shows "\<pi>\<^sub>6(addpre v npre) = \<pi>\<^sub>6(v)"
  unfolding addpre_def by (cases v) simp

lemma proj7_addpre:
  fixes dsn dsk flag hops nhip pre npre
  shows "\<pi>\<^sub>7(addpre v npre) = \<pi>\<^sub>7(v) \<union> npre"
  unfolding addpre_def by (cases v) simp

lemma addpre_empty: "addpre r {} = r"
  unfolding addpre_def by simp

lemma addpre_r:
  "addpre (dsn, dsk, fl, hops, nhip, pre) npre = (dsn, dsk, fl, hops, nhip, pre \<union> npre)"
  unfolding addpre_def by simp

lemmas addpre_simps [simp] = proj2_addpre proj3_addpre proj4_addpre proj5_addpre
                             proj6_addpre proj7_addpre addpre_empty addpre_r

definition addpreRT :: "rt \<Rightarrow> ip \<Rightarrow> ip set \<rightharpoonup> rt"
  where "addpreRT rt dip npre \<equiv>
           map_option (\<lambda>s. rt (dip \<mapsto> addpre s npre)) (\<sigma>\<^bsub>route\<^esub>(rt, dip))"

lemma snd_addpre [simp]:
  "\<And>dsn dsn' v pre. (dsn, snd(addpre (dsn', v) pre)) = addpre (dsn, v) pre"
  unfolding addpre_def by clarsimp

lemma proj2_addpreRT [simp]:
    fixes ip rt ip' npre
  assumes "ip\<in>kD rt"
      and "ip'\<in>kD rt"
    shows "\<pi>\<^sub>2(the (the (addpreRT rt ip' npre) ip)) = \<pi>\<^sub>2(the (rt ip))"
  using assms [THEN kD_Some] unfolding addpreRT_def by clarsimp

lemma proj3_addpreRT [simp]:
    fixes ip rt ip' npre
  assumes "ip\<in>kD rt"
      and "ip'\<in>kD rt"
    shows "\<pi>\<^sub>3(the (the (addpreRT rt ip' npre) ip)) = \<pi>\<^sub>3(the (rt ip))"
  using assms [THEN kD_Some] unfolding addpreRT_def by clarsimp

lemma proj5_addpreRT [simp]:
  "\<And>rt dip ip npre. dip\<in>kD(rt) \<Longrightarrow> \<pi>\<^sub>5(the (the (addpreRT rt dip npre) ip)) = \<pi>\<^sub>5(the (rt ip))"
  unfolding addpreRT_def by auto

lemma flag_addpreRT [simp]:
    fixes rt pre ip dip
  assumes "dip \<in> kD rt"
    shows "flag (the (addpreRT rt dip pre)) ip = flag rt ip"
  unfolding addpreRT_def
  using assms [THEN kD_Some] by (clarsimp)

  lemma kD_addpreRT [simp]:
  fixes rt dip npre
  assumes "dip \<in> kD rt"
  shows "kD (the (addpreRT rt dip npre)) = kD rt"
  unfolding kD_def addpreRT_def
  using assms [THEN kD_Some]
  by clarsimp blast

lemma vD_addpreRT [simp]:
  fixes rt dip npre
  assumes "dip \<in> kD rt"
  shows "vD (the (addpreRT rt dip npre)) = vD rt"
  unfolding vD_def addpreRT_def
  using assms [THEN kD_Some] by clarsimp auto

lemma iD_addpreRT [simp]:
  fixes rt dip npre
  assumes "dip \<in> kD rt"
  shows "iD (the (addpreRT rt dip npre)) = iD rt"
  unfolding iD_def addpreRT_def
  using assms [THEN kD_Some] by clarsimp auto

lemma nhop_addpreRT [simp]:
    fixes rt pre ip dip
  assumes "dip \<in> kD rt"
    shows "nhop (the (addpreRT rt dip pre)) ip = nhop rt ip"
  unfolding sqn_def addpreRT_def
  using assms [THEN kD_Some] by (clarsimp)

lemma sqn_addpreRT [simp]:
    fixes rt pre ip dip
  assumes "dip \<in> kD rt"
    shows "sqn (the (addpreRT rt dip pre)) ip = sqn rt ip"
  unfolding sqn_def addpreRT_def
  using assms [THEN kD_Some] by (clarsimp)

lemma dhops_addpreRT [simp]:
    fixes rt pre ip dip
  assumes "dip \<in> kD rt"
    shows "dhops (the (addpreRT rt dip pre)) ip = dhops rt ip"
  unfolding addpreRT_def
  using assms [THEN kD_Some] by (clarsimp)

lemma sqnf_addpreRT [simp]:
  "\<And>ip dip. ip\<in>kD(rt \<xi>) \<Longrightarrow> sqnf (the (addpreRT (rt \<xi>) ip npre)) dip = sqnf (rt \<xi>) dip"
  unfolding sqnf_def addpreRT_def by auto

subsubsection "Updating route entries"

lemma not_in_kD_case [simp]:
    fixes dip rt
  assumes "dip \<notin> kD(rt)"
    shows "(case rt dip of None \<Rightarrow> en | Some r \<Rightarrow> es r) = en"
  using assms [THEN kD_None] by auto

lemma rt_Some_sqn [dest]:
    fixes rt and ip dsn dsk flag hops nhip pre
  assumes "rt ip = Some (dsn, dsk, flag, hops, nhip, pre)"
    shows "sqn rt ip = dsn"
  unfolding sqn_def using assms by simp

lemma not_kD_sqn [simp]:
    fixes dip rt
  assumes "dip \<notin> kD(rt)"
    shows "sqn rt dip = 0"
  using assms unfolding sqn_def
  by simp

definition update_arg_wf :: "r \<Rightarrow> bool"
where "update_arg_wf r \<equiv> \<pi>\<^sub>4(r) = val \<and>
                         (\<pi>\<^sub>2(r) = 0) = (\<pi>\<^sub>3(r) = unk) \<and>
                         (\<pi>\<^sub>3(r) = unk \<longrightarrow> \<pi>\<^sub>5(r) = 1)"

lemma update_arg_wf_gives_cases:
  "\<And>r. update_arg_wf r \<Longrightarrow> (\<pi>\<^sub>2(r) = 0) = (\<pi>\<^sub>3(r) = unk)"
  unfolding update_arg_wf_def by simp

lemma update_arg_wf_tuples [simp]:
  "\<And>nhip pre. update_arg_wf (0, unk, val, Suc 0, nhip, pre)"
  "\<And>n hops nhip pre. update_arg_wf (Suc n, kno, val, hops,  nhip, pre)"
  unfolding update_arg_wf_def by auto

lemma update_arg_wf_tuples' [elim]:
  "\<And>n hops nhip pre. Suc 0 \<le> n \<Longrightarrow> update_arg_wf (n, kno, val, hops,  nhip, pre)"
  unfolding update_arg_wf_def by auto

lemma wf_r_cases [intro]:
    fixes P r
  assumes "update_arg_wf r"
      and c1: "\<And>nhip pre. P (0, unk, val, Suc 0, nhip, pre)"
      and c2: "\<And>dsn hops nhip pre. dsn > 0 \<Longrightarrow> P (dsn, kno, val, hops, nhip, pre)"
    shows "P r"
  proof -
    obtain dsn dsk flag hops nhip pre
    where *: "r = (dsn, dsk, flag, hops, nhip, pre)" by (cases r)
    with \<open>update_arg_wf r\<close> have wf1: "flag = val"
                            and wf2: "(dsn = 0) = (dsk = unk)"
                            and wf3: "dsk = unk \<longrightarrow> (hops = 1)"
      unfolding update_arg_wf_def by auto
    have "P (dsn, dsk, flag, hops, nhip, pre)"
    proof (cases dsk)
      assume "dsk = unk"
      moreover with wf2 wf3 have "dsn = 0" and "hops = Suc 0" by auto
      ultimately show ?thesis using \<open>flag = val\<close> by simp (rule c1)
    next
      assume "dsk = kno"
      moreover with wf2 have "dsn > 0" by simp
      ultimately show ?thesis using \<open>flag = val\<close> by simp (rule c2)
    qed
    with * show "P r" by simp
  qed

definition update :: "rt \<Rightarrow> ip \<Rightarrow> r \<Rightarrow> rt"
  where
  "update rt ip r \<equiv>
     case \<sigma>\<^bsub>route\<^esub>(rt, ip) of
       None \<Rightarrow> rt (ip \<mapsto> r)
     | Some s \<Rightarrow>
          if \<pi>\<^sub>2(s) < \<pi>\<^sub>2(r) then rt (ip \<mapsto> addpre r (\<pi>\<^sub>7(s)))
          else if \<pi>\<^sub>2(s) = \<pi>\<^sub>2(r) \<and> (\<pi>\<^sub>5(s) > \<pi>\<^sub>5(r) \<or> \<pi>\<^sub>4(s) = inv)
               then rt (ip \<mapsto> addpre r (\<pi>\<^sub>7(s)))
               else if \<pi>\<^sub>3(r) = unk
                    then rt (ip \<mapsto> (\<pi>\<^sub>2(s), snd (addpre r (\<pi>\<^sub>7(s)))))
                    else rt (ip \<mapsto> addpre s (\<pi>\<^sub>7(r)))"

lemma update_simps [simp]:
  fixes r s nrt nr nr' ns rt ip
  defines "s \<equiv> the \<sigma>\<^bsub>route\<^esub>(rt, ip)"
      and "nr \<equiv> addpre r (\<pi>\<^sub>7(s))"
      and "nr' \<equiv> (\<pi>\<^sub>2(s), \<pi>\<^sub>3(nr), \<pi>\<^sub>4(nr), \<pi>\<^sub>5(nr), \<pi>\<^sub>6(nr), \<pi>\<^sub>7(nr))"
      and "ns \<equiv> addpre s (\<pi>\<^sub>7(r))"
  shows
  "\<lbrakk>ip \<notin> kD(rt)\<rbrakk>                            \<Longrightarrow> update rt ip r = rt (ip \<mapsto> r)"
  "\<lbrakk>ip \<in> kD(rt); sqn rt ip < \<pi>\<^sub>2(r)\<rbrakk>         \<Longrightarrow> update rt ip r = rt (ip \<mapsto> nr)"
  "\<lbrakk>ip \<in> kD(rt); sqn rt ip = \<pi>\<^sub>2(r);
                 the (dhops rt ip) > \<pi>\<^sub>5(r)\<rbrakk> \<Longrightarrow> update rt ip r = rt (ip \<mapsto> nr)"
  "\<lbrakk>ip \<in> kD(rt); sqn rt ip = \<pi>\<^sub>2(r);
                 flag rt ip = Some inv\<rbrakk>     \<Longrightarrow> update rt ip r = rt (ip \<mapsto> nr)"
  "\<lbrakk>ip \<in> kD(rt); \<pi>\<^sub>3(r) = unk; (\<pi>\<^sub>2(r) = 0) = (\<pi>\<^sub>3(r) = unk)\<rbrakk>  \<Longrightarrow> update rt ip r = rt (ip \<mapsto> nr')"
  "\<lbrakk>ip \<in> kD(rt); sqn rt ip \<ge> \<pi>\<^sub>2(r); \<pi>\<^sub>3(r) = kno;
    sqn rt ip = \<pi>\<^sub>2(r) \<Longrightarrow> the (dhops rt ip) \<le> \<pi>\<^sub>5(r) \<and> the (flag rt ip) = val \<rbrakk>
                                            \<Longrightarrow> update rt ip r = rt (ip \<mapsto> ns)"
  proof -
    assume "ip\<notin>kD(rt)"
    hence "\<sigma>\<^bsub>route\<^esub>(rt, ip) = None" ..
    thus "update rt ip r = rt (ip \<mapsto> r)"
      unfolding update_def by simp
  next
    assume "ip \<in> kD(rt)"
       and "sqn rt ip < \<pi>\<^sub>2(r)"
    from this(1) obtain dsn dsk fl hops nhip pre
      where "rt ip = Some (dsn, dsk, fl, hops, nhip, pre)"
        by (metis kD_Some)
    with \<open>sqn rt ip < \<pi>\<^sub>2(r)\<close> show "update rt ip r = rt (ip \<mapsto> nr)"
      unfolding update_def nr_def s_def by auto
  next
    assume "ip \<in> kD(rt)"
       and "sqn rt ip = \<pi>\<^sub>2(r)"
       and "the (dhops rt ip) > \<pi>\<^sub>5(r)"
    from this(1) obtain dsn dsk fl hops nhip pre
      where "rt ip = Some (dsn, dsk, fl, hops, nhip, pre)"
        by (metis kD_Some)
    with \<open>sqn rt ip = \<pi>\<^sub>2(r)\<close> and \<open>the (dhops rt ip) > \<pi>\<^sub>5(r)\<close>
      show "update rt ip r = rt (ip \<mapsto> nr)"
        unfolding update_def nr_def s_def by auto
   next
     assume "ip \<in> kD(rt)"
        and "sqn rt ip = \<pi>\<^sub>2(r)"
        and "flag rt ip = Some inv"
    from this(1) obtain dsn dsk fl hops nhip pre
      where "rt ip = Some (dsn, dsk, fl, hops, nhip, pre)"
        by (metis kD_Some)
     with \<open>sqn rt ip = \<pi>\<^sub>2(r)\<close> and \<open>flag rt ip = Some inv\<close>
      show "update rt ip r = rt (ip \<mapsto> nr)"
        unfolding update_def nr_def s_def by auto
   next
    assume "ip \<in> kD(rt)"
       and "\<pi>\<^sub>3(r) = unk"
       and "(\<pi>\<^sub>2(r) = 0) = (\<pi>\<^sub>3(r) = unk)"
    from this(1) obtain dsn dsk fl hops nhip pre
      where "rt ip = Some (dsn, dsk, fl, hops, nhip, pre)"
        by (metis kD_Some)
    with \<open>(\<pi>\<^sub>2(r) = 0) = (\<pi>\<^sub>3(r) = unk)\<close> and \<open>\<pi>\<^sub>3(r) = unk\<close>
      show "update rt ip r = rt (ip \<mapsto> nr')"
        unfolding update_def nr'_def nr_def s_def
      by (cases r) simp
   next
    assume "ip \<in> kD(rt)"
       and otherassms: "sqn rt ip \<ge> \<pi>\<^sub>2(r)"
           "\<pi>\<^sub>3(r) = kno"
           "sqn rt ip = \<pi>\<^sub>2(r) \<Longrightarrow> the (dhops rt ip) \<le> \<pi>\<^sub>5(r) \<and> the (flag rt ip) = val"
    from this(1) obtain dsn dsk fl hops nhip pre
      where "rt ip = Some (dsn, dsk, fl, hops, nhip, pre)"
        by (metis kD_Some)
     with otherassms show "update rt ip r = rt (ip \<mapsto> ns)"
      unfolding update_def ns_def s_def by auto
  qed

lemma update_cases [elim]:
  assumes "(\<pi>\<^sub>2(r) = 0) = (\<pi>\<^sub>3(r) = unk)"
      and c1: "\<lbrakk>ip \<notin> kD(rt)\<rbrakk> \<Longrightarrow> P (rt (ip \<mapsto> r))"

      and c2: "\<lbrakk>ip \<in> kD(rt); sqn rt ip < \<pi>\<^sub>2(r)\<rbrakk>
                \<Longrightarrow> P (rt (ip \<mapsto> addpre r (\<pi>\<^sub>7(the \<sigma>\<^bsub>route\<^esub>(rt, ip)))))"
      and c3: "\<lbrakk>ip \<in> kD(rt); sqn rt ip = \<pi>\<^sub>2(r); the (dhops rt ip) > \<pi>\<^sub>5(r)\<rbrakk>
                \<Longrightarrow> P (rt (ip \<mapsto> addpre r (\<pi>\<^sub>7(the \<sigma>\<^bsub>route\<^esub>(rt, ip)))))"
      and c4: "\<lbrakk>ip \<in> kD(rt); sqn rt ip = \<pi>\<^sub>2(r); the (flag rt ip) = inv\<rbrakk>
                \<Longrightarrow> P (rt (ip \<mapsto> addpre r (\<pi>\<^sub>7(the \<sigma>\<^bsub>route\<^esub>(rt, ip)))))"
      and c5: "\<lbrakk>ip \<in> kD(rt); \<pi>\<^sub>3(r) = unk\<rbrakk>
                \<Longrightarrow> P (rt (ip \<mapsto> (\<pi>\<^sub>2(the \<sigma>\<^bsub>route\<^esub>(rt, ip)), \<pi>\<^sub>3(r),
                                  \<pi>\<^sub>4(r), \<pi>\<^sub>5(r), \<pi>\<^sub>6(r), \<pi>\<^sub>7(addpre r (\<pi>\<^sub>7(the \<sigma>\<^bsub>route\<^esub>(rt, ip)))))))"
      and c6: "\<lbrakk>ip \<in> kD(rt); sqn rt ip \<ge> \<pi>\<^sub>2(r); \<pi>\<^sub>3(r) = kno;
                sqn rt ip = \<pi>\<^sub>2(r) \<Longrightarrow> the (dhops rt ip) \<le> \<pi>\<^sub>5(r) \<and> the (flag rt ip) = val\<rbrakk>
                \<Longrightarrow> P (rt (ip \<mapsto> addpre (the \<sigma>\<^bsub>route\<^esub>(rt, ip)) (\<pi>\<^sub>7(r))))"
  shows "(P (update rt ip r))"
  proof (cases "ip \<in> kD(rt)")
    assume "ip \<notin> kD(rt)"
    with c1 show ?thesis
      by simp
  next
    assume "ip \<in> kD(rt)"
    moreover then obtain dsn dsk fl hops nhip pre
      where rteq: "rt ip = Some (dsn, dsk, fl, hops, nhip, pre)"
        by (metis kD_Some)
    moreover obtain dsn' dsk' fl' hops' nhip' pre'
      where req: "r = (dsn', dsk', fl', hops', nhip', pre')"
        by (cases r) metis
    ultimately show ?thesis
      using \<open>(\<pi>\<^sub>2(r) = 0) = (\<pi>\<^sub>3(r) = unk)\<close>
            c2 [OF \<open>ip\<in>kD(rt)\<close>]
            c3 [OF \<open>ip\<in>kD(rt)\<close>]
            c4 [OF \<open>ip\<in>kD(rt)\<close>]
            c5 [OF \<open>ip\<in>kD(rt)\<close>]
            c6 [OF \<open>ip\<in>kD(rt)\<close>]
    unfolding update_def sqn_def by auto
  qed

lemma update_cases_kD:
  assumes "(\<pi>\<^sub>2(r) = 0) = (\<pi>\<^sub>3(r) = unk)"
      and "ip \<in> kD(rt)"
      and c2: "sqn rt ip < \<pi>\<^sub>2(r) \<Longrightarrow> P (rt (ip \<mapsto> addpre r (\<pi>\<^sub>7(the \<sigma>\<^bsub>route\<^esub>(rt, ip)))))"
      and c3: "\<lbrakk>sqn rt ip = \<pi>\<^sub>2(r); the (dhops rt ip) > \<pi>\<^sub>5(r)\<rbrakk>
                \<Longrightarrow> P (rt (ip \<mapsto> addpre r (\<pi>\<^sub>7(the \<sigma>\<^bsub>route\<^esub>(rt, ip)))))"
      and c4: "\<lbrakk>sqn rt ip = \<pi>\<^sub>2(r); the (flag rt ip) = inv\<rbrakk>
                \<Longrightarrow> P (rt (ip \<mapsto> addpre r (\<pi>\<^sub>7(the \<sigma>\<^bsub>route\<^esub>(rt, ip)))))"
      and c5: "\<pi>\<^sub>3(r) = unk \<Longrightarrow> P (rt (ip \<mapsto> (\<pi>\<^sub>2(the \<sigma>\<^bsub>route\<^esub>(rt, ip)), \<pi>\<^sub>3(r),
                                            \<pi>\<^sub>4(r), \<pi>\<^sub>5(r), \<pi>\<^sub>6(r),
                                            \<pi>\<^sub>7(addpre r (\<pi>\<^sub>7(the \<sigma>\<^bsub>route\<^esub>(rt, ip)))))))"
      and c6: "\<lbrakk>sqn rt ip \<ge> \<pi>\<^sub>2(r); \<pi>\<^sub>3(r) = kno;
                sqn rt ip = \<pi>\<^sub>2(r) \<Longrightarrow> the (dhops rt ip) \<le> \<pi>\<^sub>5(r) \<and> the (flag rt ip) = val\<rbrakk>
                \<Longrightarrow> P (rt (ip \<mapsto> addpre (the \<sigma>\<^bsub>route\<^esub>(rt, ip)) (\<pi>\<^sub>7(r))))"
  shows "(P (update rt ip r))"
  using assms(1) proof (rule update_cases)
    assume "sqn rt ip < \<pi>\<^sub>2(r)"
    thus "P (rt(ip \<mapsto> addpre r (\<pi>\<^sub>7(the (rt ip)))))" by (rule c2)
  next
    assume "sqn rt ip = \<pi>\<^sub>2(r)"
       and "the (dhops rt ip) > \<pi>\<^sub>5(r)"
    thus "P (rt(ip \<mapsto> addpre r (\<pi>\<^sub>7 (the (rt ip)))))"
      by (rule c3)
  next
    assume "sqn rt ip = \<pi>\<^sub>2(r)"
       and "the (flag rt ip) = inv"
    thus "P (rt(ip \<mapsto> addpre r (\<pi>\<^sub>7 (the (rt ip)))))"
      by (rule c4)
  next
    assume "\<pi>\<^sub>3(r) = unk"
    thus "P (rt (ip \<mapsto> (\<pi>\<^sub>2(the \<sigma>\<^bsub>route\<^esub>(rt, ip)), \<pi>\<^sub>3(r), \<pi>\<^sub>4(r), \<pi>\<^sub>5(r), \<pi>\<^sub>6(r),
                        \<pi>\<^sub>7(addpre r (\<pi>\<^sub>7(the (rt ip)))))))"
      by (rule c5)
  next
    assume "sqn rt ip \<ge> \<pi>\<^sub>2(r)"
       and "\<pi>\<^sub>3(r) = kno"
       and "sqn rt ip = \<pi>\<^sub>2(r) \<Longrightarrow> the (dhops rt ip) \<le> \<pi>\<^sub>5(r) \<and> the (flag rt ip) = val"
    thus "P (rt (ip \<mapsto> addpre (the (rt ip)) (\<pi>\<^sub>7(r))))"
      by (rule c6)
  qed (simp add: \<open>ip \<in> kD(rt)\<close>)

lemma in_kD_after_update [simp]:
  fixes rt nip dsn dsk flag hops nhip pre
  shows "kD (update rt nip (dsn, dsk, flag, hops, nhip, pre)) = insert nip (kD rt)"
  unfolding update_def
  by (cases "rt nip") auto

lemma nhop_of_update [simp]:
  fixes rt dip dsn dsk flag hops nhip
  assumes "rt \<noteq> update rt dip (dsn, dsk, flag, hops, nhip, {})"
  shows "the (nhop (update rt dip (dsn, dsk, flag, hops, nhip, {})) dip) = nhip"
  proof -
  from assms
  have update_neq: "\<And>v. rt dip = Some v \<Longrightarrow>
          update rt dip (dsn, dsk, flag, hops, nhip, {})
             \<noteq> rt(dip \<mapsto> addpre (the (rt dip)) (\<pi>\<^sub>7 (dsn, dsk, flag, hops, nhip, {})))"
    by auto
  show ?thesis
    proof (cases "rt dip = None")
      assume "rt dip = None"
      thus "?thesis" unfolding update_def by clarsimp
    next
      assume "rt dip \<noteq> None"
      then obtain v where "rt dip = Some v" by (metis not_None_eq)
      with update_neq [OF this] show ?thesis
        unfolding update_def by auto
    qed
  qed

lemma sqn_if_updated:
  fixes rip v rt ip
  shows "sqn (\<lambda>x. if x = rip then Some v else rt x) ip
         = (if ip = rip then \<pi>\<^sub>2(v) else sqn rt ip)"
  unfolding sqn_def by simp

lemma update_sqn [simp]:
  fixes rt dip rip dsn dsk hops nhip pre
  assumes "(dsn = 0) = (dsk = unk)"
  shows "sqn rt dip \<le> sqn (update rt rip (dsn, dsk, val, hops, nhip, pre)) dip"
  proof (rule update_cases)
    show "(\<pi>\<^sub>2 (dsn, dsk, val, hops, nhip, pre) = 0) = (\<pi>\<^sub>3 (dsn, dsk, val, hops, nhip, pre) = unk)"
      by simp (rule assms)
  qed (clarsimp simp: sqn_if_updated sqn_def)+

lemma sqn_update_bigger [simp]:
    fixes rt ip ip' dsn dsk flag hops nhip pre
  assumes "1 \<le> hops"
    shows "sqn rt ip \<le> sqn (update rt ip' (dsn, dsk, flag, hops, nhip, pre)) ip"
  using assms unfolding update_def sqn_def
  by (clarsimp split: option.split) auto

lemma dhops_update [intro]:
    fixes rt dsn dsk flag hops ip rip nhip pre
  assumes ex: "\<forall>ip\<in>kD rt. the (dhops rt ip) \<ge> 1"
      and ip: "(ip = rip \<and> Suc 0 \<le> hops) \<or> (ip \<noteq> rip \<and> ip\<in>kD rt)"
    shows "Suc 0 \<le> the (dhops (update rt rip (dsn, dsk, flag, hops, nhip, pre)) ip)"
  using ip proof
    assume "ip = rip \<and> Suc 0 \<le> hops" thus ?thesis
      unfolding update_def using ex
      by (cases "rip \<in> kD rt") (drule(1) bspec, auto)
  next
    assume "ip \<noteq> rip \<and> ip\<in>kD rt" thus ?thesis
      using ex unfolding update_def
      by (cases "rip\<in>kD rt") auto
  qed

lemma update_another [simp]:
    fixes dip ip rt dsn dsk flag hops nhip pre
  assumes "ip \<noteq> dip"
    shows "(update rt dip (dsn, dsk, flag, hops, nhip, pre)) ip = rt ip"
  using assms unfolding update_def
  by (clarsimp split: option.split)

lemma nhop_update_another [simp]:
    fixes dip ip rt dsn dsk flag hops nhip pre
  assumes "ip \<noteq> dip"
    shows "nhop (update rt dip (dsn, dsk, flag, hops, nhip, pre)) ip = nhop rt ip"
  using assms unfolding update_def
  by (clarsimp split: option.split)

lemma dhops_update_another [simp]:
    fixes dip ip rt dsn dsk flag hops nhip pre
  assumes "ip \<noteq> dip"
    shows "dhops (update rt dip (dsn, dsk, flag, hops, nhip, pre)) ip = dhops rt ip"
  using assms unfolding update_def
  by (clarsimp split: option.split)

lemma sqn_update_same [simp]:
  "\<And>rt ip dsn dsk flag hops nhip pre. sqn (rt(ip \<mapsto> v)) ip = \<pi>\<^sub>2(v)"
  unfolding sqn_def by simp

lemma dhops_update_changed [simp]:
    fixes rt dip osn hops nhip
  assumes "rt \<noteq> update rt dip (osn, kno, val, hops, nhip, {})"
    shows "the (dhops (update rt dip (osn, kno, val, hops, nhip, {})) dip) = hops"
  using assms unfolding update_def
  by (clarsimp split: option.split_asm option.split if_split_asm) auto

lemma nhop_update_changed [simp]:
    fixes rt dip dsn dsk flg hops sip
  assumes "update rt dip (dsn, dsk, flg, hops, sip, {}) \<noteq> rt"
    shows "the (nhop (update rt dip (dsn, dsk, flg, hops, sip, {})) dip) = sip"
  using assms unfolding update_def
  by (clarsimp split: option.splits if_split_asm) auto

lemma update_rt_split_asm:
  "\<And>rt ip dsn dsk flag hops sip.
   P (update rt ip (dsn, dsk, flag, hops, sip, {}))
   =
   (\<not>(rt = update rt ip (dsn, dsk, flag, hops, sip, {}) \<and> \<not>P rt
      \<or> rt \<noteq> update rt ip (dsn, dsk, flag, hops, sip, {})
         \<and> \<not>P (update rt ip (dsn, dsk, flag, hops, sip, {}))))"
  by auto

lemma sqn_update [simp]: "\<And>rt dip dsn flg hops sip.
  rt \<noteq> update rt dip (dsn, kno, flg, hops, sip, {})
  \<Longrightarrow> sqn (update rt dip (dsn, kno, flg, hops, sip, {})) dip = dsn"
  unfolding update_def by (clarsimp split: option.split if_split_asm) auto

lemma sqnf_update [simp]: "\<And>rt dip dsn dsk flg hops sip.
  rt \<noteq> update rt dip (dsn, dsk, flg, hops, sip, {})
  \<Longrightarrow> sqnf (update rt dip (dsn, dsk, flg, hops, sip, {})) dip = dsk"
  unfolding update_def sqnf_def
  by (clarsimp split: option.splits if_split_asm) auto

lemma update_kno_dsn_greater_zero:
  "\<And>rt dip ip dsn hops npre. 1 \<le> dsn \<Longrightarrow> 1 \<le> (sqn (update rt dip (dsn, kno, val, hops, ip, npre)) dip)"
   unfolding update_def
  by (clarsimp split: option.splits)

lemma proj3_update [simp]: "\<And>rt dip dsn dsk flg hops sip.
  rt \<noteq> update rt dip (dsn, dsk, flg, hops, sip, {})
  \<Longrightarrow> \<pi>\<^sub>3(the (update rt dip (dsn, dsk, flg, hops, sip, {}) dip)) = dsk"
  unfolding update_def sqnf_def
  by (clarsimp split: option.splits if_split_asm) auto

lemma nhop_update_changed_kno_val [simp]: "\<And>rt ip dsn dsk hops nhip.
  rt \<noteq> update rt ip (dsn, kno, val, hops, nhip, {})
   \<Longrightarrow> the (nhop (update rt ip (dsn, kno, val, hops, nhip, {})) ip) = nhip"
  unfolding update_def
  by (clarsimp split: option.split_asm option.split if_split_asm) auto

lemma flag_update [simp]: "\<And>rt dip dsn flg hops sip.
  rt \<noteq> update rt dip (dsn, kno, flg, hops, sip, {})
  \<Longrightarrow> the (flag (update rt dip (dsn, kno, flg, hops, sip, {})) dip) = flg"
  unfolding update_def
  by (clarsimp split: option.split if_split_asm) auto

lemma the_flag_Some [dest!]:
    fixes ip rt
  assumes "the (flag rt ip) = x"
      and "ip \<in> kD rt"
    shows "flag rt ip = Some x"
  using assms by auto

lemma kD_update_unchanged [dest]:
    fixes rt dip dsn dsk flag hops nhip pre
  assumes "rt = update rt dip (dsn, dsk, flag, hops, nhip, pre)"
    shows "dip\<in>kD(rt)"
  proof -
    have "dip\<in>kD(update rt dip (dsn, dsk, flag, hops, nhip, pre))" by simp
    with assms show ?thesis by simp
  qed

lemma nhop_update [simp]: "\<And>rt dip dsn dsk flg hops sip.
  rt \<noteq> update rt dip (dsn, dsk, flg, hops, sip, {})
  \<Longrightarrow> the (nhop (update rt dip (dsn, dsk, flg, hops, sip, {})) dip) = sip"
  unfolding update_def sqnf_def
  by (clarsimp split: option.splits if_split_asm) auto

lemma sqn_update_another [simp]:
    fixes dip ip rt dsn dsk flag hops nhip pre
  assumes "ip \<noteq> dip"
    shows "sqn (update rt dip (dsn, dsk, flag, hops, nhip, pre)) ip = sqn rt ip"
  using assms unfolding update_def sqn_def
  by (clarsimp split: option.splits) auto

lemma vD_update_val [dest]:
  "\<And>dip rt dip' dsn dsk hops nhip pre.
   dip \<in> vD(update rt dip' (dsn, dsk, val, hops, nhip, pre)) \<Longrightarrow> (dip\<in>vD(rt) \<or> dip=dip')"
   unfolding update_def vD_def by (clarsimp split: option.split_asm if_split_asm)

subsubsection "Invalidating route entries"

definition invalidate :: "rt \<Rightarrow> (ip \<rightharpoonup> sqn) \<Rightarrow> rt"
where "invalidate rt dests \<equiv>
  \<lambda>ip. case (rt ip, dests ip) of
    (None, _) \<Rightarrow> None
  | (Some s, None) \<Rightarrow> Some s
  | (Some (_, dsk, _, hops, nhip, pre), Some rsn) \<Rightarrow>
                      Some (rsn, dsk, inv, hops, nhip, pre)"

lemma proj3_invalidate [simp]:
  "\<And>dip. \<pi>\<^sub>3(the ((invalidate rt dests) dip)) = \<pi>\<^sub>3(the (rt dip))"
  unfolding invalidate_def by (clarsimp split: option.split)

lemma proj5_invalidate [simp]:
  "\<And>dip. \<pi>\<^sub>5(the ((invalidate rt dests) dip)) = \<pi>\<^sub>5(the (rt dip))"
  unfolding invalidate_def by (clarsimp split: option.split)

lemma proj6_invalidate [simp]:
  "\<And>dip. \<pi>\<^sub>6(the ((invalidate rt dests) dip)) = \<pi>\<^sub>6(the (rt dip))"
  unfolding invalidate_def by (clarsimp split: option.split)

lemma proj7_invalidate [simp]:
  "\<And>dip. \<pi>\<^sub>7(the ((invalidate rt dests) dip)) = \<pi>\<^sub>7(the (rt dip))"
  unfolding invalidate_def by (clarsimp split: option.split)

subsection "Route Requests"

lemma invalidate_kD_inv [simp]:
  "\<And>rt dests. kD (invalidate rt dests) = kD rt"
  unfolding invalidate_def kD_def
  by (simp split: option.split)

lemma invalidate_sqn:
  fixes rt dip dests
  assumes "\<forall>rsn. dests dip = Some rsn \<longrightarrow> sqn rt dip \<le> rsn"
  shows "sqn rt dip \<le> sqn (invalidate rt dests) dip"
  proof (cases "dip \<notin> kD(rt)")
    assume "\<not> dip \<notin> kD(rt)"
    hence "dip\<in>kD(rt)" by simp
    then obtain dsn dsk flag hops nhip pre where "rt dip = Some (dsn, dsk, flag, hops, nhip, pre)"
      by (metis kD_Some)
    with assms show "sqn rt dip \<le> sqn (invalidate rt dests) dip"
      by (cases "dests dip") (auto simp add: invalidate_def sqn_def)
  qed simp

lemma sqn_invalidate_in_dests [simp]:
    fixes dests ipa rsn rt
  assumes "dests ipa = Some rsn"
      and "ipa\<in>kD(rt)"
    shows "sqn (invalidate rt dests) ipa = rsn"
  unfolding invalidate_def sqn_def
  using assms(1) assms(2) [THEN kD_Some]
  by clarsimp

lemma dhops_invalidate [simp]:
  "\<And>dip. the (dhops (invalidate rt dests) dip) = the (dhops rt dip)"
  unfolding invalidate_def by (clarsimp split: option.split)

lemma sqnf_invalidate [simp]:
  "\<And>dip. sqnf (invalidate (rt \<xi>) (dests \<xi>)) dip = sqnf (rt \<xi>) dip"
  unfolding sqnf_def invalidate_def by (clarsimp split: option.split)

lemma nhop_invalidate [simp]:
  "\<And>dip. the (nhop (invalidate (rt \<xi>) (dests \<xi>)) dip) = the (nhop (rt \<xi>) dip)"
  unfolding invalidate_def by (clarsimp split: option.split)

lemma invalidate_other [simp]:
    fixes rt dests dip
  assumes "dip\<notin>dom(dests)"
    shows "invalidate rt dests dip = rt dip"
  using assms unfolding invalidate_def
  by (clarsimp split: option.split_asm)

lemma invalidate_none [simp]:
    fixes rt dests dip
  assumes "dip\<notin>kD(rt)"
    shows "invalidate rt dests dip = None"
  using assms unfolding invalidate_def by clarsimp

lemma vD_invalidate_vD_not_dests:
  "\<And>dip rt dests. dip\<in>vD(invalidate rt dests) \<Longrightarrow> dip\<in>vD(rt) \<and> dests dip = None"
  unfolding invalidate_def vD_def
  by (clarsimp split: option.split_asm)

lemma sqn_invalidate_not_in_dests [simp]:
  fixes dests dip rt
  assumes "dip\<notin>dom(dests)"
  shows "sqn (invalidate rt dests) dip = sqn rt dip"
  using assms unfolding sqn_def by simp

lemma invalidate_changes:
    fixes rt dests dip dsn dsk flag hops nhip pre
  assumes "invalidate rt dests dip = Some (dsn, dsk, flag, hops, nhip, pre)"
    shows "  dsn = (case dests dip of None \<Rightarrow> \<pi>\<^sub>2(the (rt dip)) | Some rsn \<Rightarrow> rsn)
           \<and> dsk = \<pi>\<^sub>3(the (rt dip))
           \<and> flag = (if dests dip = None then \<pi>\<^sub>4(the (rt dip)) else inv)
           \<and> hops = \<pi>\<^sub>5(the (rt dip))
           \<and> nhip = \<pi>\<^sub>6(the (rt dip))
           \<and> pre = \<pi>\<^sub>7(the (rt dip))"
  using assms unfolding invalidate_def
  by (cases "rt dip", clarsimp, cases "dests dip") auto

lemma proj3_inv: "\<And>dip rt dests. dip\<in>kD (rt)
                      \<Longrightarrow> \<pi>\<^sub>3(the (invalidate rt dests dip)) = \<pi>\<^sub>3(the (rt dip))"
  by (clarsimp simp: invalidate_def kD_def split: option.split)

lemma dests_iD_invalidate [simp]:
  assumes "dests ip = Some rsn"
      and "ip\<in>kD(rt)"
    shows "ip\<in>iD(invalidate rt dests)"
  using assms(1) assms(2) [THEN kD_Some] unfolding invalidate_def iD_def
  by (clarsimp split: option.split)

subsection "Queued Packets"

text \<open>Functions for sending data packets.\<close>

type_synonym store = "ip \<rightharpoonup> (p \<times> data list)"

definition sigma_queue :: "store \<Rightarrow> ip \<Rightarrow> data list"    ("\<sigma>\<^bsub>queue\<^esub>'(_, _')")
  where "\<sigma>\<^bsub>queue\<^esub>(store, dip) \<equiv> case store dip of None \<Rightarrow> [] | Some (p, q) \<Rightarrow> q"

definition qD :: "store \<Rightarrow> ip set"
  where "qD \<equiv> dom"

definition add :: "data \<Rightarrow> ip \<Rightarrow> store \<Rightarrow> store"
  where "add d dip store \<equiv> case store dip of
                              None \<Rightarrow> store (dip \<mapsto> (req, [d]))
                            | Some (p, q) \<Rightarrow> store (dip \<mapsto> (p, q @ [d]))"

lemma qD_add [simp]:
  fixes d dip store
  shows "qD(add d dip store) = insert dip (qD store)"
  unfolding add_def Let_def qD_def
  by (clarsimp split: option.split)

definition drop :: "ip \<Rightarrow> store \<rightharpoonup> store"
  where "drop dip store \<equiv>
    map_option (\<lambda>(p, q). if tl q = [] then store (dip := None)
                                      else store (dip \<mapsto> (p, tl q))) (store dip)"

definition sigma_p_flag :: "store \<Rightarrow> ip \<rightharpoonup> p" ("\<sigma>\<^bsub>p-flag\<^esub>'(_, _')")
  where "\<sigma>\<^bsub>p-flag\<^esub>(store, dip) \<equiv> map_option fst (store dip)"

definition unsetRRF :: "store \<Rightarrow> ip \<Rightarrow> store"
  where "unsetRRF store dip \<equiv> case store dip of
                                None \<Rightarrow> store
                              | Some (p, q) \<Rightarrow> store (dip \<mapsto> (noreq, q))"

definition setRRF :: "store \<Rightarrow> (ip \<rightharpoonup> sqn) \<Rightarrow> store"
  where "setRRF store dests \<equiv> \<lambda>dip. if dests dip = None then store dip
                                    else map_option (\<lambda>(_, q). (req, q)) (store dip)"

subsection "Comparison with the original technical report"

text \<open>
  The major differences with the AODV technical report of Fehnker et al are:
  \begin{enumerate}
  \item @{term nhop} is partial, thus a `@{term the}' is needed, similarly for @{term dhops}
        and @{term addpreRT}.
  \item @{term precs} is partial.
  \item @{term "\<sigma>\<^bsub>p-flag\<^esub>(store, dip)"} is partial.
  \item The routing table (@{typ rt}) is modelled as a map (@{typ "ip \<Rightarrow> r option"})
        rather than a set of 7-tuples, likewise, the @{typ r} is a 6-tuple rather than
        a 7-tuple, i.e., the destination ip-address (@{term "dip"}) is taken from the
        argument to the function, rather than a part of the result. Well-definedness then
        follows from the structure of the type and more related facts are available
        automatically, rather than having to be acquired through tedious proofs.
  \item Similar remarks hold for the dests mapping passed to @{term "invalidate"},
        and @{term "store"}.
  \end{enumerate}
\<close>

end


theory Cyclic_List imports
  "HOL-Library.Confluent_Quotient"
begin

inductive cyclic1 :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" for xs where
  "cyclic1 xs (rotate1 xs)"

abbreviation cyclic :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "cyclic \<equiv> equivclp cyclic1"

lemma cyclic_mapI: "cyclic xs ys \<Longrightarrow> cyclic (map f xs) (map f ys)"
  by(induction rule: equivclp_induct)
    (auto 4 4 elim!: cyclic1.cases simp add: rotate1_map[symmetric] intro: equivclp_into_equivclp cyclic1.intros)

quotient_type 'a cyclic_list = "'a list" / cyclic by simp

lemma map_respect_cyclic: includes lifting_syntax shows
  "((=) ===> cyclic ===> cyclic) map map"
  by(auto simp add: rel_fun_def cyclic_mapI)

lemma confluentp_cyclic1: "confluentp cyclic1"
  by(intro strong_confluentp_imp_confluentp strong_confluentpI)(auto simp add: cyclic1.simps)

lemma cyclic_set_eq: "cyclic xs ys \<Longrightarrow> set xs = set ys"
  by(induction rule: converse_equivclp_induct)(simp_all add: cyclic1.simps, safe, simp_all)

lemma retract_cyclic1:
  assumes "cyclic1 (map f xs) ys"
  shows "\<exists>zs. cyclic xs zs \<and> ys = map f zs"
  using assms by(auto simp add: cyclic1.simps rotate1_map intro: cyclic1.intros symclpI1)

lemma confluent_quotient_cyclic1:
  "confluent_quotient cyclic1 cyclic cyclic cyclic cyclic cyclic (map fst) (map snd) (map fst) (map snd) list_all2 list_all2 list_all2 set set"
  by(unfold_locales)
    (auto dest: retract_cyclic1 cyclic_set_eq simp add: list.in_rel list.rel_compp map_respect_cyclic[THEN rel_funD, OF refl] confluentp_cyclic1 intro: rtranclp_mono[THEN predicate2D, OF symclp_greater])

lift_bnf 'a cyclic_list
  subgoal by(rule confluent_quotient.subdistributivity[OF confluent_quotient_cyclic1])
  subgoal by(force dest: cyclic_set_eq)
  done

end


theory SPMF_Applicative imports
  Applicative_Lifting.Applicative_PMF
  Set_Applicative
  "HOL-Probability.SPMF"
begin

declare eq_on_def [simp del]

subsection \<open>Applicative instance for @{typ "'a spmf"}\<close>

abbreviation (input) pure_spmf :: "'a \<Rightarrow> 'a spmf"
where "pure_spmf \<equiv> return_spmf"

definition ap_spmf :: "('a \<Rightarrow> 'b) spmf \<Rightarrow> 'a spmf \<Rightarrow> 'b spmf"
where "ap_spmf f x = map_spmf (\<lambda>(f, x). f x) (pair_spmf f x)"

lemma ap_spmf_conv_bind: "ap_spmf f x = bind_spmf f (\<lambda>f. bind_spmf x (\<lambda>x. return_spmf (f x)))"
by(simp add: ap_spmf_def map_spmf_conv_bind_spmf pair_spmf_alt_def)

adhoc_overloading Applicative.ap ap_spmf

context includes applicative_syntax begin

lemma ap_spmf_id: "pure_spmf (\<lambda>x. x) \<diamondop> x = x"
by(simp add: ap_spmf_def pair_spmf_return_spmf1 spmf.map_comp o_def)

lemma ap_spmf_comp: "pure_spmf (\<circ>) \<diamondop> u \<diamondop> v \<diamondop> w = u \<diamondop> (v \<diamondop> w)"
by(simp add: ap_spmf_def pair_spmf_return_spmf1 pair_map_spmf1 pair_map_spmf2 spmf.map_comp o_def split_def pair_pair_spmf)

lemma ap_spmf_homo: "pure_spmf f \<diamondop> pure_spmf x = pure_spmf (f x)"
by(simp add: ap_spmf_def pair_spmf_return_spmf1)

lemma ap_spmf_interchange: "u \<diamondop> pure_spmf x = pure_spmf (\<lambda>f. f x) \<diamondop> u"
by(simp add: ap_spmf_def pair_spmf_return_spmf1 pair_spmf_return_spmf2 spmf.map_comp o_def)

lemma ap_spmf_C: "return_spmf (\<lambda>f x y. f y x) \<diamondop> f \<diamondop> x \<diamondop> y = f \<diamondop> y \<diamondop> x"
apply(simp add: ap_spmf_def pair_map_spmf1 spmf.map_comp pair_spmf_return_spmf1 pair_pair_spmf o_def split_def)
apply(subst (2) pair_commute_spmf)
apply(simp add: pair_map_spmf2 spmf.map_comp o_def split_def)
done

applicative spmf (C)
for
  pure: pure_spmf
  ap: ap_spmf
by(rule ap_spmf_id ap_spmf_comp[unfolded o_def[abs_def]] ap_spmf_homo ap_spmf_interchange ap_spmf_C)+

lemma set_ap_spmf [simp]: "set_spmf (p \<diamondop> q) = set_spmf p \<diamondop> set_spmf q"
by(auto simp add: ap_spmf_def ap_set_def)

lemma bind_ap_spmf: "bind_spmf (p \<diamondop> x) f = bind_spmf p (\<lambda>p. x \<bind> (\<lambda>x. f (p x)))"
by(simp add: ap_spmf_conv_bind)

lemma bind_pmf_ap_return_spmf [simp]: "bind_pmf (ap_spmf (return_spmf f) p) g = bind_pmf p (g \<circ> map_option f)"
by(auto simp add: ap_spmf_conv_bind bind_spmf_def bind_return_pmf bind_assoc_pmf intro: bind_pmf_cong split: option.split)

lemma map_spmf_conv_ap [applicative_unfold]: "map_spmf f p = return_spmf f \<diamondop> p"
by(simp add: map_spmf_conv_bind_spmf ap_spmf_conv_bind)

end

end