section \<open>Library Additions\<close>
theory Analysis_More
  imports "HOL-Analysis.Equivalence_Lebesgue_Henstock_Integration"
    "HOL-Library.Function_Algebras"
    "HOL-Types_To_Sets.Linear_Algebra_On"
begin

lemma openin_open_Int'[intro]:
  "open S \<Longrightarrow> openin (top_of_set U) (S \<inter> U)"
  by (auto simp: openin_open)

subsection \<open>Parametricity rules for topology\<close>

text \<open>TODO: also check with theory \<open>Transfer_Euclidean_Space_Vector\<close> in AFP/ODE...\<close>

context includes lifting_syntax begin

lemma Sigma_transfer[transfer_rule]:
  "(rel_set A ===> (A ===> rel_set B) ===> rel_set (rel_prod A B)) Sigma Sigma"
  unfolding Sigma_def
  by transfer_prover

lemma filterlim_transfer[transfer_rule]:
  "((A ===> B) ===> rel_filter B ===> rel_filter A ===> (=)) filterlim filterlim"
  if [transfer_rule]: "bi_unique B"
  unfolding filterlim_iff
  by transfer_prover

lemma nhds_transfer[transfer_rule]:
  "(A ===> rel_filter A) nhds nhds"
  if [transfer_rule]: "bi_unique A" "bi_total A" "(rel_set A ===> (=)) open open"
  unfolding nhds_def
  by transfer_prover

lemma at_within_transfer[transfer_rule]:
  "(A ===> rel_set A ===> rel_filter A) at_within at_within"
  if [transfer_rule]: "bi_unique A" "bi_total A" "(rel_set A ===> (=)) open open"
  unfolding at_within_def
  by transfer_prover

lemma continuous_on_transfer[transfer_rule]:
  "(rel_set A ===> (A ===> B) ===> (=)) continuous_on continuous_on"
  if [transfer_rule]: "bi_unique A" "bi_total A" "(rel_set A ===> (=)) open open"
    "bi_unique B" "bi_total B" "(rel_set B ===> (=)) open open"
  unfolding continuous_on_def
  by transfer_prover

lemma continuous_on_transfer_right_total[transfer_rule]:
  "(rel_set A ===> (A ===> B) ===> (=)) (\<lambda>X::'a::t2_space set. continuous_on (X \<inter> Collect AP)) (\<lambda>Y::'b::t2_space set. continuous_on Y)"
  if DomainA: "Domainp A = AP"
    and [folded DomainA, transfer_rule]: "bi_unique A" "right_total A" "(rel_set A ===> (=)) (openin (top_of_set (Collect AP))) open"
    "bi_unique B" "bi_total B" "(rel_set B ===> (=)) open open"
  unfolding DomainA[symmetric]
proof (intro rel_funI)
  fix X Y f g
  assume H[transfer_rule]: "rel_set A X Y" "(A ===> B) f g"
  from H(1) have XA: "x \<in> X \<Longrightarrow> Domainp A x" for x
    by (auto simp: rel_set_def)
  then have *: "X \<inter> Collect (Domainp A) = X" by auto
  have "openin (top_of_set (Collect (Domainp A))) (Collect (Domainp A))" by auto
  show " continuous_on (X \<inter> Collect (Domainp A)) f = continuous_on Y g"
    unfolding continuous_on_eq_continuous_within continuous_within_topological *
    apply transfer
    apply safe
    subgoal for x B
      apply (drule bspec, assumption, drule spec, drule mp, assumption, drule mp, assumption)
      apply clarsimp
      subgoal for AA
        apply (rule exI[where x="AA \<inter> Collect (Domainp A)"])
        by (auto intro: XA)
      done
    subgoal using XA by (force simp: openin_subtopology)
    done
qed

lemma continuous_on_transfer_right_total2[transfer_rule]:
  "(rel_set A ===> (A ===> B) ===> (=)) (\<lambda>X::'a::t2_space set. continuous_on X) (\<lambda>Y::'b::t2_space set. continuous_on Y)"
  if DomainB: "Domainp B = BP"
  and [folded DomainB, transfer_rule]: "bi_unique A" "bi_total A" "(rel_set A ===> (=)) open open"
    "bi_unique B" "right_total B" "(rel_set B ===> (=)) ((openin (top_of_set (Collect BP)))) open"
  unfolding DomainB[symmetric]
proof (intro rel_funI)
  fix X Y f g
  assume H[transfer_rule]: "rel_set A X Y" "(A ===> B) f g"
  show "continuous_on X f = continuous_on Y g"
    unfolding continuous_on_eq_continuous_within continuous_within_topological
    apply transfer
    apply safe
    subgoal for x C
      apply (clarsimp simp: openin_subtopology)
      apply (drule bspec, assumption, drule spec, drule mp, assumption, drule mp, assumption)
      apply clarsimp
      by (meson Domainp_applyI H(1) H(2) rel_setD1)
    subgoal for x C
    proof -
      let ?sub = "top_of_set (Collect (Domainp B))"
      assume cont: "\<forall>x\<in>X. \<forall>Ba\<in>{A. Ball A (Domainp B)}.
          openin (top_of_set (Collect (Domainp B))) Ba \<longrightarrow> f x \<in> Ba \<longrightarrow> (\<exists>Aa.  open Aa \<and> x \<in> Aa \<and> (\<forall>y\<in>X. y \<in> Aa \<longrightarrow> f y \<in> Ba))"
        and x: "x \<in> X" "open C" "f x \<in> C"
      let ?B = "C \<inter> Collect (Domainp B)"
      have "?B \<in> {A. Ball A (Domainp B)}" by auto
      have "openin ?sub (Collect (Domainp B))" by auto
      then have "openin ?sub ?B" using \<open>open C\<close> by auto
      moreover have "f x \<in> ?B" using x
        apply transfer apply auto
        by (meson Domainp_applyI H(1) H(2) rel_setD1)
      ultimately obtain D where "open D \<and> x \<in> D \<and> (\<forall>y\<in>X. y \<in> D \<longrightarrow> f y \<in> ?B)"
        using cont x
        by blast
      then show "\<exists>A. open A \<and> x \<in> A \<and> (\<forall>y\<in>X. y \<in> A \<longrightarrow> f y \<in> C)" by auto
    qed
    done
qed

lemma generate_topology_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows "(rel_set (rel_set A) ===> rel_set A ===> (=)) (generate_topology o (insert (Collect (Domainp A)))) generate_topology"
proof (intro rel_funI)
  fix B C X Y assume t[transfer_rule]: "rel_set (rel_set A) B C" "rel_set A X Y"
  then have "X \<subseteq> Collect (Domainp A)" by (auto simp: rel_set_def)
  with t have rI: "rel_set A (X \<inter> Collect (Domainp A)) Y"
    by (auto simp: inf_absorb1)
  have eq_UNIV_I: "Z = UNIV" if [transfer_rule]: "rel_set A {a. Domainp A a} Z" for Z
    using that assms
    apply (auto simp: right_total_def rel_set_def)
    using bi_uniqueDr by fastforce
  show "(generate_topology \<circ> insert (Collect (Domainp A))) B X = generate_topology C Y"
    unfolding o_def
  proof (rule iffI)
    fix x
    assume "generate_topology (insert (Collect (Domainp A)) B) X"
    then show "generate_topology C Y" unfolding o_def
      using rI
    proof (induction X arbitrary: Y)
      case [transfer_rule]: UNIV
      with eq_UNIV_I[of Y] show ?case
        by (simp add: generate_topology.UNIV)
    next
      case (Int a b)
      note [transfer_rule] = Int(5)
      obtain a' where a'[transfer_rule]: "rel_set A (a \<inter> Collect (Domainp A)) a'"
        by (metis Domainp_iff Domainp_set Int_Collect)
      obtain b' where b'[transfer_rule]: "rel_set A (b \<inter> Collect (Domainp A)) b'"
        by (metis Domainp_iff Domainp_set Int_Collect)
      from Int.IH(1)[OF a'] Int.IH(2)[OF b']
      have "generate_topology C a'" "generate_topology C b'" by auto
      from generate_topology.Int[OF this] have "generate_topology C (a' \<inter> b')" .
      also have "a' \<inter> b' = Y"
        by transfer auto
      finally show ?case
        by (simp add: generate_topology.Int)
    next
      case (UN K)
      note [transfer_rule] = UN(3)
      have "\<exists>K'. \<forall>k. rel_set A (k \<inter> Collect (Domainp A)) (K' k)"
        by (rule choice) (metis Domainp_iff Domainp_set Int_Collect)
      then obtain K' where K': "\<And>k. rel_set A (k \<inter> Collect (Domainp A)) (K' k)" by metis
      from UN.IH[OF _ this] have "generate_topology C k'" if "k' \<in> K'`K" for k' using that by auto
      from generate_topology.UN[OF this] have "generate_topology C (\<Union>(K' ` K))" .
      also
      from K' have [transfer_rule]: "(rel_set (=) ===> rel_set A) (\<lambda>x. x \<inter> Collect (Domainp A)) K'"
        by (fastforce simp: rel_fun_def rel_set_def)
      have "\<Union>(K' ` K) = Y"
        by transfer auto
      finally show ?case
        by (simp add: generate_topology.UN)
    next
      case (Basis s)
      from this(1) show ?case
      proof
        assume "s = Collect (Domainp A)"
        with eq_UNIV_I[of Y] Basis(2)
        show ?case
          by (simp add: generate_topology.UNIV)
      next
        assume "s \<in> B"
        with Basis(2) obtain t where [transfer_rule]: "rel_set A (s \<inter> Collect (Domainp A)) t" by auto
        from Basis(1) t(1) have s: "s \<inter> Collect (Domainp A) = s"
          by (force simp: rel_set_def)
        have "t \<in> C" using \<open>s \<in> B\<close> s
          by transfer auto
        also note [transfer_rule] = Basis(2)
        have "t = Y"
          by transfer auto
        finally show ?case
          by (rule generate_topology.Basis)
      qed
    qed
  next
    assume "generate_topology C Y"
    then show "generate_topology (insert (Collect (Domainp A)) B) X"
      using \<open>rel_set A X Y\<close>
    proof (induction arbitrary: X)
      case [transfer_rule]: UNIV
      have "UNIV = (UNIV::'b set)" by auto
      then have "X = {a. Domainp A a}" by transfer
      then show ?case by (intro generate_topology.Basis) auto
    next
      case (Int a b)
      obtain a' b' where [transfer_rule]: "rel_set A a' a" "rel_set A b' b"
        by (meson assms(1) right_total_def right_total_rel_set)
      from generate_topology.Int[OF Int.IH(1)[OF this(1)] Int.IH(2)[OF this(2)]]
      have "generate_topology (insert {a. Domainp A a} B) (a' \<inter> b')" by simp
      also
      define I where "I = a \<inter> b"
      from \<open>rel_set A X (a \<inter> b)\<close> have [transfer_rule]: "rel_set A X I" by (simp add: I_def)
      from I_def
      have "a' \<inter> b' = X" by transfer simp
      finally show ?case .
    next
      case (UN K)
      have "\<exists>K'. \<forall>k. rel_set A (K' k) k"
        by (rule choice) (meson assms(1) right_total_def right_total_rel_set)
      then obtain K' where K': "\<And>k. rel_set A (K' k) k" by metis
      from UN.IH[OF _ this] have "generate_topology (insert {a. Domainp A a} B) k"
        if "k \<in> K'`K" for k using that by auto
      from generate_topology.UN[OF this]
      have "generate_topology (insert {a. Domainp A a} B) (\<Union>(K'`K))" by auto
      also
      from K' have [transfer_rule]: "(rel_set (=) ===> rel_set A) K' id"
        by (fastforce simp: rel_fun_def rel_set_def)
      define U where "U =  (\<Union>(id ` K))"
      from \<open>rel_set A X _\<close> have [transfer_rule]: "rel_set A X U" by (simp add: U_def)
      from U_def have "\<Union>(K' ` K) = X" by transfer simp
      finally show ?case .
    next
      case (Basis s)
      note [transfer_rule] = \<open>rel_set A X s\<close>
      from \<open>s \<in> C\<close> have "X \<in> B" by transfer
      then show ?case by (intro generate_topology.Basis) auto
    qed
  qed
qed

end

subsection \<open>Miscellaneous\<close>

lemmas [simp del] = mem_ball

lemma in_closureI[intro, simp]: "x \<in> X \<Longrightarrow> x \<in> closure X"
  using closure_subset by auto

lemmas open_continuous_vimage = continuous_on_open_vimage[THEN iffD1, rule_format]
lemma open_continuous_vimage': "open s \<Longrightarrow> continuous_on s f \<Longrightarrow> open B \<Longrightarrow> open (s \<inter> f -` B)"
  using open_continuous_vimage[of s f B] by (auto simp: Int_commute)

lemma support_on_mono: "support_on carrier f \<subseteq> support_on carrier g"
  if "\<And>x. x \<in> carrier \<Longrightarrow> f x \<noteq> 0 \<Longrightarrow> g x \<noteq> 0"
  using that
  by (auto simp: support_on_def)

subsection \<open>Closed support\<close>

definition "csupport_on X S = closure (support_on X S)"

lemma closed_csupport_on[intro, simp]: "closed (csupport_on carrier \<phi>)"
  by (auto simp: csupport_on_def)

lemma not_in_csupportD: "x \<notin> csupport_on carrier \<phi> \<Longrightarrow> x \<in> carrier \<Longrightarrow> \<phi> x = 0"
  by (auto simp: csupport_on_def support_on_def)

lemma csupport_on_mono: "csupport_on carrier f \<subseteq> csupport_on carrier g"
  if "\<And>x. x \<in> carrier \<Longrightarrow> f x \<noteq> 0 \<Longrightarrow> g x \<noteq> 0"
  unfolding csupport_on_def
  apply (rule closure_mono)
  using that
  by (rule support_on_mono)

subsection \<open>Homeomorphism\<close>

lemma homeomorphism_empty[simp]:
  "homeomorphism {} t f f' \<longleftrightarrow> t = {}"
  "homeomorphism s {} f f' \<longleftrightarrow> s = {}"
  by (auto simp: homeomorphism_def)

lemma homeomorphism_add:
  "homeomorphism UNIV UNIV (\<lambda>x. x + c) (\<lambda>x. x - c)"
  for c::"_::real_normed_vector"
  unfolding homeomorphism_def
  by (auto simp: algebra_simps continuous_intros intro!: image_eqI[where x="x - c" for x])

lemma in_range_scaleR_iff: "x \<in> range ((*\<^sub>R) c) \<longleftrightarrow> c = 0 \<longrightarrow> x = 0"
  for x::"_::real_vector"
  by (auto simp: intro!: image_eqI[where x="x /\<^sub>R c"])

lemma homeomorphism_scaleR:
  "homeomorphism UNIV UNIV (\<lambda>x. c *\<^sub>R x::_::real_normed_vector) (\<lambda>x. x /\<^sub>R c)"
  if "c \<noteq> 0"
  using that
  unfolding homeomorphism_def
  by (auto simp: in_range_scaleR_iff algebra_simps intro!: continuous_intros)

lemma homeomorphism_prod:
  "homeomorphism (a \<times> b) (c \<times> d) (\<lambda>(x, y). (f x, g y)) (\<lambda>(x, y). (f' x, g' y))"
  if "homeomorphism a c f f'"
     "homeomorphism b d g g'"
  using that by (simp add: homeomorphism_def image_prod)
    (auto simp add: split_beta intro!: continuous_intros elim: continuous_on_compose2)

subsection \<open>Generalizations\<close>

lemma openin_subtopology_eq_generate_topology:
  "openin (top_of_set S) x = generate_topology (insert S ((\<lambda>B. B \<inter> S) ` BB)) x"
  if open_gen: "open = generate_topology BB" and subset: "x \<subseteq> S"
proof -
  have "generate_topology (insert S ((\<lambda>B. B \<inter> S) ` BB)) (T \<inter> S)"
    if "generate_topology BB T"
    for T
    using that
  proof (induction)
    case UNIV
    then show ?case by (auto intro!: generate_topology.Basis)
  next
    case (Int a b)
    have "generate_topology (insert S ((\<lambda>B. B \<inter> S) ` BB)) (a \<inter> S \<inter> (b \<inter> S))"
      by (rule generate_topology.Int) (use Int in auto)
    then show ?case by (simp add: ac_simps)
  next
    case (UN K)
    then have "generate_topology (insert S ((\<lambda>B. B \<inter> S) ` BB)) (\<Union>k\<in>K. k \<inter> S)"
      by (intro generate_topology.UN) auto
    then show ?case by simp
  next
    case (Basis s)
    then show ?case
      by (intro generate_topology.Basis) auto
  qed
  moreover
  have "\<exists>T. generate_topology BB T \<and> x = T \<inter> S"
    if "generate_topology (insert S ((\<lambda>B. B \<inter> S) ` BB)) x" "x \<noteq> UNIV"
    using that
  proof (induction)
    case UNIV
    then show ?case by simp
  next
    case (Int a b)
    then show ?case
      using generate_topology.Int
      by auto
  next
    case (UN K)
    from UN.IH have "\<forall>k\<in>K-{UNIV}. \<exists>T. generate_topology BB T \<and> k = T \<inter> S" by auto
    from this[THEN bchoice] obtain T where T: "\<And>k. k \<in> T ` (K - {UNIV}) \<Longrightarrow> generate_topology BB k" "\<And>k. k \<in> K - {UNIV} \<Longrightarrow> k = (T k) \<inter> S"
      by auto
    from generate_topology.UN[OF T(1)]
    have "generate_topology BB (\<Union>(T ` (K - {UNIV})))" by auto
    moreover have "\<Union>K = (\<Union>(T ` (K - {UNIV}))) \<inter> S" if "UNIV \<notin> K" using T(2) UN that by auto
    ultimately show ?case
      apply (cases "UNIV \<in> K") subgoal using UN by auto
      subgoal by auto
      done
  next
    case (Basis s)
    then show ?case
      using generate_topology.UNIV generate_topology.Basis by blast
  qed
  moreover
  have "\<exists>T. generate_topology BB T \<and> UNIV = T \<inter> S" if "generate_topology (insert S ((\<lambda>B. B \<inter> S) ` BB)) x"
     "x = UNIV"
  proof -
    have "S = UNIV"
      using that \<open>x \<subseteq> S\<close>
      by auto
    then show ?thesis by (simp add: generate_topology.UNIV)
  qed
  ultimately show ?thesis
    by (metis open_gen open_openin openin_open_Int' openin_subtopology)
qed

subsection \<open>Equal topologies\<close>

lemma topology_eq_iff: "t = s \<longleftrightarrow> (topspace t = topspace s \<and>
  (\<forall>x\<subseteq>topspace t. openin t x = openin s x))"
  by (metis (full_types) openin_subset topology_eq)

subsection \<open>Finer topologies\<close>

definition finer_than (infix "(finer'_than)" 50)
  where "T1 finer_than T2 \<longleftrightarrow> continuous_map T1 T2 (\<lambda>x. x)"

lemma finer_than_iff_nhds:
  "T1 finer_than T2 \<longleftrightarrow> (\<forall>X. openin T2 X \<longrightarrow> openin T1 (X \<inter> topspace T1)) \<and> (topspace T1 \<subseteq> topspace T2)"
  by (auto simp: finer_than_def continuous_map_alt)

lemma continuous_on_finer_topo:
  "continuous_map s t f"
  if "continuous_map s' t f" "s finer_than s'"
  using that
  by (auto simp: finer_than_def o_def dest: continuous_map_compose)

lemma antisym_finer_than: "S = T" if "S finer_than T" "T finer_than S"
  using that
  apply (auto simp: finer_than_def topology_eq_iff continuous_map_alt)
  apply (metis inf.orderE)+
  done

lemma subtopology_finer_than[simp]: "top_of_set X finer_than euclidean"
  by (auto simp: finer_than_iff_nhds openin_subtopology)

subsection \<open>Support\<close>

lemma support_on_nonneg_sum:
  "support_on X (\<lambda>x. \<Sum>i\<in>S. f i x) = (\<Union>i\<in>S. support_on X (f i))"
  if "finite S" "\<And>x i . x \<in> X \<Longrightarrow> i \<in> S \<Longrightarrow> f i x \<ge> 0"
  for f::"_\<Rightarrow>_\<Rightarrow>_::ordered_comm_monoid_add"
  using that by (auto simp: support_on_def sum_nonneg_eq_0_iff)

lemma support_on_nonneg_sum_subset:
  "support_on X (\<lambda>x. \<Sum>i\<in>S. f i x) \<subseteq> (\<Union>i\<in>S. support_on X (f i))"
  for f::"_\<Rightarrow>_\<Rightarrow>_::ordered_comm_monoid_add"
by (cases "finite S") (auto simp: support_on_def, meson sum.neutral)

subsection \<open>Final topology (Bourbaki, General Topology I, 4.)\<close>

definition "final_topology X Y f =
  topology (\<lambda>U. U \<subseteq> X \<and>
    (\<forall>i. openin (Y i) (f i -` U \<inter> topspace (Y i))))"

lemma openin_final_topology:
  "openin (final_topology X Y f) =
    (\<lambda>U. U \<subseteq> X \<and> (\<forall>i. openin (Y i) (f i -` U \<inter> topspace (Y i))))"
  unfolding final_topology_def
  apply (rule topology_inverse')
  unfolding istopology_def
proof safe
  fix S T i
  assume "\<forall>i. openin (Y i) (f i -` S \<inter> topspace (Y i))"
    "\<forall>i. openin (Y i) (f i -` T \<inter> topspace (Y i))"
  then have "openin (Y i) (f i -` S \<inter> topspace (Y i) \<inter> (f i -` T \<inter> topspace (Y i)))"
    (is "openin _ ?I")
    by auto
  also have "?I = f i -` (S \<inter> T) \<inter> topspace (Y i)"
    (is "_ = ?R")
    by auto
  finally show "openin (Y i) ?R" .
next
  fix K i
  assume "\<forall>U\<in>K. U \<subseteq> X \<and> (\<forall>i. openin (Y i) (f i -` U \<inter> topspace (Y i)))"
  then have "openin (Y i) (\<Union>X\<in>K. f i -` X \<inter> topspace (Y i))"
    by (intro openin_Union) auto
  then show "openin (Y i) (f i -` \<Union>K \<inter> topspace (Y i))"
    by (auto simp: vimage_Union)
qed force+

lemma continuous_on_final_topologyI2:
  "continuous_map (Y i) (final_topology X Y f) (f i)"
  if "\<And>i. f i \<in> topspace (Y i) \<rightarrow> X"
  using that
  by (auto simp: openin_final_topology continuous_map_alt topspace_final_topology)

lemma continuous_on_final_topologyI1:
  "continuous_map (final_topology X Y f) Z g"
  if hyp: "\<And>i. continuous_map (Y i) Z (g o f i)"
    and that: "\<And>i. f i \<in> topspace (Y i) \<rightarrow> X" "g \<in> X \<rightarrow> topspace Z"
  unfolding continuous_map_alt
proof safe
  fix V assume V: "openin Z V"
  have oV: "openin (Y i) (f i -` g -` V \<inter> topspace (Y i))"
    for i
    using hyp[rule_format, of i] V
    by (auto simp: continuous_map_alt vimage_comp dest!: spec[where x=V])
  have *: "f i -` g -` V \<inter> f i -` X \<inter> topspace (Y i) =
      f i -` g -` V \<inter> topspace (Y i)"
    (is "_ = ?rhs i")
    for i using that
    by auto
  show "openin (final_topology X Y f) (g -` V \<inter> topspace (final_topology X Y f))"
    by (auto simp: openin_final_topology oV topspace_final_topology that *)
qed (use that in \<open>auto simp: topspace_final_topology\<close>)

lemma continuous_on_final_topology_iff:
  "continuous_map (final_topology X Y f) Z g \<longleftrightarrow> (\<forall>i. continuous_map (Y i) Z (g o f i))"
  if "\<And>i. f i \<in> topspace (Y i) \<rightarrow> X" "g \<in> X \<rightarrow> topspace Z"
  using that
  by (auto intro!: continuous_on_final_topologyI1[OF _ that]
      intro: continuous_map_compose[OF continuous_on_final_topologyI2[OF that(1)]])

subsection \<open>Quotient topology\<close>

definition map_topology :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a topology \<Rightarrow> 'b topology" where
  "map_topology p X = final_topology (p ` topspace X) (\<lambda>_. X) (\<lambda>(_::unit). p)"

lemma openin_map_topology:
  "openin (map_topology p X) = (\<lambda>U. U \<subseteq> p ` topspace X \<and> openin X (p -` U \<inter> topspace X))"
  by (auto simp: map_topology_def openin_final_topology)

lemma topspace_map_topology[simp]: "topspace (map_topology f T) = f ` topspace T"
  unfolding map_topology_def
  by (subst topspace_final_topology) auto

lemma continuous_on_map_topology:
  "continuous_map T (map_topology f T) f"
  unfolding continuous_map_alt openin_map_topology
  by auto

lemma continuous_map_composeD:
  "continuous_map T X (g \<circ> f) \<Longrightarrow> g \<in> f ` topspace T \<rightarrow> topspace X"
  by (auto simp: continuous_map_def)

lemma continuous_on_map_topology2:
  "continuous_map T X (g \<circ> f) \<longleftrightarrow> continuous_map (map_topology f T) X g"
  unfolding map_topology_def
  apply safe
  subgoal
    apply (rule continuous_on_final_topologyI1)
    subgoal by assumption
    subgoal by force
    subgoal by (rule continuous_map_composeD)
    done
  subgoal
    apply (erule continuous_map_compose[rotated])
    apply (rule continuous_on_final_topologyI2)
    by force
  done

lemma map_sub_finer_than_commute:
  "map_topology f (subtopology T (f -` X)) finer_than subtopology (map_topology f T) X"
  by (auto simp: finer_than_def continuous_map_def openin_subtopology openin_map_topology
      topspace_subtopology)

lemma sub_map_finer_than_commute:
  "subtopology (map_topology f T) X finer_than map_topology f (subtopology T (f -` X))"
  if "openin T (f -` X)"\<comment> \<open>this is more or less the condition from
    \<^url>\<open>https://math.stackexchange.com/questions/705840/quotient-topology-vs-subspace-topology\<close>\<close>
  unfolding finer_than_def continuous_map_alt
proof (rule conjI, clarsimp)
  fix U
  assume "openin (map_topology f (subtopology T (f -` X))) U"
  then obtain W where W: "U \<subseteq> f ` (topspace T \<inter> f -` X)" "openin T W" "f -` U \<inter> (topspace T \<inter> f -` X) = W \<inter> f -` X"
    by (auto simp: topspace_subtopology openin_subtopology openin_map_topology)
  have "(f -` f ` W \<inter> f -` X) \<inter> topspace T = W \<inter> topspace T \<inter> f -` X"
    apply auto
    by (metis Int_iff W(3) vimage_eq)
  also have "openin T \<dots>"
    by (auto intro!: W that)
  finally show "openin (subtopology (map_topology f T) X) (U \<inter> (f ` topspace T \<inter> X))"
    using W
    unfolding topspace_subtopology topspace_map_topology openin_subtopology openin_map_topology
    by (intro exI[where x="(f ` W \<inter> X)"]) auto
qed auto

lemma subtopology_map_topology:
  "subtopology (map_topology f T) X = map_topology f (subtopology T (f -` X))"
  if "openin T (f -` X)"
  apply (rule antisym_finer_than)
  using sub_map_finer_than_commute[OF that] map_sub_finer_than_commute[of f T X]
  by auto

lemma quotient_map_map_topology:
  "quotient_map X (map_topology f X) f"
  by (auto simp: quotient_map_def openin_map_topology ac_simps)
    (simp_all add: vimage_def Int_def)

lemma topological_space_quotient: "class.topological_space (openin (map_topology f euclidean))"
  if "surj f"
  apply standard
    apply (auto simp: )
  using that
  by (auto simp: openin_map_topology)

lemma t2_space_quotient: "class.t2_space (open::'b set \<Rightarrow> bool)"
  if open_def: "open = (openin (map_topology (p::'a::t2_space\<Rightarrow>'b::topological_space) euclidean))"
    "surj p" and open_p: "\<And>X. open X \<Longrightarrow> open (p ` X)" and "closed {(x, y). p x = p y}" (is "closed ?R")
  apply (rule class.t2_space.intro)
  subgoal by (unfold open_def, rule topological_space_quotient; fact)
proof standard
  fix a b::'b
  obtain x y where a_def: "a = p x" and b_def: "b = p y" using \<open>surj p\<close> by fastforce
  assume "a \<noteq> b"
  with \<open>closed ?R\<close> have "open (-?R)" "(x, y) \<in> -?R" by (auto simp add: a_def b_def)
  from open_prod_elim[OF this]
  obtain N\<^sub>x N\<^sub>y where "open N\<^sub>x" "open N\<^sub>y" "(x, y) \<in> N\<^sub>x \<times> N\<^sub>y" "N\<^sub>x \<times> N\<^sub>y \<subseteq> -?R" .
  then have "p ` N\<^sub>x \<inter> p ` N\<^sub>y = {}" by auto
  moreover
  from \<open>open N\<^sub>x\<close> \<open>open N\<^sub>y\<close> have "open (p ` N\<^sub>x)" "open (p ` N\<^sub>y)"
    using open_p by blast+
  moreover have "a \<in> p ` N\<^sub>x" "b \<in> p ` N\<^sub>y" using \<open>(x, y) \<in> _ \<times> _\<close> by (auto simp: a_def b_def)
  ultimately show "\<exists>U V. open U \<and> open V \<and> a \<in> U \<and> b \<in> V \<and> U \<inter> V = {}" by blast
qed

lemma second_countable_topology_quotient: "class.second_countable_topology (open::'b set \<Rightarrow> bool)"
  if open_def: "open = (openin (map_topology (p::'a::second_countable_topology\<Rightarrow>'b::topological_space) euclidean))"
    "surj p" and open_p: "\<And>X. open X \<Longrightarrow> open (p ` X)"
  apply (rule class.second_countable_topology.intro)
  subgoal by (unfold open_def, rule topological_space_quotient; fact)
proof standard
  have euclidean_def: "euclidean = map_topology p euclidean"
    by (simp add: openin_inverse open_def)
  have continuous_on: "continuous_on UNIV p"
    using continuous_map_iff_continuous2 continuous_on_map_topology euclidean_def by fastforce
  from ex_countable_basis[where 'a='a] obtain A::"'a set set" where "countable A" "topological_basis A"
    by auto
  define B where "B = (\<lambda>X. p ` X) ` A"
  have "countable (B::'b set set)"
    by (auto simp: B_def intro!: \<open>countable A\<close>)
  moreover have "topological_basis B"
  proof (rule topological_basisI)
    fix B' assume "B' \<in> B" then show "open B'" using \<open>topological_basis A\<close>
      by (auto simp: B_def topological_basis_open intro!: open_p)
  next
    fix x::'b and O' assume "open O'" "x \<in> O'"
    have "open (p -` O')"
      using \<open>open O'\<close>
      by (rule open_vimage) (auto simp: continuous_on)
    obtain y where y: "y \<in> p -` {x}"
      using \<open>x \<in> O'\<close>
      by auto (metis UNIV_I open_def(2) rangeE)
    then have "y \<in> p -` O'" using \<open>x \<in> O'\<close> by auto
    from topological_basisE[OF \<open>topological_basis A\<close> \<open>open (p -` O')\<close> this]
    obtain C where "C \<in> A" "y \<in> C" "C \<subseteq> p -` O'" .
    let ?B' = "p ` C"
    have "?B' \<in> B"
      using \<open>C \<in> A\<close> by (auto simp: B_def)
    moreover
    have "x \<in> ?B'" using y \<open>y \<in> C\<close> \<open>x \<in> O'\<close>
      by auto
    moreover
    have "?B' \<subseteq> O'"
      using \<open>C \<subseteq> _\<close> by auto
    ultimately show "\<exists>B'\<in>B. x \<in> B' \<and> B' \<subseteq> O'" by metis
  qed
  ultimately show "\<exists>B::'b set set. countable B \<and> open = generate_topology B"
    by (auto simp: topological_basis_imp_subbasis)
qed

subsection \<open>Closure\<close>

lemma closure_Union: "closure (\<Union>X) = (\<Union>x\<in>X. closure x)" if "finite X"
  using that
  by (induction X) auto

subsection \<open>Compactness\<close>

lemma compact_if_closed_subset_of_compact:
  "compact S" if "closed S" "compact T" "S \<subseteq> T"
proof (rule compactI)
  fix UU assume UU: "\<forall>t\<in>UU. open t" "S \<subseteq> \<Union>UU"
  have "T \<subseteq> \<Union>(insert (- S) (UU))" "\<And>B. B \<in> insert (- S) UU \<Longrightarrow> open B"
    using UU \<open>S \<subseteq> T\<close>
    by (auto simp: open_Compl \<open>closed S\<close>)
  from compactE[OF \<open>compact T\<close> this]
  obtain \<T>' where \<T>: "\<T>' \<subseteq> insert (- S) UU" "finite \<T>'" "T \<subseteq> \<Union>\<T>'"
    by metis
  show "\<exists>C'\<subseteq>UU. finite C' \<and> S \<subseteq> \<Union>C'"
    apply (rule exI[where x="\<T>' - {-S}"])
    using \<T> UU
    apply auto
  proof -
    fix x assume "x \<in> S"
    with \<T> \<open>S \<subseteq> T\<close> obtain U where "x \<in> U" "U \<in> \<T>'" using \<T>
      by auto
    then show "\<exists>X\<in>\<T>' - {- S}. x \<in> X"
      using \<T> UU \<open>x \<in> S\<close>
      apply -
      apply (rule bexI[where x=U])
      by auto
  qed
qed

subsection \<open>Locally finite\<close>

definition "locally_finite_on X I U \<longleftrightarrow> (\<forall>p\<in>X. \<exists>N. p\<in>N \<and> open N \<and> finite {i\<in>I. U i \<inter> N \<noteq> {}})"

lemmas locally_finite_onI = locally_finite_on_def[THEN iffD2, rule_format]

lemma locally_finite_onE:
  assumes "locally_finite_on X I U"
  assumes "p \<in> X"
  obtains N where "p \<in> N" "open N" "finite {i\<in>I. U i \<inter> N \<noteq> {}}"
  using assms
  by (auto simp: locally_finite_on_def)

lemma locally_finite_onD:
  assumes "locally_finite_on X I U"
  assumes "p \<in> X"
  shows "finite {i\<in>I. p \<in> U i}"
  apply (rule locally_finite_onE[OF assms])
  apply (rule finite_subset)
  by auto

lemma locally_finite_on_open_coverI: "locally_finite_on X I U"
  if fin: "\<And>j. j \<in> I \<Longrightarrow> finite {i\<in>I. U i \<inter> U j \<noteq> {}}"
    and open_cover: "X \<subseteq> (\<Union>i\<in>I. U i)" "\<And>i. i \<in> I \<Longrightarrow> open (U i)"
proof (rule locally_finite_onI)
  fix p assume "p \<in> X"
  then obtain i where i: "i \<in> I" "p \<in> U i" "open (U i)"
    using open_cover
    by blast
  show "\<exists>N. p \<in> N \<and> open N \<and> finite {i \<in> I. U i \<inter> N \<noteq> {}}"
    by (intro exI[where x="U i"] conjI i fin)
qed

lemma locally_finite_compactD:
  "finite {i\<in>I. U i \<inter> V \<noteq> {}}"
  if lf: "locally_finite_on X I U"
    and compact: "compact V"
    and subset: "V \<subseteq> X"
proof -
  have "\<exists>N. \<forall>p \<in> X. p \<in> N p \<and> open (N p) \<and> finite {i\<in>I. U i \<inter> N p \<noteq> {}}"
    by (rule bchoice) (auto elim!: locally_finite_onE[OF lf, rule_format])
  then obtain N where N: "\<And>p. p \<in> X \<Longrightarrow> p \<in> N p"
    "\<And>p. p \<in> X \<Longrightarrow> open (N p)"
    "\<And>p. p \<in> X \<Longrightarrow> finite {i\<in>I. U i \<inter> N p \<noteq> {}}"
    by blast
  have "V \<subseteq> (\<Union>p\<in>X. N p)" "\<And>B. B \<in> N ` X \<Longrightarrow> open B"
    using N subset by force+
  from compactE[OF compact this]
  obtain C where C: "C \<subseteq> X" "finite C" "V \<subseteq> \<Union>(N ` C)"
    by (metis finite_subset_image)
  then have "{i\<in>I. U i \<inter> V \<noteq> {}} \<subseteq> {i\<in>I. U i \<inter> \<Union>(N ` C) \<noteq> {}}"
    by force
  also have "\<dots> \<subseteq> (\<Union>c\<in>C. {i\<in>I. U i \<inter> N c \<noteq> {}})"
    by force
  also have "finite \<dots>"
    apply (rule finite_Union)
    using C by (auto intro!: C N)
  finally (finite_subset) show ?thesis .
qed

lemma closure_Int_open_eq_empty: "open S \<Longrightarrow> (closure T \<inter> S) = {} \<longleftrightarrow> T \<inter> S = {}"
  by (auto simp: open_Int_closure_eq_empty ac_simps)

lemma locally_finite_on_subset:
  assumes "locally_finite_on X J U"
  assumes "\<And>i. i \<in> I \<Longrightarrow> V i \<subseteq> U i" "I \<subseteq> J"
  shows "locally_finite_on X I V"
proof (rule locally_finite_onI)
  fix p assume "p \<in> X"
  from locally_finite_onE[OF assms(1) this]
  obtain N where "p \<in> N" "open N" "finite {i \<in> J. U i \<inter> N \<noteq> {}}" .
  then show "\<exists>N. p \<in> N \<and> open N \<and> finite {i \<in> I. V i \<inter> N \<noteq> {}}"
    apply (intro exI[where x=N])
    using assms
    by (auto elim!: finite_subset[rotated])
qed

lemma locally_finite_on_closure:
  "locally_finite_on X I (\<lambda>x. closure (U x))"
  if "locally_finite_on X I U"
proof (rule locally_finite_onI)
  fix p assume "p \<in> X"
  from locally_finite_onE[OF that this] obtain N
    where "p \<in> N" "open N" "finite {i \<in> I. U i \<inter> N \<noteq> {}}" .
  then show "\<exists>N. p \<in> N \<and> open N \<and> finite {i \<in> I. closure (U i) \<inter> N \<noteq> {}}"
    by (auto intro!: exI[where x=N] simp: closure_Int_open_eq_empty)
qed

lemma locally_finite_on_closedin_Union_closure:
  "closedin (top_of_set X) (\<Union>i\<in>I. closure (U i))"
  if "locally_finite_on X I U" "\<And>i. i \<in> I \<Longrightarrow> closure (U i) \<subseteq> X"
  unfolding closedin_def
  apply safe
  subgoal using that(2) by auto
  subgoal
    apply (subst openin_subopen)
  proof clarsimp
    fix x
    assume x: "x \<in> X" "\<forall>i\<in>I. x \<notin> closure (U i)"
    from locally_finite_onE[OF that(1) \<open>x \<in> X\<close>]
    obtain N where N: "x \<in> N" "open N" "finite {i \<in> I. U i \<inter> N \<noteq> {}}" (is "finite ?I").
    define N' where "N' = N - (\<Union>i \<in> ?I. closure (U i))"
    have "open N'"
      by (auto simp: N'_def intro!: N)
    then have "openin (top_of_set X) (X \<inter> N')"
      by (rule openin_open_Int)
    moreover
    have "x \<in> X \<inter> N'" using x
      by (auto simp: N'_def N)
    moreover
    have "X \<inter> N' \<subseteq> X - (\<Union>i\<in>I. closure (U i))"
      using x that(2)
      apply (auto simp: N'_def)
      by (meson N(2) closure_iff_nhds_not_empty dual_order.refl)
    ultimately show "\<exists>T. openin (top_of_set X) T \<and> x \<in> T \<and> T \<subseteq> X - (\<Union>i\<in>I. closure (U i))"
      by auto
  qed
  done

lemma closure_subtopology_minimal:
  "S \<subseteq> T \<Longrightarrow> closedin (top_of_set X) T \<Longrightarrow> closure S \<inter> X \<subseteq> T"
  apply (auto simp: closedin_closed)
  using closure_minimal by blast

lemma locally_finite_on_closure_Union:
  "(\<Union>i\<in>I. closure (U i)) = closure (\<Union>i\<in>I. (U i)) \<inter> X"
  if "locally_finite_on X I U" "\<And>i. i \<in> I \<Longrightarrow> closure (U i) \<subseteq> X"
proof (rule antisym)
  show "(\<Union>i\<in>I. closure (U i)) \<subseteq> closure (\<Union>i\<in>I. U i) \<inter> X"
    using that
    apply auto
    by (metis (no_types, lifting) SUP_le_iff closed_closure closure_minimal closure_subset subsetCE)
  show "closure (\<Union>i\<in>I. U i) \<inter> X \<subseteq> (\<Union>i\<in>I. closure (U i))"
    apply (rule closure_subtopology_minimal)
    apply auto
    using that
    by (auto intro!: locally_finite_on_closedin_Union_closure)
qed

subsection \<open>Refinement of cover\<close>

definition refines :: "'a set set \<Rightarrow> 'a set set \<Rightarrow> bool" (infix "refines" 50)
  where "A refines B \<longleftrightarrow> (\<forall>s\<in>A. (\<exists>t. t \<in> B \<and> s \<subseteq> t))"

lemma refines_subset: "x refines y" if "z refines y" "x \<subseteq> z"
  using that by (auto simp: refines_def)

subsection \<open>Functions as vector space\<close>

instantiation "fun" :: (type, scaleR) scaleR begin

definition scaleR_fun :: "real \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where
  "scaleR_fun r f = (\<lambda>x. r *\<^sub>R f x)"

lemma scaleR_fun_beta[simp]: "(r *\<^sub>R f) x = r *\<^sub>R f x"
  by (simp add: scaleR_fun_def)

instance ..

end

instance "fun" :: (type, real_vector) real_vector
  by standard (auto simp: scaleR_fun_def algebra_simps)

subsection \<open>Additional lemmas\<close>

lemmas [simp del] = vimage_Un vimage_Int

lemma finite_Collect_imageI: "finite {U \<in> f ` X. P U}" if "finite {x\<in>X. P (f x)}"
proof -
  have "{d \<in> f ` X. P d} \<subseteq> f ` {c \<in> X. P (f c)}"
    by blast
  then show ?thesis
    using finite_surj that by blast
qed

lemma plus_compose: "(x + y) \<circ> f = (x \<circ> f) + (y \<circ> f)"
  by auto

lemma mult_compose: "(x * y) \<circ> f = (x \<circ> f) * (y \<circ> f)"
  by auto

lemma scaleR_compose: "(c *\<^sub>R x) \<circ> f = c *\<^sub>R (x \<circ> f)"
  by (auto simp:)

lemma image_scaleR_ball:
  fixes a :: "'a::real_normed_vector"
  shows "c \<noteq> 0 \<Longrightarrow> (*\<^sub>R) c ` ball a r = ball (c *\<^sub>R a) (abs c *\<^sub>R r)"
proof (auto simp: mem_ball dist_norm, goal_cases)
  case (1 b)
  have "norm (c *\<^sub>R a - c *\<^sub>R b)  = abs c * norm (a - b)"
    by (auto simp: norm_scaleR[symmetric] algebra_simps simp del: norm_scaleR)
  also have "\<dots> < abs c * r"
    apply (rule mult_strict_left_mono)
    using 1 by auto
  finally show ?case .
next
  case (2 x)
  have "norm (a - x /\<^sub>R c) < r"
  proof -
    have "norm (a - x /\<^sub>R c) = abs c *\<^sub>R norm (a - x /\<^sub>R c) /\<^sub>R abs c"
      using 2 by auto
    also have "abs c *\<^sub>R norm (a - x /\<^sub>R c) = norm (c *\<^sub>R a - x)"
      using 2
      by (auto simp: norm_scaleR[symmetric] algebra_simps simp del: norm_scaleR)
    also have "\<dots> < \<bar>c\<bar> * r"
      by fact
    also have "\<bar>c\<bar> * r /\<^sub>R \<bar>c\<bar> = r" using 2 by auto
    finally show ?thesis using 2 by auto
  qed
  then have xdc: "x /\<^sub>R c \<in> ball a r"
    by (auto simp: mem_ball dist_norm)
  show ?case
    apply (rule image_eqI[OF _ xdc])
    using 2 by simp
qed

subsection \<open>Continuity\<close>

lemma continuous_within_topologicalE:
  assumes "continuous (at x within s) f"
    "open B" "f x \<in> B"
  obtains A where "open A" "x \<in> A" "\<And>y. y \<in> s \<Longrightarrow> y \<in> A \<Longrightarrow> f y \<in> B"
  using assms continuous_within_topological by metis

lemma continuous_within_topologicalE':
  assumes "continuous (at x) f"
    "open B" "f x \<in> B"
  obtains A where "open A" "x \<in> A" "f ` A \<subseteq> B"
  using assms continuous_within_topologicalE[OF assms]
  by (metis UNIV_I image_subsetI)

lemma continuous_on_inverse: "continuous_on S f \<Longrightarrow> 0 \<notin> f ` S \<Longrightarrow> continuous_on S (\<lambda>x. inverse (f x))"
  for f::"_\<Rightarrow>_::real_normed_div_algebra"
  by (auto simp: continuous_on_def intro!: tendsto_inverse)

subsection \<open>@{term "(has_derivative)"}\<close>

lemma has_derivative_plus_fun[derivative_intros]:
  "(x + y has_derivative x' + y') (at a within A)"
  if [derivative_intros]:
    "(x has_derivative x') (at a within A)"
    "(y has_derivative y') (at a within A)"
  by (auto simp: plus_fun_def intro!: derivative_eq_intros)

lemma has_derivative_scaleR_fun[derivative_intros]:
  "(x *\<^sub>R y has_derivative x *\<^sub>R y') (at a within A)"
  if [derivative_intros]:
    "(y has_derivative y') (at a within A)"
  by (auto simp: scaleR_fun_def intro!: derivative_eq_intros)

lemma has_derivative_times_fun[derivative_intros]:
  "(x * y has_derivative (\<lambda>h. x a * y' h + x' h * y a)) (at a within A)"
  if [derivative_intros]:
    "(x has_derivative x') (at a within A)"
    "(y has_derivative y') (at a within A)"
  for x y::"_\<Rightarrow>'a::real_normed_algebra"
  by (auto simp: times_fun_def intro!: derivative_eq_intros)

lemma real_sqrt_has_derivative_generic:
  "x \<noteq> 0 \<Longrightarrow> (sqrt has_derivative (*) ((if x > 0 then 1 else -1) * inverse (sqrt x) / 2)) (at x within S)"
  apply (rule has_derivative_at_withinI)
  using DERIV_real_sqrt_generic[of x "(if x > 0 then 1 else -1) * inverse (sqrt x) / 2"] at_within_open[of x "UNIV - {0}"]
  by (auto simp: has_field_derivative_def open_delete ac_simps split: if_splits)

lemma sqrt_has_derivative:
  "((\<lambda>x. sqrt (f x)) has_derivative (\<lambda>xa. (if 0 < f x then 1 else - 1) / (2 * sqrt (f x)) * f' xa)) (at x within S)"
  if "(f has_derivative f') (at x within S)" "f x \<noteq> 0"
  by (rule has_derivative_eq_rhs[OF has_derivative_compose[OF that(1) real_sqrt_has_derivative_generic, OF that(2)]])
    (auto simp: divide_simps)

lemmas has_derivative_norm_compose[derivative_intros] = has_derivative_compose[OF _ has_derivative_norm]

subsection \<open>Differentiable\<close>

lemmas differentiable_on_empty[simp]

lemma differentiable_transform_eventually: "f differentiable (at x within X)"
  if "g differentiable (at x within X)"
    "f x = g x"
    "\<forall>\<^sub>F x in (at x within X). f x = g x"
  using that
  apply (auto simp: differentiable_def)
  subgoal for D
    apply (rule exI[where x=D])
    apply (auto simp: has_derivative_within)
    by (simp add: eventually_mono Lim_transform_eventually)
  done

lemma differentiable_within_eqI: "f differentiable at x within X"
  if "g differentiable at x within X" "\<And>x. x \<in> X \<Longrightarrow> f x = g x"
    "x \<in> X" "open X"
  apply (rule differentiable_transform_eventually)
    apply (rule that)
   apply (auto simp: that)
proof -
  have "\<forall>\<^sub>F x in at x within X. x \<in> X"
    using \<open>open X\<close>
    using eventually_at_topological by blast
  then show " \<forall>\<^sub>F x in at x within X. f x = g x"
    by eventually_elim (auto simp: that)
qed

lemma differentiable_eqI: "f differentiable at x"
  if "g differentiable at x" "\<And>x. x \<in> X \<Longrightarrow> f x = g x" "x \<in> X" "open X"
  using that
  unfolding at_within_open[OF that(3,4), symmetric]
  by (rule differentiable_within_eqI)

lemma differentiable_on_eqI:
  "f differentiable_on S"
  if "g differentiable_on S" "\<And>x. x \<in> S \<Longrightarrow> f x = g x" "open S"
  using that differentiable_eqI[of g _ S f]
  by (auto simp: differentiable_on_eq_differentiable_at)

lemma differentiable_on_comp: "(f o g) differentiable_on S"
  if "g differentiable_on S" "f differentiable_on (g ` S)"
  using that
  by (auto simp: differentiable_on_def intro: differentiable_chain_within)

lemma differentiable_on_comp2: "(f o g) differentiable_on S"
  if  "f differentiable_on T" "g differentiable_on S" "g ` S \<subseteq> T"
  apply (rule differentiable_on_comp)
   apply (rule that)
  apply (rule differentiable_on_subset)
  apply (rule that)
  apply (rule that)
  done

lemmas differentiable_on_compose2 = differentiable_on_comp2[unfolded o_def]

lemma differentiable_on_openD: "f differentiable at x"
  if "f differentiable_on X" "open X" "x \<in> X"
  using differentiable_on_eq_differentiable_at that by blast

lemma differentiable_on_add_fun[intro, simp]:
  "x differentiable_on UNIV \<Longrightarrow> y differentiable_on UNIV \<Longrightarrow> x + y differentiable_on UNIV"
  by (auto simp: plus_fun_def)

lemma differentiable_on_mult_fun[intro, simp]:
  "x differentiable_on UNIV \<Longrightarrow> y differentiable_on UNIV \<Longrightarrow> x * y differentiable_on UNIV"
  for x y::"_\<Rightarrow>'a::real_normed_algebra"
  by (auto simp: times_fun_def)

lemma differentiable_on_scaleR_fun[intro, simp]:
  "y differentiable_on UNIV \<Longrightarrow> x *\<^sub>R y differentiable_on UNIV"
  by (auto simp: scaleR_fun_def)

lemma sqrt_differentiable:
  "(\<lambda>x. sqrt (f x)) differentiable (at x within S)"
  if "f differentiable (at x within S)" "f x \<noteq> 0"
  using that
  using sqrt_has_derivative[of f _ x S]
  by (auto simp: differentiable_def)

lemma sqrt_differentiable_on: "(\<lambda>x. sqrt (f x)) differentiable_on S"
  if "f differentiable_on S" "0 \<notin> f ` S"
  using sqrt_differentiable[of f _ S] that
  by (force simp: differentiable_on_def)

lemma differentiable_on_inverse: "f differentiable_on S \<Longrightarrow> 0 \<notin> f ` S \<Longrightarrow> (\<lambda>x. inverse (f x)) differentiable_on S"
  for f::"_\<Rightarrow>_::real_normed_field"
  by (auto simp: differentiable_on_def intro!: differentiable_inverse)

lemma differentiable_on_openI:
  "f differentiable_on S"
  if "open S" "\<And>x. x \<in> S \<Longrightarrow> \<exists>f'. (f has_derivative f') (at x)"
  using that
  by (auto simp: differentiable_on_def at_within_open[where S=S] differentiable_def)

lemmas differentiable_norm_compose_at = differentiable_compose[OF differentiable_norm_at]

lemma differentiable_on_Pair:
  "f differentiable_on S \<Longrightarrow> g differentiable_on S \<Longrightarrow> (\<lambda>x. (f x, g x)) differentiable_on S"
  unfolding differentiable_on_def
  using differentiable_Pair[of f _ S g] by auto

lemma differentiable_at_fst:
  "(\<lambda>x. fst (f x)) differentiable at x within X" if "f differentiable at x within X"
  using that
  by (auto simp: differentiable_def dest!: has_derivative_fst)

lemma differentiable_at_snd:
  "(\<lambda>x. snd (f x)) differentiable at x within X" if "f differentiable at x within X"
  using that
  by (auto simp: differentiable_def dest!: has_derivative_snd)

lemmas frechet_derivative_worksI = frechet_derivative_works[THEN iffD1]

lemma sin_differentiable_at: "(\<lambda>x. sin (f x::real)) differentiable at x within X"
  if "f differentiable at x within X"
  using differentiable_def has_derivative_sin that by blast

lemma cos_differentiable_at: "(\<lambda>x. cos (f x::real)) differentiable at x within X"
  if "f differentiable at x within X"
  using differentiable_def has_derivative_cos that by blast

subsection \<open>Frechet derivative\<close>

lemmas frechet_derivative_transform_within_open_ext =
  fun_cong[OF frechet_derivative_transform_within_open]

lemmas frechet_derivative_at' = frechet_derivative_at[symmetric]

lemma frechet_derivative_plus_fun:
  "x differentiable at a \<Longrightarrow> y differentiable at a \<Longrightarrow>
  frechet_derivative (x + y) (at a) =
    frechet_derivative x (at a) + frechet_derivative y (at a)"
  by (rule frechet_derivative_at')
    (auto intro!: derivative_eq_intros frechet_derivative_worksI)

lemmas frechet_derivative_plus = frechet_derivative_plus_fun[unfolded plus_fun_def]

lemma frechet_derivative_zero_fun: "frechet_derivative 0 (at a) = 0"
  by (auto simp: frechet_derivative_const zero_fun_def)

lemma frechet_derivative_sin:
  "frechet_derivative (\<lambda>x. sin (f x)) (at x) = (\<lambda>xa. frechet_derivative f (at x) xa * cos (f x))"
  if "f differentiable (at x)"
  for f::"_\<Rightarrow>real"
  by (rule frechet_derivative_at'[OF has_derivative_sin[OF frechet_derivative_worksI[OF that]]])

lemma frechet_derivative_cos:
  "frechet_derivative (\<lambda>x. cos (f x)) (at x) = (\<lambda>xa. frechet_derivative f (at x) xa * - sin (f x))"
  if "f differentiable (at x)"
  for f::"_\<Rightarrow>real"
  by (rule frechet_derivative_at'[OF has_derivative_cos[OF frechet_derivative_worksI[OF that]]])

lemma differentiable_sum_fun:
  "(\<And>i. i \<in> I \<Longrightarrow> (f i differentiable at a)) \<Longrightarrow> sum f I differentiable at a"
  by (induction I rule: infinite_finite_induct) (auto simp: zero_fun_def plus_fun_def)

lemma frechet_derivative_sum_fun:
  "(\<And>i. i \<in> I \<Longrightarrow> (f i differentiable at a)) \<Longrightarrow>
  frechet_derivative (\<Sum>i\<in>I. f i) (at a) = (\<Sum>i\<in>I. frechet_derivative (f i) (at a))"
  by (induction I rule: infinite_finite_induct)
    (auto simp: frechet_derivative_zero_fun frechet_derivative_plus_fun differentiable_sum_fun)

lemma sum_fun_def: "(\<Sum>i\<in>I. f i) = (\<lambda>x. \<Sum>i\<in>I. f i x)"
  by (induction I rule: infinite_finite_induct) auto

lemmas frechet_derivative_sum = frechet_derivative_sum_fun[unfolded sum_fun_def]

lemma frechet_derivative_times_fun:
  "f differentiable at a \<Longrightarrow> g differentiable at a \<Longrightarrow>
  frechet_derivative (f * g) (at a) =
  (\<lambda>x. f a * frechet_derivative g (at a) x + frechet_derivative f (at a) x * g a)"
  for f g::"_\<Rightarrow>'a::real_normed_algebra"
  by (rule frechet_derivative_at') (auto intro!: derivative_eq_intros frechet_derivative_worksI)

lemmas frechet_derivative_times = frechet_derivative_times_fun[unfolded times_fun_def]

lemma frechet_derivative_scaleR_fun:
  "y differentiable at a \<Longrightarrow>
  frechet_derivative (x *\<^sub>R y) (at a) =
    x *\<^sub>R frechet_derivative y (at a)"
  by (rule frechet_derivative_at')
    (auto intro!: derivative_eq_intros frechet_derivative_worksI)

lemmas frechet_derivative_scaleR = frechet_derivative_scaleR_fun[unfolded scaleR_fun_def]

lemma frechet_derivative_compose:
  "frechet_derivative (f o g) (at x) = frechet_derivative (f) (at (g x)) o frechet_derivative g (at x)"
  if "g differentiable at x" "f differentiable at (g x)"
  by (meson diff_chain_at frechet_derivative_at' frechet_derivative_works that)

lemma frechet_derivative_compose_eucl:
  "frechet_derivative (f o g) (at x) =
    (\<lambda>v. \<Sum>i\<in>Basis. ((frechet_derivative g (at x) v) \<bullet> i) *\<^sub>R frechet_derivative f (at (g x)) i)"
  (is "?l = ?r")
  if "g differentiable at x" "f differentiable at (g x)"
proof (rule ext)
  fix v
  interpret g: linear "frechet_derivative g (at x)"
    using that(1)
    by (rule linear_frechet_derivative)
  interpret f: linear "frechet_derivative f (at (g x))"
    using that(2)
    by (rule linear_frechet_derivative)
  have "frechet_derivative (f o g) (at x) v =
    frechet_derivative f (at (g x)) (\<Sum>i\<in>Basis. (frechet_derivative g (at x) v \<bullet> i) *\<^sub>R i)"
    unfolding frechet_derivative_compose[OF that] o_apply
    by (simp add: euclidean_representation)
  also have "\<dots> = ?r v"
    by (auto simp: g.sum g.scaleR f.sum f.scaleR)
  finally show "?l v = ?r v" .
qed

lemma frechet_derivative_works_on_open:
  "f differentiable_on X \<Longrightarrow> open X \<Longrightarrow> x \<in> X \<Longrightarrow>
    (f has_derivative frechet_derivative f (at x)) (at x)"
  and frechet_derivative_works_on:
  "f differentiable_on X \<Longrightarrow> x \<in> X \<Longrightarrow>
    (f has_derivative frechet_derivative f (at x within X)) (at x within X)"
  by (auto simp: differentiable_onD differentiable_on_openD frechet_derivative_worksI)

lemma frechet_derivative_inverse: "frechet_derivative (\<lambda>x. inverse (f x)) (at x) =
    (\<lambda>h. - 1 / (f x)\<^sup>2 * frechet_derivative f (at x) h)"
  if "f differentiable at x" "f x \<noteq> 0" for f::"_\<Rightarrow>_::real_normed_field"
  apply (rule frechet_derivative_at')
  using that
  by (auto intro!: derivative_eq_intros frechet_derivative_worksI
      simp: divide_simps algebra_simps power2_eq_square)

lemma frechet_derivative_sqrt: "frechet_derivative (\<lambda>x. sqrt (f x)) (at x) =
  (\<lambda>v. (if f x > 0 then 1 else -1) / (2 * sqrt (f x)) * frechet_derivative f (at x) v)"
  if "f differentiable at x" "f x \<noteq> 0"
  apply (rule frechet_derivative_at')
  apply (rule sqrt_has_derivative[THEN has_derivative_eq_rhs])
  by (auto intro!: frechet_derivative_worksI that simp: divide_simps)

lemma frechet_derivative_norm: "frechet_derivative (\<lambda>x. norm (f x)) (at x) =
    (\<lambda>v. frechet_derivative f (at x) v \<bullet> sgn (f x))"
  if "f differentiable at x" "f x \<noteq> 0"
  for f::"_\<Rightarrow>_::real_inner"
  apply (rule frechet_derivative_at')
  by (auto intro!: derivative_eq_intros frechet_derivative_worksI that simp: divide_simps)

lemma (in bounded_linear) frechet_derivative:
  "frechet_derivative f (at x) = f"
  apply (rule frechet_derivative_at')
  apply (rule has_derivative_eq_rhs)
   apply (rule has_derivative)
  by (auto intro!: derivative_eq_intros)

bundle no_matrix_mult begin
no_notation matrix_matrix_mult (infixl "**" 70)
end

lemma (in bounded_bilinear) frechet_derivative:
  includes no_matrix_mult
  shows
    "x differentiable at a \<Longrightarrow> y differentiable at a \<Longrightarrow>
      frechet_derivative (\<lambda>a. x a ** y a) (at a) =
        (\<lambda>h. x a ** frechet_derivative y (at a) h + frechet_derivative x (at a) h ** y a)"
  by (rule frechet_derivative_at') (auto intro!: FDERIV frechet_derivative_worksI)

lemma frechet_derivative_divide: "frechet_derivative (\<lambda>x. f x / g x) (at x) =
    (\<lambda>h. frechet_derivative f (at x) h / (g x) -frechet_derivative g (at x) h * f x / (g x)\<^sup>2)"
  if "f differentiable at x" "g differentiable at x" "g x \<noteq> 0" for f::"_\<Rightarrow>_::real_normed_field"
  using that
  by (auto simp: divide_inverse_commute bounded_bilinear.frechet_derivative[OF bounded_bilinear_mult]
      frechet_derivative_inverse)

lemma frechet_derivative_pair:
  "frechet_derivative (\<lambda>x. (f x, g x)) (at x) = (\<lambda>v. (frechet_derivative f (at x) v, frechet_derivative g (at x) v))"
  if "f differentiable (at x)" "g differentiable (at x)"
  apply (rule frechet_derivative_at')
  apply (rule derivative_eq_intros)
    apply (rule frechet_derivative_worksI) apply fact
    apply (rule frechet_derivative_worksI) apply fact
  ..

lemma frechet_derivative_fst:
  "frechet_derivative (\<lambda>x. fst (f x)) (at x) = (\<lambda>xa. fst (frechet_derivative f (at x) xa))"
  if "(f differentiable at x)"
  for f::"_\<Rightarrow>(_::real_normed_vector \<times> _::real_normed_vector)"
  apply (rule frechet_derivative_at')
  using that
  by (auto intro!: derivative_eq_intros frechet_derivative_worksI)

lemma frechet_derivative_snd:
  "frechet_derivative (\<lambda>x. snd (f x)) (at x) = (\<lambda>xa. snd (frechet_derivative f (at x) xa))"
  if "(f differentiable at x)"
  for f::"_\<Rightarrow>(_::real_normed_vector \<times> _::real_normed_vector)"
  apply (rule frechet_derivative_at')
  using that
  by (auto intro!: derivative_eq_intros frechet_derivative_worksI)

lemma frechet_derivative_eq_vector_derivative_1:
  assumes "f differentiable at t"
  shows "frechet_derivative f (at t) 1 = vector_derivative f (at t)"
  apply (subst frechet_derivative_eq_vector_derivative)
   apply (rule assms) by auto

subsection \<open>Linear algebra\<close>

lemma (in vector_space) dim_pos_finite_dimensional_vector_spaceE:
  assumes "dim (UNIV::'b set) > 0"
  obtains basis where "finite_dimensional_vector_space scale basis"
proof -
  from assms obtain b where b: "local.span b = local.span UNIV" "local.independent b"
    by (auto simp: dim_def split: if_splits)
  then have "dim UNIV = card b"
    by (rule dim_eq_card)
  with assms have "finite b" by (auto simp: card_ge_0_finite)
  then have "finite_dimensional_vector_space scale b"
    by unfold_locales (auto simp: b)
  then show ?thesis ..
qed

context vector_space_on begin

context includes lifting_syntax assumes "\<exists>(Rep::'s \<Rightarrow> 'b) (Abs::'b \<Rightarrow> 's). type_definition Rep Abs S" begin

interpretation local_typedef_vector_space_on S scale "TYPE('s)" by unfold_locales fact

lemmas_with [var_simplified explicit_ab_group_add,
    unoverload_type 'd,
    OF type.ab_group_add_axioms type_vector_space_on_with,
    folded dim_S_def,
    untransferred,
    var_simplified implicit_ab_group_add]:
    lt_dim_pos_finite_dimensional_vector_spaceE = vector_space.dim_pos_finite_dimensional_vector_spaceE

end

lemmas_with [cancel_type_definition,
    OF S_ne,
    folded subset_iff',
    simplified pred_fun_def, folded finite_dimensional_vector_space_on_with,
    simplified\<comment>\<open>too much?\<close>]:
    dim_pos_finite_dimensional_vector_spaceE = lt_dim_pos_finite_dimensional_vector_spaceE

end

subsection \<open>Extensional function space\<close>

text \<open>f is zero outside A. We use such functions to canonically represent
  functions whose domain is A\<close>
definition extensional0 :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b::zero) \<Rightarrow> bool"
  where "extensional0 A f = (\<forall>x. x \<notin> A \<longrightarrow> f x = 0)"

lemma extensional0_0[intro, simp]: "extensional0 X 0"
  by (auto simp: extensional0_def)

lemma extensional0_UNIV[intro, simp]: "extensional0 UNIV f"
  by (auto simp: extensional0_def)

lemma ext_extensional0:
  "f = g" if "extensional0 S f" "extensional0 S g" "\<And>x. x \<in> S \<Longrightarrow> f x = g x"
  using that by (force simp: extensional0_def fun_eq_iff)

lemma extensional0_add[intro, simp]:
  "extensional0 S f \<Longrightarrow> extensional0 S g \<Longrightarrow> extensional0 S (f + g::_\<Rightarrow>'a::comm_monoid_add)"
  by (auto simp: extensional0_def)

lemma extensinoal0_mult[intro, simp]:
  "extensional0 S x \<Longrightarrow> extensional0 S y \<Longrightarrow> extensional0 S (x * y)"
  for x y::"_\<Rightarrow>'a::mult_zero"
  by (auto simp: extensional0_def)

lemma extensional0_scaleR[intro, simp]: "extensional0 S f \<Longrightarrow> extensional0 S (c *\<^sub>R f::_\<Rightarrow>'a::real_vector)"
  by (auto simp: extensional0_def)

lemma extensional0_outside: "x \<notin> S \<Longrightarrow> extensional0 S f \<Longrightarrow> f x = 0"
  by (auto simp: extensional0_def)

lemma subspace_extensional0: "subspace (Collect (extensional0 X))"
  by (auto simp: subspace_def)

text \<open>Send the function f to its canonical representative as a function with domain A\<close>
definition restrict0 :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b::zero) \<Rightarrow> 'a \<Rightarrow> 'b"
  where "restrict0 A f x = (if x \<in> A then f x else 0)"

lemma restrict0_UNIV[simp]: "restrict0 UNIV = (\<lambda>x. x)"
  by (intro ext) (auto simp: restrict0_def)

lemma extensional0_restrict0[intro, simp]: "extensional0 A (restrict0 A f)"
  by (auto simp: extensional0_def restrict0_def)

lemma restrict0_times: "restrict0 A (x * y) = restrict0 A x * restrict0 A y"
  for x::"'a\<Rightarrow>'b::mult_zero"
  by (auto simp: restrict0_def[abs_def])

lemma restrict0_apply_in[simp]: "x \<in> A \<Longrightarrow> restrict0 A f x = f x"
  by (auto simp: restrict0_def)

lemma restrict0_apply_out[simp]: "x \<notin> A \<Longrightarrow> restrict0 A f x = 0"
  by (auto simp: restrict0_def)

lemma restrict0_scaleR: "restrict0 A (c *\<^sub>R f::_\<Rightarrow>'a::real_vector) = c *\<^sub>R restrict0 A f"
  by (auto simp: restrict0_def[abs_def])

lemma restrict0_add: "restrict0 A (f + g::_\<Rightarrow>'a::real_vector) = restrict0 A f + restrict0 A g"
  by (auto simp: restrict0_def[abs_def])

lemma restrict0_restrict0: "restrict0 X (restrict0 Y f) = restrict0 (X \<inter> Y) f"
  by (auto simp: restrict0_def)

end


(*  Title:       AWN.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Terms of the Algebra for Wireless Networks"

theory AWN
imports Lib
begin

subsection "Sequential Processes"

type_synonym ip = nat
type_synonym data = nat

text \<open>
  Most of AWN is independent of the type of messages, but the closed layer turns
  newpkt actions into the arrival of newpkt messages. We use a type class to maintain
  some abstraction (and independence from the definition of particular protocols).
\<close>

class msg =
  fixes newpkt :: "data \<times> ip \<Rightarrow> 'a"
    and eq_newpkt :: "'a \<Rightarrow> bool"
  assumes eq_newpkt_eq [simp]: "eq_newpkt (newpkt (d, i))"

text \<open>
  Sequential process terms abstract over the types of data states (@{typ 's}),
  messages (@{typ 'm}), process names (@{typ 'p}),and labels (@{typ 'l}).
\<close>

datatype (dead 's, dead 'm, dead 'p, 'l) seqp =
    GUARD "'l" "'s \<Rightarrow> 's set" "('s, 'm, 'p, 'l) seqp"
  | ASSIGN "'l" "'s \<Rightarrow> 's" "('s, 'm, 'p, 'l) seqp"
  | CHOICE "('s, 'm, 'p, 'l) seqp" "('s, 'm, 'p, 'l) seqp"
  | UCAST "'l" "'s \<Rightarrow> ip" "'s \<Rightarrow> 'm" "('s, 'm, 'p, 'l) seqp" "('s, 'm, 'p, 'l) seqp"
  | BCAST "'l" "'s \<Rightarrow> 'm" "('s, 'm, 'p, 'l) seqp"
  | GCAST "'l" "'s \<Rightarrow> ip set" "'s \<Rightarrow> 'm" "('s, 'm, 'p, 'l) seqp"
  | SEND "'l" "'s \<Rightarrow> 'm" "('s, 'm, 'p, 'l) seqp"
  | DELIVER "'l" "'s \<Rightarrow> data" "('s, 'm, 'p, 'l) seqp"
  | RECEIVE "'l" "'m \<Rightarrow> 's \<Rightarrow> 's" "('s, 'm, 'p, 'l) seqp"
  | CALL 'p
  for map: labelmap

syntax
  "_guard"    :: "['a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(\<open>unbreakable\<close>\<langle>_\<rangle>)//_" [0, 60] 60)
  "_lguard"   :: "['a, 'a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("{_}(\<open>unbreakable\<close>\<langle>_\<rangle>)//_" [0, 0, 60] 60)
  "_ifguard"  :: "[pttrn, bool,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(\<open>unbreakable\<close>\<langle>_. _\<rangle>)//_" [0, 0, 60] 60)

  "_bassign"  :: "[pttrn, 'a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(\<open>unbreakable\<close>\<lbrakk>_. _\<rbrakk>)//_" [0, 0, 60] 60)
  "_lbassign" :: "['a, pttrn, 'a, ('s, 'm, 'p, 'a) seqp] \<Rightarrow> ('s, 'm, 'p, 'a) seqp"
                 ("{_}(\<open>unbreakable\<close>\<lbrakk>_. _\<rbrakk>)//_" [0, 0, 0, 60] 60)

  "_assign"  :: "['a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("((\<open>unbreakable\<close>\<lbrakk>_\<rbrakk>))//_" [0, 60] 60)
  "_lassign" :: "['a, 'a, ('s, 'm, 'p, 'a) seqp] \<Rightarrow> ('s, 'm, 'p, 'a) seqp"
                 ("({_}(\<open>unbreakable\<close>\<lbrakk>_\<rbrakk>))//_" [0, 0, 60] 60)

  "_unicast"  :: "['a, 'a,  ('s, 'm, 'p, unit) seqp,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(3unicast'((1(3_),/ (3_))') .//(_)/ (2\<triangleright> _))" [0, 0, 60, 60] 60)
  "_lunicast" :: "['a, 'a, 'a, ('s, 'm, 'p, 'a) seqp, ('s, 'm, 'p, 'a) seqp] \<Rightarrow> ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}unicast'((1(3_),/ (3_))') .//(_)/ (2\<triangleright> _))" [0, 0, 0, 60, 60] 60)

  "_bcast"    :: "['a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(3broadcast'((1(_))') .)//_" [0, 60] 60)
  "_lbcast"   :: "['a, 'a, ('s, 'm, 'p, 'a) seqp] \<Rightarrow> ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}broadcast'((1(_))') .)//_" [0, 0, 60] 60)

  "_gcast"    :: "['a, 'a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(3groupcast'((1(_),/ (_))') .)//_" [0, 0, 60] 60)
  "_lgcast"   :: "['a, 'a, 'a, ('s, 'm, 'p, 'a) seqp] \<Rightarrow> ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}groupcast'((1(_),/ (_))') .)//_" [0, 0, 0, 60] 60)

  "_send"     :: "['a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(3send'((_)') .)//_" [0, 60] 60)
  "_lsend"    :: "['a, 'a, ('s, 'm, 'p, 'a) seqp] \<Rightarrow> ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}send'((_)') .)//_" [0, 0, 60] 60)

  "_deliver"  :: "['a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(3deliver'((_)') .)//_" [0, 60] 60)
  "_ldeliver" :: "['a, 'a, ('s, 'm, 'p, 'a) seqp] \<Rightarrow> ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}deliver'((_)') .)//_" [0, 0, 60] 60)

  "_receive"  :: "['a,  ('s, 'm, 'p, unit) seqp] \<Rightarrow>  ('s, 'm, 'p, unit) seqp"
                 ("(3receive'((_)') .)//_" [0, 60] 60)
  "_lreceive" :: "['a, 'a, ('s, 'm, 'p, 'a) seqp] \<Rightarrow> ('s, 'm, 'p, 'a) seqp"
                 ("(3{_}receive'((_)') .)//_" [0, 0, 60] 60)

translations
  "_guard f p"     \<rightleftharpoons> "CONST GUARD () f p"
  "_lguard l f p"  \<rightleftharpoons> "CONST GUARD l f p"
  "_ifguard \<xi> e p" \<rightharpoonup> "CONST GUARD () (\<lambda>\<xi>. if e then {\<xi>} else {}) p"

  "_assign f p"    \<rightleftharpoons> "CONST ASSIGN () f p"
  "_lassign l f p" \<rightleftharpoons> "CONST ASSIGN l f p"

  "_bassign \<xi> e p"    \<rightleftharpoons> "CONST ASSIGN () (\<lambda>\<xi>. e) p"
  "_lbassign l \<xi> e p" \<rightleftharpoons> "CONST ASSIGN l (\<lambda>\<xi>. e) p"

  "_unicast fip fmsg p q"    \<rightleftharpoons> "CONST UCAST () fip fmsg p q"
  "_lunicast l fip fmsg p q" \<rightleftharpoons> "CONST UCAST l fip fmsg p q"

  "_bcast fmsg p"    \<rightleftharpoons> "CONST BCAST () fmsg p"
  "_lbcast l fmsg p" \<rightleftharpoons> "CONST BCAST l fmsg p"

  "_gcast fipset fmsg p"    \<rightleftharpoons> "CONST GCAST () fipset fmsg p"
  "_lgcast l fipset fmsg p" \<rightleftharpoons> "CONST GCAST l fipset fmsg p"

  "_send fmsg p"    \<rightleftharpoons> "CONST SEND () fmsg p"
  "_lsend l fmsg p" \<rightleftharpoons> "CONST SEND l fmsg p"

  "_deliver fdata p"    \<rightleftharpoons> "CONST DELIVER () fdata p"
  "_ldeliver l fdata p" \<rightleftharpoons> "CONST DELIVER l fdata p"

  "_receive fmsg p"    \<rightleftharpoons> "CONST RECEIVE () fmsg p"
  "_lreceive l fmsg p" \<rightleftharpoons> "CONST RECEIVE l fmsg p"

notation "CHOICE" ("((_)//\<oplus>//(_))" [56, 55] 55)
     and "CALL"   ("(3call'((3_)'))" [0] 60)

definition not_call :: "('s, 'm, 'p, 'l) seqp \<Rightarrow> bool"
where "not_call p \<equiv> \<forall>pn. p \<noteq> call(pn)"

lemma not_call_simps [simp]:
  "\<And>l fg p.         not_call ({l}\<langle>fg\<rangle> p)"
  "\<And>l fa p.         not_call ({l}\<lbrakk>fa\<rbrakk> p)"
  "\<And>p1 p2.          not_call (p1 \<oplus> p2)"
  "\<And>l fip fmsg p q. not_call ({l}unicast(fip, fmsg).p \<triangleright> q)"
  "\<And>l fmsg p.       not_call ({l}broadcast(fmsg).p)"
  "\<And>l fips fmsg p.  not_call ({l}groupcast(fips, fmsg).p)"
  "\<And>l fmsg p.       not_call ({l}send(fmsg).p)"
  "\<And>l fdata p.      not_call ({l}deliver(fdata).p)"
  "\<And>l fmsg p.       not_call ({l}receive(fmsg).p)"
  "\<And>l pn.         \<not>(not_call (call(pn)))"
  unfolding not_call_def by auto

definition not_choice :: "('s, 'm, 'p, 'l) seqp \<Rightarrow> bool"
where "not_choice p \<equiv> \<forall>p1 p2. p \<noteq> p1 \<oplus> p2"

lemma not_choice_simps [simp]:
  "\<And>l fg p.         not_choice ({l}\<langle>fg\<rangle> p)"
  "\<And>l fa p.         not_choice ({l}\<lbrakk>fa\<rbrakk> p)"
  "\<And>p1 p2.        \<not>(not_choice (p1 \<oplus> p2))"
  "\<And>l fip fmsg p q. not_choice ({l}unicast(fip, fmsg).p \<triangleright> q)"
  "\<And>l fmsg p.       not_choice ({l}broadcast(fmsg).p)"
  "\<And>l fips fmsg p.  not_choice ({l}groupcast(fips, fmsg).p)"
  "\<And>l fmsg p.       not_choice ({l}send(fmsg).p)"
  "\<And>l fdata p.      not_choice ({l}deliver(fdata).p)"
  "\<And>l fmsg p.       not_choice ({l}receive(fmsg).p)"
  "\<And>l pn.           not_choice (call(pn))"
  unfolding not_choice_def by auto

lemma seqp_congs:
  "\<And>l fg p. {l}\<langle>fg\<rangle> p = {l}\<langle>fg\<rangle> p"
  "\<And>l fa p. {l}\<lbrakk>fa\<rbrakk> p = {l}\<lbrakk>fa\<rbrakk> p"
  "\<And>p1 p2. p1 \<oplus> p2 = p1 \<oplus> p2"
  "\<And>l fip fmsg p q. {l}unicast(fip, fmsg).p \<triangleright> q = {l}unicast(fip, fmsg).p \<triangleright> q"
  "\<And>l fmsg p. {l}broadcast(fmsg).p = {l}broadcast(fmsg).p"
  "\<And>l fips fmsg p. {l}groupcast(fips, fmsg).p = {l}groupcast(fips, fmsg).p"
  "\<And>l fmsg p. {l}send(fmsg).p = {l}send(fmsg).p"
  "\<And>l fdata p. {l}deliver(fdata).p = {l}deliver(fdata).p"
  "\<And>l fmsg p. {l}receive(fmsg).p = {l}receive(fmsg).p"
  "\<And>l pn. call(pn) = call(pn)"
  by auto

text \<open>Remove data expressions from process terms.\<close>

fun seqp_skeleton :: "('s, 'm, 'p, 'l) seqp \<Rightarrow> (unit, unit, 'p, 'l) seqp"
where
    "seqp_skeleton ({l}\<langle>_\<rangle> p)                 = {l}\<langle>\<lambda>_. {()}\<rangle> (seqp_skeleton p)"
  | "seqp_skeleton ({l}\<lbrakk>_\<rbrakk> p)                 = {l}\<lbrakk>\<lambda>_. ()\<rbrakk> (seqp_skeleton p)"
  | "seqp_skeleton (p \<oplus> q)                   = (seqp_skeleton p) \<oplus> (seqp_skeleton q)"
  | "seqp_skeleton ({l}unicast(_, _). p \<triangleright> q) = {l}unicast(\<lambda>_. 0, \<lambda>_. ()). (seqp_skeleton p) \<triangleright> (seqp_skeleton q)"
  | "seqp_skeleton ({l}broadcast(_). p)      = {l}broadcast(\<lambda>_. ()). (seqp_skeleton p)"
  | "seqp_skeleton ({l}groupcast(_, _). p)   = {l}groupcast(\<lambda>_. {}, \<lambda>_. ()). (seqp_skeleton p)"
  | "seqp_skeleton ({l}send(_). p)           = {l}send(\<lambda>_. ()). (seqp_skeleton p)"
  | "seqp_skeleton ({l}deliver(_). p)        = {l}deliver(\<lambda>_. 0). (seqp_skeleton p)"
  | "seqp_skeleton ({l}receive(_). p)        = {l}receive(\<lambda>_ _. ()). (seqp_skeleton p)"
  | "seqp_skeleton (call(pn))                = call(pn)"

text \<open>Calculate the subterms of a term.\<close>

fun subterms :: "('s, 'm, 'p, 'l) seqp \<Rightarrow> ('s, 'm, 'p, 'l) seqp set"
where
    "subterms ({l}\<langle>fg\<rangle> p) = {{l}\<langle>fg\<rangle> p} \<union> subterms p"
  | "subterms ({l}\<lbrakk>fa\<rbrakk> p) = {{l}\<lbrakk>fa\<rbrakk> p} \<union> subterms p"
  | "subterms (p1 \<oplus> p2) = {p1 \<oplus> p2} \<union> subterms p1 \<union> subterms p2"
  | "subterms ({l}unicast(fip, fmsg). p \<triangleright> q) =
       {{l}unicast(fip, fmsg). p \<triangleright> q} \<union> subterms p \<union> subterms q"
  | "subterms ({l}broadcast(fmsg). p) = {{l}broadcast(fmsg). p} \<union> subterms p"
  | "subterms ({l}groupcast(fips, fmsg). p) = {{l}groupcast(fips, fmsg). p} \<union> subterms p"
  | "subterms ({l}send(fmsg). p) = {{l}send(fmsg).p} \<union> subterms p"
  | "subterms ({l}deliver(fdata). p) = {{l}deliver(fdata).p} \<union> subterms p"
  | "subterms ({l}receive(fmsg). p) = {{l}receive(fmsg).p} \<union> subterms p"
  | "subterms (call(pn)) = {call(pn)}"

lemma subterms_refl [simp]: "p \<in> subterms p"
  by (cases p) simp_all

lemma subterms_trans [elim]:
  assumes "q \<in> subterms p"
      and "r \<in> subterms q"
    shows "r \<in> subterms p"
  using assms by (induction p) auto

lemma root_in_subterms [simp]:
   "\<And>\<Gamma> pn. \<exists>pn'. \<Gamma> pn \<in> subterms (\<Gamma> pn')"
  by (rule_tac x=pn in exI) simp

lemma deriv_in_subterms [elim, dest]:
  "\<And>l f p q. {l}\<langle>f\<rangle> q \<in> subterms p \<Longrightarrow> q \<in> subterms p"
  "\<And>l fa p q. {l}\<lbrakk>fa\<rbrakk> q \<in> subterms p \<Longrightarrow> q \<in> subterms p"
  "\<And>p1 p2 p. p1 \<oplus> p2 \<in> subterms p \<Longrightarrow> p1 \<in> subterms p"
  "\<And>p1 p2 p. p1 \<oplus> p2 \<in> subterms p \<Longrightarrow> p2 \<in> subterms p"
  "\<And>l fip fmsg p q r. {l}unicast(fip, fmsg). q \<triangleright> r \<in> subterms p \<Longrightarrow> q \<in> subterms p"
  "\<And>l fip fmsg p q r. {l}unicast(fip, fmsg). q \<triangleright> r \<in> subterms p \<Longrightarrow> r \<in> subterms p"
  "\<And>l fmsg p q. {l}broadcast(fmsg). q \<in> subterms p \<Longrightarrow> q \<in> subterms p"
  "\<And>l fips fmsg p q. {l}groupcast(fips, fmsg). q \<in> subterms p \<Longrightarrow> q \<in> subterms p"
  "\<And>l fmsg p q. {l}send(fmsg). q \<in> subterms p \<Longrightarrow> q \<in> subterms p"
  "\<And>l fdata p q. {l}deliver(fdata). q \<in> subterms p \<Longrightarrow> q \<in> subterms p"
  "\<And>l fmsg p q. {l}receive(fmsg). q \<in> subterms p \<Longrightarrow> q \<in> subterms p"
  by auto

subsection "Actions"

text \<open>
  There are two sorts of \<open>\<tau>\<close> actions in AWN: one at the level of individual processes
  (within nodes), and one at the network level (outside nodes). We define a class so that
  we can ignore this distinction whenever it is not critical.
\<close>

class tau =
  fixes tau :: "'a" ("\<tau>")

subsubsection "Sequential Actions (and related predicates)"

datatype 'm seq_action =
    broadcast 'm
  | groupcast "ip set" 'm
  | unicast ip 'm
  | notunicast ip           ("\<not>unicast _" [1000] 60)
  | send 'm
  | deliver data
  | receive 'm
  | seq_tau                 ("\<tau>\<^sub>s")

instantiation "seq_action" :: (type) tau
begin
definition step_seq_tau [simp]: "\<tau> \<equiv> \<tau>\<^sub>s"
instance ..
end

definition recvmsg :: "('m \<Rightarrow> bool) \<Rightarrow> 'm seq_action \<Rightarrow> bool"
where "recvmsg P a \<equiv> case a of receive m \<Rightarrow> P m
                             | _ \<Rightarrow> True"

lemma recvmsg_simps[simp]:
  "\<And>m.     recvmsg P (broadcast m)     = True"
  "\<And>ips m. recvmsg P (groupcast ips m) = True"
  "\<And>ip m.  recvmsg P (unicast ip m)    = True"
  "\<And>ip.    recvmsg P (notunicast ip)   = True"
  "\<And>m.     recvmsg P (send m)          = True"
  "\<And>d.     recvmsg P (deliver d)       = True"
  "\<And>m.     recvmsg P (receive m)       = P m"
  "        recvmsg P \<tau>\<^sub>s                 = True"
  unfolding recvmsg_def by simp_all

lemma recvmsgTT [simp]: "recvmsg TT a"
  by (cases a) simp_all

lemma recvmsgE [elim]:
  assumes "recvmsg (R \<sigma>) a"
      and "\<And>m. R \<sigma> m \<Longrightarrow> R \<sigma>' m"
    shows "recvmsg (R \<sigma>') a"
  using assms(1) by (cases a) (auto elim!: assms(2))

definition anycast :: "('m \<Rightarrow> bool) \<Rightarrow> 'm seq_action \<Rightarrow> bool"
where "anycast P a \<equiv> case a of broadcast m \<Rightarrow> P m
                             | groupcast _ m \<Rightarrow> P m
                             | unicast _ m \<Rightarrow> P m
                             | _ \<Rightarrow> True"

lemma anycast_simps [simp]:
  "\<And>m.     anycast P (broadcast m)     = P m"
  "\<And>ips m. anycast P (groupcast ips m) = P m"
  "\<And>ip m.  anycast P (unicast ip m)    = P m"
  "\<And>ip.    anycast P (notunicast ip)   = True"
  "\<And>m.     anycast P (send m)          = True"
  "\<And>d.     anycast P (deliver d)       = True"
  "\<And>m.     anycast P (receive m)       = True"
  "        anycast P \<tau>\<^sub>s                 = True"
  unfolding anycast_def by simp_all

definition orecvmsg :: "((ip \<Rightarrow> 's) \<Rightarrow> 'm \<Rightarrow> bool) \<Rightarrow> (ip \<Rightarrow> 's) \<Rightarrow> 'm seq_action \<Rightarrow> bool"
where "orecvmsg P \<sigma> a \<equiv> (case a of receive m \<Rightarrow> P \<sigma> m
                                         | _ \<Rightarrow> True)"

lemma orecvmsg_simps [simp]:
  "\<And>m.     orecvmsg P \<sigma> (broadcast m)     = True"
  "\<And>ips m. orecvmsg P \<sigma> (groupcast ips m) = True"
  "\<And>ip m.  orecvmsg P \<sigma> (unicast ip m)    = True"
  "\<And>ip.    orecvmsg P \<sigma> (notunicast ip)   = True"
  "\<And>m.     orecvmsg P \<sigma> (send m)          = True"
  "\<And>d.     orecvmsg P \<sigma> (deliver d)       = True"
  "\<And>m.     orecvmsg P \<sigma> (receive m)       = P \<sigma> m"
  "         orecvmsg P \<sigma> \<tau>\<^sub>s                = True"
  unfolding orecvmsg_def by simp_all

lemma orecvmsgEI [elim]:
  "\<lbrakk> orecvmsg P \<sigma> a; \<And>\<sigma> a. P \<sigma> a \<Longrightarrow> Q \<sigma> a \<rbrakk> \<Longrightarrow> orecvmsg Q \<sigma> a"
  by (cases a) simp_all

lemma orecvmsg_stateless_recvmsg [elim]:
  "orecvmsg (\<lambda>_. P) \<sigma> a \<Longrightarrow> recvmsg P a"
  by (cases a) simp_all

lemma orecvmsg_recv_weaken [elim]:
  "\<lbrakk> orecvmsg P \<sigma> a; \<And>\<sigma> a. P \<sigma> a \<Longrightarrow> Q a \<rbrakk> \<Longrightarrow> recvmsg Q a"
  by (cases a) simp_all

lemma orecvmsg_recvmsg [elim]:
  "orecvmsg P \<sigma> a \<Longrightarrow> recvmsg (P \<sigma>) a"
  by (cases a) simp_all

definition sendmsg :: "('m \<Rightarrow> bool) \<Rightarrow> 'm seq_action \<Rightarrow> bool"
where "sendmsg P a \<equiv> case a of send m \<Rightarrow> P m | _ \<Rightarrow> True"

lemma sendmsg_simps [simp]:
  "\<And>m.     sendmsg P (broadcast m)     = True"
  "\<And>ips m. sendmsg P (groupcast ips m) = True"
  "\<And>ip m.  sendmsg P (unicast ip m)    = True"
  "\<And>ip.    sendmsg P (notunicast ip)   = True"
  "\<And>m.     sendmsg P (send m)          = P m"
  "\<And>d.     sendmsg P (deliver d)       = True"
  "\<And>m.     sendmsg P (receive m)       = True"
  "        sendmsg P \<tau>\<^sub>s                 = True"
  unfolding sendmsg_def by simp_all

type_synonym ('s, 'm, 'p, 'l) seqp_env = "'p \<Rightarrow> ('s, 'm, 'p, 'l) seqp"

subsubsection "Node Actions (and related predicates)"

datatype 'm node_action =
    node_cast "ip set" 'm             ("_:*cast'(_')"       [200, 200] 200)
  | node_deliver ip data              ("_:deliver'(_')"     [200, 200] 200)
  | node_arrive "ip set" "ip set" 'm  ("_\<not>_:arrive'(_')"    [200, 200, 200] 200)
  | node_connect ip ip                ("connect'(_, _')"    [200, 200] 200)
  | node_disconnect ip ip             ("disconnect'(_, _')" [200, 200] 200)
  | node_newpkt ip data ip            ("_:newpkt'(_, _')"   [200, 200, 200] 200)
  | node_tau                          ("\<tau>\<^sub>n")

instantiation "node_action" :: (type) tau
begin
definition step_node_tau [simp]: "\<tau> \<equiv> \<tau>\<^sub>n"
instance ..
end

definition arrivemsg :: "ip \<Rightarrow> ('m \<Rightarrow> bool) \<Rightarrow> 'm node_action \<Rightarrow> bool"
where "arrivemsg i P a \<equiv> case a of node_arrive ii ni m \<Rightarrow> ((ii = {i} \<longrightarrow> P m))
                                  | _ \<Rightarrow> True"

lemma arrivemsg_simps[simp]:
  "\<And>R m.       arrivemsg i P (R:*cast(m))         = True"
  "\<And>d m.       arrivemsg i P (d:deliver(m))       = True"
  "\<And>i ii ni m. arrivemsg i P (ii\<not>ni:arrive(m))    = (ii = {i} \<longrightarrow> P m)"
  "\<And>i1 i2.     arrivemsg i P (connect(i1, i2))    = True"
  "\<And>i1 i2.     arrivemsg i P (disconnect(i1, i2)) = True"
  "\<And>i i' d di. arrivemsg i P (i':newpkt(d, di))   = True"
  "             arrivemsg i P \<tau>\<^sub>n                   = True"
  unfolding arrivemsg_def by simp_all

lemma arrivemsgTT [simp]: "arrivemsg i TT = TT"
  by (rule ext) (clarsimp simp: arrivemsg_def split: node_action.split)

definition oarrivemsg :: "((ip \<Rightarrow> 's) \<Rightarrow> 'm \<Rightarrow> bool) \<Rightarrow> (ip \<Rightarrow> 's) \<Rightarrow> 'm node_action \<Rightarrow> bool"
where "oarrivemsg P \<sigma> a \<equiv> case a of node_arrive ii ni m \<Rightarrow> P \<sigma> m | _ \<Rightarrow> True"

lemma oarrivemsg_simps[simp]:
  "\<And>R m.       oarrivemsg P \<sigma> (R:*cast(m))         = True"
  "\<And>d m.       oarrivemsg P \<sigma> (d:deliver(m))       = True"
  "\<And>i ii ni m. oarrivemsg P \<sigma> (ii\<not>ni:arrive(m))    = P \<sigma> m"
  "\<And>i1 i2.     oarrivemsg P \<sigma> (connect(i1, i2))    = True"
  "\<And>i1 i2.     oarrivemsg P \<sigma> (disconnect(i1, i2)) = True"
  "\<And>i i' d di. oarrivemsg P \<sigma> (i':newpkt(d, di))   = True"
  "             oarrivemsg P \<sigma> \<tau>\<^sub>n                   = True"
  unfolding oarrivemsg_def by simp_all

lemma oarrivemsg_True [simp, intro]: "oarrivemsg (\<lambda>_ _. True) \<sigma> a"
  by (cases a) auto

definition castmsg :: "('m \<Rightarrow> bool) \<Rightarrow> 'm node_action \<Rightarrow> bool"
where "castmsg P a \<equiv> case a of _:*cast(m) \<Rightarrow> P m
                              | _ \<Rightarrow> True"

lemma castmsg_simps[simp]:
  "\<And>R m.       castmsg P (R:*cast(m))         = P m"
  "\<And>d m.       castmsg P (d:deliver(m))       = True"
  "\<And>i ii ni m. castmsg P (ii\<not>ni:arrive(m))    = True"
  "\<And>i1 i2.     castmsg P (connect(i1, i2))    = True"
  "\<And>i1 i2.     castmsg P (disconnect(i1, i2)) = True"
  "\<And>i i' d di. castmsg P (i':newpkt(d, di))   = True"
  "             castmsg P \<tau>\<^sub>n                   = True"
  unfolding castmsg_def by simp_all

subsection "Networks"

datatype net_tree =
    Node ip "ip set"          ("\<langle>_; _\<rangle>")
  | Subnet net_tree net_tree  (infixl "\<parallel>" 90)

declare net_tree.induct [[induct del]]
lemmas net_tree_induct [induct type: net_tree] = net_tree.induct [rename_abs i R p1 p2]

datatype 's net_state =
    NodeS ip 's "ip set"
  | SubnetS "'s net_state" "'s net_state"

fun net_ips :: "'s net_state \<Rightarrow> ip set"
where
    "net_ips (NodeS i s R) = {i}"
  | "net_ips (SubnetS n1 n2) = net_ips n1 \<union> net_ips n2"

fun net_tree_ips :: "net_tree \<Rightarrow> ip set"
where
    "net_tree_ips (p1 \<parallel> p2) = net_tree_ips p1 \<union> net_tree_ips p2"
  | "net_tree_ips (\<langle>i; R\<rangle>) = {i}"

lemma net_tree_ips_commute:
  "net_tree_ips (p1 \<parallel> p2) = net_tree_ips (p2 \<parallel> p1)"
  by simp (rule Un_commute)

fun wf_net_tree :: "net_tree \<Rightarrow> bool"
where
   "wf_net_tree (p1 \<parallel> p2) = (net_tree_ips p1 \<inter> net_tree_ips p2 = {}
                             \<and> wf_net_tree p1 \<and> wf_net_tree p2)"
 | "wf_net_tree (\<langle>i; R\<rangle>) = True"

lemma wf_net_tree_children [elim]:
  assumes "wf_net_tree (p1 \<parallel> p2)"
  obtains "wf_net_tree p1"
      and "wf_net_tree p2"
  using assms by simp

fun netmap :: "'s net_state \<Rightarrow> ip \<Rightarrow> 's option"
where
    "netmap (NodeS i p R\<^sub>i) = [i \<mapsto> p]"
  | "netmap (SubnetS s t) = netmap s ++ netmap t"

lemma not_in_netmap [simp]:
  assumes "i \<notin> net_ips ns"
    shows "netmap ns i = None"
  using assms by (induction ns) simp_all

lemma netmap_none_not_in_net_ips:
  assumes "netmap ns i = None"
    shows "i\<notin>net_ips ns"
  using assms by (induction ns) auto

lemma net_ips_is_dom_netmap: "net_ips s = dom(netmap s)"
  proof (induction s)
    fix i R\<^sub>i and p :: 's
    show "net_ips (NodeS i p R\<^sub>i) = dom (netmap (NodeS i p R\<^sub>i))"
      by auto
  next
    fix s1 s2 :: "'s net_state"
    assume "net_ips s1 = dom (netmap s1)"
       and "net_ips s2 = dom (netmap s2)"
    thus "net_ips (SubnetS s1 s2) = dom (netmap (SubnetS s1 s2))"
      by auto
  qed

lemma in_netmap [simp]:
  assumes "i \<in> net_ips ns"
    shows "netmap ns i \<noteq> None"
  using assms by (auto simp add: net_ips_is_dom_netmap)

lemma netmap_subnets_same:
  assumes "netmap s1 i = x"
      and "netmap s2 i = x"
    shows "netmap (SubnetS s1 s2) i = x"
  using assms by simp (metis map_add_dom_app_simps(1) map_add_dom_app_simps(3))

lemma netmap_subnets_samef:
  assumes "netmap s1 = f"
      and "netmap s2 = f"
    shows "netmap (SubnetS s1 s2) = f"
  using assms by simp (metis map_add_le_mapI map_le_antisym map_le_map_add map_le_refl)

lemma netmap_add_disjoint [elim]:
  assumes "\<forall>i\<in>net_ips s1 \<union> net_ips s2. the ((netmap s1 ++ netmap s2) i) = \<sigma> i"
      and "net_ips s1 \<inter> net_ips s2 = {}"
    shows "\<forall>i\<in>net_ips s1. the (netmap s1 i) = \<sigma> i"
  proof
    fix i
    assume "i \<in> net_ips s1"
    hence "i \<in> dom(netmap s1)" by (simp add: net_ips_is_dom_netmap)
    moreover with assms(2) have "i \<notin> dom(netmap s2)" by (auto simp add: net_ips_is_dom_netmap)
    ultimately have "the (netmap s1 i) = the ((netmap s1 ++ netmap s2) i)"
      by (simp add: map_add_dom_app_simps)
    with assms(1) and \<open>i\<in>net_ips s1\<close> show "the (netmap s1 i) = \<sigma> i" by simp
  qed

lemma netmap_add_disjoint2 [elim]:
  assumes "\<forall>i\<in>net_ips s1 \<union> net_ips s2. the ((netmap s1 ++ netmap s2) i) = \<sigma> i"
    shows "\<forall>i\<in>net_ips s2. the (netmap s2 i) = \<sigma> i"
  using assms by (simp add: net_ips_is_dom_netmap)
                 (metis Un_iff map_add_dom_app_simps(1))

lemma net_ips_netmap_subnet [elim]:
  assumes "net_ips s1 \<inter> net_ips s2 = {}"
      and "\<forall>i\<in>net_ips (SubnetS s1 s2). the (netmap (SubnetS s1 s2) i) = \<sigma> i"
    shows "\<forall>i\<in>net_ips s1. the (netmap s1 i) = \<sigma> i"
      and "\<forall>i\<in>net_ips s2. the (netmap s2 i) = \<sigma> i"
  proof -
    from assms(2) have "\<forall>i\<in>net_ips s1 \<union> net_ips s2. the ((netmap s1 ++ netmap s2) i) = \<sigma> i" by auto
    with assms(1) show "\<forall>i\<in>net_ips s1. the (netmap s1 i) = \<sigma> i"
      by - (erule(1) netmap_add_disjoint)
  next
    from assms(2) have "\<forall>i\<in>net_ips s1 \<union> net_ips s2. the ((netmap s1 ++ netmap s2) i) = \<sigma> i" by auto
    thus "\<forall>i\<in>net_ips s2. the (netmap s2 i) = \<sigma> i"
      by - (erule netmap_add_disjoint2)
  qed

fun inoclosed :: "'s \<Rightarrow> 'm::msg node_action \<Rightarrow> bool"
where
    "inoclosed _ (node_arrive ii ni m) = eq_newpkt m"
  | "inoclosed _ (node_newpkt i d di)  = False"
  | "inoclosed _ _ = True"

lemma inclosed_simps [simp]:
  "\<And>\<sigma> ii ni. inoclosed \<sigma> (ii\<not>ni:arrive(m))   = eq_newpkt m"
  "\<And>\<sigma> d di.  inoclosed \<sigma> (i:newpkt(d, di))   = False"
  "\<And>\<sigma> R m.   inoclosed \<sigma> (R:*cast(m))        = True"
  "\<And>\<sigma> i d.   inoclosed \<sigma> (i:deliver(d))      = True"
  "\<And>\<sigma> i i'.  inoclosed \<sigma> (connect(i, i'))    = True"
  "\<And>\<sigma> i i'.  inoclosed \<sigma> (disconnect(i, i')) = True"
  "\<And>\<sigma>.       inoclosed \<sigma> (\<tau>)                 = True"
  by auto

definition
  netmask :: "ip set \<Rightarrow> ((ip \<Rightarrow> 's) \<times> 'l) \<Rightarrow> ((ip \<Rightarrow> 's option) \<times> 'l)"
where
  "netmask I s \<equiv> (\<lambda>i. if i\<in>I then Some (fst s i) else None, snd s)"

lemma netmask_def' [simp]:
  "netmask I (\<sigma>, \<zeta>) = (\<lambda>i. if i\<in>I then Some (\<sigma> i) else None, \<zeta>)"
  unfolding netmask_def by auto

fun netgmap :: "('s \<Rightarrow> 'g \<times> 'l) \<Rightarrow> 's net_state \<Rightarrow> (nat \<Rightarrow> 'g option) \<times> 'l net_state"
  where
    "netgmap sr (NodeS i s R) = ([i \<mapsto> fst (sr s)], NodeS i (snd (sr s)) R)"
  | "netgmap sr (SubnetS s\<^sub>1 s\<^sub>2) = (let (\<sigma>\<^sub>1, ss) = netgmap sr s\<^sub>1 in
                                   let (\<sigma>\<^sub>2, tt) = netgmap sr s\<^sub>2 in
                                   (\<sigma>\<^sub>1 ++ \<sigma>\<^sub>2, SubnetS ss tt))"

lemma dom_fst_netgmap [simp, intro]: "dom (fst (netgmap sr n)) = net_ips n"
  proof (induction n)
    fix i s R
    show "dom (fst (netgmap sr (NodeS i s R))) = net_ips (NodeS i s R)"
      by simp
  next
    fix n1 n2
    assume a1: "dom (fst (netgmap sr n1)) = net_ips n1"
       and a2: "dom (fst (netgmap sr n2)) = net_ips n2"
    obtain \<sigma>\<^sub>1 \<zeta>\<^sub>1 \<sigma>\<^sub>2 \<zeta>\<^sub>2 where nm1: "netgmap sr n1 = (\<sigma>\<^sub>1, \<zeta>\<^sub>1)"
                        and nm2: "netgmap sr n2 = (\<sigma>\<^sub>2, \<zeta>\<^sub>2)"
      by (metis surj_pair)
    hence "netgmap sr (SubnetS n1 n2) = (\<sigma>\<^sub>1 ++ \<sigma>\<^sub>2, SubnetS \<zeta>\<^sub>1 \<zeta>\<^sub>2)" by simp
    hence "dom (fst (netgmap sr (SubnetS n1 n2))) = dom (\<sigma>\<^sub>1 ++ \<sigma>\<^sub>2)" by simp
    also from a1 a2 nm1 nm2 have "dom (\<sigma>\<^sub>1 ++ \<sigma>\<^sub>2) = net_ips (SubnetS n1 n2)" by auto
    finally show "dom (fst (netgmap sr (SubnetS n1 n2))) = net_ips (SubnetS n1 n2)" .
  qed

lemma netgmap_pair_dom [elim]:
  obtains \<sigma> \<zeta> where "netgmap sr n = (\<sigma>, \<zeta>)"
                and "dom \<sigma> = net_ips n"
    by (metis dom_fst_netgmap surjective_pairing)

lemma net_ips_netgmap [simp]:
  "net_ips (snd (netgmap sr s)) = net_ips s"
  proof (induction s)
    fix s1 s2
    assume "net_ips (snd (netgmap sr s1)) = net_ips s1"
       and "net_ips (snd (netgmap sr s2)) = net_ips s2"
    thus "net_ips (snd (netgmap sr (SubnetS s1 s2))) = net_ips (SubnetS s1 s2)"
      by (cases "netgmap sr s1", cases "netgmap sr s2") auto
  qed simp

lemma some_the_fst_netgmap:
  assumes "i \<in> net_ips s"
    shows "Some (the (fst (netgmap sr s) i)) = fst (netgmap sr s) i"
  using assms by (metis domIff dom_fst_netgmap option.collapse)

lemma fst_netgmap_none [simp]:
  assumes "i \<notin> net_ips s"
    shows "fst (netgmap sr s) i = None"
  using assms by (metis domIff dom_fst_netgmap)

lemma fst_netgmap_subnet [simp]:
  "fst (case netgmap sr s1 of (\<sigma>\<^sub>1, ss) \<Rightarrow>
        case netgmap sr s2 of (\<sigma>\<^sub>2, tt) \<Rightarrow>
        (\<sigma>\<^sub>1 ++ \<sigma>\<^sub>2, SubnetS ss tt)) = (fst (netgmap sr s1) ++ fst (netgmap sr s2))"
  by (metis (mono_tags) fst_conv netgmap_pair_dom split_conv)

lemma snd_netgmap_subnet [simp]:
  "snd (case netgmap sr s1 of (\<sigma>\<^sub>1, ss) \<Rightarrow>
        case netgmap sr s2 of (\<sigma>\<^sub>2, tt) \<Rightarrow>
        (\<sigma>\<^sub>1 ++ \<sigma>\<^sub>2, SubnetS ss tt)) = (SubnetS (snd (netgmap sr s1)) (snd (netgmap sr s2)))"
  by (metis (lifting, no_types) Pair_inject split_beta' surjective_pairing)

lemma fst_netgmap_not_none [simp]:
  assumes "i \<in> net_ips s"
    shows "fst (netgmap sr s) i \<noteq> None"
  using assms by (induction s) auto

lemma netgmap_netgmap_not_rhs [simp]:
  assumes "i \<notin> net_ips s2"
    shows "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i = (fst (netgmap sr s1)) i"
  proof -
    from assms(1) have "i \<notin> dom (fst (netgmap sr s2))" by simp
    thus ?thesis by (simp add: map_add_dom_app_simps)
  qed

lemma netgmap_netgmap_rhs [simp]:
  assumes "i \<in> net_ips s2"
    shows "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i = (fst (netgmap sr s2)) i"
  using assms by (simp add: map_add_dom_app_simps)

lemma netgmap_netmask_subnets [elim]:
  assumes "netgmap sr s1 = netmask (net_tree_ips n1) (\<sigma>, snd (netgmap sr s1))"
      and "netgmap sr s2 = netmask (net_tree_ips n2) (\<sigma>, snd (netgmap sr s2))"
    shows "fst (netgmap sr (SubnetS s1 s2))
            = fst (netmask (net_tree_ips (n1 \<parallel> n2)) (\<sigma>, snd (netgmap sr (SubnetS s1 s2))))"
  proof (rule ext)
    fix i
    have "i \<in> net_tree_ips n1 \<or> i \<in> net_tree_ips n2 \<or> (i\<notin>net_tree_ips n1 \<union> net_tree_ips n2)"
      by auto
    thus "fst (netgmap sr (SubnetS s1 s2)) i
            = fst (netmask (net_tree_ips (n1 \<parallel> n2)) (\<sigma>, snd (netgmap sr (SubnetS s1 s2)))) i"
    proof (elim disjE)
      assume "i \<in> net_tree_ips n1"
      with \<open>netgmap sr s1 = netmask (net_tree_ips n1) (\<sigma>, snd (netgmap sr s1))\<close>
           \<open>netgmap sr s2 = netmask (net_tree_ips n2) (\<sigma>, snd (netgmap sr s2))\<close>
        show ?thesis
          by (cases "netgmap sr s1", cases "netgmap sr s2", clarsimp)
             (metis (lifting, mono_tags) map_add_Some_iff)
    next
      assume "i \<in> net_tree_ips n2"
      with \<open>netgmap sr s2 = netmask (net_tree_ips n2) (\<sigma>, snd (netgmap sr s2))\<close>
        show ?thesis
          by simp (metis (lifting, mono_tags) fst_conv map_add_find_right)
    next
      assume "i\<notin>net_tree_ips n1 \<union> net_tree_ips n2"
      with \<open>netgmap sr s1 = netmask (net_tree_ips n1) (\<sigma>, snd (netgmap sr s1))\<close>
           \<open>netgmap sr s2 = netmask (net_tree_ips n2) (\<sigma>, snd (netgmap sr s2))\<close>
        show ?thesis
          by simp (metis (lifting, mono_tags) fst_conv)
    qed
  qed

lemma netgmap_netmask_subnets' [elim]:
  assumes "netgmap sr s1 = netmask (net_tree_ips n1) (\<sigma>, snd (netgmap sr s1))"
      and "netgmap sr s2 = netmask (net_tree_ips n2) (\<sigma>, snd (netgmap sr s2))"
      and "s = SubnetS s1 s2"
    shows "netgmap sr s = netmask (net_tree_ips (n1 \<parallel> n2)) (\<sigma>, snd (netgmap sr s))"
  by (simp only: assms(3))
     (rule prod_eqI [OF netgmap_netmask_subnets [OF assms(1-2)]], simp)

lemma netgmap_subnet_split1:
  assumes "netgmap sr (SubnetS s1 s2) = netmask (net_tree_ips (n1 \<parallel> n2)) (\<sigma>, \<zeta>)"
      and "net_tree_ips n1 \<inter> net_tree_ips n2 = {}"
      and "net_ips s1 = net_tree_ips n1"
      and "net_ips s2 = net_tree_ips n2"
    shows "netgmap sr s1 = netmask (net_tree_ips n1) (\<sigma>, snd (netgmap sr s1))"
  proof (rule prod_eqI)
    show "fst (netgmap sr s1) = fst (netmask (net_tree_ips n1) (\<sigma>, snd (netgmap sr s1)))"
    proof (rule ext, simp, intro conjI impI)
      fix i
      assume "i\<in>net_tree_ips n1"
      with \<open>net_tree_ips n1 \<inter> net_tree_ips n2 = {}\<close> have "i\<notin>net_tree_ips n2"
        by auto
      from assms(1) [simplified prod_eq_iff]
        have "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i =
                 (if i \<in> net_tree_ips n1 \<or> i \<in> net_tree_ips n2 then Some (\<sigma> i) else None)"
          by simp
      also from \<open>i\<notin>net_tree_ips n2\<close> and \<open>net_ips s2 = net_tree_ips n2\<close>
        have "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i = fst (netgmap sr s1) i"
          by (metis dom_fst_netgmap map_add_dom_app_simps(3))
      finally show "fst (netgmap sr s1) i = Some (\<sigma> i)"
        using \<open>i\<in>net_tree_ips n1\<close> by simp
    next
      fix i
      assume "i \<notin> net_tree_ips n1"
      with \<open>net_ips s1 = net_tree_ips n1\<close> have "i \<notin> net_ips s1" by simp
      thus "fst (netgmap sr s1) i = None" by simp
    qed
  qed simp

lemma netgmap_subnet_split2:
  assumes "netgmap sr (SubnetS s1 s2) = netmask (net_tree_ips (n1 \<parallel> n2)) (\<sigma>, \<zeta>)"
      and "net_ips s1 = net_tree_ips n1"
      and "net_ips s2 = net_tree_ips n2"
    shows "netgmap sr s2 = netmask (net_tree_ips n2) (\<sigma>, snd (netgmap sr s2))"
  proof (rule prod_eqI)
    show "fst (netgmap sr s2) = fst (netmask (net_tree_ips n2) (\<sigma>, snd (netgmap sr s2)))"
    proof (rule ext, simp, intro conjI impI)
      fix i
      assume "i\<in>net_tree_ips n2"
      from assms(1) [simplified prod_eq_iff]
        have "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i =
                 (if i \<in> net_tree_ips n1 \<or> i \<in> net_tree_ips n2 then Some (\<sigma> i) else None)"
          by simp
      also from \<open>i\<in>net_tree_ips n2\<close> and \<open>net_ips s2 = net_tree_ips n2\<close>
        have "(fst (netgmap sr s1) ++ fst (netgmap sr s2)) i = fst (netgmap sr s2) i"
          by (metis dom_fst_netgmap map_add_dom_app_simps(1))
      finally show "fst (netgmap sr s2) i = Some (\<sigma> i)"
        using \<open>i\<in>net_tree_ips n2\<close> by simp
    next
      fix i
      assume "i \<notin> net_tree_ips n2"
      with \<open>net_ips s2 = net_tree_ips n2\<close> have "i \<notin> net_ips s2" by simp
      thus "fst (netgmap sr s2) i = None" by simp
    qed
  qed simp

lemma netmap_fst_netgmap_rel:
  shows "(\<lambda>i. map_option (fst o sr) (netmap s i)) = fst (netgmap sr s)"
  proof (induction s)
    fix ii s R
    show "(\<lambda>i. map_option (fst \<circ> sr) (netmap (NodeS ii s R) i)) = fst (netgmap sr (NodeS ii s R))"
      by auto
  next
    fix s1 s2
    assume a1: "(\<lambda>i. map_option (fst \<circ> sr) (netmap s1 i)) = fst (netgmap sr s1)"
       and a2: "(\<lambda>i. map_option (fst \<circ> sr) (netmap s2 i)) = fst (netgmap sr s2)"
    show "(\<lambda>i. map_option (fst \<circ> sr) (netmap (SubnetS s1 s2) i)) = fst (netgmap sr (SubnetS s1 s2))"
    proof (rule ext)
      fix i
      from a1 a2 have "map_option (fst \<circ> sr) ((netmap s1 ++ netmap s2) i)
                                    = (fst (netgmap sr s1) ++ fst (netgmap sr s2)) i"
        by (metis fst_conv map_add_dom_app_simps(1) map_add_dom_app_simps(3)
                  net_ips_is_dom_netmap netgmap_pair_dom)
      thus "map_option (fst \<circ> sr) (netmap (SubnetS s1 s2) i) = fst (netgmap sr (SubnetS s1 s2)) i"
        by simp
    qed
  qed

lemma netmap_is_fst_netgmap:
  assumes "netmap s' = netmap s"
    shows "fst (netgmap sr s') = fst (netgmap sr s)"
  using assms by (metis netmap_fst_netgmap_rel)

lemma netmap_is_fst_netgmap':
  assumes "netmap s' i = netmap s i"
    shows "fst (netgmap sr s') i = fst (netgmap sr s) i"
  using assms by (metis netmap_fst_netgmap_rel)

lemma fst_netgmap_pair_fst [simp]:
  "fst (netgmap (\<lambda>(p, q). (fst p, snd p, q)) s) = fst (netgmap fst s)"
  by (induction s) auto

text \<open>Introduce streamlined alternatives to netgmap to simplify certain property
        statements and thus make them easier to understand and to present.\<close>

fun netlift :: "('s \<Rightarrow> 'g \<times> 'l) \<Rightarrow> 's net_state \<Rightarrow> (nat \<Rightarrow> 'g option)"
  where
    "netlift sr (NodeS i s R) = [i \<mapsto> fst (sr s)]"
  | "netlift sr (SubnetS s t) = (netlift sr s) ++ (netlift sr t)"

lemma fst_netgmap_netlift:
  "fst (netgmap sr s) = netlift sr s"
  by (induction s) simp_all

fun netliftl :: "('s \<Rightarrow> 'g \<times> 'l) \<Rightarrow> 's net_state \<Rightarrow> 'l net_state"
  where
    "netliftl sr (NodeS i s R) = NodeS i (snd (sr s)) R"
  | "netliftl sr (SubnetS s t) = SubnetS (netliftl sr s) (netliftl sr t)"

lemma snd_netgmap_netliftl:
  "snd (netgmap sr s) = netliftl sr s"
  by (induction s) simp_all

lemma netgmap_netlift_netliftl: "netgmap sr s = (netlift sr s, netliftl sr s)"
  by rule (simp_all add: fst_netgmap_netlift snd_netgmap_netliftl)

end