(*  Author:     John Harrison
    Author:     Robert Himmelmann, TU Muenchen (translation from HOL light)
*)

section \<open>Fashoda meet theorem\<close>

theory Fashoda_Theorem
imports Brouwer_Fixpoint Path_Connected Cartesian_Euclidean_Space
begin

subsection \<open>Bijections between intervals.\<close>

definition interval_bij :: "'a \<times> 'a \<Rightarrow> 'a \<times> 'a \<Rightarrow> 'a \<Rightarrow> 'a::euclidean_space"
  where "interval_bij =
    (\<lambda>(a, b) (u, v) x. (\<Sum>i\<in>Basis. (u\<bullet>i + (x\<bullet>i - a\<bullet>i) / (b\<bullet>i - a\<bullet>i) * (v\<bullet>i - u\<bullet>i)) *\<^sub>R i))"

lemma interval_bij_affine:
  "interval_bij (a,b) (u,v) = (\<lambda>x. (\<Sum>i\<in>Basis. ((v\<bullet>i - u\<bullet>i) / (b\<bullet>i - a\<bullet>i) * (x\<bullet>i)) *\<^sub>R i) +
    (\<Sum>i\<in>Basis. (u\<bullet>i - (v\<bullet>i - u\<bullet>i) / (b\<bullet>i - a\<bullet>i) * (a\<bullet>i)) *\<^sub>R i))"
  by (auto simp: sum.distrib[symmetric] scaleR_add_left[symmetric] interval_bij_def fun_eq_iff
    field_simps inner_simps add_divide_distrib[symmetric] intro!: sum.cong)

lemma continuous_interval_bij:
  fixes a b :: "'a::euclidean_space"
  shows "continuous (at x) (interval_bij (a, b) (u, v))"
  by (auto simp add: divide_inverse interval_bij_def intro!: continuous_sum continuous_intros)

lemma continuous_on_interval_bij: "continuous_on s (interval_bij (a, b) (u, v))"
  apply(rule continuous_at_imp_continuous_on)
  apply (rule, rule continuous_interval_bij)
  done

lemma in_interval_interval_bij:
  fixes a b u v x :: "'a::euclidean_space"
  assumes "x \<in> cbox a b"
    and "cbox u v \<noteq> {}"
  shows "interval_bij (a, b) (u, v) x \<in> cbox u v"
  apply (simp only: interval_bij_def split_conv mem_box inner_sum_left_Basis cong: ball_cong)
  apply safe
proof -
  fix i :: 'a
  assume i: "i \<in> Basis"
  have "cbox a b \<noteq> {}"
    using assms by auto
  with i have *: "a\<bullet>i \<le> b\<bullet>i" "u\<bullet>i \<le> v\<bullet>i"
    using assms(2) by (auto simp add: box_eq_empty)
  have x: "a\<bullet>i\<le>x\<bullet>i" "x\<bullet>i\<le>b\<bullet>i"
    using assms(1)[unfolded mem_box] using i by auto
  have "0 \<le> (x \<bullet> i - a \<bullet> i) / (b \<bullet> i - a \<bullet> i) * (v \<bullet> i - u \<bullet> i)"
    using * x by auto
  then show "u \<bullet> i \<le> u \<bullet> i + (x \<bullet> i - a \<bullet> i) / (b \<bullet> i - a \<bullet> i) * (v \<bullet> i - u \<bullet> i)"
    using * by auto
  have "((x \<bullet> i - a \<bullet> i) / (b \<bullet> i - a \<bullet> i)) * (v \<bullet> i - u \<bullet> i) \<le> 1 * (v \<bullet> i - u \<bullet> i)"
    apply (rule mult_right_mono)
    unfolding divide_le_eq_1
    using * x
    apply auto
    done
  then show "u \<bullet> i + (x \<bullet> i - a \<bullet> i) / (b \<bullet> i - a \<bullet> i) * (v \<bullet> i - u \<bullet> i) \<le> v \<bullet> i"
    using * by auto
qed

lemma interval_bij_bij:
  "\<forall>(i::'a::euclidean_space)\<in>Basis. a\<bullet>i < b\<bullet>i \<and> u\<bullet>i < v\<bullet>i \<Longrightarrow>
    interval_bij (a, b) (u, v) (interval_bij (u, v) (a, b) x) = x"
  by (auto simp: interval_bij_def euclidean_eq_iff[where 'a='a])

lemma interval_bij_bij_cart: fixes x::"real^'n" assumes "\<forall>i. a$i < b$i \<and> u$i < v$i"
  shows "interval_bij (a,b) (u,v) (interval_bij (u,v) (a,b) x) = x"
  using assms by (intro interval_bij_bij) (auto simp: Basis_vec_def inner_axis)

subsection \<open>Fashoda meet theorem\<close>

lemma infnorm_2:
  fixes x :: "real^2"
  shows "infnorm x = max \<bar>x$1\<bar> \<bar>x$2\<bar>"
  unfolding infnorm_cart UNIV_2 by (rule cSup_eq) auto

lemma infnorm_eq_1_2:
  fixes x :: "real^2"
  shows "infnorm x = 1 \<longleftrightarrow>
    \<bar>x$1\<bar> \<le> 1 \<and> \<bar>x$2\<bar> \<le> 1 \<and> (x$1 = -1 \<or> x$1 = 1 \<or> x$2 = -1 \<or> x$2 = 1)"
  unfolding infnorm_2 by auto

lemma infnorm_eq_1_imp:
  fixes x :: "real^2"
  assumes "infnorm x = 1"
  shows "\<bar>x$1\<bar> \<le> 1" and "\<bar>x$2\<bar> \<le> 1"
  using assms unfolding infnorm_eq_1_2 by auto

lemma fashoda_unit:
  fixes f g :: "real \<Rightarrow> real^2"
  assumes "f ` {-1 .. 1} \<subseteq> cbox (-1) 1"
    and "g ` {-1 .. 1} \<subseteq> cbox (-1) 1"
    and "continuous_on {-1 .. 1} f"
    and "continuous_on {-1 .. 1} g"
    and "f (- 1)$1 = - 1"
    and "f 1$1 = 1" "g (- 1) $2 = -1"
    and "g 1 $2 = 1"
  shows "\<exists>s\<in>{-1 .. 1}. \<exists>t\<in>{-1 .. 1}. f s = g t"
proof (rule ccontr)
  assume "\<not> ?thesis"
  note as = this[unfolded bex_simps,rule_format]
  define sqprojection
    where [abs_def]: "sqprojection z = (inverse (infnorm z)) *\<^sub>R z" for z :: "real^2"
  define negatex :: "real^2 \<Rightarrow> real^2"
    where "negatex x = (vector [-(x$1), x$2])" for x
  have lem1: "\<forall>z::real^2. infnorm (negatex z) = infnorm z"
    unfolding negatex_def infnorm_2 vector_2 by auto
  have lem2: "\<forall>z. z \<noteq> 0 \<longrightarrow> infnorm (sqprojection z) = 1"
    unfolding sqprojection_def
    unfolding infnorm_mul[unfolded scalar_mult_eq_scaleR]
    unfolding abs_inverse real_abs_infnorm
    apply (subst infnorm_eq_0[symmetric])
    apply auto
    done
  let ?F = "\<lambda>w::real^2. (f \<circ> (\<lambda>x. x$1)) w - (g \<circ> (\<lambda>x. x$2)) w"
  have *: "\<And>i. (\<lambda>x::real^2. x $ i) ` cbox (- 1) 1 = {-1 .. 1}"
    apply (rule set_eqI)
    unfolding image_iff Bex_def mem_interval_cart interval_cbox_cart
    apply rule
    defer
    apply (rule_tac x="vec x" in exI)
    apply auto
    done
  {
    fix x
    assume "x \<in> (\<lambda>w. (f \<circ> (\<lambda>x. x $ 1)) w - (g \<circ> (\<lambda>x. x $ 2)) w) ` (cbox (- 1) (1::real^2))"
    then obtain w :: "real^2" where w:
        "w \<in> cbox (- 1) 1"
        "x = (f \<circ> (\<lambda>x. x $ 1)) w - (g \<circ> (\<lambda>x. x $ 2)) w"
      unfolding image_iff ..
    then have "x \<noteq> 0"
      using as[of "w$1" "w$2"]
      unfolding mem_interval_cart atLeastAtMost_iff
      by auto
  } note x0 = this
  have 21: "\<And>i::2. i \<noteq> 1 \<Longrightarrow> i = 2"
    using UNIV_2 by auto
  have 1: "box (- 1) (1::real^2) \<noteq> {}"
    unfolding interval_eq_empty_cart by auto
  have 2: "continuous_on (cbox (- 1) 1) (negatex \<circ> sqprojection \<circ> ?F)"
    apply (intro continuous_intros continuous_on_component)
    unfolding *
    apply (rule assms)+
    apply (subst sqprojection_def)
    apply (intro continuous_intros)
    apply (simp add: infnorm_eq_0 x0)
    apply (rule linear_continuous_on)
  proof -
    show "bounded_linear negatex"
      apply (rule bounded_linearI')
      unfolding vec_eq_iff
    proof (rule_tac[!] allI)
      fix i :: 2
      fix x y :: "real^2"
      fix c :: real
      show "negatex (x + y) $ i =
        (negatex x + negatex y) $ i" "negatex (c *\<^sub>R x) $ i = (c *\<^sub>R negatex x) $ i"
        apply -
        apply (case_tac[!] "i\<noteq>1")
        prefer 3
        apply (drule_tac[1-2] 21)
        unfolding negatex_def
        apply (auto simp add:vector_2)
        done
    qed
  qed
  have 3: "(negatex \<circ> sqprojection \<circ> ?F) ` cbox (-1) 1 \<subseteq> cbox (-1) 1"
    unfolding subset_eq
  proof (rule, goal_cases)
    case (1 x)
    then obtain y :: "real^2" where y:
        "y \<in> cbox (- 1) 1"
        "x = (negatex \<circ> sqprojection \<circ> (\<lambda>w. (f \<circ> (\<lambda>x. x $ 1)) w - (g \<circ> (\<lambda>x. x $ 2)) w)) y"
      unfolding image_iff ..
    have "?F y \<noteq> 0"
      apply (rule x0)
      using y(1)
      apply auto
      done
    then have *: "infnorm (sqprojection (?F y)) = 1"
      unfolding y o_def
      by - (rule lem2[rule_format])
    have "infnorm x = 1"
      unfolding *[symmetric] y o_def
      by (rule lem1[rule_format])
    then show "x \<in> cbox (-1) 1"
      unfolding mem_interval_cart interval_cbox_cart infnorm_2
      apply -
      apply rule
    proof -
      fix i
      assume "max \<bar>x $ 1\<bar> \<bar>x $ 2\<bar> = 1"
      then show "(- 1) $ i \<le> x $ i \<and> x $ i \<le> 1 $ i"
        apply (cases "i = 1")
        defer
        apply (drule 21)
        apply auto
        done
    qed
  qed
  obtain x :: "real^2" where x:
      "x \<in> cbox (- 1) 1"
      "(negatex \<circ> sqprojection \<circ> (\<lambda>w. (f \<circ> (\<lambda>x. x $ 1)) w - (g \<circ> (\<lambda>x. x $ 2)) w)) x = x"
    apply (rule brouwer_weak[of "cbox (- 1) (1::real^2)" "negatex \<circ> sqprojection \<circ> ?F"])
    apply (rule compact_cbox convex_box)+
    unfolding interior_cbox
    apply (rule 1 2 3)+
    apply blast
    done
  have "?F x \<noteq> 0"
    apply (rule x0)
    using x(1)
    apply auto
    done
  then have *: "infnorm (sqprojection (?F x)) = 1"
    unfolding o_def
    by (rule lem2[rule_format])
  have nx: "infnorm x = 1"
    apply (subst x(2)[symmetric])
    unfolding *[symmetric] o_def
    apply (rule lem1[rule_format])
    done
  have "\<forall>x i. x \<noteq> 0 \<longrightarrow> (0 < (sqprojection x)$i \<longleftrightarrow> 0 < x$i)"
    and "\<forall>x i. x \<noteq> 0 \<longrightarrow> ((sqprojection x)$i < 0 \<longleftrightarrow> x$i < 0)"
    apply -
    apply (rule_tac[!] allI impI)+
  proof -
    fix x :: "real^2"
    fix i :: 2
    assume x: "x \<noteq> 0"
    have "inverse (infnorm x) > 0"
      using x[unfolded infnorm_pos_lt[symmetric]] by auto
    then show "(0 < sqprojection x $ i) = (0 < x $ i)"
      and "(sqprojection x $ i < 0) = (x $ i < 0)"
      unfolding sqprojection_def vector_component_simps vector_scaleR_component real_scaleR_def
      unfolding zero_less_mult_iff mult_less_0_iff
      by (auto simp add: field_simps)
  qed
  note lem3 = this[rule_format]
  have x1: "x $ 1 \<in> {- 1..1::real}" "x $ 2 \<in> {- 1..1::real}"
    using x(1) unfolding mem_interval_cart by auto
  then have nz: "f (x $ 1) - g (x $ 2) \<noteq> 0"
    unfolding right_minus_eq
    apply -
    apply (rule as)
    apply auto
    done
  have "x $ 1 = -1 \<or> x $ 1 = 1 \<or> x $ 2 = -1 \<or> x $ 2 = 1"
    using nx unfolding infnorm_eq_1_2 by auto
  then show False
  proof -
    fix P Q R S
    presume "P \<or> Q \<or> R \<or> S"
      and "P \<Longrightarrow> False"
      and "Q \<Longrightarrow> False"
      and "R \<Longrightarrow> False"
      and "S \<Longrightarrow> False"
    then show False by auto
  next
    assume as: "x$1 = 1"
    then have *: "f (x $ 1) $ 1 = 1"
      using assms(6) by auto
    have "sqprojection (f (x$1) - g (x$2)) $ 1 < 0"
      using x(2)[unfolded o_def vec_eq_iff,THEN spec[where x=1]]
      unfolding as negatex_def vector_2
      by auto
    moreover
    from x1 have "g (x $ 2) \<in> cbox (-1) 1"
      apply -
      apply (rule assms(2)[unfolded subset_eq,rule_format])
      apply auto
      done
    ultimately show False
      unfolding lem3[OF nz] vector_component_simps * mem_interval_cart
      apply (erule_tac x=1 in allE)
      apply auto
      done
  next
    assume as: "x$1 = -1"
    then have *: "f (x $ 1) $ 1 = - 1"
      using assms(5) by auto
    have "sqprojection (f (x$1) - g (x$2)) $ 1 > 0"
      using x(2)[unfolded o_def vec_eq_iff,THEN spec[where x=1]]
      unfolding as negatex_def vector_2
      by auto
    moreover
    from x1 have "g (x $ 2) \<in> cbox (-1) 1"
      apply -
      apply (rule assms(2)[unfolded subset_eq,rule_format])
      apply auto
      done
    ultimately show False
      unfolding lem3[OF nz] vector_component_simps * mem_interval_cart
      apply (erule_tac x=1 in allE)
      apply auto
      done
  next
    assume as: "x$2 = 1"
    then have *: "g (x $ 2) $ 2 = 1"
      using assms(8) by auto
    have "sqprojection (f (x$1) - g (x$2)) $ 2 > 0"
      using x(2)[unfolded o_def vec_eq_iff,THEN spec[where x=2]]
      unfolding as negatex_def vector_2
      by auto
    moreover
    from x1 have "f (x $ 1) \<in> cbox (-1) 1"
      apply -
      apply (rule assms(1)[unfolded subset_eq,rule_format])
      apply auto
      done
    ultimately show False
      unfolding lem3[OF nz] vector_component_simps * mem_interval_cart
      apply (erule_tac x=2 in allE)
      apply auto
      done
  next
    assume as: "x$2 = -1"
    then have *: "g (x $ 2) $ 2 = - 1"
      using assms(7) by auto
    have "sqprojection (f (x$1) - g (x$2)) $ 2 < 0"
      using x(2)[unfolded o_def vec_eq_iff,THEN spec[where x=2]]
      unfolding as negatex_def vector_2
      by auto
    moreover
    from x1 have "f (x $ 1) \<in> cbox (-1) 1"
      apply -
      apply (rule assms(1)[unfolded subset_eq,rule_format])
      apply auto
      done
    ultimately show False
      unfolding lem3[OF nz] vector_component_simps * mem_interval_cart
      apply (erule_tac x=2 in allE)
      apply auto
      done
  qed auto
qed

lemma fashoda_unit_path:
  fixes f g :: "real \<Rightarrow> real^2"
  assumes "path f"
    and "path g"
    and "path_image f \<subseteq> cbox (-1) 1"
    and "path_image g \<subseteq> cbox (-1) 1"
    and "(pathstart f)$1 = -1"
    and "(pathfinish f)$1 = 1"
    and "(pathstart g)$2 = -1"
    and "(pathfinish g)$2 = 1"
  obtains z where "z \<in> path_image f" and "z \<in> path_image g"
proof -
  note assms=assms[unfolded path_def pathstart_def pathfinish_def path_image_def]
  define iscale where [abs_def]: "iscale z = inverse 2 *\<^sub>R (z + 1)" for z :: real
  have isc: "iscale ` {- 1..1} \<subseteq> {0..1}"
    unfolding iscale_def by auto
  have "\<exists>s\<in>{- 1..1}. \<exists>t\<in>{- 1..1}. (f \<circ> iscale) s = (g \<circ> iscale) t"
  proof (rule fashoda_unit)
    show "(f \<circ> iscale) ` {- 1..1} \<subseteq> cbox (- 1) 1" "(g \<circ> iscale) ` {- 1..1} \<subseteq> cbox (- 1) 1"
      using isc and assms(3-4) by (auto simp add: image_comp [symmetric])
    have *: "continuous_on {- 1..1} iscale"
      unfolding iscale_def by (rule continuous_intros)+
    show "continuous_on {- 1..1} (f \<circ> iscale)" "continuous_on {- 1..1} (g \<circ> iscale)"
      apply -
      apply (rule_tac[!] continuous_on_compose[OF *])
      apply (rule_tac[!] continuous_on_subset[OF _ isc])
      apply (rule assms)+
      done
    have *: "(1 / 2) *\<^sub>R (1 + (1::real^1)) = 1"
      unfolding vec_eq_iff by auto
    show "(f \<circ> iscale) (- 1) $ 1 = - 1"
      and "(f \<circ> iscale) 1 $ 1 = 1"
      and "(g \<circ> iscale) (- 1) $ 2 = -1"
      and "(g \<circ> iscale) 1 $ 2 = 1"
      unfolding o_def iscale_def
      using assms
      by (auto simp add: *)
  qed
  then obtain s t where st:
      "s \<in> {- 1..1}"
      "t \<in> {- 1..1}"
      "(f \<circ> iscale) s = (g \<circ> iscale) t"
    by auto
  show thesis
    apply (rule_tac z = "f (iscale s)" in that)
    using st
    unfolding o_def path_image_def image_iff
    apply -
    apply (rule_tac x="iscale s" in bexI)
    prefer 3
    apply (rule_tac x="iscale t" in bexI)
    using isc[unfolded subset_eq, rule_format]
    apply auto
    done
qed

lemma fashoda:
  fixes b :: "real^2"
  assumes "path f"
    and "path g"
    and "path_image f \<subseteq> cbox a b"
    and "path_image g \<subseteq> cbox a b"
    and "(pathstart f)$1 = a$1"
    and "(pathfinish f)$1 = b$1"
    and "(pathstart g)$2 = a$2"
    and "(pathfinish g)$2 = b$2"
  obtains z where "z \<in> path_image f" and "z \<in> path_image g"
proof -
  fix P Q S
  presume "P \<or> Q \<or> S" "P \<Longrightarrow> thesis" and "Q \<Longrightarrow> thesis" and "S \<Longrightarrow> thesis"
  then show thesis
    by auto
next
  have "cbox a b \<noteq> {}"
    using assms(3) using path_image_nonempty[of f] by auto
  then have "a \<le> b"
    unfolding interval_eq_empty_cart less_eq_vec_def by (auto simp add: not_less)
  then show "a$1 = b$1 \<or> a$2 = b$2 \<or> (a$1 < b$1 \<and> a$2 < b$2)"
    unfolding less_eq_vec_def forall_2 by auto
next
  assume as: "a$1 = b$1"
  have "\<exists>z\<in>path_image g. z$2 = (pathstart f)$2"
    apply (rule connected_ivt_component_cart)
    apply (rule connected_path_image assms)+
    apply (rule pathstart_in_path_image)
    apply (rule pathfinish_in_path_image)
    unfolding assms using assms(3)[unfolded path_image_def subset_eq,rule_format,of "f 0"]
    unfolding pathstart_def
    apply (auto simp add: less_eq_vec_def mem_interval_cart)
    done
  then obtain z :: "real^2" where z: "z \<in> path_image g" "z $ 2 = pathstart f $ 2" ..
  have "z \<in> cbox a b"
    using z(1) assms(4)
    unfolding path_image_def
    by blast
  then have "z = f 0"
    unfolding vec_eq_iff forall_2
    unfolding z(2) pathstart_def
    using assms(3)[unfolded path_image_def subset_eq mem_interval_cart,rule_format,of "f 0" 1]
    unfolding mem_interval_cart
    apply (erule_tac x=1 in allE)
    using as
    apply auto
    done
  then show thesis
    apply -
    apply (rule that[OF _ z(1)])
    unfolding path_image_def
    apply auto
    done
next
  assume as: "a$2 = b$2"
  have "\<exists>z\<in>path_image f. z$1 = (pathstart g)$1"
    apply (rule connected_ivt_component_cart)
    apply (rule connected_path_image assms)+
    apply (rule pathstart_in_path_image)
    apply (rule pathfinish_in_path_image)
    unfolding assms
    using assms(4)[unfolded path_image_def subset_eq,rule_format,of "g 0"]
    unfolding pathstart_def
    apply (auto simp add: less_eq_vec_def mem_interval_cart)
    done
  then obtain z where z: "z \<in> path_image f" "z $ 1 = pathstart g $ 1" ..
  have "z \<in> cbox a b"
    using z(1) assms(3)
    unfolding path_image_def
    by blast
  then have "z = g 0"
    unfolding vec_eq_iff forall_2
    unfolding z(2) pathstart_def
    using assms(4)[unfolded path_image_def subset_eq mem_interval_cart,rule_format,of "g 0" 2]
    unfolding mem_interval_cart
    apply (erule_tac x=2 in allE)
    using as
    apply auto
    done
  then show thesis
    apply -
    apply (rule that[OF z(1)])
    unfolding path_image_def
    apply auto
    done
next
  assume as: "a $ 1 < b $ 1 \<and> a $ 2 < b $ 2"
  have int_nem: "cbox (-1) (1::real^2) \<noteq> {}"
    unfolding interval_eq_empty_cart by auto
  obtain z :: "real^2" where z:
      "z \<in> (interval_bij (a, b) (- 1, 1) \<circ> f) ` {0..1}"
      "z \<in> (interval_bij (a, b) (- 1, 1) \<circ> g) ` {0..1}"
    apply (rule fashoda_unit_path[of "interval_bij (a,b) (- 1,1) \<circ> f" "interval_bij (a,b) (- 1,1) \<circ> g"])
    unfolding path_def path_image_def pathstart_def pathfinish_def
    apply (rule_tac[1-2] continuous_on_compose)
    apply (rule assms[unfolded path_def] continuous_on_interval_bij)+
    unfolding subset_eq
    apply(rule_tac[1-2] ballI)
  proof -
    fix x
    assume "x \<in> (interval_bij (a, b) (- 1, 1) \<circ> f) ` {0..1}"
    then obtain y where y:
        "y \<in> {0..1}"
        "x = (interval_bij (a, b) (- 1, 1) \<circ> f) y"
      unfolding image_iff ..
    show "x \<in> cbox (- 1) 1"
      unfolding y o_def
      apply (rule in_interval_interval_bij)
      using y(1)
      using assms(3)[unfolded path_image_def subset_eq] int_nem
      apply auto
      done
  next
    fix x
    assume "x \<in> (interval_bij (a, b) (- 1, 1) \<circ> g) ` {0..1}"
    then obtain y where y:
        "y \<in> {0..1}"
        "x = (interval_bij (a, b) (- 1, 1) \<circ> g) y"
      unfolding image_iff ..
    show "x \<in> cbox (- 1) 1"
      unfolding y o_def
      apply (rule in_interval_interval_bij)
      using y(1)
      using assms(4)[unfolded path_image_def subset_eq] int_nem
      apply auto
      done
  next
    show "(interval_bij (a, b) (- 1, 1) \<circ> f) 0 $ 1 = -1"
      and "(interval_bij (a, b) (- 1, 1) \<circ> f) 1 $ 1 = 1"
      and "(interval_bij (a, b) (- 1, 1) \<circ> g) 0 $ 2 = -1"
      and "(interval_bij (a, b) (- 1, 1) \<circ> g) 1 $ 2 = 1"
      using assms as
      by (simp_all add: axis_in_Basis cart_eq_inner_axis pathstart_def pathfinish_def interval_bij_def)
         (simp_all add: inner_axis)
  qed
  from z(1) obtain zf where zf:
      "zf \<in> {0..1}"
      "z = (interval_bij (a, b) (- 1, 1) \<circ> f) zf"
    unfolding image_iff ..
  from z(2) obtain zg where zg:
      "zg \<in> {0..1}"
      "z = (interval_bij (a, b) (- 1, 1) \<circ> g) zg"
    unfolding image_iff ..
  have *: "\<forall>i. (- 1) $ i < (1::real^2) $ i \<and> a $ i < b $ i"
    unfolding forall_2
    using as
    by auto
  show thesis
    apply (rule_tac z="interval_bij (- 1,1) (a,b) z" in that)
    apply (subst zf)
    defer
    apply (subst zg)
    unfolding o_def interval_bij_bij_cart[OF *] path_image_def
    using zf(1) zg(1)
    apply auto
    done
qed

subsection \<open>Some slightly ad hoc lemmas I use below\<close>

lemma segment_vertical:
  fixes a :: "real^2"
  assumes "a$1 = b$1"
  shows "x \<in> closed_segment a b \<longleftrightarrow>
    x$1 = a$1 \<and> x$1 = b$1 \<and> (a$2 \<le> x$2 \<and> x$2 \<le> b$2 \<or> b$2 \<le> x$2 \<and> x$2 \<le> a$2)"
  (is "_ = ?R")
proof -
  let ?L = "\<exists>u. (x $ 1 = (1 - u) * a $ 1 + u * b $ 1 \<and> x $ 2 = (1 - u) * a $ 2 + u * b $ 2) \<and> 0 \<le> u \<and> u \<le> 1"
  {
    presume "?L \<Longrightarrow> ?R" and "?R \<Longrightarrow> ?L"
    then show ?thesis
      unfolding closed_segment_def mem_Collect_eq
      unfolding vec_eq_iff forall_2 scalar_mult_eq_scaleR[symmetric] vector_component_simps
      by blast
  }
  {
    assume ?L
    then obtain u where u:
        "x $ 1 = (1 - u) * a $ 1 + u * b $ 1"
        "x $ 2 = (1 - u) * a $ 2 + u * b $ 2"
        "0 \<le> u"
        "u \<le> 1"
      by blast
    { fix b a
      assume "b + u * a > a + u * b"
      then have "(1 - u) * b > (1 - u) * a"
        by (auto simp add:field_simps)
      then have "b \<ge> a"
        apply (drule_tac mult_left_less_imp_less)
        using u
        apply auto
        done
      then have "u * a \<le> u * b"
        apply -
        apply (rule mult_left_mono[OF _ u(3)])
        using u(3-4)
        apply (auto simp add: field_simps)
        done
    } note * = this
    {
      fix a b
      assume "u * b > u * a"
      then have "(1 - u) * a \<le> (1 - u) * b"
        apply -
        apply (rule mult_left_mono)
        apply (drule mult_left_less_imp_less)
        using u
        apply auto
        done
      then have "a + u * b \<le> b + u * a"
        by (auto simp add: field_simps)
    } note ** = this
    then show ?R
      unfolding u assms
      using u
      by (auto simp add:field_simps not_le intro: * **)
  }
  {
    assume ?R
    then show ?L
    proof (cases "x$2 = b$2")
      case True
      then show ?L
        apply (rule_tac x="(x$2 - a$2) / (b$2 - a$2)" in exI)
        unfolding assms True
        using \<open>?R\<close>
        apply (auto simp add: field_simps)
        done
    next
      case False
      then show ?L
        apply (rule_tac x="1 - (x$2 - b$2) / (a$2 - b$2)" in exI)
        unfolding assms
        using \<open>?R\<close>
        apply (auto simp add: field_simps)
        done
    qed
  }
qed

lemma segment_horizontal:
  fixes a :: "real^2"
  assumes "a$2 = b$2"
  shows "x \<in> closed_segment a b \<longleftrightarrow>
    x$2 = a$2 \<and> x$2 = b$2 \<and> (a$1 \<le> x$1 \<and> x$1 \<le> b$1 \<or> b$1 \<le> x$1 \<and> x$1 \<le> a$1)"
  (is "_ = ?R")
proof -
  let ?L = "\<exists>u. (x $ 1 = (1 - u) * a $ 1 + u * b $ 1 \<and> x $ 2 = (1 - u) * a $ 2 + u * b $ 2) \<and> 0 \<le> u \<and> u \<le> 1"
  {
    presume "?L \<Longrightarrow> ?R" and "?R \<Longrightarrow> ?L"
    then show ?thesis
      unfolding closed_segment_def mem_Collect_eq
      unfolding vec_eq_iff forall_2 scalar_mult_eq_scaleR[symmetric] vector_component_simps
      by blast
  }
  {
    assume ?L
    then obtain u where u:
        "x $ 1 = (1 - u) * a $ 1 + u * b $ 1"
        "x $ 2 = (1 - u) * a $ 2 + u * b $ 2"
        "0 \<le> u"
        "u \<le> 1"
      by blast
    {
      fix b a
      assume "b + u * a > a + u * b"
      then have "(1 - u) * b > (1 - u) * a"
        by (auto simp add: field_simps)
      then have "b \<ge> a"
        apply (drule_tac mult_left_less_imp_less)
        using u
        apply auto
        done
      then have "u * a \<le> u * b"
        apply -
        apply (rule mult_left_mono[OF _ u(3)])
        using u(3-4)
        apply (auto simp add: field_simps)
        done
    } note * = this
    {
      fix a b
      assume "u * b > u * a"
      then have "(1 - u) * a \<le> (1 - u) * b"
        apply -
        apply (rule mult_left_mono)
        apply (drule mult_left_less_imp_less)
        using u
        apply auto
        done
      then have "a + u * b \<le> b + u * a"
        by (auto simp add: field_simps)
    } note ** = this
    then show ?R
      unfolding u assms
      using u
      by (auto simp add: field_simps not_le intro: * **)
  }
  {
    assume ?R
    then show ?L
    proof (cases "x$1 = b$1")
      case True
      then show ?L
        apply (rule_tac x="(x$1 - a$1) / (b$1 - a$1)" in exI)
        unfolding assms True
        using \<open>?R\<close>
        apply (auto simp add: field_simps)
        done
    next
      case False
      then show ?L
        apply (rule_tac x="1 - (x$1 - b$1) / (a$1 - b$1)" in exI)
        unfolding assms
        using \<open>?R\<close>
        apply (auto simp add: field_simps)
        done
    qed
  }
qed

subsection \<open>Useful Fashoda corollary pointed out to me by Tom Hales\<close>

lemma fashoda_interlace:
  fixes a :: "real^2"
  assumes "path f"
    and "path g"
    and "path_image f \<subseteq> cbox a b"
    and "path_image g \<subseteq> cbox a b"
    and "(pathstart f)$2 = a$2"
    and "(pathfinish f)$2 = a$2"
    and "(pathstart g)$2 = a$2"
    and "(pathfinish g)$2 = a$2"
    and "(pathstart f)$1 < (pathstart g)$1"
    and "(pathstart g)$1 < (pathfinish f)$1"
    and "(pathfinish f)$1 < (pathfinish g)$1"
  obtains z where "z \<in> path_image f" and "z \<in> path_image g"
proof -
  have "cbox a b \<noteq> {}"
    using path_image_nonempty[of f] using assms(3) by auto
  note ab=this[unfolded interval_eq_empty_cart not_ex forall_2 not_less]
  have "pathstart f \<in> cbox a b"
    and "pathfinish f \<in> cbox a b"
    and "pathstart g \<in> cbox a b"
    and "pathfinish g \<in> cbox a b"
    using pathstart_in_path_image pathfinish_in_path_image
    using assms(3-4)
    by auto
  note startfin = this[unfolded mem_interval_cart forall_2]
  let ?P1 = "linepath (vector[a$1 - 2, a$2 - 2]) (vector[(pathstart f)$1,a$2 - 2]) +++
     linepath(vector[(pathstart f)$1,a$2 - 2])(pathstart f) +++ f +++
     linepath(pathfinish f)(vector[(pathfinish f)$1,a$2 - 2]) +++
     linepath(vector[(pathfinish f)$1,a$2 - 2])(vector[b$1 + 2,a$2 - 2])"
  let ?P2 = "linepath(vector[(pathstart g)$1, (pathstart g)$2 - 3])(pathstart g) +++ g +++
     linepath(pathfinish g)(vector[(pathfinish g)$1,a$2 - 1]) +++
     linepath(vector[(pathfinish g)$1,a$2 - 1])(vector[b$1 + 1,a$2 - 1]) +++
     linepath(vector[b$1 + 1,a$2 - 1])(vector[b$1 + 1,b$2 + 3])"
  let ?a = "vector[a$1 - 2, a$2 - 3]"
  let ?b = "vector[b$1 + 2, b$2 + 3]"
  have P1P2: "path_image ?P1 = path_image (linepath (vector[a$1 - 2, a$2 - 2]) (vector[(pathstart f)$1,a$2 - 2])) \<union>
      path_image (linepath(vector[(pathstart f)$1,a$2 - 2])(pathstart f)) \<union> path_image f \<union>
      path_image (linepath(pathfinish f)(vector[(pathfinish f)$1,a$2 - 2])) \<union>
      path_image (linepath(vector[(pathfinish f)$1,a$2 - 2])(vector[b$1 + 2,a$2 - 2]))"
    "path_image ?P2 = path_image(linepath(vector[(pathstart g)$1, (pathstart g)$2 - 3])(pathstart g)) \<union> path_image g \<union>
      path_image(linepath(pathfinish g)(vector[(pathfinish g)$1,a$2 - 1])) \<union>
      path_image(linepath(vector[(pathfinish g)$1,a$2 - 1])(vector[b$1 + 1,a$2 - 1])) \<union>
      path_image(linepath(vector[b$1 + 1,a$2 - 1])(vector[b$1 + 1,b$2 + 3]))" using assms(1-2)
      by(auto simp add: path_image_join path_linepath)
  have abab: "cbox a b \<subseteq> cbox ?a ?b"
    unfolding interval_cbox_cart[symmetric]
    by (auto simp add:less_eq_vec_def forall_2 vector_2)
  obtain z where
    "z \<in> path_image
          (linepath (vector [a $ 1 - 2, a $ 2 - 2]) (vector [pathstart f $ 1, a $ 2 - 2]) +++
           linepath (vector [pathstart f $ 1, a $ 2 - 2]) (pathstart f) +++
           f +++
           linepath (pathfinish f) (vector [pathfinish f $ 1, a $ 2 - 2]) +++
           linepath (vector [pathfinish f $ 1, a $ 2 - 2]) (vector [b $ 1 + 2, a $ 2 - 2]))"
    "z \<in> path_image
          (linepath (vector [pathstart g $ 1, pathstart g $ 2 - 3]) (pathstart g) +++
           g +++
           linepath (pathfinish g) (vector [pathfinish g $ 1, a $ 2 - 1]) +++
           linepath (vector [pathfinish g $ 1, a $ 2 - 1]) (vector [b $ 1 + 1, a $ 2 - 1]) +++
           linepath (vector [b $ 1 + 1, a $ 2 - 1]) (vector [b $ 1 + 1, b $ 2 + 3]))"
    apply (rule fashoda[of ?P1 ?P2 ?a ?b])
    unfolding pathstart_join pathfinish_join pathstart_linepath pathfinish_linepath vector_2
  proof -
    show "path ?P1" and "path ?P2"
      using assms by auto
    have "path_image ?P1 \<subseteq> cbox ?a ?b"
      unfolding P1P2 path_image_linepath
      apply (rule Un_least)+
      defer 3
      apply (rule_tac[1-4] convex_box(1)[unfolded convex_contains_segment,rule_format])
      unfolding mem_interval_cart forall_2 vector_2
      using ab startfin abab assms(3)
      using assms(9-)
      unfolding assms
      apply (auto simp add: field_simps box_def)
      done
    then show "path_image ?P1 \<subseteq> cbox ?a ?b" .
    have "path_image ?P2 \<subseteq> cbox ?a ?b"
      unfolding P1P2 path_image_linepath
      apply (rule Un_least)+
      defer 2
      apply (rule_tac[1-4] convex_box(1)[unfolded convex_contains_segment,rule_format])
      unfolding mem_interval_cart forall_2 vector_2
      using ab startfin abab assms(4)
      using assms(9-)
      unfolding assms
      apply (auto simp add: field_simps box_def)
      done
    then show "path_image ?P2 \<subseteq> cbox ?a ?b" .
    show "a $ 1 - 2 = a $ 1 - 2"
      and "b $ 1 + 2 = b $ 1 + 2"
      and "pathstart g $ 2 - 3 = a $ 2 - 3"
      and "b $ 2 + 3 = b $ 2 + 3"
      by (auto simp add: assms)
  qed
  note z=this[unfolded P1P2 path_image_linepath]
  show thesis
    apply (rule that[of z])
  proof -
    have "(z \<in> closed_segment (vector [a $ 1 - 2, a $ 2 - 2]) (vector [pathstart f $ 1, a $ 2 - 2]) \<or>
      z \<in> closed_segment (vector [pathstart f $ 1, a $ 2 - 2]) (pathstart f)) \<or>
      z \<in> closed_segment (pathfinish f) (vector [pathfinish f $ 1, a $ 2 - 2]) \<or>
      z \<in> closed_segment (vector [pathfinish f $ 1, a $ 2 - 2]) (vector [b $ 1 + 2, a $ 2 - 2]) \<Longrightarrow>
    (((z \<in> closed_segment (vector [pathstart g $ 1, pathstart g $ 2 - 3]) (pathstart g)) \<or>
      z \<in> closed_segment (pathfinish g) (vector [pathfinish g $ 1, a $ 2 - 1])) \<or>
      z \<in> closed_segment (vector [pathfinish g $ 1, a $ 2 - 1]) (vector [b $ 1 + 1, a $ 2 - 1])) \<or>
      z \<in> closed_segment (vector [b $ 1 + 1, a $ 2 - 1]) (vector [b $ 1 + 1, b $ 2 + 3]) \<Longrightarrow> False"
    proof (simp only: segment_vertical segment_horizontal vector_2, goal_cases)
      case prems: 1
      have "pathfinish f \<in> cbox a b"
        using assms(3) pathfinish_in_path_image[of f] by auto
      then have "1 + b $ 1 \<le> pathfinish f $ 1 \<Longrightarrow> False"
        unfolding mem_interval_cart forall_2 by auto
      then have "z$1 \<noteq> pathfinish f$1"
        using prems(2)
        using assms ab
        by (auto simp add: field_simps)
      moreover have "pathstart f \<in> cbox a b"
        using assms(3) pathstart_in_path_image[of f]
        by auto
      then have "1 + b $ 1 \<le> pathstart f $ 1 \<Longrightarrow> False"
        unfolding mem_interval_cart forall_2
        by auto
      then have "z$1 \<noteq> pathstart f$1"
        using prems(2) using assms ab
        by (auto simp add: field_simps)
      ultimately have *: "z$2 = a$2 - 2"
        using prems(1)
        by auto
      have "z$1 \<noteq> pathfinish g$1"
        using prems(2)
        using assms ab
        by (auto simp add: field_simps *)
      moreover have "pathstart g \<in> cbox a b"
        using assms(4) pathstart_in_path_image[of g]
        by auto
      note this[unfolded mem_interval_cart forall_2]
      then have "z$1 \<noteq> pathstart g$1"
        using prems(1)
        using assms ab
        by (auto simp add: field_simps *)
      ultimately have "a $ 2 - 1 \<le> z $ 2 \<and> z $ 2 \<le> b $ 2 + 3 \<or> b $ 2 + 3 \<le> z $ 2 \<and> z $ 2 \<le> a $ 2 - 1"
        using prems(2)
        unfolding * assms
        by (auto simp add: field_simps)
      then show False
        unfolding * using ab by auto
    qed
    then have "z \<in> path_image f \<or> z \<in> path_image g"
      using z unfolding Un_iff by blast
    then have z': "z \<in> cbox a b"
      using assms(3-4)
      by auto
    have "a $ 2 = z $ 2 \<Longrightarrow> (z $ 1 = pathstart f $ 1 \<or> z $ 1 = pathfinish f $ 1) \<Longrightarrow>
      z = pathstart f \<or> z = pathfinish f"
      unfolding vec_eq_iff forall_2 assms
      by auto
    with z' show "z \<in> path_image f"
      using z(1)
      unfolding Un_iff mem_interval_cart forall_2
      apply -
      apply (simp only: segment_vertical segment_horizontal vector_2)
      unfolding assms
      apply auto
      done
    have "a $ 2 = z $ 2 \<Longrightarrow> (z $ 1 = pathstart g $ 1 \<or> z $ 1 = pathfinish g $ 1) \<Longrightarrow>
      z = pathstart g \<or> z = pathfinish g"
      unfolding vec_eq_iff forall_2 assms
      by auto
    with z' show "z \<in> path_image g"
      using z(2)
      unfolding Un_iff mem_interval_cart forall_2
      apply (simp only: segment_vertical segment_horizontal vector_2)
      unfolding assms
      apply auto
      done
  qed
qed

(** The Following still needs to be translated. Maybe I will do that later.

(* ------------------------------------------------------------------------- *)
(* Complement in dimension N >= 2 of set homeomorphic to any interval in     *)
(* any dimension is (path-)connected. This naively generalizes the argument  *)
(* in Ryuji Maehara's paper "The Jordan curve theorem via the Brouwer        *)
(* fixed point theorem", American Mathematical Monthly 1984.                 *)
(* ------------------------------------------------------------------------- *)

let RETRACTION_INJECTIVE_IMAGE_INTERVAL = prove
 (`!p:real^M->real^N a b.
        ~(interval[a,b] = {}) /\
        p continuous_on interval[a,b] /\
        (!x y. x IN interval[a,b] /\ y IN interval[a,b] /\ p x = p y ==> x = y)
        ==> ?f. f continuous_on (:real^N) /\
                IMAGE f (:real^N) SUBSET (IMAGE p (interval[a,b])) /\
                (!x. x IN (IMAGE p (interval[a,b])) ==> f x = x)`,
  REPEAT STRIP_TAC THEN
  FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [INJECTIVE_ON_LEFT_INVERSE]) THEN
  DISCH_THEN(X_CHOOSE_TAC `q:real^N->real^M`) THEN
  SUBGOAL_THEN `(q:real^N->real^M) continuous_on
                (IMAGE p (interval[a:real^M,b]))`
  ASSUME_TAC THENL
   [MATCH_MP_TAC CONTINUOUS_ON_INVERSE THEN ASM_REWRITE_TAC[COMPACT_INTERVAL];
    ALL_TAC] THEN
  MP_TAC(ISPECL [`q:real^N->real^M`;
                 `IMAGE (p:real^M->real^N)
                 (interval[a,b])`;
                 `a:real^M`; `b:real^M`]
        TIETZE_CLOSED_INTERVAL) THEN
  ASM_SIMP_TAC[COMPACT_INTERVAL; COMPACT_CONTINUOUS_IMAGE;
               COMPACT_IMP_CLOSED] THEN
  ANTS_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN
  DISCH_THEN(X_CHOOSE_THEN `r:real^N->real^M` STRIP_ASSUME_TAC) THEN
  EXISTS_TAC `(p:real^M->real^N) o (r:real^N->real^M)` THEN
  REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; o_THM; IN_UNIV] THEN
  CONJ_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN
  MATCH_MP_TAC CONTINUOUS_ON_COMPOSE THEN ASM_REWRITE_TAC[] THEN
  FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP(REWRITE_RULE[IMP_CONJ]
        CONTINUOUS_ON_SUBSET)) THEN ASM SET_TAC[]);;

let UNBOUNDED_PATH_COMPONENTS_COMPLEMENT_HOMEOMORPHIC_INTERVAL = prove
 (`!s:real^N->bool a b:real^M.
        s homeomorphic (interval[a,b])
        ==> !x. ~(x IN s) ==> ~bounded(path_component((:real^N) DIFF s) x)`,
  REPEAT GEN_TAC THEN REWRITE_TAC[homeomorphic; homeomorphism] THEN
  REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN
  MAP_EVERY X_GEN_TAC [`p':real^N->real^M`; `p:real^M->real^N`] THEN
  DISCH_TAC THEN
  SUBGOAL_THEN
   `!x y. x IN interval[a,b] /\ y IN interval[a,b] /\
          (p:real^M->real^N) x = p y ==> x = y`
  ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN
  FIRST_X_ASSUM(MP_TAC o funpow 4 CONJUNCT2) THEN
  DISCH_THEN(CONJUNCTS_THEN2 (SUBST1_TAC o SYM) ASSUME_TAC) THEN
  ASM_CASES_TAC `interval[a:real^M,b] = {}` THEN
  ASM_REWRITE_TAC[IMAGE_CLAUSES; DIFF_EMPTY; PATH_COMPONENT_UNIV;
                  NOT_BOUNDED_UNIV] THEN
  ABBREV_TAC `s = (:real^N) DIFF (IMAGE p (interval[a:real^M,b]))` THEN
  X_GEN_TAC `c:real^N` THEN REPEAT STRIP_TAC THEN
  SUBGOAL_THEN `(c:real^N) IN s` ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN
  SUBGOAL_THEN `bounded((path_component s c) UNION
                        (IMAGE (p:real^M->real^N) (interval[a,b])))`
  MP_TAC THENL
   [ASM_SIMP_TAC[BOUNDED_UNION; COMPACT_IMP_BOUNDED; COMPACT_IMP_BOUNDED;
                 COMPACT_CONTINUOUS_IMAGE; COMPACT_INTERVAL];
    ALL_TAC] THEN
  DISCH_THEN(MP_TAC o SPEC `c:real^N` o MATCH_MP BOUNDED_SUBSET_BALL) THEN
  REWRITE_TAC[UNION_SUBSET] THEN
  DISCH_THEN(X_CHOOSE_THEN `B:real` STRIP_ASSUME_TAC) THEN
  MP_TAC(ISPECL [`p:real^M->real^N`; `a:real^M`; `b:real^M`]
    RETRACTION_INJECTIVE_IMAGE_INTERVAL) THEN
  ASM_REWRITE_TAC[SUBSET; IN_UNIV] THEN
  DISCH_THEN(X_CHOOSE_THEN `r:real^N->real^N` MP_TAC) THEN
  DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC
   (CONJUNCTS_THEN2 MP_TAC ASSUME_TAC)) THEN
  REWRITE_TAC[FORALL_IN_IMAGE; IN_UNIV] THEN DISCH_TAC THEN
  ABBREV_TAC `q = \z:real^N. if z IN path_component s c then r(z) else z` THEN
  SUBGOAL_THEN
    `(q:real^N->real^N) continuous_on
     (closure(path_component s c) UNION ((:real^N) DIFF (path_component s c)))`
  MP_TAC THENL
   [EXPAND_TAC "q" THEN MATCH_MP_TAC CONTINUOUS_ON_CASES THEN
    REWRITE_TAC[CLOSED_CLOSURE; CONTINUOUS_ON_ID; GSYM OPEN_CLOSED] THEN
    REPEAT CONJ_TAC THENL
     [MATCH_MP_TAC OPEN_PATH_COMPONENT THEN EXPAND_TAC "s" THEN
      ASM_SIMP_TAC[GSYM CLOSED_OPEN; COMPACT_IMP_CLOSED;
                   COMPACT_CONTINUOUS_IMAGE; COMPACT_INTERVAL];
      ASM_MESON_TAC[CONTINUOUS_ON_SUBSET; SUBSET_UNIV];
      ALL_TAC] THEN
    X_GEN_TAC `z:real^N` THEN
    REWRITE_TAC[SET_RULE `~(z IN (s DIFF t) /\ z IN t)`] THEN
    STRIP_TAC THEN FIRST_X_ASSUM MATCH_MP_TAC THEN
    MP_TAC(ISPECL
     [`path_component s (z:real^N)`; `path_component s (c:real^N)`]
     OPEN_INTER_CLOSURE_EQ_EMPTY) THEN
    ASM_REWRITE_TAC[GSYM DISJOINT; PATH_COMPONENT_DISJOINT] THEN ANTS_TAC THENL
     [MATCH_MP_TAC OPEN_PATH_COMPONENT THEN EXPAND_TAC "s" THEN
      ASM_SIMP_TAC[GSYM CLOSED_OPEN; COMPACT_IMP_CLOSED;
                   COMPACT_CONTINUOUS_IMAGE; COMPACT_INTERVAL];
      REWRITE_TAC[DISJOINT; EXTENSION; IN_INTER; NOT_IN_EMPTY] THEN
      DISCH_THEN(MP_TAC o SPEC `z:real^N`) THEN ASM_REWRITE_TAC[] THEN
      GEN_REWRITE_TAC (LAND_CONV o ONCE_DEPTH_CONV) [IN] THEN
      REWRITE_TAC[PATH_COMPONENT_REFL_EQ] THEN ASM SET_TAC[]];
    ALL_TAC] THEN
  SUBGOAL_THEN
   `closure(path_component s c) UNION ((:real^N) DIFF (path_component s c)) =
    (:real^N)`
  SUBST1_TAC THENL
   [MATCH_MP_TAC(SET_RULE `s SUBSET t ==> t UNION (UNIV DIFF s) = UNIV`) THEN
    REWRITE_TAC[CLOSURE_SUBSET];
    DISCH_TAC] THEN
  MP_TAC(ISPECL
   [`(\x. &2 % c - x) o
     (\x. c + B / norm(x - c) % (x - c)) o (q:real^N->real^N)`;
    `cball(c:real^N,B)`]
    BROUWER) THEN
  REWRITE_TAC[NOT_IMP; GSYM CONJ_ASSOC; COMPACT_CBALL; CONVEX_CBALL] THEN
  ASM_SIMP_TAC[CBALL_EQ_EMPTY; REAL_LT_IMP_LE; REAL_NOT_LT] THEN
  SUBGOAL_THEN `!x. ~((q:real^N->real^N) x = c)` ASSUME_TAC THENL
   [X_GEN_TAC `x:real^N` THEN EXPAND_TAC "q" THEN
    REWRITE_TAC[NORM_EQ_0; VECTOR_SUB_EQ] THEN COND_CASES_TAC THEN
    ASM SET_TAC[PATH_COMPONENT_REFL_EQ];
    ALL_TAC] THEN
  REPEAT CONJ_TAC THENL
   [MATCH_MP_TAC CONTINUOUS_ON_COMPOSE THEN
    SIMP_TAC[CONTINUOUS_ON_SUB; CONTINUOUS_ON_ID; CONTINUOUS_ON_CONST] THEN
    MATCH_MP_TAC CONTINUOUS_ON_COMPOSE THEN CONJ_TAC THENL
     [ASM_MESON_TAC[CONTINUOUS_ON_SUBSET; SUBSET_UNIV]; ALL_TAC] THEN
    MATCH_MP_TAC CONTINUOUS_ON_ADD THEN REWRITE_TAC[CONTINUOUS_ON_CONST] THEN
    MATCH_MP_TAC CONTINUOUS_ON_MUL THEN
    SIMP_TAC[CONTINUOUS_ON_SUB; CONTINUOUS_ON_ID; CONTINUOUS_ON_CONST] THEN
    REWRITE_TAC[o_DEF; real_div; LIFT_CMUL] THEN
    MATCH_MP_TAC CONTINUOUS_ON_CMUL THEN
    MATCH_MP_TAC(REWRITE_RULE[o_DEF] CONTINUOUS_ON_INV) THEN
    ASM_REWRITE_TAC[FORALL_IN_IMAGE; NORM_EQ_0; VECTOR_SUB_EQ] THEN
    SUBGOAL_THEN
     `(\x:real^N. lift(norm(x - c))) = (lift o norm) o (\x. x - c)`
    SUBST1_TAC THENL [REWRITE_TAC[o_DEF]; ALL_TAC] THEN
    MATCH_MP_TAC CONTINUOUS_ON_COMPOSE THEN
    ASM_SIMP_TAC[CONTINUOUS_ON_SUB; CONTINUOUS_ON_ID; CONTINUOUS_ON_CONST;
                 CONTINUOUS_ON_LIFT_NORM];
    REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_CBALL; o_THM; dist] THEN
    X_GEN_TAC `x:real^N` THEN DISCH_TAC THEN
    REWRITE_TAC[VECTOR_ARITH `c - (&2 % c - (c + x)) = x`] THEN
    REWRITE_TAC[NORM_MUL; REAL_ABS_DIV; REAL_ABS_NORM] THEN
    ASM_SIMP_TAC[REAL_DIV_RMUL; NORM_EQ_0; VECTOR_SUB_EQ] THEN
    ASM_REAL_ARITH_TAC;
    REWRITE_TAC[NOT_EXISTS_THM; TAUT `~(c /\ b) <=> c ==> ~b`] THEN
    REWRITE_TAC[IN_CBALL; o_THM; dist] THEN
    X_GEN_TAC `x:real^N` THEN DISCH_TAC THEN
    REWRITE_TAC[VECTOR_ARITH `&2 % c - (c + x') = x <=> --x' = x - c`] THEN
    ASM_CASES_TAC `(x:real^N) IN path_component s c` THENL
     [MATCH_MP_TAC(NORM_ARITH `norm(y) < B /\ norm(x) = B ==> ~(--x = y)`) THEN
      REWRITE_TAC[NORM_MUL; REAL_ABS_DIV; REAL_ABS_NORM] THEN
      ASM_SIMP_TAC[REAL_DIV_RMUL; NORM_EQ_0; VECTOR_SUB_EQ] THEN
      ASM_SIMP_TAC[REAL_ARITH `&0 < B ==> abs B = B`] THEN
      UNDISCH_TAC `path_component s c SUBSET ball(c:real^N,B)` THEN
      REWRITE_TAC[SUBSET; IN_BALL] THEN ASM_MESON_TAC[dist; NORM_SUB];
      EXPAND_TAC "q" THEN REWRITE_TAC[] THEN ASM_REWRITE_TAC[] THEN
      REWRITE_TAC[VECTOR_ARITH `--(c % x) = x <=> (&1 + c) % x = vec 0`] THEN
      ASM_REWRITE_TAC[DE_MORGAN_THM; VECTOR_SUB_EQ; VECTOR_MUL_EQ_0] THEN
      SUBGOAL_THEN `~(x:real^N = c)` ASSUME_TAC THENL
       [ASM_MESON_TAC[PATH_COMPONENT_REFL; IN]; ALL_TAC] THEN
      ASM_REWRITE_TAC[] THEN
      MATCH_MP_TAC(REAL_ARITH `&0 < x ==> ~(&1 + x = &0)`) THEN
      ASM_SIMP_TAC[REAL_LT_DIV; NORM_POS_LT; VECTOR_SUB_EQ]]]);;

let PATH_CONNECTED_COMPLEMENT_HOMEOMORPHIC_INTERVAL = prove
 (`!s:real^N->bool a b:real^M.
        2 <= dimindex(:N) /\ s homeomorphic interval[a,b]
        ==> path_connected((:real^N) DIFF s)`,
  REPEAT STRIP_TAC THEN REWRITE_TAC[PATH_CONNECTED_IFF_PATH_COMPONENT] THEN
  FIRST_ASSUM(MP_TAC o MATCH_MP
    UNBOUNDED_PATH_COMPONENTS_COMPLEMENT_HOMEOMORPHIC_INTERVAL) THEN
  ASM_REWRITE_TAC[SET_RULE `~(x IN s) <=> x IN (UNIV DIFF s)`] THEN
  ABBREV_TAC `t = (:real^N) DIFF s` THEN
  DISCH_TAC THEN MAP_EVERY X_GEN_TAC [`x:real^N`; `y:real^N`] THEN
  STRIP_TAC THEN FIRST_ASSUM(MP_TAC o MATCH_MP HOMEOMORPHIC_COMPACTNESS) THEN
  REWRITE_TAC[COMPACT_INTERVAL] THEN
  DISCH_THEN(MP_TAC o MATCH_MP COMPACT_IMP_BOUNDED) THEN
  REWRITE_TAC[BOUNDED_POS; LEFT_IMP_EXISTS_THM] THEN
  X_GEN_TAC `B:real` THEN STRIP_TAC THEN
  SUBGOAL_THEN `(?u:real^N. u IN path_component t x /\ B < norm(u)) /\
                (?v:real^N. v IN path_component t y /\ B < norm(v))`
  STRIP_ASSUME_TAC THENL
   [ASM_MESON_TAC[BOUNDED_POS; REAL_NOT_LE]; ALL_TAC] THEN
  MATCH_MP_TAC PATH_COMPONENT_TRANS THEN EXISTS_TAC `u:real^N` THEN
  CONJ_TAC THENL [ASM_MESON_TAC[IN]; ALL_TAC] THEN
  MATCH_MP_TAC PATH_COMPONENT_SYM THEN
  MATCH_MP_TAC PATH_COMPONENT_TRANS THEN EXISTS_TAC `v:real^N` THEN
  CONJ_TAC THENL [ASM_MESON_TAC[IN]; ALL_TAC] THEN
  MATCH_MP_TAC PATH_COMPONENT_OF_SUBSET THEN
  EXISTS_TAC `(:real^N) DIFF cball(vec 0,B)` THEN CONJ_TAC THENL
   [EXPAND_TAC "t" THEN MATCH_MP_TAC(SET_RULE
     `s SUBSET t ==> (u DIFF t) SUBSET (u DIFF s)`) THEN
    ASM_REWRITE_TAC[SUBSET; IN_CBALL_0];
    MP_TAC(ISPEC `cball(vec 0:real^N,B)`
       PATH_CONNECTED_COMPLEMENT_BOUNDED_CONVEX) THEN
    ASM_REWRITE_TAC[BOUNDED_CBALL; CONVEX_CBALL] THEN
    REWRITE_TAC[PATH_CONNECTED_IFF_PATH_COMPONENT] THEN
    DISCH_THEN MATCH_MP_TAC THEN
    ASM_REWRITE_TAC[IN_DIFF; IN_UNIV; IN_CBALL_0; REAL_NOT_LE]]);;

(* ------------------------------------------------------------------------- *)
(* In particular, apply all these to the special case of an arc.             *)
(* ------------------------------------------------------------------------- *)

let RETRACTION_ARC = prove
 (`!p. arc p
       ==> ?f. f continuous_on (:real^N) /\
               IMAGE f (:real^N) SUBSET path_image p /\
               (!x. x IN path_image p ==> f x = x)`,
  REWRITE_TAC[arc; path; path_image] THEN REPEAT STRIP_TAC THEN
  MATCH_MP_TAC RETRACTION_INJECTIVE_IMAGE_INTERVAL THEN
  ASM_REWRITE_TAC[INTERVAL_EQ_EMPTY_CART_1; DROP_VEC; REAL_NOT_LT; REAL_POS]);;

let PATH_CONNECTED_ARC_COMPLEMENT = prove
 (`!p. 2 <= dimindex(:N) /\ arc p
       ==> path_connected((:real^N) DIFF path_image p)`,
  REWRITE_TAC[arc; path] THEN REPEAT STRIP_TAC THEN SIMP_TAC[path_image] THEN
  MP_TAC(ISPECL [`path_image p:real^N->bool`; `vec 0:real^1`; `vec 1:real^1`]
    PATH_CONNECTED_COMPLEMENT_HOMEOMORPHIC_INTERVAL) THEN
  ASM_REWRITE_TAC[path_image] THEN DISCH_THEN MATCH_MP_TAC THEN
  ONCE_REWRITE_TAC[HOMEOMORPHIC_SYM] THEN
  MATCH_MP_TAC HOMEOMORPHIC_COMPACT THEN
  EXISTS_TAC `p:real^1->real^N` THEN ASM_REWRITE_TAC[COMPACT_INTERVAL]);;

let CONNECTED_ARC_COMPLEMENT = prove
 (`!p. 2 <= dimindex(:N) /\ arc p
       ==> connected((:real^N) DIFF path_image p)`,
  SIMP_TAC[PATH_CONNECTED_ARC_COMPLEMENT; PATH_CONNECTED_IMP_CONNECTED]);; *)

end


section "A Typed Language"

theory Chapter9_Ex4 imports "~~/src/HOL/IMP/Star" Complex_Main begin

text {* We build on @{theory Complex_Main} instead of @{theory Main} to access
the real numbers. *}

subsection "Arithmetic Expressions"

datatype val = Iv int | Rv real | Bv bool

type_synonym vname = string
type_synonym state = "vname \<Rightarrow> val"

text_raw{*\snip{aexptDef}{0}{2}{% *}
datatype exp =  Ic int | Rc real | V vname | Plus exp exp | Bc bool | Not exp | And exp exp | Less exp exp
text_raw{*}%endsnip*}

inductive eval :: "exp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
"eval (Ic i) s (Iv i)" |
"eval (Rc r) s (Rv r)" |
"eval (Bc v) s (Bv v)" |
"eval (V x) s (s x)" |
"eval a1 s (Iv i1) \<Longrightarrow> eval a2 s (Iv i2) \<Longrightarrow> eval (Plus a1 a2) s (Iv(i1+i2))" |
"eval a1 s (Rv r1) \<Longrightarrow> eval a2 s (Rv r2) \<Longrightarrow> eval (Plus a1 a2) s (Rv(r1+r2))" |
"eval b s (Bv bv) \<Longrightarrow> eval (Not b) s (Bv (\<not> bv))" |
"eval b1 s (Bv bv1) \<Longrightarrow> eval b2 s (Bv bv2) \<Longrightarrow> eval (And b1 b2) s (Bv (bv1 & bv2))" |
"eval a1 s (Iv i1) \<Longrightarrow> eval a2 s (Iv i2) \<Longrightarrow> eval (Less a1 a2) s (Bv (i1 < i2))" |
"eval a1 s (Rv r1) \<Longrightarrow> eval a2 s (Rv r2) \<Longrightarrow> eval (Less a1 a2) s (Bv (r1 < r2))"

inductive_cases [elim!]:
  "eval (Ic i) s v"  "eval (Rc i) s v" "eval (Bc b) s v"
  "eval (V x) s v"
  "eval (Plus a1 a2) s v"
  "eval (Not b) s v" "eval (And a1 a2) s v" "eval (Less a1 a2) s v"

subsection "Syntax of Commands"
(* a copy of Com.thy - keep in sync! *)

datatype
  com = SKIP
      | Assign vname exp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com        ("_;; _"  [60, 61] 60)
      | If     exp com com     ("IF _ THEN _ ELSE _"  [0, 0, 61] 61)
      | While  exp com         ("WHILE _ DO _"  [0, 61] 61)
      | Repeat com  exp        ("REPEAT _/ UNTIL _/" [0, 61] 61)

subsection "Small-Step Semantics of Commands"

inductive
  small_step :: "(com \<times> state) \<Rightarrow> (com \<times> state) \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "eval a s v \<Longrightarrow> (x ::= a, s) \<rightarrow> (SKIP, s(x := v))" |

Seq1:   "(SKIP;;c,s) \<rightarrow> (c,s)" |
Seq2:   "(c1,s) \<rightarrow> (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow> (c1';;c2,s')" |

IfTrue:  "eval b s (Bv True) \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c1,s)" |
IfFalse: "eval b s (Bv False) \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP,s)" |
Repeat: "(REPEAT c UNTIL b, s) \<rightarrow> (c;; IF b THEN SKIP ELSE REPEAT c UNTIL b, s)"

lemmas small_step_induct = small_step.induct[split_format(complete)]

subsection "The Type System"

datatype ty = Ity | Rty | Bty

type_synonym tyenv = "vname \<Rightarrow> ty"

inductive etyping :: "tyenv \<Rightarrow> exp \<Rightarrow> ty \<Rightarrow> bool"
  ("(1_/ \<turnstile>/ (_ :/ _))" [50,0,50] 50)
where
Ic_ty: "\<Gamma> \<turnstile> Ic i : Ity" |
Rc_ty: "\<Gamma> \<turnstile> Rc r : Rty" |
V_ty: "\<Gamma> \<turnstile> V x : \<Gamma> x" |
Plus_ity: "\<Gamma> \<turnstile> a1 : Ity \<Longrightarrow> \<Gamma> \<turnstile> a2 : Ity \<Longrightarrow> \<Gamma> \<turnstile> Plus a1 a2 : Ity" |
Plus_rty: "\<Gamma> \<turnstile> a1 : Rty \<Longrightarrow> \<Gamma> \<turnstile> a2 : Rty \<Longrightarrow> \<Gamma> \<turnstile> Plus a1 a2 : Rty" |
Bc_ty: "\<Gamma> \<turnstile> Bc v : Bty" |
Not_ty: "\<Gamma> \<turnstile> b : Bty \<Longrightarrow> \<Gamma> \<turnstile> Not b : Bty" |
And_ty: "\<Gamma> \<turnstile> b1 : Bty \<Longrightarrow> \<Gamma> \<turnstile> b2 : Bty \<Longrightarrow> \<Gamma> \<turnstile> And b1 b2 : Bty" |
Less_ty_int: "\<Gamma> \<turnstile> a1 : Ity \<Longrightarrow> \<Gamma> \<turnstile> a2 : Ity \<Longrightarrow> \<Gamma> \<turnstile> Less a1 a2 : Bty" |
Less_ty_real: "\<Gamma> \<turnstile> a1 : Rty \<Longrightarrow> \<Gamma> \<turnstile> a2 : Rty \<Longrightarrow> \<Gamma> \<turnstile> Less a1 a2 : Bty"

declare etyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> V x : \<tau>" "\<Gamma> \<turnstile> Ic i : \<tau>" "\<Gamma> \<turnstile> Rc r : \<tau>" "\<Gamma> \<turnstile> Plus a1 a2 : \<tau>"
  "\<Gamma> \<turnstile> Bc i : \<tau>" "\<Gamma> \<turnstile> Not b : \<tau>" "\<Gamma> \<turnstile> And b1 b2 : \<tau>" "\<Gamma> \<turnstile> Less a1 a2 : \<tau>"

text{* Warning: the ``:'' notation leads to syntactic ambiguities,
i.e. multiple parse trees, because ``:'' also stands for set membership.
In most situations Isabelle's type system will reject all but one parse tree,
but will still inform you of the potential ambiguity. *}

inductive ctyping :: "tyenv \<Rightarrow> com \<Rightarrow> bool" (infix "\<turnstile>" 50) where
Skip_ty: "\<Gamma> \<turnstile> SKIP" |
Assign_ty: "\<Gamma> \<turnstile> a : \<Gamma>(x) \<Longrightarrow> \<Gamma> \<turnstile> x ::= a" |
Seq_ty: "\<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> c1;;c2" |
If_ty: "\<Gamma> \<turnstile> b : Bty \<Longrightarrow> \<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> IF b THEN c1 ELSE c2" |
While_ty: "\<Gamma> \<turnstile> b : Bty \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> WHILE b DO c" |
Repeat_ty: "\<Gamma> \<turnstile> b : Bty \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> REPEAT c UNTIL b"

declare ctyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> x ::= a"  "\<Gamma> \<turnstile> c1;;c2"
  "\<Gamma> \<turnstile> IF b THEN c1 ELSE c2"
  "\<Gamma> \<turnstile> WHILE b DO c"
  "\<Gamma> \<turnstile> REPEAT c UNTIL b"

subsection "Well-typed Programs Do Not Get Stuck"

fun type :: "val \<Rightarrow> ty" where
"type (Iv i) = Ity" |
"type (Rv r) = Rty" |
"type (Bv b) = Bty"

lemma type_eq_Ity[simp]: "type v = Ity \<longleftrightarrow> (\<exists>i. v = Iv i)"
by (cases v) simp_all

lemma type_eq_Rty[simp]: "type v = Rty \<longleftrightarrow> (\<exists>r. v = Rv r)"
by (cases v) simp_all

lemma type_eq_Bty[simp]: "type v = Bty \<longleftrightarrow> (\<exists>r. v = Bv r)"
by (cases v) simp_all

definition styping :: "tyenv \<Rightarrow> state \<Rightarrow> bool" (infix "\<turnstile>" 50)
where "\<Gamma> \<turnstile> s  \<longleftrightarrow>  (\<forall>x. type (s x) = \<Gamma> x)"

lemma epreservation:
  "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> eval a s v \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> type v = \<tau>"
apply(induction arbitrary: v rule: etyping.induct)
apply (fastforce simp: styping_def)+
done

lemma eprogress: "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. eval a s v"
by (induction rule: etyping.induct; metis eval.intros type_eq_Ity type_eq_Rty type_eq_Bty epreservation)

theorem progress:
  "\<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c \<noteq> SKIP \<Longrightarrow> \<exists>cs'. (c,s) \<rightarrow> cs'"
proof(induction rule: ctyping.induct)
  case Skip_ty thus ?case by simp
next
  case Assign_ty
  thus ?case by (metis Assign eprogress)
next
  case Seq_ty thus ?case by simp (metis Seq1 Seq2)
next
  case (If_ty \<Gamma> b c1 c2)
  then obtain bv where bv_def: "eval b s bv" by (metis eprogress)
  then have "type bv = Bty" using epreservation If_ty by blast
  thus ?case using bv_def If_ty epreservation by (metis IfFalse IfTrue ty.distinct(3) ty.distinct(5) type.elims)
next
  case While_ty show ?case by (metis While)
next
  case Repeat_ty show ?case by (metis Repeat)
qed

theorem styping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<Gamma> \<turnstile> s'"
proof(induction rule: small_step_induct)
  case Assign thus ?case
    by (auto simp: styping_def) (metis Assign(1,3) epreservation)
qed auto

theorem ctyping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> c'"
by (induct rule: small_step_induct) (auto simp: ctyping.intros)

abbreviation small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

theorem type_sound:
  "(c,s) \<rightarrow>* (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c' \<noteq> SKIP
   \<Longrightarrow> \<exists>cs''. (c',s') \<rightarrow> cs''"
apply(induction rule:star_induct)
apply (metis progress)
by (metis styping_preservation ctyping_preservation)

end


(*  Title:      HOL/HOLCF/ex/Concurrency_Monad.thy
    Author:     Brian Huffman
*)

theory Concurrency_Monad
imports HOLCF
begin

text {* This file contains the concurrency monad example from
  Chapter 7 of the author's PhD thesis. *}

subsection {* State/nondeterminism monad, as a type synonym *}

type_synonym ('s, 'a) N = "'s \<rightarrow> ('a u \<otimes> 's u)\<natural>"

definition mapN :: "('a \<rightarrow> 'b) \<rightarrow> ('s, 'a) N \<rightarrow> ('s, 'b) N"
  where "mapN = (\<Lambda> f. cfun_map\<cdot>ID\<cdot>(convex_map\<cdot>(sprod_map\<cdot>(u_map\<cdot>f)\<cdot>ID)))"

definition unitN :: "'a \<rightarrow> ('s, 'a) N"
  where "unitN = (\<Lambda> x. (\<Lambda> s. convex_unit\<cdot>(:up\<cdot>x, up\<cdot>s:)))"

definition bindN :: "('s, 'a) N \<rightarrow> ('a \<rightarrow> ('s, 'b) N) \<rightarrow> ('s, 'b) N"
  where "bindN = (\<Lambda> c k. (\<Lambda> s. convex_bind\<cdot>(c\<cdot>s)\<cdot>(\<Lambda> (:up\<cdot>x, up\<cdot>s':). k\<cdot>x\<cdot>s')))"

definition plusN :: "('s, 'a) N \<rightarrow> ('s, 'a) N \<rightarrow> ('s, 'a) N"
  where "plusN = (\<Lambda> a b. (\<Lambda> s. convex_plus\<cdot>(a\<cdot>s)\<cdot>(b\<cdot>s)))"

lemma mapN_ID: "mapN\<cdot>ID = ID"
by (simp add: mapN_def domain_map_ID)

lemma mapN_mapN: "mapN\<cdot>f\<cdot>(mapN\<cdot>g\<cdot>m) = mapN\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>m"
unfolding mapN_def ID_def
by (simp add: cfun_map_map convex_map_map sprod_map_map u_map_map eta_cfun)

lemma mapN_unitN: "mapN\<cdot>f\<cdot>(unitN\<cdot>x) = unitN\<cdot>(f\<cdot>x)"
unfolding mapN_def unitN_def
by (simp add: cfun_map_def)

lemma bindN_unitN: "bindN\<cdot>(unitN\<cdot>a)\<cdot>f = f\<cdot>a"
by (simp add: unitN_def bindN_def eta_cfun)

lemma mapN_conv_bindN: "mapN\<cdot>f\<cdot>m = bindN\<cdot>m\<cdot>(unitN oo f)"
apply (simp add: mapN_def bindN_def unitN_def)
apply (rule cfun_eqI, simp)
apply (simp add: convex_map_def)
apply (rule cfun_arg_cong)
apply (rule cfun_eqI, simp, rename_tac p)
apply (case_tac p, simp)
apply (case_tac x, simp)
apply (case_tac y, simp)
apply simp
done

lemma bindN_unitN_right: "bindN\<cdot>m\<cdot>unitN = m"
proof -
  have "mapN\<cdot>ID\<cdot>m = m" by (simp add: mapN_ID)
  thus ?thesis by (simp add: mapN_conv_bindN)
qed

lemma bindN_bindN:
  "bindN\<cdot>(bindN\<cdot>m\<cdot>f)\<cdot>g = bindN\<cdot>m\<cdot>(\<Lambda> x. bindN\<cdot>(f\<cdot>x)\<cdot>g)"
apply (rule cfun_eqI, rename_tac s)
apply (simp add: bindN_def)
apply (simp add: convex_bind_bind)
apply (rule cfun_arg_cong)
apply (rule cfun_eqI, rename_tac w)
apply (case_tac w, simp)
apply (case_tac x, simp)
apply (case_tac y, simp)
apply simp
done

lemma mapN_bindN: "mapN\<cdot>f\<cdot>(bindN\<cdot>m\<cdot>g) = bindN\<cdot>m\<cdot>(\<Lambda> x. mapN\<cdot>f\<cdot>(g\<cdot>x))"
by (simp add: mapN_conv_bindN bindN_bindN)

lemma bindN_mapN: "bindN\<cdot>(mapN\<cdot>f\<cdot>m)\<cdot>g = bindN\<cdot>m\<cdot>(\<Lambda> x. g\<cdot>(f\<cdot>x))"
by (simp add: mapN_conv_bindN bindN_bindN bindN_unitN)

lemma mapN_plusN:
  "mapN\<cdot>f\<cdot>(plusN\<cdot>a\<cdot>b) = plusN\<cdot>(mapN\<cdot>f\<cdot>a)\<cdot>(mapN\<cdot>f\<cdot>b)"
unfolding mapN_def plusN_def by (simp add: cfun_map_def)

lemma plusN_commute: "plusN\<cdot>a\<cdot>b = plusN\<cdot>b\<cdot>a"
unfolding plusN_def by (simp add: convex_plus_commute)

lemma plusN_assoc: "plusN\<cdot>(plusN\<cdot>a\<cdot>b)\<cdot>c = plusN\<cdot>a\<cdot>(plusN\<cdot>b\<cdot>c)"
unfolding plusN_def by (simp add: convex_plus_assoc)

lemma plusN_absorb: "plusN\<cdot>a\<cdot>a = a"
unfolding plusN_def by (simp add: eta_cfun)

subsection {* Resumption-state-nondeterminism monad *}

domain ('s, 'a) R = Done (lazy "'a") | More (lazy "('s, ('s, 'a) R) N")

thm R.take_induct

lemma R_induct [case_names adm bottom Done More, induct type: R]:
  fixes P :: "('s, 'a) R \<Rightarrow> bool"
  assumes adm: "adm P"
  assumes bottom: "P \<bottom>"
  assumes Done: "\<And>x. P (Done\<cdot>x)"
  assumes More: "\<And>p c. (\<And>r::('s, 'a) R. P (p\<cdot>r)) \<Longrightarrow> P (More\<cdot>(mapN\<cdot>p\<cdot>c))"
  shows "P r"
proof (induct r rule: R.take_induct)
  show "adm P" by fact
next
  fix n
  show "P (R_take n\<cdot>r)"
  proof (induct n arbitrary: r)
    case 0 show ?case by (simp add: bottom)
  next
    case (Suc n r)
    show ?case
      apply (cases r)
      apply (simp add: bottom)
      apply (simp add: Done)
      using More [OF Suc]
      apply (simp add: mapN_def)
      done
  qed
qed

declare R.take_rews(2) [simp del]

lemma R_take_Suc_More [simp]:
  "R_take (Suc n)\<cdot>(More\<cdot>k) = More\<cdot>(mapN\<cdot>(R_take n)\<cdot>k)"
by (simp add: mapN_def R.take_rews(2))

subsection {* Map function *}

fixrec mapR :: "('a \<rightarrow> 'b) \<rightarrow> ('s, 'a) R \<rightarrow> ('s, 'b) R"
  where "mapR\<cdot>f\<cdot>(Done\<cdot>a) = Done\<cdot>(f\<cdot>a)"
  | "mapR\<cdot>f\<cdot>(More\<cdot>k) = More\<cdot>(mapN\<cdot>(mapR\<cdot>f)\<cdot>k)"

lemma mapR_strict [simp]: "mapR\<cdot>f\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma mapR_mapR: "mapR\<cdot>f\<cdot>(mapR\<cdot>g\<cdot>r) = mapR\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>r"
by (induct r) (simp_all add: mapN_mapN)

lemma mapR_ID: "mapR\<cdot>ID\<cdot>r = r"
by (induct r) (simp_all add: mapN_mapN eta_cfun)

lemma "mapR\<cdot>f\<cdot>(mapR\<cdot>g\<cdot>r) = mapR\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>r"
apply (induct r)
apply simp
apply simp
apply simp
apply (simp (no_asm))
apply (simp (no_asm) add: mapN_mapN)
apply simp
done

subsection {* Monadic bind function *}

fixrec bindR :: "('s, 'a) R \<rightarrow> ('a \<rightarrow> ('s, 'b) R) \<rightarrow> ('s, 'b) R"
  where "bindR\<cdot>(Done\<cdot>x)\<cdot>k = k\<cdot>x"
  | "bindR\<cdot>(More\<cdot>c)\<cdot>k = More\<cdot>(mapN\<cdot>(\<Lambda> r. bindR\<cdot>r\<cdot>k)\<cdot>c)"

lemma bindR_strict [simp]: "bindR\<cdot>\<bottom>\<cdot>k = \<bottom>"
by fixrec_simp

lemma bindR_Done_right: "bindR\<cdot>r\<cdot>Done = r"
by (induct r) (simp_all add: mapN_mapN eta_cfun)

lemma mapR_conv_bindR: "mapR\<cdot>f\<cdot>r = bindR\<cdot>r\<cdot>(\<Lambda> x. Done\<cdot>(f\<cdot>x))"
by (induct r) (simp_all add: mapN_mapN)

lemma bindR_bindR: "bindR\<cdot>(bindR\<cdot>r\<cdot>f)\<cdot>g = bindR\<cdot>r\<cdot>(\<Lambda> x. bindR\<cdot>(f\<cdot>x)\<cdot>g)"
by (induct r) (simp_all add: mapN_mapN)

lemma "bindR\<cdot>(bindR\<cdot>r\<cdot>f)\<cdot>g = bindR\<cdot>r\<cdot>(\<Lambda> x. bindR\<cdot>(f\<cdot>x)\<cdot>g)"
apply (induct r)
apply (simp_all add: mapN_mapN)
done

subsection {* Zip function *}

fixrec zipR :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('s, 'a) R \<rightarrow> ('s, 'b) R \<rightarrow> ('s, 'c) R"
  where zipR_Done_Done:
    "zipR\<cdot>f\<cdot>(Done\<cdot>x)\<cdot>(Done\<cdot>y) = Done\<cdot>(f\<cdot>x\<cdot>y)"
  | zipR_Done_More:
    "zipR\<cdot>f\<cdot>(Done\<cdot>x)\<cdot>(More\<cdot>b) =
      More\<cdot>(mapN\<cdot>(\<Lambda> r. zipR\<cdot>f\<cdot>(Done\<cdot>x)\<cdot>r)\<cdot>b)"
  | zipR_More_Done:
    "zipR\<cdot>f\<cdot>(More\<cdot>a)\<cdot>(Done\<cdot>y) =
      More\<cdot>(mapN\<cdot>(\<Lambda> r. zipR\<cdot>f\<cdot>r\<cdot>(Done\<cdot>y))\<cdot>a)"
  | zipR_More_More:
    "zipR\<cdot>f\<cdot>(More\<cdot>a)\<cdot>(More\<cdot>b) =
      More\<cdot>(plusN\<cdot>(mapN\<cdot>(\<Lambda> r. zipR\<cdot>f\<cdot>(More\<cdot>a)\<cdot>r)\<cdot>b)
                 \<cdot>(mapN\<cdot>(\<Lambda> r. zipR\<cdot>f\<cdot>r\<cdot>(More\<cdot>b))\<cdot>a))"

lemma zipR_strict1 [simp]: "zipR\<cdot>f\<cdot>\<bottom>\<cdot>r = \<bottom>"
by fixrec_simp

lemma zipR_strict2 [simp]: "zipR\<cdot>f\<cdot>r\<cdot>\<bottom> = \<bottom>"
by (fixrec_simp, cases r, simp_all)

abbreviation apR (infixl "\<diamond>" 70)
  where "a \<diamond> b \<equiv> zipR\<cdot>ID\<cdot>a\<cdot>b"

text {* Proofs that @{text zipR} satisfies the applicative functor laws: *}

lemma R_homomorphism: "Done\<cdot>f \<diamond> Done\<cdot>x = Done\<cdot>(f\<cdot>x)"
  by simp

lemma R_identity: "Done\<cdot>ID \<diamond> r = r"
  by (induct r, simp_all add: mapN_mapN eta_cfun)

lemma R_interchange: "r \<diamond> Done\<cdot>x = Done\<cdot>(\<Lambda> f. f\<cdot>x) \<diamond> r"
  by (induct r, simp_all add: mapN_mapN)

text {* The associativity rule is the hard one! *}

lemma R_associativity: "Done\<cdot>cfcomp \<diamond> r1 \<diamond> r2 \<diamond> r3 = r1 \<diamond> (r2 \<diamond> r3)"
proof (induct r1 arbitrary: r2 r3)
  case (Done x1) thus ?case
  proof (induct r2 arbitrary: r3)
    case (Done x2) thus ?case
    proof (induct r3)
      case (More p3 c3) thus ?case (* Done/Done/More *)
        by (simp add: mapN_mapN)
    qed simp_all
  next
    case (More p2 c2) thus ?case
    proof (induct r3)
      case (Done x3) thus ?case (* Done/More/Done *)
        by (simp add: mapN_mapN)
    next
      case (More p3 c3) thus ?case (* Done/More/More *)
        by (simp add: mapN_mapN mapN_plusN)
    qed simp_all
  qed simp_all
next
  case (More p1 c1) thus ?case
  proof (induct r2 arbitrary: r3)
    case (Done y) thus ?case
    proof (induct r3)
      case (Done x3) thus ?case
        by (simp add: mapN_mapN)
    next
      case (More p3 c3) thus ?case
        by (simp add: mapN_mapN)
    qed simp_all
  next
    case (More p2 c2) thus ?case
    proof (induct r3)
      case (Done x3) thus ?case
        by (simp add: mapN_mapN mapN_plusN)
    next
      case (More p3 c3) thus ?case
        by (simp add: mapN_mapN mapN_plusN plusN_assoc)
    qed simp_all
  qed simp_all
qed simp_all

text {* Other miscellaneous properties about @{text zipR}: *}

lemma zipR_Done_left:
  shows "zipR\<cdot>f\<cdot>(Done\<cdot>x)\<cdot>r = mapR\<cdot>(f\<cdot>x)\<cdot>r"
by (induct r) (simp_all add: mapN_mapN)

lemma zipR_Done_right:
  shows "zipR\<cdot>f\<cdot>r\<cdot>(Done\<cdot>y) = mapR\<cdot>(\<Lambda> x. f\<cdot>x\<cdot>y)\<cdot>r"
by (induct r) (simp_all add: mapN_mapN)

lemma mapR_zipR: "mapR\<cdot>h\<cdot>(zipR\<cdot>f\<cdot>a\<cdot>b) = zipR\<cdot>(\<Lambda> x y. h\<cdot>(f\<cdot>x\<cdot>y))\<cdot>a\<cdot>b"
apply (induct a arbitrary: b)
apply simp
apply simp
apply (simp add: zipR_Done_left zipR_Done_right mapR_mapR)
apply (induct_tac b)
apply simp
apply simp
apply (simp add: mapN_mapN)
apply (simp add: mapN_mapN mapN_plusN)
done

lemma zipR_mapR_left: "zipR\<cdot>f\<cdot>(mapR\<cdot>h\<cdot>a)\<cdot>b = zipR\<cdot>(\<Lambda> x y. f\<cdot>(h\<cdot>x)\<cdot>y)\<cdot>a\<cdot>b"
apply (induct a arbitrary: b)
apply simp
apply simp
apply (simp add: zipR_Done_left zipR_Done_right eta_cfun)
apply (simp add: mapN_mapN)
apply (induct_tac b)
apply simp
apply simp
apply (simp add: mapN_mapN)
apply (simp add: mapN_mapN)
done

lemma zipR_mapR_right: "zipR\<cdot>f\<cdot>a\<cdot>(mapR\<cdot>h\<cdot>b) = zipR\<cdot>(\<Lambda> x y. f\<cdot>x\<cdot>(h\<cdot>y))\<cdot>a\<cdot>b"
apply (induct b arbitrary: a)
apply simp
apply simp
apply (simp add: zipR_Done_left zipR_Done_right)
apply (simp add: mapN_mapN)
apply (induct_tac a)
apply simp
apply simp
apply (simp add: mapN_mapN)
apply (simp add: mapN_mapN)
done

lemma zipR_commute:
  assumes f: "\<And>x y. f\<cdot>x\<cdot>y = g\<cdot>y\<cdot>x"
  shows "zipR\<cdot>f\<cdot>a\<cdot>b = zipR\<cdot>g\<cdot>b\<cdot>a"
apply (induct a arbitrary: b)
apply simp
apply simp
apply (simp add: zipR_Done_left zipR_Done_right f [symmetric] eta_cfun)
apply (induct_tac b)
apply simp
apply simp
apply (simp add: mapN_mapN)
apply (simp add: mapN_mapN mapN_plusN plusN_commute)
done

lemma zipR_assoc:
  fixes a :: "('s, 'a) R" and b :: "('s, 'b) R" and c :: "('s, 'c) R"
  fixes f :: "'a \<rightarrow> 'b \<rightarrow> 'd" and g :: "'d \<rightarrow> 'c \<rightarrow> 'e"
  assumes gf: "\<And>x y z. g\<cdot>(f\<cdot>x\<cdot>y)\<cdot>z = h\<cdot>x\<cdot>(k\<cdot>y\<cdot>z)"
  shows "zipR\<cdot>g\<cdot>(zipR\<cdot>f\<cdot>a\<cdot>b)\<cdot>c = zipR\<cdot>h\<cdot>a\<cdot>(zipR\<cdot>k\<cdot>b\<cdot>c)" (is "?P a b c")
 apply (induct a arbitrary: b c)
    apply simp
   apply simp
  apply (simp add: zipR_Done_left zipR_Done_right)
  apply (simp add: zipR_mapR_left mapR_zipR gf)
 apply (rename_tac pA kA b c)
 apply (rule_tac x=c in spec)
 apply (induct_tac b)
    apply simp
   apply simp
  apply (simp add: mapN_mapN)
  apply (simp add: zipR_Done_left zipR_Done_right eta_cfun)
  apply (simp add: zipR_mapR_right)
  apply (rule allI, rename_tac c)
  apply (induct_tac c)
     apply simp
    apply simp
   apply (rename_tac z)
   apply (simp add: mapN_mapN)
   apply (simp add: zipR_mapR_left gf)
  apply (rename_tac pC kC)
  apply (simp add: mapN_mapN)
  apply (simp add: zipR_mapR_left gf)
 apply (rename_tac pB kB)
 apply (rule allI, rename_tac c)
 apply (induct_tac c)
    apply simp
   apply simp
  apply (simp add: mapN_mapN mapN_plusN)
 apply (rename_tac pC kC)
 apply (simp add: mapN_mapN mapN_plusN plusN_assoc)
done

text {* Alternative proof using take lemma. *}

lemma
  fixes a :: "('s, 'a) R" and b :: "('s, 'b) R" and c :: "('s, 'c) R"
  fixes f :: "'a \<rightarrow> 'b \<rightarrow> 'd" and g :: "'d \<rightarrow> 'c \<rightarrow> 'e"
  assumes gf: "\<And>x y z. g\<cdot>(f\<cdot>x\<cdot>y)\<cdot>z = h\<cdot>x\<cdot>(k\<cdot>y\<cdot>z)"
  shows "zipR\<cdot>g\<cdot>(zipR\<cdot>f\<cdot>a\<cdot>b)\<cdot>c = zipR\<cdot>h\<cdot>a\<cdot>(zipR\<cdot>k\<cdot>b\<cdot>c)"
    (is "?lhs = ?rhs" is "?P a b c")
proof (rule R.take_lemma)
  fix n show "R_take n\<cdot>?lhs = R_take n\<cdot>?rhs"
  proof (induct n arbitrary: a b c)
    case (0 a b c)
    show ?case by simp
  next
    case (Suc n a b c)
    note IH = this
    let ?P = ?case
    show ?case
    proof (cases a)
      case bottom thus ?P by simp
    next
      case (Done x) thus ?P
        by (simp add: zipR_Done_left zipR_mapR_left mapR_zipR gf)
    next
      case (More nA) thus ?P
      proof (cases b)
        case bottom thus ?P by simp
      next
        case (Done y) thus ?P
          by (simp add: zipR_Done_left zipR_Done_right
            zipR_mapR_left zipR_mapR_right gf)
      next
        case (More nB) thus ?P
        proof (cases c)
          case bottom thus ?P by simp
        next
          case (Done z) thus ?P
            by (simp add: zipR_Done_right mapR_zipR zipR_mapR_right gf)
        next
          case (More nC)
          note H = `a = More\<cdot>nA` `b = More\<cdot>nB` `c = More\<cdot>nC`
          show ?P
            apply (simp only: H zipR_More_More)
            apply (simplesubst zipR_More_More [of f, symmetric])
            apply (simplesubst zipR_More_More [of k, symmetric])
            apply (simp only: H [symmetric])
            apply (simp add: mapN_mapN mapN_plusN plusN_assoc IH)
            done
        qed
      qed
    qed
  qed
qed

end


theory sort_QSortPermutes
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun filter :: "('t => bool) => 't list => 't list" where
"filter q (Nil2) = Nil2"
| "filter q (Cons2 y z) =
     (if q y then Cons2 y (filter q z) else filter q z)"

fun count :: "int => int list => Nat" where
"count x (Nil2) = Z"
| "count x (Cons2 z xs) =
     (if x = z then S (count x xs) else count x xs)"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun qsort :: "int list => int list" where
"qsort (Nil2) = Nil2"
| "qsort (Cons2 y xs) =
     append
       (append
          (qsort (filter (% (z :: int) => z <= y) xs)) (Cons2 y (Nil2)))
       (qsort (filter (% (x2 :: int) => x2 > y) xs))"

(*hipster filter count append qsort *)

theorem x0 :
  "!! (x :: int) (y :: int list) . (count x (qsort y)) = (count x y)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


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

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

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun sort2 :: "int => int => int list" where
  "sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun pairs :: "int list => int list => int list" where
  "pairs (nil2) z = z"
| "pairs (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "pairs (cons2 z2 x2) (cons2 x3 x4) =
     x (sort2 z2 x3) (pairs x2 x4)"

fun stitch :: "int list => int list => int list" where
  "stitch (nil2) z = z"
| "stitch (cons2 z2 xs) z = cons2 z2 (pairs xs z)"

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

function evens :: "'a list => 'a list"
  and odds :: "'a list => 'a list" where
  "evens (nil2) = nil2"
| "evens (cons2 z xs) = cons2 z (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 z xs) = evens xs"
  by pat_completeness auto

(*fun did not finish the proof*)
function bmerge :: "int list => int list => int list" where
  "bmerge (nil2) z = nil2"
| "bmerge (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "bmerge (cons2 z2 x2) (cons2 x3 x4) =
     (let fail :: int list =
       stitch
         (bmerge (evens (cons2 z2 x2)) (evens (cons2 x3 x4)))
         (bmerge (odds (cons2 z2 x2)) (odds (cons2 x3 x4)))
     in (case x2 of
           nil2 =>
             (case x4 of
                nil2 => sort2 z2 x3
                | cons2 x5 x6 => fail)
           | cons2 x7 x8 => fail))"
  by pat_completeness auto

(*fun did not finish the proof*)
function bsort :: "int list => int list" where
  "bsort (nil2) = nil2"
| "bsort (cons2 z (nil2)) = cons2 z (nil2)"
| "bsort (cons2 z (cons2 x2 x3)) =
     bmerge
       (bsort (evens (cons2 z (cons2 x2 x3))))
       (bsort (odds (cons2 z (cons2 x2 x3))))"
  by pat_completeness auto

theorem property0 :
  "ordered (bsort xs)"
  oops

end


theory GZF_Base
  imports BoundedQuants
begin

syntax
  "_Repl"  :: "[pttrn, pttrn, 'a, bool] => 'a"  (\<open>(1{_ |/\<exists>_ \<in> _. _})\<close>)
translations
  "{c | \<exists>b\<in>x. P }" \<rightleftharpoons> "CONST Repl x (\<lambda>b c. P)"
context GZF begin

thm Union_typ Pow_typ Inf_typ Repl_typ

lemma setof_subset :
  assumes "x : Set" "y : SetOf \<alpha>" "x \<subseteq> y"
    shows "x : SetOf \<alpha>"
proof (rule setofI[OF \<open>x : Set\<close>])
  fix b assume "b \<in> x"
  hence "b \<in> y" by (rule subsetD[OF \<open>x \<subseteq> y\<close>])
  thus "b : \<alpha>" by (rule setof_mem[OF \<open>y : SetOf \<alpha>\<close>])
qed

declare subsetD [trans] rev_subsetD [trans] subset_trans [trans]

subsection \<open>Equality of sets\<close>
lemma equality_iff :
  assumes "x : Set" "y : Set"
    shows "x = y \<longleftrightarrow> (\<forall>b. b \<in> x \<longleftrightarrow> b \<in> y)"
  using assms ext
  by auto

lemma subset_equal :
  assumes "x : Set" "y : Set"
    shows "x = y \<longleftrightarrow> x \<subseteq> y \<and> y \<subseteq> x"
  using equality_iff[OF assms] subset_iff assms
  by auto

(*Lemmas taken from ZF/ZF_Base:*)
lemma equalityI :
  assumes "x : Set" "y : Set"
    shows "\<lbrakk> x \<subseteq> y;  y \<subseteq> x \<rbrakk> \<Longrightarrow> x = y"
  using subset_equal[OF assms]
  by auto
(*WAS: by (rule extension [THEN iffD2], rule conjI) *)

(*Added assumptions: \<open>A : Set\<close> \<open>B : Set\<close>*)
lemma equality_iffI:
  assumes "x : Set" "y : Set"
    shows "(\<And>b. b \<in> x \<longleftrightarrow> b \<in> y) \<Longrightarrow> x = y"
  using assms equalityI subsetI
  by blast
(*WAS: by (rule equalityI, blast+)*)

(*Replaced \<open>extension\<close> with \<open>subset_equal\<close>*)
lemmas equalityD1 = subset_equal [THEN iffD1, THEN conjunct1]
lemmas equalityD2 = subset_equal [THEN iffD1, THEN conjunct2]

(*Added assumptions: \<open>A : Set\<close> \<open>B : Set\<close>*)
lemma equalityE:
  assumes "A : Set"
    shows "[| A = B;  [| A \<subseteq> B; B \<subseteq> A |] ==> P |]  ==>  P"
  by (use equalityD1[OF assms] equalityD2[OF assms] in auto)
(*WAS: by (blast dest: equalityD1 equalityD2) *)

(*Added assumptions: \<open>A : Set\<close> \<open>B : Set\<close>*)
lemma equalityCE:
  assumes "A : Set"
    shows "[| A = B;  [| c\<in>A; c\<in>B |] ==> P;  [| c\<notin>A; c\<notin>B |] ==> P |]  ==>  P"
by (erule equalityE[OF assms], use assms in blast)
(*WAS: by (erule equalityE, blast)*)

subsection \<open>Corollaries of the Axiom of Union\<close>

lemma union_set : "x : SetOf Set \<Longrightarrow> \<Union> x : Set"
  using Union_typ by (rule funE)

(*Added assumption: \<open>x : Set\<close>*)
lemma union_iff :
  assumes "x : SetOf Set"
    shows "a \<in> \<Union> x \<longleftrightarrow> (\<exists>y \<in> x. a \<in> y)"
  using assms uni
  by auto
(*WAS: axiomatised then, declare union_iff [simp]*)

(*Added assumption: \<open>x : Set\<close>*)
lemma unionI [intro]:
  assumes "x : SetOf Set"
  shows "\<lbrakk> y \<in> x;  a \<in> y \<rbrakk> \<Longrightarrow> a \<in> \<Union> x"
  by (simp add: union_iff[OF assms], blast)
(*WAS: by (simp, blast)*)

(*Added assumption: \<open>x : Set\<close>*)
lemma unionE [elim]:
  assumes "x : SetOf Set"
  shows "\<lbrakk> a \<in> \<Union> x;  \<And>y. \<lbrakk> a \<in> y;  y \<in> x \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  by (simp add: union_iff[OF assms], blast)
(*WAS: by (simp, blast)*)

subsection \<open>Rules for power sets\<close>

(*Added assumption: \<open>x : Set\<close>*)
lemma pow_iff :
  assumes "x : Set" "y : Set"
    shows "x \<in> \<P> y \<longleftrightarrow> x \<subseteq> y"
  using pow assms by auto
(*WAS: an axiom*)

lemma Pow_typ_set : "Pow : Set \<rightarrow> Set"
  by (rule funI[OF subtypE[OF setof_set_subtyp funE[OF Pow_typ]]])

(*Soft typing rules can be derived from instances of typing rules: *)
lemmas pow_setof = funE[OF Pow_typ]
lemmas pow_set   = funE[OF Pow_typ_set]

lemma pow_mem : "x : Set \<Longrightarrow> y \<in> \<P> x \<Longrightarrow> y : Set"
  using funE[OF Pow_typ, THEN tyE] unfolding SetOf_def by auto

(*Added assumption: \<open>x : Set\<close>*)
lemma powI:
  assumes "x : Set" "y : Set"
    shows "x \<subseteq> y \<Longrightarrow> x \<in> \<P> y"
  using pow_iff[OF assms] by auto
(*WAS: by (erule Pow_iff [THEN iffD2])*)

lemma powD:
  assumes y : "y : Set"
    shows "x \<in> \<P> y \<Longrightarrow> x \<subseteq> y"
  using pow_iff[OF setof_mem[OF pow_setof[OF y]] assms] by simp
(*WAS: by (erule Pow_iff [THEN iffD1]) *)

lemma pow_top :
  assumes x : "x : Set"
    shows "x \<in> \<P> x"
  by (rule powI[OF x x subset_refl])

lemma set_setmem_subtyp : "Set << SetMem"
proof (rule subtypI, rule setmemI)
  fix x assume "x : Set"
  thus "\<P> x : Set" "x \<in> \<P> x" by (rule pow_set, rule pow_top)
qed

lemma pow_iterate :
  assumes x : "x : Set" and y : "y : Set"
      and pow : "x \<in> \<P> y"
    shows "\<P> x \<in> \<P> (\<P> y)"
proof (rule powI[OF pow_set[OF x] pow_set[OF y]], rule)
  fix a assume "a \<in> \<P> x"
  hence "a : Set" "a \<subseteq> x"
    using setof_mem[OF pow_setof[OF x]] powD[OF x] by auto
  hence "a \<subseteq> y" using subset_trans[OF _ powD[OF y pow]] by auto
  thus "a \<in> \<P> y" using powI[OF \<open>a : Set\<close> y] by auto
qed

   (*  drule powD[OF x y], rule powI[OF y], metis subset_trans[OF _ powD[OF y pow]])
    *)
lemmas set_setmem = subtypE[OF set_setmem_subtyp]

subsection \<open>Rules for a witness of Axiom of Infinity\<close>

lemma inf0 : "\<emptyset> \<in> Inf" by (simp add: inf)
lemma inf_closed: "x \<in> Inf \<Longrightarrow> Succ x \<in> Inf" by (simp add: inf)
(* lemma inf_set : "Inf : Set" by (rule Inf_typ) *)

subsection \<open>Rules for Replacement and derived operators\<close>

thm ReplPred_def
lemma replpredI :
  assumes "\<And>a. a \<in> x \<Longrightarrow> \<exists>\<^sub>\<le>\<^sub>1 b : SetMem. P a b"
  shows "P : ReplPred x"
  using assms
  unfolding ReplPred_def has_ty_def by auto

lemma repl_iff :
  assumes "x : Set" "P : ReplPred x"
    shows "\<forall>b. b \<in> { b | \<exists>a\<in>x. P a b } \<longleftrightarrow> (\<exists>a. a \<in> x \<and> P a b) \<and> b : SetMem"
  using repl assms by blast

lemma repl_set :
  assumes "x : Set" "P : ReplPred x"
    shows "{ b | \<exists>a\<in>x. P a b } : Set"
  using funE[OF depfunE[OF Repl_typ]] assms
  by auto

lemma replace_iff :
  assumes "x : Set" "P : ReplPred x"
    shows "b \<in> { b | \<exists>a\<in>x. P a b } \<longleftrightarrow> (\<exists>a \<in> x. P a b) \<and> b : SetMem"
  using repl assms unfolding bex_def rex_def
  by blast

lemma replaceI :
  assumes "x : Set" "P : ReplPred x"
    shows "\<lbrakk> P a b ; a \<in> x ; b : SetMem\<rbrakk> \<Longrightarrow> b \<in> { b | \<exists>a\<in>x. P a b }"
  unfolding replace_iff[OF assms]
  by blast

lemma replaceE:
  assumes "x : Set" "P : ReplPred x"
    shows "\<lbrakk> b \<in> { b | \<exists>a\<in>x. P a b } ; \<And>a. \<lbrakk> a \<in> x ; b : SetMem ; P a b \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  using replace_iff[OF assms] by blast

lemma replace_cong :
  assumes "x : Set" "P : ReplPred x" "y : Set" "Q : ReplPred y"
    shows [cong]: "\<lbrakk> x = y ; \<And>a b. a \<in> y \<Longrightarrow> P a b \<longleftrightarrow> Q a b \<rbrakk> \<Longrightarrow> Repl x P = Repl y Q"
  by (rule equality_iffI[OF repl_set[OF assms(1,2)] repl_set[OF assms(3,4)]],
      unfold replace_iff[OF assms(1,2)] replace_iff[OF assms(3,4)], blast)

definition ReplFunPred :: "['a, 'a \<Rightarrow> bool] \<Rightarrow> ((['a,'a] \<Rightarrow> bool) \<Rightarrow> bool)"
  where [typdef] : "ReplFunPred x \<beta> \<equiv> ReplPred x \<triangle> BinPred (MemOf x) \<beta>"

lemma funpred_replpred: "ReplFunPred x \<beta> << ReplPred x"
  unfolding ReplFunPred_def
  by (rule int_sub1)

lemma funpred_binpred_typ : "ReplFunPred x \<beta> << BinPred (MemOf x) \<beta>"
  unfolding ReplFunPred_def
  by (rule int_sub2)

lemmas funpred_binpred = subtypE[OF funpred_binpred_typ]

lemma Repl_typ2 : "Repl : (\<Pi> x : Set. ReplFunPred x \<alpha> \<rightarrow> SetOf \<alpha>)"
proof (rule depfunI, rule funI)
  fix x P assume P:"P : ReplFunPred x \<alpha>" and x:"x : Set"
  hence "P : ReplPred x"
    using subtypE[OF funpred_replpred]  by simp_all
  show "Repl x P : SetOf \<alpha>"
  proof (rule setofI, rule repl_set[OF \<open>x : Set\<close> \<open>P : ReplPred x\<close>])
    fix b assume "b \<in> Repl x P" thus "b : \<alpha>"
    proof (rule replaceE[OF \<open>x : Set\<close> \<open>P : ReplPred x\<close>])
      fix a assume "a \<in> x" "P a b"
      thus "b : \<alpha>"
        using bpredE[OF funpred_binpred[OF P] memofI]
      by auto
    qed
  qed
qed
end
end