theory Directed_Tree
  imports "Graph_Theory.Graph_Theory" More_Graph_Theory
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 \<open>finite (verts T \<times> verts T)\<close> have "finite ?A"
    using [[simproc add: finite_Collect]] by (auto split: prod.splits)
  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
    with tree_T.root_in_T have "verts T = {root}"
      by (metis card_1_singletonE singletonD)
    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

end

end

end


(*  Author:     Tobias Nipkow, 2007  *)

theory FRE
imports LinArith
begin

subsection{* Ferrante-Rackoff \label{sec:FRE}*}

text{* This section formalizes a slight variant of Ferrante and
Rackoff's algorithm~\cite{FerranteR-SIAM75}. We consider equalities
separately, which improves performance. *}

fun between :: "real * real list \<Rightarrow> real * real list \<Rightarrow> real * real list"
where "between (r,cs) (s,ds) = ((r+s)/2, (1/2) *\<^sub>s (cs+ds))"

definition FR\<^sub>1 :: "atom fm \<Rightarrow> atom fm" where
"FR\<^sub>1 \<phi> =
(let as = R.atoms\<^sub>0 \<phi>; lbs = lbounds as; ubs = ubounds as; ebs = ebounds as;
     intrs = [subst \<phi> (between l u) . l \<leftarrow> lbs, u \<leftarrow> ubs]
 in list_disj (inf\<^sub>- \<phi> # inf\<^sub>+ \<phi> # intrs @ map (subst \<phi>) ebs))"

declare [[simp_depth_limit = 50]]

lemma dense:
  "\<lbrakk> nqfree f; \<forall>y\<in>{l<..<x}. y \<notin> LB f xs; \<forall>y\<in>{x<..<u}. y \<notin> UB f xs;
     l < x; x < u; x \<notin> EQ f xs;  R.I f (x#xs); l < y; y < u\<rbrakk>
   \<Longrightarrow> R.I f (y#xs)"
proof(induct f)
  case (Atom a)
  show ?case
  proof (cases a)
    case (Less r cs)
    show ?thesis
    proof (cases cs)
      case Nil thus ?thesis using Atom Less by (simp add:depends\<^sub>R_def)
    next
      case (Cons c cs)
      hence "r < c*x + \<langle>cs,xs\<rangle>" using Atom Less by simp
      { assume "c=0" hence ?thesis using Atom Less Cons by simp }
      moreover
      { assume "c<0"
        hence "x < (r - \<langle>cs,xs\<rangle>)/c" (is "_ < ?u") using `r < c*x + \<langle>cs,xs\<rangle>`
          by (simp add: field_simps)
        have ?thesis
        proof (rule ccontr)
          assume "\<not> R.I (Atom a) (y#xs)"
          hence "?u \<le> y" using Atom Less Cons `c<0`
            by (auto simp add: field_simps)
          hence "?u < u" using `y<u` by simp
          with `x<?u` show False using Atom Less Cons `c<0`
            by(auto simp:depends\<^sub>R_def)
        qed } moreover
      { assume "c>0"
        hence "x > (r - \<langle>cs,xs\<rangle>)/c" (is "_ > ?l") using `r < c*x + \<langle>cs,xs\<rangle>`
          by (simp add: field_simps)
        have ?thesis
        proof (rule ccontr)
          assume "\<not> R.I (Atom a) (y#xs)"
          hence "?l \<ge> y" using Atom Less Cons `c>0`
            by (auto simp add: field_simps)
          hence "?l > l" using `y>l` by simp
          with `?l<x` show False using Atom Less Cons `c>0`
            by (auto simp:depends\<^sub>R_def)
        qed }
      ultimately show ?thesis by force
    qed
  next
    case (Eq r cs)
    show ?thesis
    proof (cases cs)
      case Nil thus ?thesis using Atom Eq by (simp add:depends\<^sub>R_def)
    next
      case (Cons c cs)
      hence "r = c*x + \<langle>cs,xs\<rangle>" using Atom Eq by simp
      { assume "c=0" hence ?thesis using Atom Eq Cons by simp }
      moreover
      { assume "c\<noteq>0"
        hence ?thesis using `r = c*x + \<langle>cs,xs\<rangle>` Atom Eq Cons `l<y` `y<u`
          by(auto simp: ac_simps depends\<^sub>R_def split:if_splits) }
      ultimately show ?thesis by force
    qed
  qed
next
  case (And f1 f2) thus ?case by (fastforce simp:Ball_def)
next
  case (Or f1 f2) thus ?case by (fastforce simp:Ball_def)
qed fastforce+

theorem I_FR\<^sub>1:
assumes "nqfree \<phi>" shows "R.I (FR\<^sub>1 \<phi>) xs = (\<exists>x. R.I \<phi> (x#xs))"
  (is "?FR = ?EX")
proof
  assume ?FR
  { assume "R.I (inf\<^sub>- \<phi>) xs"
    hence ?EX using `?FR` min_inf[OF `nqfree \<phi>`, where xs=xs]
      by(auto simp add:FR\<^sub>1_def)
  } moreover
  { assume "R.I (inf\<^sub>+ \<phi>) xs"
    hence ?EX using `?FR` plus_inf[OF `nqfree \<phi>`, where xs=xs]
      by(auto simp add:FR\<^sub>1_def)
  } moreover
  { assume "\<exists>x \<in> EQ \<phi> xs. R.I \<phi> (x#xs)"
    hence ?EX using `?FR` by(auto simp add:FR\<^sub>1_def)
  } moreover
  { assume "\<not>R.I (inf\<^sub>- \<phi>) xs \<and> \<not>R.I (inf\<^sub>+ \<phi>) xs \<and>
            (\<forall>x\<in>EQ \<phi> xs. \<not>R.I \<phi> (x#xs))"
    with `?FR` obtain r cs s ds
      where "R.I (subst \<phi> (between (r,cs) (s,ds))) xs"
      by(auto simp: FR\<^sub>1_def eval_def
        diff_divide_distrib set_ebounds I_subst `nqfree \<phi>`) blast
    hence "R.I \<phi> (eval (between (r,cs) (s,ds)) xs # xs)"
      by(simp add:I_subst `nqfree \<phi>`)
    hence ?EX .. }
  ultimately show ?EX by blast
next
  assume ?EX
  then obtain x where x: "R.I \<phi> (x#xs)" ..
  { assume "R.I (inf\<^sub>- \<phi>) xs \<or> R.I (inf\<^sub>+ \<phi>) xs"
    hence ?FR by(auto simp:FR\<^sub>1_def)
  } moreover
  { assume "x : EQ \<phi> xs"
    then obtain r cs
      where "(r,cs) : set(ebounds(R.atoms\<^sub>0 \<phi>)) \<and> x = r + \<langle>cs,xs\<rangle>"
      by(force simp:set_ebounds field_simps)
    moreover hence "R.I (subst \<phi> (r,cs)) xs" using x
      by(auto simp: I_subst `nqfree \<phi>` eval_def)
    ultimately have ?FR by(force simp:FR\<^sub>1_def) } moreover
  { assume "\<not> R.I (inf\<^sub>- \<phi>) xs" and "\<not> R.I (inf\<^sub>+ \<phi>) xs" and "x \<notin> EQ \<phi> xs"
    obtain l where "l : LB \<phi> xs" "l < x"
      using LBex[OF `nqfree \<phi>` x `\<not> R.I (inf\<^sub>- \<phi>) xs` `x \<notin> EQ \<phi> xs`] ..
    obtain u where "u : UB \<phi> xs" "x < u"
      using UBex[OF `nqfree \<phi>` x `\<not> R.I (inf\<^sub>+ \<phi>) xs` `x \<notin> EQ \<phi> xs`] ..
    have "\<exists>l\<in>LB \<phi> xs. \<exists>u\<in>UB \<phi> xs. l<u \<and> (\<forall>y. l < y \<and> y < u \<longrightarrow> R.I \<phi> (y#xs))"
      using dense_interval[where P = "\<lambda>x. R.I \<phi> (x#xs)", OF finite_LB finite_UB `l:LB \<phi> xs` `u:UB \<phi> xs` `l<x` `x<u` x] x dense[OF `nqfree \<phi>` _ _ _ _ `x \<notin> EQ \<phi> xs`] by simp
    then obtain r c cs s d ds
      where "Less r (c # cs) : set (R.atoms\<^sub>0 \<phi>)" "Less s (d # ds) : set (R.atoms\<^sub>0 \<phi>)"
          "\<And>y. (r - \<langle>cs,xs\<rangle>) / c < y \<Longrightarrow> y < (s - \<langle>ds,xs\<rangle>) / d \<Longrightarrow> R.I \<phi> (y # xs)"
        and *: "c > 0" "d < 0" "(r - \<langle>cs,xs\<rangle>) / c < (s - \<langle>ds,xs\<rangle>) / d"
      by blast
    moreover
      have "(r - \<langle>cs,xs\<rangle>) / c < eval (between (r / c, (-1 / c) *\<^sub>s cs) (s / d, (-1 / d) *\<^sub>s ds)) xs" (is ?P)
        and "eval (between (r / c, (-1 / c) *\<^sub>s cs) (s / d, (-1 / d) *\<^sub>s ds)) xs < (s - \<langle>ds,xs\<rangle>) / d" (is ?Q)
    proof -
      from * have [simp]: "c * (c * (d * (d * 4))) > 0" by (auto simp add: sign_simps)
      from * have "c * s + d * \<langle>cs,xs\<rangle> < d * r + c * \<langle>ds,xs\<rangle>"
        by (simp add: field_simps)
      with * have "(2 * c * c * d) * (d * r + c * \<langle>ds,xs\<rangle>)
        < (2 * c * c * d) * (c * s + d * \<langle>cs,xs\<rangle>)"
        and "(2 * c * d * d) * (c * s + d * \<langle>cs,xs\<rangle>)
        < (2 * c * d * d) * (d * r + c * \<langle>ds,xs\<rangle>)" by simp_all
      with * show ?P and ?Q by (auto simp add: field_simps eval_def iprod_left_add_distrib)
    qed
    ultimately have ?FR
      by (fastforce simp: FR\<^sub>1_def bex_Un set_lbounds set_ubounds set_ebounds I_subst `nqfree \<phi>`)
  } ultimately show ?FR by blast
qed

definition "FR = R.lift_nnf_qe FR\<^sub>1"

lemma qfree_FR\<^sub>1: "nqfree \<phi> \<Longrightarrow> qfree (FR\<^sub>1 \<phi>)"
apply(simp add:FR\<^sub>1_def)
apply(rule qfree_list_disj)
apply(auto simp:qfree_min_inf qfree_plus_inf set_ubounds set_lbounds set_ebounds image_def qfree_map_fm)
done

theorem I_FR: "R.I (FR \<phi>) xs = R.I \<phi> xs"
by(simp add:I_FR\<^sub>1 FR_def R.I_lift_nnf_qe qfree_FR\<^sub>1)

theorem qfree_FR: "qfree (FR \<phi>)"
by(simp add:FR_def R.qfree_lift_nnf_qe qfree_FR\<^sub>1)

end


theory Weakening
  imports "../Nominal"
begin

text {*
  A simple proof of the Weakening Property in the simply-typed
  lambda-calculus. The proof is simple, because we can make use
  of the variable convention. *}

atom_decl name

text {* Terms and Types *}

nominal_datatype lam =
    Var "name"
  | App "lam" "lam"
  | Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [100,100] 100)

nominal_datatype ty =
    TVar "string"
  | TArr "ty" "ty" ("_ \<rightarrow> _" [100,100] 100)

lemma ty_fresh:
  fixes x::"name"
  and   T::"ty"
  shows "x\<sharp>T"
by (nominal_induct T rule: ty.strong_induct)
   (auto simp add: fresh_string)

text {*
  Valid contexts (at the moment we have no type for finite
  sets yet, therefore typing-contexts are lists). *}

inductive
  valid :: "(name\<times>ty) list \<Rightarrow> bool"
where
    v1[intro]: "valid []"
  | v2[intro]: "\<lbrakk>valid \<Gamma>;x\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((x,T)#\<Gamma>)"

equivariance valid

text{* Typing judgements *}

inductive
  typing :: "(name\<times>ty) list\<Rightarrow>lam\<Rightarrow>ty\<Rightarrow>bool" ("_ \<turnstile> _ : _" [60,60,60] 60)
where
    t_Var[intro]: "\<lbrakk>valid \<Gamma>; (x,T)\<in>set \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Var x : T"
  | t_App[intro]: "\<lbrakk>\<Gamma> \<turnstile> t1 : T1\<rightarrow>T2; \<Gamma> \<turnstile> t2 : T1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> App t1 t2 : T2"
  | t_Lam[intro]: "\<lbrakk>x\<sharp>\<Gamma>;(x,T1)#\<Gamma> \<turnstile> t : T2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].t : T1\<rightarrow>T2"

text {*
  We derive the strong induction principle for the typing
  relation (this induction principle has the variable convention
  already built-in). *}

equivariance typing
nominal_inductive typing
  by (simp_all add: abs_fresh ty_fresh)

text {* Abbreviation for the notion of subcontexts. *}

abbreviation
  "sub_context" :: "(name\<times>ty) list \<Rightarrow> (name\<times>ty) list \<Rightarrow> bool" ("_ \<subseteq> _" [60,60] 60)
where
  "\<Gamma>1 \<subseteq> \<Gamma>2 \<equiv> \<forall>x T. (x,T)\<in>set \<Gamma>1 \<longrightarrow> (x,T)\<in>set \<Gamma>2"

text {* Now it comes: The Weakening Lemma *}

text {*
  The first version is, after setting up the induction,
  completely automatic except for use of atomize. *}

lemma weakening_version1:
  fixes \<Gamma>1 \<Gamma>2::"(name\<times>ty) list"
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "valid \<Gamma>2"
  and     c: "\<Gamma>1 \<subseteq> \<Gamma>2"
  shows "\<Gamma>2 \<turnstile> t : T"
using a b c
by (nominal_induct \<Gamma>1 t T avoiding: \<Gamma>2 rule: typing.strong_induct)
   (auto | atomize)+

text {*
  The second version gives the details for the variable
  and lambda case. *}

lemma weakening_version2:
  fixes \<Gamma>1 \<Gamma>2::"(name\<times>ty) list"
  and   t ::"lam"
  and   \<tau> ::"ty"
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "valid \<Gamma>2"
  and     c: "\<Gamma>1 \<subseteq> \<Gamma>2"
  shows "\<Gamma>2 \<turnstile> t : T"
using a b c
proof (nominal_induct \<Gamma>1 t T avoiding: \<Gamma>2 rule: typing.strong_induct)
  case (t_Var \<Gamma>1 x T)  (* variable case *)
  have "\<Gamma>1 \<subseteq> \<Gamma>2" by fact
  moreover
  have "valid \<Gamma>2" by fact
  moreover
  have "(x,T)\<in> set \<Gamma>1" by fact
  ultimately show "\<Gamma>2 \<turnstile> Var x : T" by auto
next
  case (t_Lam x \<Gamma>1 T1 t T2) (* lambda case *)
  have vc: "x\<sharp>\<Gamma>2" by fact   (* variable convention *)
  have ih: "\<lbrakk>valid ((x,T1)#\<Gamma>2); (x,T1)#\<Gamma>1 \<subseteq> (x,T1)#\<Gamma>2\<rbrakk> \<Longrightarrow> (x,T1)#\<Gamma>2 \<turnstile> t:T2" by fact
  have "\<Gamma>1 \<subseteq> \<Gamma>2" by fact
  then have "(x,T1)#\<Gamma>1 \<subseteq> (x,T1)#\<Gamma>2" by simp
  moreover
  have "valid \<Gamma>2" by fact
  then have "valid ((x,T1)#\<Gamma>2)" using vc by (simp add: v2)
  ultimately have "(x,T1)#\<Gamma>2 \<turnstile> t : T2" using ih by simp
  with vc show "\<Gamma>2 \<turnstile> Lam [x].t : T1\<rightarrow>T2" by auto
qed (auto) (* app case *)

text{*
  The original induction principle for the typing relation
  is not strong enough - even this simple lemma fails to be
  simple ;o) *}

lemma weakening_not_straigh_forward:
  fixes \<Gamma>1 \<Gamma>2::"(name\<times>ty) list"
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "valid \<Gamma>2"
  and     c: "\<Gamma>1 \<subseteq> \<Gamma>2"
  shows "\<Gamma>2 \<turnstile> t : T"
using a b c
proof (induct arbitrary: \<Gamma>2)
  case (t_Var \<Gamma>1 x T) (* variable case still works *)
  have "\<Gamma>1 \<subseteq> \<Gamma>2" by fact
  moreover
  have "valid \<Gamma>2" by fact
  moreover
  have "(x,T) \<in> (set \<Gamma>1)" by fact
  ultimately show "\<Gamma>2 \<turnstile> Var x : T" by auto
next
  case (t_Lam x \<Gamma>1 T1 t T2) (* lambda case *)
  (* These are all assumptions available in this case*)
  have a0: "x\<sharp>\<Gamma>1" by fact
  have a1: "(x,T1)#\<Gamma>1 \<turnstile> t : T2" by fact
  have a2: "\<Gamma>1 \<subseteq> \<Gamma>2" by fact
  have a3: "valid \<Gamma>2" by fact
  have ih: "\<And>\<Gamma>3. \<lbrakk>valid \<Gamma>3; (x,T1)#\<Gamma>1 \<subseteq> \<Gamma>3\<rbrakk> \<Longrightarrow> \<Gamma>3 \<turnstile> t : T2" by fact
  have "(x,T1)#\<Gamma>1 \<subseteq> (x,T1)#\<Gamma>2" using a2 by simp
  moreover
  have "valid ((x,T1)#\<Gamma>2)" using v2 (* fails *)
    oops

text{*
  To show that the proof with explicit renaming is not simple,
  here is the proof without using the variable convention. It
  crucially depends on the equivariance property of the typing
  relation.

*}

lemma weakening_with_explicit_renaming:
  fixes \<Gamma>1 \<Gamma>2::"(name\<times>ty) list"
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "valid \<Gamma>2"
  and     c: "\<Gamma>1 \<subseteq> \<Gamma>2"
  shows "\<Gamma>2 \<turnstile> t : T"
using a b c
proof (induct arbitrary: \<Gamma>2)
  case (t_Lam x \<Gamma>1 T1 t T2) (* lambda case *)
  have fc0: "x\<sharp>\<Gamma>1" by fact
  have ih: "\<And>\<Gamma>3. \<lbrakk>valid \<Gamma>3; (x,T1)#\<Gamma>1 \<subseteq> \<Gamma>3\<rbrakk> \<Longrightarrow> \<Gamma>3 \<turnstile> t : T2" by fact
  obtain c::"name" where fc1: "c\<sharp>(x,t,\<Gamma>1,\<Gamma>2)"  (* we obtain a fresh name *)
    by (rule exists_fresh) (auto simp add: fs_name1)
  have "Lam [c].([(c,x)]\<bullet>t) = Lam [x].t" using fc1 (* we then alpha-rename the lambda-abstraction *)
    by (auto simp add: lam.inject alpha fresh_prod fresh_atm)
  moreover
  have "\<Gamma>2 \<turnstile> Lam [c].([(c,x)]\<bullet>t) : T1 \<rightarrow> T2" (* we can then alpha-rename our original goal *)
  proof -
    (* we establish (x,T1)#\<Gamma>1 \<subseteq> (x,T1)#([(c,x)]\<bullet>\<Gamma>2) and valid ((x,T1)#([(c,x)]\<bullet>\<Gamma>2)) *)
    have "(x,T1)#\<Gamma>1 \<subseteq> (x,T1)#([(c,x)]\<bullet>\<Gamma>2)"
    proof -
      have "\<Gamma>1 \<subseteq> \<Gamma>2" by fact
      then have "[(c,x)]\<bullet>((x,T1)#\<Gamma>1 \<subseteq> (x,T1)#([(c,x)]\<bullet>\<Gamma>2))" using fc0 fc1
        by (perm_simp add: eqvts calc_atm perm_fresh_fresh ty_fresh)
      then show "(x,T1)#\<Gamma>1 \<subseteq> (x,T1)#([(c,x)]\<bullet>\<Gamma>2)" by (rule perm_boolE)
    qed
    moreover
    have "valid ((x,T1)#([(c,x)]\<bullet>\<Gamma>2))"
    proof -
      have "valid \<Gamma>2" by fact
      then show "valid ((x,T1)#([(c,x)]\<bullet>\<Gamma>2))" using fc1
        by (auto intro!: v2 simp add: fresh_left calc_atm eqvts)
    qed
    (* these two facts give us by induction hypothesis the following *)
    ultimately have "(x,T1)#([(c,x)]\<bullet>\<Gamma>2) \<turnstile> t : T2" using ih by simp
    (* we now apply renamings to get to our goal *)
    then have "[(c,x)]\<bullet>((x,T1)#([(c,x)]\<bullet>\<Gamma>2) \<turnstile> t : T2)" by (rule perm_boolI)
    then have "(c,T1)#\<Gamma>2 \<turnstile> ([(c,x)]\<bullet>t) : T2" using fc1
      by (perm_simp add: eqvts calc_atm perm_fresh_fresh ty_fresh)
    then show "\<Gamma>2 \<turnstile> Lam [c].([(c,x)]\<bullet>t) : T1 \<rightarrow> T2" using fc1 by auto
  qed
  ultimately show "\<Gamma>2 \<turnstile> Lam [x].t : T1 \<rightarrow> T2" by simp
qed (auto) (* var and app cases *)

text {*
  Moral: compare the proof with explicit renamings to weakening_version1
  and weakening_version2, and imagine you are proving something more substantial
  than the weakening lemma. *}

end


(*  Title:      ZF/func.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section\<open>Functions, Function Spaces, Lambda-Abstraction\<close>

theory func imports equalities Sum begin

subsection\<open>The Pi Operator: Dependent Function Space\<close>

lemma subset_Sigma_imp_relation: "r \<subseteq> Sigma(A,B) \<Longrightarrow> relation(r)"
by (simp add: relation_def, blast)

lemma relation_converse_converse [simp]:
     "relation(r) \<Longrightarrow> converse(converse(r)) = r"
by (simp add: relation_def, blast)

lemma relation_restrict [simp]:  "relation(restrict(r,A))"
by (simp add: restrict_def relation_def, blast)

lemma Pi_iff:
    "f \<in> Pi(A,B) \<longleftrightarrow> function(f) \<and> f<=Sigma(A,B) \<and> A<=domain(f)"
by (unfold Pi_def, blast)

(*For upward compatibility with the former definition*)
lemma Pi_iff_old:
    "f \<in> Pi(A,B) \<longleftrightarrow> f<=Sigma(A,B) \<and> (\<forall>x\<in>A. \<exists>!y. \<langle>x,y\<rangle>: f)"
by (unfold Pi_def function_def, blast)

lemma fun_is_function: "f \<in> Pi(A,B) \<Longrightarrow> function(f)"
by (simp only: Pi_iff)

lemma function_imp_Pi:
     "\<lbrakk>function(f); relation(f)\<rbrakk> \<Longrightarrow> f \<in> domain(f) -> range(f)"
by (simp add: Pi_iff relation_def, blast)

lemma functionI:
     "\<lbrakk>\<And>x y y'. \<lbrakk>\<langle>x,y\<rangle>:r; <x,y'>:r\<rbrakk> \<Longrightarrow> y=y'\<rbrakk> \<Longrightarrow> function(r)"
by (simp add: function_def, blast)

(*Functions are relations*)
lemma fun_is_rel: "f \<in> Pi(A,B) \<Longrightarrow> f \<subseteq> Sigma(A,B)"
by (unfold Pi_def, blast)

lemma Pi_cong:
    "\<lbrakk>A=A';  \<And>x. x \<in> A' \<Longrightarrow> B(x)=B'(x)\<rbrakk> \<Longrightarrow> Pi(A,B) = Pi(A',B')"
by (simp add: Pi_def cong add: Sigma_cong)

(*Sigma_cong, Pi_cong NOT given to Addcongs: they cause
  flex-flex pairs and the "Check your prover" error.  Most
  Sigmas and Pis are abbreviated as * or -> *)

(*Weakening one function type to another; see also Pi_type*)
lemma fun_weaken_type: "\<lbrakk>f \<in> A->B;  B<=D\<rbrakk> \<Longrightarrow> f \<in> A->D"
by (unfold Pi_def, best)

subsection\<open>Function Application\<close>

lemma apply_equality2: "\<lbrakk>\<langle>a,b\<rangle>: f;  \<langle>a,c\<rangle>: f;  f \<in> Pi(A,B)\<rbrakk> \<Longrightarrow> b=c"
by (unfold Pi_def function_def, blast)

lemma function_apply_equality: "\<lbrakk>\<langle>a,b\<rangle>: f;  function(f)\<rbrakk> \<Longrightarrow> f`a = b"
by (unfold apply_def function_def, blast)

lemma apply_equality: "\<lbrakk>\<langle>a,b\<rangle>: f;  f \<in> Pi(A,B)\<rbrakk> \<Longrightarrow> f`a = b"
  unfolding Pi_def
apply (blast intro: function_apply_equality)
done

(*Applying a function outside its domain yields 0*)
lemma apply_0: "a \<notin> domain(f) \<Longrightarrow> f`a = 0"
by (unfold apply_def, blast)

lemma Pi_memberD: "\<lbrakk>f \<in> Pi(A,B);  c \<in> f\<rbrakk> \<Longrightarrow> \<exists>x\<in>A.  c = <x,f`x>"
apply (frule fun_is_rel)
apply (blast dest: apply_equality)
done

lemma function_apply_Pair: "\<lbrakk>function(f);  a \<in> domain(f)\<rbrakk> \<Longrightarrow> <a,f`a>: f"
apply (simp add: function_def, clarify)
apply (subgoal_tac "f`a = y", blast)
apply (simp add: apply_def, blast)
done

lemma apply_Pair: "\<lbrakk>f \<in> Pi(A,B);  a \<in> A\<rbrakk> \<Longrightarrow> <a,f`a>: f"
apply (simp add: Pi_iff)
apply (blast intro: function_apply_Pair)
done

(*Conclusion is flexible -- use rule_tac or else apply_funtype below!*)
lemma apply_type [TC]: "\<lbrakk>f \<in> Pi(A,B);  a \<in> A\<rbrakk> \<Longrightarrow> f`a \<in> B(a)"
by (blast intro: apply_Pair dest: fun_is_rel)

(*This version is acceptable to the simplifier*)
lemma apply_funtype: "\<lbrakk>f \<in> A->B;  a \<in> A\<rbrakk> \<Longrightarrow> f`a \<in> B"
by (blast dest: apply_type)

lemma apply_iff: "f \<in> Pi(A,B) \<Longrightarrow> \<langle>a,b\<rangle>: f \<longleftrightarrow> a \<in> A \<and> f`a = b"
apply (frule fun_is_rel)
apply (blast intro!: apply_Pair apply_equality)
done

(*Refining one Pi type to another*)
lemma Pi_type: "\<lbrakk>f \<in> Pi(A,C);  \<And>x. x \<in> A \<Longrightarrow> f`x \<in> B(x)\<rbrakk> \<Longrightarrow> f \<in> Pi(A,B)"
apply (simp only: Pi_iff)
apply (blast dest: function_apply_equality)
done

(*Such functions arise in non-standard datatypes, ZF/ex/Ntree for instance*)
lemma Pi_Collect_iff:
     "(f \<in> Pi(A, \<lambda>x. {y \<in> B(x). P(x,y)}))
      \<longleftrightarrow>  f \<in> Pi(A,B) \<and> (\<forall>x\<in>A. P(x, f`x))"
by (blast intro: Pi_type dest: apply_type)

lemma Pi_weaken_type:
        "\<lbrakk>f \<in> Pi(A,B);  \<And>x. x \<in> A \<Longrightarrow> B(x)<=C(x)\<rbrakk> \<Longrightarrow> f \<in> Pi(A,C)"
by (blast intro: Pi_type dest: apply_type)

(** Elimination of membership in a function **)

lemma domain_type: "\<lbrakk>\<langle>a,b\<rangle> \<in> f;  f \<in> Pi(A,B)\<rbrakk> \<Longrightarrow> a \<in> A"
by (blast dest: fun_is_rel)

lemma range_type: "\<lbrakk>\<langle>a,b\<rangle> \<in> f;  f \<in> Pi(A,B)\<rbrakk> \<Longrightarrow> b \<in> B(a)"
by (blast dest: fun_is_rel)

lemma Pair_mem_PiD: "\<lbrakk>\<langle>a,b\<rangle>: f;  f \<in> Pi(A,B)\<rbrakk> \<Longrightarrow> a \<in> A \<and> b \<in> B(a) \<and> f`a = b"
by (blast intro: domain_type range_type apply_equality)

subsection\<open>Lambda Abstraction\<close>

lemma lamI: "a \<in> A \<Longrightarrow> <a,b(a)> \<in> (\<lambda>x\<in>A. b(x))"
  unfolding lam_def
apply (erule RepFunI)
done

lemma lamE:
    "\<lbrakk>p: (\<lambda>x\<in>A. b(x));  \<And>x.\<lbrakk>x \<in> A; p=<x,b(x)>\<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow>  P"
by (simp add: lam_def, blast)

lemma lamD: "\<lbrakk>\<langle>a,c\<rangle>: (\<lambda>x\<in>A. b(x))\<rbrakk> \<Longrightarrow> c = b(a)"
by (simp add: lam_def)

lemma lam_type [TC]:
    "\<lbrakk>\<And>x. x \<in> A \<Longrightarrow> b(x): B(x)\<rbrakk> \<Longrightarrow> (\<lambda>x\<in>A. b(x)) \<in> Pi(A,B)"
by (simp add: lam_def Pi_def function_def, blast)

lemma lam_funtype: "(\<lambda>x\<in>A. b(x)) \<in> A -> {b(x). x \<in> A}"
by (blast intro: lam_type)

lemma function_lam: "function (\<lambda>x\<in>A. b(x))"
by (simp add: function_def lam_def)

lemma relation_lam: "relation (\<lambda>x\<in>A. b(x))"
by (simp add: relation_def lam_def)

lemma beta_if [simp]: "(\<lambda>x\<in>A. b(x)) ` a = (if a \<in> A then b(a) else 0)"
by (simp add: apply_def lam_def, blast)

lemma beta: "a \<in> A \<Longrightarrow> (\<lambda>x\<in>A. b(x)) ` a = b(a)"
by (simp add: apply_def lam_def, blast)

lemma lam_empty [simp]: "(\<lambda>x\<in>0. b(x)) = 0"
by (simp add: lam_def)

lemma domain_lam [simp]: "domain(Lambda(A,b)) = A"
by (simp add: lam_def, blast)

(*congruence rule for lambda abstraction*)
lemma lam_cong [cong]:
    "\<lbrakk>A=A';  \<And>x. x \<in> A' \<Longrightarrow> b(x)=b'(x)\<rbrakk> \<Longrightarrow> Lambda(A,b) = Lambda(A',b')"
by (simp only: lam_def cong add: RepFun_cong)

lemma lam_theI:
    "(\<And>x. x \<in> A \<Longrightarrow> \<exists>!y. Q(x,y)) \<Longrightarrow> \<exists>f. \<forall>x\<in>A. Q(x, f`x)"
apply (rule_tac x = "\<lambda>x\<in>A. THE y. Q (x,y)" in exI)
apply simp
apply (blast intro: theI)
done

lemma lam_eqE: "\<lbrakk>(\<lambda>x\<in>A. f(x)) = (\<lambda>x\<in>A. g(x));  a \<in> A\<rbrakk> \<Longrightarrow> f(a)=g(a)"
by (fast intro!: lamI elim: equalityE lamE)

(*Empty function spaces*)
lemma Pi_empty1 [simp]: "Pi(0,A) = {0}"
by (unfold Pi_def function_def, blast)

(*The singleton function*)
lemma singleton_fun [simp]: "{\<langle>a,b\<rangle>} \<in> {a} -> {b}"
by (unfold Pi_def function_def, blast)

lemma Pi_empty2 [simp]: "(A->0) = (if A=0 then {0} else 0)"
by (unfold Pi_def function_def, force)

lemma  fun_space_empty_iff [iff]: "(A->X)=0 \<longleftrightarrow> X=0 \<and> (A \<noteq> 0)"
apply auto
apply (fast intro!: equals0I intro: lam_type)
done

subsection\<open>Extensionality\<close>

(*Semi-extensionality!*)

lemma fun_subset:
    "\<lbrakk>f \<in> Pi(A,B);  g \<in> Pi(C,D);  A<=C;
        \<And>x. x \<in> A \<Longrightarrow> f`x = g`x\<rbrakk> \<Longrightarrow> f<=g"
by (force dest: Pi_memberD intro: apply_Pair)

lemma fun_extension:
    "\<lbrakk>f \<in> Pi(A,B);  g \<in> Pi(A,D);
        \<And>x. x \<in> A \<Longrightarrow> f`x = g`x\<rbrakk> \<Longrightarrow> f=g"
by (blast del: subsetI intro: subset_refl sym fun_subset)

lemma eta [simp]: "f \<in> Pi(A,B) \<Longrightarrow> (\<lambda>x\<in>A. f`x) = f"
apply (rule fun_extension)
apply (auto simp add: lam_type apply_type beta)
done

lemma fun_extension_iff:
     "\<lbrakk>f \<in> Pi(A,B); g \<in> Pi(A,C)\<rbrakk> \<Longrightarrow> (\<forall>a\<in>A. f`a = g`a) \<longleftrightarrow> f=g"
by (blast intro: fun_extension)

(*thm by Mark Staples, proof by lcp*)
lemma fun_subset_eq: "\<lbrakk>f \<in> Pi(A,B); g \<in> Pi(A,C)\<rbrakk> \<Longrightarrow> f \<subseteq> g \<longleftrightarrow> (f = g)"
by (blast dest: apply_Pair
          intro: fun_extension apply_equality [symmetric])

(*Every element of Pi(A,B) may be expressed as a lambda abstraction!*)
lemma Pi_lamE:
  assumes major: "f \<in> Pi(A,B)"
      and minor: "\<And>b. \<lbrakk>\<forall>x\<in>A. b(x):B(x);  f = (\<lambda>x\<in>A. b(x))\<rbrakk> \<Longrightarrow> P"
  shows "P"
apply (rule minor)
apply (rule_tac [2] eta [symmetric])
apply (blast intro: major apply_type)+
done

subsection\<open>Images of Functions\<close>

lemma image_lam: "C \<subseteq> A \<Longrightarrow> (\<lambda>x\<in>A. b(x)) `` C = {b(x). x \<in> C}"
by (unfold lam_def, blast)

lemma Repfun_function_if:
     "function(f)
      \<Longrightarrow> {f`x. x \<in> C} = (if C \<subseteq> domain(f) then f``C else cons(0,f``C))"
apply simp
apply (intro conjI impI)
 apply (blast dest: function_apply_equality intro: function_apply_Pair)
apply (rule equalityI)
 apply (blast intro!: function_apply_Pair apply_0)
apply (blast dest: function_apply_equality intro: apply_0 [symmetric])
done

(*For this lemma and the next, the right-hand side could equivalently
  be written \<Union>x\<in>C. {f`x} *)
lemma image_function:
     "\<lbrakk>function(f);  C \<subseteq> domain(f)\<rbrakk> \<Longrightarrow> f``C = {f`x. x \<in> C}"
by (simp add: Repfun_function_if)

lemma image_fun: "\<lbrakk>f \<in> Pi(A,B);  C \<subseteq> A\<rbrakk> \<Longrightarrow> f``C = {f`x. x \<in> C}"
apply (simp add: Pi_iff)
apply (blast intro: image_function)
done

lemma image_eq_UN:
  assumes f: "f \<in> Pi(A,B)" "C \<subseteq> A" shows "f``C = (\<Union>x\<in>C. {f ` x})"
by (auto simp add: image_fun [OF f])

lemma Pi_image_cons:
     "\<lbrakk>f \<in> Pi(A,B);  x \<in> A\<rbrakk> \<Longrightarrow> f `` cons(x,y) = cons(f`x, f``y)"
by (blast dest: apply_equality apply_Pair)

subsection\<open>Properties of \<^term>\<open>restrict(f,A)\<close>\<close>

lemma restrict_subset: "restrict(f,A) \<subseteq> f"
by (unfold restrict_def, blast)

lemma function_restrictI:
    "function(f) \<Longrightarrow> function(restrict(f,A))"
by (unfold restrict_def function_def, blast)

lemma restrict_type2: "\<lbrakk>f \<in> Pi(C,B);  A<=C\<rbrakk> \<Longrightarrow> restrict(f,A) \<in> Pi(A,B)"
by (simp add: Pi_iff function_def restrict_def, blast)

lemma restrict: "restrict(f,A) ` a = (if a \<in> A then f`a else 0)"
by (simp add: apply_def restrict_def, blast)

lemma restrict_empty [simp]: "restrict(f,0) = 0"
by (unfold restrict_def, simp)

lemma restrict_iff: "z \<in> restrict(r,A) \<longleftrightarrow> z \<in> r \<and> (\<exists>x\<in>A. \<exists>y. z = \<langle>x, y\<rangle>)"
by (simp add: restrict_def)

lemma restrict_restrict [simp]:
     "restrict(restrict(r,A),B) = restrict(r, A \<inter> B)"
by (unfold restrict_def, blast)

lemma domain_restrict [simp]: "domain(restrict(f,C)) = domain(f) \<inter> C"
  unfolding restrict_def
apply (auto simp add: domain_def)
done

lemma restrict_idem: "f \<subseteq> Sigma(A,B) \<Longrightarrow> restrict(f,A) = f"
by (simp add: restrict_def, blast)

(*converse probably holds too*)
lemma domain_restrict_idem:
     "\<lbrakk>domain(r) \<subseteq> A; relation(r)\<rbrakk> \<Longrightarrow> restrict(r,A) = r"
by (simp add: restrict_def relation_def, blast)

lemma domain_restrict_lam [simp]: "domain(restrict(Lambda(A,f),C)) = A \<inter> C"
  unfolding restrict_def lam_def
apply (rule equalityI)
apply (auto simp add: domain_iff)
done

lemma restrict_if [simp]: "restrict(f,A) ` a = (if a \<in> A then f`a else 0)"
by (simp add: restrict apply_0)

lemma restrict_lam_eq:
    "A<=C \<Longrightarrow> restrict(\<lambda>x\<in>C. b(x), A) = (\<lambda>x\<in>A. b(x))"
by (unfold restrict_def lam_def, auto)

lemma fun_cons_restrict_eq:
     "f \<in> cons(a, b) -> B \<Longrightarrow> f = cons(<a, f ` a>, restrict(f, b))"
apply (rule equalityI)
 prefer 2 apply (blast intro: apply_Pair restrict_subset [THEN subsetD])
apply (auto dest!: Pi_memberD simp add: restrict_def lam_def)
done

subsection\<open>Unions of Functions\<close>

(** The Union of a set of COMPATIBLE functions is a function **)

lemma function_Union:
    "\<lbrakk>\<forall>x\<in>S. function(x);
        \<forall>x\<in>S. \<forall>y\<in>S. x<=y | y<=x\<rbrakk>
     \<Longrightarrow> function(\<Union>(S))"
by (unfold function_def, blast)

lemma fun_Union:
    "\<lbrakk>\<forall>f\<in>S. \<exists>C D. f \<in> C->D;
             \<forall>f\<in>S. \<forall>y\<in>S. f<=y | y<=f\<rbrakk> \<Longrightarrow>
          \<Union>(S) \<in> domain(\<Union>(S)) -> range(\<Union>(S))"
  unfolding Pi_def
apply (blast intro!: rel_Union function_Union)
done

lemma gen_relation_Union:
     "(\<And>f. f\<in>F \<Longrightarrow> relation(f)) \<Longrightarrow> relation(\<Union>(F))"
by (simp add: relation_def)

(** The Union of 2 disjoint functions is a function **)

lemmas Un_rls = Un_subset_iff SUM_Un_distrib1 prod_Un_distrib2
                subset_trans [OF _ Un_upper1]
                subset_trans [OF _ Un_upper2]

lemma fun_disjoint_Un:
     "\<lbrakk>f \<in> A->B;  g \<in> C->D;  A \<inter> C = 0\<rbrakk>
      \<Longrightarrow> (f \<union> g) \<in> (A \<union> C) -> (B \<union> D)"
(*Prove the product and domain subgoals using distributive laws*)
apply (simp add: Pi_iff extension Un_rls)
apply (unfold function_def, blast)
done

lemma fun_disjoint_apply1: "a \<notin> domain(g) \<Longrightarrow> (f \<union> g)`a = f`a"
by (simp add: apply_def, blast)

lemma fun_disjoint_apply2: "c \<notin> domain(f) \<Longrightarrow> (f \<union> g)`c = g`c"
by (simp add: apply_def, blast)

subsection\<open>Domain and Range of a Function or Relation\<close>

lemma domain_of_fun: "f \<in> Pi(A,B) \<Longrightarrow> domain(f)=A"
by (unfold Pi_def, blast)

lemma apply_rangeI: "\<lbrakk>f \<in> Pi(A,B);  a \<in> A\<rbrakk> \<Longrightarrow> f`a \<in> range(f)"
by (erule apply_Pair [THEN rangeI], assumption)

lemma range_of_fun: "f \<in> Pi(A,B) \<Longrightarrow> f \<in> A->range(f)"
by (blast intro: Pi_type apply_rangeI)

subsection\<open>Extensions of Functions\<close>

lemma fun_extend:
     "\<lbrakk>f \<in> A->B;  c\<notin>A\<rbrakk> \<Longrightarrow> cons(\<langle>c,b\<rangle>,f) \<in> cons(c,A) -> cons(b,B)"
apply (frule singleton_fun [THEN fun_disjoint_Un], blast)
apply (simp add: cons_eq)
done

lemma fun_extend3:
     "\<lbrakk>f \<in> A->B;  c\<notin>A;  b \<in> B\<rbrakk> \<Longrightarrow> cons(\<langle>c,b\<rangle>,f) \<in> cons(c,A) -> B"
by (blast intro: fun_extend [THEN fun_weaken_type])

lemma extend_apply:
     "c \<notin> domain(f) \<Longrightarrow> cons(\<langle>c,b\<rangle>,f)`a = (if a=c then b else f`a)"
by (auto simp add: apply_def)

lemma fun_extend_apply [simp]:
     "\<lbrakk>f \<in> A->B;  c\<notin>A\<rbrakk> \<Longrightarrow> cons(\<langle>c,b\<rangle>,f)`a = (if a=c then b else f`a)"
apply (rule extend_apply)
apply (simp add: Pi_def, blast)
done

lemmas singleton_apply = apply_equality [OF singletonI singleton_fun, simp]

(*For Finite.ML.  Inclusion of right into left is easy*)
lemma cons_fun_eq:
     "c \<notin> A \<Longrightarrow> cons(c,A) -> B = (\<Union>f \<in> A->B. \<Union>b\<in>B. {cons(\<langle>c,b\<rangle>, f)})"
apply (rule equalityI)
apply (safe elim!: fun_extend3)
(*Inclusion of left into right*)
apply (subgoal_tac "restrict (x, A) \<in> A -> B")
 prefer 2 apply (blast intro: restrict_type2)
apply (rule UN_I, assumption)
apply (rule apply_funtype [THEN UN_I])
  apply assumption
 apply (rule consI1)
apply (simp (no_asm))
apply (rule fun_extension)
  apply assumption
 apply (blast intro: fun_extend)
apply (erule consE, simp_all)
done

lemma succ_fun_eq: "succ(n) -> B = (\<Union>f \<in> n->B. \<Union>b\<in>B. {cons(\<langle>n,b\<rangle>, f)})"
by (simp add: succ_def mem_not_refl cons_fun_eq)

subsection\<open>Function Updates\<close>

definition
  update  :: "[i,i,i] \<Rightarrow> i"  where
   "update(f,a,b) \<equiv> \<lambda>x\<in>cons(a, domain(f)). if(x=a, b, f`x)"

nonterminal updbinds and updbind

syntax

  (* Let expressions *)

  "_updbind"    :: "[i, i] \<Rightarrow> updbind"               (\<open>(2_ :=/ _)\<close>)
  ""            :: "updbind \<Rightarrow> updbinds"             (\<open>_\<close>)
  "_updbinds"   :: "[updbind, updbinds] \<Rightarrow> updbinds" (\<open>_,/ _\<close>)
  "_Update"     :: "[i, updbinds] \<Rightarrow> i"              (\<open>_/'((_)')\<close> [900,0] 900)

translations
  "_Update (f, _updbinds(b,bs))"  == "_Update (_Update(f,b), bs)"
  "f(x:=y)"                       == "CONST update(f,x,y)"

lemma update_apply [simp]: "f(x:=y) ` z = (if z=x then y else f`z)"
apply (simp add: update_def)
apply (case_tac "z \<in> domain(f)")
apply (simp_all add: apply_0)
done

lemma update_idem: "\<lbrakk>f`x = y;  f \<in> Pi(A,B);  x \<in> A\<rbrakk> \<Longrightarrow> f(x:=y) = f"
  unfolding update_def
apply (simp add: domain_of_fun cons_absorb)
apply (rule fun_extension)
apply (best intro: apply_type if_type lam_type, assumption, simp)
done

(* \<lbrakk>f \<in> Pi(A, B); x \<in> A\<rbrakk> \<Longrightarrow> f(x := f`x) = f *)
declare refl [THEN update_idem, simp]

lemma domain_update [simp]: "domain(f(x:=y)) = cons(x, domain(f))"
by (unfold update_def, simp)

lemma update_type: "\<lbrakk>f \<in> Pi(A,B);  x \<in> A;  y \<in> B(x)\<rbrakk> \<Longrightarrow> f(x:=y) \<in> Pi(A, B)"
  unfolding update_def
apply (simp add: domain_of_fun cons_absorb apply_funtype lam_type)
done

subsection\<open>Monotonicity Theorems\<close>

subsubsection\<open>Replacement in its Various Forms\<close>

(*Not easy to express monotonicity in P, since any "bigger" predicate
  would have to be single-valued*)
lemma Replace_mono: "A<=B \<Longrightarrow> Replace(A,P) \<subseteq> Replace(B,P)"
by (blast elim!: ReplaceE)

lemma RepFun_mono: "A<=B \<Longrightarrow> {f(x). x \<in> A} \<subseteq> {f(x). x \<in> B}"
by blast

lemma Pow_mono: "A<=B \<Longrightarrow> Pow(A) \<subseteq> Pow(B)"
by blast

lemma Union_mono: "A<=B \<Longrightarrow> \<Union>(A) \<subseteq> \<Union>(B)"
by blast

lemma UN_mono:
    "\<lbrakk>A<=C;  \<And>x. x \<in> A \<Longrightarrow> B(x)<=D(x)\<rbrakk> \<Longrightarrow> (\<Union>x\<in>A. B(x)) \<subseteq> (\<Union>x\<in>C. D(x))"
by blast

(*Intersection is ANTI-monotonic.  There are TWO premises! *)
lemma Inter_anti_mono: "\<lbrakk>A<=B;  A\<noteq>0\<rbrakk> \<Longrightarrow> \<Inter>(B) \<subseteq> \<Inter>(A)"
by blast

lemma cons_mono: "C<=D \<Longrightarrow> cons(a,C) \<subseteq> cons(a,D)"
by blast

lemma Un_mono: "\<lbrakk>A<=C;  B<=D\<rbrakk> \<Longrightarrow> A \<union> B \<subseteq> C \<union> D"
by blast

lemma Int_mono: "\<lbrakk>A<=C;  B<=D\<rbrakk> \<Longrightarrow> A \<inter> B \<subseteq> C \<inter> D"
by blast

lemma Diff_mono: "\<lbrakk>A<=C;  D<=B\<rbrakk> \<Longrightarrow> A-B \<subseteq> C-D"
by blast

subsubsection\<open>Standard Products, Sums and Function Spaces\<close>

lemma Sigma_mono [rule_format]:
     "\<lbrakk>A<=C;  \<And>x. x \<in> A \<longrightarrow> B(x) \<subseteq> D(x)\<rbrakk> \<Longrightarrow> Sigma(A,B) \<subseteq> Sigma(C,D)"
by blast

lemma sum_mono: "\<lbrakk>A<=C;  B<=D\<rbrakk> \<Longrightarrow> A+B \<subseteq> C+D"
by (unfold sum_def, blast)

(*Note that B->A and C->A are typically disjoint!*)
lemma Pi_mono: "B<=C \<Longrightarrow> A->B \<subseteq> A->C"
by (blast intro: lam_type elim: Pi_lamE)

lemma lam_mono: "A<=B \<Longrightarrow> Lambda(A,c) \<subseteq> Lambda(B,c)"
  unfolding lam_def
apply (erule RepFun_mono)
done

subsubsection\<open>Converse, Domain, Range, Field\<close>

lemma converse_mono: "r<=s \<Longrightarrow> converse(r) \<subseteq> converse(s)"
by blast

lemma domain_mono: "r<=s \<Longrightarrow> domain(r)<=domain(s)"
by blast

lemmas domain_rel_subset = subset_trans [OF domain_mono domain_subset]

lemma range_mono: "r<=s \<Longrightarrow> range(r)<=range(s)"
by blast

lemmas range_rel_subset = subset_trans [OF range_mono range_subset]

lemma field_mono: "r<=s \<Longrightarrow> field(r)<=field(s)"
by blast

lemma field_rel_subset: "r \<subseteq> A*A \<Longrightarrow> field(r) \<subseteq> A"
by (erule field_mono [THEN subset_trans], blast)

subsubsection\<open>Images\<close>

lemma image_pair_mono:
    "\<lbrakk>\<And>x y. \<langle>x,y\<rangle>:r \<Longrightarrow> \<langle>x,y\<rangle>:s;  A<=B\<rbrakk> \<Longrightarrow> r``A \<subseteq> s``B"
by blast

lemma vimage_pair_mono:
    "\<lbrakk>\<And>x y. \<langle>x,y\<rangle>:r \<Longrightarrow> \<langle>x,y\<rangle>:s;  A<=B\<rbrakk> \<Longrightarrow> r-``A \<subseteq> s-``B"
by blast

lemma image_mono: "\<lbrakk>r<=s;  A<=B\<rbrakk> \<Longrightarrow> r``A \<subseteq> s``B"
by blast

lemma vimage_mono: "\<lbrakk>r<=s;  A<=B\<rbrakk> \<Longrightarrow> r-``A \<subseteq> s-``B"
by blast

lemma Collect_mono:
    "\<lbrakk>A<=B;  \<And>x. x \<in> A \<Longrightarrow> P(x) \<longrightarrow> Q(x)\<rbrakk> \<Longrightarrow> Collect(A,P) \<subseteq> Collect(B,Q)"
by blast

(*Used in intr_elim.ML and in individual datatype definitions*)
lemmas basic_monos = subset_refl imp_refl disj_mono conj_mono ex_mono
                     Collect_mono Part_mono in_mono

(* Useful with simp; contributed by Clemens Ballarin. *)

lemma bex_image_simp:
  "\<lbrakk>f \<in> Pi(X, Y); A \<subseteq> X\<rbrakk>  \<Longrightarrow> (\<exists>x\<in>f``A. P(x)) \<longleftrightarrow> (\<exists>x\<in>A. P(f`x))"
  apply safe
   apply rule
    prefer 2 apply assumption
   apply (simp add: apply_equality)
  apply (blast intro: apply_Pair)
  done

lemma ball_image_simp:
  "\<lbrakk>f \<in> Pi(X, Y); A \<subseteq> X\<rbrakk>  \<Longrightarrow> (\<forall>x\<in>f``A. P(x)) \<longleftrightarrow> (\<forall>x\<in>A. P(f`x))"
  apply safe
   apply (blast intro: apply_Pair)
  apply (drule bspec) apply assumption
  apply (simp add: apply_equality)
  done

end


(*
  Title: The Quantale of Kleisli Arrows
  Author: Georg Struth
  Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>The Quantale of Kleisli Arrows\<close>

theory Kleisli_Quantale
  imports Kleisli_Quantaloid
          "Quantales.Quantale_Star"

begin

text \<open>This component revisits the results of the quantaloid one in the single-typed setting, that is, in
the context of quantales. An instance proof, showing that Kleisli arrows (or state transformers) form quantales, is
its main result. Facts proved for quantales are thus made available for state transformers.\<close>

typedef 'a nd_fun = "{f::'a \<Rightarrow> 'a set. f \<in> UNIV}"
  by simp

setup_lifting type_definition_nd_fun

text \<open>Definitions are lifted to gain access to the Kleisli categories.\<close>

lift_definition r2fnd :: "'a rel \<Rightarrow> 'a nd_fun" is "Abs_nd_fun \<circ> \<F>".

lift_definition f2rnd :: "'a nd_fun \<Rightarrow> 'a rel" is "\<R> \<circ> Rep_nd_fun".

declare Rep_nd_fun_inverse [simp]

lemma r2f2r_inv: "r2fnd \<circ> f2rnd = id"
  by transfer (simp add: fun_eq_iff pointfree_idE)

lemma f2r2f_inv: "f2rnd \<circ> r2fnd = id"
  by transfer (simp add: fun_eq_iff r2f_def f2r_def Abs_nd_fun_inverse)

instantiation nd_fun :: (type) monoid_mult
begin

lift_definition one_nd_fun :: "'a nd_fun" is "Abs_nd_fun \<eta>".

lift_definition times_nd_fun :: "'a::type nd_fun \<Rightarrow> 'a::type nd_fun \<Rightarrow> 'a::type nd_fun" is "\<lambda>f g. Abs_nd_fun (Rep_nd_fun f \<circ>\<^sub>K Rep_nd_fun g)".

instance
  by intro_classes (transfer, simp add: Abs_nd_fun_inverse kcomp_assoc)+

end

instantiation nd_fun :: (type) order_lean
begin

lift_definition less_eq_nd_fun :: "'a nd_fun \<Rightarrow> 'a nd_fun \<Rightarrow> bool" is "\<lambda>f g. Rep_nd_fun f \<le> Rep_nd_fun g".

lift_definition less_nd_fun :: "'a nd_fun \<Rightarrow> 'a nd_fun \<Rightarrow> bool" is "\<lambda>f g. Rep_nd_fun f \<le> Rep_nd_fun g \<and> f \<noteq> g".

instance
  apply intro_classes
    apply (transfer, simp)
   apply transfer using order.trans apply blast
  by (simp add: Rep_nd_fun_inject less_eq_nd_fun.abs_eq)

end

instantiation nd_fun :: (type) Sup_lattice
begin

lift_definition Sup_nd_fun :: "'a nd_fun set \<Rightarrow> 'a nd_fun" is "Abs_nd_fun \<circ> Sup \<circ> \<P> Rep_nd_fun".

instance
  by (intro_classes; transfer, simp_all add: Abs_nd_fun_inverse Sup_upper sup_absorb2 Sup_le_iff)

end

lemma Abs_comp_hom: "Abs_nd_fun (f \<circ>\<^sub>K g) = Abs_nd_fun f \<cdot> Abs_nd_fun g"
  by transfer (simp add: Abs_nd_fun_inverse)

lemma Rep_comp_hom: "Rep_nd_fun (f \<cdot> g) = Rep_nd_fun f \<circ>\<^sub>K Rep_nd_fun g"
  by (simp add: Abs_nd_fun_inverse times_nd_fun.abs_eq)

instance nd_fun :: (type) unital_Sup_quantale
  by (intro_classes; transfer, simp_all) (smt Abs_comp_hom Rep_comp_hom Rep_nd_fun_inverse SUP_cong image_image kSup_distr kSup_distl)+

text \<open>Unfortunately, this is not it yet. To benefit from Isabelle's theorems for orderings, lattices,
Kleene algebras and quantales, Isabelle's complete lattices need to be in scope. Somewhat annoyingly, this
requires more work...\<close>

instantiation nd_fun :: (type) complete_lattice
begin

lift_definition Inf_nd_fun :: "'a nd_fun set \<Rightarrow> 'a nd_fun" is "Abs_nd_fun \<circ> Inf \<circ> \<P> Rep_nd_fun".

lift_definition bot_nd_fun :: "'a::type nd_fun" is "Abs_nd_fun (Sup {})".

lift_definition sup_nd_fun :: "'a::type nd_fun \<Rightarrow> 'a::type nd_fun \<Rightarrow> 'a::type nd_fun" is "\<lambda>f g. Abs_nd_fun (Rep_nd_fun f \<squnion> Rep_nd_fun g)".

lift_definition top_nd_fun :: "'a::type nd_fun" is "Abs_nd_fun (Inf {})".

lift_definition inf_nd_fun :: "'a::type nd_fun \<Rightarrow> 'a::type nd_fun \<Rightarrow> 'a::type nd_fun" is "\<lambda>f g. Abs_nd_fun (Rep_nd_fun f \<sqinter> Rep_nd_fun g)".

instance
  apply intro_classes
                 apply transfer using Rep_nd_fun_inject dual_order.antisym apply blast
                apply (transfer, simp)
               apply (transfer, simp)
              apply (simp add: Abs_nd_fun_inverse)
  by (transfer; simp_all add: Abs_nd_fun_inverse Sup_le_iff SUP_upper2 le_INF_iff Inf_lower)+

end

instance nd_fun :: (type) unital_quantale
  apply intro_classes
  using supq.Sup_distr apply fastforce
  by (simp add: supq.Sup_distl)

text \<open>Now, theorems for the Kleene star, which come from quantales, are finally in scope.\<close>

lemma fun_star_unfoldl_eq: "(1::'a nd_fun) \<squnion> f \<cdot> qstar f = qstar f"
  by (simp add: qstar_comm)

lemma fun_star_unfoldl: "(1::'a nd_fun) \<squnion> f \<cdot> qstar f \<le> qstar f"
  using qstar_unfoldl by blast

lemma fun_star_unfoldr_eq: "(1::'a nd_fun) \<squnion> (qstar f) \<cdot> f = qstar f"
  by simp

lemma fun_star_unfoldr: "(1::'a nd_fun) \<squnion> qstar f \<cdot> f \<le> qstar f"
  by (simp add: fun_star_unfoldr_eq)

lemma fun_star_inductl: "(h::'a nd_fun) \<squnion> f \<cdot> g \<le> g \<Longrightarrow> qstar f \<cdot>  h \<le> g"
  using qstar_inductl by blast

lemma fun_star_inductr: "(h::'a nd_fun) \<squnion> g \<cdot> f \<le> g \<Longrightarrow> h \<cdot> qstar f \<le> g"
  by (simp add: qstar_inductr)

end


(*  Title:      HOL/Library/Char_ord.thy
    Author:     Norbert Voelker, Florian Haftmann
*)

section \<open>Order on characters\<close>

theory Char_ord
  imports Main
begin

instantiation char :: linorder
begin

definition "c1 \<le> c2 \<longleftrightarrow> nat_of_char c1 \<le> nat_of_char c2"
definition "c1 < c2 \<longleftrightarrow> nat_of_char c1 < nat_of_char c2"

instance
  by standard (auto simp add: less_eq_char_def less_char_def)

end

lemma less_eq_char_simps:
  "0 \<le> c"
  "Char k \<le> 0 \<longleftrightarrow> numeral k mod 256 = (0 :: nat)"
  "Char k \<le> Char l \<longleftrightarrow> numeral k mod 256 \<le> (numeral l mod 256 :: nat)"
  for c :: char
  by (simp_all add: Char_def less_eq_char_def)

lemma less_char_simps:
  "\<not> c < 0"
  "0 < Char k \<longleftrightarrow> (0 :: nat) < numeral k mod 256"
  "Char k < Char l \<longleftrightarrow> numeral k mod 256 < (numeral l mod 256 :: nat)"
  for c :: char
  by (simp_all add: Char_def less_char_def)

instantiation char :: distrib_lattice
begin

definition "(inf :: char \<Rightarrow> _) = min"
definition "(sup :: char \<Rightarrow> _) = max"

instance
  by standard (auto simp add: inf_char_def sup_char_def max_min_distrib2)

end

instantiation String.literal :: linorder
begin

context includes literal.lifting
begin

lift_definition less_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> bool"
  is "ord.lexordp op <" .

lift_definition less_eq_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> bool"
  is "ord.lexordp_eq op <" .

instance
proof -
  interpret linorder "ord.lexordp_eq op <" "ord.lexordp op < :: string \<Rightarrow> string \<Rightarrow> bool"
    by (rule linorder.lexordp_linorder[where less_eq="op \<le>"]) unfold_locales
  show "PROP ?thesis"
    by intro_classes (transfer, simp add: less_le_not_le linear)+
qed

end

end

lemma less_literal_code [code]:
  "op < = (\<lambda>xs ys. ord.lexordp op < (String.explode xs) (String.explode ys))"
  by (simp add: less_literal.rep_eq fun_eq_iff)

lemma less_eq_literal_code [code]:
  "op \<le> = (\<lambda>xs ys. ord.lexordp_eq op < (String.explode xs) (String.explode ys))"
  by (simp add: less_eq_literal.rep_eq fun_eq_iff)

lifting_update literal.lifting
lifting_forget literal.lifting

end


theory alexandrov
   imports "../conditions/conditions_kuratowski_infinitary"
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Generalized specialization orderings and Alexandrov topologies\<close>

(**A topology is called 'Alexandrov' (after the Russian mathematician Pavel Alexandrov) if the intersection
(resp. union) of any (finite or infinite) family of open (resp. closed) sets is open (resp. closed);
in algebraic terms, this means that the set of fixed points of the interior (closure) operation is closed
under infinite meets (joins). Another common algebraic formulation requires the closure (interior) operation
to satisfy the infinitary variants of additivity (multiplicativity), i.e. iADDI (iMULT) as introduced before.

In the literature, the well-known Kuratowski conditions for the closure (resp. interior) operation are assumed,
namely: ADDI, EXP, NOR, IDEM (resp. MULT, dEXP, dNOR, IDEM). This makes both formulations equivalent.
However, this is not the case in general if those conditions become negotiable.*)

(**Alexandrov topologies have interesting properties relating them to the semantics of modal logic.
Assuming Kuratowski conditions, Alexandrov topological operations defined on subsets of S are in one-to-one
correspondence with preorders on S; in topological terms, Alexandrov topologies are uniquely determined by
their specialization preorders. Since we do not presuppose any Kuratowski conditions to begin with, the
preorders in question are in general not even transitive. Here we just call them 'specialization relations'.
We will still call (generalized) closure/interior-like operations as such (for lack of a better name).
We explore minimal conditions under which some relevant results for the semantics of modal logic obtain.*)

subsection \<open>Specialization relations\<close>

(**Specialization relations (among worlds/points) are particular cases of propositional functions with type @{type "w\<Rightarrow>\<sigma>"}.*)

(**Define some relevant properties of relations: *)
abbreviation "serial R  \<equiv> \<forall>x. \<exists>y. R x y"
abbreviation "reflexive R  \<equiv> \<forall>x. R x x"
abbreviation "transitive R \<equiv> \<forall>x y z. R x y \<and> R y z \<longrightarrow> R x z"
abbreviation "antisymmetric R  \<equiv> \<forall>x y. R x y \<and> R y x \<longrightarrow> x = y"
abbreviation "symmetric R  \<equiv> \<forall>x y. R x y \<longrightarrow> R y x"

(**Closure/interior operations can be derived from an arbitrary relation as operations returning down-/up-sets.*)
definition Cl_rel::"(w\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<C>\<^sub>R") where "\<C>\<^sub>R R \<equiv> \<lambda>A. \<lambda>w. \<exists>v. R w v \<and> A v"
definition Int_rel::"(w\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<I>\<^sub>R") where "\<I>\<^sub>R R \<equiv> \<lambda>A. \<lambda>w. \<forall>v. R w v \<longrightarrow> A v"

(**Duality between interior and closure follows directly:*)
lemma dual_rel1: "\<forall>A. (\<C>\<^sub>R R) A \<^bold>\<approx> (\<I>\<^sub>R R)\<^sup>d A" unfolding Cl_rel_def Int_rel_def dual_def conn by simp
lemma dual_rel2: "\<forall>A. (\<I>\<^sub>R R) A \<^bold>\<approx> (\<C>\<^sub>R R)\<^sup>d A" unfolding Cl_rel_def Int_rel_def dual_def conn by simp

(**We explore minimal conditions of the specialization relation under which some operation's conditions obtain.*)
lemma rC1: "ADDI (\<C>\<^sub>R R)" unfolding Cl_rel_def ADDI_def conn by blast
lemma rC1i:"iADDI (\<C>\<^sub>R R)" by (smt Cl_rel_def Ra_restr_ex iADDI_def supremum_def)
lemma rC2: "reflexive R \<longrightarrow> EXP (\<C>\<^sub>R R)" unfolding EXP_def Cl_rel_def by auto
lemma rC3: "NOR (\<C>\<^sub>R R)" unfolding Cl_rel_def NOR_def conn by blast
lemma rC4: "reflexive R \<and> transitive R \<longrightarrow> IDEM (\<C>\<^sub>R R)" unfolding Cl_rel_def IDEM_def by smt
lemma rC_Barcan: "\<forall>\<pi>. (\<C>\<^sub>R R)(\<^bold>\<exists>x. \<pi> x) \<^bold>\<preceq> (\<^bold>\<exists>x. (\<C>\<^sub>R R)(\<pi> x))" unfolding Cl_rel_def by auto

lemma rI1: "MULT (\<I>\<^sub>R R)" unfolding Int_rel_def MULT_def conn by blast
lemma rI1i:"iMULT (\<I>\<^sub>R R)" by (smt Int_rel_def Ra_restr_all iMULT_def infimum_def)
lemma rI2: "reflexive R \<Longrightarrow> dEXP (\<I>\<^sub>R R)" unfolding Int_rel_def dEXP_def Int_rel_def by auto
lemma rI3: "dNOR (\<I>\<^sub>R R)" unfolding Int_rel_def dNOR_def conn by simp
lemma rI4: "reflexive R \<Longrightarrow> transitive R \<Longrightarrow> IDEM (\<I>\<^sub>R R)" unfolding IDEM_def Int_rel_def by smt
lemma rI_Barcan: "\<forall>\<pi>. (\<^bold>\<forall>x. (\<I>\<^sub>R R)(\<pi> x)) \<^bold>\<preceq> (\<I>\<^sub>R R)(\<^bold>\<forall>x. \<pi> x)" unfolding Int_rel_def by simp

(**A specialization relation can be derived from a given operation (intended as a closure-like operation).*)
definition sp_rel::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(w\<Rightarrow>\<sigma>)" ("\<R>\<^sup>C") where "\<R>\<^sup>C \<C> \<equiv> \<lambda>w v. \<C> (\<lambda>u. u=v) w"

(**Preorder properties of the specialization relation follow directly from the corresponding operation's conditions.*)
lemma sp_rel_reflex: "EXP \<C> \<Longrightarrow> reflexive (\<R>\<^sup>C \<C>)" by (simp add: EXP_def sp_rel_def)
lemma sp_rel_trans: "MONO \<C> \<Longrightarrow> IDEM \<C> \<Longrightarrow> transitive (\<R>\<^sup>C \<C>)" by (smt IDEM_def MONO_def sp_rel_def)

(**However, we can obtain finite countermodels for antisymmetry and symmetry given all relevant conditions.
We will revisit this issue later and examine their relation with the topological separation axioms T0 and T1 resp.*)
lemma "iADDI \<C> \<Longrightarrow> EXP \<C> \<Longrightarrow> NOR \<C> \<Longrightarrow> IDEM \<C> \<Longrightarrow> antisymmetric (\<R>\<^sup>C \<C>)" nitpick oops (*counterexample*)
lemma "iADDI \<C> \<Longrightarrow> EXP \<C> \<Longrightarrow> NOR \<C> \<Longrightarrow> IDEM \<C> \<Longrightarrow> symmetric (\<R>\<^sup>C \<C>)" nitpick oops (*counterexample*)

subsection \<open>Alexandrov topology\<close>

(**As mentioned previously, Alexandrov closure (and by duality interior) operations correspond to specialization
relations. It is worth mentioning that in Alexandrov topologies every point has a minimal/smallest neighborhood,
namely the set of points related to it by the specialization (aka. accessibility) relation. Alexandrov spaces are
thus also called 'finitely generated'. We examine below  minimal conditions under which these relations obtain.*)

lemma sp_rel_a:   "MONO \<C>  \<Longrightarrow> \<forall>A. (\<C>\<^sub>R (\<R>\<^sup>C \<C>)) A \<^bold>\<preceq> \<C> A" by (smt Cl_rel_def MONO_def sp_rel_def)
lemma sp_rel_b: "iADDI_a \<C> \<Longrightarrow> \<forall>A. (\<C>\<^sub>R (\<R>\<^sup>C \<C>)) A \<^bold>\<succeq> \<C> A"  proof -
  assume iaddia: "iADDI_a \<C>"
  { fix A
    let ?S="\<lambda>B::\<sigma>. \<exists>w::w. A w \<and> B=(\<lambda>u. u=w)"
    have "A \<^bold>\<approx> (\<^bold>\<Or>?S)" using supremum_def by auto
    hence "\<C>(A) \<^bold>\<approx> \<C>(\<^bold>\<Or>?S)" by (smt eq_ext)
    moreover have "\<^bold>\<Or>Ra[\<C>|?S] \<^bold>\<approx> (\<C>\<^sub>R (\<R>\<^sup>C \<C>)) A" by (smt Cl_rel_def Ra_restr_ex sp_rel_def)
    moreover from iaddia have "\<C>(\<^bold>\<Or>?S) \<^bold>\<preceq> \<^bold>\<Or>Ra[\<C>|?S]" unfolding iADDI_a_def by simp
    ultimately have "\<C> A \<^bold>\<preceq> (\<C>\<^sub>R (\<R>\<^sup>C \<C>)) A" by simp
  } thus ?thesis by simp
qed
lemma sp_rel: "iADDI \<C> \<Longrightarrow> \<forall>A. \<C> A \<^bold>\<approx> (\<C>\<^sub>R (\<R>\<^sup>C \<C>)) A" by (metis MONO_iADDIb iADDI_a_def iADDI_b_def iADDI_def sp_rel_a sp_rel_b)
(**It is instructive to expand the definitions in the above lemma:*)
lemma "iADDI \<C> \<Longrightarrow>  \<forall>A. \<forall>w. (\<C> A) w \<longleftrightarrow> (\<exists>v. A v \<and> (\<C> (\<lambda>u. u=v)) w)" using Cl_rel_def sp_rel by fastforce

(**We now turn to the more traditional characterization of Alexandrov topologies in terms of closure under
infinite joins/meets.*)

(**Fixed points of operations satisfying ADDI (MULT) are not in general closed under infinite joins (meets).
For the given conditions countermodels are expected to be infinite. We (sanity) check that nitpick cannot find any.*)
lemma "ADDI(\<phi>) \<Longrightarrow> supremum_closed (fp \<phi>)" (*nitpick*) oops (*cannot find finite countermodels*)
lemma "MULT(\<phi>) \<Longrightarrow> infimum_closed  (fp \<phi>)" (*nitpick*) oops (*cannot find finite countermodels*)

(**By contrast, we can show that this obtains if assuming the corresponding infinitary variants (iADDI/iMULT).*)
lemma "iADDI(\<phi>) \<Longrightarrow> supremum_closed (fp \<phi>)" by (metis (full_types) Ra_restr_ex iADDI_def supremum_def)
lemma "iMULT(\<phi>) \<Longrightarrow> infimum_closed  (fp \<phi>)" by (metis (full_types) Ra_restr_all iMULT_def infimum_def)

(**As shown above, closure (interior) operations derived from relations readily satisfy iADDI (iMULT),
being thus closed under infinite joins (meets).*)
lemma "supremum_closed (fp (\<C>\<^sub>R R))" by (smt Cl_rel_def supremum_def)
lemma "infimum_closed  (fp (\<I>\<^sub>R R))" by (smt Int_rel_def infimum_def)

subsection \<open>(Anti)symmetry and the separation axioms T0 and T1\<close>
(**We can now revisit the relationship between (anti)symmetry and the separation axioms T1 and T0.*)

(**T0: any two distinct points in the space can be separated by an open set (i.e. containing one point and not the other).*)
abbreviation "T0_sep \<C> \<equiv> \<forall>w v. w \<noteq> v \<longrightarrow> (\<exists>G. (fp \<C>\<^sup>d)(G) \<and> (G w \<noteq> G v))"
(**T1: any two distinct points can be separated by (two not necessarily disjoint) open sets, i.e. all singletons are closed.*)
abbreviation "T1_sep \<C> \<equiv> \<forall>w. (fp \<C>)(\<lambda>u. u = w)"

(**We can (sanity) check that T1 entails T0 but not viceversa.*)
lemma "T0_sep \<C> \<Longrightarrow> T1_sep \<C>" nitpick oops (*counterexample*)
lemma "T1_sep \<C> \<Longrightarrow> T0_sep \<C>" by (smt compl_def dual_def dual_symm)

(**Under appropriate conditions, T0-separation corresponds to antisymmetry of the specialization relation (here an ordering).*)
lemma "T0_sep \<C> \<longleftrightarrow> antisymmetric (\<R>\<^sup>C \<C>)" nitpick oops (*counterexample*)
lemma T0_antisymm_a: "MONO \<C> \<Longrightarrow> T0_sep \<C> \<longrightarrow> antisymmetric (\<R>\<^sup>C \<C>)" by (smt Cl_rel_def compl_def dual_def sp_rel_a)
lemma T0_antisymm_b: "EXP \<C> \<Longrightarrow> IDEM \<C> \<Longrightarrow> antisymmetric (\<R>\<^sup>C \<C>) \<longrightarrow> T0_sep \<C>" by (metis (full_types) EXP_dual1 IDEM_def IDEM_dual2 IDEMa_def IDEMb_def compl_def dEXP_def dual_def dual_symm sp_rel_def)
lemma T0_antisymm: "MONO \<C> \<Longrightarrow> EXP \<C> \<Longrightarrow> IDEM \<C> \<Longrightarrow> T0_sep \<C> = antisymmetric (\<R>\<^sup>C \<C>)" by (metis T0_antisymm_a T0_antisymm_b)

(**Also, under the appropriate conditions, T1-separation corresponds to symmetry of the specialization relation.*)
lemma T1_symm_a: "T1_sep \<C> \<longrightarrow> symmetric (\<R>\<^sup>C \<C>)" using sp_rel_def by auto
lemma T1_symm_b: "MONO \<C> \<Longrightarrow> EXP \<C> \<Longrightarrow> T0_sep \<C> \<Longrightarrow> symmetric (\<R>\<^sup>C \<C>) \<longrightarrow> T1_sep \<C>" by (metis T0_antisymm_a sp_rel_def sp_rel_reflex)
lemma T1_symm: "MONO \<C> \<Longrightarrow> EXP \<C> \<Longrightarrow> T0_sep \<C> \<Longrightarrow> symmetric (\<R>\<^sup>C \<C>) = T1_sep \<C>" by (metis T1_symm_a T1_symm_b)

end

github-repos/isabelle/davfuenmayor-topological-semantics/topological-semantics-770a84ffa2cf8498bd5f60853d11be4d77fc8cd3/old-stuff (to migrate from old version)/Example/alexandrov.thy