theory Shortest_Path_Tree
  imports "Graph_Theory.Graph_Theory" "Graph_Definitions" "Graph_Theory_Batteries" "Misc"
begin

text \<open>
This theory defines the notion of a partial shortest path tree in the locale @{text psp_tree}.
A partial shortest path tree contains the s nearest notes with respect to some weight function.
Since, at the time of writing, the definition of @{const forest} only guarantees acyclicity
and the definition of @{const tree} is also incorrect by extension, we develop our own definition
of a directed tree in the locale @{text directed_tree}.
\<close>

section \<open>Directed tree\<close>

text \<open>
The following locale defines the notion of a rooted directed tree. The tree property is
established by asserting a unique walk from the root to each vertex. Note that we need
@{const pre_digraph.awalk} and not @{const pre_digraph.apath} here since we want to have only one
incoming arc for each vertex. In the locale all the usual properties of trees are established, e.g.
non-existence of @{const pre_digraph.cycle}, absence of loops with @{locale loopfree_digraph} and
multi-arcs with @{locale nomulti_digraph}.
We also prove the admissibility of an induction rule for finite trees which constructs any tree
inductively by starting with a single node (the root) and consecutively adding leaves.
Finally we define the depth of a tree.
\<close>
locale directed_tree =
    wf_digraph T for T +
fixes
  root :: 'a
assumes
  root_in_T: "root \<in> verts T" and
  unique_awalk: "v \<in> verts T \<Longrightarrow> \<exists>!p. awalk root p v"
begin

subsection \<open>General properties of trees\<close>

lemma reachable_from_root: "v \<in> verts T \<Longrightarrow> root \<rightarrow>\<^sup>*\<^bsub>T\<^esub> v"
  using unique_awalk reachable_awalkI by blast

lemma non_empty: "verts T \<noteq> {}"
  using root_in_T by blast

theorem cycle_free: "\<nexists>c. cycle c"
proof
  assume "\<exists>c. cycle c"
  then obtain c where c: "cycle c" by blast
  from unique_awalk[of "awhd root c", OF awhd_in_verts[OF root_in_T, of c]]
  obtain p where p: "awalk root p (awhd root c)"
    using c[unfolded cycle_conv] unfolding awalk_conv by auto
  from c p awalk_appendI have "awalk root (p@c) (awhd root c)"
    by (metis awalkE' cycle_def awalk_verts_ne_eq)
  with unique_awalk p c show "False"
    using awalk_last_in_verts unfolding cycle_def by blast
qed

sublocale loopfree: loopfree_digraph T
proof(standard, rule ccontr)
  fix e assume arc: "e \<in> arcs T" and loop: "\<not> tail T e \<noteq> head T e"
  then have "cycle [e]"
    unfolding cycle_conv
    using arc_implies_awalk by force
  with cycle_free show "False" by blast
qed

sublocale nomulti: nomulti_digraph T
proof(standard, rule ccontr, goal_cases)
  case (1 e1 e2)
  let ?u = "tail T e1" and ?v = "head T e1"
  from unique_awalk obtain p where "awalk root p ?u"
    using 1 tail_in_verts by blast
  with 1 have "awalk root (p@[e1]) ?v" and "awalk root (p@[e2]) ?v"
    unfolding arc_to_ends_def
    using arc_implies_awalk by (fastforce)+

  with unique_awalk show "False"
    using \<open>e1 \<noteq> e2\<close> by blast
qed

lemma connected': "\<lbrakk> u \<in> verts T; v \<in> verts T \<rbrakk> \<Longrightarrow> u \<rightarrow>\<^sup>*\<^bsub>mk_symmetric T\<^esub> v"
proof -
  let ?T' = "mk_symmetric T"
  fix u v assume "u \<in> verts T" and "v \<in> verts T"
  then have "\<exists>up. awalk root up u" and "\<exists>vp. awalk root vp v"
    using unique_awalk by blast+
  then obtain up vp where up: "awalk root up u" and vp: "awalk root vp v" by blast
  then have "u \<rightarrow>\<^sup>*\<^bsub>mk_symmetric T\<^esub> root" and "root \<rightarrow>\<^sup>*\<^bsub>mk_symmetric T\<^esub> v"
    by (meson reachable_awalkI reachable_mk_symmetricI
        symmetric_mk_symmetric symmetric_reachable)+
  then show "u \<rightarrow>\<^sup>*\<^bsub>mk_symmetric T\<^esub> v"
    by (meson wellformed_mk_symmetric wf_digraph.reachable_trans wf_digraph_wp_iff)
qed

theorem connected: "connected T"
  unfolding connected_def strongly_connected_def
  using connected' root_in_T by auto

lemma unique_awalk_All: "\<exists>p. awalk u p v \<Longrightarrow> \<exists>!p. awalk u p v"
proof(rule ccontr, goal_cases)
  case 1
  then have "\<exists>p q. awalk u p v \<and> awalk u q v \<and> p \<noteq> q"
    by blast
  then obtain p q where
    p: "awalk u p v" and q: "awalk u q v" and "p \<noteq> q" by blast
  from unique_awalk obtain w where w: "awalk root w u"
    using \<open>awalk u p v\<close> by blast
  then have "awalk root (w@p) v" and "awalk root (w@q) v" and "(w@p) \<noteq> (w@q)"
    using \<open>awalk u p v\<close> \<open>awalk u q v\<close> \<open>p \<noteq> q\<close> awalk_appendI by auto
  with unique_awalk show ?case by blast
qed

lemma unique_arc:
  shows "u \<rightarrow>\<^bsub>T\<^esub> v \<Longrightarrow> \<exists>!e \<in> arcs T. tail T e = u \<and> head T e = v"
    and "(\<nexists>e. e \<in> arcs T \<and> tail T e = u \<and> head T e = v) \<Longrightarrow> \<not> u \<rightarrow>\<^bsub>T\<^esub> v"
  using unique_awalk_All nomulti.no_multi_arcs unfolding arc_to_ends_def
  by auto

lemma unique_arc_set:
  fixes u v
  defines "A \<equiv> {e \<in> arcs T. tail T e = u \<and> head T e = v}"
  shows "A = {} \<or> (\<exists>e. A = {e})"
proof(cases "u \<rightarrow>\<^bsub>T\<^esub> v")
  case True
  note unique_arc(1)[OF True]
  then show ?thesis unfolding A_def by blast
next
  case False
  then have "\<nexists>e. e \<in> arcs T \<and> tail T e = u \<and> head T e = v"
    using in_arcs_imp_in_arcs_ends arcs_ends_def by blast
  then show ?thesis unfolding A_def by auto
qed

lemma sp_eq_awalk_cost: "awalk a p b \<Longrightarrow> awalk_cost w p = \<mu> w a b"
proof -
  assume "awalk a p b"
  with unique_awalk_All have "{p. awalk a p b} = {p}"
    by blast
  then show ?thesis unfolding \<mu>_def
    by (metis cInf_singleton image_empty image_insert)
qed

lemma sp_cost_finite: "awalk a p b \<Longrightarrow> \<mu> w a b > -\<infinity> \<and> \<mu> w a b < \<infinity>"
  using sp_eq_awalk_cost[symmetric] by simp

theorem sp_append:
  "\<lbrakk> awalk a p b; awalk b q c \<rbrakk> \<Longrightarrow> \<mu> w a c = \<mu> w a b + \<mu> w b c"
proof -
  assume p: "awalk a p b" and q: "awalk b q c"
  then have p_q: "awalk a (p@q) c" by auto
  then have "awalk_cost w (p@q) = awalk_cost w p + awalk_cost w q"
    using awalk_cost_append by blast

  with p q p_q show ?thesis using sp_eq_awalk_cost
    by (metis plus_ereal.simps(1))
qed

text \<open>Convenience lemma which reformulates @{thm sp_append} to use reachability as assumptions.\<close>
lemma sp_append2: "\<lbrakk> v1 \<rightarrow>\<^sup>*\<^bsub>T\<^esub> v2; v2 \<rightarrow>\<^sup>*\<^bsub>T\<^esub> v3 \<rbrakk>
  \<Longrightarrow> \<mu> w v1 v3 = \<mu> w v1 v2 + \<mu> w v2 v3"
  using reachable_awalk sp_append by auto

theorem connected_minimal: "e \<in> arcs T \<Longrightarrow>  \<not> (tail T e) \<rightarrow>\<^sup>*\<^bsub>(del_arc e)\<^esub> (head T e)"
proof
  let ?T' = "del_arc e" and ?u = "tail T e" and ?v = "head T e"
  assume "e \<in> arcs T" and "?u \<rightarrow>\<^sup>*\<^bsub>?T'\<^esub> ?v"
  note e = this
  then have T'_wf: "wf_digraph ?T'" by blast

  from e have "awalk ?u [e] ?v"
    by (simp add: arc_implies_awalk)
  moreover
  note wf_digraph.reachable_awalk[OF T'_wf, of ?u ?v]
  with e obtain p where p: "pre_digraph.awalk ?T' ?u p ?v" by blast

  from e have "e \<notin> arcs ?T'" by simp
  with e p have "e \<notin> set p" by (meson T'_wf subsetCE wf_digraph.awalkE')
  with p have "[e] \<noteq> p" and "awalk ?u p ?v"
    by (auto simp: subgraph_awalk_imp_awalk subgraph_del_arc)

  ultimately show False using unique_awalk_All by blast
qed

lemma All_arcs_in_path: "e \<in> arcs T \<Longrightarrow> \<exists>p u v. awalk u p v \<and> e \<in> set p"
  by (meson arc_implies_awalk list.set_intros(1))

subsection \<open>An induction rule for finite trees\<close>
text \<open>
In this section we develop an induction rule for finite trees. Since this induction rule works by
inductively adding trees we first need to define the notion of a leaf and prove numerous facts
about them.
\<close>

definition (in pre_digraph) leaf :: "'a \<Rightarrow> bool" where
  "leaf v \<equiv> v \<in> verts G \<and> out_arcs G v = {}"

lemma in_degree_root_zero: "in_degree T root = 0"
proof(rule ccontr)
  assume "in_degree T root \<noteq> 0"
  then obtain e u where e: "tail T e = u" "head T e = root" "u \<in> verts T" "e \<in> arcs T"
    by (metis tail_in_verts all_not_in_conv card.empty in_degree_def in_in_arcs_conv)
  with unique_awalk obtain p where p: "awalk root p u" by blast
  with e have "awalk root (p@[e]) root"
    using awalk_appendI arc_implies_awalk by auto
  moreover
  have "awalk root [] root" by (simp add: awalk_Nil_iff root_in_T)
  ultimately show "False" using unique_awalk by blast
qed

lemma leaf_out_degree_zero: "leaf v \<Longrightarrow> out_degree T v = 0"
  unfolding leaf_def out_degree_def by auto

lemma two_in_arcs_contr:
  assumes "e1 \<in> arcs T" "e2 \<in> arcs T" and "e1 \<noteq> e2" and "head T e1 = head T e2"
  shows "False"
proof -
  from unique_awalk assms obtain p1 p2
    where "awalk root p1 (tail T e1)" and "awalk root p2 (tail T e2)"
    by (meson tail_in_verts in_in_arcs_conv)
  with assms have "awalk root (p1@[e1]) (head T e1)" and "awalk root (p2@[e2]) (head T e1)"
    unfolding in_arcs_def
    using arc_implies_awalk by force+
  with unique_awalk \<open>e1 \<noteq> e2\<close> show "False" by blast
qed

lemma in_arcs_finite: "v \<in> verts T \<Longrightarrow> finite (in_arcs T v)"
proof(rule ccontr)
  assume "\<not> finite (in_arcs T v)"
  then obtain e1 e2
    where e1_e2: "e1 \<in> in_arcs T v" "e2 \<in> in_arcs T v" "e1 \<noteq> e2"
    by (metis finite.emptyI finite_insert finite_subset insertI1 subsetI)
  with two_in_arcs_contr show "False" unfolding in_arcs_def by auto
qed

lemma not_root_imp_in_deg_one: "\<lbrakk> v \<in> verts T; v \<noteq> root \<rbrakk>  \<Longrightarrow> in_degree T v = 1"
proof(rule ccontr)
  assume "v \<noteq> root" and "v \<in> verts T" and "in_degree T v \<noteq> 1"
  then have "in_degree T v \<noteq> 0"
  proof -
    from unique_awalk \<open>v \<in> verts T\<close> obtain p where "awalk root p v" by blast
    with \<open>v \<noteq> root\<close> have "root \<rightarrow>\<^sup>+\<^bsub>T\<^esub> v" using reachable_awalkI by blast
    then have "\<exists>u. u \<rightarrow>\<^bsub>T\<^esub> v" by (meson tranclD2)
    then show ?thesis
      using in_arcs_finite[OF \<open>v \<in> verts T\<close>] unfolding in_degree_def
      using card_eq_0_iff by fastforce
  qed
  moreover
  have "\<not> in_degree T v \<ge> 2"
  proof
    assume in_deg_ge_2: "in_degree T v \<ge> 2"
    have "\<exists>e1 e2. e1 \<in> in_arcs T v \<and> e2 \<in> in_arcs T v \<and> e1 \<noteq> e2"
    proof(cases "in_arcs T v = {}")
      case True
      then show ?thesis using in_deg_ge_2[unfolded in_degree_def] by simp
    next
      case False
      then obtain e1 where "e1 \<in> in_arcs T v" by blast
      then have "card (in_arcs T v) = 1" if "\<forall>e2 \<in> in_arcs T v. e1 = e2"
        using that by(auto simp: card_Suc_eq[where ?A="(in_arcs T v)"])
      then show ?thesis
        using in_deg_ge_2[unfolded in_degree_def] \<open>e1 \<in> in_arcs T v\<close> by force
    qed
    with two_in_arcs_contr show "False" unfolding in_arcs_def by auto
  qed
  ultimately show "False" using \<open>in_degree T v \<noteq> 1\<close> by linarith
qed

lemma in_deg_one_imp_not_root: "\<lbrakk> v \<in> verts T; in_degree T v = 1 \<rbrakk>  \<Longrightarrow> v \<noteq> root"
  using in_degree_root_zero by auto

corollary in_deg_one_iff: "v \<in> verts T \<Longrightarrow> v \<noteq> root \<longleftrightarrow> in_degree T v = 1"
  using not_root_imp_in_deg_one in_deg_one_imp_not_root by blast

lemma ex_in_arc: "\<lbrakk> v \<noteq> root; v \<in> verts T \<rbrakk> \<Longrightarrow> \<exists>e. in_arcs T v = {e}"
  using not_root_imp_in_deg_one unfolding in_degree_def
  by (auto simp: card_Suc_eq)

lemma ex_leaf: "finite (verts T) \<Longrightarrow> \<exists>v \<in> verts T. leaf v"
proof(rule ccontr, simp)
  assume verts_fin: "finite (verts T)" and  no_leaves: "\<forall>x\<in>verts T. \<not> leaf x"
  then have "\<forall>x \<in> verts T. \<exists>e. e \<in> out_arcs T x"
    unfolding leaf_def by (simp add: out_arcs_def)
  then have "\<forall>x \<in> verts T. \<exists>x' e. awalk x [e] x'"
    unfolding out_arcs_def using arc_implies_awalk by force
  then have extend: "\<exists>p v'. awalk u (ps@[p]) v'" if "awalk u ps v" for u ps v
    using that by force
  have "\<exists>u p v. awalk u p v \<and> length p = n" for n
  proof(induction n)
    case 0
    from root_in_T have "awalk root [] root"
      by (simp add: awalk_Nil_iff)
    then show ?case by blast
  next
    case (Suc n)
    then obtain u p v where "awalk u p v" and "length p = n" by blast
    from extend[OF this(1)] obtain e v' where "awalk u (p@[e]) v'" and "length (p@[e]) = Suc n"
      using length_append_singleton \<open>length p = n\<close> by auto
    then show ?case by blast
  qed
  with awalk_not_distinct[OF verts_fin] have "\<exists>p. cycle p"
    using awalk_cyc_decompE' closed_w_imp_cycle by (metis order_refl)
  with cycle_free show False by blast
qed

lemma verts_finite_imp_arcs_finite: "finite (verts T) \<Longrightarrow> finite (arcs T)"
proof -
  assume "finite (verts T)"
  then have "finite (verts T \<times> verts T)" by simp
  let ?a = "\<lambda>(u,v). {e \<in> arcs T.  tail T e = u \<and> head T e = v}"
  let ?A = "\<Union>{?a e |e. e \<in> verts T \<times> verts T}"
  have "arcs T \<subseteq> ?A"
  proof
    fix e assume e: "e \<in> arcs T"
    then have "tail T e \<in> verts T" and "head T e \<in> verts T"
      using wellformed by auto
    with e show "e \<in> ?A" by blast
  qed
  moreover
  have "finite (?a (u,v))" for u v
    using unique_arc_set[of u v] finite.simps by auto
  with finite_Union[OF \<open>finite (verts T \<times> verts T)\<close>] have "finite ?A"
    by blast
  ultimately show "finite (arcs T)" using finite_subset by blast
qed

lemma root_leaf_iff: "leaf root \<longleftrightarrow> verts T = {root}"
proof
  from root_in_T show "verts T = {root} \<Longrightarrow> leaf root"
    using leaf_def ex_leaf by auto
  show "leaf root \<Longrightarrow> (verts T = {root})"
  proof(rule ccontr)
    assume "leaf root" and "verts T \<noteq> {root}"
    with non_empty obtain u where u: "u \<in> verts T" "u \<noteq>root"
      by blast
    with unique_awalk obtain p where p: "awalk root p u" by blast
    with \<open>u \<noteq> root\<close> obtain e where e: "e = hd p" "tail T e = root"
      by (metis awalkE' awalk_ends pre_digraph.cas_simp)
    with u p have "e \<in> out_arcs T root" unfolding out_arcs_def
      by (simp, metis awalkE awalk_ends hd_in_set subset_iff)
    with \<open>leaf root\<close> show "False"
      unfolding leaf_def out_degree_def by auto
  qed
qed

lemma leaf_not_mem_awalk:
  "\<lbrakk> leaf x; awalk u p v; v \<noteq> x \<rbrakk> \<Longrightarrow> x \<notin> set (awalk_verts u p)"
proof(induction p arbitrary: u)
  case Nil
  then have "u = v" unfolding awalk_conv by simp
  with Nil show ?case by auto
next
  case (Cons a p)
  then have "x \<notin> set (awalk_verts (head T a) p)" by (simp add: awalk_Cons_iff)
  moreover
  from Cons.prems have "tail T a \<noteq> x"
    unfolding leaf_def out_arcs_def by auto
  ultimately show ?case by simp
qed

lemma tree_del_vert:
  assumes "v \<noteq> root" and "leaf v"
  shows "directed_tree (del_vert v) root"
proof(unfold_locales)
  from \<open>v \<noteq> root\<close> show "root \<in> verts (del_vert v)" using verts_del_vert root_in_T by auto

  have "u\<in>verts (del_vert v) \<Longrightarrow> \<exists>!p. pre_digraph.awalk (del_vert v) root p u" for u
  proof -
    assume "u \<in> verts (del_vert v)"
    then have "u \<in> verts T" "u \<noteq> v" by (simp_all add: verts_del_vert)
    then obtain p where p: "awalk root p u" "\<forall>p'. awalk root p' u \<longrightarrow> p = p'"
    using unique_awalk[OF \<open>u \<in> verts T\<close>] by auto
    then have "v \<notin> set (awalk_verts root p)"
    using leaf_not_mem_awalk[OF \<open>leaf v\<close> _ \<open>u \<noteq> v\<close>] by blast
    with p have
      "pre_digraph.awalk (del_vert v) root p u"
      "\<forall>p'. pre_digraph.awalk (del_vert v) root p' u \<longrightarrow> p = p'"
      using awalk_del_vert subgraph_awalk_imp_awalk subgraph_del_vert by blast+
    then show ?thesis by blast
  qed
  then show "\<And>va. va \<in> verts (del_vert v)
  \<Longrightarrow> \<exists>!p. pre_digraph.awalk (del_vert v) root p va" by blast
qed (meson wf_digraph_del_vert wf_digraph_def)+

lemma arcs_del_leaf:
  assumes e: "e \<in> arcs T" "head T e = v" and v: "leaf v"
  shows "arcs (del_vert v) = arcs T - {e}"
proof -
  from v have "out_arcs T v = {}"
    unfolding pre_digraph.leaf_def by simp
  moreover
  from e v have "v \<noteq> root"
    using loopfree.no_loops root_leaf_iff by fastforce
  from ex_in_arc[OF this] v have "in_arcs T v = {e}"
    unfolding pre_digraph.leaf_def using e e two_in_arcs_contr by fastforce
  ultimately show ?thesis unfolding out_arcs_def in_arcs_def
    using arcs_del_vert2 by auto
qed

lemma finite_directed_tree_induct[consumes 1, case_names single_vert add_leaf]:
  assumes "finite (verts T)"
  assumes base: "\<And>t h root. P \<lparr> verts = {root}, arcs = {}, tail = t, head = h \<rparr>"
      and add_leaf: "\<And>T' V A t h u root a v. \<lbrakk>T' = \<lparr> verts = V, arcs = A, tail = t, head = h \<rparr>; finite (verts T');
            directed_tree T' root; P T'; u \<in> V; v \<notin> V; a \<notin> A\<rbrakk>
    \<Longrightarrow> P \<lparr> verts = V \<union> {v}, arcs = A \<union> {a}, tail = t(a := u), head = h(a := v) \<rparr>"
    shows "P T"
  using assms(1) directed_tree_axioms
proof(induction "card (verts T)" arbitrary: T root)
  case 0
  then have "verts T = {}" using card_eq_0_iff by simp
  with directed_tree.non_empty[OF \<open>directed_tree T root\<close>] show ?case by blast
next
  case (Suc n)
  then interpret tree_T: directed_tree T root by simp
  show ?case
  proof(cases "n = 0")
    case True
    with \<open>Suc n = card (verts T)\<close> have "card (verts T) = 1" by simp
    from mem_card1_singleton[OF tree_T.root_in_T this] have "verts T = {root}" .
    then have "arcs T = {}"
      using tree_T.loopfree.no_loops tree_T.tail_in_verts by fastforce
    with \<open>verts T = {root}\<close> have "T = \<lparr> verts = {root}, arcs = {}, tail = tail T, head = head T \<rparr>"
      by simp
    with base[of root "tail T" "head T"] show ?thesis by simp
  next
    case False

    from Suc.prems(1) have "finite (verts T)"
      using finite_insert by simp
    from tree_T.ex_leaf[OF this]
    obtain v where v: "tree_T.leaf v" by blast
    with False have "v \<noteq> root"
      using tree_T.root_leaf_iff Suc.hyps(2) by fastforce
    note v = \<open>tree_T.leaf v\<close> \<open>v \<noteq> root\<close>

    let ?T' = "tree_T.del_vert v"
    have T': "?T' = \<lparr> verts = verts ?T', arcs = arcs ?T', tail = tail ?T', head = head ?T' \<rparr>"
      by simp
    note tree_T.tree_del_vert[OF v(2,1)]
    moreover
    have "finite (verts ?T')"
      by (simp add: tree_T.verts_del_vert \<open>finite (verts T)\<close>)
    moreover
    from \<open>finite (verts ?T')\<close> Suc.hyps(2) Suc.prems(1) have "card (verts ?T') = n"
      using tree_T.verts_del_vert v(1)[unfolded tree_T.leaf_def] by auto
    moreover
    from tree_T.ex_in_arc[OF v(2)]
    obtain e where e: "in_arcs T v = {e}" "tail T e \<in> verts T"
      using v(1)[unfolded tree_T.leaf_def] by force
    then have "tail T e \<in> verts ?T'"
      unfolding in_arcs_def using tree_T.arcs_del_vert[of v]
      using tree_T.loopfree.no_loops tree_T.verts_del_vert[of v]
      using v(1)[unfolded tree_T.leaf_def] by fastforce
    moreover
    from Suc.hyps(1) have "P ?T'" using calculation by blast
    moreover
    note tree_T.verts_del_vert[of v]
    moreover
    from e have "head T e = v" unfolding in_arcs_def by blast
    then have "e \<notin> arcs ?T'" unfolding tree_T.arcs_del_vert by simp

    ultimately have "P \<lparr> verts = verts ?T' \<union> {v}, arcs = arcs ?T' \<union> {e},
      tail = (tail ?T')(e := (tail T e)), head = (head ?T')(e := v) \<rparr>"
      using add_leaf[OF T'] by blast
    moreover
    have "T = \<lparr> verts = verts ?T' \<union> {v}, arcs = arcs ?T' \<union> {e},
      tail = (tail ?T')(e := (tail T e)), head = (head ?T')(e := v) \<rparr>"
    proof -
      have "verts T = verts ?T' \<union> {v}"
        using v(1)[unfolded tree_T.leaf_def] tree_T.verts_del_vert[of v] by fastforce
      moreover
      have "arcs ?T' = arcs T - out_arcs T v - in_arcs T v"
        using tree_T.arcs_del_vert2 by fastforce
      with e v(1)[unfolded pre_digraph.leaf_def] have "arcs T = arcs ?T' \<union> {e}" by auto
      moreover
      have "tail T = (tail ?T')(e := (tail T e))"
        by (simp add: tree_T.tail_del_vert)
      moreover
      from e[unfolded in_arcs_def] have "head T = (head ?T')(e := v)"
        using tree_T.head_del_vert \<open>head T e = v\<close> by auto
      ultimately show ?thesis by simp
    qed
    ultimately show ?thesis by simp
  qed
qed

text \<open>A simple consequence of the induction rule is that a tree with n vertices has n-1 arcs.\<close>
lemma Suc_card_arcs_eq_card_verts:
  assumes "finite (verts T)"
  shows "Suc (card (arcs T)) = card (verts T)"
using assms
proof(induction rule: finite_directed_tree_induct)
  case (single_vert)
  then show ?case by simp
next
  case (add_leaf)
  then show ?case
    using directed_tree.verts_finite_imp_arcs_finite
    by fastforce
qed

subsection \<open>Depth of a tree\<close>

definition depth where "depth w \<equiv> Sup {\<mu> w root v|v. v \<in> verts T}"

context
  fixes w :: "'b weight_fun"
  assumes "\<forall>e \<in> arcs T. w e \<ge> 0"
begin

lemma sp_from_root_le: "u \<rightarrow>\<^sup>*\<^bsub>T\<^esub> v \<Longrightarrow> \<mu> w root v \<ge> \<mu> w u v"
proof -
  assume "u \<rightarrow>\<^sup>*\<^bsub>T\<^esub> v"

  have "\<mu> w root u \<ge> 0"
    using \<open>\<forall>e\<in>arcs T. 0 \<le> w e\<close> sp_non_neg_if_w_non_neg by simp
  moreover
  have "root \<rightarrow>\<^sup>*\<^bsub>T\<^esub> u"
    using \<open>u \<rightarrow>\<^sup>*\<^bsub>T\<^esub> v\<close> reachable_from_root reachable_in_verts(1) by auto
  ultimately show ?thesis
    using \<open>u \<rightarrow>\<^sup>*\<^bsub>T\<^esub> v\<close> sp_append2 ereal_le_add_self2 by auto
qed

lemma depth_lowerB: "v \<in> verts T \<Longrightarrow> depth w \<ge> \<mu> w root v"
proof -
  assume "v \<in> verts T"
  then have "\<mu> w root v \<in> {\<mu> w root v|v. v \<in> verts T}" by auto
  then show "depth w \<ge> \<mu> w root v"
    unfolding depth_def by (simp add: Sup_upper)
qed

lemma depth_upperB: "\<forall>v \<in> verts T. \<mu> w root v \<le> d \<Longrightarrow> depth w \<le> d"
proof -
  assume "\<forall>v \<in> verts T. \<mu> w root v \<le> d"
  then have "\<forall>x \<in> {\<mu> w root v |v. v \<in> verts T}. x \<le> d"
    by auto
  then show ?thesis
    unfolding depth_def using Sup_least by fast
qed

text \<open>
This relation between depth of a tree and its diameter is later used to establish the
correctness of the diameter estimate.
\<close>
lemma depth_eq_fin_dia: "fin_digraph T \<Longrightarrow> depth w = fin_diameter w"
proof -
  assume "fin_digraph T"
  have "\<forall>v \<in> verts T. \<mu> w root v < \<infinity>"
    using \<mu>_reach_conv reachable_from_root by blast
  then have "{\<mu> w root v|v. v \<in> verts T} \<subseteq> fin_sp_costs w"
    unfolding fin_sp_costs_def using root_in_T by blast
  then have "depth w \<le> fin_diameter w"
    unfolding depth_def fin_diameter_def by (simp add: Sup_subset_mono)
  moreover
  have "\<not> depth w < fin_diameter w"
  proof
    assume "depth w < fin_diameter w"
    obtain u v where "\<mu> w u v = fin_diameter w" "u \<in> verts T" "v \<in> verts T"
      using fin_digraph.ex_sp_eq_fin_dia[OF \<open>fin_digraph T\<close> non_empty] by blast
    then have "u \<rightarrow>\<^sup>*\<^bsub>T\<^esub> v"
      by (metis \<mu>_reach_conv fin_digraph.fin_diameter_finite[OF \<open>fin_digraph T\<close>])
    then have "\<mu> w u v \<le> \<mu> w root v" using sp_from_root_le by blast
    also have "\<dots> \<le> depth w" using depth_lowerB[OF \<open>v \<in> verts T\<close>] by simp
    finally have "fin_diameter w \<le> depth w"
      using \<open>\<mu> w u v = fin_diameter w\<close> by simp
    with \<open>depth w < fin_diameter w\<close> show False by simp
  qed
  ultimately show ?thesis by simp
qed

end

end

section \<open>Subgraph locale\<close>

locale subgraph =
    G: wf_digraph G for T G +
assumes
  sub_G: "subgraph T G"
begin

sublocale wf_digraph T
  using sub_G unfolding subgraph_def by blast

lemma awalk_sub_imp_awalk:
  "awalk a p b \<Longrightarrow> G.awalk a p b"
  using G.subgraph_awalk_imp_awalk sub_G by force

end

section \<open>Partial shortest path three\<close>

locale psp_tree =
  directed_tree T source + subgraph T G for G T w source n +
  assumes
    source_in_G: "source \<in> verts G" and
    partial: "G.n_nearest_verts w source n (verts T)" and
    sp: "u \<in> verts T \<Longrightarrow> \<mu> w source u = G.\<mu> w source u"
begin

text \<open>
Here we formalize the notion of a partial shortest path tree. This is a shortest path tree where
only the @{term n} nearest nodes in the graph @{term G} are explored.
Consequently, a partial shortest path tree is a subtree of the complete shortest path tree.
We can obtain the complete shortest path tree by choosing n to be larger than the cardinality
of the graph @{term G}.
\<close>

sublocale fin_digraph T
proof(unfold_locales)
  show "finite (verts T)" using G.nnvs_finite[OF partial] .
  from verts_finite_imp_arcs_finite[OF this] show "finite (arcs T)" .
qed

lemma card_verts_le: "card (verts T) \<le> Suc n"
  using G.nnvs_card_le_n partial by auto

lemma reachable_subs: "{x. r \<rightarrow>\<^sup>*\<^bsub>T\<^esub> x} \<subseteq> {x. r \<rightarrow>\<^sup>*\<^bsub>G\<^esub> x}"
  by (simp add: Collect_mono G.reachable_mono sub_G)

text \<open>The following lemma proves that we explore all nodes if we set @{term n} large enough.\<close>
lemma sp_tree:
  assumes "fin_digraph G"
  assumes card_reachable: "Suc n \<ge> card {x. source \<rightarrow>\<^sup>*\<^bsub>G\<^esub> x}"
  shows "verts T = {x. source \<rightarrow>\<^sup>*\<^bsub>G\<^esub> x}"
  using fin_digraph.nnvs_imp_all_reachable_Suc[OF \<open>fin_digraph G\<close> partial card_reachable] .

corollary sp_tree2:
  assumes "fin_digraph G"
  assumes "Suc n \<ge> card (verts G)"
  shows "verts T = {x. source \<rightarrow>\<^sup>*\<^bsub>G\<^esub> x}"
proof -
  have "{x. source \<rightarrow>\<^sup>*\<^bsub>G\<^esub> x} \<subseteq> verts G"
    using source_in_G G.reachable_in_verts(2) by blast
  then have "Suc n \<ge> card {x. source \<rightarrow>\<^sup>*\<^bsub>G\<^esub> x}"
    using \<open>Suc n \<ge> card (verts G)\<close> fin_digraph.finite_verts[OF \<open>fin_digraph G\<close>]
    by (meson card_mono dual_order.trans)
  from sp_tree[OF \<open>fin_digraph G\<close> this] show ?thesis .
qed

lemma strongly_con_imp_card_verts_eq:
  assumes "fin_digraph G"
  assumes "strongly_connected G"
  assumes card_verts: "Suc n \<le> card (verts G)"
  shows "card (verts T) = Suc n"
proof -
  have verts_G: "verts G = {x. source \<rightarrow>\<^sup>*\<^bsub>G\<^esub> x}"
    using G.strongly_con_imp_reachable_eq_verts
      [OF source_in_G \<open>strongly_connected G\<close>, symmetric] .
  with card_verts have "Suc n \<le> card {x. source \<rightarrow>\<^sup>*\<^bsub>G\<^esub> x}" by simp

  from fin_digraph.nnvs_imp_reachable[OF \<open>fin_digraph G\<close> partial this]
  show ?thesis by blast
qed

lemma depth_fin_dia_lB:
  assumes "\<forall>e \<in> arcs G. w e \<ge> 0"
  shows "depth w \<le> G.fin_diameter w"
proof(rule ccontr)
  assume "\<not> depth w \<le> G.fin_diameter w"
  then have "depth w > G.fin_diameter w"
    by auto
  then have "\<exists>v \<in> verts T. \<mu> w source v > G.fin_diameter w"
    unfolding depth_def by (auto simp: less_Sup_iff)
  then obtain v where v: "v \<in> verts T" "v \<in> verts G" "\<mu> w source v > G.fin_diameter w"
    using sub_G by blast
  moreover
  have "\<mu> w source v < \<infinity>"
    using reachable_from_root \<mu>_reach_conv v(1) by blast
  ultimately show "False"
    using source_in_G G.fin_dia_lowerB[OF source_in_G \<open>v \<in> verts G\<close>] sp v
    by (simp add: leD)
qed

end

end


(*  Title:      HOL/Old_Number_Theory/IntPrimes.thy
    Author:     Thomas M. Rasmussen
    Copyright   2000  University of Cambridge
*)

section {* Divisibility and prime numbers (on integers) *}

theory IntPrimes
imports Primes
begin

text {*
  The @{text dvd} relation, GCD, Euclid's extended algorithm, primes,
  congruences (all on the Integers).  Comparable to theory @{text
  Primes}, but @{text dvd} is included here as it is not present in
  main HOL.  Also includes extended GCD and congruences not present in
  @{text Primes}.
*}

subsection {* Definitions *}

fun xzgcda :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int => (int * int * int)"
where
  "xzgcda m n r' r s' s t' t =
        (if r \<le> 0 then (r', s', t')
         else xzgcda m n r (r' mod r)
                      s (s' - (r' div r) * s)
                      t (t' - (r' div r) * t))"

definition zprime :: "int \<Rightarrow> bool"
  where "zprime p = (1 < p \<and> (\<forall>m. 0 <= m & m dvd p --> m = 1 \<or> m = p))"

definition xzgcd :: "int => int => int * int * int"
  where "xzgcd m n = xzgcda m n m n 1 0 0 1"

definition zcong :: "int => int => int => bool"  ("(1[_ = _] '(mod _'))")
  where "[a = b] (mod m) = (m dvd (a - b))"

subsection {* Euclid's Algorithm and GCD *}

lemma zrelprime_zdvd_zmult_aux:
     "zgcd n k = 1 ==> k dvd m * n ==> 0 \<le> m ==> k dvd m"
    by (metis abs_of_nonneg dvd_triv_right zgcd_greatest_iff zgcd_zmult_distrib2_abs mult_1_right)

lemma zrelprime_zdvd_zmult: "zgcd n k = 1 ==> k dvd m * n ==> k dvd m"
  apply (case_tac "0 \<le> m")
   apply (blast intro: zrelprime_zdvd_zmult_aux)
  apply (subgoal_tac "k dvd -m")
   apply (rule_tac [2] zrelprime_zdvd_zmult_aux, auto)
  done

lemma zgcd_geq_zero: "0 <= zgcd x y"
  by (auto simp add: zgcd_def)

text{*This is merely a sanity check on zprime, since the previous version
      denoted the empty set.*}
lemma "zprime 2"
  apply (auto simp add: zprime_def)
  apply (frule zdvd_imp_le, simp)
  apply (auto simp add: order_le_less dvd_def)
  done

lemma zprime_imp_zrelprime:
    "zprime p ==> \<not> p dvd n ==> zgcd n p = 1"
  apply (auto simp add: zprime_def)
  apply (metis zgcd_geq_zero zgcd_zdvd1 zgcd_zdvd2)
  done

lemma zless_zprime_imp_zrelprime:
    "zprime p ==> 0 < n ==> n < p ==> zgcd n p = 1"
  apply (erule zprime_imp_zrelprime)
  apply (erule zdvd_not_zless, assumption)
  done

lemma zprime_zdvd_zmult:
    "0 \<le> (m::int) ==> zprime p ==> p dvd m * n ==> p dvd m \<or> p dvd n"
  by (metis zgcd_zdvd1 zgcd_zdvd2 zgcd_pos zprime_def zrelprime_dvd_mult)

lemma zgcd_zadd_zmult [simp]: "zgcd (m + n * k) n = zgcd m n"
  apply (rule zgcd_eq [THEN trans])
  apply (simp add: mod_add_eq)
  apply (rule zgcd_eq [symmetric])
  done

lemma zgcd_zdvd_zgcd_zmult: "zgcd m n dvd zgcd (k * m) n"
by (simp add: zgcd_greatest_iff)

lemma zgcd_zmult_zdvd_zgcd:
    "zgcd k n = 1 ==> zgcd (k * m) n dvd zgcd m n"
  apply (simp add: zgcd_greatest_iff)
  apply (rule_tac n = k in zrelprime_zdvd_zmult)
   prefer 2
   apply (simp add: mult.commute)
  apply (metis zgcd_1 zgcd_commute zgcd_left_commute)
  done

lemma zgcd_zmult_cancel: "zgcd k n = 1 ==> zgcd (k * m) n = zgcd m n"
  by (simp add: zgcd_def nat_abs_mult_distrib gcd_mult_cancel)

lemma zgcd_zgcd_zmult:
    "zgcd k m = 1 ==> zgcd n m = 1 ==> zgcd (k * n) m = 1"
  by (simp add: zgcd_zmult_cancel)

lemma zdvd_iff_zgcd: "0 < m ==> m dvd n \<longleftrightarrow> zgcd n m = m"
  by (metis abs_of_pos dvd_mult_div_cancel zgcd_0 zgcd_commute zgcd_geq_zero zgcd_zdvd2 zgcd_zmult_eq_self)

subsection {* Congruences *}

lemma zcong_1 [simp]: "[a = b] (mod 1)"
  by (unfold zcong_def, auto)

lemma zcong_refl [simp]: "[k = k] (mod m)"
  by (unfold zcong_def, auto)

lemma zcong_sym: "[a = b] (mod m) = [b = a] (mod m)"
  unfolding zcong_def minus_diff_eq [of a, symmetric] dvd_minus_iff ..

lemma zcong_zadd:
    "[a = b] (mod m) ==> [c = d] (mod m) ==> [a + c = b + d] (mod m)"
  apply (unfold zcong_def)
  apply (rule_tac s = "(a - b) + (c - d)" in subst)
   apply (rule_tac [2] dvd_add, auto)
  done

lemma zcong_zdiff:
    "[a = b] (mod m) ==> [c = d] (mod m) ==> [a - c = b - d] (mod m)"
  apply (unfold zcong_def)
  apply (rule_tac s = "(a - b) - (c - d)" in subst)
   apply (rule_tac [2] dvd_diff, auto)
  done

lemma zcong_trans:
  "[a = b] (mod m) ==> [b = c] (mod m) ==> [a = c] (mod m)"
unfolding zcong_def by (auto elim!: dvdE simp add: algebra_simps)

lemma zcong_zmult:
    "[a = b] (mod m) ==> [c = d] (mod m) ==> [a * c = b * d] (mod m)"
  apply (rule_tac b = "b * c" in zcong_trans)
   apply (unfold zcong_def)
  apply (metis right_diff_distrib dvd_mult mult.commute)
  apply (metis right_diff_distrib dvd_mult)
  done

lemma zcong_scalar: "[a = b] (mod m) ==> [a * k = b * k] (mod m)"
  by (rule zcong_zmult, simp_all)

lemma zcong_scalar2: "[a = b] (mod m) ==> [k * a = k * b] (mod m)"
  by (rule zcong_zmult, simp_all)

lemma zcong_zmult_self: "[a * m = b * m] (mod m)"
  apply (unfold zcong_def)
  apply (rule dvd_diff, simp_all)
  done

lemma zcong_square:
   "[| zprime p;  0 < a;  [a * a = 1] (mod p)|]
    ==> [a = 1] (mod p) \<or> [a = p - 1] (mod p)"
  apply (unfold zcong_def)
  apply (rule zprime_zdvd_zmult)
    apply (rule_tac [3] s = "a * a - 1 + p * (1 - a)" in subst)
     prefer 4
     apply (simp add: zdvd_reduce)
    apply (simp_all add: left_diff_distrib mult.commute right_diff_distrib)
  done

lemma zcong_cancel:
  "0 \<le> m ==>
    zgcd k m = 1 ==> [a * k = b * k] (mod m) = [a = b] (mod m)"
  apply safe
   prefer 2
   apply (blast intro: zcong_scalar)
  apply (case_tac "b < a")
   prefer 2
   apply (subst zcong_sym)
   apply (unfold zcong_def)
   apply (rule_tac [!] zrelprime_zdvd_zmult)
     apply (simp_all add: left_diff_distrib)
  apply (subgoal_tac "m dvd (-(a * k - b * k))")
   apply simp
  apply (subst dvd_minus_iff, assumption)
  done

lemma zcong_cancel2:
  "0 \<le> m ==>
    zgcd k m = 1 ==> [k * a = k * b] (mod m) = [a = b] (mod m)"
  by (simp add: mult.commute zcong_cancel)

lemma zcong_zgcd_zmult_zmod:
  "[a = b] (mod m) ==> [a = b] (mod n) ==> zgcd m n = 1
    ==> [a = b] (mod m * n)"
  apply (auto simp add: zcong_def dvd_def)
  apply (subgoal_tac "m dvd n * ka")
   apply (subgoal_tac "m dvd ka")
    apply (case_tac [2] "0 \<le> ka")
  apply (metis dvd_mult_div_cancel dvd_refl dvd_mult_left mult.commute zrelprime_zdvd_zmult)
  apply (metis abs_dvd_iff abs_of_nonneg add_0 zgcd_0_left zgcd_commute zgcd_zadd_zmult zgcd_zdvd_zgcd_zmult zgcd_zmult_distrib2_abs mult_1_right mult.commute)
  apply (metis mult_le_0_iff  zdvd_mono zdvd_mult_cancel dvd_triv_left zero_le_mult_iff order_antisym linorder_linear order_refl mult.commute zrelprime_zdvd_zmult)
  apply (metis dvd_triv_left)
  done

lemma zcong_zless_imp_eq:
  "0 \<le> a ==>
    a < m ==> 0 \<le> b ==> b < m ==> [a = b] (mod m) ==> a = b"
  apply (unfold zcong_def dvd_def, auto)
  apply (drule_tac f = "\<lambda>z. z mod m" in arg_cong)
  apply (metis diff_add_cancel mod_pos_pos_trivial add_0 add.commute zmod_eq_0_iff mod_add_right_eq)
  done

lemma zcong_square_zless:
  "zprime p ==> 0 < a ==> a < p ==>
    [a * a = 1] (mod p) ==> a = 1 \<or> a = p - 1"
  apply (cut_tac p = p and a = a in zcong_square)
     apply (simp add: zprime_def)
    apply (auto intro: zcong_zless_imp_eq)
  done

lemma zcong_not:
    "0 < a ==> a < m ==> 0 < b ==> b < a ==> \<not> [a = b] (mod m)"
  apply (unfold zcong_def)
  apply (rule zdvd_not_zless, auto)
  done

lemma zcong_zless_0:
    "0 \<le> a ==> a < m ==> [a = 0] (mod m) ==> a = 0"
  apply (unfold zcong_def dvd_def, auto)
  apply (metis div_pos_pos_trivial linorder_not_less div_mult_self1_is_id)
  done

lemma zcong_zless_unique:
    "0 < m ==> (\<exists>!b. 0 \<le> b \<and> b < m \<and> [a = b] (mod m))"
  apply auto
   prefer 2 apply (metis zcong_sym zcong_trans zcong_zless_imp_eq)
  apply (unfold zcong_def dvd_def)
  apply (rule_tac x = "a mod m" in exI, auto)
  apply (metis zmult_div_cancel)
  done

lemma zcong_iff_lin: "([a = b] (mod m)) = (\<exists>k. b = a + m * k)"
  unfolding zcong_def
  apply (auto elim!: dvdE simp add: algebra_simps)
  apply (rule_tac x = "-k" in exI) apply simp
  done

lemma zgcd_zcong_zgcd:
  "0 < m ==>
    zgcd a m = 1 ==> [a = b] (mod m) ==> zgcd b m = 1"
  by (auto simp add: zcong_iff_lin)

lemma zcong_zmod_aux:
     "a - b = (m::int) * (a div m - b div m) + (a mod m - b mod m)"
  by(simp add: right_diff_distrib add_diff_eq eq_diff_eq ac_simps)

lemma zcong_zmod: "[a = b] (mod m) = [a mod m = b mod m] (mod m)"
  apply (unfold zcong_def)
  apply (rule_tac t = "a - b" in ssubst)
  apply (rule_tac m = m in zcong_zmod_aux)
  apply (rule trans)
   apply (rule_tac [2] k = m and m = "a div m - b div m" in zdvd_reduce)
  apply (simp add: add.commute)
  done

lemma zcong_zmod_eq: "0 < m ==> [a = b] (mod m) = (a mod m = b mod m)"
  apply auto
  apply (metis pos_mod_conj zcong_zless_imp_eq zcong_zmod)
  apply (metis zcong_refl zcong_zmod)
  done

lemma zcong_zminus [iff]: "[a = b] (mod -m) = [a = b] (mod m)"
  by (auto simp add: zcong_def)

lemma zcong_zero [iff]: "[a = b] (mod 0) = (a = b)"
  by (auto simp add: zcong_def)

lemma "[a = b] (mod m) = (a mod m = b mod m)"
  apply (cases "m = 0", simp)
  apply (simp add: linorder_neq_iff)
  apply (erule disjE)
   prefer 2 apply (simp add: zcong_zmod_eq)
  txt{*Remainding case: @{term "m<0"}*}
  apply (rule_tac t = m in minus_minus [THEN subst])
  apply (subst zcong_zminus)
  apply (subst zcong_zmod_eq, arith)
  apply (frule neg_mod_bound [of _ a], frule neg_mod_bound [of _ b])
  apply (simp add: zmod_zminus2_eq_if del: neg_mod_bound)
  done

subsection {* Modulo *}

lemma zmod_zdvd_zmod:
    "0 < (m::int) ==> m dvd b ==> (a mod b mod m) = (a mod m)"
  by (rule mod_mod_cancel)

subsection {* Extended GCD *}

declare xzgcda.simps [simp del]

lemma xzgcd_correct_aux1:
  "zgcd r' r = k --> 0 < r -->
    (\<exists>sn tn. xzgcda m n r' r s' s t' t = (k, sn, tn))"
  apply (induct m n r' r s' s t' t rule: xzgcda.induct)
  apply (subst zgcd_eq)
  apply (subst xzgcda.simps, auto)
  apply (case_tac "r' mod r = 0")
   prefer 2
   apply (frule_tac a = "r'" in pos_mod_sign, auto)
  apply (rule exI)
  apply (rule exI)
  apply (subst xzgcda.simps, auto)
  done

lemma xzgcd_correct_aux2:
  "(\<exists>sn tn. xzgcda m n r' r s' s t' t = (k, sn, tn)) --> 0 < r -->
    zgcd r' r = k"
  apply (induct m n r' r s' s t' t rule: xzgcda.induct)
  apply (subst zgcd_eq)
  apply (subst xzgcda.simps)
  apply (auto simp add: linorder_not_le)
  apply (case_tac "r' mod r = 0")
   prefer 2
   apply (frule_tac a = "r'" in pos_mod_sign, auto)
  apply (metis Pair_eq xzgcda.simps order_refl)
  done

lemma xzgcd_correct:
    "0 < n ==> (zgcd m n = k) = (\<exists>s t. xzgcd m n = (k, s, t))"
  apply (unfold xzgcd_def)
  apply (rule iffI)
   apply (rule_tac [2] xzgcd_correct_aux2 [THEN mp, THEN mp])
    apply (rule xzgcd_correct_aux1 [THEN mp, THEN mp], auto)
  done

text {* \medskip @{term xzgcd} linear *}

lemma xzgcda_linear_aux1:
  "(a - r * b) * m + (c - r * d) * (n::int) =
   (a * m + c * n) - r * (b * m + d * n)"
  by (simp add: left_diff_distrib distrib_left mult.assoc)

lemma xzgcda_linear_aux2:
  "r' = s' * m + t' * n ==> r = s * m + t * n
    ==> (r' mod r) = (s' - (r' div r) * s) * m + (t' - (r' div r) * t) * (n::int)"
  apply (rule trans)
   apply (rule_tac [2] xzgcda_linear_aux1 [symmetric])
  apply (simp add: eq_diff_eq mult.commute)
  done

lemma order_le_neq_implies_less: "(x::'a::order) \<le> y ==> x \<noteq> y ==> x < y"
  by (rule iffD2 [OF order_less_le conjI])

lemma xzgcda_linear [rule_format]:
  "0 < r --> xzgcda m n r' r s' s t' t = (rn, sn, tn) -->
    r' = s' * m + t' * n -->  r = s * m + t * n --> rn = sn * m + tn * n"
  apply (induct m n r' r s' s t' t rule: xzgcda.induct)
  apply (subst xzgcda.simps)
  apply (simp (no_asm))
  apply (rule impI)+
  apply (case_tac "r' mod r = 0")
   apply (simp add: xzgcda.simps, clarify)
  apply (subgoal_tac "0 < r' mod r")
   apply (rule_tac [2] order_le_neq_implies_less)
   apply (rule_tac [2] pos_mod_sign)
    apply (cut_tac m = m and n = n and r' = r' and r = r and s' = s' and
      s = s and t' = t' and t = t in xzgcda_linear_aux2, auto)
  done

lemma xzgcd_linear:
    "0 < n ==> xzgcd m n = (r, s, t) ==> r = s * m + t * n"
  apply (unfold xzgcd_def)
  apply (erule xzgcda_linear, assumption, auto)
  done

lemma zgcd_ex_linear:
    "0 < n ==> zgcd m n = k ==> (\<exists>s t. k = s * m + t * n)"
  apply (simp add: xzgcd_correct, safe)
  apply (rule exI)+
  apply (erule xzgcd_linear, auto)
  done

lemma zcong_lineq_ex:
    "0 < n ==> zgcd a n = 1 ==> \<exists>x. [a * x = 1] (mod n)"
  apply (cut_tac m = a and n = n and k = 1 in zgcd_ex_linear, safe)
  apply (rule_tac x = s in exI)
  apply (rule_tac b = "s * a + t * n" in zcong_trans)
   prefer 2
   apply simp
  apply (unfold zcong_def)
  apply (simp (no_asm) add: mult.commute)
  done

lemma zcong_lineq_unique:
  "0 < n ==>
    zgcd a n = 1 ==> \<exists>!x. 0 \<le> x \<and> x < n \<and> [a * x = b] (mod n)"
  apply auto
   apply (rule_tac [2] zcong_zless_imp_eq)
       apply (tactic {* stac (@{thm zcong_cancel2} RS sym) 6 *})
         apply (rule_tac [8] zcong_trans)
          apply (simp_all (no_asm_simp))
   prefer 2
   apply (simp add: zcong_sym)
  apply (cut_tac a = a and n = n in zcong_lineq_ex, auto)
  apply (rule_tac x = "x * b mod n" in exI, safe)
    apply (simp_all (no_asm_simp))
  apply (metis zcong_scalar zcong_zmod mod_mult_right_eq mult_1 mult.assoc)
  done

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_MSortBU2Sorts
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun risers :: "int list => (int list) list" where
  "risers (nil2) = nil2"
| "risers (cons2 y (nil2)) = cons2 (cons2 y (nil2)) (nil2)"
| "risers (cons2 y (cons2 y2 xs)) =
     (if y <= y2 then
        (case risers (cons2 y2 xs) of
           nil2 => nil2
           | cons2 ys yss => cons2 (cons2 y ys) yss)
        else
        cons2 (cons2 y (nil2)) (risers (cons2 y2 xs)))"

fun ordered :: "int list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((y <= y2) & (ordered (cons2 y2 xs)))"

fun lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(int list) list => (int list) list" where
  "pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu2 :: "(int list) list => int list" where
  "mergingbu2 (nil2) = nil2"
| "mergingbu2 (cons2 xs (nil2)) = xs"
| "mergingbu2 (cons2 xs (cons2 z x2)) =
     mergingbu2 (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun msortbu2 :: "int list => int list" where
  "msortbu2 x = mergingbu2 (risers x)"

theorem property0 :
  "ordered (msortbu2 xs)"
  oops

end


(* Author: Tobias Nipkow *)

section \<open>Multiset of Elements of Binary Tree\<close>

theory Tree_Multiset
imports Multiset Tree
begin

text\<open>Kept separate from theory @{theory Tree} to avoid importing all of
theory @{theory Multiset} into @{theory Tree}. Should be merged if
@{theory Multiset} ever becomes part of @{theory Main}.\<close>

fun mset_tree :: "'a tree \<Rightarrow> 'a multiset" where
"mset_tree Leaf = {#}" |
"mset_tree (Node l a r) = {#a#} + mset_tree l + mset_tree r"

fun subtrees_mset :: "'a tree \<Rightarrow> 'a tree multiset" where
"subtrees_mset Leaf = {#Leaf#}" |
"subtrees_mset (Node l x r) = add_mset (Node l x r) (subtrees_mset l + subtrees_mset r)"

lemma set_mset_tree[simp]: "set_mset (mset_tree t) = set_tree t"
by(induction t) auto

lemma size_mset_tree[simp]: "size(mset_tree t) = size t"
by(induction t) auto

lemma mset_map_tree: "mset_tree (map_tree f t) = image_mset f (mset_tree t)"
by (induction t) auto

lemma mset_iff_set_tree: "x \<in># mset_tree t \<longleftrightarrow> x \<in> set_tree t"
by(induction t arbitrary: x) auto

lemma mset_preorder[simp]: "mset (preorder t) = mset_tree t"
by (induction t) (auto simp: ac_simps)

lemma mset_inorder[simp]: "mset (inorder t) = mset_tree t"
by (induction t) (auto simp: ac_simps)

lemma map_mirror: "mset_tree (mirror t) = mset_tree t"
by (induction t) (simp_all add: ac_simps)

lemma in_subtrees_mset_iff[simp]: "s \<in># subtrees_mset t \<longleftrightarrow> s \<in> subtrees t"
by(induction t) auto

end


(*  Title:      HOL/Isar_Examples/Knaster_Tarski.thy
    Author:     Markus Wenzel, TU Muenchen

Typical textbook proof example.
*)

section \<open>Textbook-style reasoning: the Knaster-Tarski Theorem\<close>

theory Knaster_Tarski
imports Main "~~/src/HOL/Library/Lattice_Syntax"
begin

subsection \<open>Prose version\<close>

text \<open>According to the textbook @{cite \<open>pages 93--94\<close> "davey-priestley"},
  the Knaster-Tarski fixpoint theorem is as
  follows.\footnote{We have dualized the argument, and tuned the
  notation a little bit.}

  \textbf{The Knaster-Tarski Fixpoint Theorem.}  Let @{text L} be a
  complete lattice and @{text "f: L \<rightarrow> L"} an order-preserving map.
  Then @{text "\<Sqinter>{x \<in> L | f(x) \<le> x}"} is a fixpoint of @{text f}.

  \textbf{Proof.} Let @{text "H = {x \<in> L | f(x) \<le> x}"} and @{text "a =
  \<Sqinter>H"}.  For all @{text "x \<in> H"} we have @{text "a \<le> x"}, so @{text
  "f(a) \<le> f(x) \<le> x"}.  Thus @{text "f(a)"} is a lower bound of @{text
  H}, whence @{text "f(a) \<le> a"}.  We now use this inequality to prove
  the reverse one (!) and thereby complete the proof that @{text a} is
  a fixpoint.  Since @{text f} is order-preserving, @{text "f(f(a)) \<le>
  f(a)"}.  This says @{text "f(a) \<in> H"}, so @{text "a \<le> f(a)"}.\<close>

subsection \<open>Formal versions\<close>

text \<open>The Isar proof below closely follows the original
  presentation.  Virtually all of the prose narration has been
  rephrased in terms of formal Isar language elements.  Just as many
  textbook-style proofs, there is a strong bias towards forward proof,
  and several bends in the course of reasoning.\<close>

theorem Knaster_Tarski:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f"
  shows "\<exists>a. f a = a"
proof
  let ?H = "{u. f u \<le> u}"
  let ?a = "\<Sqinter>?H"
  show "f ?a = ?a"
  proof -
    {
      fix x
      assume "x \<in> ?H"
      then have "?a \<le> x" by (rule Inf_lower)
      with \<open>mono f\<close> have "f ?a \<le> f x" ..
      also from \<open>x \<in> ?H\<close> have "\<dots> \<le> x" ..
      finally have "f ?a \<le> x" .
    }
    then have "f ?a \<le> ?a" by (rule Inf_greatest)
    {
      also presume "\<dots> \<le> f ?a"
      finally (order_antisym) show ?thesis .
    }
    from \<open>mono f\<close> and \<open>f ?a \<le> ?a\<close> have "f (f ?a) \<le> f ?a" ..
    then have "f ?a \<in> ?H" ..
    then show "?a \<le> f ?a" by (rule Inf_lower)
  qed
qed

text \<open>Above we have used several advanced Isar language elements,
  such as explicit block structure and weak assumptions.  Thus we have
  mimicked the particular way of reasoning of the original text.

  In the subsequent version the order of reasoning is changed to
  achieve structured top-down decomposition of the problem at the
  outer level, while only the inner steps of reasoning are done in a
  forward manner.  We are certainly more at ease here, requiring only
  the most basic features of the Isar language.\<close>

theorem Knaster_Tarski':
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f"
  shows "\<exists>a. f a = a"
proof
  let ?H = "{u. f u \<le> u}"
  let ?a = "\<Sqinter>?H"
  show "f ?a = ?a"
  proof (rule order_antisym)
    show "f ?a \<le> ?a"
    proof (rule Inf_greatest)
      fix x
      assume "x \<in> ?H"
      then have "?a \<le> x" by (rule Inf_lower)
      with \<open>mono f\<close> have "f ?a \<le> f x" ..
      also from \<open>x \<in> ?H\<close> have "\<dots> \<le> x" ..
      finally show "f ?a \<le> x" .
    qed
    show "?a \<le> f ?a"
    proof (rule Inf_lower)
      from \<open>mono f\<close> and \<open>f ?a \<le> ?a\<close> have "f (f ?a) \<le> f ?a" ..
      then show "f ?a \<in> ?H" ..
    qed
  qed
qed

end


(******************************************************************************)
(* Submission: "The Interchange Law: A Principle of Concurrent Programming"   *)
(* Authors: Tony Hoare, Bernard Möller, Georg Struth, and Frank Zeyda         *)
(* File: ICL_Examples.thy                                                     *)
(******************************************************************************)
(* LAST REVIEWED: TODO *)

section {* Example Applications *}

theory ICL_Examples
imports ICL Strict_Operators Computer_Arith Partiality
begin

hide_const Partiality.Value

text \<open>We are going to use the `\<open>|\<close>' symbol for parallel composition.\<close>

no_notation (ASCII)
  disj  (infixr "|" 30)

text \<open>Example applications of the interchange law from the article.\<close>

subsection \<open>Arithmetic: addition (\<open>+\<close>) and subtraction (\<open>-\<close>) of numbers.\<close>

text \<open>
  We prove the interchange laws for the HOL types @{type int}, @{type rat} and
  @{type real}, as well as the corresponding @{type option} types of those. We
  note that the law does not hold for type @{type nat}, although a weaker
  version using \<open>\<le>\<close> instead of equality is provable because Isabelle/HOL
  interprets the minus operators as monus on natural numbers.
\<close>

interpretation icl_plus_minus_nat:
  iclaw "TYPE(nat)" "op =" "op -" "op +"
apply (unfold_locales)
apply (linarith?)
oops

interpretation icl_plus_minus_nat:
  iclaw "TYPE(nat)" "op \<le>" "op -" "op +"
apply (unfold_locales)
apply (linarith)
oops

interpretation icl_plus_minus_nat_option:
  iclaw "TYPE(nat option)" "op \<le>\<^sub>?" "op -\<^sub>?" "op +\<^sub>?"
apply (unfold_locales)
apply (option_tac)
done

interpretation icl_plus_minus_int:
  iclaw "TYPE(int)" "op =" "op -" "op +"
apply (unfold_locales)
apply (linarith)
done

interpretation icl_plus_minus_rat:
  iclaw "TYPE(rat)" "op =" "op -" "op +"
apply (unfold_locales)
apply (linarith)
done

interpretation icl_plus_minus_real:
  iclaw "TYPE(real)" "op =" "op -" "op +"
apply (unfold_locales)
apply (linarith)
done

text \<open>Corresponding proofs for option types and strict operators.\<close>

interpretation icl_plus_minus_int_option:
  iclaw "TYPE(int option)" "op =\<^sub>?" "op -\<^sub>?" "op +\<^sub>?"
apply (unfold_locales)
apply (option_tac)
done

interpretation icl_plus_minus_rat_option:
  iclaw "TYPE(rat option)" "op =\<^sub>?" "op -\<^sub>?" "op +\<^sub>?"
apply (unfold_locales)
apply (option_tac)
done

interpretation icl_plus_minus_real_option:
  iclaw "TYPE(real option)" "op =\<^sub>?" "op -\<^sub>?" "op +\<^sub>?"
apply (unfold_locales)
apply (option_tac)
done

subsection \<open>Positive arithmetic: with multiplication (\<open>\<times>\<close>).\<close>

interpretation icl_plus_times_nat:
  iclaw "TYPE(nat)" "op \<le>" "op +" "op *"
apply (unfold_locales)
apply (simp add: distrib_left distrib_right)
done

interpretation icl_plus_times_nat_option:
  iclaw "TYPE(nat option)" "op \<le>\<^sub>?" "op +\<^sub>?" "op *\<^sub>?"
apply (unfold_locales)
apply (option_tac)
apply (simp add: distrib_left distrib_right)
done

interpretation icl_plus_times_nat_option:
  iclaw "TYPE(int)" "op \<le>" "op +" "op *"
apply (unfold_locales)
apply (subgoal_tac "p \<ge> 0 \<and> r \<ge> 0 \<and> q \<ge> 0 \<and> s \<ge> 0")
-- {* Subgoal 1 *}
apply (clarify)
apply (unfold ring_distribs)
apply (unfold sym [OF add.assoc])
apply (simp)
oops

text \<open>
  We note that the law can be proved more generally to hold in any (ordered)
  @{class semiring} in which @{term 0} is the least element. To mechanically
  verify this result, it is useful to introduce a type class that guarantees
  that all elements of a type are positive.
\<close>

class positive = zero + ord +
  assumes zero_least: "0 \<le> x"

interpretation icl_positive_semiring:
  iclaw "TYPE('a::{positive,ordered_semiring})" "op \<le>" "op +" "op *"
apply (unfold_locales)
apply (simp add: distrib_left distrib_right)
apply (metis add.right_neutral add_increasing add_mono order_refl zero_least)
done

text \<open>Clearly, all elements of the type @{type nat} are positive.\<close>

instance nat :: positive
apply (intro_classes)
apply (simp)
done

text \<open>
  For other number types, such as @{type int}eger, @{type rat}ional and
  @{type real} numbers, we introduce a subtype \<open>'a pos\<close> that includes only the
  positive individuals of some type @{typ "'a"}. In order to establish the
  non-emptiness caveat of the type definition, we require that the ordering be
  a @{class preorder}.
\<close>

typedef (overloaded) 'a::"{zero, preorder}" pos = "{x::'a. 0 \<le> x}"
apply (clarsimp)
apply (rule_tac x = "0" in exI)
apply (rule order_refl)
done

setup_lifting type_definition_pos

text \<open>We next lift `\<open>\<le>\<close>', `\<open>0\<close>', `\<open>+\<close>' and `\<open>*\<close>' into the new type @{type pos}.\<close>

instantiation pos :: ("{zero,preorder}") preorder
begin
lift_definition less_eq_pos :: "'a pos \<Rightarrow> 'a pos \<Rightarrow> bool"
is "op \<le>" .
lift_definition less_pos :: "'a pos \<Rightarrow> 'a pos \<Rightarrow> bool"
is "op <" .
instance
apply (intro_classes; transfer)
using less_le_not_le apply (blast)
using order_refl apply (blast)
using order_trans apply (blast)
done
end

instantiation pos :: ("{zero,preorder}") zero
begin
lift_definition zero_pos :: "'a pos"
is "0" by (rule order_refl)
instance ..
end

text \<open>
  We note that for the lifting of `\<open>+\<close>' and `\<open>*\<close>', we require closure of those
  operators under positive numbers. Such is, however, provable within ordered
  semi-rings, as we establish later on.
\<close>

class plus_pos_cl = zero + ord + plus +
  assumes plus_pos_closure: "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> 0 \<le> x + y"

class times_pos_cl = zero + ord + times +
  assumes times_pos_closure: "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> 0 \<le> x * y"

instantiation pos :: ("{zero,preorder,plus_pos_cl}") plus
begin
lift_definition plus_pos :: "'a pos \<Rightarrow> 'a pos \<Rightarrow> 'a pos"
is "op +" by (rule plus_pos_closure)
instance ..
end

instantiation pos :: ("{zero,preorder,times_pos_cl}") times
begin
lift_definition times_pos :: "'a pos \<Rightarrow> 'a pos \<Rightarrow> 'a pos"
is "op *" by (rule times_pos_closure)
instance ..
end

text \<open>
  We prove that the above closure property of `\<open>+\<close>' and `\<open>*\<close>' wrt the positive
  individuals holds within any (ordered) semi-ring.
\<close>

subclass (in ordered_semiring) plus_pos_cl
apply (unfold class.plus_pos_cl_def)
using local.add_nonneg_nonneg by (blast)

subclass (in ordered_semiring_0) times_pos_cl
apply (unfold class.times_pos_cl_def)
using local.mult_nonneg_nonneg by (blast)

text \<open>
  Lastly, we prove that subtype @{typ "'a pos"} over some (ordered) semi-ring
  is itself and ordered semi-ring, albeit comprising positive elements only.
  With the earlier interpretation proof, namely for \<open>icl_positive_semiring\<close>,
  this implies that the interchange law holds for positive arithmetic with
  multiplication within any (ordered) semi-ring, including positive rational
  and real numbers.
\<close>

instance pos :: ("{zero, preorder}") positive
apply (intro_classes)
apply (transfer)
apply (assumption)
done

instance pos :: (ordered_semiring_0) ordered_semiring
apply (intro_classes; transfer'; simp?)
apply (simp add: add.assoc)
apply (simp add: add.commute)
apply (simp add: add_left_mono)
apply (simp add: mult.assoc)
apply (simp add: distrib_right)
apply (simp add: distrib_left)
apply (simp add: mult_left_mono)
apply (simp add: mult_right_mono)
done

interpretation icl_plus_times_pos:
  iclaw "TYPE('a::ordered_semiring_0 pos)" "op \<le>" "op +" "op *"
apply (unfold_locales)
done

interpretation icl_plus_times_pos_option:
  iclaw "TYPE('a::ordered_semiring_0 pos option)" "op \<le>\<^sub>?" "op +\<^sub>?" "op *\<^sub>?"
apply (unfold_locales)
apply (option_tac)
apply (rule icl_positive_semiring.interchange_law)
done

interpretation icl_plus_times_pos_int:
  iclaw "TYPE(int pos)" "op \<le>" "op +" "op *"
apply (unfold_locales)
done

interpretation icl_plus_times_pos_rat:
  iclaw "TYPE(rat pos)" "op \<le>" "op +" "op *"
apply (unfold_locales)
done

interpretation icl_plus_times_pos_real:
  iclaw "TYPE(real pos)" "op \<le>" "op +" "op *"
apply (unfold_locales)
done

interpretation icl_plus_times_pos_int_option:
  iclaw "TYPE(int pos option)" "op \<le>\<^sub>?" "op +\<^sub>?" "op *\<^sub>?"
apply (unfold_locales)
done

interpretation icl_plus_times_pos_rat_option:
  iclaw "TYPE(rat pos option)" "op \<le>\<^sub>?" "op +\<^sub>?" "op *\<^sub>?"
apply (unfold_locales)
done

interpretation icl_plus_times_pos_real_option:
  iclaw "TYPE(real pos option)" "op \<le>\<^sub>?" "op +\<^sub>?" "op *\<^sub>?"
apply (unfold_locales)
done

subsection \<open>Arithmetic: multiplication (\<open>\<times>\<close>) and division (\<open>/\<close>) of numbers.\<close>

text \<open>This is proved for @{type rat}, @{type real}, and option types thereof.\<close>

interpretation icl_mult_div_rat:
  iclaw "TYPE(rat)" "op =" "op *" "op /"
apply (unfold_locales)
apply (simp)
done

interpretation icl_mult_div_real:
  iclaw "TYPE(real)" "op =" "op *" "op /"
apply (unfold_locales)
apply (simp)
done

interpretation icl_mult_div_field:
  iclaw "TYPE('a::field)" "op =" "op *" "op /"
apply (unfold_locales)
apply (simp)
done

interpretation icl_mult_div_rat_option:
  iclaw "TYPE(rat option)" "op =\<^sub>?" "op *\<^sub>?" "op /\<^sub>?"
apply (unfold_locales)
apply (option_tac)
done

interpretation icl_mult_div_real_option:
  iclaw "TYPE(real option)" "op =\<^sub>?" "op *\<^sub>?" "op /\<^sub>?"
apply (unfold_locales)
apply (option_tac)
done

text \<open>
  Theorem 1 likewise holds for @{type rat}ional and @{type real} numbers and
  option types thereof.
\<close>

lemma Theorem1_rat:
fixes p :: "rat"
fixes q :: "rat"
shows "(p / q) * q = (p * q) / q"
apply (insert icl_mult_div_rat.interchange_law [of p q q 1])
apply (unfold div_by_1 mult_1_right)
apply (assumption)
done

lemma Theorem1_real:
fixes p :: "real"
fixes q :: "real"
shows "(p / q) * q = (p * q) / q"
apply (insert icl_mult_div_real.interchange_law [of p q q 1])
apply (unfold div_by_1 mult_1_right)
apply (assumption)
done

lemma Theorem1_rat_option:
fixes p :: "rat option"
fixes q :: "rat option"
shows "(p /\<^sub>? q) *\<^sub>? q = (p *\<^sub>? q) /\<^sub>? q"
apply (insert icl_mult_div_rat_option.interchange_law [of p q q 1])
apply (unfold div_by_1_option mult_1_right_option)
apply (case_tac p; case_tac q; option_tac)
done

lemma Theorem1_real_option:
fixes p :: "real option"
fixes q :: "real option"
shows "(p /\<^sub>? q) *\<^sub>? q = (p *\<^sub>? q) /\<^sub>? q"
apply (insert icl_mult_div_real_option.interchange_law [of p q q 1])
apply (unfold div_by_1_option mult_1_right_option)
apply (case_tac p; case_tac q; option_tac)
done

text \<open>It also holds, more generally, in any division ring.\<close>

context division_ring
begin
lemma div_mult_exchange:
fixes p :: "'a"
fixes q :: "'a"
shows "(p / q) * q = (p * q) / q"
apply (metis eq_divide_eq mult_eq_0_iff)
done
end

subsection \<open>Positive integers: with truncated division (\<open>\<div>\<close>).\<close>

text \<open>
  By default, @{term "x div y"} is also used for truncated (integer) division
  in Isabelle/HOL. Hence, we first introduce a neat syntax \<open>x \<div> y\<close> consistent
  with our notation in the paper. This is done via @{command abbreviation}.
\<close>

abbreviation trunc_div :: "nat binop" (infixl "\<div>" 70) where
"x \<div> y \<equiv> x div y"

abbreviation trunc_div_option :: "nat option binop" (infixl "\<div>\<^sub>?" 70) where
"x \<div>\<^sub>? y \<equiv> x /\<^sub>? y"

text \<open>
  Since Isabelle/HOL defines \<open>x div 0 = 0\<close>, we can prove the interchange law
  even in HOL's weak treatment of undefinedness, as well as in the strong one.
\<close>

interpretation icl_mult_trunc_div_nat:
  iclaw "TYPE(nat)" "op \<le>" "op *" "op \<div>"
apply (unfold_locales)
apply (case_tac "r = 0"; simp_all)
apply (case_tac "s = 0"; simp_all)
apply (subgoal_tac "(p div r) * (q div s) * (r * s) \<le> p * q")
apply (metis div_le_mono div_mult_self_is_m nat_0_less_mult_iff)
apply (unfold semiring_normalization_rules(13))
apply (metis mult.commute mult_le_mono split_div_lemma)
done

interpretation icl_mult_trunc_div_nat_option:
  iclaw "TYPE(nat option)" "op \<le>\<^sub>?" "op *\<^sub>?" "op \<div>\<^sub>?"
apply (unfold_locales)
apply (option_tac)
apply (rule icl_mult_trunc_div_nat.interchange_law)
done

text \<open>
  With the above, we prove Theorem 2 in the paper, both for natural numbers
  and the option type over naturals.
\<close>

lemma Theorem2:
fixes p :: "nat"
fixes q :: "nat"
shows "(p \<div> q) * q \<le> (p * q) \<div> q"
apply (insert icl_mult_trunc_div_nat.interchange_law [of p q q 1])
apply (unfold div_by_1 mult_1_right)
apply (assumption)
done

lemma Theorem2_option:
fixes p :: "nat option"
fixes q :: "nat option"
shows "(p \<div>\<^sub>? q) *\<^sub>? q \<le> (p *\<^sub>? q) \<div>\<^sub>? q"
apply (insert icl_mult_trunc_div_nat_option.interchange_law [of p q q 1])
apply (unfold div_by_1_option mult_1_right_option)
apply (case_tac p; case_tac q; option_tac)
done

subsection \<open>Propositional calculus: conjunction (\<open>\<and>\<close>) and implication (\<open>\<Rightarrow>\<close>).\<close>

text \<open>RE: Implication \<open>p \<Rightarrow> q\<close> is defined in the usual way as \<open>\<not>p \<or> q\<close>.\<close>

text \<open>We can easily verify the above equivalence in HOL.\<close>

lemma "(p \<longrightarrow> q) \<equiv> (\<not> p \<or> q)"
apply (auto)
done

text \<open>
  This instance of the interchange law cannot be proved by way of interpreting
  the @{locale iclaw} locale because rule implication is not an object-logic
  operator. Nonetheless, we can prove the interchange law as an Isabelle/HOL
  proof rule. We note that Isabelle uses \<open>\<longrightarrow>\<close> for implication and \<open>\<Longrightarrow>\<close> for
  meta-level (rule) implication. To make the theorem look as in the paper, we
  temporarily change the syntax of those operators.
\<close>

notation HOL.implies (infixr "\<Rightarrow>" 25)
notation Pure.imp    (infixr "\<turnstile>" 1)

lemma icl_conj_imp_prop:
"(p \<Rightarrow> q) \<and> (r \<Rightarrow> s) \<turnstile> (p \<and> r) \<Rightarrow> (q \<and> s)"
apply (auto)
done

subsection \<open>Boolean Algebra: conjunction (\<open>\<and>\<close>) and disjunction (\<open>\<or>\<close>).\<close>

text \<open>Numerical value of a @{type bool}ean.\<close>

definition valOfBool :: "bool \<Rightarrow> nat" where
"valOfBool p = (if p then 1 else 0)"

text \<open>Order on boolean values induced by @{const valOfBool}.\<close>

definition numOrdBool :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
"numOrdBool p q \<longleftrightarrow> (valOfBool p) \<le> (valOfBool q)"

text \<open>We show that the numerical order above is just implication.\<close>

lemma numOrdBool_is_imp [simp]:
"(numOrdBool p q) = (p \<longrightarrow> q)"
apply (unfold numOrdBool_def valOfBool_def)
apply (induct_tac p; induct_tac q)
apply (simp_all)
done

interpretation preorder_numOrdBool:
  preorder "TYPE(bool)" "numOrdBool"
apply (unfold_locales)
apply (unfold numOrdBool_is_imp)
apply (auto)
done

text \<open>Note that \<open>;\<close> is \<open>\<or>\<close> and \<open>|\<close> is \<open>\<and>\<close>.\<close>

interpretation icl_boolean_algebra:
  iclaw "TYPE(bool)" "numOrdBool" "op \<or>" "op \<and>"
apply (unfold_locales)
apply (unfold numOrdBool_is_imp)
apply (auto)
done

text \<open>Theorem 3 once again needs to be formulated as an Isabelle proof rule.\<close>

lemma Theorem3:
"q \<and> s \<turnstile> q \<or> s"
apply (auto)
done

no_notation HOL.implies (infixr "\<Rightarrow>" 25)
no_notation Pure.imp    (infixr "\<turnstile>" 1)

subsection \<open>Self-interchanging operators: \<open>+\<close>, \<open>\<times>\<close>, \<open>\<or>\<close>, \<open>\<and>\<close>.\<close>

text \<open>For convenience, we define a locale for self-interchanging operators.\<close>

locale self_iclaw =
  iclaw "type" "op =" "self_op" "self_op"
  for type :: "'a itself" and self_op :: "'a binop"

text \<open>
  We next introduce separate locales to capture associativity, commutativity
  and existence of units for some binary operator. We use a bold circle (\<open>\<^bold>\<circ>\<close>)
  to avoid clashes with Isabelle/HOL's symbol (\<open>\<circ>\<close>) for functional composition.
\<close>

locale associative =
  fixes operator :: "'a binop" (infix "\<^bold>\<circ>" 100)
  assumes assoc: "x \<^bold>\<circ> (y \<^bold>\<circ> z) = (x \<^bold>\<circ> y) \<^bold>\<circ> z"

locale commutative =
  fixes operator :: "'a binop" (infix "\<^bold>\<circ>" 100)
  assumes comm: "x \<^bold>\<circ> y = y \<^bold>\<circ> x"

locale has_unit =
  fixes operator :: "'a binop" (infix "\<^bold>\<circ>" 100)
  fixes unit :: "'a" ("\<^bold>1")
  assumes left_unit [simp]: "\<^bold>1 \<^bold>\<circ> x = x"
  assumes right_unit [simp]: "x \<^bold>\<circ> \<^bold>1 = x"

text \<open>
  We first show that any associative and commuting operator self-interchanges.
\<close>

lemma assoc_comm_self_iclaw:
"(associative bop) \<and> (commutative bop) \<Longrightarrow> (self_iclaw bop)"
apply (unfold_locales)
apply (unfold associative_def commutative_def)
apply (clarify)
apply (auto)
done

text \<open>
  We next show that self-interchanging operators with a unit are associative
  and commute (Theorem 4).
\<close>

lemma Theorem4_assoc:
"(self_iclaw bop) \<and> (has_unit bop one) \<Longrightarrow> associative bop"
apply (unfold_locales)
apply (unfold self_iclaw_def iclaw_def iclaw_axioms_def)
apply (clarsimp)
apply (drule_tac x = "x" in spec)
apply (drule_tac x = "one" in spec)
apply (drule_tac x = "y" in spec)
apply (drule_tac x = "z" in spec)
apply (simp add: has_unit_def)
done

lemma Theorem4_commute:
"(self_iclaw bop) \<and> (has_unit bop one) \<Longrightarrow> commutative bop"
apply (unfold_locales)
apply (unfold self_iclaw_def iclaw_def iclaw_axioms_def)
apply (clarsimp)
apply (drule_tac x = "one" in spec)
apply (drule_tac x = "x" in spec)
apply (drule_tac x = "y" in spec)
apply (drule_tac x = "one" in spec)
apply (simp add: has_unit_def)
done

text \<open>Lastly, we prove the self-interchange law for \<open>+\<close>, \<open>*\<close>, \<open>\<or>\<close> and \<open>\<and>\<close>.\<close>

interpretation self_icl_plus:
  self_iclaw "TYPE('a::comm_monoid_add)" "op +"
apply (rule assoc_comm_self_iclaw)
apply (rule conjI)
-- {* Subgoal 1 *}
apply (unfold associative_def)
apply (simp add: add.assoc)
-- {* Subgoal 2 *}
apply (unfold commutative_def)
apply (simp add: add.commute)
done

interpretation self_icl_mult:
  self_iclaw "TYPE('a::comm_monoid_mult)" "op *"
apply (rule assoc_comm_self_iclaw)
apply (rule conjI)
-- {* Subgoal 1 *}
apply (unfold associative_def)
apply (simp add: mult.assoc)
-- {* Subgoal 2 *}
apply (unfold commutative_def)
apply (simp add: mult.commute)
done

interpretation self_icl_conj:
  self_iclaw "TYPE(bool)" "op \<and>"
apply (rule assoc_comm_self_iclaw)
apply (rule conjI)
-- {* Subgoal 1 *}
apply (standard) [1]
apply (blast)
-- {* Subgoal 2 *}
apply (standard) [1]
apply (blast)
done

interpretation self_icl_disj:
  self_iclaw "TYPE(bool)" "op \<or>"
apply (rule assoc_comm_self_iclaw)
apply (rule conjI)
-- {* Subgoal 1 *}
apply (standard) [1]
apply (blast)
-- {* Subgoal 2 *}
apply (standard) [1]
apply (blast)
done

text \<open>In addition, we can also show self-interchanging of \<open>+\<^sub>?\<close> and \<open>*\<^sub>?\<close>.\<close>

interpretation self_icl_plus_option:
  self_iclaw "TYPE('a::comm_monoid_add option)" "op +\<^sub>?"
apply (rule assoc_comm_self_iclaw)
apply (rule conjI)
-- {* Subgoal 1 *}
apply (unfold associative_def)
apply (option_tac)
apply (simp add: add.assoc)
-- {* Subgoal 2 *}
apply (option_tac)
apply (unfold commutative_def)
apply (option_tac)
apply (simp add: add.commute)
done

interpretation self_icl_mult_option:
  self_iclaw "TYPE('a::comm_monoid_mult option)" "op *\<^sub>?"
apply (rule assoc_comm_self_iclaw)
apply (rule conjI)
-- {* Subgoal 1 *}
apply (unfold associative_def)
apply (option_tac)
apply (simp add: mult.assoc)
-- {* Subgoal 2 *}
apply (unfold commutative_def)
apply (option_tac)
apply (simp add: mult.commute)
done

subsection \<open>Note: Partial operators.\<close>

text \<open>TO: This validates the cancellation law in the algebra of Section 4.\<close>

text \<open>
  Note that the below could even be proved if removing the assumption \<open>0 < q\<close>.
  The reason for this is that in Isabelle/HOL, division by zero is defined to
  be zero. Below we, however, conduct the prove not exploiting that fact.
\<close>

lemma trunc_div_mult_cancel:
fixes p :: "nat"
fixes q :: "nat"
assumes "0 < q"
shows "(p \<div> q) * q \<le> p"
apply (insert Theorem2 [of p q])
apply (erule order_trans)
apply (simp)
done

lemma trunc_div_mult_cancel_option:
fixes p :: "nat option"
fixes q :: "nat option"
shows "(p \<div>\<^sub>? q) *\<^sub>? q \<le> p"
apply (induction p; induction q; option_tac)
apply (rename_tac q p)
apply (erule trunc_div_mult_cancel)
done

subsection \<open>Computer arithmetic: Overflow (\<open>\<top>\<close>).\<close>

text \<open>
  We note that the various necessary types and operators to formalise machine
  calculations are developed in the theories:
  \begin{itemize}
    \item @{theory Strict_Operators};
    \item @{theory Machine_Number};
    \item @{theory Overflow_Monad}; and
    \item @{theory Computer_Arith}.
  \end{itemize}
\<close>

paragraph \<open>Cancellation Laws\<close>

lemma Section_8_cancel_law_1a:
fixes p :: "nat machine_number_ext"
fixes q :: "nat machine_number_ext"
shows "q \<noteq> 0 \<Longrightarrow> p \<le> (p *\<^sub>\<infinity> q) div\<^sub>\<infinity> q"
apply (transfer) -- \<open>Just to quantify free variables!\<close>
apply (overflow_tac)
done

lemma Section_8_cancel_law_1b:
fixes p :: "nat comparith"
fixes q :: "nat comparith"
shows "q \<noteq> 0 \<Longrightarrow> q \<noteq> \<bottom> \<Longrightarrow> p \<le> (p *\<^sub>c q) /\<^sub>c q"
apply (transfer) -- \<open>Just to quantify free variables!\<close>
apply (comparith_tac)
done

lemma Section_8_cancel_law_2a:
fixes p :: "nat option"
fixes q :: "nat option"
shows "(p /\<^sub>? q) *\<^sub>? q \<le> p"
apply (transfer) -- \<open>Just to quantify free variables!\<close>
apply (option_tac)
apply (metis mult.commute split_div_lemma)
done

lemma Section_8_cancel_law_2b:
fixes p :: "nat comparith"
fixes q :: "nat comparith"
shows "q \<noteq> \<top> \<Longrightarrow> (p /\<^sub>c q) *\<^sub>c q \<le> p"
apply (transfer) -- \<open>Just to quantify free variables!\<close>
apply (comparith_tac)
apply (transfer)
apply (clarsimp; safe)
-- {* Subgoal 1 *}
apply (metis mult.commute split_div_lemma)
-- {* Subgoal 2 *}
using div_le_dividend dual_order.trans apply (blast)
-- {* Subgoal 3 *}
apply (metis dual_order.trans mult.commute split_div_lemma)
done

paragraph \<open>Interchange Law\<close>

lemma overflow_times_neq_Value_MN_0:
fixes x :: "nat machine_number_ext"
fixes y :: "nat machine_number_ext"
shows
"x \<noteq> Value MN(0) \<Longrightarrow>
 y \<noteq> Value MN(0) \<Longrightarrow> x *\<^sub>\<infinity> y \<noteq> Value MN(0)"
apply (transfer) -- \<open>Just to quantify free variables!\<close>
apply (overflow_tac)
done

interpretation icl_mult_trunc_div_nat_overflow:
  iclaw "TYPE(nat comparith)" "op \<le>" "op *\<^sub>c" "op /\<^sub>c"
apply (unfold_locales)
apply (option_tac)
apply (simp add: overflow_times_neq_Value_MN_0)
apply (unfold times_overflow_def divide_overflow_def)
apply (thin_tac "r \<noteq> Value MN(0)")
apply (thin_tac "s \<noteq> Value MN(0)")
apply (overflow_tac)
apply (transfer)
apply (clarsimp)
apply (safe)
using icl_mult_trunc_div_nat.interchange_law apply (blast)
using div_le_dividend dual_order.trans apply (blast)
apply (meson dual_order.trans icl_mult_trunc_div_nat.interchange_law)
using div_le_dividend dual_order.trans apply (blast)
done

subsection \<open>Sets: union (\<open>\<union>\<close>) and disjoint union (\<open>+\<close>) of sets, ordered by inclusion \<open>\<subseteq>\<close>.\<close>

text \<open>Proof of the below relies on @{term "\<bottom> \<subseteq>\<^sub>? A"} for any \<open>A\<close>.\<close>

interpretation preorder_option_subset:
  iclaw "TYPE('a set option)" "(op \<subseteq>\<^sub>?)" "op \<oplus>\<^sub>?" "op \<union>\<^sub>?"
apply (unfold_locales)
apply (rename_tac p q r s)
apply (option_tac)
apply (auto)
oops

text \<open>RE: Disjoint union has a unit \<open>{}\<close>, and so it interchanges with itself.\<close>

interpretation disjoint_union_unit:
  has_unit "op \<oplus>\<^sub>?" "Some {}"
apply (unfold_locales)
apply (option_tac)
apply (option_tac)
done

interpretation self_icl_disjoint_union:
  self_iclaw "TYPE('a set option)" "op \<oplus>\<^sub>?"
apply (unfold_locales)
apply (option_tac)
apply (auto)
done

text \<open>
  RE: But it is clearly not idempotent: \<open>p \<oplus>\<^sub>? p = p\<close> only when \<open>p = {}\<close> or
  \<open>p = \<bottom>\<close> or \<open>p = \<top>\<close>
\<close>

text \<open>TODO: Use the type @{type partial} to prove this also for \<open>\<top>\<close>.\<close>

lemma [rule_format]:
"\<forall>p. p \<oplus>\<^sub>? p = p \<longleftrightarrow> (p = \<bottom> \<or> p = Some {})"
apply (option_tac)
done

subsection \<open>Note: Variance of operators, covariant (\<open>+\<close>,\<open>\<and>\<close>, \<open>\<or>\<close>) and contravariant (\<open>-\<close>, \<open>\<and>\<close>, \<open>\<Leftarrow>\<close>)\<close>

text \<open>
  We introduce the property of covariance and contravariance via locales.
  For covariance, we have a single locale; and for contravariance, three
  different locales to account for all possible combinations.
\<close>

locale covariant = preorder +
  fixes cov_op :: "'a binop" (infixr "cov" 100)
  assumes cov_rule: "x \<^bold>\<le> x' \<and> y \<^bold>\<le> y' \<Longrightarrow> (x cov y) \<^bold>\<le> (x' cov y')"

text \<open>We consider contravariance in the first, second or both operators.\<close>

locale contravariant = preorder +
  fixes cot_op :: "'a binop" (infixr "cot" 100)
  assumes cot_rule: "x' \<^bold>\<le> x \<and> y' \<^bold>\<le> y \<Longrightarrow> (x cot y) \<^bold>\<le> (x' cot y')"

locale contravariant1 = preorder +
  fixes cot_op :: "'a binop" (infixr "cot" 100)
  assumes cot_rule1: "x' \<^bold>\<le> x \<and> y \<^bold>\<le> y' \<Longrightarrow> (x cot y) \<^bold>\<le> (x' cot y')"

locale contravariant2 = preorder +
  fixes cot_op :: "'a binop" (infixr "cot" 100)
  assumes cot_rule2: "x \<^bold>\<le> x' \<and> y' \<^bold>\<le> y \<Longrightarrow> (x cot y) \<^bold>\<le> (x' cot y')"

text \<open>Note that if the ordering is equality, all operators are covariant.\<close>

interpretation covariant_equality:
  covariant "TYPE('a)" "op =" "f::'a binop"
apply (intro_locales)
apply (unfold covariant_axioms_def)
apply (clarsimp)
done

interpretation contravariant_equality:
  contravariant "TYPE('a)" "op =" "f::'a binop"
apply (intro_locales)
apply (unfold contravariant_axioms_def)
apply (clarsimp)
done

interpretation contravariant1_equality:
  contravariant1 "TYPE('a)" "op =" "f::'a binop"
apply (intro_locales)
apply (unfold contravariant1_axioms_def)
apply (clarsimp)
done

interpretation contravariant2_equality:
  contravariant2 "TYPE('a)" "op =" "f::'a binop"
apply (intro_locales)
apply (unfold contravariant2_axioms_def)
apply (clarsimp)
done

text \<open>
  Below, we prove covariance of \<open>+\<close> for @{type nat}ural, @{type int}eger,
  @{type rat}ional and @{type real} numbers, as well as extensions of those
  types with \<open>\<bottom>\<close>.
\<close>

interpretation covariant_plus_nat:
  covariant "TYPE(nat)" "op \<le>" "op +"
apply (unfold_locales)
apply (linarith)
done

interpretation covariant_plus_int:
  covariant "TYPE(int)" "op \<le>" "op +"
apply (unfold_locales)
apply (linarith)
done

interpretation covariant_plus_rat:
  covariant "TYPE(rat)" "op \<le>" "op +"
apply (unfold_locales)
apply (linarith)
done

interpretation covariant_plus_real:
  covariant "TYPE(real)" "op \<le>" "op +"
apply (unfold_locales)
apply (linarith)
done

interpretation covariant_plus_nat_option:
  covariant "TYPE(nat option)" "op \<le>\<^sub>?" "op +\<^sub>?"
apply (unfold_locales)
apply (option_tac)
done

interpretation covariant_plus_int_option:
  covariant "TYPE(int option)" "op \<le>\<^sub>?" "op +\<^sub>?"
apply (unfold_locales)
apply (option_tac)
done

interpretation covariant_plus_rat_option:
  covariant "TYPE(rat option)" "op \<le>\<^sub>?" "op +\<^sub>?"
apply (unfold_locales)
apply (option_tac)
done

interpretation covariant_plus_real_option:
  covariant "TYPE(real option)" "op \<le>\<^sub>?" "op +\<^sub>?"
apply (unfold_locales)
apply (option_tac)
done

text \<open>Covariance of conjunction and disjunction with respect to implication.\<close>

interpretation covariant_conj:
  covariant "TYPE(bool)" "op \<longrightarrow>" "op \<and>"
apply (unfold_locales)
apply (clarsimp)
done

interpretation covariant_disj:
  covariant "TYPE(bool)" "op \<longrightarrow>" "op \<or>"
apply (unfold_locales)
apply (clarsimp)
done

text \<open>
  We prove contravariance in the right operator of \<open>-\<close> for @{type nat}ural,
  @{type int}eger, @{type rat}ional and @{type real} numbers. We note that
  contravariance does not hold for their respective @{type option} types. A
  counter examples is where \<open>y' = \<bottom>\<close> in \<open>(x cov y) \<^bold>\<le> (x' cov y')\<close> with all
  other quantities defined.
\<close>

interpretation contravariant2_minus_nat:
  contravariant2 "TYPE(nat)" "op \<le>" "op -"
apply (unfold_locales)
apply (linarith)
done

interpretation contravariant2_minus_int:
  contravariant2 "TYPE(int)" "op \<le>" "op -"
apply (unfold_locales)
apply (linarith)
done

interpretation contravariant2_minus_rat:
  contravariant2 "TYPE(rat)" "op \<le>" "op -"
apply (unfold_locales)
apply (linarith)
done

interpretation contravariant2_minus_real:
  contravariant2 "TYPE(real)" "op \<le>" "op -"
apply (unfold_locales)
apply (linarith)
done

text \<open>
  Contravariance of division actually could not be proved. First of all it
  does not hold for plain number types @{type nat} since the additional caveat
  @{term "y' > 0"} is needed, see the proof below. For @{type int}, @{type rat}
  and @{type real} it is even worse, since we also need to show that \<open>y*y'\<close> is
  positive. Moving to @{type option} types does not help as we are facing the
  same issue as for \<open>-\<close> above. Various instances of the contravariance law for
  division may only be proved if we strengthen the assumptions on \<open>y\<close> and \<open>y'\<close>.
\<close>

interpretation contravariant2_nat:
  contravariant2 "TYPE(nat)" "op \<le>" "op div"
apply (unfold_locales)
apply (clarify)
apply (subgoal_tac "x div y \<le> x div y'")
apply (erule order_trans)
apply (erule div_le_mono)
apply (rule div_le_mono2)
apply (simp_all)
oops

interpretation contravariant2_rat:
  contravariant2 "TYPE(rat)" "op \<le>" "op /"
apply (unfold_locales)
apply (clarify)
apply (subgoal_tac "x / y \<le> x / y'")
apply (erule order_trans)
apply (erule divide_right_mono) defer
apply (erule divide_left_mono) defer
defer
oops

interpretation contravariant2_div_nat:
  contravariant2 "TYPE(nat option)" "op \<le>\<^sub>?" "op /\<^sub>?"
apply (unfold_locales)
apply (option_tac)
apply (safe; clarsimp?) defer
apply (subgoal_tac "x div y \<le> x div y'")
apply (erule order_trans)
apply (erule div_le_mono)
apply (erule div_le_mono2)
apply (assumption)
oops

text \<open>Contravariance in the second operators holds for reverse implication.\<close>

interpretation contravariant_ref_implies:
  contravariant2 "TYPE(bool)" "op \<longrightarrow>" "op \<longleftarrow>"
apply (unfold_locales)
apply (auto)
done

text \<open>
  Covariance and contravariance with respect to equality is trivial in HOL due
  to Leibniz's law following from the axioms of the HOL kernel.
\<close>

subsection {* Note: Modularity, compositionality, locality, etc. *}

text \<open>
  This proof could  be more involved in requiring inductive reasoning about
  arbitrary languages whose operators are covariant with respect to an order.
  In a deep embedding of a specific language, this would not be difficult to
  show. We will not dig deeper into mechanically proving this property in all
  its generality, as it requires deep embedding of HOL functions, and giving
  a semantics to this (in HOL) I stipulate is beyond expressivity of the type
  system of HOL. An inductive proof would have to proceed at the meta-level.
\<close>

subsection \<open>Strings of characters: catenation (\<open>;\<close>) interleaving (\<open>|\<close>) and empty string (\<open>\<epsilon>\<close>).\<close>

text \<open>We first define a datatype to formalise the syntax of our string algebra.\<close>

text \<open>Note that we added a constructor for a single character (\<open>atom\<close>).\<close>

datatype 'a str_calc =
  empty_str ("\<epsilon>") |
  atom "'a" |
  seq_str "'a str_calc" "'a str_calc" (infixr ";" 110) |
  par_str "'a str_calc" "'a str_calc" (infixr "|" 100)

text \<open>The following function facilitates construction from HOL strings.\<close>

primrec mk_str :: "string \<Rightarrow> char str_calc" (*("\<guillemotleft>_\<guillemotright>" )*) where
"mk_str [] = \<epsilon>" |
"mk_str (h # t) = seq_str (atom h) (mk_str t)"

syntax "_mk_str" :: "id \<Rightarrow> char str_calc" ("\<guillemotleft>_\<guillemotright>")

parse_translation \<open>
  let
    fun mk_str_tr [Free  (name, _)] = @{const mk_str} $ (HOLogic.mk_string name)
      | mk_str_tr [Const (name, _)] = @{const mk_str} $ (HOLogic.mk_string name)
      | mk_str_tr _ = raise Match;
  in
    [(@{syntax_const "_mk_str"}, K mk_str_tr)]
  end
\<close>

translations "_mk_str s" \<leftharpoondown> "(CONST mk_str) s"

text \<open>The function \<open>ch\<close> yields all characters in a @{type str_calc} term.\<close>

primrec ch :: "'a str_calc \<Rightarrow> 'a set" where
"ch \<epsilon> = {}" |
"ch (atom c) = {c}" |
"ch (p ; q) = (ch p) \<union> (ch q)" |
"ch (p | q) = (ch p) \<union> (ch q)"

text \<open>The function \<open>sd\<close> computes the sequential dependencies using \<open>ch\<close>.\<close>

primrec sd :: "'a str_calc \<Rightarrow> ('a \<times> 'a) set" where
"sd \<epsilon> = {}" |
"sd (atom c) = {}" |
"sd (p ; q) = {(c, d). c \<in> (ch p) \<and> d \<in> (ch q)} \<union> sd(p) \<union> sd(q)" |
"sd (p | q) = sd(p) \<union> sd(q)"

(*<*)
value "ch \<guillemotleft>frank\<guillemotright>"
value "sd \<guillemotleft>frank\<guillemotright>"
(*>*)
text \<open>We are now able to define our ordering of @{type str_calc} objects.\<close>

instantiation str_calc :: (type) ord
begin
definition less_eq_str_calc :: "'a str_calc \<Rightarrow> 'a str_calc \<Rightarrow> bool" where
"less_eq_str_calc p q \<longleftrightarrow> (*ch p = ch q \<and>*)sd(q) \<subseteq> sd(p)"
definition less_str_calc :: "'a str_calc \<Rightarrow> 'a str_calc \<Rightarrow> bool" where
"less_str_calc p q \<longleftrightarrow> (*ch p = ch q \<and>*)sd(q) \<subset> sd(p)"
instance ..
end

text \<open>Proof of the interchange law for the string calculus operators.\<close>

instance str_calc :: (type) preorder
apply (intro_classes)
apply (unfold less_eq_str_calc_def less_str_calc_def)
apply (auto)
done

interpretation preorder_str_calc:
  preorder "TYPE('a str_calc)" "op \<le>"
apply (rule ICL.preorder_leq.preorder_axioms)
done

interpretation iclaw_str_calc:
  iclaw "TYPE('a str_calc)" "op \<le>" "op ;" "op |"
apply (unfold_locales)
apply (unfold less_eq_str_calc_def less_str_calc_def)
apply (clarsimp)
apply (simp add: subset_iff)
(* apply (auto) *)
done

subsection \<open>Note: Small interchange laws.\<close>

lemma equiv_str_calc:
"s \<cong> t \<longleftrightarrow> (*ch s = ch t \<and>*) sd s = sd t"
apply (clarsimp)
apply (unfold less_eq_str_calc_def)
apply (auto)
done

lemma empty_str_seq_unit:
"\<epsilon> ; s \<cong> s"
"s ; \<epsilon> \<cong> s"
apply (unfold equiv_str_calc)
apply (auto)
done

lemma empty_str_par_unit:
"\<epsilon> | s \<cong> s"
"s | \<epsilon> \<cong> s"
apply (unfold equiv_str_calc)
apply (auto)
done

lemma small_interchange_laws:
"(p | q) ; s \<le> p | (q ; s)"
"p ; (r | s) \<le> (p ; r) | s"
"q ; (r | s) \<le> r | (q ; s)"
"(p | q) ; r \<le> (p ; r) | q"
"p ; s \<le> p | s"
"q ; s \<le> s | q"
apply (unfold less_eq_str_calc_def)
apply (auto)
done

subsection \<open>Note: an example derivation\<close>

text \<open>We first prove several key lemmas.\<close>

lemma seq_str_assoc:
"(s ; t) ; u \<ge> s ; t ; u"
apply (unfold less_eq_str_calc_def)
apply (auto)
done

lemma par_str_assoc:
"(s | t) | u \<ge> s | t | u"
apply (unfold less_eq_str_calc_def)
apply (auto)
done

text \<open>
  The following law does not hold but is needed to remove the \<open>ch\<close>-related
  provisos in the law \<open>seq_str_mono\<close>. Alternatively, we could strengthen the
  definition of the order by additionally requiring @{term "ch p = ch q"}.
\<close>

lemma sd_imp_ch_subset:
"sd s \<subseteq> sd t \<Longrightarrow> ch s \<subseteq> ch t"
apply (induction s; induction t)
apply (simp)
apply (simp)
apply (simp)
apply (simp)
defer
defer
apply (simp)
apply (simp)
apply (simp)
apply (simp)
apply (simp)
apply (simp)
apply (simp)
apply (simp)
apply (simp)
apply (simp)
oops

lemma seq_str_mono:
"ch s = ch s' \<Longrightarrow>
 ch t = ch t' \<Longrightarrow>
 s \<ge> s' \<Longrightarrow> t \<ge> t' \<Longrightarrow> (s ; t) \<ge> (s' ; t')"
apply (unfold less_eq_str_calc_def)
apply (auto)
done

lemma par_str_mono:
"s \<ge> s' \<Longrightarrow> t \<ge> t' \<Longrightarrow> (s | t) \<ge> (s' | t')"
apply (unfold less_eq_str_calc_def)
apply (auto)
done

lemma str_calc_step:
fixes LHS :: "'a::preorder"
fixes RHS :: "'a::preorder"
fixes MID :: "'a::preorder"
shows "LHS \<ge> MID \<Longrightarrow> MID \<ge> RHS \<Longrightarrow> LHS \<ge> RHS"
using order_trans by (blast)

lemma example_derivation:
assumes lhs: "LHS = \<guillemotleft>abcd\<guillemotright> | \<guillemotleft>xyzw\<guillemotright>"
assumes rhs: "RHS = \<guillemotleft>xaybzwcd\<guillemotright>"
shows "LHS \<ge> RHS"
apply (unfold lhs rhs)
-- \<open>Step 1\<close>
apply (rule_tac MID = "(\<guillemotleft>a\<guillemotright> ; \<guillemotleft>bcd\<guillemotright>) | (\<guillemotleft>xy\<guillemotright> ; \<guillemotleft>zw\<guillemotright>)" in str_calc_step)
apply (unfold less_eq_str_calc_def; auto) [1]
-- \<open>Step 2\<close>
apply (rule_tac MID = "(\<guillemotleft>a\<guillemotright> | \<guillemotleft>xy\<guillemotright>) ; (\<guillemotleft>bcd\<guillemotright> | \<guillemotleft>zw\<guillemotright>)" in str_calc_step)
apply (rule iclaw_str_calc.interchange_law)
-- \<open>Step 3\<close>
apply (rule_tac MID = "(\<guillemotleft>a\<guillemotright> | \<guillemotleft>x\<guillemotright> ; \<guillemotleft>y\<guillemotright>) ; (\<guillemotleft>b\<guillemotright> ; \<guillemotleft>cd\<guillemotright> | \<guillemotleft>zw\<guillemotright>)" in str_calc_step)
apply (unfold less_eq_str_calc_def; auto) [1]
-- \<open>Step 4\<close>
apply (rule_tac MID = "(\<guillemotleft>a\<guillemotright> | \<guillemotleft>x\<guillemotright>) ; \<guillemotleft>y\<guillemotright> ; (\<guillemotleft>b\<guillemotright> | \<guillemotleft>zw\<guillemotright>) ; \<guillemotleft>cd\<guillemotright>" in str_calc_step)
apply (unfold less_eq_str_calc_def; auto) [1]
(* using seq_str_assoc seq_str_mono
  small_interchange_laws(1)
  small_interchange_laws(4) str_calc_step
apply (blast) *)
-- \<open>Remainder of the proof...\<close>
apply (unfold less_eq_str_calc_def)
apply (auto)
done

lemma example_derivation_auto:
assumes lhs: "LHS = \<guillemotleft>abcd\<guillemotright> | \<guillemotleft>xyzw\<guillemotright>"
assumes rhs: "RHS = \<guillemotleft>xaybzwcd\<guillemotright>"
shows "LHS \<ge> RHS"
apply (unfold lhs rhs)
apply (unfold less_eq_str_calc_def)
apply (auto)
done
end