section \<open>Projective Space\<close>
theory Projective_Space
  imports Differentiable_Manifold "HOL-Library.Quotient_Set"
begin

text \<open>Some of the main things to note here: double transfer (-> nonzero -> quotient)\<close>

subsection \<open>Subtype of nonzero elements\<close>

lemma open_ne_zero: "open {x::'a::t1_space. x \<noteq> c}"
proof -
  have "{x::'a. x \<noteq> c} = UNIV - {c}" by auto
  also have "open \<dots>" by (rule open_delete; rule open_UNIV)
  finally show ?thesis .
qed

typedef (overloaded) 'a::euclidean_space nonzero = "UNIV - {0::'a::euclidean_space}" by auto

setup_lifting type_definition_nonzero

instantiation nonzero :: (euclidean_space) topological_space
begin

lift_definition open_nonzero::"'a nonzero set \<Rightarrow> bool" is "open::'a set \<Rightarrow> bool" .

instance
  apply standard
  subgoal by transfer (auto simp: open_ne_zero)
  subgoal by transfer auto
  subgoal by transfer auto
  done

end

lemma open_nonzero_openin_transfer:
  "(rel_set (pcr_nonzero A) ===> (=)) (openin (top_of_set (Collect (Domainp (pcr_nonzero A))))) open"
  if "is_equality A"
  unfolding is_equality_def[THEN iffD1, OF that]
proof
  fix X::"'a set" and Y::"'a nonzero set"
  assume t[transfer_rule]: "rel_set (pcr_nonzero (=)) X Y"
  show "openin (top_of_set (Collect (Domainp (pcr_nonzero (=))))) X = open Y"
    apply (auto simp: openin_subtopology)
    subgoal by transfer (auto simp: nonzero.domain_eq open_ne_zero)
    subgoal
      apply transfer
      apply (rule exI[where x=X])
      using t
      by (auto simp: rel_set_def)
    done
qed

instantiation nonzero :: (euclidean_space) scaleR
begin
lift_definition scaleR_nonzero::"real \<Rightarrow> 'a nonzero \<Rightarrow> 'a nonzero" is "\<lambda>c x. if c = 0 then One else c *\<^sub>R x"
  by auto
instance ..

end

instantiation nonzero :: (euclidean_space) plus
begin
lift_definition plus_nonzero::"'a nonzero \<Rightarrow> 'a nonzero \<Rightarrow> 'a nonzero" is "\<lambda>x y. if x + y = 0 then One else x + y"
  by auto
instance ..
end

instantiation nonzero :: (euclidean_space) minus
begin
lift_definition minus_nonzero::"'a nonzero \<Rightarrow> 'a nonzero \<Rightarrow> 'a nonzero" is "\<lambda>x y. if x = y then One else x - y"
  by auto
instance ..
end

instantiation nonzero :: (euclidean_space) dist
begin
lift_definition dist_nonzero::"'a nonzero \<Rightarrow> 'a nonzero \<Rightarrow> real" is dist .
instance ..
end

instantiation nonzero :: (euclidean_space) norm
begin
lift_definition norm_nonzero::"'a nonzero \<Rightarrow> real" is norm .
instance ..
end

instance nonzero :: (euclidean_space) t2_space
  apply standard
  apply transfer
  subgoal for x y
    using hausdorff[of x y]
    apply clarsimp
    subgoal for U V
      apply (rule exI[where x="U - {0}"])
      apply clarsimp
      apply (rule conjI) defer
       apply (rule exI[where x="V - {0}"])
      by auto
    done
  done

lemma scaleR_one_nonzero[simp]: "1 *\<^sub>R x = (x::_ nonzero)"
  by transfer auto

lemma scaleR_scaleR_nonzero[simp]: "b \<noteq> 0 \<Longrightarrow> scaleR a (scaleR b x) = scaleR (a * b) (x::_ nonzero)"
  by transfer auto

instance nonzero :: (euclidean_space) second_countable_topology
proof standard
  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. Abs_nonzero ` (X - {0})) ` A"
  have [transfer_rule]: "rel_set (rel_set (pcr_nonzero (=))) ((\<lambda>X. X - {0})`A) B"
    by (clarsimp simp: B_def rel_set_def pcr_nonzero_def OO_def cr_nonzero_def)
      (metis Abs_nonzero_inverse Diff_iff UNIV_I singleton_iff)
  from \<open>topological_basis A\<close>
  have "topological_basis B"
    unfolding topological_basis_def
    apply transfer
    apply safe
     apply force
    subgoal for X
      apply (drule spec[where x=X])
      apply clarsimp
      subgoal for B'
        apply (rule exI[where x=B'])
        by auto
      done
    done
  then show "\<exists>B::'a nonzero set set. countable B \<and> open = generate_topology B"
    apply (intro exI[where x=B])
    by (auto simp add: B_def \<open>countable A\<close> topological_basis_imp_subbasis)
qed

subsection \<open>Quotient\<close>

inductive proj_rel :: "'a::euclidean_space nonzero \<Rightarrow> 'a nonzero \<Rightarrow> bool" for x where
  "c \<noteq> 0 \<Longrightarrow> proj_rel x (c *\<^sub>R x)"

lemma proj_rel_parametric: "(pcr_nonzero A ===> pcr_nonzero A ===> (=)) proj_rel proj_rel"
  if [transfer_rule]: " ((=) ===> pcr_nonzero A ===> pcr_nonzero A) (*\<^sub>R) (*\<^sub>R)"
    "bi_unique A"
  unfolding proj_rel.simps
  by transfer_prover

quotient_type (overloaded) 'a proj_space = "('a::euclidean_space \<times> real) nonzero" /  proj_rel
  morphisms rep_proj Proj
    parametric proj_rel_parametric
proof (rule equivpI)
  show "reflp proj_rel"
    using proj_rel.intros[where c=1, simplified] by (auto simp: reflp_def)
  show "symp proj_rel"
    unfolding symp_def
    apply (auto elim!: proj_rel.cases)
    subgoal for x c
      by (rule proj_rel.intros[of "inverse c" "c *\<^sub>R x", simplified])
    done
  show "transp proj_rel"
    unfolding transp_def
    by (auto elim!: proj_rel.cases intro!: proj_rel.intros)
qed

lemma surj_Proj: "surj Proj"
  apply safe
  subgoal by force
  subgoal for x by (induct x) auto
  done

definition proj_topology :: "'a::euclidean_space proj_space topology" where
  "proj_topology = map_topology Proj euclidean"

instantiation proj_space :: (euclidean_space) topological_space
begin

definition open_proj_space :: "'a proj_space set \<Rightarrow> bool" where
  "open_proj_space = openin (map_topology Proj euclidean)"

lemma topspace_map_Proj: "topspace (map_topology Proj euclidean) = UNIV"
  using surj_Proj by auto

instance
  apply (rule class.Topological_Spaces.topological_space.of_class.intro)
  unfolding open_proj_space_def
  using surj_Proj
  by (rule topological_space_quotient)

end

lemma open_vimage_ProjI: "open T \<Longrightarrow> open (Proj -` T)"
  by (metis inf_top.right_neutral open_openin open_proj_space_def openin_map_topology topspace_euclidean)
lemma open_vimage_ProjD: "open (Proj -` T) \<Longrightarrow> open T"
  by (metis inf_top.right_neutral open_openin open_proj_space_def openin_map_topology top.extremum topspace_euclidean topspace_map_Proj topspace_map_topology)
lemma open_vimage_Proj_iff[simp]: "open (Proj -` T) = open T"
  by (auto simp: open_vimage_ProjI open_vimage_ProjD)

lemma euclidean_proj_space_def: "euclidean = map_topology Proj euclidean"
  apply (auto simp: topology_eq_iff openin_map_topology)
  subgoal for x by (induction x) auto
  subgoal for _ x by (induction x) auto
  done

lemma continuous_on_proj_spaceI: "continuous_on (S) f" if "continuous_on (Proj -` S) (f o Proj)" "open (S)"
  for f::"_ proj_space \<Rightarrow> _"
 by (metis (no_types, hide_lams) continuous_on_open_vimage open_vimage_Proj_iff that vimage_Int vimage_comp)

lemma open_scaling_nonzero: "c \<noteq> 0 \<Longrightarrow> open s \<Longrightarrow> open ((*\<^sub>R) c ` s::'a::euclidean_space nonzero set)"
  by transfer auto

subsection \<open>Proof of Hausdorff property\<close>

lemma Proj_open_map: "open (Proj ` X)" if "open X"
proof -
  note saturate_eq[of X]
  also have "open ((\<Union>c\<in>UNIV - {0}. (*\<^sub>R) c ` X))"
    apply (rule open_Union)
    apply (rule)
    apply (erule imageE)
    apply simp
    apply (rule open_scaling_nonzero)
     apply (simp)
    apply (rule that)
    done
  finally show ?thesis by simp
qed

lemma proj_rel_transfer[transfer_rule]:
  "(pcr_nonzero A ===> pcr_nonzero A ===> (=))  (\<lambda>x a. \<exists>c. a = sr c x \<and> c \<noteq> 0) proj_rel"
  if [transfer_rule]: "((=) ===> pcr_nonzero A ===> pcr_nonzero A) sr (*\<^sub>R)"
    "bi_unique A"
  unfolding proj_rel.simps
  by (transfer_prover)

lemma bool_aux: "a \<and> (a \<longrightarrow> b) \<longleftrightarrow> a \<and> b" by auto

lemma closed_proj_rel: "closed {(x::'a::euclidean_space nonzero, y::'a nonzero). proj_rel x y}"
proof -
  have closed_proj_rel_euclidean:
    "\<exists>A B. 0 \<notin> A \<and> 0 \<notin> B \<and> open A \<and> open B \<and> a \<in> A \<and> b \<in> B \<and>
      A \<times> B \<subseteq> - {(x, y). (x, y) \<noteq> 0 \<and> (\<exists>c. c \<noteq> 0 \<and> y = c *\<^sub>R x)}"
    if "\<And>c. c \<noteq> 0 \<Longrightarrow> b \<noteq> c *\<^sub>R a" "a \<noteq> 0" "b \<noteq> 0"
    for a b::'a
  proof -\<comment> \<open>explicitly constructing open ``cones'' that are disjoint\<close>
    define a1 where "a1 = a /\<^sub>R norm a"
    define b1 where "b1 = b /\<^sub>R norm b"
    have norm_a1[simp]: "norm a1 = 1" and norm_b1[simp]: "norm b1 = 1"
      using that
      by (auto simp: a1_def b1_def divide_simps)
    have a_alt_def: "a = norm a *\<^sub>R a1" and b_alt_def: "b = norm b *\<^sub>R b1"
      using that
      by (auto simp: a1_def b1_def)
    have a1_neq_b1: "a1 \<noteq> b1" "a1 \<noteq> -b1"
      using that(1)[of "norm b / norm a"] that(2-)
       apply (auto simp: a1_def b1_def divide_simps)
       apply (metis divideR_right divide_inverse inverse_eq_divide norm_eq_zero scaleR_scaleR)
      by (metis (no_types, lifting) add.inverse_inverse b1_def b_alt_def inverse_eq_divide
            scaleR_scaleR scale_eq_0_iff scale_minus_left that(1))
    define e where "e = (1/2) * (min 1 (min (dist a1 b1) (dist (-a1) b1)))"
    have e_less: "2 * e \<le> dist a1 b1" "2 * e \<le> dist (-a1) b1" "e < 1"
      and e_pos: "0 < e"
      using that a1_neq_b1
      by (auto simp: e_def min_def)
    define A1 where "A1 = ball a1 e \<inter> {x. norm x = 1}"
    define B1 where "B1 = ball b1 e \<inter> {x. norm x = 1}"
    have disjoint: "A1 \<inter> B1 = {}" "uminus ` A1 \<inter> B1 = {}"
      using e_less
      apply (auto simp: A1_def B1_def mem_ball)
      apply (smt dist_commute dist_triangle)
      by (smt add_uminus_conv_diff diff_self dist_0_norm dist_add_cancel dist_commute dist_norm dist_triangle)
    have norm_1: "x \<in> A1 \<Longrightarrow> norm x = 1"
      "x \<in> B1 \<Longrightarrow> norm x = 1"
      for x
      by (auto simp: A1_def B1_def)
    define scales where "scales X = {c *\<^sub>R x |c x. c \<noteq> 0 \<and> x \<in> X}" for X::"'a set"
    have scales_mem: "c *\<^sub>R x \<in> (scales X) \<longleftrightarrow> x \<in> (scales X)" if "c \<noteq> 0" for c x X
      apply (auto simp: scales_def)
      apply (metis eq_vector_fraction_iff that)
      apply (metis divisors_zero that)
      done
    define A where "A = scales A1"
    define B where "B = scales B1"

    from disjoint have "A \<inter> B = {}"
      apply (auto simp: A_def B_def mem_ball scales_def, goal_cases)
      by (smt disjoint_iff_not_equal imageI mult_cancel_right norm_1(1) norm_1(2) norm_scaleR
          scaleR_left.minus scale_left_imp_eq scale_minus_right)
    have "0 \<notin> A" "0 \<notin> B" using e_less \<open>a \<noteq> 0\<close> \<open>b \<noteq> 0\<close>
      by (auto simp: A_def B_def A1_def B1_def mem_ball a1_def b1_def scales_def)
    moreover
    let ?S = "top_of_set {x. norm x = 1}"
    have open_scales: "open (scales X)" if "openin ?S X" for X
    proof -
      have X1: "x \<in> X \<Longrightarrow> norm x = 1" for x using that by (auto simp: openin_subtopology)
      have "0 \<notin> X" using that by (auto simp: openin_subtopology)
      have "scales X = (\<lambda>x. x /\<^sub>R norm x) -` (X \<union> uminus ` X) \<inter> (topspace (top_of_set (UNIV - {0})))"
        apply (auto simp: scales_def)
        subgoal for c x using \<open>0 \<notin> X\<close>
          apply (cases "c > 0")
          by (auto simp: X1)
        subgoal by (metis X1 norm_zero zero_neq_one)
        subgoal for x
          apply (rule exI[where x="norm x"])
          apply (rule exI[where x="x /\<^sub>R norm x"])
          by auto
        subgoal for x y apply (rule exI[where x="- norm x"]) apply (rule exI[where x=y])
          apply auto
          by (metis divideR_right norm_eq_zero scale_minus_right)
        done
      also have "openin (top_of_set (UNIV - {0})) \<dots>"
      proof -
        have *: " {y. inverse (norm y) * norm y = 1} = UNIV - {0}"
          by auto
        from that have "openin ?S (uminus ` X)"
          apply (clarsimp simp: openin_subtopology)
          by (auto simp: open_negations intro!: exI[where x="uminus ` T" for T])
        then have "openin ?S (X \<union> uminus ` X)"
          using \<open>openin _ X\<close> by auto
        from _ this show ?thesis
          apply (rule continuous_map_open)
          apply (auto simp: continuous_map_def)
          apply (subst(asm) openin_subtopology)
          apply (auto simp: *)
          apply (subst openin_subtopology)
          apply clarsimp
          subgoal for T
            apply (rule exI[where x="(\<lambda>x. x /\<^sub>R norm x) -` T \<inter> UNIV - {0}"])
            apply (auto simp: Diff_eq)
            apply (rule open_continuous_vimage)
            by (auto intro!: continuous_intros)
          done
      qed
      finally show ?thesis
        apply (subst (asm) openin_subtopology)
        by clarsimp auto
    qed
    have "openin ?S A1" "openin ?S B1"
      by (auto simp: openin_subtopology A1_def B1_def)
    from open_scales[OF this(1)] open_scales[OF this(2)]
    have "open A" "open B" by (simp_all add: A_def B_def)
    moreover
    have "a \<in> A" "b \<in> B"
      by (force simp: A_def B_def A1_def B1_def that e_pos scales_def intro: a_alt_def b_alt_def)+
    moreover
    have False if "c *\<^sub>R p \<in> B" "p \<in> A" "c \<noteq> 0" for p c
      using that \<open>0 \<notin> A\<close> \<open>0 \<notin> B\<close> \<open>A \<inter> B = {}\<close>
      by (auto simp: A_def B_def scales_mem)
    then have "A \<times> B \<subseteq> - {(x, y). (x, y) \<noteq> 0 \<and> (\<exists>c. c \<noteq> 0 \<and> y = c *\<^sub>R x)}"
      by (auto simp: prod_eq_iff)
    ultimately show ?thesis by blast
  qed
  show ?thesis
    unfolding closed_def open_prod_def
    apply transfer
    apply (simp add: split_beta' bool_aux pred_prod.simps)
    apply (rule ballI)
    apply (clarsimp simp: pred_prod.simps[abs_def])
    subgoal for a b
      apply (subgoal_tac "(\<And>c. c \<noteq> 0 \<Longrightarrow> b \<noteq> c *\<^sub>R a)")
      using closed_proj_rel_euclidean[of b a]
       apply clarsimp
      subgoal for A B
        apply (rule exI[where x=A])
        apply (auto intro!: exI[where x=B])
        apply (auto simp: subset_iff prod_eq_iff)
        by blast
      subgoal by auto
      done
    done
qed

lemma closed_Proj_rel: "closed {(x, y). Proj x = Proj y}"
  using closed_proj_rel
  by (smt Collect_cong case_prodE case_prodI2 prod.inject proj_space.abs_eq_iff)

instance proj_space :: (euclidean_space) t2_space
  apply (rule class.Topological_Spaces.t2_space.of_class.intro)
  using open_proj_space_def surj_Proj Proj_open_map closed_Proj_rel
  by (rule t2_space_quotient)

instance proj_space :: (euclidean_space) second_countable_topology
  apply (rule class.Elementary_Topology.second_countable_topology.of_class.intro)
  using open_proj_space_def surj_Proj Proj_open_map
  by (rule second_countable_topology_quotient)

subsection \<open>Charts\<close>

subsubsection \<open>Chart for last coordinate\<close>

lift_definition chart_last_nonzero :: "('a::euclidean_space \<times> real) nonzero \<Rightarrow> 'a" is "\<lambda>(x,c). x /\<^sub>R c" .

lemma chart_last_nonzero_scaleR[simp]: "c \<noteq> 0 \<Longrightarrow> chart_last_nonzero (c *\<^sub>R n) = chart_last_nonzero n"
  by (transfer) auto

lift_definition chart_last :: "'a::euclidean_space proj_space \<Rightarrow> 'a" is chart_last_nonzero
  by (erule proj_rel.cases) auto

lift_definition chart_last_inv_nonzero :: "'a \<Rightarrow> ('a::euclidean_space\<times>real) nonzero" is
  "\<lambda>x. (x, 1)"
  by (auto simp: zero_prod_def)

lift_definition chart_last_inv :: "'a \<Rightarrow> 'a::euclidean_space proj_space" is chart_last_inv_nonzero .

lift_definition chart_last_domain_nonzeroP :: "('a::euclidean_space\<times>real) nonzero \<Rightarrow> bool" is
  "\<lambda>x. snd x \<noteq> 0" .

lift_definition chart_last_domainP :: "'a::euclidean_space proj_space \<Rightarrow> bool" is chart_last_domain_nonzeroP
  unfolding rel_set_def
  by (safe elim!: proj_rel.cases; (transfer,simp))

lemma open_chart_last_domain: "open (Collect chart_last_domainP)"
  unfolding open_proj_space_def
  unfolding openin_map_topology
  apply auto subgoal for x apply (induction x) by auto
  subgoal
    apply transfer
    apply transfer
    unfolding Collect_conj_eq
    apply (rule open_Int)
    by (auto intro!: open_Collect_neq continuous_on_snd)
  done

lemma Proj_vimage_chart_last_domainP: "Proj -` Collect chart_last_domainP = Collect (chart_last_domain_nonzeroP)"
  apply safe
  subgoal by transfer'
  subgoal for x
    by auto transfer
  done

lemma chart_last_continuous:
  notes [transfer_rule] = open_nonzero_openin_transfer
  shows "continuous_on (Collect chart_last_domainP) chart_last"
  apply (rule continuous_on_proj_spaceI)
  unfolding o_def chart_last.abs_eq Proj_vimage_chart_last_domainP
  apply transfer
  subgoal by (auto intro!: continuous_intros simp: split_beta)
  subgoal by (rule open_chart_last_domain)
  done

lemma chart_last_inv_continuous:
  notes [transfer_rule] = open_nonzero_openin_transfer
  shows "continuous_on UNIV chart_last_inv"
  unfolding chart_last_inv_def map_fun_def comp_id
  apply (rule continuous_on_compose)
  subgoal by transfer (auto intro!: continuous_intros)
  subgoal
    by (metis continuous_on_open_vimage continuous_on_subset inf_top.right_neutral open_UNIV open_vimage_Proj_iff top_greatest)
  done

lemma proj_rel_iff: "proj_rel a b \<longleftrightarrow> (\<exists>c\<noteq>0. b = c *\<^sub>R a)"
  by (auto elim!: proj_rel.cases intro!: proj_rel.intros)

lemma chart_last_inverse: "chart_last_inv (chart_last x) = x" if "chart_last_domainP x"
  using that
  apply -
  apply transfer
  unfolding proj_rel_iff
  apply transfer
  apply (simp add: split_beta prod_eq_iff)
  subgoal for x
    by (rule exI[where x="snd x"]) auto
  done

lemma chart_last_inv_inverse: "chart_last (chart_last_inv x) = x"
  apply transfer
  apply transfer
  by auto

lemma chart_last_domainP_chart_last_inv: "chart_last_domainP (chart_last_inv x)"
  apply transfer apply transfer by auto

lemma homeomorphism_chart_last:
  "homeomorphism (Collect chart_last_domainP) UNIV chart_last chart_last_inv"
  apply (auto simp: homeomorphism_def chart_last_inverse chart_last_inv_inverse
      chart_last_continuous chart_last_inv_continuous)
  subgoal
    apply transfer apply transfer apply (auto simp: split_beta')
    subgoal for x by (rule image_eqI[where x="(x, 1)"]) (auto simp: prod_eq_iff)
    done
  subgoal
    apply transfer apply transfer by (auto simp: split_beta')
  subgoal for x
    by (rule image_eqI[where x="chart_last x"]) (auto simp: chart_last_inverse)
  done

lift_definition last_chart::"('a::euclidean_space proj_space, 'a) chart" is
  "(Collect chart_last_domainP, UNIV, chart_last, chart_last_inv)"
  using homeomorphism_chart_last open_chart_last_domain by auto

subsubsection \<open>Charts for first \<open>DIM('a)\<close> coordinates\<close>

lift_definition chart_basis_nonzero :: "'a \<Rightarrow> ('a::euclidean_space\<times>real)nonzero \<Rightarrow> 'a" is
  "\<lambda>b. \<lambda>(x,c). (x + (c - x \<bullet> b) *\<^sub>R b) /\<^sub>R (x \<bullet> b)" .

lift_definition chart_basis :: "'a \<Rightarrow> 'a::euclidean_space proj_space \<Rightarrow> 'a" is
  chart_basis_nonzero
  apply (erule proj_rel.cases)
  apply transfer
  by (auto simp add: divide_simps algebra_simps)

lift_definition chart_basis_domain_nonzeroP :: "'a \<Rightarrow> ('a::euclidean_space\<times>real) nonzero \<Rightarrow> bool" is
  "\<lambda>b (x, _). (x \<bullet> b) \<noteq> 0" .

lift_definition chart_basis_domainP :: "'a \<Rightarrow> 'a::euclidean_space proj_space \<Rightarrow> bool" is chart_basis_domain_nonzeroP
  unfolding rel_set_def
  apply (safe elim!: proj_rel.cases)
  subgoal by transfer auto
  subgoal by transfer auto
  done

lemma Proj_vimage_chart_basis_domainP:
  "Proj -` Collect (chart_basis_domainP b) = Collect (chart_basis_domain_nonzeroP b)"
  apply safe
  subgoal by transfer'
  subgoal for x
    by auto transfer
  done

lemma open_chart_basis_domain: "open (Collect (chart_basis_domainP b))"
  unfolding open_proj_space_def
  unfolding openin_map_topology
  apply auto subgoal for x apply (induction x) by auto
  subgoal
    apply transfer
    apply transfer
    unfolding Collect_conj_eq
    apply (rule open_Int)
     apply (auto intro!: open_Collect_neq continuous_on_fst continuous_on_inner simp: split_beta)
    done
  done

lemma chart_basis_continuous:
  notes [transfer_rule] = open_nonzero_openin_transfer
  shows "continuous_on (Collect (chart_basis_domainP b)) (chart_basis b)"
  apply (rule continuous_on_proj_spaceI)
  unfolding o_def chart_basis.abs_eq Proj_vimage_chart_basis_domainP
   apply transfer
  subgoal by (auto intro!: continuous_intros simp: split_beta)
  subgoal by (rule open_chart_basis_domain)
  done

context
  fixes b::"'a::euclidean_space"
  assumes b: "b \<in> Basis"
begin

lemma b_neq0: "b \<noteq> 0" using b by auto

lift_definition chart_basis_inv_nonzero :: "'a \<Rightarrow> ('a::euclidean_space \<times> real) nonzero" is
  "\<lambda>x. (x + (1 - x \<bullet> b) *\<^sub>R b, x \<bullet> b)"
  apply (auto simp: zero_prod_def)
  using b_neq0 using eq_neg_iff_add_eq_0 by force

lift_definition chart_basis_inv :: "'a \<Rightarrow> 'a::euclidean_space proj_space" is
  chart_basis_inv_nonzero .

lemma chart_basis_inv_continuous:
  notes [transfer_rule] = open_nonzero_openin_transfer
  shows "continuous_on UNIV chart_basis_inv"
  unfolding chart_basis_inv_def map_fun_def comp_id
  apply (rule continuous_on_compose)
  subgoal by transfer (auto intro!: continuous_intros)
  subgoal
    unfolding continuous_map_iff_continuous euclidean_proj_space_def
    using continuous_on_open_invariant open_vimage_Proj_iff by blast
  done

lemma chart_basis_inv_inverse: "chart_basis b (chart_basis_inv x) = x"
  apply transfer
  apply transfer
  using b_neq0 b
  by (auto simp: algebra_simps divide_simps)

lemma chart_basis_inverse: "chart_basis_inv (chart_basis b x) = x" if "chart_basis_domainP b x"
  using that
  apply transfer
  unfolding proj_rel_iff
  apply transfer
  apply (simp add: split_beta prod_eq_iff)
  subgoal for x
    apply (rule exI[where x="fst x \<bullet> b"])
    using b
    by (simp add: algebra_simps)
  done

lemma chart_basis_domainP_chart_basis_inv: "chart_basis_domainP b (chart_basis_inv x)"
  apply transfer apply transfer by (use b in \<open>auto simp: algebra_simps\<close>)

lemma homeomorphism_chart_basis:
  "homeomorphism (Collect (chart_basis_domainP b)) UNIV (chart_basis b) chart_basis_inv"
  apply (auto simp: homeomorphism_def chart_basis_inverse chart_basis_inv_inverse
      chart_basis_continuous chart_basis_inv_continuous)
  subgoal
    apply transfer apply transfer apply (auto simp: split_beta')
    subgoal for x
      apply (rule image_eqI[where x="(x + (1 - (x \<bullet> b)) *\<^sub>R b, x \<bullet> b)"])
      using b
      apply (auto simp add: algebra_simps divide_simps prod_eq_iff)
      by (metis add.right_neutral b_neq0 inner_commute inner_eq_zero_iff inner_right_distrib inner_zero_right)
    done
  subgoal
    apply transfer apply transfer using b by (auto simp: split_beta' algebra_simps)
  subgoal for x
    by (rule image_eqI[where x="chart_basis b x"]) (auto simp: chart_basis_inverse)
  done

lift_definition basis_chart::"('a proj_space, 'a) chart"
  is "(Collect (chart_basis_domainP b), UNIV, chart_basis b, chart_basis_inv)"
  using homeomorphism_chart_basis by (auto simp: open_chart_basis_domain)

end

subsubsection \<open>Atlas\<close>

definition "charts_proj_space = insert last_chart (basis_chart ` Basis)"

lemma chart_last_basis_defined:
  "chart_last_domainP xa \<Longrightarrow> chart_basis_domainP b xa \<Longrightarrow> chart_last xa \<bullet> b \<noteq> 0"
  apply transfer apply transfer by (auto simp: prod_eq_iff)

lemma chart_basis_last_defined:
  "b \<in> Basis \<Longrightarrow> chart_last_domainP xa \<Longrightarrow> chart_basis_domainP b xa \<Longrightarrow> chart_basis b xa \<bullet> b \<noteq> 0"
  apply transfer apply transfer
  by (auto simp: prod_eq_iff algebra_simps)

lemma compat_last_chart: "\<infinity>-smooth_compat last_chart (basis_chart b)"
  if [transfer_rule]: "b \<in> Basis"
  unfolding smooth_compat_def
proof (transfer; auto)
  have "smooth_on {x. x \<bullet> b \<noteq> 0} (chart_basis b \<circ> chart_last_inv)"
    apply transfer
    apply transfer
    by (auto simp: o_def intro!: smooth_on_inverse smooth_on_scaleR smooth_on_inner smooth_on_add
        smooth_on_minus open_Collect_neq continuous_intros)
  then show "smooth_on (chart_last ` (Collect chart_last_domainP \<inter> Collect (chart_basis_domainP b))) (chart_basis b \<circ> chart_last_inv)"
    by (rule smooth_on_subset) (auto simp: chart_last_basis_defined)
next
  have "smooth_on {x. x \<bullet> b \<noteq> 0}  (chart_last \<circ> chart_basis_inv b)"
    apply transfer
    apply transfer
    by (auto simp: o_def intro!: smooth_on_add smooth_on_scaleR smooth_on_minus smooth_on_inverse
        smooth_on_inner open_Collect_neq continuous_intros)
  then show "smooth_on (chart_basis b ` (Collect chart_last_domainP \<inter> Collect (chart_basis_domainP b))) (chart_last \<circ> chart_basis_inv b)"
    by (rule smooth_on_subset) (auto simp: chart_basis_last_defined that)
qed

lemma smooth_on_basis_comp_inv: "smooth_on {x. (x + (1 - x \<bullet> a) *\<^sub>R a) \<bullet> b \<noteq> 0} (chart_basis b \<circ> chart_basis_inv a)"
  if [transfer_rule]: "a \<in> Basis" "b \<in> Basis"
  apply transfer
  apply transfer
  by (auto intro!: smooth_on_add smooth_on_scaleR smooth_on_minus smooth_on_inner smooth_on_inverse
    smooth_on_mult open_Collect_neq continuous_intros simp: o_def algebra_simps inner_Basis)

lemma chart_basis_basis_defined:
  "a \<noteq> b \<Longrightarrow> chart_basis_domainP a xa \<Longrightarrow> chart_basis_domainP b xa \<Longrightarrow> chart_basis a xa \<bullet> b \<noteq> 0"
  if "a \<in> Basis" "b \<in> Basis"
  using that
  apply transfer
  apply transfer
  by (auto simp: algebra_simps inner_Basis prod_eq_iff)

lemma compat_basis_chart: "\<infinity>-smooth_compat (basis_chart a) (basis_chart b)"
  if [transfer_rule]: "a \<in> Basis" "b \<in> Basis"
  apply (cases "a = b")
  subgoal by (auto simp: smooth_compat_refl)
  subgoal
    unfolding smooth_compat_def
    apply (transfer; auto)
    subgoal
      using smooth_on_basis_comp_inv[OF that]
      apply (rule smooth_on_subset)
      by (auto simp: algebra_simps inner_Basis chart_basis_basis_defined that)
    subgoal
      using smooth_on_basis_comp_inv[OF that(2,1)]
      apply (rule smooth_on_subset)
      by (auto simp: algebra_simps inner_Basis chart_basis_basis_defined that)
    done
  done

lemma c_manifold_proj_space: "c_manifold charts_proj_space \<infinity>"
  by standard
    (auto simp: charts_proj_space_def smooth_compat_refl smooth_compat_commute compat_last_chart
      compat_basis_chart)

end


text \<open>Authors: Anthony Bordg and Lawrence Paulson\<close>

theory Set_Extras
  imports "Jacobson_Basic_Algebra.Set_Theory"

begin

text \<open>Some new notation for built-in primitives\<close>

section \<open>Sets\<close>

abbreviation complement_in_of:: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" ("_\<setminus>_" [65,65]65)
  where "A \<setminus> B \<equiv> A-B"

section \<open>Functions\<close>

abbreviation preimage:: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> 'a set" ("_ \<^sup>\<inverse> _ _" [90,90,1000]90)
  where "f\<^sup>\<inverse> X V \<equiv> (vimage f V) \<inter> X"

lemma preimage_of_inter:
  fixes f::"'a \<Rightarrow> 'b" and X::"'a set" and V::"'b set" and V'::"'b set"
  shows "f\<^sup>\<inverse> X (V \<inter> V') = (f\<^sup>\<inverse> X V) \<inter> (f\<^sup>\<inverse> X V')"
  by blast

lemma preimage_identity_self: "identity A \<^sup>\<inverse> A B = B \<inter> A"
  by (simp add: vimage_inter_cong)

text \<open>Simplification actually replaces the RHS by the LHS\<close>
lemma preimage_vimage_eq: "(f \<^sup>\<inverse> (f -` U') U) \<inter> X = f\<^sup>\<inverse> X (U \<inter> U')"
  by simp

definition inverse_map:: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('b \<Rightarrow> 'a)"
  where "inverse_map f S T \<equiv> restrict (inv_into S f) T"

lemma bijective_map_preimage:
  assumes "bijective_map f S T"
  shows "bijective_map (inverse_map f S T) T S"
proof
  show "inverse_map f S T \<in> T \<rightarrow>\<^sub>E S"
    by (simp add: assms bij_betw_imp_funcset bij_betw_inv_into bijective.bijective bijective_map.axioms(2) inverse_map_def)
  show "bij_betw (inverse_map f S T) T S"
    using assms by (simp add: bij_betw_inv_into bijective_def bijective_map_def inverse_map_def)
qed

lemma inverse_map_identity [simp]:
  "inverse_map (identity S) S S = identity S"
  by (metis Id_compose compose_id_inv_into image_ident image_restrict_eq inv_into_funcset inverse_map_def restrict_extensional)

abbreviation composing ("_ \<circ> _ \<down> _" [60,0,60]59)
  where "g \<circ> f \<down> D \<equiv> compose D g f"

lemma comp_maps:
  assumes "Set_Theory.map \<eta> A B" and "Set_Theory.map \<theta> B C"
  shows "Set_Theory.map (\<theta> \<circ> \<eta> \<down> A) A C"
proof-
  have "(\<theta> \<circ> \<eta> \<down> A) \<in> A \<rightarrow>\<^sub>E C"
    using assms by (metis Int_iff PiE_def compose_def funcset_compose map.graph restrict_extensional)
  thus ?thesis by (simp add: Set_Theory.map_def)
qed

lemma undefined_is_map_on_empty:
  fixes f:: "'a set \<Rightarrow> 'b set"
  assumes "f = (\<lambda>x. undefined)"
  shows "map f {} {}"
  using assms by (simp add: map.intro)

lemma restrict_on_source:
  assumes "map f S T"
  shows "restrict f S = f"
  using assms by (meson PiE_restrict map.graph)

lemma restrict_further:
  assumes "map f S T" and "U \<subseteq> S" and "V \<subseteq> U"
  shows "restrict (restrict f U) V = restrict f V"
  using assms by (simp add: inf.absorb_iff2)

lemma map_eq:
  assumes "map f S T" and "map g S T" and "\<And>x. x \<in> S \<Longrightarrow> f x = g x"
  shows "f = g"
  using assms by (metis restrict_ext restrict_on_source)

lemma image_subset_of_target:
  assumes "map f S T"
  shows "f ` S \<subseteq> T"
  using assms by (meson image_subsetI map.map_closed)

end


(*
    Title:      Bases_Of_Fundamental_Subspaces.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Bases of the four fundamental subspaces\<close>

theory Bases_Of_Fundamental_Subspaces
imports
  Gauss_Jordan_PA
begin

subsection\<open>Computation of the bases of the fundamental subspaces\<close>

definition "basis_null_space A = {row i (P_Gauss_Jordan (transpose A)) | i. to_nat i \<ge> rank A}"
definition "basis_row_space A = {row i (Gauss_Jordan A) |i. row i (Gauss_Jordan A) \<noteq> 0}"
definition "basis_col_space A = {row i (Gauss_Jordan (transpose A)) |i. row i (Gauss_Jordan (transpose A)) \<noteq> 0}"
definition "basis_left_null_space A = {row i (P_Gauss_Jordan A) | i. to_nat i \<ge> rank A}"

subsection\<open>Relatioships amongst the bases\<close>

lemma basis_null_space_eq_basis_left_null_space_transpose:
  "basis_null_space A = basis_left_null_space (transpose A)"
unfolding basis_null_space_def
unfolding basis_left_null_space_def
unfolding rank_transpose[of A, symmetric] ..

lemma basis_null_space_transpose_eq_basis_left_null_space:
shows "basis_null_space (transpose A) = basis_left_null_space A"
by (metis transpose_transpose basis_null_space_eq_basis_left_null_space_transpose)

lemma basis_col_space_eq_basis_row_space_transpose:
  "basis_col_space A = basis_row_space (transpose A)"
unfolding basis_col_space_def basis_row_space_def ..

subsection\<open>Code equations\<close>

text\<open>Code equations to make more efficient the computations.\<close>
lemma basis_null_space_code[code]: "basis_null_space A = (let GJ = Gauss_Jordan_PA (transpose A);
                                                               rank_A = (if A = 0 then 0 else to_nat (GREATEST a. row a (snd GJ) \<noteq> 0) + 1)
                                                               in {row i (fst GJ) | i. to_nat i \<ge> rank_A})"
unfolding basis_null_space_def Let_def P_Gauss_Jordan_def
unfolding Gauss_Jordan_PA_eq
unfolding rank_transpose[symmetric, of A]
unfolding rank_Gauss_Jordan_code[of "transpose A"]
unfolding Let_def
unfolding transpose_zero ..

lemma basis_row_space_code[code]: "basis_row_space A = (let A' = Gauss_Jordan A in {row i A' |i. row i A' \<noteq> 0})"
unfolding basis_row_space_def Let_def ..

lemma basis_col_space_code[code]: "basis_col_space A = (let A' = Gauss_Jordan (transpose A) in {row i A' |i. row i A' \<noteq> 0})"
unfolding basis_col_space_def Let_def ..

lemma basis_left_null_space_code[code]: "basis_left_null_space A = (let GJ = Gauss_Jordan_PA A;
                                                               rank_A = (if A = 0 then 0 else to_nat (GREATEST a. row a (snd GJ) \<noteq> 0) + 1)
                                                               in {row i (fst GJ) | i. to_nat i \<ge> rank_A})"
unfolding basis_left_null_space_def Let_def P_Gauss_Jordan_def
unfolding Gauss_Jordan_PA_eq
unfolding rank_Gauss_Jordan_code[of "A"]
unfolding Let_def
unfolding transpose_zero ..

subsection\<open>Demonstrations that they are bases\<close>

text\<open>We prove that we have obtained a basis for each subspace\<close>

lemma independent_basis_left_null_space:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "vec.independent (basis_left_null_space A)"
proof (unfold basis_left_null_space_def, rule vec.independent_mono)
show "vec.independent (rows (P_Gauss_Jordan A))"
  by (metis P_Gauss_Jordan_def det_dependent_rows invertible_det_nz invertible_fst_Gauss_Jordan_PA)
show "{row i (P_Gauss_Jordan A) |i. rank A \<le> to_nat i} \<subseteq> (rows (P_Gauss_Jordan A))" unfolding rows_def by fast
qed

lemma card_basis_left_null_space_eq_dim:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "card (basis_left_null_space A) = vec.dim (left_null_space A)"
proof -
let ?f="\<lambda>n. row (from_nat (n + (rank A))) (P_Gauss_Jordan A)"
have "card (basis_left_null_space A) = card {row i (P_Gauss_Jordan A) | i. to_nat i \<ge> rank A}" unfolding basis_left_null_space_def ..
also have "... = card {..<(vec.dimension TYPE('a) TYPE('rows)) - rank A}"
  proof (rule bij_betw_same_card[symmetric, of ?f], unfold bij_betw_def, rule conjI)
    show "inj_on ?f {..<(vec.dimension TYPE('a) TYPE('rows)) - rank A}" unfolding inj_on_def
      proof (auto, rule ccontr, unfold dimension_vector)
        fix x y
        assume x: "x <CARD('rows) - rank A"
          and y: "y < CARD('rows) - rank A"
          and eq: "row (from_nat (x + rank A)) (P_Gauss_Jordan A) = row (from_nat (y + rank A)) (P_Gauss_Jordan A)"
          and x_not_y: "x \<noteq> y"
          have "det (P_Gauss_Jordan A) = 0"
            proof (rule det_identical_rows[OF _ eq])
              have "(x + rank A) \<noteq> (y + rank A)" using x_not_y x y by simp
              thus "(from_nat (x + rank A)::'rows) \<noteq> from_nat (y + rank A)" by (metis (mono_tags) from_nat_eq_imp_eq less_diff_conv x y)
            qed
          moreover have "invertible (P_Gauss_Jordan A)" by (metis P_Gauss_Jordan_def invertible_fst_Gauss_Jordan_PA)
          ultimately show False  unfolding invertible_det_nz by contradiction
       qed
       show "?f  ` {..<(vec.dimension TYPE('a) TYPE('rows)) - rank A} = {row i (P_Gauss_Jordan A) |i. rank A \<le> to_nat i}"
       proof (unfold image_def dimension_vector, auto, metis le_add2 less_diff_conv to_nat_from_nat_id)
        fix i::'rows
        assume rank_le_i: "rank A \<le> to_nat i"
        show "\<exists>x\<in>{..<CARD('rows) - rank A}. row i (P_Gauss_Jordan A) = row (from_nat (x + rank A)) (P_Gauss_Jordan A)"
            proof (rule bexI[of _ "(to_nat i - rank A)"])
              have "i = (from_nat (to_nat i - rank A + rank A))" by (metis rank_le_i from_nat_to_nat_id le_add_diff_inverse2)
              thus "row i (P_Gauss_Jordan A) = row (from_nat (to_nat i - rank A + rank A)) (P_Gauss_Jordan A)" by presburger
              show "to_nat i - rank A \<in> {..<CARD('rows) - rank A}" using rank_le_i by (metis diff_less_mono lessThan_def mem_Collect_eq to_nat_less_card)
            qed
        qed
        qed
        also have "... = (vec.dimension TYPE('a) TYPE('rows)) - rank A" unfolding card_lessThan ..
        also have "... = vec.dim (null_space (transpose A))" unfolding dim_null_space rank_transpose ..
        also have "... = vec.dim (left_null_space A)" unfolding left_null_space_eq_null_space_transpose ..
        finally show ?thesis .
qed

lemma basis_left_null_space_in_left_null_space:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "basis_left_null_space A \<subseteq> left_null_space A"
  proof (unfold basis_left_null_space_def left_null_space_def, auto)
    fix i::'rows
    assume rank_le_i: " rank A \<le> to_nat i"
    have "row i (P_Gauss_Jordan A) v* A = ((P_Gauss_Jordan A) $ i) v* A" unfolding row_def vec_nth_inverse ..
    also have "... = ((P_Gauss_Jordan A) ** A) $ i" unfolding row_matrix_matrix_mult by simp
    also have "... = (Gauss_Jordan A) $ i" unfolding P_Gauss_Jordan_def Gauss_Jordan_PA_eq[symmetric] using fst_Gauss_Jordan_PA by metis
    also have "... = 0" by (rule rank_less_row_i_imp_i_is_zero[OF rank_le_i])
    finally show "row i (P_Gauss_Jordan A) v* A = 0" .
qed

lemma left_null_space_subset_span_basis:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows  "left_null_space A \<subseteq> vec.span (basis_left_null_space A)"
proof (rule vec.card_ge_dim_independent)
show "basis_left_null_space A \<subseteq> left_null_space A" by (rule basis_left_null_space_in_left_null_space)
show "vec.independent (basis_left_null_space A)" by (rule independent_basis_left_null_space)
show "vec.dim (left_null_space A) \<le> card (basis_left_null_space A)"
  proof -
    have "{x. x v* A = 0} = {x. (transpose A) *v x = 0}" by (metis transpose_vector)
    thus ?thesis using card_basis_left_null_space_eq_dim by (metis order_refl)
  qed
qed

corollary basis_left_null_space:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "vec.independent (basis_left_null_space A) \<and>
       left_null_space A = vec.span (basis_left_null_space A)"
by (metis basis_left_null_space_in_left_null_space independent_basis_left_null_space
  left_null_space_subset_span_basis vec.span_subspace subspace_left_null_space)

corollary basis_null_space:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "vec.independent (basis_null_space A) \<and>
       null_space A = vec.span (basis_null_space A)"
unfolding basis_null_space_eq_basis_left_null_space_transpose
unfolding null_space_eq_left_null_space_transpose
by (rule basis_left_null_space)

lemma basis_row_space_subset_row_space:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "basis_row_space A \<subseteq> row_space A"
  proof -
    have "basis_row_space A = {row i (Gauss_Jordan A) |i. row i (Gauss_Jordan A) \<noteq> 0}" unfolding basis_row_space_def ..
    also have "... \<subseteq> row_space (Gauss_Jordan A)"
      proof (unfold row_space_def, clarify)
        fix i assume "row i (Gauss_Jordan A) \<noteq> 0"
        show "row i (Gauss_Jordan A) \<in> vec.span (rows (Gauss_Jordan A))"
          using rows_def vec.span_base by auto
      qed
      also have "... = row_space A" unfolding Gauss_Jordan_PA_eq[symmetric] unfolding fst_Gauss_Jordan_PA[symmetric]
      by (rule row_space_is_preserved[OF invertible_fst_Gauss_Jordan_PA])
      finally show ?thesis .
qed

lemma row_space_subset_span_basis_row_space:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "row_space A \<subseteq> vec.span (basis_row_space A)"
proof (rule vec.card_ge_dim_independent)
show "basis_row_space A \<subseteq> row_space A" by (rule basis_row_space_subset_row_space)
show "vec.independent (basis_row_space A)" unfolding basis_row_space_def by (rule independent_not_zero_rows_rref[OF rref_Gauss_Jordan])
show "vec.dim (row_space A) \<le> card (basis_row_space A)"
unfolding basis_row_space_def
using rref_rank[OF rref_Gauss_Jordan, of A] unfolding row_rank_def[symmetric] rank_def[symmetric] rank_Gauss_Jordan[symmetric] by fastforce
qed

lemma basis_row_space:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "vec.independent (basis_row_space A)
  \<and> vec.span (basis_row_space A) = row_space A"
proof (rule conjI)
  show "vec.independent (basis_row_space A)" unfolding basis_row_space_def using independent_not_zero_rows_rref[OF rref_Gauss_Jordan] .
  show "vec.span (basis_row_space A) = row_space A"
    proof (rule vec.span_subspace)
      show "basis_row_space A \<subseteq> row_space A" by (rule basis_row_space_subset_row_space)
      show "row_space A \<subseteq> vec.span (basis_row_space A)" by (rule row_space_subset_span_basis_row_space)
      show "vec.subspace (row_space A)" by (rule subspace_row_space)
    qed
qed

corollary basis_col_space:
fixes A::"'a::{field}^'cols::{mod_type}^'rows::{mod_type}"
shows "vec.independent (basis_col_space A)
  \<and> vec.span (basis_col_space A) = col_space A"
unfolding col_space_eq_row_space_transpose basis_col_space_eq_basis_row_space_transpose
by (rule basis_row_space)

end


(*
  File:      Treap_Sort_and_BSTs.thy
  Authors:   Max Haslbeck
*)
section \<open>Relationship between treaps and BSTs\<close>
theory Treap_Sort_and_BSTs
imports
  Treap
  Random_List_Permutation
  "Random_BSTs.Random_BSTs"
begin

text \<open>
  Here, we will show that if we ``forget'' the priorities of a treap, we essentially get a
  BST into which the elements have been inserted by ascending priority.

  First, we show some facts about sorting that we will need.
\<close>

text \<open>
  The following two lemmas are only important for measurability later.
\<close>
lemma insort_key_conv_rec_list:
  "insort_key f x xs =
     rec_list [x] (\<lambda>y ys zs. if f x \<le> f y then x # y # ys else y # zs) xs"
  by (induction xs) simp_all

lemma insort_key_conv_rec_list':
  "insort_key = (\<lambda>f x.
     rec_list [x] (\<lambda>y ys zs. if f x \<le> f y then x # y # ys else y # zs))"
  by (intro ext) (simp add: insort_key_conv_rec_list)

lemma bst_of_list_trees:
  assumes "set ys \<subseteq> A"
  shows "bst_of_list ys \<in> trees A"
  using assms by (induction ys rule: bst_of_list.induct) auto

lemma insort_wrt_insort_key:
   "a \<in> A \<Longrightarrow>
   set xs \<subseteq> A \<Longrightarrow>
   insert_wrt (linorder_from_keys A f) a xs = insort_key f a xs"
 unfolding linorder_from_keys_def by (induction xs) (auto)

lemma insort_wrt_sort_key:
  assumes "set xs \<subseteq> A"
  shows "insort_wrt (linorder_from_keys A f) xs = sort_key f xs"
  using assms by (induction xs) (auto simp add: insort_wrt_def insort_wrt_insort_key)

text \<open>
  The following is an important recurrence for @{term "sort_key"} that states that for distinct
  priorities, sorting a list w.\,r.\,t.\ those priorities can be seen as selection sort, i.\,e.\
  we can first choose the (unique) element with minimum priority as the first element and then
  sort the rest of the list and append it.
\<close>
lemma sort_key_arg_min_on:
  assumes "zs \<noteq> []"  "inj_on p (set zs)"
  shows "sort_key p (zs::'a::linorder list) =
         (let z = arg_min_on p (set zs) in z # sort_key p (remove1 z zs))"
proof -
  have "mset zs = mset (let z = arg_min_on p (set zs) in z # sort_key p (remove1 z zs))"
  proof -
    define m where "m = arg_min_on p (set zs)"
    have "m \<in> (set zs)"
      unfolding m_def by (rule arg_min_if_finite) (use assms in auto)
    then show ?thesis
      by (auto simp add: Let_def m_def)
  qed
  moreover have "linorder_class.sorted
                 (map p (let z = arg_min_on p (set zs) in z # sort_key p (remove1 z zs)))"
  proof -
    have "set (map p (sort_key p (remove1 (arg_min_on p (set zs)) zs))) \<subseteq> p ` set zs"
      using set_remove1_subset by (fastforce)
    moreover have "\<And>y. y \<in> p ` set zs \<Longrightarrow> p (arg_min_on p (set zs)) \<le> y"
      using arg_min_least assms by force
    ultimately have "linorder_class.sorted
        (p (arg_min_on p (set zs)) # map p (sort_key p (remove1 (arg_min_on p (set zs)) zs)))"
      by (auto)
    then show ?thesis
      by (simp add: Let_def)
  qed
  ultimately show ?thesis
    using sort_key_inj_key_eq assms by blast
qed

lemma arg_min_on_image_finite:
  fixes f :: "'b \<Rightarrow> 'c :: linorder"
  assumes "inj_on f (g ` B)" "finite B" "B \<noteq> {}"
  shows "arg_min_on f (g ` B) = g (arg_min_on (f \<circ> g) B)"
proof -
  note * = arg_min_if_finite[OF \<open>finite B\<close> \<open>B \<noteq> {}\<close>, of \<open>f \<circ> g\<close>]
  show ?thesis
    using assms * arg_min_inj_eq
    by (smt arg_min_if_finite(1) arg_min_least
        comp_apply finite_imageI imageE image_eqI image_is_empty inj_onD less_le)
qed

lemma fst_snd_arg_min_on: fixes p::"'a \<Rightarrow> 'b::linorder"
  assumes "finite B" "inj_on p B" "B \<noteq> {}"
  shows   "fst (arg_min_on snd ((\<lambda>x. (x, p x)) ` B)) = arg_min_on p B"
  by (subst arg_min_on_image_finite [OF inj_on_imageI])
     (auto simp: o_def assms)

text \<open>
  The following is now the main result:
\<close>
theorem treap_of_bst_of_list':
  assumes "ys = map (\<lambda>x. (x, p x)) xs" "inj_on p (set xs)" "xs' = sort_key p xs"
  shows "map_tree fst (treap_of (set ys)) = bst_of_list xs'"
  using assms
proof(induction xs' arbitrary: xs ys rule: bst_of_list.induct)
  case 1
  from \<open>[] = sort_key p xs\<close>[symmetric] \<open>ys = map (\<lambda>x. (x, p x)) xs\<close>
  have "ys = []"
    by (cases xs) (auto)
  then show ?case by (simp add: treap_of.simps)
next
  case (2 z zs)
  note IH = 2(1,2)
  note assms = 2(3,4,5)
  define m where "m = arg_min_on snd (set ys)"
  define ls where "ls = map (\<lambda>x. (x, p x)) [y\<leftarrow>zs . y < z]"
  define rs where "rs = map (\<lambda>x. (x, p x)) [y\<leftarrow>zs . y > z]"
  define L where "L = {p \<in> (set ys). fst p < fst m}"
  define R where "R = {p \<in> (set ys). fst p > fst m}"
  have h1: "set (z#zs) = set xs"
    using assms by simp
  then have h2: "inj_on p {x \<in> set zs. x < z}" "inj_on p (set (filter ((<) z) zs))"
    "inj_on p (set zs)"
    using \<open>inj_on p (set xs)\<close> by (auto intro!: inj_on_subset[of _ "set xs"])
  have "z # zs = (let z = arg_min_on p (set xs) in z # sort_key p (remove1 z xs))"
  proof -
    have "xs \<noteq> []"
      using assms by force
    then show ?thesis
      by (auto simp add: assms intro!: sort_key_arg_min_on)
  qed
  then have h3: "z = arg_min_on p (set xs)" "zs = sort_key p (remove1 z xs)"
    unfolding Let_def by auto
  have h4: "sort_key p zs = zs"
  proof -
    have "linorder_class.sorted (map p (z#zs))"
      using assms by simp
    then have "linorder_class.sorted (map p zs)"
      by auto
    then show ?thesis
      using h1 h2 sort_key_inj_key_eq by blast
  qed
  note helpers = h1 h2 h3 h4
  have "fst m = z"
  proof -
    have "fst m = arg_min_on p (set xs)"
      unfolding m_def using assms by (auto intro!: fst_snd_arg_min_on)
    also have "\<dots> = z"
      using helpers by auto
    finally show ?thesis .
  qed
  moreover have "map_tree fst (treap_of L) = bst_of_list [y\<leftarrow>zs . y < z]"
  proof -
    have "L = set ls"
      unfolding L_def ls_def \<open>fst m = z\<close> using helpers assms by force
    moreover have "map_tree fst (treap_of (set ls)) = bst_of_list [y\<leftarrow>zs . y < z]"
      unfolding ls_def using helpers
      by (intro IH(1)[of _ "[y\<leftarrow>zs . y < z]"]) (auto simp add: filter_sort[symmetric])
    ultimately show ?thesis
      by blast
  qed
  moreover have "map_tree fst (treap_of R) = bst_of_list [y\<leftarrow>zs . z < y]"
  proof -
    have 0: "R = set rs"
      unfolding R_def rs_def \<open>fst m = z\<close> using helpers assms by force
    moreover have "map_tree fst (treap_of (set rs)) = bst_of_list [y\<leftarrow>zs . z < y]"
      unfolding rs_def using helpers
      by (intro IH(2)[of _ "[y\<leftarrow>zs . z < y]"]) (auto simp add: filter_sort[symmetric])
    ultimately show ?thesis
      by blast
  qed
  moreover have "treap_of (set ys) = \<langle>treap_of L, m, treap_of R\<rangle>"
    unfolding L_def m_def R_def using assms by (auto simp add: treap_of.simps Let_def)
  ultimately show ?case by auto
qed

corollary treap_of_bst_of_list: "inj_on p (set zs) \<Longrightarrow>
   map_tree fst (treap_of (set (map (\<lambda>x. (x, p x)) zs))) = bst_of_list (sort_key p zs)"
  using treap_of_bst_of_list' by blast

corollary treap_of_bst_of_list'': "inj_on p (set zs) \<Longrightarrow>
   map_tree fst (treap_of ((\<lambda>x. (x, p x)) ` set zs)) = bst_of_list (sort_key p zs)"
  using treap_of_bst_of_list by auto

corollary fold_ins_bst_of_list: "distinct zs \<Longrightarrow> inj_on p (set zs) \<Longrightarrow>
   map_tree fst (foldl (\<lambda>t (x,p). ins x p t) \<langle>\<rangle> (map (\<lambda>x. (x, p x)) zs)) = bst_of_list (sort_key p zs)"
  by (auto simp add: foldl_ins_treap_of distinct_map inj_on_def inj_on_convol_ident
                     treap_of_bst_of_list'')

end


theory deMorgan1
  imports Main
begin
  text\<open> Apply style \<close>
   lemma lem_k_1 : "\<not>(p \<or> q) \<longrightarrow> (\<not>p \<and> \<not>q)"
    apply (rule impI)
    apply (rule conjI)
    apply (rule notI)
    apply (erule notE)
     apply(rule disjI1)
       apply assumption
      apply (rule notI)
      apply (erule notE)
      apply (rule disjI2)
     apply assumption
    done

end