section \<open>Cotangent Space\<close>
theory Cotangent_Space
  imports Tangent_Space
begin

subsection \<open>Dual of a vector space\<close>

abbreviation "linear_fun_on S \<equiv> linear_on S (UNIV::real set) scaleR scaleR"

definition dual_space :: "'a::real_vector set \<Rightarrow> ('a \<Rightarrow> real) set" where
  "dual_space S = {E. linear_fun_on S E \<and> extensional0 S E}"

lemma dual_spaceI:
  "E \<in> dual_space S"
  if "extensional0 S E" "linear_fun_on S E"
  using that
  by (auto simp: dual_space_def)

lemma dual_spaceD:
  assumes "E \<in> dual_space S"
  shows dual_space_linear_on: "linear_fun_on S E"
    and dual_space_restrict[simp]: "extensional0 S E"
  using assms by (auto simp: dual_space_def)

lemma linear_fun_on_zero:
  "linear_fun_on S 0"
  if "subspace S"
  by (unfold_locales, auto simp add: algebra_simps that[unfolded subspace_def])

lemma "linear_fun_on S x \<Longrightarrow> a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> x (a + b) = x a + x b"
  using linear_on.axioms module_hom_on.add by blast

lemma linear_fun_on_add:
  "linear_fun_on S (x + y)"
  if x: "linear_fun_on S x" and y: "linear_fun_on S y" and S: "subspace S"
  using x that
  by (unfold_locales, auto dest!: linear_on.axioms
      simp add: algebra_simps module_hom_on.add module_hom_on.scale subspace_def)

lemma linear_fun_on_scaleR:
  "linear_fun_on S (c *\<^sub>R x)"
  if x: "linear_fun_on S x" and S: "subspace S"
  using x that
  by (unfold_locales, auto dest!: linear_on.axioms
      simp add: module_hom_on.add module_hom_on.scale algebra_simps subspace_def)

lemma subspace_linear_fun_on:
  "subspace {E. linear_fun_on S E}"
  if "subspace S"
  by (auto simp: subspace_def linear_fun_on_zero[OF that]
      linear_fun_on_add[OF _ _ that] linear_fun_on_scaleR[OF _ that])

lemma subspace_dual_space:
  "subspace (dual_space S)"
  if "subspace S"
  unfolding dual_space_eq
  apply (rule subspace_inter)
   apply (rule subspace_linear_fun_on[OF that])
  apply (rule subspace_extensional0)
  done

subsection \<open>Dimension of dual space\<close>

text \<open>Mapping from S to the dual of S\<close>

context fixes B S assumes B: "independent B" "span B = S"
begin

definition "inner_Basis a b = (\<Sum>i\<in>B. representation B a i * representation B b i)"
  \<comment> \<open>TODO: move to library\<close>

definition std_dual :: "'a::real_vector \<Rightarrow> ('a \<Rightarrow> real)" where
  "std_dual a = restrict0 S (restrict0 S (\<lambda>b. inner_Basis a b))"

lemma inner_Basis_add:
  "b1 \<in> S \<Longrightarrow> b2 \<in> S \<Longrightarrow> inner_Basis (b1 + b2) v = inner_Basis b1 v + inner_Basis b2 v"
  by (auto simp: std_dual_def restrict0_def algebra_simps representation_add representation_scale
      B inner_Basis_def
      sum.distrib sum_distrib_left)

lemma inner_Basis_add2:
  "b1 \<in> S \<Longrightarrow> b2 \<in> S \<Longrightarrow> inner_Basis v (b1 + b2) = inner_Basis v b1 + inner_Basis v b2"
  by (auto simp: std_dual_def restrict0_def algebra_simps representation_add representation_scale
      B inner_Basis_def
      sum.distrib sum_distrib_left)

lemma inner_Basis_scale:
  "b1 \<in> S \<Longrightarrow> inner_Basis (c *\<^sub>R b1) v = c * inner_Basis b1 v"
  by (auto simp: std_dual_def restrict0_def algebra_simps representation_add representation_scale
      B inner_Basis_def sum.distrib sum_distrib_left)

lemma inner_Basis_scale2:
  "b1 \<in> S \<Longrightarrow> inner_Basis v (c *\<^sub>R b1) = c * inner_Basis v b1"
  by (auto simp: std_dual_def restrict0_def algebra_simps representation_add representation_scale
      B inner_Basis_def sum.distrib sum_distrib_left)

lemma inner_Basis_minus:
  "b1 \<in> S \<Longrightarrow> b2 \<in> S \<Longrightarrow> inner_Basis (b1 - b2) v = inner_Basis b1 v - inner_Basis b2 v"
  and inner_Basis_minus2:
  "b1 \<in> S \<Longrightarrow> b2 \<in> S \<Longrightarrow> inner_Basis v (b1 - b2) = inner_Basis v b1 - inner_Basis v b2"
  by (auto simp: std_dual_def restrict0_def algebra_simps representation_diff representation_scale
      B inner_Basis_def
      sum_subtractf sum_distrib_left)

lemma sum_zero_representation:
  "v = 0"
  if "\<And>b. b \<in> B \<Longrightarrow> representation B v b = 0" and v: "v \<in> S"
proof -
  have empty: "{b. representation B v b \<noteq> 0} = {}"
    using that(1) representation_ne_zero by auto
  have "v \<in> span B" using B v by simp
  from sum_nonzero_representation_eq[OF B(1) this]
  show ?thesis
    by (simp add: empty)
qed

lemma inner_Basis_0[simp]: "inner_Basis 0 a = 0" "inner_Basis a 0 = 0"
  by (auto simp: inner_Basis_def representation_zero)

lemma inner_Basis_eq_zeroI: "a = 0" if "inner_Basis a a = 0"
  and "finite B" "a \<in> S"
  by (rule sum_zero_representation)
    (use that in \<open>auto simp: inner_Basis_def that sum_nonneg_eq_0_iff\<close>)

lemma inner_Basis_zero: "inner_Basis a a = 0 \<longleftrightarrow> a = 0"
  if "finite B" "a \<in> S"
  by (auto simp: inner_Basis_eq_zeroI that)

lemma subspace_S: "subspace S"
  using B by auto

interpretation S: real_vector_space_on S
  using subspace_S
  by unfold_locales

interpretation dual: real_vector_space_on "dual_space S"
  using subspace_dual_space[OF subspace_S]
  by unfold_locales

lemma std_dual_linear:
  "linear_on S (dual_space S) scaleR scaleR std_dual"
  by unfold_locales
    (auto simp add: subspace_S[unfolded subspace_def] subspace_dual_space[unfolded subspace_def] algebra_simps
      std_dual_def inner_Basis_scale inner_Basis_add restrict0_def)

lemma image_std_dual:
  "std_dual ` S \<subseteq> dual_space S"
  if "subspace S"
proof safe
  fix y assume "y \<in> S"
  show "std_dual y \<in> dual_space S"
  proof (rule dual_spaceI)
    show "extensional0 S (std_dual y)"
      by (auto simp: std_dual_def)
    show "linear_fun_on S (std_dual y)"
      by (unfold_locales, auto simp: std_dual_def algebra_simps that[unfolded subspace_def]
        inner_Basis_add2 inner_Basis_scale2 B)
  qed
qed

lemma inj_std_dual:
  "inj_on std_dual S"
  if "subspace S" "finite B"
proof (intro inj_onI)
  fix x y assume x: "x \<in> S" and y: "y \<in> S" and eq: "std_dual x = std_dual y"
  have 1: "inner_Basis x b = inner_Basis y b" if b: "b \<in> S" for b
  proof -
    have "std_dual x b = inner_Basis x b" "std_dual y b = inner_Basis y b"
      unfolding std_dual_def restrict0_def
      using b by auto
    then show ?thesis using eq by auto
  qed
  have 2: "x - y \<in> S" using that(1) x y by (rule subspace_diff)
  have "inner_Basis x (x - y) - inner_Basis y (x - y) = 0" using 1 2 by auto
  then have "inner_Basis (x - y) (x - y) = 0"
    by (auto simp: inner_Basis_minus inner_Basis_minus2 2 B x y algebra_simps)
  then show "x = y"
    by (auto simp: inner_Basis_zero B that 2)
qed

lemma inner_Basis_sum:
  "(\<And>i. i \<in> I \<Longrightarrow> x i \<in> S) \<Longrightarrow> inner_Basis (\<Sum>i\<in>I. x i) v = (\<Sum>i\<in>I. inner_Basis (x i) v)"
  apply (induction I rule: infinite_finite_induct)
    apply (auto simp: )
  apply (subst inner_Basis_add)
  apply auto
  by (metis B(2) subspace_span subspace_sum)

lemma inner_Basis_sum2:
  "(\<And>i. i \<in> I \<Longrightarrow> x i \<in> S) \<Longrightarrow> inner_Basis v (\<Sum>i\<in>I. x i) = (\<Sum>i\<in>I. inner_Basis v (x i))"
  apply (induction I rule: infinite_finite_induct)
    apply (auto simp: )
  apply (subst inner_Basis_add2)
  apply auto
  by (metis B(2) subspace_span subspace_sum)

lemma B_sub_S: "B \<subseteq> S"
  using B(2) span_eq by auto

lemma inner_Basis_eq_representation:
  "inner_Basis i x = representation B x i"
  if "i \<in> B" "finite B"
  unfolding inner_Basis_def
  by (simp add: B that representation_basis if_distrib if_distribR cong: if_cong)

lemma surj_std_dual:
  "std_dual ` S \<supseteq> dual_space S" if "subspace S" "finite B"
proof safe
  fix y
  assume y: "y \<in> dual_space S"
  show "y \<in> std_dual ` S"
  proof -
    (* Basic idea: let v_i be a basis of S. Let x be the sum of (y v_i) * v_i.
       Then y should be equal to std_dual S ` x. *)
    let ?x = "\<Sum>i\<in>B. (y i) *\<^sub>R i"
    have x: "?x \<in> S"
      using that(1) apply (rule subspace_sum) using that(1) apply (rule subspace_scale)
      using B span_superset
      by auto
    from dual_space_linear_on[OF y]
    have linear_y: "linear_fun_on S y" .
    then interpret linear_on S UNIV scaleR scaleR y .
    interpret vector_space_pair_on S "UNIV::real set" scaleR scaleR by unfold_locales
    have "y = std_dual ?x"
      apply (rule ext_extensional0[of S])
      subgoal using y dual_space_def by auto
      subgoal by (auto simp: std_dual_def)
      unfolding std_dual_def restrict0_def apply auto
      apply (subst inner_Basis_sum) subgoal
        using B(2) span_base subspace_scale by blast
      subgoal for x
      proof goal_cases
        case 1
        have "(\<Sum>i\<in>B. inner_Basis (y i *\<^sub>R i) x) = (\<Sum>i\<in>B. y (inner_Basis i x *\<^sub>R i))"
        proof (rule sum.cong[OF refl])
          fix i assume i: "i \<in> B"
          then have "i : S" using B_sub_S by auto
          have "inner_Basis (y i *\<^sub>R i) x = y i * inner_Basis i x"
            apply (subst inner_Basis_scale)
            subgoal using B_sub_S i by auto
            apply (rule refl)
            done
          also have "\<dots> = y i *\<^sub>R inner_Basis i x" by simp
          also have "\<dots> = y (inner_Basis i x *\<^sub>R i)"
            by (auto simp: \<open>i \<in> S\<close> scale)
          finally show "inner_Basis (y i *\<^sub>R i) x = y (inner_Basis i x *\<^sub>R i)" .
        qed
        also have "\<dots> = y (\<Sum>i\<in>B. (inner_Basis i x *\<^sub>R i))" (is "_ = y ?sum")
          apply (subst linear_sum'[OF _ _ linear_y])
            apply (auto simp: inner_Basis_eq_representation)
          using B(2) S.mem_scale span_base by blast
        also have "?sum = x"
          apply (subst sum.cong[OF refl])
           apply (subst inner_Basis_eq_representation, assumption, rule that, rule refl)
          apply (subst sum_representation_eq)
          by (auto simp: that B \<open>x : S\<close>)
        finally show ?thesis by simp
      qed
      done
    then show ?thesis
      using x by auto
  qed
qed

lemma std_dual_bij_betw:
  "bij_betw (std_dual) S (dual_space S)"
  if "finite B"
  unfolding bij_betw_def
  using subspace_S inj_std_dual image_std_dual surj_std_dual that by blast

lemma std_dual_eq_dual_space: "finite B \<Longrightarrow> std_dual ` S = dual_space S"
  using image_std_dual surj_std_dual subspace_S by auto

lemma dim_dual_space:
  assumes "finite B"
  shows "dim (dual_space S) = dim S"
proof -
  interpret finite_dimensional_real_vector_space_pair_1_on S "dual_space S" B
    using B assms span_superset
    by unfold_locales auto
  have *: "span S = S" using subspace_S by auto
  then have "dual.dim (std_dual ` S) = S.dim S"
    apply (intro dim_image_eq[OF _ order_refl std_dual_linear])
    using std_dual_bij_betw[OF assms]
    by (auto simp: bij_betw_def *)
  also have "S.dim S = dim S"
    unfolding S.dim_eq[OF order_refl] ..
  also have "dual.dim (std_dual ` S) = dim (std_dual ` S)"
    using image_std_dual[OF subspace_S]
    by (rule dual.dim_eq)
  also have "std_dual ` S = dual_space S"
    using assms
    by (rule std_dual_eq_dual_space)
  finally show ?thesis .
qed

end

subsection \<open>Dual map\<close>

context real_vector_space_pair_on begin

definition dual_map :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> real) \<Rightarrow> ('a \<Rightarrow> real)" where
  "dual_map f y = restrict0 S (\<lambda>x. y (f x))"

lemma subspace_dual_S: "subspace (dual_space S)"
  apply (rule subspace_dual_space)
  apply (rule local.vs1.subspace)
  done

lemma subspace_dual_T: "subspace (dual_space T)"
  apply (rule subspace_dual_space)
  apply (rule local.vs2.subspace)
  done

lemma dual_map_linear:
  "linear_on (dual_space T) (dual_space S) scaleR scaleR (dual_map f)"
  apply unfold_locales
  by (auto simp add: dual_map_def restrict0_def subspace_dual_S[unfolded subspace_def]
                     subspace_dual_T[unfolded subspace_def] algebra_simps)

lemma image_dual_map:
  "dual_map f ` (dual_space T) \<subseteq> dual_space S"
  if f: "linear_on S T scaleR scaleR f" and
  defined: "f ` S \<subseteq> T"
proof safe
  fix x assume x: "x \<in> dual_space T"
  show "dual_map f x \<in> dual_space S"
  proof (rule dual_spaceI)
    have 1: "linear_fun_on T x"
      using x by (rule dual_space_linear_on)
    show "extensional0 S (dual_map f x)" by (auto simp: dual_map_def)
    show "linear_fun_on S (dual_map f x)"
      apply (unfold_locales, auto simp: dual_map_def restrict0_def linear_on_def algebra_simps
             local.vs1.subspace[unfolded subspace_def])
    proof -
      show "x (f (b1 + b2)) = x (f b1) + x (f b2)" if "b1 \<in> S" "b2 \<in> S" for b1 b2
      proof -
        have "f b1 \<in> T" using \<open>b1 \<in> S\<close> defined by auto
        have "f b2 \<in> T" using \<open>b2 \<in> S\<close> defined by auto
        have "x (f (b1 + b2)) = x (f b1 + f b2)"
          by (auto simp: f[THEN linear_on.axioms, THEN module_hom_on.add] that)
        also have "x (f b1 + f b2) = x (f b1) + x (f b2)"
          by (auto simp: 1[THEN linear_on.axioms, THEN module_hom_on.add] \<open>f b1 \<in> T\<close> \<open>f b2 \<in> T\<close>)
        finally show ?thesis .
      qed
      show "x (f (r *\<^sub>R b)) = r * x (f b)" if "b \<in> S" for r b
      proof -
        have "f b \<in> T" using \<open>b \<in> S\<close> defined by auto
        have "x (f (r *\<^sub>R b)) = x (r *\<^sub>R f b)"
          by (auto simp: f[THEN linear_on.axioms, THEN module_hom_on.scale] that)
        also have "x (r *\<^sub>R f b) = r * x (f b)"
          by (auto simp: 1[THEN linear_on.axioms, THEN module_hom_on.scale] \<open>f b \<in> T\<close>)
        finally show ?thesis .
      qed
    qed
  qed
qed

end

text \<open>Functoriality of dual map: identity\<close>

context real_vector_space_on begin

lemma dual_map_id:
  "real_vector_space_pair_on.dual_map S f y = y"
  if f: "\<And>x. x \<in> S \<Longrightarrow> f x = x" and y: "y \<in> dual_space S"
proof (rule ext_extensional0[of S])
  have 1: "real_vector_space_pair_on S S" ..
  show "extensional0 S (real_vector_space_pair_on.dual_map S f y)"
    unfolding real_vector_space_pair_on.dual_map_def[OF 1] by auto
  show "extensional0 S y"
    using y by auto
  fix x assume x: "x \<in> S"
  show "real_vector_space_pair_on.dual_map S f y x = y x"
  proof -
    have "real_vector_space_pair_on.dual_map S f y x = y (f x)"
      by (auto simp: real_vector_space_pair_on.dual_map_def[OF 1] restrict0_def x)
    also have "y (f x) = y x"
      using f x by auto
    finally show ?thesis .
  qed
qed

end

abbreviation "dual_map \<equiv> real_vector_space_pair_on.dual_map"
lemmas dual_map_def = real_vector_space_pair_on.dual_map_def

text \<open>Functoriality of dual map: composition\<close>

lemma dual_map_compose:
  "dual_map S f (dual_map T g x) = dual_map S (g \<circ> f) x"
  if "x \<in> dual_space U" and "linear_on T U scaleR scaleR g"
  and f: "linear_on S T scaleR scaleR f"
  and defined: "f ` S \<subseteq> T"
  and ST: "real_vector_space_pair_on S T"
  and TU: "real_vector_space_pair_on T U"
proof (rule ext)
  have SU: "real_vector_space_pair_on S U"
    using ST TU by (auto simp add: real_vector_space_pair_on_def)
  fix v show "dual_map S f (dual_map T g x) v = dual_map S (g \<circ> f) x v"
  unfolding dual_map_def[OF ST] dual_map_def[OF TU] dual_map_def[OF SU] restrict0_def
  using defined by auto
qed

subsection \<open>Definition of cotangent space\<close>

context c_manifold begin

definition cotangent_space :: "'a \<Rightarrow> ((('a \<Rightarrow> real) \<Rightarrow> real) \<Rightarrow> real) set" where
  "cotangent_space p = dual_space (tangent_space p)"

lemma subspace_cotangent_space:
  "subspace (cotangent_space p)"
  unfolding cotangent_space_def
  apply (rule subspace_dual_space)
  apply (rule subspace_tangent_space)
  done

sublocale cotangent_space: real_vector_space_on "cotangent_space p"
  by unfold_locales (rule subspace_cotangent_space)

(* Shouldn't there be a general theorem for this, instead of repeating the proof
   for tangent_space_dim_eq?
*)
lemma cotangent_space_dim_eq: "cotangent_space.dim p X = dim X"
  if "X \<subseteq> cotangent_space p"
proof -
  have *: "b \<subseteq> cotangent_space p \<and> independent b \<and> span b = span X \<longleftrightarrow> independent b \<and> span b = span X"
    for b
    using that
    by auto (metis (no_types, lifting) c_manifold.subspace_cotangent_space c_manifold_axioms span_base span_eq_iff span_mono subsetCE)
  show ?thesis
    using that
    unfolding cotangent_space.dim_def dim_def *
    by auto
qed

lemma dim_cotangent_space:
  "dim (cotangent_space p) = DIM('b)" if "p \<in> carrier" and "k = \<infinity>"
proof -
  from basis_exists[of "tangent_space p"]
  obtain B where B: "B \<subseteq> tangent_space p" "independent B" "tangent_space p \<subseteq> span B"
    "card B = dim (tangent_space p)"
    by auto
  have "finite B"
    apply (rule card_ge_0_finite)
    unfolding B
    apply (subst dim_tangent_space[OF that])
    by simp
  have "dim (cotangent_space p) = dim (tangent_space p)"
    unfolding cotangent_space_def
    apply (rule dim_dual_space[of B])
    apply fact
    using B span_minimal[OF B(1) subspace_tangent_space] \<open>finite B\<close>
    by auto
  also have "dim (tangent_space p) = DIM('b)"
    by (rule dim_tangent_space[OF that])
  finally show ?thesis .
qed

end

subsection \<open>Pullback of cotangent space\<close>

context diff begin

definition pull_back :: "'a \<Rightarrow> ((('b \<Rightarrow> real) \<Rightarrow> real) \<Rightarrow> real) \<Rightarrow> (('a \<Rightarrow> real) \<Rightarrow> real) \<Rightarrow> real" where
  "pull_back p = dual_map (src.tangent_space p) push_forward"

lemma
  linear_pullback: "linear_on (dest.cotangent_space (f p)) (src.cotangent_space p) scaleR scaleR (pull_back p)" and
  image_pullback: "pull_back p ` (dest.cotangent_space (f p)) \<subseteq> src.cotangent_space p"
  if "p \<in> src.carrier"
proof -
  interpret a: real_vector_space_pair_on "src.tangent_space p" "dest.tangent_space (f p)" ..
  show "linear_on (dest.cotangent_space (f p)) (src.cotangent_space p) (*\<^sub>R) (*\<^sub>R) (pull_back p)"
    unfolding dest.cotangent_space_def src.cotangent_space_def pull_back_def
    by (rule a.dual_map_linear)
  show "pull_back p ` (dest.cotangent_space (f p)) \<subseteq> src.cotangent_space p"
    unfolding dest.cotangent_space_def src.cotangent_space_def pull_back_def
    apply (rule a.image_dual_map)
    apply (rule linear_imp_linear_on)
      apply (rule local.linear_push_forward)
      apply (rule local.src.subspace_tangent_space)
     apply (rule local.dest.subspace_tangent_space)
    apply (rule local.push_forward_in_tangent_space)
    by fact
qed

end

subsection \<open>Cotangent field of a function\<close>

context c_manifold begin

text \<open>Given a function f, the cotangent vector of f at a point p is defined
  as follows: given a tangent vector X at p, considered as a functional, evaluate
  X on f.\<close>

definition cotangent_field :: "('a \<Rightarrow> real) \<Rightarrow> 'a \<Rightarrow> ((('a \<Rightarrow> real) \<Rightarrow> real) \<Rightarrow> real)" where
  "cotangent_field f p = restrict0 (tangent_space p) (\<lambda>X. X f)"

subsection \<open>Tangent field of a path\<close>

(* Note: an alternative definition is as follows: consider the path as
   a smooth map from the manifold with boundary [a,b], then take the
   push-forward of the trivial tangent field on [a,b]. In this case,
   showing this is a tangent vector would be trivial. *)

text \<open>Given a path \<open>c\<close>, the tangent vector of \<open>c\<close> at real number \<open>x\<close> (or at point \<open>c(x)\<close>)
  is defined as follows: given a function f, take the derivative of the
  real-valued function \<open>f \<circ> c\<close>.\<close>

definition tangent_field :: "(real \<Rightarrow> 'a) \<Rightarrow> real \<Rightarrow> (('a \<Rightarrow> real) \<Rightarrow> real)" where
  "tangent_field c x = restrict0 diff_fun_space (\<lambda>f. frechet_derivative (f \<circ> c) (at x) 1)"

lemma tangent_field_is_tangent:
  "tangent_field c x \<in> tangent_space (c x)"
  if c_smooth: "diff k charts_eucl charts c" and smooth: "k > 0"
proof (rule tangent_spaceI)
  show "extensional0 diff_fun_space (tangent_field c x)"
    unfolding tangent_field_def by auto
  have diff_fun_c_diff: "(\<lambda>x. b (c x)) differentiable at x"
    if b: "b \<in> diff_fun_space"
    for b::"'a \<Rightarrow> real" and x
  proof -
    have diff_b: "diff_fun k charts_eucl (b o c)"
      unfolding diff_fun_def
      using c_smooth diff_fun_spaceD[OF b, THEN diff_fun.axioms]
      by (rule diff_compose)
    from diff_fun_charts_euclD[OF this] smooth
    have "(b o c) differentiable_on UNIV"
      by (rule smooth_on_imp_differentiable_on)
    then show ?thesis by (auto simp: differentiable_on_def o_def)
  qed
  show "linear_fun_on diff_fun_space (tangent_field c x)"
    apply unfold_locales unfolding cotangent_field_def apply auto
  proof -
    show "tangent_field c x (b1 + b2) = tangent_field c x b1 + tangent_field c x b2"
      if b1: "b1 \<in> diff_fun_space" and b2: "b2 \<in> diff_fun_space" for b1 b2
      unfolding tangent_field_def restrict0_def
      by (auto simp: diff_fun_space_add o_def diff_fun_c_diff b1 b2 frechet_derivative_plus)
    show "tangent_field c x (r *\<^sub>R b) = r * tangent_field c x b"
      if b: "b \<in> diff_fun_space" for r b
      unfolding tangent_field_def restrict0_def
      by (auto simp: diff_fun_space.m1.mem_scale o_def diff_fun_c_diff b frechet_derivative_times
          frechet_derivative_const)
  qed
  show "tangent_field c x (f * g) = f (c x) * tangent_field c x g + g (c x) * tangent_field c x f"
    if f: "f \<in> diff_fun_space" and g: "g \<in> diff_fun_space" for f g
    unfolding tangent_field_def restrict0_def
    by (auto simp: f g diff_fun_space_times diff_fun_space_add o_def diff_fun_c_diff
        frechet_derivative_plus frechet_derivative_times)
qed

subsection \<open>Integral along a path\<close>

lemma fundamental_theorem_of_path_integral:
  "((\<lambda>x. (cotangent_field f (c x)) (tangent_field c x)) has_integral f (c b) - f (c a)) {a..b}"
  if ab: "a \<le> b" and f: "f \<in> diff_fun_space" and c: "diff k charts_eucl charts c" and k: "k \<noteq> 0"
proof -
  from f have "diff k charts charts_eucl f"
    by (auto simp: diff_fun_space_def diff_fun_def)
  then have "(diff_fun k charts_eucl (f o c))"
    unfolding diff_fun_def
    apply (intro diff_compose)
     apply (rule c)
    apply assumption
    done
  then have "k-smooth_on UNIV (f o c)"
    by (rule diff_fun_charts_euclD)
  then have "(f o c) differentiable_on UNIV"
    by (rule smooth_on_imp_differentiable_on) (use k in simp)
  then have fc: "(\<lambda>a. f (c a)) differentiable at x" for x
    by (auto simp: differentiable_on_def o_def)
  then show ?thesis
    using ab
    unfolding cotangent_field_def
    apply (auto simp: tangent_field_is_tangent c k)
    unfolding tangent_field_def
    apply (auto simp: f)
    apply (rule fundamental_theorem_of_calculus)
     apply assumption
    apply (rule has_vector_derivative_at_within)
    unfolding o_def has_vector_derivative_def
    apply (subst frechet_derivative_at_real_eq_scaleR[symmetric])
      apply simp
     apply simp
    apply (rule frechet_derivative_worksI)
    apply simp
    done
qed

end

end


section \<open>Augmented Tree (Tree2)\<close>

theory Tree2
imports "Tree"
begin

text \<open>This theory provides the basic infrastructure for the type @{typ \<open>('a * 'b) tree\<close>}
of augmented trees where @{typ 'a} is the key and @{typ 'b} some additional information.\<close>

text \<open>IMPORTANT: Inductions and cases analyses on augmented trees need to use the following
two rules explicitly. They generate nodes of the form @{term "Node l (a,b) r"}
rather than @{term "Node l a r"} for trees of type @{typ "'a tree"}.\<close>

lemmas tree2_induct = tree.induct[where 'a = "'a * 'b", split_format(complete)]

lemmas tree2_cases = tree.exhaust[where 'a = "'a * 'b", split_format(complete)]

fun inorder :: "('a*'b)tree \<Rightarrow> 'a list" where
"inorder Leaf = []" |
"inorder (Node l (a,_) r) = inorder l @ a # inorder r"

fun set_tree :: "('a*'b) tree \<Rightarrow> 'a set" where
"set_tree Leaf = {}" |
"set_tree (Node l (a,_) r) = {a} \<union> set_tree l \<union> set_tree r"

fun bst :: "('a::linorder*'b) tree \<Rightarrow> bool" where
"bst Leaf = True" |
"bst (Node l (a, _) r) = ((\<forall>x \<in> set_tree l. x < a) \<and> (\<forall>x \<in> set_tree r. a < x) \<and> bst l \<and> bst r)"

lemma finite_set_tree[simp]: "finite(set_tree t)"
by(induction t) auto

lemma eq_set_tree_empty[simp]: "set_tree t = {} \<longleftrightarrow> t = Leaf"
by (cases t) auto

lemma set_inorder[simp]: "set (inorder t) = set_tree t"
by (induction t) auto

lemma length_inorder[simp]: "length (inorder t) = size t"
by (induction t) auto

end


(*  Title:      ZF/AC/DC.thy
    Author:     Krzysztof Grabczewski

The proofs concerning the Axiom of Dependent Choice.
*)

theory DC
imports AC_Equiv Hartog Cardinal_aux
begin

lemma RepFun_lepoll: "Ord(a) ==> {P(b). b \<in> a} \<lesssim> a"
apply (unfold lepoll_def)
apply (rule_tac x = "\<lambda>z \<in> RepFun (a,P) . LEAST i. z=P (i) " in exI)
apply (rule_tac d="%z. P (z)" in lam_injective)
 apply (fast intro!: Least_in_Ord)
apply (rule sym)
apply (fast intro: LeastI Ord_in_Ord)
done

text{*Trivial in the presence of AC, but here we need a wellordering of X*}
lemma image_Ord_lepoll: "[| f \<in> X->Y; Ord(X) |] ==> f``X \<lesssim> X"
apply (unfold lepoll_def)
apply (rule_tac x = "\<lambda>x \<in> f``X. LEAST y. f`y = x" in exI)
apply (rule_tac d = "%z. f`z" in lam_injective)
apply (fast intro!: Least_in_Ord apply_equality, clarify)
apply (rule LeastI)
 apply (erule apply_equality, assumption+)
apply (blast intro: Ord_in_Ord)
done

lemma range_subset_domain:
      "[| R \<subseteq> X*X;   !!g. g \<in> X ==> \<exists>u. <g,u> \<in> R |]
       ==> range(R) \<subseteq> domain(R)"
by blast

lemma cons_fun_type: "g \<in> n->X ==> cons(<n,x>, g) \<in> succ(n) -> cons(x, X)"
apply (unfold succ_def)
apply (fast intro!: fun_extend elim!: mem_irrefl)
done

lemma cons_fun_type2:
     "[| g \<in> n->X; x \<in> X |] ==> cons(<n,x>, g) \<in> succ(n) -> X"
by (erule cons_absorb [THEN subst], erule cons_fun_type)

lemma cons_image_n: "n \<in> nat ==> cons(<n,x>, g)``n = g``n"
by (fast elim!: mem_irrefl)

lemma cons_val_n: "g \<in> n->X ==> cons(<n,x>, g)`n = x"
by (fast intro!: apply_equality elim!: cons_fun_type)

lemma cons_image_k: "k \<in> n ==> cons(<n,x>, g)``k = g``k"
by (fast elim: mem_asym)

lemma cons_val_k: "[| k \<in> n; g \<in> n->X |] ==> cons(<n,x>, g)`k = g`k"
by (fast intro!: apply_equality consI2 elim!: cons_fun_type apply_Pair)

lemma domain_cons_eq_succ: "domain(f)=x ==> domain(cons(<x,y>, f)) = succ(x)"
by (simp add: domain_cons succ_def)

lemma restrict_cons_eq: "g \<in> n->X ==> restrict(cons(<n,x>, g), n) = g"
apply (simp add: restrict_def Pi_iff)
apply (blast intro: elim: mem_irrefl)
done

lemma succ_in_succ: "[| Ord(k); i \<in> k |] ==> succ(i) \<in> succ(k)"
apply (rule Ord_linear [of "succ(i)" "succ(k)", THEN disjE])
apply (fast elim: Ord_in_Ord mem_irrefl mem_asym)+
done

lemma restrict_eq_imp_val_eq:
      "[|restrict(f, domain(g)) = g; x \<in> domain(g)|]
       ==> f`x = g`x"
by (erule subst, simp add: restrict)

lemma domain_eq_imp_fun_type: "[| domain(f)=A; f \<in> B->C |] ==> f \<in> A->C"
by (frule domain_of_fun, fast)

lemma ex_in_domain: "[| R \<subseteq> A * B; R \<noteq> 0 |] ==> \<exists>x. x \<in> domain(R)"
by (fast elim!: not_emptyE)

definition
  DC  :: "i => o"  where
    "DC(a) == \<forall>X R. R \<subseteq> Pow(X)*X  &
                    (\<forall>Y \<in> Pow(X). Y \<prec> a \<longrightarrow> (\<exists>x \<in> X. <Y,x> \<in> R))
                    \<longrightarrow> (\<exists>f \<in> a->X. \<forall>b<a. <f``b,f`b> \<in> R)"

definition
  DC0 :: o  where
    "DC0 == \<forall>A B R. R \<subseteq> A*B & R\<noteq>0 & range(R) \<subseteq> domain(R)
                    \<longrightarrow> (\<exists>f \<in> nat->domain(R). \<forall>n \<in> nat. <f`n,f`succ(n)>:R)"

definition
  ff  :: "[i, i, i, i] => i"  where
    "ff(b, X, Q, R) ==
           transrec(b, %c r. THE x. first(x, {x \<in> X. <r``c, x> \<in> R}, Q))"

locale DC0_imp =
  fixes XX and RR and X and R

  assumes all_ex: "\<forall>Y \<in> Pow(X). Y \<prec> nat \<longrightarrow> (\<exists>x \<in> X. <Y, x> \<in> R)"

  defines XX_def: "XX == (\<Union>n \<in> nat. {f \<in> n->X. \<forall>k \<in> n. <f``k, f`k> \<in> R})"
     and RR_def:  "RR == {<z1,z2>:XX*XX. domain(z2)=succ(domain(z1))
                                       & restrict(z2, domain(z1)) = z1}"

(* ********************************************************************** *)
(* DC ==> DC(omega)                                                       *)
(*                                                                        *)
(* The scheme of the proof:                                               *)
(*                                                                        *)
(* Assume DC. Let R and X satisfy the premise of DC(omega).               *)
(*                                                                        *)
(* Define XX and RR as follows:                                           *)
(*                                                                        *)
(*       XX = (\<Union>n \<in> nat. {f \<in> n->X. \<forall>k \<in> n. <f``k, f`k> \<in> R})           *)
(*       f RR g iff domain(g)=succ(domain(f)) &                           *)
(*              restrict(g, domain(f)) = f                                *)
(*                                                                        *)
(* Then RR satisfies the hypotheses of DC.                                *)
(* So applying DC:                                                        *)
(*                                                                        *)
(*       \<exists>f \<in> nat->XX. \<forall>n \<in> nat. f`n RR f`succ(n)                        *)
(*                                                                        *)
(* Thence                                                                 *)
(*                                                                        *)
(*       ff = {<n, f`succ(n)`n>. n \<in> nat}                                 *)
(*                                                                        *)
(* is the desired function.                                               *)
(*                                                                        *)
(* ********************************************************************** *)

lemma (in DC0_imp) lemma1_1: "RR \<subseteq> XX*XX"
by (unfold RR_def, fast)

lemma (in DC0_imp) lemma1_2: "RR \<noteq> 0"
apply (unfold RR_def XX_def)
apply (rule all_ex [THEN ballE])
apply (erule_tac [2] notE [OF _ empty_subsetI [THEN PowI]])
apply (erule_tac impE [OF _ nat_0I [THEN n_lesspoll_nat]])
apply (erule bexE)
apply (rule_tac a = "<0, {<0, x>}>" in not_emptyI)
apply (rule CollectI)
apply (rule SigmaI)
apply (rule nat_0I [THEN UN_I])
apply (simp (no_asm_simp) add: nat_0I [THEN UN_I])
apply (rule nat_1I [THEN UN_I])
apply (force intro!: singleton_fun [THEN Pi_type]
             simp add: singleton_0 [symmetric])
apply (simp add: singleton_0)
done

lemma (in DC0_imp) lemma1_3: "range(RR) \<subseteq> domain(RR)"
apply (unfold RR_def XX_def)
apply (rule range_subset_domain, blast, clarify)
apply (frule fun_is_rel [THEN image_subset, THEN PowI,
                         THEN all_ex [THEN bspec]])
apply (erule impE[OF _ lesspoll_trans1[OF image_Ord_lepoll
                                          [OF _ nat_into_Ord] n_lesspoll_nat]],
       assumption+)
apply (erule bexE)
apply (rule_tac x = "cons (<n,x>, g) " in exI)
apply (rule CollectI)
apply (force elim!: cons_fun_type2
             simp add: cons_image_n cons_val_n cons_image_k cons_val_k)
apply (simp add: domain_of_fun succ_def restrict_cons_eq)
done

lemma (in DC0_imp) lemma2:
     "[| \<forall>n \<in> nat. <f`n, f`succ(n)> \<in> RR;  f \<in> nat -> XX;  n \<in> nat |]
      ==> \<exists>k \<in> nat. f`succ(n) \<in> k -> X & n \<in> k
                  & <f`succ(n)``n, f`succ(n)`n> \<in> R"
apply (induct_tac "n")
apply (drule apply_type [OF _ nat_1I])
apply (drule bspec [OF _ nat_0I])
apply (simp add: XX_def, safe)
apply (rule rev_bexI, assumption)
apply (subgoal_tac "0 \<in> y", force)
apply (force simp add: RR_def
             intro: ltD elim!: nat_0_le [THEN leE])
(** LEVEL 7, other subgoal **)
apply (drule bspec [OF _ nat_succI], assumption)
apply (subgoal_tac "f ` succ (succ (x)) \<in> succ (k) ->X")
apply (drule apply_type [OF _ nat_succI [THEN nat_succI]], assumption)
apply (simp (no_asm_use) add: XX_def RR_def)
apply safe
apply (frule_tac a="succ(k)" in domain_of_fun [symmetric, THEN trans],
       assumption)
apply (frule_tac a=y in domain_of_fun [symmetric, THEN trans],
       assumption)
apply (fast elim!: nat_into_Ord [THEN succ_in_succ]
            dest!: bspec [OF _ nat_into_Ord [THEN succ_in_succ]])
apply (drule domain_of_fun)
apply (simp add: XX_def RR_def, clarify)
apply (blast dest: domain_of_fun [symmetric, THEN trans] )
done

lemma (in DC0_imp) lemma3_1:
     "[| \<forall>n \<in> nat. <f`n, f`succ(n)> \<in> RR;  f \<in> nat -> XX;  m \<in> nat |]
      ==>  {f`succ(x)`x. x \<in> m} = {f`succ(m)`x. x \<in> m}"
apply (subgoal_tac "\<forall>x \<in> m. f`succ (m) `x = f`succ (x) `x")
apply simp
apply (induct_tac "m", blast)
apply (rule ballI)
apply (erule succE)
 apply (rule restrict_eq_imp_val_eq)
  apply (drule bspec [OF _ nat_succI], assumption)
  apply (simp add: RR_def)
 apply (drule lemma2, assumption+)
 apply (fast dest!: domain_of_fun)
apply (drule_tac x = xa in bspec, assumption)
apply (erule sym [THEN trans, symmetric])
apply (rule restrict_eq_imp_val_eq [symmetric])
 apply (drule bspec [OF _ nat_succI], assumption)
 apply (simp add: RR_def)
apply (drule lemma2, assumption+)
apply (blast dest!: domain_of_fun
             intro: nat_into_Ord OrdmemD [THEN subsetD])
done

lemma (in DC0_imp) lemma3:
     "[| \<forall>n \<in> nat. <f`n, f`succ(n)> \<in> RR;  f \<in> nat -> XX;  m \<in> nat |]
      ==> (\<lambda>x \<in> nat. f`succ(x)`x) `` m = f`succ(m)``m"
apply (erule natE, simp)
apply (subst image_lam)
 apply (fast elim!: OrdmemD [OF nat_succI Ord_nat])
apply (subst lemma3_1, assumption+)
 apply fast
apply (fast dest!: lemma2
            elim!: image_fun [symmetric, OF _ OrdmemD [OF _ nat_into_Ord]])
done

theorem DC0_imp_DC_nat: "DC0 ==> DC(nat)"
apply (unfold DC_def DC0_def, clarify)
apply (elim allE)
apply (erule impE)
   (*these three results comprise Lemma 1*)
apply (blast intro!: DC0_imp.lemma1_1 [OF DC0_imp.intro] DC0_imp.lemma1_2 [OF DC0_imp.intro] DC0_imp.lemma1_3 [OF DC0_imp.intro])
apply (erule bexE)
apply (rule_tac x = "\<lambda>n \<in> nat. f`succ (n) `n" in rev_bexI)
 apply (rule lam_type, blast dest!: DC0_imp.lemma2 [OF DC0_imp.intro] intro: fun_weaken_type)
apply (rule oallI)
apply (frule DC0_imp.lemma2 [OF DC0_imp.intro], assumption)
  apply (blast intro: fun_weaken_type)
 apply (erule ltD)
(** LEVEL 11: last subgoal **)
apply (subst DC0_imp.lemma3 [OF DC0_imp.intro], assumption+)
  apply (fast elim!: fun_weaken_type)
 apply (erule ltD)
apply (force simp add: lt_def)
done

(* ************************************************************************
   DC(omega) ==> DC

   The scheme of the proof:

   Assume DC(omega). Let R and x satisfy the premise of DC.

   Define XX and RR as follows:

    XX = (\<Union>n \<in> nat. {f \<in> succ(n)->domain(R). \<forall>k \<in> n. <f`k, f`succ(k)> \<in> R})

    RR = {<z1,z2>:Fin(XX)*XX.
           (domain(z2)=succ(\<Union>f \<in> z1. domain(f)) &
            (\<forall>f \<in> z1. restrict(z2, domain(f)) = f)) |
           (~ (\<exists>g \<in> XX. domain(g)=succ(\<Union>f \<in> z1. domain(f)) &
                        (\<forall>f \<in> z1. restrict(g, domain(f)) = f)) &
            z2={<0,x>})}

   Then XX and RR satisfy the hypotheses of DC(omega).
   So applying DC:

         \<exists>f \<in> nat->XX. \<forall>n \<in> nat. f``n RR f`n

   Thence

         ff = {<n, f`n`n>. n \<in> nat}

   is the desired function.

************************************************************************* *)

lemma singleton_in_funs:
 "x \<in> X ==> {<0,x>} \<in>
            (\<Union>n \<in> nat. {f \<in> succ(n)->X. \<forall>k \<in> n. <f`k, f`succ(k)> \<in> R})"
apply (rule nat_0I [THEN UN_I])
apply (force simp add: singleton_0 [symmetric]
             intro!: singleton_fun [THEN Pi_type])
done

locale imp_DC0 =
  fixes XX and RR and x and R and f and allRR
  defines XX_def: "XX == (\<Union>n \<in> nat.
                      {f \<in> succ(n)->domain(R). \<forall>k \<in> n. <f`k, f`succ(k)> \<in> R})"
      and RR_def:
         "RR == {<z1,z2>:Fin(XX)*XX.
                  (domain(z2)=succ(\<Union>f \<in> z1. domain(f))
                    & (\<forall>f \<in> z1. restrict(z2, domain(f)) = f))
                  | (~ (\<exists>g \<in> XX. domain(g)=succ(\<Union>f \<in> z1. domain(f))
                     & (\<forall>f \<in> z1. restrict(g, domain(f)) = f)) & z2={<0,x>})}"
      and allRR_def:
        "allRR == \<forall>b<nat.
                   <f``b, f`b> \<in>
                    {<z1,z2>\<in>Fin(XX)*XX. (domain(z2)=succ(\<Union>f \<in> z1. domain(f))
                                    & (\<Union>f \<in> z1. domain(f)) = b
                                    & (\<forall>f \<in> z1. restrict(z2,domain(f)) = f))}"

lemma (in imp_DC0) lemma4:
     "[| range(R) \<subseteq> domain(R);  x \<in> domain(R) |]
      ==> RR \<subseteq> Pow(XX)*XX &
             (\<forall>Y \<in> Pow(XX). Y \<prec> nat \<longrightarrow> (\<exists>x \<in> XX. <Y,x>:RR))"
apply (rule conjI)
apply (force dest!: FinD [THEN PowI] simp add: RR_def)
apply (rule impI [THEN ballI])
apply (drule Finite_Fin [OF lesspoll_nat_is_Finite PowD], assumption)
apply (case_tac
       "\<exists>g \<in> XX. domain (g) =
             succ(\<Union>f \<in> Y. domain(f)) & (\<forall>f\<in>Y. restrict(g, domain(f)) = f)")
apply (simp add: RR_def, blast)
apply (safe del: domainE)
apply (unfold XX_def RR_def)
apply (rule rev_bexI, erule singleton_in_funs)
apply (simp add: nat_0I [THEN rev_bexI] cons_fun_type2)
done

lemma (in imp_DC0) UN_image_succ_eq:
     "[| f \<in> nat->X; n \<in> nat |]
      ==> (\<Union>x \<in> f``succ(n). P(x)) =  P(f`n) \<union> (\<Union>x \<in> f``n. P(x))"
by (simp add: image_fun OrdmemD)

lemma (in imp_DC0) UN_image_succ_eq_succ:
     "[| (\<Union>x \<in> f``n. P(x)) = y; P(f`n) = succ(y);
         f \<in> nat -> X; n \<in> nat |] ==> (\<Union>x \<in> f``succ(n). P(x)) = succ(y)"
by (simp add: UN_image_succ_eq, blast)

lemma (in imp_DC0) apply_domain_type:
     "[| h \<in> succ(n) -> D;  n \<in> nat; domain(h)=succ(y) |] ==> h`y \<in> D"
by (fast elim: apply_type dest!: trans [OF sym domain_of_fun])

lemma (in imp_DC0) image_fun_succ:
     "[| h \<in> nat -> X; n \<in> nat |] ==> h``succ(n) = cons(h`n, h``n)"
by (simp add: image_fun OrdmemD)

lemma (in imp_DC0) f_n_type:
     "[| domain(f`n) = succ(k); f \<in> nat -> XX;  n \<in> nat |]
      ==> f`n \<in> succ(k) -> domain(R)"
apply (unfold XX_def)
apply (drule apply_type, assumption)
apply (fast elim: domain_eq_imp_fun_type)
done

lemma (in imp_DC0) f_n_pairs_in_R [rule_format]:
     "[| h \<in> nat -> XX;  domain(h`n) = succ(k);  n \<in> nat |]
      ==> \<forall>i \<in> k. <h`n`i, h`n`succ(i)> \<in> R"
apply (unfold XX_def)
apply (drule apply_type, assumption)
apply (elim UN_E CollectE)
apply (drule domain_of_fun [symmetric, THEN trans], assumption, simp)
done

lemma (in imp_DC0) restrict_cons_eq_restrict:
     "[| restrict(h, domain(u))=u;  h \<in> n->X;  domain(u) \<subseteq> n |]
      ==> restrict(cons(<n, y>, h), domain(u)) = u"
apply (unfold restrict_def)
apply (simp add: restrict_def Pi_iff)
apply (erule sym [THEN trans, symmetric])
apply (blast elim: mem_irrefl)
done

lemma (in imp_DC0) all_in_image_restrict_eq:
     "[| \<forall>x \<in> f``n. restrict(f`n, domain(x))=x;
         f \<in> nat -> XX;
         n \<in> nat;  domain(f`n) = succ(n);
         (\<Union>x \<in> f``n. domain(x)) \<subseteq> n |]
      ==> \<forall>x \<in> f``succ(n). restrict(cons(<succ(n),y>, f`n), domain(x)) = x"
apply (rule ballI)
apply (simp add: image_fun_succ)
apply (drule f_n_type, assumption+)
apply (erule disjE)
 apply (simp add: domain_of_fun restrict_cons_eq)
apply (blast intro!: restrict_cons_eq_restrict)
done

lemma (in imp_DC0) simplify_recursion:
     "[| \<forall>b<nat. <f``b, f`b> \<in> RR;
         f \<in> nat -> XX; range(R) \<subseteq> domain(R); x \<in> domain(R)|]
      ==> allRR"
apply (unfold RR_def allRR_def)
apply (rule oallI, drule ltD)
apply (erule nat_induct)
apply (drule_tac x=0 in ospec, blast intro: Limit_has_0)
apply (force simp add: singleton_fun [THEN domain_of_fun] singleton_in_funs)
(*induction step*) (** LEVEL 5 **)
(*prevent simplification of ~\<exists> to \<forall>~ *)
apply (simp only: separation split)
apply (drule_tac x="succ(xa)" in ospec, blast intro: ltI)
apply (elim conjE disjE)
apply (force elim!: trans subst_context
             intro!: UN_image_succ_eq_succ)
apply (erule notE)
apply (simp add: XX_def UN_image_succ_eq_succ)
apply (elim conjE bexE)
apply (drule apply_domain_type, assumption+)
apply (erule domainE)+
apply (frule f_n_type)
apply (simp add: XX_def, assumption+)
apply (rule rev_bexI, erule nat_succI)
apply (rename_tac m i j y z)
apply (rule_tac x = "cons(<succ(m), z>, f`m)" in bexI)
prefer 2 apply (blast intro: cons_fun_type2)
apply (rule conjI)
prefer 2 apply (fast del: ballI subsetI
                 elim: trans [OF _ subst_context, THEN domain_cons_eq_succ]
                       subst_context
                       all_in_image_restrict_eq [simplified XX_def]
                       trans equalityD1)
(*one remaining subgoal*)
apply (rule ballI)
apply (erule succE)
(** LEVEL 25 **)
 apply (simp add: cons_val_n cons_val_k)
(*assumption+ will not perform the required backtracking!*)
apply (drule f_n_pairs_in_R [simplified XX_def, OF _ domain_of_fun],
       assumption, assumption, assumption)
apply (simp add: nat_into_Ord [THEN succ_in_succ] succI2 cons_val_k)
done

lemma (in imp_DC0) lemma2:
     "[| allRR; f \<in> nat->XX; range(R) \<subseteq> domain(R); x \<in> domain(R); n \<in> nat |]
      ==> f`n \<in> succ(n) -> domain(R) & (\<forall>i \<in> n. <f`n`i, f`n`succ(i)>:R)"
apply (unfold allRR_def)
apply (drule ospec)
apply (erule ltI [OF _ Ord_nat])
apply (erule CollectE, simp)
apply (rule conjI)
prefer 2 apply (fast elim!: f_n_pairs_in_R trans subst_context)
apply (unfold XX_def)
apply (fast elim!: trans [THEN domain_eq_imp_fun_type] subst_context)
done

lemma (in imp_DC0) lemma3:
     "[| allRR; f \<in> nat->XX; n\<in>nat; range(R) \<subseteq> domain(R);  x \<in> domain(R) |]
      ==> f`n`n = f`succ(n)`n"
apply (frule lemma2 [THEN conjunct1, THEN domain_of_fun], assumption+)
apply (unfold allRR_def)
apply (drule ospec)
apply (drule ltI [OF nat_succI Ord_nat], assumption, simp)
apply (elim conjE ballE)
apply (erule restrict_eq_imp_val_eq [symmetric], force)
apply (simp add: image_fun OrdmemD)
done

theorem DC_nat_imp_DC0: "DC(nat) ==> DC0"
apply (unfold DC_def DC0_def)
apply (intro allI impI)
apply (erule asm_rl conjE ex_in_domain [THEN exE] allE)+
apply (erule impE [OF _ imp_DC0.lemma4], assumption+)
apply (erule bexE)
apply (drule imp_DC0.simplify_recursion, assumption+)
apply (rule_tac x = "\<lambda>n \<in> nat. f`n`n" in bexI)
apply (rule_tac [2] lam_type)
apply (erule_tac [2] apply_type [OF imp_DC0.lemma2 [THEN conjunct1] succI1])
apply (rule ballI)
apply (frule_tac n="succ(n)" in imp_DC0.lemma2,
       (assumption|erule nat_succI)+)
apply (drule imp_DC0.lemma3, auto)
done

(* ********************************************************************** *)
(* \<forall>K. Card(K) \<longrightarrow> DC(K) ==> WO3                                       *)
(* ********************************************************************** *)

lemma fun_Ord_inj:
      "[| f \<in> a->X;  Ord(a);
          !!b c. [| b<c; c \<in> a |] ==> f`b\<noteq>f`c |]
       ==> f \<in> inj(a, X)"
apply (unfold inj_def, simp)
apply (intro ballI impI)
apply (rule_tac j=x in Ord_in_Ord [THEN Ord_linear_lt], assumption+)
apply (blast intro: Ord_in_Ord, auto)
apply (atomize, blast dest: not_sym)
done

lemma value_in_image: "[| f \<in> X->Y; A \<subseteq> X; a \<in> A |] ==> f`a \<in> f``A"
by (fast elim!: image_fun [THEN ssubst])

lemma lesspoll_lemma: "[| ~ A \<prec> B; C \<prec> B |] ==> A - C \<noteq> 0"
apply (unfold lesspoll_def)
apply (fast dest!: Diff_eq_0_iff [THEN iffD1, THEN subset_imp_lepoll]
            intro!: eqpollI elim: notE
            elim!: eqpollE lepoll_trans)
done

theorem DC_WO3: "(\<forall>K. Card(K) \<longrightarrow> DC(K)) ==> WO3"
apply (unfold DC_def WO3_def)
apply (rule allI)
apply (case_tac "A \<prec> Hartog (A)")
apply (fast dest!: lesspoll_imp_ex_lt_eqpoll
            intro!: Ord_Hartog leI [THEN le_imp_subset])
apply (erule allE impE)+
apply (rule Card_Hartog)
apply (erule_tac x = A in allE)
apply (erule_tac x = "{<z1,z2> \<in> Pow (A) *A . z1 \<prec> Hartog (A) & z2 \<notin> z1}"
                 in allE)
apply simp
apply (erule impE, fast elim: lesspoll_lemma [THEN not_emptyE])
apply (erule bexE)
apply (rule Hartog_lepoll_selfE)
apply (rule lepoll_def [THEN def_imp_iff, THEN iffD2])
apply (rule exI, rule fun_Ord_inj, assumption, rule Ord_Hartog)
apply (drule value_in_image)
apply (drule OrdmemD, rule Ord_Hartog, assumption+, erule ltD)
apply (drule ospec)
apply (blast intro: ltI Ord_Hartog, force)
done

(* ********************************************************************** *)
(* WO1 ==> \<forall>K. Card(K) \<longrightarrow> DC(K)                                       *)
(* ********************************************************************** *)

lemma images_eq:
     "[| \<forall>x \<in> A. f`x=g`x; f \<in> Df->Cf; g \<in> Dg->Cg; A \<subseteq> Df; A \<subseteq> Dg |]
      ==> f``A = g``A"
apply (simp (no_asm_simp) add: image_fun)
done

lemma lam_images_eq:
     "[| Ord(a); b \<in> a |] ==> (\<lambda>x \<in> a. h(x))``b = (\<lambda>x \<in> b. h(x))``b"
apply (rule images_eq)
    apply (rule ballI)
    apply (drule OrdmemD [THEN subsetD], assumption+)
    apply simp
   apply (fast elim!: RepFunI OrdmemD intro!: lam_type)+
done

lemma lam_type_RepFun: "(\<lambda>b \<in> a. h(b)) \<in> a -> {h(b). b \<in> a}"
by (fast intro!: lam_type RepFunI)

lemma lemmaX:
     "[| \<forall>Y \<in> Pow(X). Y \<prec> K \<longrightarrow> (\<exists>x \<in> X. <Y, x> \<in> R);
         b \<in> K; Z \<in> Pow(X); Z \<prec> K |]
      ==> {x \<in> X. <Z,x> \<in> R} \<noteq> 0"
by blast

lemma WO1_DC_lemma:
     "[| Card(K); well_ord(X,Q);
         \<forall>Y \<in> Pow(X). Y \<prec> K \<longrightarrow> (\<exists>x \<in> X. <Y, x> \<in> R); b \<in> K |]
      ==> ff(b, X, Q, R) \<in> {x \<in> X. <(\<lambda>c \<in> b. ff(c, X, Q, R))``b, x> \<in> R}"
apply (rule_tac P = "b \<in> K" in impE, (erule_tac [2] asm_rl)+)
apply (rule_tac i=b in Card_is_Ord [THEN Ord_in_Ord, THEN trans_induct],
       assumption+)
apply (rule impI)
apply (rule ff_def [THEN def_transrec, THEN ssubst])
apply (erule the_first_in, fast)
apply (simp add: image_fun [OF lam_type_RepFun subset_refl])
apply (erule lemmaX, assumption)
 apply (blast intro: Card_is_Ord OrdmemD [THEN subsetD])
apply (blast intro: lesspoll_trans1 in_Card_imp_lesspoll RepFun_lepoll)
done

theorem WO1_DC_Card: "WO1 ==> \<forall>K. Card(K) \<longrightarrow> DC(K)"
apply (unfold DC_def WO1_def)
apply (rule allI impI)+
apply (erule allE exE conjE)+
apply (rule_tac x = "\<lambda>b \<in> K. ff (b, X, Ra, R) " in bexI)
 apply (simp add: lam_images_eq [OF Card_is_Ord ltD])
 apply (fast elim!: ltE WO1_DC_lemma [THEN CollectD2])
apply (rule_tac lam_type)
apply (rule WO1_DC_lemma [THEN CollectD1], assumption+)
done

end


section \<open>More on Polynomials\<close>

text \<open>This theory contains several results on content, gcd, primitive part, etc..
  Moreover, there is a slightly improved code-equation for computing the gcd.\<close>

theory Missing_Polynomial_Factorial
  imports "HOL-Computational_Algebra.Polynomial_Factorial"
   Polynomial_Interpolation.Missing_Polynomial
begin

text \<open>Improved code equation for @{const gcd_poly_code}
  which avoids computing the content twice.\<close>
lemma gcd_poly_code_code[code]: "gcd_poly_code p q =
           (if p = 0 then normalize q else if q = 0 then normalize p else let
              c1 = content p;
              c2 = content q;
              p' = map_poly (\<lambda> x. x div c1) p;
              q' = map_poly (\<lambda> x. x div c2) q
              in smult (gcd c1 c2) (gcd_poly_code_aux p' q'))"
  unfolding gcd_poly_code_def Let_def primitive_part_def by simp

lemma gcd_smult: fixes f g :: "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize} poly"
  defines cf: "cf \<equiv> content f"
  and cg: "cg \<equiv> content g"
shows "gcd (smult a f) g = (if a = 0 \<or> f = 0 then normalize g else
  smult (gcd a (cg div (gcd cf cg))) (gcd f g))"
proof (cases "a = 0 \<or> f = 0")
  case False
  let ?c = "content"
  let ?pp = primitive_part
  let ?ua = "unit_factor a"
  let ?na = "normalize a"
  define H where "H = gcd (?c f) (?c g)"
  have "H dvd ?c f" unfolding H_def by auto
  then obtain F where fh: "?c f = H * F" unfolding dvd_def by blast
  from False have cf0: "?c f \<noteq> 0" by auto
  hence H: "H \<noteq> 0" unfolding H_def by auto
  from arg_cong[OF fh, of "\<lambda> f. f div H"] H have F: "F = ?c f div H" by auto
  have "H dvd ?c g" unfolding H_def by auto
  then obtain G where gh: "?c g = H * G" unfolding dvd_def by blast
  from arg_cong[OF gh, of "\<lambda> f. f div H"] H have G: "G = ?c g div H" by auto
  have "coprime F G" using H unfolding F G H_def
    using cf0 div_gcd_coprime by blast
  have "is_unit ?ua" using False by simp
  then have ua: "is_unit [: ?ua :]"
    by (simp add: is_unit_const_poly_iff)
  have "gcd (smult a f) g = smult (gcd (?na * ?c f) (?c g))
     (gcd (smult ?ua (?pp f)) (?pp g))"
    unfolding gcd_poly_decompose[of "smult a f"]
    content_smult primitive_part_smult by simp
  also have "smult ?ua (?pp f) = ?pp f * [: ?ua :]" by simp
  also have "gcd \<dots> (?pp g) = gcd (?pp f) (?pp g)"
    unfolding gcd_mult_unit1[OF ua] ..
  also have "gcd (?na * ?c f) (?c g) = gcd ((?na * F) * H) (G * H)"
    unfolding fh gh by (simp add: ac_simps)
  also have "\<dots> = gcd (?na * F) G * normalize H" unfolding gcd_mult_right gcd.commute[of G]
    by (simp add: normalize_mult)
  also have "normalize H = H" by (metis H_def normalize_gcd)
  finally
  have "gcd (smult a f) g = smult (gcd (?na * F) G) (smult  H (gcd (?pp f) (?pp g)))" by simp
  also have "smult H (gcd (?pp f) (?pp g)) = gcd f g" unfolding H_def
    by (rule gcd_poly_decompose[symmetric])
  also have "gcd (?na * F) G = gcd (F * ?na) G" by (simp add: ac_simps)
  also have "\<dots> = gcd ?na G"
    using \<open>coprime F G\<close> by (simp add: gcd_mult_right_left_cancel ac_simps)
  finally show ?thesis unfolding G H_def cg cf using False by simp
next
  case True
  hence "gcd (smult a f) g = normalize g" by (cases "a = 0", auto)
  thus ?thesis using True by simp
qed

lemma gcd_smult_ex: assumes "a \<noteq> 0"
  shows "\<exists> b. gcd (smult a f) g = smult b (gcd f g) \<and> b \<noteq> 0"
proof (cases "f = 0")
  case True
  thus ?thesis by (intro exI[of _ 1], auto)
next
  case False
  hence id: "(a = 0 \<or> f = 0) = False" using assms by auto
  show ?thesis unfolding gcd_smult id if_False
    by (intro exI conjI, rule refl, insert assms, auto)
qed

lemma primitive_part_idemp[simp]:
  fixes f :: "'a :: {semiring_gcd,normalization_semidom_multiplicative} poly"
  shows "primitive_part (primitive_part f) = primitive_part f"
  by (metis content_primitive_part[of f] primitive_part_eq_0_iff primitive_part_prim)

lemma content_gcd_primitive:
   "f \<noteq> 0 \<Longrightarrow> content (gcd (primitive_part f) g) = 1"
   "f \<noteq> 0 \<Longrightarrow> content (gcd (primitive_part f) (primitive_part g)) = 1"
  by (metis (no_types, lifting) content_dvd_contentI content_primitive_part gcd_dvd1 is_unit_content_iff)+

lemma content_gcd_content: "content (gcd f g) = gcd (content f) (content g)"
  (is "?l = ?r")
proof -
  let ?c = "content"
  have "?l = normalize (gcd (?c f) (?c g)) *
    ?c (gcd (primitive_part f) (primitive_part g))"
    unfolding gcd_poly_decompose[of f g] content_smult ..
  also have "\<dots> = gcd (?c f) (?c g) *
    ?c (gcd (primitive_part f) (primitive_part g))" by simp
  also have "\<dots> = ?r" using content_gcd_primitive[of f g]
    by (metis (no_types, lifting) content_dvd_contentI content_eq_zero_iff
    content_primitive_part gcd_dvd2 gcd_eq_0_iff is_unit_content_iff mult_cancel_left1)
  finally show ?thesis .
qed

lemma gcd_primitive_part:
  "gcd (primitive_part f) (primitive_part g) = normalize (primitive_part (gcd f g))"
  proof(cases "f = 0")
    case True
    show ?thesis unfolding gcd_poly_decompose[of f g] gcd_0_left primitive_part_0 True
      by (simp add: associatedI primitive_part_dvd_primitive_partI)
  next
    case False
    have "normalize 1 = normalize (unit_factor (gcd (content f) (content g)))"
      by (simp add: False)
    then show ?thesis unfolding gcd_poly_decompose[of f g]
      by (metis (no_types) Polynomial.normalize_smult content_gcd_primitive(1)[OF False] content_times_primitive_part normalize_gcd primitive_part_smult)
qed

lemma primitive_part_gcd: "primitive_part (gcd f g)
  = unit_factor (gcd f g) * gcd (primitive_part f) (primitive_part g)"
  unfolding gcd_primitive_part
  by (metis (no_types, lifting)
  content_times_primitive_part gcd.normalize_idem mult_cancel_left2 mult_smult_left
  normalize_eq_0_iff normalize_mult_unit_factor primitive_part_eq_0_iff
  smult_content_normalize_primitive_part unit_factor_mult_normalize)

lemma primitive_part_normalize:
  fixes f :: "'a :: {semiring_gcd,idom_divide,normalization_semidom_multiplicative} poly"
  shows "primitive_part (normalize f) = normalize (primitive_part f)"
proof (cases "f = 0")
  case True
  thus ?thesis by simp
next
  case False
  have "normalize (content (normalize (primitive_part f))) = 1"
    using content_primitive_part[OF False] content_dvd content_const
          content_dvd_contentI dvd_normalize_iff is_unit_content_iff by (metis (no_types))
  then have "content (normalize (primitive_part f)) = 1" by fastforce
  then have "content (normalize f) = 1 * content f"
    by (metis (no_types) content_smult mult.commute normalize_content
    smult_content_normalize_primitive_part)
  then have "content f = content (normalize f)"
    by simp
  then show ?thesis unfolding smult_content_normalize_primitive_part[of f,symmetric]
    by (metis (no_types) False content_times_primitive_part mult.commute mult_cancel_left
                                   mult_smult_right smult_content_normalize_primitive_part)
qed

lemma length_coeffs_primitive_part[simp]: "length (coeffs (primitive_part f)) = length (coeffs f)"
proof (cases "f = 0")
  case False
  hence "length (coeffs f) \<noteq> 0" "length (coeffs (primitive_part f)) \<noteq> 0" by auto
  thus ?thesis using degree_primitive_part[of f, unfolded degree_eq_length_coeffs] by linarith
qed simp

lemma degree_unit_factor[simp]: "degree (unit_factor f) = 0"
  by (simp add: monom_0 unit_factor_poly_def)

lemma degree_normalize[simp]: "degree (normalize f) = degree f"
proof (cases "f = 0")
  case False
  have "degree f = degree (unit_factor f * normalize f)" by simp
  also have "\<dots> = degree (unit_factor f) + degree (normalize f)"
    by (rule degree_mult_eq, insert False, auto)
  finally show ?thesis by simp
qed simp

lemma content_iff: "x dvd content p \<longleftrightarrow> (\<forall> c \<in> set (coeffs p). x dvd c)"
  by (simp add: content_def dvd_gcd_list_iff)

definition primitive where
  "primitive f \<longleftrightarrow> (\<forall>x. (\<forall>y \<in> set (coeffs f). x dvd y) \<longrightarrow> x dvd 1)"

lemma primitiveI:
  assumes "(\<And>x. (\<And>y. y \<in> set (coeffs f) \<Longrightarrow> x dvd y) \<Longrightarrow> x dvd 1)"
  shows "primitive f" by (insert assms, auto simp: primitive_def)

lemma primitiveD:
  assumes "primitive f"
  shows "(\<And>y. y \<in> set (coeffs f) \<Longrightarrow> x dvd y) \<Longrightarrow> x dvd 1"
    by (insert assms, auto simp: primitive_def)

lemma not_primitiveE:
  assumes "\<not> primitive f"
      and "\<And>x. (\<And>y. y \<in> set (coeffs f) \<Longrightarrow> x dvd y) \<Longrightarrow> \<not> x dvd 1 \<Longrightarrow> thesis"
  shows thesis by (insert assms, auto simp: primitive_def)

lemma primitive_iff_content_eq_1[simp]:
  fixes f :: "'a :: semiring_gcd poly"
  shows "primitive f \<longleftrightarrow> content f = 1"
proof(intro iffI primitiveI)
  fix x
  assume "(\<And>y. y \<in> set (coeffs f) \<Longrightarrow> x dvd y)"
  from gcd_list_greatest[of "coeffs f", OF this]
  have "x dvd content f" by (simp add: content_def)
  also assume "content f = 1"
  finally show "x dvd 1".
next
  assume "primitive f"
  from primitiveD[OF this list_gcd[of _ "coeffs f"], folded content_def]
  show "content f = 1" by simp
qed

lemma primitive_prod_list:
  fixes fs :: "'a :: {factorial_semiring,semiring_Gcd,normalization_semidom_multiplicative} poly list"
  assumes "primitive (prod_list fs)" and "f \<in> set fs" shows "primitive f"
proof (insert assms, induct fs arbitrary: f)
  case (Cons f' fs)
  from Cons.prems
  have "is_unit (content f' * content (prod_list fs))" by (auto simp: content_mult)
  from this[unfolded is_unit_mult_iff]
  have "content f' = 1" and "content (prod_list fs) = 1" by auto
  moreover from Cons.prems have "f = f' \<or> f \<in> set fs" by auto
  ultimately show ?case using Cons.hyps[of f] by auto
qed auto

lemma irreducible_imp_primitive:
  fixes f :: "'a :: {idom,semiring_gcd} poly"
  assumes irr: "irreducible f" and deg: "degree f \<noteq> 0" shows "primitive f"
proof (rule ccontr)
  assume not: "\<not> ?thesis"
  then have "\<not> [:content f:] dvd 1" by simp
  moreover have "f = [:content f:] * primitive_part f" by simp
    note Factorial_Ring.irreducibleD[OF irr this]
  ultimately
  have "primitive_part f dvd 1" by auto
  from this[unfolded poly_dvd_1] have "degree f = 0" by auto
  with deg show False by auto
qed

lemma irreducible_primitive_connect:
  fixes f :: "'a :: {idom,semiring_gcd} poly"
  assumes cf: "primitive f" shows "irreducible\<^sub>d f \<longleftrightarrow> irreducible f" (is "?l \<longleftrightarrow> ?r")
proof
  assume l: ?l show ?r
  proof(rule ccontr, elim not_irreducibleE)
    from l have deg: "degree f > 0" by (auto dest: irreducible\<^sub>dD)
    from cf have f0: "f \<noteq> 0" by auto
    then show "f = 0 \<Longrightarrow> False" by auto
    show "f dvd 1 \<Longrightarrow> False" using deg by (auto simp:poly_dvd_1)
    fix a b assume fab: "f = a * b" and a1: "\<not> a dvd 1" and b1: "\<not> b dvd 1"
    then have af: "a dvd f" and bf: "b dvd f" by auto
    with f0 have a0: "a \<noteq> 0" and b0: "b \<noteq> 0" by auto
    from irreducible\<^sub>dD(2)[OF l, of a] af dvd_imp_degree_le[OF af f0]
    have "degree a = 0 \<or> degree a = degree f"
      by (metis degree_smult_le irreducible\<^sub>d_dvd_smult l le_antisym Nat.neq0_conv)
    then show False
    proof(elim disjE)
      assume "degree a = 0"
      then obtain c where ac: "a = [:c:]" by (auto dest: degree0_coeffs)
      from fab[unfolded ac] have "c dvd content f" by (simp add: content_iff coeffs_smult)
      with cf have "c dvd 1" by simp
      then have "a dvd 1" by (auto simp: ac)
      with a1 show False by auto
    next
      assume dega: "degree a = degree f"
      with f0 degree_mult_eq[OF a0 b0] fab have "degree b = 0" by (auto simp: ac_simps)
      then obtain c where bc: "b = [:c:]" by (auto dest: degree0_coeffs)
      from fab[unfolded bc] have "c dvd content f" by (simp add: content_iff coeffs_smult)
      with cf have "c dvd 1" by simp
      then have "b dvd 1" by (auto simp: bc)
      with b1 show False by auto
    qed
  qed
next
  assume r: ?r
  show ?l
  proof(intro irreducible\<^sub>dI)
    show "degree f > 0"
    proof (rule ccontr)
      assume "\<not>degree f > 0"
      then obtain f0 where f: "f = [:f0:]" by (auto dest: degree0_coeffs)
      from cf[unfolded this] have "normalize f0 = 1" by auto
      then have "f0 dvd 1" by (unfold normalize_1_iff)
      with r[unfolded f irreducible_const_poly_iff] show False by auto
    qed
  next
    fix g h assume deg_g: "degree g > 0" and deg_gf: "degree g < degree f" and fgh: "f = g * h"
    with r have "g dvd 1 \<or> h dvd 1" by auto
    with deg_g have "degree h = 0" by (auto simp: poly_dvd_1)
    with deg_gf[unfolded fgh] degree_mult_eq[of g h] show False by (cases "g = 0 \<or> h = 0", auto)
  qed
qed

lemma deg_not_zero_imp_not_unit:
  fixes f:: "'a::{idom_divide,semidom_divide_unit_factor} poly"
  assumes deg_f: "degree f > 0"
  shows "\<not> is_unit f"
proof -
  have "degree (normalize f) > 0"
    using deg_f degree_normalize by auto
  hence "normalize f \<noteq> 1"
    by fastforce
  thus "\<not> is_unit f" using normalize_1_iff by auto
qed

lemma content_pCons[simp]: "content (pCons a p) = gcd a (content p)"
proof(induct p arbitrary: a)
  case 0 show ?case by simp
next
  case (pCons c p)
  then show ?case by (cases "p = 0", auto simp: content_def cCons_def)
qed

lemma content_field_poly:
  fixes f :: "'a :: {field,semiring_gcd} poly"
  shows "content f = (if f = 0 then 0 else 1)"
  by(induct f, auto simp: dvd_field_iff is_unit_normalize)

end


(*  Title:       Executable Transitive Closures of Finite Relations
    Author:      Christian Sternagel <c.sternagel@gmail.com>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

header {* Closure Computation using Lists *}

theory Transitive_Closure_List_Impl
imports Transitive_Closure_Impl
begin

text \<open>
  We provide two algorithms for the computation of the reflexive transitive closure which internally
  work on lists. The first one (@{term rtrancl_list_impl}) computes the closure on demand for a
  given set of initial states. The second one (@{term memo_list_rtrancl}) precomputes the closure
  for each individual state, stores the result, and then only does a look-up.

  For the transitive closure there are the corresponding algorithms @{term trancl_list_impl} and
  @{term memo_list_trancl}.
\<close>

subsection \<open>Computing Closures from Sets On-The-Fly\<close>

text \<open>
  The algorithms are based on the generic algorithms @{const rtrancl_impl} and @{const trancl_impl}
  instantiated by list operations. Here, after computing the successors in a straightforward way,
  we use @{const remdups} to not have duplicates in the results. Moreover, also in the union
  operation we filter to those elements that have not yet been seen. The use of @{const filter} in
  the union operation is preferred over @{const remdups} since by construction the latter set will
  not contain duplicates.
\<close>

definition rtrancl_list_impl :: "('a \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "rtrancl_list_impl = rtrancl_impl
    (\<lambda> r as. remdups (map snd (filter (\<lambda> (a, b). a \<in> set as) r)))
    (\<lambda> xs ys. (filter (\<lambda> x. x \<notin> set ys) xs) @ ys)
    (\<lambda> x xs. x \<in> set xs)
    []"

definition trancl_list_impl :: "('a \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "trancl_list_impl = trancl_impl
    (\<lambda> r as. remdups (map snd (filter (\<lambda> (a, b). a \<in> set as) r)))
    (\<lambda> xs ys. (filter (\<lambda> x. x \<notin> set ys) xs) @ ys)
    (\<lambda> x xs. x \<in> set xs)
    []"

lemma rtrancl_list_impl:
  "set (rtrancl_list_impl r as) = {b. \<exists> a \<in> set as. (a, b) \<in> (set r)\<^sup>*}"
  unfolding rtrancl_list_impl_def
  by (rule set_access_gen.rtrancl_impl, unfold_locales, force+)

lemma trancl_list_impl:
  "set (trancl_list_impl r as) = {b. \<exists> a \<in> set as. (a, b) \<in> (set r)\<^sup>+}"
  unfolding trancl_list_impl_def
  by (rule set_access_gen.trancl_impl, unfold_locales, force+)

subsection \<open>Precomputing Closures for Single States\<close>

text \<open>
  Storing all relevant entries is done by mapping all left-hand sides of the relation to their
  closure. To avoid redundant entries, @{const remdups} is used.
\<close>

definition memo_list_rtrancl :: "('a \<times> 'a) list \<Rightarrow> ('a \<Rightarrow> 'a list)"
where
  "memo_list_rtrancl r =
    (let
      tr = rtrancl_list_impl r;
      rm = map (\<lambda>a. (a, tr [a])) ((remdups \<circ> map fst) r)
    in
      (\<lambda>a. case map_of rm a of
        None \<Rightarrow> [a]
      | Some as \<Rightarrow> as))"

lemma memo_list_rtrancl:
  "set (memo_list_rtrancl r a) = {b. (a, b) \<in> (set r)\<^sup>*}" (is "?l = ?r")
proof -
  let ?rm = "map (\<lambda> a. (a, rtrancl_list_impl r [a])) ((remdups \<circ> map fst) r)"
  show ?thesis
  proof (cases "map_of ?rm a")
    case None
    have one: "?l = {a}"
      unfolding memo_list_rtrancl_def Let_def None
      by auto
    from None [unfolded map_of_eq_None_iff]
    have a: "a \<notin> fst ` set r" by force
    {
      fix b
      assume "b \<in> ?r"
      from this [unfolded rtrancl_power relpow_fun_conv] obtain n f where
        ab: "f 0 = a \<and> f n = b" and steps: "\<And> i. i < n \<Longrightarrow> (f i, f (Suc i)) \<in> set r" by auto
      from ab steps [of 0] a have "a = b"
        by (cases n, force+)
    }
    then have "?r = {a}" by auto
    then show ?thesis unfolding one by simp
  next
    case (Some as)
    have as: "set as = {b. (a, b) \<in> (set r)^*}"
      using map_of_is_SomeD [OF Some]
        rtrancl_list_impl [of r "[a]"] by force
    then show ?thesis unfolding memo_list_rtrancl_def Let_def Some by simp
  qed
qed

definition memo_list_trancl :: "('a \<times> 'a) list \<Rightarrow> ('a \<Rightarrow> 'a list)"
where
  "memo_list_trancl r =
    (let
      tr = trancl_list_impl r;
      rm = map (\<lambda>a. (a, tr [a])) ((remdups \<circ> map fst) r)
    in
      (\<lambda>a. case map_of rm a of
        None \<Rightarrow> []
      | Some as \<Rightarrow> as))"

lemma memo_list_trancl:
  "set (memo_list_trancl r a) = {b. (a, b) \<in> (set r)\<^sup>+}" (is "?l = ?r")
proof -
  let ?rm = "map (\<lambda> a. (a, trancl_list_impl r [a])) ((remdups \<circ> map fst) r)"
  show ?thesis
  proof (cases "map_of ?rm a")
    case None
    have one: "?l = {}"
      unfolding memo_list_trancl_def Let_def None
      by auto
    from None [unfolded map_of_eq_None_iff]
      have a: "a \<notin> fst ` set r" by force
    {
      fix b
      assume "b \<in> ?r"
      from this [unfolded trancl_unfold_left] a have False by force
    }
    then have "?r = {}" by auto
    then show ?thesis unfolding one by simp
  next
    case (Some as)
    have as: "set as = {b. (a, b) \<in> (set r)\<^sup>+}"
      using map_of_is_SomeD [OF Some]
        trancl_list_impl[of r "[a]"] by force
    then show ?thesis unfolding memo_list_trancl_def Let_def Some by simp
  qed
qed

end


text \<open>
Created 2021-09-10, by Anand Shetler
\<close>

theory CommOr
  imports Main

begin

lemma lem_w_1 : "(p \<or> q) \<longrightarrow> (q \<or> p)"
  apply (rule impI)
  apply (erule disjE)
   apply (rule disjI2)
   apply assumption
  apply (rule disjI1)
  apply assumption
  done

text\<open> Apply style proof, more verbose than the preceding proof \<close>
lemma lem_w_2 : "(p \<or> q) \<longrightarrow> (q \<or> p)"
  apply (rule impI)
  apply (rule disjE)
    apply assumption
   apply (rule disjI2)
   apply assumption
  apply (rule disjI1)
  apply assumption
  done

text\<open> Isar style \<close>
lemma lem_x_1 : "(p \<or> q) \<longrightarrow> (q \<or> p)"
proof
  assume A : "(p \<or> q)"
  from A show "(q \<or> p)"
  proof
    assume "p" thus "(q \<or> p)" by (rule disjI2)
    (* you can substitute '..' for 'by (rule disjI2)'*)
  next
    assume "q" thus "(q \<or> p)" by (rule disjI1)
    (* you can substitute '..' for 'by (rule disjI1)'*)
  qed
qed

end


(* Title: Sub_Designs.thy
   Author: Chelsea Edmonds
*)

section \<open>Sub-designs\<close>
text \<open>Sub designs are a relationship between two designs using the subset and submultiset relations
This theory defines the concept at the incidence system level, before extending to defining on
well defined designs\<close>

theory Sub_Designs imports Design_Operations
begin

subsection \<open>Sub-system and Sub-design Locales\<close>
locale sub_set_system = incidence_system \<V> \
  for "\" and "\" and "\<V>" and "\" +
  assumes points_subset: "\ \<subseteq> \<V>"
  assumes blocks_subset: "\ \<subseteq># \"
begin

lemma sub_points: "x \<in> \ \<Longrightarrow> x \<in> \<V>"
  using points_subset by auto

lemma sub_blocks: "bl \<in># \ \<Longrightarrow> bl \<in># \"
  using blocks_subset by auto

lemma sub_blocks_count: "count \ b \<le> count \ b"
  by (simp add: mset_subset_eq_count blocks_subset)

end

locale sub_incidence_system = sub_set_system + ins: incidence_system \ \

locale sub_design = sub_incidence_system + des: design \<V> \
begin

lemma sub_non_empty_blocks: "A \<in># \ \<Longrightarrow> A \<noteq> {}"
  using des.blocks_nempty sub_blocks by simp

sublocale sub_des: design \ \
  using des.finite_sets finite_subset points_subset sub_non_empty_blocks
  by (unfold_locales) (auto)

end

locale proper_sub_set_system = incidence_system \<V> \
  for "\" and "\" and "\<V>" and "\" +
  assumes points_psubset: "\ \<subset> \<V>"
  assumes blocks_subset: "\ \<subseteq># \"
begin

lemma point_sets_ne: "\ \<noteq> \<V>"
  using points_psubset by auto

end

sublocale proper_sub_set_system \<subseteq> sub_set_system
  using points_psubset blocks_subset by (unfold_locales) simp_all

context sub_set_system
begin

lemma sub_is_proper: "\ \<noteq> \<V> \<Longrightarrow> proper_sub_set_system \ \ \<V> \"
  using blocks_subset incidence_system_axioms
  by (simp add: points_subset proper_sub_set_system.intro proper_sub_set_system_axioms_def psubsetI)

end

locale proper_sub_incidence_system = proper_sub_set_system + ins: incidence_system \ \

sublocale proper_sub_incidence_system \<subseteq> sub_incidence_system
  by (unfold_locales)

context sub_incidence_system
begin
lemma sub_is_proper: "\ \<noteq> \<V> \<Longrightarrow> proper_sub_incidence_system \ \ \<V> \"
  by (simp add: ins.incidence_system_axioms proper_sub_incidence_system_def sub_is_proper)

end

locale proper_sub_design = proper_sub_incidence_system + des: design \<V> \

sublocale proper_sub_design \<subseteq> sub_design
  by (unfold_locales)

context sub_design
begin
lemma sub_is_proper: "\ \<noteq> \<V> \<Longrightarrow> proper_sub_design \ \ \<V> \"
  by (simp add: des.wf_design proper_sub_design.intro sub_is_proper)

end

lemma ss_proper_implies_sub [intro]: "proper_sub_set_system \ \ \<V> \ \<Longrightarrow> sub_set_system \ \ \<V> \"
  using proper_sub_set_system.axioms(1) proper_sub_set_system.blocks_subset psubsetE
  by (metis proper_sub_set_system.points_psubset sub_set_system.intro sub_set_system_axioms_def)

lemma sub_ssI [intro!]: "incidence_system \<V> \ \<Longrightarrow> \ \<subseteq> \<V> \<Longrightarrow> \ \<subseteq># \ \<Longrightarrow> sub_set_system \ \ \<V> \"
  using incidence_system_def subset_iff
  by (unfold_locales) (simp_all add: incidence_system.wellformed)

lemma sub_ss_equality:
  assumes "sub_set_system \ \ \<V> \"
    and "sub_set_system \<V> \ \ \"
  shows "\ = \<V>" and "\ = \"
  using assms(1) assms(2) sub_set_system.points_subset apply blast
  by (meson assms(1) assms(2) sub_set_system.blocks_subset subset_mset.eq_iff)

subsection \<open>Reasoning on Sub-designs\<close>

subsubsection \<open>Reasoning on Incidence Sys property relationships\<close>

context sub_incidence_system
begin

lemma sub_sys_block_sizes: "ins.sys_block_sizes \<subseteq> sys_block_sizes"
  by (auto simp add: sys_block_sizes_def ins.sys_block_sizes_def blocks_subset sub_blocks)

lemma sub_point_rep_number_le: "x \<in> \ \<Longrightarrow> \ rep x \<le> \ rep x"
  by (simp add: point_replication_number_def blocks_subset multiset_filter_mono size_mset_mono)

lemma sub_point_index_le: "ps \<subseteq> \ \<Longrightarrow> \ index ps \<le> \ index ps"
  by (simp add: points_index_def blocks_subset multiset_filter_mono size_mset_mono)

lemma sub_sys_intersection_numbers: "ins.intersection_numbers \<subseteq> intersection_numbers"
  apply (auto simp add: intersection_numbers_def ins.intersection_numbers_def)
  by (metis blocks_subset insert_DiffM insert_subset_eq_iff)

end

subsubsection \<open>Reasoning on Incidence Sys/Design operations\<close>
context incidence_system
begin

lemma sub_set_sysI[intro]: "\ \<subseteq> \<V> \<Longrightarrow> \ \<subseteq># \ \<Longrightarrow> sub_set_system \ \ \<V> \"
  by (simp add: sub_ssI incidence_system_axioms)

lemma sub_inc_sysI[intro]: "incidence_system \ \ \<Longrightarrow> \ \<subseteq> \<V> \<Longrightarrow> \ \<subseteq># \ \<Longrightarrow>
    sub_incidence_system \ \ \<V> \"
  by (simp add: sub_incidence_system.intro sub_set_sysI)

lemma multiple_orig_sub_system:
  assumes "n > 0"
  shows "sub_incidence_system \<V> \ \<V> (multiple_blocks n)"
  using multiple_block_in_original wellformed multiple_blocks_sub assms
  by (unfold_locales) simp_all

lemma add_point_sub_sys: "sub_incidence_system \<V> \ (add_point p) \"
  using add_point_wf add_point_def
  by (simp add: sub_ssI subset_insertI incidence_system_axioms sub_incidence_system.intro)

lemma strong_del_point_sub_sys: "sub_incidence_system (del_point p) (str_del_point_blocks p) \<V> \ "
  using strong_del_point_incidence_wf wf_invalid_point del_point_def str_del_point_blocks_def
  by (unfold_locales) (auto)

lemma add_block_sub_sys: "sub_incidence_system \<V> \ (\<V> \<union> b) (add_block b)"
  using add_block_wf wf_invalid_point add_block_def by (unfold_locales) (auto)

lemma delete_block_sub_sys: "sub_incidence_system \<V> (del_block b)  \<V> \ "
  using delete_block_wf delete_block_subset incidence_system_def by (unfold_locales, auto)

end

lemma (in two_set_systems) combine_sub_sys: "sub_incidence_system \<V> \ \<V>\<^sup>+ \\<^sup>+"
  by (unfold_locales) (simp_all)

lemma (in two_set_systems) combine_sub_sys_alt: "sub_incidence_system \<V>' \' \<V>\<^sup>+ \\<^sup>+"
  by (unfold_locales) (simp_all)

context design
begin

lemma sub_designI [intro]: "design \ \ \<Longrightarrow> sub_incidence_system \ \ \<V> \ \<Longrightarrow> sub_design \ \ \<V> \"
  by (simp add: sub_design.intro wf_design)

lemma sub_designII [intro]: "design \ \ \<Longrightarrow> sub_incidence_system \<V> \ \ \ \<Longrightarrow> sub_design \<V> \ \ \"
  by (simp add: sub_design_def)

lemma multiple_orig_sub_des:
  assumes "n > 0"
  shows "sub_design \<V> \ \<V> (multiple_blocks n)"
  using multiple_is_design assms multiple_orig_sub_system by (simp add: sub_design.intro)

lemma add_point_sub_des: "sub_design \<V> \ (add_point p) \"
  using add_point_design add_point_sub_sys sub_design.intro by fastforce

lemma strong_del_point_sub_des: "sub_design (del_point p) (str_del_point_blocks p) \<V> \ "
  using strong_del_point_sub_sys sub_design.intro wf_design by blast

lemma add_block_sub_des: "finite b \<Longrightarrow> b \<noteq> {} \<Longrightarrow> sub_design \<V> \ (\<V> \<union> b) (add_block b)"
  using add_block_sub_sys add_block_design sub_designII by fastforce

lemma delete_block_sub_des: "sub_design \<V> (del_block b) \<V> \ "
  using delete_block_design delete_block_sub_sys sub_designI by auto

end

lemma (in two_designs) combine_sub_des: "sub_design \<V> \ \<V>\<^sup>+ \\<^sup>+"
  by (unfold_locales) (simp_all)

lemma (in two_designs) combine_sub_des_alt: "sub_design \<V>' \' \<V>\<^sup>+ \\<^sup>+"
  by (unfold_locales) (simp_all)

end