(*  Author:     L C Paulson, University of Cambridge
    Material split off from Topology_Euclidean_Space
*)

section \<open>Connected Components\<close>

theory Connected
  imports
    Abstract_Topology_2
begin

subsection\<^marker>\<open>tag unimportant\<close> \<open>Connectedness\<close>

lemma connected_local:
 "connected S \<longleftrightarrow>
  \<not> (\<exists>e1 e2.
      openin (top_of_set S) e1 \<and>
      openin (top_of_set S) e2 \<and>
      S \<subseteq> e1 \<union> e2 \<and>
      e1 \<inter> e2 = {} \<and>
      e1 \<noteq> {} \<and>
      e2 \<noteq> {})"
  unfolding connected_def openin_open
  by safe blast+

lemma exists_diff:
  fixes P :: "'a set \<Rightarrow> bool"
  shows "(\<exists>S. P (- S)) \<longleftrightarrow> (\<exists>S. P S)"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof -
  have ?rhs if ?lhs
    using that by blast
  moreover have "P (- (- S))" if "P S" for S
  proof -
    have "S = - (- S)" by simp
    with that show ?thesis by metis
  qed
  ultimately show ?thesis by metis
qed

lemma connected_clopen: "connected S \<longleftrightarrow>
  (\<forall>T. openin (top_of_set S) T \<and>
     closedin (top_of_set S) T \<longrightarrow> T = {} \<or> T = S)" (is "?lhs \<longleftrightarrow> ?rhs")
proof -
  have "\<not> connected S \<longleftrightarrow>
    (\<exists>e1 e2. open e1 \<and> open (- e2) \<and> S \<subseteq> e1 \<union> (- e2) \<and> e1 \<inter> (- e2) \<inter> S = {} \<and> e1 \<inter> S \<noteq> {} \<and> (- e2) \<inter> S \<noteq> {})"
    unfolding connected_def openin_open closedin_closed
    by (metis double_complement)
  then have th0: "connected S \<longleftrightarrow>
    \<not> (\<exists>e2 e1. closed e2 \<and> open e1 \<and> S \<subseteq> e1 \<union> (- e2) \<and> e1 \<inter> (- e2) \<inter> S = {} \<and> e1 \<inter> S \<noteq> {} \<and> (- e2) \<inter> S \<noteq> {})"
    (is " _ \<longleftrightarrow> \<not> (\<exists>e2 e1. ?P e2 e1)")
    by (simp add: closed_def) metis
  have th1: "?rhs \<longleftrightarrow> \<not> (\<exists>t' t. closed t'\<and>t = S\<inter>t' \<and> t\<noteq>{} \<and> t\<noteq>S \<and> (\<exists>t'. open t' \<and> t = S \<inter> t'))"
    (is "_ \<longleftrightarrow> \<not> (\<exists>t' t. ?Q t' t)")
    unfolding connected_def openin_open closedin_closed by auto
  have "(\<exists>e1. ?P e2 e1) \<longleftrightarrow> (\<exists>t. ?Q e2 t)" for e2
  proof -
    have "?P e2 e1 \<longleftrightarrow> (\<exists>t. closed e2 \<and> t = S\<inter>e2 \<and> open e1 \<and> t = S\<inter>e1 \<and> t\<noteq>{} \<and> t \<noteq> S)" for e1
      by auto
    then show ?thesis
      by metis
  qed
  then have "\<forall>e2. (\<exists>e1. ?P e2 e1) \<longleftrightarrow> (\<exists>t. ?Q e2 t)"
    by blast
  then show ?thesis
    by (simp add: th0 th1)
qed

subsection \<open>Connected components, considered as a connectedness relation or a set\<close>

definition\<^marker>\<open>tag important\<close> "connected_component S x y \<equiv> \<exists>T. connected T \<and> T \<subseteq> S \<and> x \<in> T \<and> y \<in> T"

abbreviation "connected_component_set S x \<equiv> Collect (connected_component S x)"

lemma connected_componentI:
  "connected T \<Longrightarrow> T \<subseteq> S \<Longrightarrow> x \<in> T \<Longrightarrow> y \<in> T \<Longrightarrow> connected_component S x y"
  by (auto simp: connected_component_def)

lemma connected_component_in: "connected_component S x y \<Longrightarrow> x \<in> S \<and> y \<in> S"
  by (auto simp: connected_component_def)

lemma connected_component_refl: "x \<in> S \<Longrightarrow> connected_component S x x"
  by (auto simp: connected_component_def) (use connected_sing in blast)

lemma connected_component_refl_eq [simp]: "connected_component S x x \<longleftrightarrow> x \<in> S"
  by (auto simp: connected_component_refl) (auto simp: connected_component_def)

lemma connected_component_sym: "connected_component S x y \<Longrightarrow> connected_component S y x"
  by (auto simp: connected_component_def)

lemma connected_component_trans:
  "connected_component S x y \<Longrightarrow> connected_component S y z \<Longrightarrow> connected_component S x z"
  unfolding connected_component_def
  by (metis Int_iff Un_iff Un_subset_iff equals0D connected_Un)

lemma connected_component_of_subset:
  "connected_component S x y \<Longrightarrow> S \<subseteq> T \<Longrightarrow> connected_component T x y"
  by (auto simp: connected_component_def)

lemma connected_component_Union: "connected_component_set S x = \<Union>{T. connected T \<and> x \<in> T \<and> T \<subseteq> S}"
  by (auto simp: connected_component_def)

lemma connected_connected_component [iff]: "connected (connected_component_set S x)"
  by (auto simp: connected_component_Union intro: connected_Union)

lemma connected_iff_eq_connected_component_set:
  "connected S \<longleftrightarrow> (\<forall>x \<in> S. connected_component_set S x = S)"
proof (cases "S = {}")
  case True
  then show ?thesis by simp
next
  case False
  then obtain x where "x \<in> S" by auto
  show ?thesis
  proof
    assume "connected S"
    then show "\<forall>x \<in> S. connected_component_set S x = S"
      by (force simp: connected_component_def)
  next
    assume "\<forall>x \<in> S. connected_component_set S x = S"
    then show "connected S"
      by (metis \<open>x \<in> S\<close> connected_connected_component)
  qed
qed

lemma connected_component_subset: "connected_component_set S x \<subseteq> S"
  using connected_component_in by blast

lemma connected_component_eq_self: "connected S \<Longrightarrow> x \<in> S \<Longrightarrow> connected_component_set S x = S"
  by (simp add: connected_iff_eq_connected_component_set)

lemma connected_iff_connected_component:
  "connected S \<longleftrightarrow> (\<forall>x \<in> S. \<forall>y \<in> S. connected_component S x y)"
  using connected_component_in by (auto simp: connected_iff_eq_connected_component_set)

lemma connected_component_maximal:
  "x \<in> T \<Longrightarrow> connected T \<Longrightarrow> T \<subseteq> S \<Longrightarrow> T \<subseteq> (connected_component_set S x)"
  using connected_component_eq_self connected_component_of_subset by blast

lemma connected_component_mono:
  "S \<subseteq> T \<Longrightarrow> connected_component_set S x \<subseteq> connected_component_set T x"
  by (simp add: Collect_mono connected_component_of_subset)

lemma connected_component_eq_empty [simp]: "connected_component_set S x = {} \<longleftrightarrow> x \<notin> S"
  using connected_component_refl by (fastforce simp: connected_component_in)

lemma connected_component_set_empty [simp]: "connected_component_set {} x = {}"
  using connected_component_eq_empty by blast

lemma connected_component_eq:
  "y \<in> connected_component_set S x \<Longrightarrow> (connected_component_set S y = connected_component_set S x)"
  by (metis (no_types, lifting)
      Collect_cong connected_component_sym connected_component_trans mem_Collect_eq)

lemma closed_connected_component:
  assumes S: "closed S"
  shows "closed (connected_component_set S x)"
proof (cases "x \<in> S")
  case False
  then show ?thesis
    by (metis connected_component_eq_empty closed_empty)
next
  case True
  show ?thesis
    unfolding closure_eq [symmetric]
  proof
    show "closure (connected_component_set S x) \<subseteq> connected_component_set S x"
      apply (rule connected_component_maximal)
        apply (simp add: closure_def True)
       apply (simp add: connected_imp_connected_closure)
      apply (simp add: S closure_minimal connected_component_subset)
      done
  next
    show "connected_component_set S x \<subseteq> closure (connected_component_set S x)"
      by (simp add: closure_subset)
  qed
qed

lemma connected_component_disjoint:
  "connected_component_set S a \<inter> connected_component_set S b = {} \<longleftrightarrow>
    a \<notin> connected_component_set S b"
  apply (auto simp: connected_component_eq)
  using connected_component_eq connected_component_sym
  apply blast
  done

lemma connected_component_nonoverlap:
  "connected_component_set S a \<inter> connected_component_set S b = {} \<longleftrightarrow>
    a \<notin> S \<or> b \<notin> S \<or> connected_component_set S a \<noteq> connected_component_set S b"
  apply (auto simp: connected_component_in)
  using connected_component_refl_eq
    apply blast
   apply (metis connected_component_eq mem_Collect_eq)
  apply (metis connected_component_eq mem_Collect_eq)
  done

lemma connected_component_overlap:
  "connected_component_set S a \<inter> connected_component_set S b \<noteq> {} \<longleftrightarrow>
    a \<in> S \<and> b \<in> S \<and> connected_component_set S a = connected_component_set S b"
  by (auto simp: connected_component_nonoverlap)

lemma connected_component_sym_eq: "connected_component S x y \<longleftrightarrow> connected_component S y x"
  using connected_component_sym by blast

lemma connected_component_eq_eq:
  "connected_component_set S x = connected_component_set S y \<longleftrightarrow>
    x \<notin> S \<and> y \<notin> S \<or> x \<in> S \<and> y \<in> S \<and> connected_component S x y"
  apply (cases "y \<in> S", simp)
   apply (metis connected_component_eq connected_component_eq_empty connected_component_refl_eq mem_Collect_eq)
  apply (cases "x \<in> S", simp)
   apply (metis connected_component_eq_empty)
  using connected_component_eq_empty
  apply blast
  done

lemma connected_iff_connected_component_eq:
  "connected S \<longleftrightarrow> (\<forall>x \<in> S. \<forall>y \<in> S. connected_component_set S x = connected_component_set S y)"
  by (simp add: connected_component_eq_eq connected_iff_connected_component)

lemma connected_component_idemp:
  "connected_component_set (connected_component_set S x) x = connected_component_set S x"
  apply (rule subset_antisym)
   apply (simp add: connected_component_subset)
  apply (metis connected_component_eq_empty connected_component_maximal
      connected_component_refl_eq connected_connected_component mem_Collect_eq set_eq_subset)
  done

lemma connected_component_unique:
  "\<lbrakk>x \<in> c; c \<subseteq> S; connected c;
    \<And>c'. \<lbrakk>x \<in> c'; c' \<subseteq> S; connected c'\<rbrakk> \<Longrightarrow> c' \<subseteq> c\<rbrakk>
        \<Longrightarrow> connected_component_set S x = c"
  apply (rule subset_antisym)
   apply (meson connected_component_maximal connected_component_subset connected_connected_component contra_subsetD)
  by (simp add: connected_component_maximal)

lemma joinable_connected_component_eq:
  "\<lbrakk>connected T; T \<subseteq> S;
    connected_component_set S x \<inter> T \<noteq> {};
    connected_component_set S y \<inter> T \<noteq> {}\<rbrakk>
    \<Longrightarrow> connected_component_set S x = connected_component_set S y"
  by (metis (full_types) subsetD connected_component_eq connected_component_maximal disjoint_iff_not_equal)

lemma Union_connected_component: "\<Union>(connected_component_set S ` S) = S"
  apply (rule subset_antisym)
  apply (simp add: SUP_least connected_component_subset)
  using connected_component_refl_eq
  by force

lemma complement_connected_component_unions:
    "S - connected_component_set S x =
     \<Union>(connected_component_set S ` S - {connected_component_set S x})"
  apply (subst Union_connected_component [symmetric], auto)
  apply (metis connected_component_eq_eq connected_component_in)
  by (metis connected_component_eq mem_Collect_eq)

lemma connected_component_intermediate_subset:
        "\<lbrakk>connected_component_set U a \<subseteq> T; T \<subseteq> U\<rbrakk>
        \<Longrightarrow> connected_component_set T a = connected_component_set U a"
  by (metis connected_component_idemp connected_component_mono subset_antisym)

lemma connected_component_homeomorphismI:
  assumes "homeomorphism A B f g" "connected_component A x y"
  shows   "connected_component B (f x) (f y)"
proof -
  from assms obtain T where T: "connected T" "T \<subseteq> A" "x \<in> T" "y \<in> T"
    unfolding connected_component_def by blast
  have "connected (f ` T)" "f ` T \<subseteq> B" "f x \<in> f ` T" "f y \<in> f ` T"
    using assms T continuous_on_subset[of A f T]
    by (auto intro!: connected_continuous_image simp: homeomorphism_def)
  thus ?thesis
    unfolding connected_component_def by blast
qed

lemma connected_component_homeomorphism_iff:
  assumes "homeomorphism A B f g"
  shows   "connected_component A x y \<longleftrightarrow> x \<in> A \<and> y \<in> A \<and> connected_component B (f x) (f y)"
  by (metis assms connected_component_homeomorphismI connected_component_in homeomorphism_apply1 homeomorphism_sym)

lemma connected_component_set_homeomorphism:
  assumes "homeomorphism A B f g" "x \<in> A"
  shows   "connected_component_set B (f x) = f ` connected_component_set A x" (is "?lhs = ?rhs")
proof -
  have "y \<in> ?lhs \<longleftrightarrow> y \<in> ?rhs" for y
    by (smt (verit, best) assms connected_component_homeomorphism_iff homeomorphism_def image_iff mem_Collect_eq)
  thus ?thesis
    by blast
qed

subsection \<open>The set of connected components of a set\<close>

definition\<^marker>\<open>tag important\<close> components:: "'a::topological_space set \<Rightarrow> 'a set set"
  where "components S \<equiv> connected_component_set S ` S"

lemma components_iff: "S \<in> components U \<longleftrightarrow> (\<exists>x. x \<in> U \<and> S = connected_component_set U x)"
  by (auto simp: components_def)

lemma componentsI: "x \<in> U \<Longrightarrow> connected_component_set U x \<in> components U"
  by (auto simp: components_def)

lemma componentsE:
  assumes "S \<in> components U"
  obtains x where "x \<in> U" "S = connected_component_set U x"
  using assms by (auto simp: components_def)

lemma Union_components [simp]: "\<Union>(components u) = u"
  apply (rule subset_antisym)
  using Union_connected_component components_def apply fastforce
  apply (metis Union_connected_component components_def set_eq_subset)
  done

lemma pairwise_disjoint_components: "pairwise (\<lambda>X Y. X \<inter> Y = {}) (components u)"
  apply (simp add: pairwise_def)
  apply (auto simp: components_iff)
  apply (metis connected_component_eq_eq connected_component_in)+
  done

lemma in_components_nonempty: "c \<in> components s \<Longrightarrow> c \<noteq> {}"
    by (metis components_iff connected_component_eq_empty)

lemma in_components_subset: "c \<in> components s \<Longrightarrow> c \<subseteq> s"
  using Union_components by blast

lemma in_components_connected: "c \<in> components s \<Longrightarrow> connected c"
  by (metis components_iff connected_connected_component)

lemma in_components_maximal:
  "c \<in> components s \<longleftrightarrow>
    c \<noteq> {} \<and> c \<subseteq> s \<and> connected c \<and> (\<forall>d. d \<noteq> {} \<and> c \<subseteq> d \<and> d \<subseteq> s \<and> connected d \<longrightarrow> d = c)"
  apply (rule iffI)
   apply (simp add: in_components_nonempty in_components_connected)
   apply (metis (full_types) components_iff connected_component_eq_self connected_component_intermediate_subset connected_component_refl in_components_subset mem_Collect_eq rev_subsetD)
  apply (metis bot.extremum_uniqueI components_iff connected_component_eq_empty connected_component_maximal connected_component_subset connected_connected_component subset_emptyI)
  done

lemma joinable_components_eq:
  "connected t \<and> t \<subseteq> s \<and> c1 \<in> components s \<and> c2 \<in> components s \<and> c1 \<inter> t \<noteq> {} \<and> c2 \<inter> t \<noteq> {} \<Longrightarrow> c1 = c2"
  by (metis (full_types) components_iff joinable_connected_component_eq)

lemma closed_components: "\<lbrakk>closed s; c \<in> components s\<rbrakk> \<Longrightarrow> closed c"
  by (metis closed_connected_component components_iff)

lemma components_nonoverlap:
    "\<lbrakk>c \<in> components s; c' \<in> components s\<rbrakk> \<Longrightarrow> (c \<inter> c' = {}) \<longleftrightarrow> (c \<noteq> c')"
  apply (auto simp: in_components_nonempty components_iff)
    using connected_component_refl apply blast
   apply (metis connected_component_eq_eq connected_component_in)
  by (metis connected_component_eq mem_Collect_eq)

lemma components_eq: "\<lbrakk>c \<in> components s; c' \<in> components s\<rbrakk> \<Longrightarrow> (c = c' \<longleftrightarrow> c \<inter> c' \<noteq> {})"
  by (metis components_nonoverlap)

lemma components_eq_empty [simp]: "components s = {} \<longleftrightarrow> s = {}"
  by (simp add: components_def)

lemma components_empty [simp]: "components {} = {}"
  by simp

lemma connected_eq_connected_components_eq: "connected s \<longleftrightarrow> (\<forall>c \<in> components s. \<forall>c' \<in> components s. c = c')"
  by (metis (no_types, opaque_lifting) components_iff connected_component_eq_eq connected_iff_connected_component)

lemma components_eq_sing_iff: "components s = {s} \<longleftrightarrow> connected s \<and> s \<noteq> {}"
  apply (rule iffI)
  using in_components_connected apply fastforce
  apply safe
  using Union_components apply fastforce
   apply (metis components_iff connected_component_eq_self)
  using in_components_maximal
  apply auto
  done

lemma components_eq_sing_exists: "(\<exists>a. components s = {a}) \<longleftrightarrow> connected s \<and> s \<noteq> {}"
  apply (rule iffI)
  using connected_eq_connected_components_eq apply fastforce
  apply (metis components_eq_sing_iff)
  done

lemma connected_eq_components_subset_sing: "connected s \<longleftrightarrow> components s \<subseteq> {s}"
  by (metis Union_components components_empty components_eq_sing_iff connected_empty insert_subset order_refl subset_singletonD)

lemma connected_eq_components_subset_sing_exists: "connected s \<longleftrightarrow> (\<exists>a. components s \<subseteq> {a})"
  by (metis components_eq_sing_exists connected_eq_components_subset_sing empty_iff subset_iff subset_singletonD)

lemma in_components_self: "s \<in> components s \<longleftrightarrow> connected s \<and> s \<noteq> {}"
  by (metis components_empty components_eq_sing_iff empty_iff in_components_connected insertI1)

lemma components_maximal: "\<lbrakk>c \<in> components s; connected t; t \<subseteq> s; c \<inter> t \<noteq> {}\<rbrakk> \<Longrightarrow> t \<subseteq> c"
  apply (simp add: components_def ex_in_conv [symmetric], clarify)
  by (meson connected_component_def connected_component_trans)

lemma exists_component_superset: "\<lbrakk>t \<subseteq> s; s \<noteq> {}; connected t\<rbrakk> \<Longrightarrow> \<exists>c. c \<in> components s \<and> t \<subseteq> c"
  apply (cases "t = {}", force)
  apply (metis components_def ex_in_conv connected_component_maximal contra_subsetD image_eqI)
  done

lemma components_intermediate_subset: "\<lbrakk>s \<in> components u; s \<subseteq> t; t \<subseteq> u\<rbrakk> \<Longrightarrow> s \<in> components t"
  apply (auto simp: components_iff)
  apply (metis connected_component_eq_empty connected_component_intermediate_subset)
  done

lemma in_components_unions_complement: "c \<in> components s \<Longrightarrow> s - c = \<Union>(components s - {c})"
  by (metis complement_connected_component_unions components_def components_iff)

lemma connected_intermediate_closure:
  assumes cs: "connected s" and st: "s \<subseteq> t" and ts: "t \<subseteq> closure s"
  shows "connected t"
proof (rule connectedI)
  fix A B
  assume A: "open A" and B: "open B" and Alap: "A \<inter> t \<noteq> {}" and Blap: "B \<inter> t \<noteq> {}"
    and disj: "A \<inter> B \<inter> t = {}" and cover: "t \<subseteq> A \<union> B"
  have disjs: "A \<inter> B \<inter> s = {}"
    using disj st by auto
  have "A \<inter> closure s \<noteq> {}"
    using Alap Int_absorb1 ts by blast
  then have Alaps: "A \<inter> s \<noteq> {}"
    by (simp add: A open_Int_closure_eq_empty)
  have "B \<inter> closure s \<noteq> {}"
    using Blap Int_absorb1 ts by blast
  then have Blaps: "B \<inter> s \<noteq> {}"
    by (simp add: B open_Int_closure_eq_empty)
  then show False
    using cs [unfolded connected_def] A B disjs Alaps Blaps cover st
    by blast
qed

lemma closedin_connected_component: "closedin (top_of_set s) (connected_component_set s x)"
proof (cases "connected_component_set s x = {}")
  case True
  then show ?thesis
    by (metis closedin_empty)
next
  case False
  then obtain y where y: "connected_component s x y"
    by blast
  have *: "connected_component_set s x \<subseteq> s \<inter> closure (connected_component_set s x)"
    by (auto simp: closure_def connected_component_in)
  have "connected_component s x y \<Longrightarrow> s \<inter> closure (connected_component_set s x) \<subseteq> connected_component_set s x"
    apply (rule connected_component_maximal, simp)
    using closure_subset connected_component_in apply fastforce
    using * connected_intermediate_closure apply blast+
    done
  with y * show ?thesis
    by (auto simp: closedin_closed)
qed

lemma closedin_component:
   "C \<in> components s \<Longrightarrow> closedin (top_of_set s) C"
  using closedin_connected_component componentsE by blast

subsection\<^marker>\<open>tag unimportant\<close> \<open>Proving a function is constant on a connected set
  by proving that a level set is open\<close>

lemma continuous_levelset_openin_cases:
  fixes f :: "_ \<Rightarrow> 'b::t1_space"
  shows "connected s \<Longrightarrow> continuous_on s f \<Longrightarrow>
        openin (top_of_set s) {x \<in> s. f x = a}
        \<Longrightarrow> (\<forall>x \<in> s. f x \<noteq> a) \<or> (\<forall>x \<in> s. f x = a)"
  unfolding connected_clopen
  using continuous_closedin_preimage_constant by auto

lemma continuous_levelset_openin:
  fixes f :: "_ \<Rightarrow> 'b::t1_space"
  shows "connected s \<Longrightarrow> continuous_on s f \<Longrightarrow>
        openin (top_of_set s) {x \<in> s. f x = a} \<Longrightarrow>
        (\<exists>x \<in> s. f x = a)  \<Longrightarrow> (\<forall>x \<in> s. f x = a)"
  using continuous_levelset_openin_cases[of s f ]
  by meson

lemma continuous_levelset_open:
  fixes f :: "_ \<Rightarrow> 'b::t1_space"
  assumes "connected s"
    and "continuous_on s f"
    and "open {x \<in> s. f x = a}"
    and "\<exists>x \<in> s.  f x = a"
  shows "\<forall>x \<in> s. f x = a"
  using continuous_levelset_openin[OF assms(1,2), of a, unfolded openin_open]
  using assms (3,4)
  by fast

subsection\<^marker>\<open>tag unimportant\<close> \<open>Preservation of Connectedness\<close>

lemma homeomorphic_connectedness:
  assumes "s homeomorphic t"
  shows "connected s \<longleftrightarrow> connected t"
using assms unfolding homeomorphic_def homeomorphism_def by (metis connected_continuous_image)

lemma connected_monotone_quotient_preimage:
  assumes "connected T"
      and contf: "continuous_on S f" and fim: "f ` S = T"
      and opT: "\<And>U. U \<subseteq> T
                 \<Longrightarrow> openin (top_of_set S) (S \<inter> f -` U) \<longleftrightarrow>
                     openin (top_of_set T) U"
      and connT: "\<And>y. y \<in> T \<Longrightarrow> connected (S \<inter> f -` {y})"
    shows "connected S"
proof (rule connectedI)
  fix U V
  assume "open U" and "open V" and "U \<inter> S \<noteq> {}" and "V \<inter> S \<noteq> {}"
    and "U \<inter> V \<inter> S = {}" and "S \<subseteq> U \<union> V"
  moreover
  have disjoint: "f ` (S \<inter> U) \<inter> f ` (S \<inter> V) = {}"
  proof -
    have False if "y \<in> f ` (S \<inter> U) \<inter> f ` (S \<inter> V)" for y
    proof -
      have "y \<in> T"
        using fim that by blast
      show ?thesis
        using connectedD [OF connT [OF \<open>y \<in> T\<close>] \<open>open U\<close> \<open>open V\<close>]
              \<open>S \<subseteq> U \<union> V\<close> \<open>U \<inter> V \<inter> S = {}\<close> that by fastforce
    qed
    then show ?thesis by blast
  qed
  ultimately have UU: "(S \<inter> f -` f ` (S \<inter> U)) = S \<inter> U" and VV: "(S \<inter> f -` f ` (S \<inter> V)) = S \<inter> V"
    by auto
  have opeU: "openin (top_of_set T) (f ` (S \<inter> U))"
    by (metis UU \<open>open U\<close> fim image_Int_subset le_inf_iff opT openin_open_Int)
  have opeV: "openin (top_of_set T) (f ` (S \<inter> V))"
    by (metis opT fim VV \<open>open V\<close> openin_open_Int image_Int_subset inf.bounded_iff)
  have "T \<subseteq> f ` (S \<inter> U) \<union> f ` (S \<inter> V)"
    using \<open>S \<subseteq> U \<union> V\<close> fim by auto
  then show False
    using \<open>connected T\<close> disjoint opeU opeV \<open>U \<inter> S \<noteq> {}\<close> \<open>V \<inter> S \<noteq> {}\<close>
    by (auto simp: connected_openin)
qed

lemma connected_open_monotone_preimage:
  assumes contf: "continuous_on S f" and fim: "f ` S = T"
    and ST: "\<And>C. openin (top_of_set S) C \<Longrightarrow> openin (top_of_set T) (f ` C)"
    and connT: "\<And>y. y \<in> T \<Longrightarrow> connected (S \<inter> f -` {y})"
    and "connected C" "C \<subseteq> T"
  shows "connected (S \<inter> f -` C)"
proof -
  have contf': "continuous_on (S \<inter> f -` C) f"
    by (meson contf continuous_on_subset inf_le1)
  have eqC: "f ` (S \<inter> f -` C) = C"
    using \<open>C \<subseteq> T\<close> fim by blast
  show ?thesis
  proof (rule connected_monotone_quotient_preimage [OF \<open>connected C\<close> contf' eqC])
    show "connected (S \<inter> f -` C \<inter> f -` {y})" if "y \<in> C" for y
    proof -
      have "S \<inter> f -` C \<inter> f -` {y} = S \<inter> f -` {y}"
        using that by blast
      moreover have "connected (S \<inter> f -` {y})"
        using \<open>C \<subseteq> T\<close> connT that by blast
      ultimately show ?thesis
        by metis
    qed
    have "\<And>U. openin (top_of_set (S \<inter> f -` C)) U
               \<Longrightarrow> openin (top_of_set C) (f ` U)"
      using open_map_restrict [OF _ ST \<open>C \<subseteq> T\<close>] by metis
    then show "\<And>D. D \<subseteq> C
          \<Longrightarrow> openin (top_of_set (S \<inter> f -` C)) (S \<inter> f -` C \<inter> f -` D) =
              openin (top_of_set C) D"
      using open_map_imp_quotient_map [of "(S \<inter> f -` C)" f] contf' by (simp add: eqC)
  qed
qed

lemma connected_closed_monotone_preimage:
  assumes contf: "continuous_on S f" and fim: "f ` S = T"
    and ST: "\<And>C. closedin (top_of_set S) C \<Longrightarrow> closedin (top_of_set T) (f ` C)"
    and connT: "\<And>y. y \<in> T \<Longrightarrow> connected (S \<inter> f -` {y})"
    and "connected C" "C \<subseteq> T"
  shows "connected (S \<inter> f -` C)"
proof -
  have contf': "continuous_on (S \<inter> f -` C) f"
    by (meson contf continuous_on_subset inf_le1)
  have eqC: "f ` (S \<inter> f -` C) = C"
    using \<open>C \<subseteq> T\<close> fim by blast
  show ?thesis
  proof (rule connected_monotone_quotient_preimage [OF \<open>connected C\<close> contf' eqC])
    show "connected (S \<inter> f -` C \<inter> f -` {y})" if "y \<in> C" for y
    proof -
      have "S \<inter> f -` C \<inter> f -` {y} = S \<inter> f -` {y}"
        using that by blast
      moreover have "connected (S \<inter> f -` {y})"
        using \<open>C \<subseteq> T\<close> connT that by blast
      ultimately show ?thesis
        by metis
    qed
    have "\<And>U. closedin (top_of_set (S \<inter> f -` C)) U
               \<Longrightarrow> closedin (top_of_set C) (f ` U)"
      using closed_map_restrict [OF _ ST \<open>C \<subseteq> T\<close>] by metis
    then show "\<And>D. D \<subseteq> C
          \<Longrightarrow> openin (top_of_set (S \<inter> f -` C)) (S \<inter> f -` C \<inter> f -` D) =
              openin (top_of_set C) D"
      using closed_map_imp_quotient_map [of "(S \<inter> f -` C)" f] contf' by (simp add: eqC)
  qed
qed

subsection\<open>Lemmas about components\<close>

text  \<open>See Newman IV, 3.3 and 3.4.\<close>

lemma connected_Un_clopen_in_complement:
  fixes S U :: "'a::metric_space set"
  assumes "connected S" "connected U" "S \<subseteq> U"
      and opeT: "openin (top_of_set (U - S)) T"
      and cloT: "closedin (top_of_set (U - S)) T"
    shows "connected (S \<union> T)"
proof -
  have *: "\<lbrakk>\<And>x y. P x y \<longleftrightarrow> P y x; \<And>x y. P x y \<Longrightarrow> S \<subseteq> x \<or> S \<subseteq> y;
            \<And>x y. \<lbrakk>P x y; S \<subseteq> x\<rbrakk> \<Longrightarrow> False\<rbrakk> \<Longrightarrow> \<not>(\<exists>x y. (P x y))" for P
    by metis
  show ?thesis
    unfolding connected_closedin_eq
  proof (rule *)
    fix H1 H2
    assume H: "closedin (top_of_set (S \<union> T)) H1 \<and>
               closedin (top_of_set (S \<union> T)) H2 \<and>
               H1 \<union> H2 = S \<union> T \<and> H1 \<inter> H2 = {} \<and> H1 \<noteq> {} \<and> H2 \<noteq> {}"
    then have clo: "closedin (top_of_set S) (S \<inter> H1)"
                   "closedin (top_of_set S) (S \<inter> H2)"
      by (metis Un_upper1 closedin_closed_subset inf_commute)+
    have Seq: "S \<inter> (H1 \<union> H2) = S"
      by (simp add: H)
    have "S \<inter> ((S \<union> T) \<inter> H1) \<union> S \<inter> ((S \<union> T) \<inter> H2) = S"
      using Seq by auto
    moreover have "H1 \<inter> (S \<inter> ((S \<union> T) \<inter> H2)) = {}"
      using H by blast
    ultimately have "S \<inter> H1 = {} \<or> S \<inter> H2 = {}"
      by (metis (no_types) H Int_assoc \<open>S \<inter> (H1 \<union> H2) = S\<close> \<open>connected S\<close>
          clo Seq connected_closedin inf_bot_right inf_le1)
    then show "S \<subseteq> H1 \<or> S \<subseteq> H2"
      using H \<open>connected S\<close> unfolding connected_closedin by blast
  next
    fix H1 H2
    assume H: "closedin (top_of_set (S \<union> T)) H1 \<and>
               closedin (top_of_set (S \<union> T)) H2 \<and>
               H1 \<union> H2 = S \<union> T \<and> H1 \<inter> H2 = {} \<and> H1 \<noteq> {} \<and> H2 \<noteq> {}"
       and "S \<subseteq> H1"
    then have H2T: "H2 \<subseteq> T"
      by auto
    have "T \<subseteq> U"
      using Diff_iff opeT openin_imp_subset by auto
    with \<open>S \<subseteq> U\<close> have Ueq: "U = (U - S) \<union> (S \<union> T)"
      by auto
    have "openin (top_of_set ((U - S) \<union> (S \<union> T))) H2"
    proof (rule openin_subtopology_Un)
      show "openin (top_of_set (S \<union> T)) H2"
        using \<open>H2 \<subseteq> T\<close> apply (auto simp: openin_closedin_eq)
        by (metis Diff_Diff_Int Diff_disjoint Diff_partition Diff_subset H Int_absorb1 Un_Diff)
      then show "openin (top_of_set (U - S)) H2"
        by (meson H2T Un_upper2 opeT openin_subset_trans openin_trans)
    qed
    moreover have "closedin (top_of_set ((U - S) \<union> (S \<union> T))) H2"
    proof (rule closedin_subtopology_Un)
      show "closedin (top_of_set (U - S)) H2"
        using H H2T cloT closedin_subset_trans
        by (blast intro: closedin_subtopology_Un closedin_trans)
    qed (simp add: H)
    ultimately
    have H2: "H2 = {} \<or> H2 = U"
      using Ueq \<open>connected U\<close> unfolding connected_clopen by metis
    then have "H2 \<subseteq> S"
      by (metis Diff_partition H Un_Diff_cancel Un_subset_iff \<open>H2 \<subseteq> T\<close> assms(3) inf.orderE opeT openin_imp_subset)
    moreover have "T \<subseteq> H2 - S"
      by (metis (no_types) H2 H opeT openin_closedin_eq topspace_euclidean_subtopology)
    ultimately show False
      using H \<open>S \<subseteq> H1\<close> by blast
  qed blast
qed

proposition component_diff_connected:
  fixes S :: "'a::metric_space set"
  assumes "connected S" "connected U" "S \<subseteq> U" and C: "C \<in> components (U - S)"
  shows "connected(U - C)"
  using \<open>connected S\<close> unfolding connected_closedin_eq not_ex de_Morgan_conj
proof clarify
  fix H3 H4
  assume clo3: "closedin (top_of_set (U - C)) H3"
    and clo4: "closedin (top_of_set (U - C)) H4"
    and "H3 \<union> H4 = U - C" and "H3 \<inter> H4 = {}" and "H3 \<noteq> {}" and "H4 \<noteq> {}"
    and * [rule_format]:
    "\<forall>H1 H2. \<not> closedin (top_of_set S) H1 \<or>
                      \<not> closedin (top_of_set S) H2 \<or>
                      H1 \<union> H2 \<noteq> S \<or> H1 \<inter> H2 \<noteq> {} \<or> \<not> H1 \<noteq> {} \<or> \<not> H2 \<noteq> {}"
  then have "H3 \<subseteq> U-C" and ope3: "openin (top_of_set (U - C)) (U - C - H3)"
    and "H4 \<subseteq> U-C" and ope4: "openin (top_of_set (U - C)) (U - C - H4)"
    by (auto simp: closedin_def)
  have "C \<noteq> {}" "C \<subseteq> U-S" "connected C"
    using C in_components_nonempty in_components_subset in_components_maximal by blast+
  have cCH3: "connected (C \<union> H3)"
  proof (rule connected_Un_clopen_in_complement [OF \<open>connected C\<close> \<open>connected U\<close> _ _ clo3])
    show "openin (top_of_set (U - C)) H3"
      apply (simp add: openin_closedin_eq \<open>H3 \<subseteq> U - C\<close>)
      apply (simp add: closedin_subtopology)
      by (metis Diff_cancel Diff_triv Un_Diff clo4 \<open>H3 \<inter> H4 = {}\<close> \<open>H3 \<union> H4 = U - C\<close> closedin_closed inf_commute sup_bot.left_neutral)
  qed (use clo3 \<open>C \<subseteq> U - S\<close> in auto)
  have cCH4: "connected (C \<union> H4)"
  proof (rule connected_Un_clopen_in_complement [OF \<open>connected C\<close> \<open>connected U\<close> _ _ clo4])
    show "openin (top_of_set (U - C)) H4"
      apply (simp add: openin_closedin_eq \<open>H4 \<subseteq> U - C\<close>)
      apply (simp add: closedin_subtopology)
      by (metis Diff_cancel Int_commute Un_Diff Un_Diff_Int \<open>H3 \<inter> H4 = {}\<close> \<open>H3 \<union> H4 = U - C\<close> clo3 closedin_closed)
  qed (use clo4 \<open>C \<subseteq> U - S\<close> in auto)
  have "closedin (top_of_set S) (S \<inter> H3)" "closedin (top_of_set S) (S \<inter> H4)"
    using clo3 clo4 \<open>S \<subseteq> U\<close> \<open>C \<subseteq> U - S\<close> by (auto simp: closedin_closed)
  moreover have "S \<inter> H3 \<noteq> {}"
    using components_maximal [OF C cCH3] \<open>C \<noteq> {}\<close> \<open>C \<subseteq> U - S\<close> \<open>H3 \<noteq> {}\<close> \<open>H3 \<subseteq> U - C\<close> by auto
  moreover have "S \<inter> H4 \<noteq> {}"
    using components_maximal [OF C cCH4] \<open>C \<noteq> {}\<close> \<open>C \<subseteq> U - S\<close> \<open>H4 \<noteq> {}\<close> \<open>H4 \<subseteq> U - C\<close> by auto
  ultimately show False
    using * [of "S \<inter> H3" "S \<inter> H4"] \<open>H3 \<inter> H4 = {}\<close> \<open>C \<subseteq> U - S\<close> \<open>H3 \<union> H4 = U - C\<close> \<open>S \<subseteq> U\<close>
    by auto
qed

subsection\<^marker>\<open>tag unimportant\<close>\<open>Constancy of a function from a connected set into a finite, disconnected or discrete set\<close>

text\<open>Still missing: versions for a set that is smaller than R, or countable.\<close>

lemma continuous_disconnected_range_constant:
  assumes S: "connected S"
      and conf: "continuous_on S f"
      and fim: "f ` S \<subseteq> t"
      and cct: "\<And>y. y \<in> t \<Longrightarrow> connected_component_set t y = {y}"
    shows "f constant_on S"
proof (cases "S = {}")
  case True then show ?thesis
    by (simp add: constant_on_def)
next
  case False
  { fix x assume "x \<in> S"
    then have "f ` S \<subseteq> {f x}"
    by (metis connected_continuous_image conf connected_component_maximal fim image_subset_iff rev_image_eqI S cct)
  }
  with False show ?thesis
    unfolding constant_on_def by blast
qed

text\<open>This proof requires the existence of two separate values of the range type.\<close>
lemma finite_range_constant_imp_connected:
  assumes "\<And>f::'a::topological_space \<Rightarrow> 'b::real_normed_algebra_1.
              \<lbrakk>continuous_on S f; finite(f ` S)\<rbrakk> \<Longrightarrow> f constant_on S"
    shows "connected S"
proof -
  { fix t u
    assume clt: "closedin (top_of_set S) t"
       and clu: "closedin (top_of_set S) u"
       and tue: "t \<inter> u = {}" and tus: "t \<union> u = S"
    have conif: "continuous_on S (\<lambda>x. if x \<in> t then 0 else 1)"
      apply (subst tus [symmetric])
      apply (rule continuous_on_cases_local)
      using clt clu tue
      apply (auto simp: tus)
      done
    have fi: "finite ((\<lambda>x. if x \<in> t then 0 else 1) ` S)"
      by (rule finite_subset [of _ "{0,1}"]) auto
    have "t = {} \<or> u = {}"
      using assms [OF conif fi] tus [symmetric]
      by (auto simp: Ball_def constant_on_def) (metis IntI empty_iff one_neq_zero tue)
  }
  then show ?thesis
    by (simp add: connected_closedin_eq)
qed

end


theory ConcreteSemantics10_1_Fold
  imports Main "~~/src/HOL/IMP/Big_Step"  "~~/src/HOL/IMP/Vars"
begin

subsection "Simple folding of arithmetic expressions"

type_synonym tab = "vname \<Rightarrow> val option"

fun afold :: "aexp \<Rightarrow> tab \<Rightarrow> aexp" where
"afold (N n) _ = N n" |
"afold (V x) t = (case t x of None \<Rightarrow> V x | Some k \<Rightarrow> N k)" |
"afold (Plus e1 e2) t = (case (afold e1 t, afold e2 t) of
  (N n1, N n2) \<Rightarrow> N(n1+n2) | (e1',e2') \<Rightarrow> Plus e1' e2')"

definition  "approx t s \<longleftrightarrow> (\<forall> x k. t x = Some k \<longrightarrow> s x = k)"

(*Lemma 10.6 (Correctness of afold).*)
theorem aval_afold[simp]:
assumes "approx t s"
shows "aval (afold a t) s = aval a s"
proof (induction a)
  case (N x)
  then show ?case by auto
next
  case (V x)
  then show ?case using assms by (auto simp: approx_def split: option.split )
next
  case (Plus a1 a2)
  then show ?case using assms by (auto simp: approx_def split: option.split aexp.split)
qed

theorem aval_afold_N:
assumes "approx t s"
shows "afold a t = N n \<Longrightarrow> aval a s = n"
  by (metis assms aval.simps(1) aval_afold)

definition
  "merge t1 t2 = (\<lambda>m. if t1 m = t2 m then t1 m else None)"

primrec "defs" :: "com \<Rightarrow> tab \<Rightarrow> tab" where
"defs SKIP t = t" |
"defs (x ::= a) t =
  (case afold a t of N k \<Rightarrow> t(x \<mapsto> k) | _ \<Rightarrow> t(x:=None))" |
"defs (c1;;c2) t = (defs c2 o defs c1) t" |
"defs (IF b THEN c1 ELSE c2) t = merge (defs c1 t) (defs c2 t)" |
"defs (WHILE b DO c) t = t |` (-lvars c)"

primrec fold where
"fold SKIP _ = SKIP" |
"fold (x ::= a) t = (x ::= (afold a t))" |
"fold (c1;;c2) t = (fold c1 t;; fold c2 (defs c1 t))" |
"fold (IF b THEN c1 ELSE c2) t = IF b THEN fold c1 t ELSE fold c2 t" |
"fold (WHILE b DO c) t = WHILE b DO fold c (t |` (-lvars c))"

value "fold(''x'' ::= Plus (N 42) (N (- 5))) nil"
value "defs (fold(''x'' ::= Plus (N 42) (N (- 5))) nil ) nil"
value "fold(''y'' ::= Plus (V ''x'') (V ''x'')) (defs (fold(''x'' ::= Plus (N 42) (N (- 5))) nil ) nil)"
value "fold(''x'' ::= Plus (N 42) (N (- 5));;''y'' ::= Plus (V ''x'') (V ''x'')) nil"

subsection "Semantic Equivalence up to a Condition"

type_synonym assn = "state \<Rightarrow> bool"

definition
  equiv_up_to :: "assn \<Rightarrow> com \<Rightarrow> com \<Rightarrow> bool" ("_ \<Turnstile> _ \<sim> _" [50,0,10] 50)
where
  "(P \<Turnstile> c \<sim> c') = (\<forall>s s'. P s \<longrightarrow> (c,s) \<Rightarrow> s' \<longleftrightarrow> (c',s) \<Rightarrow> s')"

definition
  bequiv_up_to :: "assn \<Rightarrow> bexp \<Rightarrow> bexp \<Rightarrow> bool" ("_ \<Turnstile> _ <\<sim>> _" [50,0,10] 50)
where
  "(P \<Turnstile> b <\<sim>> b') = (\<forall>s. P s \<longrightarrow> bval b s = bval b' s)"

(* Lemma 10.7. *)
lemma equiv_up_to_True:
  "((\<lambda>_. True) \<Turnstile> c \<sim> c') = (c \<sim> c')"
  by (simp add: equiv_up_to_def)

lemma equiv_up_to_weaken:
  "P \<Turnstile> c \<sim> c' \<Longrightarrow> (\<And>s. P' s \<Longrightarrow> P s) \<Longrightarrow> P' \<Turnstile> c \<sim> c'"
  by (simp add: equiv_up_to_def)

lemma equiv_up_toI:
  "(\<And>s s'. P s \<Longrightarrow> (c, s) \<Rightarrow> s' = (c', s) \<Rightarrow> s') \<Longrightarrow> P \<Turnstile> c \<sim> c'"
  by (unfold equiv_up_to_def) blast

lemma equiv_up_toD1:
  "P \<Turnstile> c \<sim> c' \<Longrightarrow> (c, s) \<Rightarrow> s' \<Longrightarrow> P s \<Longrightarrow> (c', s) \<Rightarrow> s'"
  by (unfold equiv_up_to_def) blast

lemma equiv_up_toD2:
  "P \<Turnstile> c \<sim> c' \<Longrightarrow> (c', s) \<Rightarrow> s' \<Longrightarrow> P s \<Longrightarrow> (c, s) \<Rightarrow> s'"
  by (unfold equiv_up_to_def) blast

(* Lemma 10.8 (Equivalence Relation). *)
lemma equiv_up_to_refl [simp, intro!]:
  "P \<Turnstile> c \<sim> c"
  by (simp add: equiv_up_to_def)

lemma equiv_up_to_sym:
  "(P \<Turnstile> c \<sim> c') = (P \<Turnstile> c' \<sim> c)"
  by (auto simp add: equiv_up_to_def)

lemma equiv_up_to_trans:
  "P \<Turnstile> c \<sim> c' \<Longrightarrow> P \<Turnstile> c' \<sim> c'' \<Longrightarrow> P \<Turnstile> c \<sim> c''"
  by(auto simp add: equiv_up_to_def)

lemma bequiv_up_to_refl [simp, intro!]:
  "P \<Turnstile> b <\<sim>> b"
  by (auto simp: bequiv_up_to_def)

lemma bequiv_up_to_sym:
  "(P \<Turnstile> b <\<sim>> b') = (P \<Turnstile> b' <\<sim>> b)"
  by (auto simp: bequiv_up_to_def)

lemma bequiv_up_to_trans:
  "P \<Turnstile> b <\<sim>> b' \<Longrightarrow> P \<Turnstile> b' <\<sim>> b'' \<Longrightarrow> P \<Turnstile> b <\<sim>> b''"
  by (auto simp: bequiv_up_to_def)

lemma bequiv_up_to_subst:
  "P \<Turnstile> b <\<sim>> b' \<Longrightarrow> P s \<Longrightarrow> bval b s = bval b' s"
  by (simp add: bequiv_up_to_def)

(* Congruence rules *)
lemma equiv_up_to_seq:
  "P \<Turnstile> c \<sim> c' \<Longrightarrow> Q \<Turnstile> d \<sim> d' \<Longrightarrow>
  (\<And>s s'. (c,s) \<Rightarrow> s' \<Longrightarrow> P s \<Longrightarrow> Q s') \<Longrightarrow>
  P \<Turnstile> (c;; d) \<sim> (c';; d')"
  apply(simp add: equiv_up_to_def)
  apply blast
  done

lemma equiv_up_to_if_weak:
  "P \<Turnstile> b <\<sim>> b' \<Longrightarrow> P \<Turnstile> c \<sim> c' \<Longrightarrow> P \<Turnstile> d \<sim> d' \<Longrightarrow>
   P \<Turnstile> IF b THEN c ELSE d \<sim> IF b' THEN c' ELSE d'"
  apply(auto simp: bequiv_up_to_def equiv_up_to_def)
  done

lemma equiv_up_to_while_lemma_weak:
  shows "(d,s) \<Rightarrow> s' \<Longrightarrow>
         P \<Turnstile> b <\<sim>> b' \<Longrightarrow>
         P \<Turnstile> c \<sim> c' \<Longrightarrow>
         (\<And>s s'. (c, s) \<Rightarrow> s' \<Longrightarrow> P s \<Longrightarrow> bval b s \<Longrightarrow> P s') \<Longrightarrow>
         P s \<Longrightarrow>
         d = WHILE b DO c \<Longrightarrow>
         (WHILE b' DO c', s) \<Rightarrow> s'"
  sorry

lemma equiv_up_to_while_weak:
  assumes b: "P \<Turnstile> b <\<sim>> b'"
  assumes c: "P \<Turnstile> c \<sim> c'"
  assumes I: "\<And>s s'. (c, s) \<Rightarrow> s' \<Longrightarrow> P s \<Longrightarrow> bval b s \<Longrightarrow> P s'"
  shows "P \<Turnstile> WHILE b DO c \<sim> WHILE b' DO c'"
proof -
  from b have b': "P \<Turnstile> b' <\<sim>> b"
    by (simp add: bequiv_up_to_sym)
  from c have c': "P \<Turnstile> c' \<sim> c"
    by (simp add: equiv_up_to_sym)

  from I have I' :"\<And>s s'. (c', s) \<Rightarrow> s' \<Longrightarrow> P s \<Longrightarrow> bval b' s \<Longrightarrow> P s'"
    using b' bequiv_up_to_subst c' equiv_up_to_def by auto

  note equiv_up_to_while_lemma_weak [OF _ b c]
       equiv_up_to_while_lemma_weak [OF _ b' c']
  thus ?thesis using I I' by (auto intro!: equiv_up_toI)
qed

lemma approx_merge:
  "approx t1 s \<or> approx t2 s \<Longrightarrow> approx (merge t1 t2) s"
  by (fastforce simp: merge_def approx_def)

lemma approx_map_le:
  "approx t2 s \<Longrightarrow> t1 \<subseteq>\<^sub>m t2 \<Longrightarrow> approx t1 s"
  by (clarsimp simp: approx_def map_le_def dom_def)

lemma restrict_map_le [intro!, simp]: "t |` S \<subseteq>\<^sub>m t"
  by (clarsimp simp: restrict_map_def map_le_def)

lemma merge_restrict:
  assumes "t1 |` S = t |` S"
  assumes "t2 |` S = t |` S"
  shows "merge t1 t2 |` S = t |` S"
proof -
  from assms
  have "\<forall>x. (t1 |` S) x = (t |` S) x"
   and "\<forall>x. (t2 |` S) x = (t |` S) x" by auto
  thus ?thesis
    by (auto simp: merge_def restrict_map_def
             split: if_splits)
qed

(* Lemma 10.10. *)
lemma defs_restrict:
  "defs c t |` (- lvars c) = t |` (- lvars c)"
proof(induction c arbitrary: t)
  case SKIP
  then show ?case
    by simp
next
  case (Assign x1 x2)
  then show ?case by (auto split: aexp.split)
next
  case (Seq c1 c2)
(*
    defs c1 ?t |` (- lvars c1) = ?t |` (- lvars c1)
    defs c2 ?t |` (- lvars c2) = ?t |` (- lvars c2)

defs (?c1.2;; ?c2.2) ?ta2 |` (- lvars (?c1.2;; ?c2.2)) = ?ta2 |` (- lvars (?c1.2;; ?c2.2))
*)
  have "defs c2 (defs c1 t) |` (- lvars c2) |` (- lvars c1) =
         defs c1 t |` (- lvars c2) |` (- lvars c1)"
    by (simp add: Seq.IH(2))
  moreover have "defs c1 t |` (- lvars c1) |` (-lvars c2) =
         t |` (- lvars c1) |` (-lvars c2)"
    by (simp add: Seq.IH(1))
  ultimately show ?case
    by (simp add: Int_commute)
next
  case (If x1 c1 c2)
(*
  (\<And>t. defs ?c1.2 t |` (- lvars ?c1.2) = t |` (- lvars ?c1.2)) \<Longrightarrow>
  (\<And>t. defs ?c2.2 t |` (- lvars ?c2.2) = t |` (- lvars ?c2.2)) \<Longrightarrow>
  defs (IF ?x1.2 THEN ?c1.2 ELSE ?c2.2) ?ta2 |` (- lvars (IF ?x1.2 THEN ?c1.2 ELSE ?c2.2)) =
  ?ta2 |` (- lvars (IF ?x1.2 THEN ?c1.2 ELSE ?c2.2))
*)
  have "defs c1 t |` (- lvars c1) |` (- lvars c2) =
         t |` (- lvars c1) |` (- lvars c2)"
    using If.IH(1) by auto
  moreover have "defs c2 t |` (- lvars c1) |` (-lvars c2) =
         t |` (- lvars c1) |` (-lvars c2)"
    by (metis If.IH(2) inf_sup_aci(1) restrict_restrict)
  ultimately  show ?case by (auto simp: Int_commute intro: merge_restrict)
next
  case (While x1 c)
  then show ?case by (auto split: aexp.split)
qed

(* Lemma 10.9 (defs approximates execution correctly). *)
lemma big_step_pres_approx:
  "(c,s) \<Rightarrow> s' \<Longrightarrow> approx t s \<Longrightarrow> approx (defs c t) s'"
proof(induction arbitrary: t rule: big_step_induct )
case (Skip s)
  then show ?case by simp
next
  case (Assign x a s)
  then show ?case
    (*by(simp add: approx_def split: aexp.split)*)
    by(simp add: aval_afold_N approx_def split: aexp.split)
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
(*
  (\<And>t. approx t ?s\<^sub>12 \<Longrightarrow> approx (defs ?c\<^sub>12 t) ?s\<^sub>22) \<Longrightarrow>
  (\<And>t. approx t ?s\<^sub>22 \<Longrightarrow> approx (defs ?c\<^sub>22 t) ?s\<^sub>32) \<Longrightarrow>
*)
  have "approx (defs c\<^sub>1 t) s\<^sub>2"
    by (simp add: Seq.IH(1) Seq.prems)
  have "approx (defs c\<^sub>2 (defs c\<^sub>1 t)) s\<^sub>3"
    by (simp add: Seq.IH(2) \<open>approx (defs c\<^sub>1 t) s\<^sub>2\<close>)
  then show ?case
    by simp
next
  case (IfTrue b s c\<^sub>1 t c\<^sub>2)
  then show ?case
    by (simp add: approx_merge)
next
  case (IfFalse b s c\<^sub>2 t c\<^sub>1)
  then show ?case
    by (simp add: approx_merge)
next
  case (WhileFalse b s c)
  then show ?case
    by (simp add: approx_def restrict_map_def)
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  hence "approx (defs c t) s\<^sub>2" by simp
  then have "approx (defs c t |` (-lvars c)) s\<^sub>3"
    using WhileTrue.IH(2) by auto
  then show ?case
    by (simp add: defs_restrict)
qed

(* Lemma 10.11. *)

lemma big_step_pres_approx_restrict:
  "(c,s) \<Rightarrow> s' \<Longrightarrow> approx (t |` (-lvars c)) s \<Longrightarrow> approx (t |` (-lvars c)) s'"
proof(induction arbitrary: t rule: big_step_induct)
case (Skip s)
  then show ?case by simp
next
  case (Assign x a s)
  then show ?case by(simp add: aval_afold_N approx_def split: aexp.split)
next
  case (Seq c1 s1 s2 c2 s3)
(*
using this:
    defs c2 (defs c1 t) |` (- lvars c2) |` (- lvars c1) =
    defs c1 t |` (- lvars c2) |` (- lvars c1)
    defs c1 t |` (- lvars c1) |` (- lvars c2) = t |` (- lvars c1) |` (- lvars c2)

goal (1 subgoal):
 1. approx (t |` (- lvars (c1;; c2))) s3
*)
  then have "approx (t |` (-lvars c2) |` (-lvars c1)) s1" by (simp add: Int_commute)
  hence "approx (t |` (-lvars c2) |` (-lvars c1)) s2"
    by (rule Seq)
  hence "approx (t |` (-lvars c1) |` (-lvars c2)) s2"
    by (simp add: Int_commute)
  then have "approx (t |` (-lvars c1) |` (-lvars c2)) s3"
    using Seq.IH(2) by blast
  then show ?case by simp
next
  case (IfTrue b s c1 s' c2)
(*
using this:
    bval b s
    (c\<^sub>1, s) \<Rightarrow> ta__
    approx (?t |` (- lvars c\<^sub>1)) s \<Longrightarrow> approx (?t |` (- lvars c\<^sub>1)) ta__
    approx (t |` (- lvars (IF b THEN c\<^sub>1 ELSE c\<^sub>2))) s

goal (1 subgoal):
 1. approx (t |` (- lvars (IF b THEN c\<^sub>1 ELSE c\<^sub>2))) ta__
*)
  then have "approx (t |` (-lvars c2) |` (-lvars c1)) s" by (simp add: Int_commute)
  then have "approx (t |` (-lvars c2) |` (-lvars c1)) s'"
    using IfTrue.IH by blast
  then show ?case
    (*by (simp add: approx_merge)*)
    by (simp add: Int_commute)
next
  case (IfFalse b s c2 s' c1)
  then have "approx (t |` (-lvars c1) |` (-lvars c2)) s" by (simp add: Int_commute)
  then have "approx (t |` (-lvars c1) |` (-lvars c2)) s'"
    using IfFalse.IH by blast
  then show ?case
    (*by (simp add: approx_merge)*)
    by (simp add: Int_commute)
next
  case (WhileFalse b s c)
  then show ?case
    by (simp add: approx_def restrict_map_def)
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  then show ?case
    by (simp add: defs_restrict)
qed

(* Lemma 10.12 (Generalized correctness of constant folding). *)
text \<open>
the declaration is needed to prove the case of Assign.
\<close>
(*declare assign_simp [simp]*)

lemma approx_eq:
  "approx t \<Turnstile> c \<sim> fold c t"
  proof(induction c arbitrary: t)
case SKIP
  then show ?case by simp
next
  case (Assign x1 x2)
  then show ?case by (auto simp: assign_simp equiv_up_to_def)
next
  case (Seq c1 c2)
  then show ?case
    by (auto intro!: equiv_up_to_seq big_step_pres_approx)
(*    by (smt ConcreteSemantics10_1_Fold.fold.simps(3) big_step_pres_approx equiv_up_to_seq)*)
next
  case (If x1 c1 c2)
  then show ?case
    by (simp add: equiv_up_to_if_weak)
next
  case (While x1 c)
(*
 1. \<And>x1 c t.
       (\<And>t. approx t \<Turnstile> c \<sim> ConcreteSemantics10_1_Fold.fold c t) \<Longrightarrow>
       approx t \<Turnstile> WHILE x1 DO c \<sim> ConcreteSemantics10_1_Fold.fold (WHILE x1 DO c) t
*)
  then have "approx (t |` (- lvars c)) \<Turnstile> WHILE x1 DO c \<sim> WHILE x1 DO fold c (t |` (-lvars c))"
    by (simp add: big_step_pres_approx_restrict equiv_up_to_while_weak)
  then show ?case
    by (simp add: approx_map_le equiv_up_to_def)
qed

(*Theorem 10.13 (Correctness of constant folding).*)
lemma approx_empty [simp]:
  "approx Map.empty = (\<lambda>_. True)"
  by (auto simp: approx_def)

theorem constant_folding_equiv:
  "fold c Map.empty \<sim> c"
  using approx_eq
  by (metis approx_empty equiv_up_toD1 equiv_up_toD2)

end


(*  Title:      HOL/Library/List_lexord.thy
    Author:     Norbert Voelker
*)

section \<open>Lexicographic order on lists\<close>

theory List_lexord
imports Main
begin

instantiation list :: (ord) ord
begin

definition
  list_less_def: "xs < ys \<longleftrightarrow> (xs, ys) \<in> lexord {(u, v). u < v}"

definition
  list_le_def: "(xs :: _ list) \<le> ys \<longleftrightarrow> xs < ys \<or> xs = ys"

instance ..

end

instance list :: (order) order
proof
  fix xs :: "'a list"
  show "xs \<le> xs" by (simp add: list_le_def)
next
  fix xs ys zs :: "'a list"
  assume "xs \<le> ys" and "ys \<le> zs"
  then show "xs \<le> zs"
    apply (auto simp add: list_le_def list_less_def)
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
next
  fix xs ys :: "'a list"
  assume "xs \<le> ys" and "ys \<le> xs"
  then show "xs = ys"
    apply (auto simp add: list_le_def list_less_def)
    apply (rule lexord_irreflexive [THEN notE])
    defer
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
next
  fix xs ys :: "'a list"
  show "xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs"
    apply (auto simp add: list_less_def list_le_def)
    defer
    apply (rule lexord_irreflexive [THEN notE])
    apply auto
    apply (rule lexord_irreflexive [THEN notE])
    defer
    apply (rule lexord_trans)
    apply (auto intro: transI)
    done
qed

instance list :: (linorder) linorder
proof
  fix xs ys :: "'a list"
  have "(xs, ys) \<in> lexord {(u, v). u < v} \<or> xs = ys \<or> (ys, xs) \<in> lexord {(u, v). u < v}"
    by (rule lexord_linear) auto
  then show "xs \<le> ys \<or> ys \<le> xs"
    by (auto simp add: list_le_def list_less_def)
qed

instantiation list :: (linorder) distrib_lattice
begin

definition "(inf :: 'a list \<Rightarrow> _) = min"

definition "(sup :: 'a list \<Rightarrow> _) = max"

instance
  by standard (auto simp add: inf_list_def sup_list_def max_min_distrib2)

end

lemma not_less_Nil [simp]: "\<not> x < []"
  by (simp add: list_less_def)

lemma Nil_less_Cons [simp]: "[] < a # x"
  by (simp add: list_less_def)

lemma Cons_less_Cons [simp]: "a # x < b # y \<longleftrightarrow> a < b \<or> a = b \<and> x < y"
  by (simp add: list_less_def)

lemma le_Nil [simp]: "x \<le> [] \<longleftrightarrow> x = []"
  unfolding list_le_def by (cases x) auto

lemma Nil_le_Cons [simp]: "[] \<le> x"
  unfolding list_le_def by (cases x) auto

lemma Cons_le_Cons [simp]: "a # x \<le> b # y \<longleftrightarrow> a < b \<or> a = b \<and> x \<le> y"
  unfolding list_le_def by auto

instantiation list :: (order) order_bot
begin

definition "bot = []"

instance
  by standard (simp add: bot_list_def)

end

lemma less_list_code [code]:
  "xs < ([]::'a::{equal, order} list) \<longleftrightarrow> False"
  "[] < (x::'a::{equal, order}) # xs \<longleftrightarrow> True"
  "(x::'a::{equal, order}) # xs < y # ys \<longleftrightarrow> x < y \<or> x = y \<and> xs < ys"
  by simp_all

end


(*
  Authors: Asta Halkjær From & Jørgen Villadsen, DTU Compute
*)

section \<open>Formalization of the Bernays-Tarski Axiom System for Classical Implicational Logic\<close>

(* Uncomment for Full Classical Propositional Logic *)

subsection \<open>Syntax, Semantics and Axiom System\<close>

theory Implicational_Logic imports Main begin

datatype form =
  (*Falsity (\<open>\<bottom>\<close>) |*)
  Pro nat (\<open>\<cdot>\<close>) |
  Imp form form (infixr \<open>\<rightarrow>\<close> 55)

primrec semantics (infix \<open>\<Turnstile>\<close> 50) where
  (*\<open>I \<Turnstile> \<bottom> = False\<close> |*)
  \<open>I \<Turnstile> \<cdot> n = I n\<close> |
  \<open>I \<Turnstile> p \<rightarrow> q = (I \<Turnstile> p \<longrightarrow> I \<Turnstile> q)\<close>

inductive Ax (\<open>\<turnstile> _\<close> 50) where
  (*Expl: \<open>\<turnstile> \<bottom> \<rightarrow> p\<close> |*)
  Simp: \<open>\<turnstile> p \<rightarrow> q \<rightarrow> p\<close> |
  Tran: \<open>\<turnstile> (p \<rightarrow> q) \<rightarrow> (q \<rightarrow> r) \<rightarrow> p \<rightarrow> r\<close> |
  MP: \<open>\<turnstile> p \<rightarrow> q \<Longrightarrow> \<turnstile> p \<Longrightarrow> \<turnstile> q\<close> |
  PR: \<open>\<turnstile> (p \<rightarrow> q) \<rightarrow> p \<Longrightarrow> \<turnstile> p\<close>

subsection \<open>Soundness and Derived Formulas\<close>

theorem soundness: \<open>\<turnstile> p \<Longrightarrow> I \<Turnstile> p\<close>
  by (induct p rule: Ax.induct) auto

lemma Swap: \<open>\<turnstile> (p \<rightarrow> q \<rightarrow> r) \<rightarrow> q \<rightarrow> p \<rightarrow> r\<close>
proof -
  have \<open>\<turnstile> q \<rightarrow> (q \<rightarrow> r) \<rightarrow> r\<close>
    using MP PR Simp Tran by metis
  then show ?thesis
    using MP Tran by meson
qed

lemma Peirce: \<open>\<turnstile> ((p \<rightarrow> q) \<rightarrow> p) \<rightarrow> p\<close>
  using MP PR Simp Swap Tran by meson

lemma Hilbert: \<open>\<turnstile> (p \<rightarrow> p \<rightarrow> q) \<rightarrow> p \<rightarrow> q\<close>
  using MP MP Tran Tran Peirce .

lemma Id: \<open>\<turnstile> p \<rightarrow> p\<close>
  using MP Hilbert Simp .

lemma Tran': \<open>\<turnstile> (q \<rightarrow> r) \<rightarrow> (p \<rightarrow> q) \<rightarrow> p \<rightarrow> r\<close>
  using MP Swap Tran .

lemma Frege: \<open>\<turnstile> (p \<rightarrow> q \<rightarrow> r) \<rightarrow> (p \<rightarrow> q) \<rightarrow> p \<rightarrow> r\<close>
  using MP MP Tran MP MP Tran Swap Tran' MP Tran' Hilbert .

lemma Imp1: \<open>\<turnstile> (q \<rightarrow> s) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> s) \<rightarrow> s\<close>
  using MP Peirce Tran Tran' by meson

lemma Imp2: \<open>\<turnstile> ((r \<rightarrow> s) \<rightarrow> s) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> s) \<rightarrow> s\<close>
  using MP Tran MP Tran Simp .

lemma Imp3: \<open>\<turnstile> ((q \<rightarrow> s) \<rightarrow> s) \<rightarrow> (r \<rightarrow> s) \<rightarrow> (q \<rightarrow> r) \<rightarrow> s\<close>
  using MP Swap Tran by meson

subsection \<open>Completeness and Main Theorem\<close>

fun pros where
  \<open>pros (p \<rightarrow> q) = remdups (pros p @ pros q)\<close> |
  \<open>pros p = (case p of (\<cdot> n) \<Rightarrow> [n] | _ \<Rightarrow> [])\<close>

lemma distinct_pros: \<open>distinct (pros p)\<close>
  by (induct p) simp_all

primrec imply (infixr \<open>\<leadsto>\<close> 56) where
  \<open>[] \<leadsto> q = q\<close> |
  \<open>p # ps \<leadsto> q = p \<rightarrow> ps \<leadsto> q\<close>

lemma imply_append: \<open>ps @ qs \<leadsto> r = ps \<leadsto> qs \<leadsto> r\<close>
  by (induct ps) simp_all

abbreviation Ax_assms (infix \<open>\<turnstile>\<close> 50) where \<open>ps \<turnstile> q \<equiv> \<turnstile> ps \<leadsto> q\<close>

lemma imply_Cons: \<open>ps \<turnstile> q \<Longrightarrow> p # ps \<turnstile> q\<close>
proof -
  assume \<open>ps \<turnstile> q\<close>
  with MP Simp have \<open>\<turnstile> p \<rightarrow> ps \<leadsto> q\<close> .
  then show ?thesis
    by simp
qed

lemma imply_head: \<open>p # ps \<turnstile> p\<close>
  by (induct ps) (use MP Frege Simp imply.simps in metis)+

lemma imply_mem: \<open>p \<in> set ps \<Longrightarrow> ps \<turnstile> p\<close>
  by (induct ps) (use imply_Cons imply_head in auto)

lemma imply_MP: \<open>\<turnstile> ps \<leadsto> (p \<rightarrow> q) \<rightarrow> ps \<leadsto> p \<rightarrow> ps \<leadsto> q\<close>
proof (induct ps)
  case (Cons r ps)
  then have \<open>\<turnstile> (r \<rightarrow> ps \<leadsto> (p \<rightarrow> q)) \<rightarrow> (r \<rightarrow> ps \<leadsto> p) \<rightarrow> r \<rightarrow> ps \<leadsto> q\<close>
    using MP Frege Simp by meson
  then show ?case
    by simp
qed (auto intro: Id)

lemma MP': \<open>ps \<turnstile> p \<rightarrow> q \<Longrightarrow> ps \<turnstile> p \<Longrightarrow> ps \<turnstile> q\<close>
  using MP imply_MP by metis

lemma imply_swap_append: \<open>ps @ qs \<turnstile> r \<Longrightarrow> qs @ ps \<turnstile> r\<close>
  by (induct qs arbitrary: ps) (simp, metis MP' imply_append imply_Cons imply_head imply.simps(2))

lemma imply_deduct: \<open>p # ps \<turnstile> q \<Longrightarrow> ps \<turnstile> p \<rightarrow> q\<close>
  using imply_append imply_swap_append imply.simps by metis

lemma add_imply [simp]: \<open>\<turnstile> p \<Longrightarrow> ps \<turnstile> p\<close>
proof -
  note MP
  moreover have \<open>\<turnstile> p \<rightarrow> ps \<leadsto> p\<close>
    using imply_head by simp
  moreover assume \<open>\<turnstile> p\<close>
  ultimately show ?thesis .
qed

lemma imply_weaken: \<open>ps \<turnstile> p \<Longrightarrow> set ps \<subseteq> set ps' \<Longrightarrow> ps' \<turnstile> p\<close>
  by (induct ps arbitrary: p) (simp, metis MP' imply_deduct imply_mem insert_subset list.set(2))

abbreviation \<open>lift t s p \<equiv> if t then (p \<rightarrow> s) \<rightarrow> s else p \<rightarrow> s\<close>

abbreviation \<open>lifts I s \<equiv> map (\<lambda>n. lift (I n) s (\<cdot> n))\<close>

lemma lifts_weaken: \<open>lifts I s l \<turnstile> p \<Longrightarrow> set l \<subseteq> set l' \<Longrightarrow> lifts I s l' \<turnstile> p\<close>
  using imply_weaken by (metis (no_types, lifting) image_mono set_map)

lemma lifts_pros_lift: \<open>lifts I s (pros p) \<turnstile> lift (I \<Turnstile> p) s p\<close>
proof (induct p)
  case (Imp q r)
  consider \<open>\<not> I \<Turnstile> q\<close> | \<open>I \<Turnstile> r\<close> | \<open>I \<Turnstile> q\<close> \<open>\<not> I \<Turnstile> r\<close>
    by blast
  then show ?case
  proof cases
    case 1
    then have \<open>lifts I s (pros (q \<rightarrow> r)) \<turnstile> q \<rightarrow> s\<close>
      using Imp(1) lifts_weaken[where l' = \<open>pros (q \<rightarrow> r)\<close>] by simp
    then have \<open>lifts I s (pros (q \<rightarrow> r)) \<turnstile> ((q \<rightarrow> r) \<rightarrow> s) \<rightarrow> s\<close>
      using Imp1 MP' add_imply by blast
    with 1 show ?thesis
      by simp
  next
    case 2
    then have \<open>lifts I s (pros (q \<rightarrow> r)) \<turnstile> (r \<rightarrow> s) \<rightarrow> s\<close>
      using Imp(2) lifts_weaken[where l' = \<open>pros (q \<rightarrow> r)\<close>] by simp
    then have \<open>lifts I s (pros (q \<rightarrow> r)) \<turnstile> ((q \<rightarrow> r) \<rightarrow> s) \<rightarrow> s\<close>
      using Imp2 MP' add_imply by blast
    with 2 show ?thesis
      by simp
  next
    case 3
    then have \<open>lifts I s (pros (q \<rightarrow> r)) \<turnstile> (q \<rightarrow> s) \<rightarrow> s\<close> \<open>lifts I s (pros (q \<rightarrow> r)) \<turnstile> r \<rightarrow> s\<close>
      using Imp lifts_weaken[where l' = \<open>pros (q \<rightarrow> r)\<close>] by simp_all
    then have \<open>lifts I s (pros (q \<rightarrow> r)) \<turnstile> (q \<rightarrow> r) \<rightarrow> s\<close>
      using Imp3 MP' add_imply by blast
    with 3 show ?thesis
      by simp
  qed
qed (auto intro: Id Ax.intros)

lemma lifts_pros: \<open>I \<Turnstile> p \<Longrightarrow> lifts I p (pros p) \<turnstile> p\<close>
proof -
  assume \<open>I \<Turnstile> p\<close>
  then have \<open>lifts I p (pros p) \<turnstile> (p \<rightarrow> p) \<rightarrow> p\<close>
    using lifts_pros_lift[of I p p] by simp
  then show ?thesis
    using Id MP' add_imply by blast
qed

theorem completeness: \<open>\<forall>I. I \<Turnstile> p \<Longrightarrow> \<turnstile> p\<close>
proof -
  let ?A = \<open>\<lambda>l I. lifts I p l \<turnstile> p\<close>
  let ?B = \<open>\<lambda>l. \<forall>I. ?A l I \<and> distinct l\<close>
  assume \<open>\<forall>I. I \<Turnstile> p\<close>
  moreover have \<open>?B l \<Longrightarrow> (\<And>n l. ?B (n # l) \<Longrightarrow> ?B l) \<Longrightarrow> ?B []\<close> for l
    by (induct l) blast+
  moreover have \<open>?B (n # l) \<Longrightarrow> ?B l\<close> for n l
  proof -
    assume *: \<open>?B (n # l)\<close>
    show \<open>?B l\<close>
    proof
      fix I
      from * have \<open>?A (n # l) (I(n := True))\<close> \<open>?A (n # l) (I(n := False))\<close>
        by blast+
      moreover from * have \<open>\<forall>m \<in> set l. \<forall>t. (I(n := t)) m = I m\<close>
        by simp
      ultimately have \<open>((\<cdot> n \<rightarrow> p) \<rightarrow> p) # lifts I p l \<turnstile> p\<close> \<open>(\<cdot> n \<rightarrow> p) # lifts I p l \<turnstile> p\<close>
        by (simp_all cong: map_cong)
      then have \<open>?A l I\<close>
        using MP' imply_deduct by blast
      moreover from * have \<open>distinct (n # l)\<close>
        by blast
      ultimately show \<open>?A l I \<and> distinct l\<close>
        by simp
    qed
  qed
  ultimately have \<open>?B []\<close>
    using lifts_pros distinct_pros by blast
  then show ?thesis
    by simp
qed

theorem main: \<open>(\<turnstile> p) = (\<forall>I. I \<Turnstile> p)\<close>
  using soundness completeness by blast

subsection \<open>Reference\<close>

text \<open>Wikipedia \<^url>\<open>https://en.wikipedia.org/wiki/Implicational_propositional_calculus\<close> July 2022\<close>

end


(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

section \<open>Ordinal Arithmetic\<close>

theory OrdinalArith
imports OrdinalRec
begin

subsection \<open>Addition\<close>

instantiation ordinal :: plus
begin

definition
  "(+) = (\<lambda>x. ordinal_rec x (\<lambda>p. oSuc))"

instance ..

end

lemma ordinal_plus_0 [simp]: "x + 0 = (x::ordinal)"
  by (simp add: plus_ordinal_def)

lemma ordinal_plus_oSuc [simp]: "x + oSuc y = oSuc (x + y)"
  by (simp add: plus_ordinal_def)

lemma ordinal_plus_oLimit [simp]: "x + oLimit f = oLimit (\<lambda>n. x + f n)"
  by (simp add: normal.oLimit normal_plus)

lemma ordinal_0_plus [simp]: "0 + x = (x::ordinal)"
  by (rule_tac a=x in oLimit_induct, simp_all)

lemma ordinal_plus_assoc: "(x + y) + z = x + (y + z::ordinal)"
  by (rule_tac a=z in oLimit_induct, simp_all)

lemma ordinal_plus_monoL [rule_format]:
"\<forall>x x'. x \<le> x' \<longrightarrow> x + y \<le> x' + (y::ordinal)"
 apply (rule_tac a=y in oLimit_induct, simp_all)
 apply clarify
 apply (rule oLimit_leI, clarify)
 apply (rule_tac n=n in le_oLimitI)
 apply simp
done

lemma ordinal_plus_monoR: "y \<le> y' \<Longrightarrow> x + y \<le> x + (y'::ordinal)"
  by (rule normal.monoD[OF normal_plus])

lemma ordinal_plus_mono:
  "\<lbrakk>x \<le> x'; y \<le> y'\<rbrakk> \<Longrightarrow> x + y \<le> x' + (y'::ordinal)"
  by (rule order_trans[OF ordinal_plus_monoL ordinal_plus_monoR])

lemma ordinal_plus_strict_monoR: "y < y' \<Longrightarrow> x + y < x + (y'::ordinal)"
  by (rule normal.strict_monoD[OF normal_plus])

lemma ordinal_le_plusL [simp]: "y \<le> x + (y::ordinal)"
  by (cut_tac ordinal_plus_monoL[OF ordinal_0_le], simp)

lemma ordinal_le_plusR [simp]: "x \<le> x + (y::ordinal)"
  by (cut_tac ordinal_plus_monoR[OF ordinal_0_le], simp)

lemma ordinal_less_plusR: "0 < y \<Longrightarrow> x < x + (y::ordinal)"
  by (drule_tac ordinal_plus_strict_monoR, simp)

lemma ordinal_plus_left_cancel [simp]:
  "(w + x = w + y) = (x = (y::ordinal))"
  by (rule normal.cancel_eq[OF normal_plus])

lemma ordinal_plus_left_cancel_le [simp]:
  "(w + x \<le> w + y) = (x \<le> (y::ordinal))"
  by (rule normal.cancel_le[OF normal_plus])

lemma ordinal_plus_left_cancel_less [simp]:
  "(w + x < w + y) = (x < (y::ordinal))"
  by (rule normal.cancel_less[OF normal_plus])

lemma ordinal_plus_not_0: "(0 < x + y) = (0 < x \<or> 0 < (y::ordinal))"
  by (metis ordinal_le_0 ordinal_le_plusL ordinal_neq_0 ordinal_plus_0)

lemma not_inject: "(\<not> P) = (\<not> Q) \<Longrightarrow> P = Q"
by auto

lemma ordinal_plus_eq_0:
"((x::ordinal) + y = 0) = (x = 0 \<and> y = 0)"
by (rule not_inject, simp add: ordinal_plus_not_0)

subsection \<open>Subtraction\<close>

instantiation ordinal :: minus
begin

definition
  minus_ordinal_def:
    "x - y = ordinal_rec 0 (\<lambda>p w. if y \<le> p then oSuc w else w) x"

instance ..

end

lemma continuous_minus: "continuous (\<lambda>x. x - y)"
 unfolding minus_ordinal_def
  by (simp add: continuous_ordinal_rec order_less_imp_le)

lemma ordinal_0_minus [simp]: "0 - x = (0::ordinal)"
  by (simp add: minus_ordinal_def)

lemma ordinal_oSuc_minus [simp]: "y \<le> x \<Longrightarrow> oSuc x - y = oSuc (x - y)"
  by (simp add: minus_ordinal_def)

lemma ordinal_oLimit_minus [simp]: "oLimit f - y = oLimit (\<lambda>n. f n - y)"
  by (rule continuousD[OF continuous_minus])

lemma ordinal_minus_0 [simp]: "x - 0 = (x::ordinal)"
  by (rule_tac a=x in oLimit_induct, simp_all)

lemma ordinal_oSuc_minus2: "x < y \<Longrightarrow> oSuc x - y = x - y"
  by (simp add: minus_ordinal_def linorder_not_le[symmetric])

lemma ordinal_minus_eq_0 [rule_format, simp]:
"x \<le> y \<longrightarrow> x - y = (0::ordinal)"
 apply (rule_tac a=x in oLimit_induct)
   apply simp
  apply (simp add: ordinal_oSuc_minus2 order_less_imp_le oSuc_le_eq_less)
 apply (simp add: order_trans[OF le_oLimit])
done

lemma ordinal_plus_minus1 [simp]: "(x + y) - x = (y::ordinal)"
by (rule_tac a=y in oLimit_induct, simp_all)

lemma ordinal_plus_minus2 [simp]: "x \<le> y \<Longrightarrow> x + (y - x) = (y::ordinal)"
 apply (subgoal_tac "\<forall>z. y < x + z \<longrightarrow> x + (y - x) = y")
  apply (drule_tac x="oSuc y" in spec, erule mp)
  apply (rule order_less_le_trans[OF less_oSuc], simp)
 apply (rule allI, rule_tac a=z in oLimit_induct)
   apply (simp add: linorder_not_less[symmetric])
  apply (clarsimp simp add: less_oSuc_eq_le)
 apply (clarsimp, drule less_oLimitD, clarsimp)
done

lemma ordinal_minusI: "x = y + z \<Longrightarrow> x - y = (z::ordinal)"
  by simp

lemma ordinal_minus_less_eq [simp]:
  "(y::ordinal) \<le> x \<Longrightarrow> (x - y < z) = (x < y + z)"
  by (metis ordinal_plus_left_cancel_less ordinal_plus_minus2)

lemma ordinal_minus_le_eq [simp]: "(x - y \<le> z) = (x \<le> y + (z::ordinal))"
proof (rule linorder_le_cases)
  assume "x \<le> y" then show ?thesis
    using order_trans by force
next
  assume "y \<le> x" then show ?thesis
    by (metis ordinal_plus_left_cancel_le ordinal_plus_minus2)
qed

lemma ordinal_minus_monoL: "x \<le> y \<Longrightarrow> x - z \<le> y - (z::ordinal)"
by (erule continuous.monoD[OF continuous_minus])

lemma ordinal_minus_monoR: "x \<le> y \<Longrightarrow> z - y \<le> z - (x::ordinal)"
  by (metis linorder_le_cases order_trans ordinal_minus_le_eq ordinal_plus_monoL)

subsection \<open>Multiplication\<close>

instantiation ordinal :: times
begin

definition
  times_ordinal_def: "(*) = (\<lambda>x. ordinal_rec 0 (\<lambda>p w. w + x))"

instance ..

end

lemma continuous_times: "continuous ((*) x)"
  by (simp add: times_ordinal_def continuous_ordinal_rec)

lemma normal_times: "0 < x \<Longrightarrow> normal ((*) x)"
  unfolding times_ordinal_def
  by (simp add: normal_ordinal_rec ordinal_less_plusR)

lemma ordinal_times_0 [simp]: "x * 0 = (0::ordinal)"
  by (simp add: times_ordinal_def)

lemma ordinal_times_oSuc [simp]: "x * oSuc y = (x * y) + x"
  by (simp add: times_ordinal_def)

lemma ordinal_times_oLimit [simp]: "x * oLimit f = oLimit (\<lambda>n. x * f n)"
  by (simp add: times_ordinal_def ordinal_rec_oLimit)

lemma ordinal_0_times [simp]: "0 * x = (0::ordinal)"
  by (rule_tac a=x in oLimit_induct, simp_all)

lemma ordinal_1_times [simp]: "oSuc 0 * x = (x::ordinal)"
  by (rule_tac a=x in oLimit_induct, simp_all)

lemma ordinal_times_1 [simp]: "x * oSuc 0 = (x::ordinal)"
  by simp

lemma ordinal_times_distrib:
  "x * (y + z) = (x * y) + (x * z::ordinal)"
  by (rule_tac a=z in oLimit_induct, simp_all add: ordinal_plus_assoc)

lemma ordinal_times_assoc:
  "(x * y::ordinal) * z = x * (y * z)"
  by (rule_tac a=z in oLimit_induct, simp_all add: ordinal_times_distrib)

lemma ordinal_times_monoL [rule_format]:
  "\<forall>x x'. x \<le> x' \<longrightarrow> x * y \<le> x' * (y::ordinal)"
  apply (rule_tac a=y in oLimit_induct)
    apply simp
   apply clarify
   apply (simp add: ordinal_plus_mono)
  apply clarsimp
  apply (rule oLimit_leI, clarify)
  apply (rule_tac n=n in le_oLimitI)
  apply simp
  done

lemma ordinal_times_monoR: "y \<le> y' \<Longrightarrow> x * y \<le> x * (y'::ordinal)"
  by (rule continuous.monoD[OF continuous_times])

lemma ordinal_times_mono:
  "\<lbrakk>x \<le> x'; y \<le> y'\<rbrakk> \<Longrightarrow> x * y \<le> x' * (y'::ordinal)"
  by (rule order_trans[OF ordinal_times_monoL ordinal_times_monoR])

lemma ordinal_times_strict_monoR:
  "\<lbrakk>y < y'; 0 < x\<rbrakk> \<Longrightarrow> x * y < x * (y'::ordinal)"
  by (rule normal.strict_monoD[OF normal_times])

lemma ordinal_le_timesL [simp]: "0 < x \<Longrightarrow> y \<le> x * (y::ordinal)"
  by (drule ordinal_times_monoL[OF oSuc_leI], simp)

lemma ordinal_le_timesR [simp]: "0 < y \<Longrightarrow> x \<le> x * (y::ordinal)"
  by (drule ordinal_times_monoR[OF oSuc_leI], simp)

lemma ordinal_less_timesR: "\<lbrakk>0 < x; oSuc 0 < y\<rbrakk> \<Longrightarrow> x < x * (y::ordinal)"
  by (drule ordinal_times_strict_monoR, assumption, simp)

lemma ordinal_times_left_cancel [simp]:
  "0 < w \<Longrightarrow> (w * x = w * y) = (x = (y::ordinal))"
  by (rule normal.cancel_eq[OF normal_times])

lemma ordinal_times_left_cancel_le [simp]:
  "0 < w \<Longrightarrow> (w * x \<le> w * y) = (x \<le> (y::ordinal))"
  by (rule normal.cancel_le[OF normal_times])

lemma ordinal_times_left_cancel_less [simp]:
  "0 < w \<Longrightarrow> (w * x < w * y) = (x < (y::ordinal))"
  by (rule normal.cancel_less[OF normal_times])

lemma ordinal_times_eq_0:
  "((x::ordinal) * y = 0) = (x = 0 \<or> y = 0)"
  by (metis ordinal_0_times ordinal_neq_0 ordinal_times_0 ordinal_times_strict_monoR)

lemma ordinal_times_not_0 [simp]:
  "((0::ordinal) < x * y) = (0 < x \<and> 0 < y)"
  by (metis ordinal_neq_0 ordinal_times_eq_0)

subsection \<open>Exponentiation\<close>

definition
  exp_ordinal :: "[ordinal, ordinal] \<Rightarrow> ordinal" (infixr "**" 75) where
  "(**) = (\<lambda>x. if 0 < x then ordinal_rec 1 (\<lambda>p w. w * x)
                         else (\<lambda>y. if y = 0 then 1 else 0))"

lemma continuous_exp: "0 < x \<Longrightarrow> continuous ((**) x)"
  by (simp add: exp_ordinal_def continuous_ordinal_rec)

lemma ordinal_exp_0 [simp]: "x ** 0 = (1::ordinal)"
  by (simp add: exp_ordinal_def)

lemma ordinal_exp_oSuc [simp]: "x ** oSuc y = (x ** y) * x"
  by (simp add: exp_ordinal_def)

lemma ordinal_exp_oLimit [simp]:
  "0 < x \<Longrightarrow> x ** oLimit f = oLimit (\<lambda>n. x ** f n)"
  by (rule continuousD[OF continuous_exp])

lemma ordinal_0_exp [simp]: "0 ** x = (if x = 0 then 1 else 0)"
  by (simp add: exp_ordinal_def)

lemma ordinal_1_exp [simp]: "oSuc 0 ** x = oSuc 0"
  by (rule_tac a=x in oLimit_induct, simp_all)

lemma ordinal_exp_1 [simp]: "x ** oSuc 0 = x"
  by simp

lemma ordinal_exp_distrib:
  "x ** (y + z) = (x ** y) * (x ** (z::ordinal))"
  apply (case_tac "x = 0", simp_all add: ordinal_plus_not_0)
  apply (rule_tac a=z in oLimit_induct, simp_all add: ordinal_times_assoc)
  done

lemma ordinal_exp_not_0 [simp]: "(0 < x ** y) = (0 < x \<or> y = 0)"
  apply auto
   apply (erule contrapos_pp, simp)
  apply (rule_tac a=y in oLimit_induct, simp_all)
  apply (rule less_oLimitI, erule spec)
  done

lemma ordinal_exp_eq_0 [simp]: "(x ** y = 0) = (x = 0 \<and> 0 < y)"
  by (rule not_inject, simp)

lemma ordinal_exp_assoc:
  "(x ** y) ** z = x ** (y * z)"
  apply (case_tac "x = 0", simp_all)
  apply (rule_tac a=z in oLimit_induct, simp_all add: ordinal_exp_distrib)
  done

lemma ordinal_exp_monoL [rule_format]:
  "\<forall>x x'. x \<le> x' \<longrightarrow> x ** y \<le> x' ** (y::ordinal)"
  apply (rule_tac a=y in oLimit_induct)
    apply simp
   apply (simp add: ordinal_times_mono)
  apply clarsimp
  apply (case_tac "x = 0", simp)
  apply (case_tac "x' = 0", simp_all)
  apply (rule oLimit_leI, clarify)
  apply (rule_tac n=n in le_oLimitI)
  apply simp
  done

lemma normal_exp: "oSuc 0 < x \<Longrightarrow> normal ((**) x)"
  using order_less_trans[OF less_oSuc]
  by (simp add: normalI ordinal_less_timesR)

lemma ordinal_exp_monoR:
  "\<lbrakk>0 < x; y \<le> y'\<rbrakk> \<Longrightarrow> x ** y \<le> x ** (y'::ordinal)"
  by (rule continuous.monoD[OF continuous_exp])

lemma ordinal_exp_mono:
  "\<lbrakk>0 < x'; x \<le> x'; y \<le> y'\<rbrakk> \<Longrightarrow> x ** y \<le> x' ** (y'::ordinal)"
  by (rule order_trans[OF ordinal_exp_monoL ordinal_exp_monoR])

lemma ordinal_exp_strict_monoR:
  "\<lbrakk>oSuc 0 < x; y < y'\<rbrakk> \<Longrightarrow> x ** y < x ** (y'::ordinal)"
  by (rule normal.strict_monoD[OF normal_exp])

lemma ordinal_le_expR [simp]: "0 < y \<Longrightarrow> x \<le> x ** (y::ordinal)"
  by (metis leI nless_le oSuc_le_eq_less ordinal_exp_1 ordinal_exp_mono ordinal_le_0)

lemma ordinal_exp_left_cancel [simp]:
  "oSuc 0 < w \<Longrightarrow> (w ** x = w ** y) = (x = y)"
  by (rule normal.cancel_eq[OF normal_exp])

lemma ordinal_exp_left_cancel_le [simp]:
  "oSuc 0 < w \<Longrightarrow> (w ** x \<le> w ** y) = (x \<le> y)"
  by (rule normal.cancel_le[OF normal_exp])

lemma ordinal_exp_left_cancel_less [simp]:
  "oSuc 0 < w \<Longrightarrow> (w ** x < w ** y) = (x < y)"
  by (rule normal.cancel_less[OF normal_exp])

end


theory Ex03
imports Main "~~/src/HOL/IMP/AExp"
begin

inductive odd :: "nat \<Rightarrow> bool" where
odd1: "odd 1"
  | odd_add: "odd n \<Longrightarrow> odd (n+2)"

thm odd1 odd_add

(* Exercise 3.1 *)
inductive is_aval :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
  N: "is_aval (N n) s n"
| V: "is_aval (V x) s (s x)"
| P: "\<lbrakk> is_aval a1 s v1; is_aval a2 s v2 \<rbrakk> \<Longrightarrow> is_aval (Plus a1 a2) s (v1 + v2)"

(* Step by step proof
   We can also use apply(rule N V P)+
   or apply(rule is_val.intros)+
   or apply(intro is_aval.intros)
*)
lemma "is_aval (Plus (N 2) (Plus (V x) (N 3))) s (2+(s x + 3))"
  apply(rule P)
  apply(rule N)
  apply(rule P)
  apply(rule V)
  apply(rule N)
  done

theorem "is_aval a s v \<longleftrightarrow> aval a s = v"
proof (* this is the default rule(rule iffI) *)
  assume "is_aval a s v"
  (* then show "aval a s = v" by induction auto *)
  (* thus "aval a s = v" by induction auto *)
  thus "aval a s = v"
  proof induction
    print_cases
    case (N n s) show ?case by simp
      thm aval.simps
  next
    case (V x s) show ?case by simp
  next
    case (P a1 s v1 a2 v2)
      (* thm P.IH IH *)
      (* thm P.hyps additional hyps *)
      (* thm P.prems additional premises, we dont have those here *)
    have "aval (Plus a1 a2) s = aval a1 s + aval a2 s" by simp
    also from P.IH have "... = v1 + v2" by simp (* "..." are bound to the RHS of the last equation *)
    finally show ?case . (* "." means by assumption *)
  qed
next
  assume "aval a s = v" thus "is_aval a s v"
  proof induction
    case (N v) thus ?case by (simp add: is_aval.N)
  next
    case (V x) thus ?case
      by (auto simp add: is_aval.V)
  next
    case (Plus a1 a2)
    from Plus.prems have foo: "v = aval a1 s + aval a2 s" by simp
    thm Plus.IH
    show ?case
      unfolding foo
      apply(rule is_aval.P)
      thm Plus.IH
      apply(rule Plus.IH, simp)
      apply(rule Plus.IH, simp)
      done
      oops

(*  by (induction a arbitrary: v) (auto intro: N V P) *)

end


(*  Title:      HOL/Multivariate_Analysis/Euclidean_Space.thy
    Author:     Johannes Hölzl, TU München
    Author:     Brian Huffman, Portland State University
*)

section {* Finite-Dimensional Inner Product Spaces *}

theory Euclidean_Space
imports
  L2_Norm
  "~~/src/HOL/Library/Inner_Product"
  "~~/src/HOL/Library/Product_Vector"
begin

subsection {* Type class of Euclidean spaces *}

class euclidean_space = real_inner +
  fixes Basis :: "'a set"
  assumes nonempty_Basis [simp]: "Basis \<noteq> {}"
  assumes finite_Basis [simp]: "finite Basis"
  assumes inner_Basis:
    "\<lbrakk>u \<in> Basis; v \<in> Basis\<rbrakk> \<Longrightarrow> inner u v = (if u = v then 1 else 0)"
  assumes euclidean_all_zero_iff:
    "(\<forall>u\<in>Basis. inner x u = 0) \<longleftrightarrow> (x = 0)"

abbreviation dimension :: "('a::euclidean_space) itself \<Rightarrow> nat" where
  "dimension TYPE('a) \<equiv> card (Basis :: 'a set)"

syntax "_type_dimension" :: "type => nat" ("(1DIM/(1'(_')))")

translations "DIM('t)" == "CONST dimension (TYPE('t))"

lemma (in euclidean_space) norm_Basis[simp]: "u \<in> Basis \<Longrightarrow> norm u = 1"
  unfolding norm_eq_sqrt_inner by (simp add: inner_Basis)

lemma (in euclidean_space) inner_same_Basis[simp]: "u \<in> Basis \<Longrightarrow> inner u u = 1"
  by (simp add: inner_Basis)

lemma (in euclidean_space) inner_not_same_Basis: "u \<in> Basis \<Longrightarrow> v \<in> Basis \<Longrightarrow> u \<noteq> v \<Longrightarrow> inner u v = 0"
  by (simp add: inner_Basis)

lemma (in euclidean_space) sgn_Basis: "u \<in> Basis \<Longrightarrow> sgn u = u"
  unfolding sgn_div_norm by (simp add: scaleR_one)

lemma (in euclidean_space) Basis_zero [simp]: "0 \<notin> Basis"
proof
  assume "0 \<in> Basis" thus "False"
    using inner_Basis [of 0 0] by simp
qed

lemma (in euclidean_space) nonzero_Basis: "u \<in> Basis \<Longrightarrow> u \<noteq> 0"
  by clarsimp

lemma (in euclidean_space) SOME_Basis: "(SOME i. i \<in> Basis) \<in> Basis"
  by (metis ex_in_conv nonempty_Basis someI_ex)

lemma (in euclidean_space) inner_setsum_left_Basis[simp]:
    "b \<in> Basis \<Longrightarrow> inner (\<Sum>i\<in>Basis. f i *\<^sub>R i) b = f b"
  by (simp add: inner_setsum_left inner_Basis if_distrib comm_monoid_add_class.setsum.If_cases)

lemma (in euclidean_space) euclidean_eqI:
  assumes b: "\<And>b. b \<in> Basis \<Longrightarrow> inner x b = inner y b" shows "x = y"
proof -
  from b have "\<forall>b\<in>Basis. inner (x - y) b = 0"
    by (simp add: inner_diff_left)
  then show "x = y"
    by (simp add: euclidean_all_zero_iff)
qed

lemma (in euclidean_space) euclidean_eq_iff:
  "x = y \<longleftrightarrow> (\<forall>b\<in>Basis. inner x b = inner y b)"
  by (auto intro: euclidean_eqI)

lemma (in euclidean_space) euclidean_representation_setsum:
  "(\<Sum>i\<in>Basis. f i *\<^sub>R i) = b \<longleftrightarrow> (\<forall>i\<in>Basis. f i = inner b i)"
  by (subst euclidean_eq_iff) simp

lemma (in euclidean_space) euclidean_representation_setsum':
  "b = (\<Sum>i\<in>Basis. f i *\<^sub>R i) \<longleftrightarrow> (\<forall>i\<in>Basis. f i = inner b i)"
  by (auto simp add: euclidean_representation_setsum[symmetric])

lemma (in euclidean_space) euclidean_representation: "(\<Sum>b\<in>Basis. inner x b *\<^sub>R b) = x"
  unfolding euclidean_representation_setsum by simp

lemma (in euclidean_space) choice_Basis_iff:
  fixes P :: "'a \<Rightarrow> real \<Rightarrow> bool"
  shows "(\<forall>i\<in>Basis. \<exists>x. P i x) \<longleftrightarrow> (\<exists>x. \<forall>i\<in>Basis. P i (inner x i))"
  unfolding bchoice_iff
proof safe
  fix f assume "\<forall>i\<in>Basis. P i (f i)"
  then show "\<exists>x. \<forall>i\<in>Basis. P i (inner x i)"
    by (auto intro!: exI[of _ "\<Sum>i\<in>Basis. f i *\<^sub>R i"])
qed auto

lemma DIM_positive: "0 < DIM('a::euclidean_space)"
  by (simp add: card_gt_0_iff)

subsection {* Subclass relationships *}

instance euclidean_space \<subseteq> perfect_space
proof
  fix x :: 'a show "\<not> open {x}"
  proof
    assume "open {x}"
    then obtain e where "0 < e" and e: "\<forall>y. dist y x < e \<longrightarrow> y = x"
      unfolding open_dist by fast
    def y \<equiv> "x + scaleR (e/2) (SOME b. b \<in> Basis)"
    have [simp]: "(SOME b. b \<in> Basis) \<in> Basis"
      by (rule someI_ex) (auto simp: ex_in_conv)
    from `0 < e` have "y \<noteq> x"
      unfolding y_def by (auto intro!: nonzero_Basis)
    from `0 < e` have "dist y x < e"
      unfolding y_def by (simp add: dist_norm)
    from `y \<noteq> x` and `dist y x < e` show "False"
      using e by simp
  qed
qed

subsection {* Class instances *}

subsubsection {* Type @{typ real} *}

instantiation real :: euclidean_space
begin

definition
  [simp]: "Basis = {1::real}"

instance
  by default auto

end

lemma DIM_real[simp]: "DIM(real) = 1"
  by simp

subsubsection {* Type @{typ complex} *}

instantiation complex :: euclidean_space
begin

definition Basis_complex_def:
  "Basis = {1, ii}"

instance
  by default (auto simp add: Basis_complex_def intro: complex_eqI split: split_if_asm)

end

lemma DIM_complex[simp]: "DIM(complex) = 2"
  unfolding Basis_complex_def by simp

subsubsection {* Type @{typ "'a \<times> 'b"} *}

instantiation prod :: (euclidean_space, euclidean_space) euclidean_space
begin

definition
  "Basis = (\<lambda>u. (u, 0)) ` Basis \<union> (\<lambda>v. (0, v)) ` Basis"

lemma setsum_Basis_prod_eq:
  fixes f::"('a*'b)\<Rightarrow>('a*'b)"
  shows "setsum f Basis = setsum (\<lambda>i. f (i, 0)) Basis + setsum (\<lambda>i. f (0, i)) Basis"
proof -
  have "inj_on (\<lambda>u. (u::'a, 0::'b)) Basis" "inj_on (\<lambda>u. (0::'a, u::'b)) Basis"
    by (auto intro!: inj_onI Pair_inject)
  thus ?thesis
    unfolding Basis_prod_def
    by (subst setsum.union_disjoint) (auto simp: Basis_prod_def setsum.reindex)
qed

instance proof
  show "(Basis :: ('a \<times> 'b) set) \<noteq> {}"
    unfolding Basis_prod_def by simp
next
  show "finite (Basis :: ('a \<times> 'b) set)"
    unfolding Basis_prod_def by simp
next
  fix u v :: "'a \<times> 'b"
  assume "u \<in> Basis" and "v \<in> Basis"
  thus "inner u v = (if u = v then 1 else 0)"
    unfolding Basis_prod_def inner_prod_def
    by (auto simp add: inner_Basis split: split_if_asm)
next
  fix x :: "'a \<times> 'b"
  show "(\<forall>u\<in>Basis. inner x u = 0) \<longleftrightarrow> x = 0"
    unfolding Basis_prod_def ball_Un ball_simps
    by (simp add: inner_prod_def prod_eq_iff euclidean_all_zero_iff)
qed

lemma DIM_prod[simp]: "DIM('a \<times> 'b) = DIM('a) + DIM('b)"
  unfolding Basis_prod_def
  by (subst card_Un_disjoint) (auto intro!: card_image arg_cong2[where f="op +"] inj_onI)

end

end


theory Exe3p4
  imports Main
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

lemma star_post: "star r x y \<Longrightarrow> r y z \<Longrightarrow> star r x z"
  apply(induction rule: star.induct)
   apply(auto simp add: refl step)
  done

lemma star_trans: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
  apply(induction rule: star.induct)
   apply(auto simp add: step)
  done

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
iter_refl: "iter r 0 x x" |
iter_step: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

thm exI exE

lemma "star r x y \<Longrightarrow> \<exists>n. iter r n x y"
proof (induction rule: star.induct)
  case (refl r x)
  then show ?case

next
  case (step r x y z)
  then show ?case sorry
qed