section \<open>The case $y \neq new\_last$\<close>

theory Y_neq_new_last imports MengerInduction begin

text \<open>
  Let us now consider the case that @{term "y \<noteq> v1 \<and> y \<noteq> new_last"}.  Our goal is to show that
  this is inconsistent: The following locale will be unsatisfiable, proving that
  @{term "y = v1 \<or> y = new_last"} holds.
\<close>
locale ProofStepInduct_y_neq_new_last = ProofStepInduct_NonTrivial_P_k_pre +
  assumes y_neq_v1: "y \<noteq> v1" and y_neq_new_last: "y \<noteq> new_last"
begin

lemma Q_hit_exists: obtains Q_hit Q_hit_pre Q_hit_post where
  "Q_hit \<in> Q" "y \<in> set Q_hit" "Q_hit = Q_hit_pre @ y # Q_hit_post"
proof-
  obtain Q_hit where "Q_hit \<in> Q" "y \<in> set Q_hit"
    using hitting_Q_or_new_last_def y y_neq_v1 y_neq_new_last by auto
  then show ?thesis using that by (meson split_list)
qed

text \<open>
  We open an anonymous context because we do not want to export any lemmas except the final lemma
  proving the contradiction.  This is also an easy way to get the decomposition of @{term Q_hit},
  whose existence we have established above.
\<close>

context
  fixes Q_hit Q_hit_pre Q_hit_post
  assumes Q_hit: "Q_hit \<in> Q" "y \<in> set Q_hit"
    and Q_hit_decomp: "Q_hit = Q_hit_pre @ y # Q_hit_post"
begin
  private lemma Q_hit_v0_v1: "v0 \<leadsto>Q_hit\<leadsto>\<^bsub>H_x\<^esub> v1" using Q.paths Q_hit(1) by blast

  private lemma Q_hit_vertices: "set Q_hit \<subseteq> V - {new_last}"
    using Q.walk_in_V H_x_def path_from_to_def remove_vertex_V Q_hit_v0_v1 by fastforce

  private lemma Q_hit_pre_not_Nil: "Q_hit_pre \<noteq> Nil"
    using Q_hit_v0_v1 y_neq_v0 unfolding Q_hit_decomp by auto

  private lemma tl_Q_hit_pre: "tl (Q_hit_pre @ [y]) \<noteq> Nil" using Q_hit_pre_not_Nil by simp

  private lemma Q_hit_pre_edges: "edges_of_walk (Q_hit_pre @ [y]) \<inter> B \<noteq> {}" proof
    assume "edges_of_walk (Q_hit_pre @ [y]) \<inter> B = {}"
    moreover have "edges_of_walk (Q_hit_pre @ [y]) \<subseteq> E"
      by (metis Q.paths H_x_def Q_hit(1) Q_hit_decomp edges_of_walk_in_E path_decomp'
          path_from_to_def remove_vertex_walk_add)
    ultimately have Q_hit_pre_edges:
      "edges_of_walk (Q_hit_pre @ [y]) \<subseteq> \<Union>(edges_of_walk ` paths_with_new)"
      unfolding B_def by blast
    then have *: "first_edge_of_walk (Q_hit_pre @ [y]) \<in> \<Union>(edges_of_walk ` paths_with_new)"
      using tl_Q_hit_pre first_edge_in_edges by blast

    define v' where "v' \<equiv> hd (tl (Q_hit_pre @ [y]))"
    then have v': "(v0, v') = first_edge_of_walk (Q_hit_pre @ [y])"
      using first_edge_hd_tl Q_hit_pre_not_Nil tl_Q_hit_pre
      by (metis Q.path_from_toE Q_hit_decomp Q_hit_v0_v1 first_edge_of_walk.simps(1)
          hd_Cons_tl hd_append snoc_eq_iff_butlast)

    then obtain P_i where
      P_i: "P_i \<in> paths_with_new" "(v0, v') \<in> edges_of_walk P_i" using * by auto
    then have P_i_first: "first_edge_of_walk P_i = (v0, v')"
      using first_edge_first paths_with_new_def paths P_new by (metis insert_iff)
    moreover have "first_edge_of_walk P_k = (v0, hd (tl P_k))"
      by (metis P_k_decomp P_k_pre_not_Nil append_is_Nil_conv first_edge_of_walk.simps(1)
          hd_P_k_v0 list.distinct(1) list.exhaust_sel tl_append2)
    ultimately have "P_i \<noteq> P_k"
      by (metis Q.first_edge_first P_k(2) Q.second_vertices_first_edge Q_hit(1) Q_hit_decomp
          Q_hit_v0_v1 Un_iff v' tl_Q_hit_pre first_edge_in_edges walk_edges_decomp)

    text \<open>
      Then @{term P_k} and @{term P_i} intersect in @{term y}, which is not one of @{term v0},
      @{term v1}, or @{term new_last}.  So we get a contradiction because these two paths should be
      disjoint on all other vertices.
\<close>

    moreover have "v1 \<notin> set (Q_hit_pre @ [y])"
      using Q_hit_v0_v1 Q_hit_decomp y_neq_v1 by (simp add: Q.path_from_to_last')
    moreover have "new_last \<notin> set (Q_hit_pre @ [y])" proof-
      have "new_last \<notin> set Q_hit_pre" using Q_hit_decomp Q_hit_vertices by auto
      then show ?thesis using y_neq_new_last by auto
    qed
    moreover have "hd (tl (Q_hit_pre @ [y])) = hd (tl P_i)" proof-
      have "hd (tl P_i) = v'" using P_i_first P_i(1) tl_P_new(1)
        by (metis Pair_inject first_edge_of_walk.simps(1) insert_iff list.collapse
            paths_tl_notnil paths_with_new_def tl_Nil)
      then show ?thesis using v'_def by simp
    qed
    moreover have "v0 \<leadsto>(Q_hit_pre @ [y])\<leadsto> y"
      by (metis Q.path_decomp' H_x_def Q_hit_decomp Q_hit_v0_v1 Q_hit_pre_not_Nil
          hd_append2 path_from_to_def remove_vertex_walk_add snoc_eq_iff_butlast)
    ultimately have "edges_of_walk (Q_hit_pre @ [y]) \<subseteq> edges_of_walk P_i"
      using new_path_follows_old_paths tl_Q_hit_pre P_i(1) Q_hit_pre_edges by blast
    from walk_edges_subset[OF this] have "y \<in> set P_i" by (simp add: tl_Q_hit_pre)
    moreover have "y \<in> set P_k" using P_k_decomp by auto
    ultimately show False
      using y_neq_v0 y_neq_v1 y_neq_new_last \<open>P_i \<noteq> P_k\<close>
        paths_plus_one_disjoint[OF P_i(1), of P_k y] P_k(1) P_new_decomp by auto
  qed

  private lemma P_k_pre_edges: "edges_of_walk (P_k_pre @ [y]) \<inter> B = {}" proof-
    have "edges_of_walk (P_k_pre @ [y]) \<subseteq> \<Union>(edges_of_walk ` paths_with_new)"
    proof (cases)
      assume "P_k = P_new"
      then have "edges_of_walk (P_k_pre @ [y]) \<subseteq> edges_of_walk P_new"
        using P_k_decomp edges_of_comp1 by force
      then show ?thesis unfolding paths_with_new_def by blast
    next
      assume "P_k \<noteq> P_new"
      then have "P_k \<in> paths" using P_k(1) paths_with_new_def by blast
      then have "edges_of_walk (P_k_pre @ [y]) \<subseteq> \<Union>(edges_of_walk ` paths)"
        using edges_of_comp1[of "P_k_pre @ [y]"] P_k_decomp by auto
      then show ?thesis unfolding paths_with_new_def by blast
    qed
    then show ?thesis unfolding B_def by blast
  qed

  private definition Q_hit' where "Q_hit' \<equiv> P_k_pre @ y # Q_hit_post"

  private

  private lemma Q_hit'_v0_v1_H_x: "v0 \<leadsto>Q_hit'\<leadsto>\<^bsub>H_x\<^esub> v1" proof-
    have "new_last \<notin> set P_k_pre" using new_last_neq_v0 hitting_Q_or_new_last_def y_min by auto
    moreover have "new_last \<notin> set Q_hit_post" using Q_hit_vertices unfolding Q_hit_decomp by auto
    ultimately have "new_last \<notin> set Q_hit'" using y_neq_new_last Q_hit'_def by auto
    then show ?thesis using remove_vertex_path_from_to[OF Q_hit'_v0_v1] H_x_def new_last_in_V by simp
  qed

  private definition Q' where "Q' \<equiv> insert Q_hit' (Q - {Q_hit})"

  private

  private lemma Q_hit'_notin_Q_minus_Q_hit: "Q_hit' \<notin> Q - {Q_hit}" proof-
    have "hd (tl Q_hit') \<notin> Q.second_vertices" using P_k(2) P_k_decomp
      by (metis P_k_pre_not_Nil Q_hit'_def append_eq_append_conv2 append_self_conv hd_append2
          list.sel(1) tl_append2)
    then show ?thesis using Q.second_vertices_new_path[of Q_hit'] by blast
  qed

  private lemma Q_weight_smaller: "Q_weight Q' < Q_weight Q" proof-
    define Q_edges where "Q_edges \<equiv> \<Union>(edges_of_walk ` Q) \<inter> B"
    define Q'_edges where "Q'_edges \<equiv> \<Union>(edges_of_walk ` Q') \<inter> B"
    {
      fix v w assume *: "(v,w) \<in> Q'_edges" "(v,w) \<notin> Q_edges"
      then have v_w_in_B: "(v,w) \<in> B" unfolding Q'_edges_def by blast

      obtain Q'_v_w_witness where Q'_v_w_witness:
        "Q'_v_w_witness \<in> Q'" "(v,w) \<in> edges_of_walk Q'_v_w_witness"
        using *(1) unfolding Q'_edges_def by blast

      have "Q'_v_w_witness \<noteq> Q_hit'" proof
        assume "Q'_v_w_witness = Q_hit'"
        then have "edges_of_walk Q'_v_w_witness =
            edges_of_walk (P_k_pre @ [y]) \<union> edges_of_walk (y # Q_hit_post)"
          unfolding Q_hit'_def using walk_edges_decomp[of P_k_pre y Q_hit_post] by simp
        moreover have "(v,w) \<notin> edges_of_walk (P_k_pre @ [y])"
          using P_k_pre_edges v_w_in_B by blast
        moreover have "(v,w) \<notin> edges_of_walk (y # Q_hit_post)" proof
          assume "(v,w) \<in> edges_of_walk (y # Q_hit_post)"
          then have "(v,w) \<in> edges_of_walk Q_hit"
            unfolding Q_hit_decomp by (metis UnCI walk_edges_decomp)
          then show False using *(2) v_w_in_B Q_hit(1) unfolding Q_edges_def by blast
        qed
        ultimately show False using Q'_v_w_witness(2) by blast
      qed
      then have "Q'_v_w_witness \<in> Q" using Q'_v_w_witness(1) unfolding Q'_def by blast
      then have False using *(2) v_w_in_B Q'_v_w_witness(2) unfolding Q_edges_def by blast
    }
    moreover have "\<exists>e \<in> Q_edges. e \<notin> Q'_edges" proof-
      obtain v w where v_w: "(v,w) \<in> edges_of_walk (Q_hit_pre @ [y]) \<inter> B"
        using Q_hit_pre_edges by auto
      then have v_w_in_Q_hit: "(v,w) \<in> edges_of_walk Q_hit \<inter> B" unfolding Q_hit_decomp
        by (metis Int_iff UnCI walk_edges_decomp)
      then have "(v,w) \<in> Q_edges" unfolding Q_edges_def using Q_hit(1) by blast
      moreover have "(v,w) \<notin> Q'_edges" proof
        assume "(v,w) \<in> Q'_edges"
        then have "(v,w) \<in> edges_of_walk Q_hit'" unfolding Q'_edges_def Q'_def
          using IntD1 v_w_in_Q_hit Q_hit_edges_disjoint by auto
        then have "(v,w) \<in> edges_of_walk (y # Q_hit_post)" unfolding Q_hit'_def
          using v_w P_k_pre_edges
          by (metis (no_types, lifting) IntD2 UnE disjoint_iff_not_equal walk_edges_decomp)
        then show False using v_w Q_hit(1) Q.paths Q_hit_decomp
          by (metis DiffE Q.path_edges_remove_prefix IntD1 path_from_to_def)
      qed
      ultimately show ?thesis by blast
    qed
    moreover have "finite Q_edges" unfolding Q_edges_def B_def by simp
    moreover have "finite Q'_edges" unfolding Q'_edges_def B_def by simp
    ultimately have "card Q'_edges < card Q_edges" by (metis card_seteq not_le subrelI)
    then have "card (\<Union>(edges_of_walk ` Q') \<inter> B) < card (\<Union>(edges_of_walk ` Q) \<inter> B)"
      unfolding Q_edges_def Q'_edges_def by blast
    then show ?thesis unfolding Q_weight_def by blast
  qed

  private lemma DisjointPaths_Q': "DisjointPaths H_x v0 v1 Q'" proof-
    interpret Q_reduced: DisjointPaths H_x v0 v1 "Q - {Q_hit}"
      using Q.DisjointPaths_reduce[of "Q - {Q_hit}"] by blast
    {
      fix xs v
      assume xs: "xs \<in> Q - {Q_hit}"
          and v: "v \<in> set xs" "v \<in> set Q_hit'" "v \<noteq> v0" "v \<noteq> v1"
      have "v \<notin> set P_k_pre" proof
        assume "v \<in> set P_k_pre"
        then have "\<not>hitting_Q_or_new_last v" using y_min by blast
        moreover have "v \<noteq> new_last" using v(2) calculation hitting_Q_or_new_last_def v(3) by auto
        ultimately show False unfolding hitting_Q_or_new_last_def using v(1,3) xs by blast
      qed
      moreover have "v \<noteq> y"
        by (metis DiffE Q.paths_disjoint Q_hit y_neq_v0 y_neq_v1 insert_iff v(1) xs)
      moreover have "v \<notin> set Q_hit_post" proof
        assume "v \<in> set Q_hit_post"
        then have "v \<in> set Q_hit" unfolding Q_hit_decomp by simp
        then show False using Q.paths_disjoint[of Q_hit xs] xs Q_hit(1) v by blast
      qed
      ultimately have False using v(2) unfolding Q_hit'_def by simp
    }
    then show ?thesis using Q_reduced.DisjointPaths_extend Q_hit'_v0_v1_H_x
      unfolding Q'_def by blast
  qed

  private lemma card_Q': "card Q' = sep_size" proof-
    have "Suc (card (Q - {Q_hit})) = card Q"
      using Q_hit(1) Q.finite_paths by (meson card_Suc_Diff1)
    then show ?thesis using Q(2) Q.finite_paths Q_hit'_notin_Q_minus_Q_hit
      unfolding Q'_def by simp
  qed

  lemma contradiction': "False" using Q_weight_smaller DisjointPaths_Q' card_Q' Q_min
    using Suc_leI not_less_eq_eq by blast
end \<comment> \<open>anonymous context\<close>

corollary contradiction: "False" using Q_hit_exists contradiction' by blast

end \<comment> \<open>locale @{locale ProofStepInduct_y_neq_new_last}\<close>
end


(* Author: Tobias Nipkow *)

theory VCG_Total_EX
imports "~~/src/HOL/IMP/Hoare_Total_EX"
begin

subsection "Verification Conditions for Total Correctness"

text{* Annotated commands: commands where loops are annotated with
invariants. *}

datatype acom =
  Askip                  ("SKIP") |
  Aassign vname aexp     ("(_ ::= _)" [1000, 61] 61) |
  Aseq   acom acom       ("_;;/ _"  [60, 61] 60) |
  Aif bexp acom acom     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61) |
  Awhile "nat \<Rightarrow> assn" bexp acom
    ("({_}/ WHILE _/ DO _)"  [0, 0, 61] 61)

notation com.SKIP ("SKIP")

text{* Strip annotations: *}

fun strip :: "acom \<Rightarrow> com" where
"strip SKIP = SKIP" |
"strip (x ::= a) = (x ::= a)" |
"strip (C\<^sub>1;; C\<^sub>2) = (strip C\<^sub>1;; strip C\<^sub>2)" |
"strip (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = (IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2)" |
"strip ({_} WHILE b DO C) = (WHILE b DO strip C)"

text{* Weakest precondition from annotated commands: *}

fun pre :: "acom \<Rightarrow> assn \<Rightarrow> assn" where
"pre SKIP Q = Q" |
"pre (x ::= a) Q = (\<lambda>s. Q(s(x := aval a s)))" |
"pre (C\<^sub>1;; C\<^sub>2) Q = pre C\<^sub>1 (pre C\<^sub>2 Q)" |
"pre (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q =
  (\<lambda>s. if bval b s then pre C\<^sub>1 Q s else pre C\<^sub>2 Q s)" |
"pre ({I} WHILE b DO C) Q = (\<lambda>s. EX n. I n s)"

text{* Verification condition: *}

fun vc :: "acom \<Rightarrow> assn \<Rightarrow> bool" where
"vc SKIP Q = True" |
"vc (x ::= a) Q = True" |
"vc (C\<^sub>1;; C\<^sub>2) Q = (vc C\<^sub>1 (pre C\<^sub>2 Q) \<and> vc C\<^sub>2 Q)" |
"vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (vc C\<^sub>1 Q \<and> vc C\<^sub>2 Q)" |
"vc ({I} WHILE b DO C) Q =
  (\<forall>s n. (I (Suc n) s \<longrightarrow> pre C (I n) s) \<and>
       (I (Suc n) s \<longrightarrow> bval b s) \<and>
       (I 0 s \<longrightarrow> \<not> bval b s \<and> Q s) \<and>
       vc C (I n))"

lemma vc_sound: "vc C Q \<Longrightarrow> \<turnstile>\<^sub>t {pre C Q} strip C {Q}"
proof(induction C arbitrary: Q)
  case (Awhile I b C)
  show ?case
  proof(simp, rule conseq[OF _ While[of I]], goal_cases)
    case (2 n) show ?case
      using Awhile.IH[of "I n"] Awhile.prems
      by (auto intro: strengthen_pre)
  qed (insert Awhile.prems, auto)
qed (auto intro: conseq Seq If simp: Skip Assign)

text\<open>When trying to extend the completeness proof of the VCG for partial correctness
to total correctness one runs into the following problem.
In the case of the while-rule, the universally quantified \<open>n\<close> in the first premise
means that for that premise the induction hypothesis does not yield a single
annotated command \<open>C\<close> but merely that for every \<open>n\<close> such a \<open>C\<close> exists.\<close>

end


(*  Title:      HOL/IMPP/EvenOdd.thy
    Author:     David von Oheimb, TUM
*)

section \<open>Example of mutually recursive procedures verified with Hoare logic\<close>

theory EvenOdd
imports MainRLT Misc
begin

axiomatization
  Even :: pname and
  Odd :: pname
where
  Even_neq_Odd: "Even ~= Odd" and
  Arg_neq_Res:  "Arg  ~= Res"

definition
  evn :: com where
 "evn = (IF (%s. s<Arg> = 0)
         THEN Loc Res:==(%s. 0)
         ELSE(Loc Res:=CALL Odd(%s. s<Arg> - 1);;
              Loc Arg:=CALL Odd(%s. s<Arg> - 1);;
              Loc Res:==(%s. s<Res> * s<Arg>)))"

definition
  odd :: com where
 "odd = (IF (%s. s<Arg> = 0)
         THEN Loc Res:==(%s. 1)
         ELSE(Loc Res:=CALL Even (%s. s<Arg> - 1)))"

overloading bodies \<equiv> bodies
begin
  definition "bodies == [(Even,evn),(Odd,odd)]"
end

definition
  Z_eq_Arg_plus :: "nat => nat assn" ("Z=Arg+_" [50]50) where
  "Z=Arg+n = (%Z s.      Z =  s<Arg>+n)"

definition
  Res_ok :: "nat assn" where
  "Res_ok = (%Z s. even Z = (s<Res> = 0))"

subsection "Arg, Res"

declare Arg_neq_Res [simp] Arg_neq_Res [THEN not_sym, simp]
declare Even_neq_Odd [simp] Even_neq_Odd [THEN not_sym, simp]

lemma Z_eq_Arg_plus_def2: "(Z=Arg+n) Z s = (Z = s<Arg>+n)"
apply (unfold Z_eq_Arg_plus_def)
apply (rule refl)
done

lemma Res_ok_def2: "Res_ok Z s = (even Z = (s<Res> = 0))"
apply (unfold Res_ok_def)
apply (rule refl)
done

lemmas Arg_Res_simps = Z_eq_Arg_plus_def2 Res_ok_def2

lemma body_Odd [simp]: "body Odd = Some odd"
apply (unfold body_def bodies_def)
apply auto
done

lemma body_Even [simp]: "body Even = Some evn"
apply (unfold body_def bodies_def)
apply auto
done

subsection "verification"

lemma Odd_lemma: "{{Z=Arg+0}. BODY Even .{Res_ok}}|-{Z=Arg+Suc 0}. odd .{Res_ok}"
apply (unfold odd_def)
apply (rule hoare_derivs.If)
apply (rule hoare_derivs.Ass [THEN conseq1])
apply  (clarsimp simp: Arg_Res_simps)
apply (rule export_s)
apply (rule hoare_derivs.Call [THEN conseq1])
apply  (rule_tac P = "Z=Arg+Suc (Suc 0) " in conseq12)
apply (rule single_asm)
apply (auto simp: Arg_Res_simps)
done

lemma Even_lemma: "{{Z=Arg+1}. BODY Odd .{Res_ok}}|-{Z=Arg+0}. evn .{Res_ok}"
apply (unfold evn_def)
apply (rule hoare_derivs.If)
apply (rule hoare_derivs.Ass [THEN conseq1])
apply  (clarsimp simp: Arg_Res_simps)
apply (rule hoare_derivs.Comp)
apply (rule_tac [2] hoare_derivs.Ass)
apply clarsimp
apply (rule_tac Q = "%Z s. P Z s & Res_ok Z s" and P = P for P in hoare_derivs.Comp)
apply (rule export_s)
apply  (rule_tac I1 = "%Z l. Z = l Arg & 0 < Z" and Q1 = "Res_ok" in Call_invariant [THEN conseq12])
apply (rule single_asm [THEN conseq2])
apply   (clarsimp simp: Arg_Res_simps)
apply  (force simp: Arg_Res_simps)
apply (rule export_s)
apply (rule_tac I1 = "%Z l. even Z = (l Res = 0) " and Q1 = "%Z s. even Z = (s<Arg> = 0) " in Call_invariant [THEN conseq12])
apply (rule single_asm [THEN conseq2])
apply  (clarsimp simp: Arg_Res_simps)
apply (force simp: Arg_Res_simps)
done

lemma Even_ok_N: "{}|-{Z=Arg+0}. BODY Even .{Res_ok}"
apply (rule BodyN)
apply (simp (no_asm))
apply (rule Even_lemma [THEN hoare_derivs.cut])
apply (rule BodyN)
apply (simp (no_asm))
apply (rule Odd_lemma [THEN thin])
apply (simp (no_asm))
done

lemma Even_ok_S: "{}|-{Z=Arg+0}. BODY Even .{Res_ok}"
apply (rule conseq1)
apply  (rule_tac Procs = "{Odd, Even}" and pn = "Even" and P = "%pn. Z=Arg+ (if pn = Odd then 1 else 0) " and Q = "%pn. Res_ok" in Body1)
apply    auto
apply (rule hoare_derivs.insert)
apply (rule Odd_lemma [THEN thin])
apply  (simp (no_asm))
apply (rule Even_lemma [THEN thin])
apply (simp (no_asm))
done

end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics for Isabelle/Isar.

    Copyright (C) 2005 - 2022  Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open>Topology 1\<close>

theory Topology_ZF_1 imports Topology_ZF

begin

text\<open>In this theory file we study separation axioms and the notion of base and
  subbase. Using the products of open sets as a subbase we define a natural
  topology on a product of two topological spaces.\<close>

subsection\<open>Separation axioms\<close>

text\<open>Topological spaces cas be classified according to certain properties
  called "separation axioms". In this section we define what it means that a
  topological space is $T_0$, $T_1$ or $T_2$.\<close>

text\<open>A topology on $X$ is $T_0$ if for every pair of distinct points of $X$
  there is an open set that contains only one of them.\<close>

definition
  isT0 ("_ {is T\<^sub>0}" [90] 91) where
  "T {is T\<^sub>0} \<equiv> \<forall> x y. ((x \<in> \<Union>T \<and> y \<in> \<Union>T \<and>  x\<noteq>y) \<longrightarrow>
  (\<exists>U\<in>T. (x\<in>U \<and> y\<notin>U) \<or> (y\<in>U \<and> x\<notin>U)))"

text\<open>A topology is $T_1$ if for every such pair there exist an open set that
  contains the first point but not the second.\<close>

definition
  isT1 ("_ {is T\<^sub>1}" [90] 91) where
  "T {is T\<^sub>1} \<equiv> \<forall> x y. ((x \<in> \<Union>T \<and> y \<in> \<Union>T \<and>  x\<noteq>y) \<longrightarrow>
  (\<exists>U\<in>T. (x\<in>U \<and> y\<notin>U)))"

text\<open> $T_1$ topological spaces are exactly those in which all singletons are closed.\<close>

lemma (in topology0) t1_def_alt:
  shows "T {is T\<^sub>1} \<longleftrightarrow> (\<forall>x\<in>\<Union>T. {x} {is closed in} T)"
proof
  let ?X = "\<Union>T"
  assume T1: "T {is T\<^sub>1}"
  { fix x assume "x\<in>?X"
    let ?U = "?X-{x}"
    have "?U \<in> T"
    proof -
      let ?W = "\<Union>y\<in>?U.\<Union>{V\<in>T. y\<in>V \<and> x\<notin>V}"
      { fix y assume "y\<in>?U"
        with topSpaceAssum have "(\<Union>{V\<in>T. y\<in>V \<and> x\<notin>V}) \<in> T"
          unfolding IsATopology_def by blast
      } hence "\<forall>y\<in>?U. (\<Union>{V\<in>T. y\<in>V \<and> x\<notin>V}) \<in> T" by blast
      with topSpaceAssum have "?W\<in>T" by (rule union_indexed_open)
      have "?U = ?W"
      proof
        show "?W\<subseteq>?U" by auto
        { fix y assume "y\<in>?U"
          hence "y\<in>?X" and "y\<noteq>x" by auto
          with T1 \<open>x\<in>?X\<close> have  "y \<in> \<Union>{V\<in>T. y\<in>V \<and> x\<notin>V}"
            unfolding isT1_def by blast
          hence "y\<in>?W" by blast
        } thus "?U \<subseteq> ?W" by blast
      qed
      with \<open>?W\<in>T\<close> show "?U\<in>T" by simp
    qed
    with \<open>x\<in>?X\<close> have "(?X-?U) {is closed in} T" and "?X-?U = {x}"
      using Top_3_L9 by auto
    hence "{x} {is closed in} T" by simp
  } thus "\<forall>x\<in>?X. {x} {is closed in} T" by blast
next
  let ?X = "\<Union>T"
  assume scl: "\<forall>x\<in>\<Union>T. {x} {is closed in} T"
  { fix x y assume "x\<in>?X" "y\<in>?X" "x\<noteq>y"
    let ?U = "?X-{y}"
    from scl \<open>x\<in>?X\<close> \<open>y\<in>?X\<close> \<open>x\<noteq>y\<close> have "?U \<in> T" "x\<in>?U \<and> y\<notin>?U"
      unfolding IsClosed_def by auto
    then have "\<exists>U\<in>T. (x\<in>U \<and> y\<notin>U)" by (rule witness_exists)
  } then show "T {is T\<^sub>1}" unfolding isT1_def by blast
qed

text\<open>A topology is $T_2$ (Hausdorff) if for every pair of points there exist a
  pair of disjoint open sets each containing one of the points.
  This is an important class of topological spaces. In particular, metric
  spaces are Hausdorff.\<close>

definition
  isT2 ("_ {is T\<^sub>2}" [90] 91) where
  "T {is T\<^sub>2} \<equiv> \<forall> x y. ((x \<in> \<Union>T \<and> y \<in> \<Union>T \<and>  x\<noteq>y) \<longrightarrow>
  (\<exists>U\<in>T. \<exists>V\<in>T. x\<in>U \<and> y\<in>V \<and> U\<inter>V=0))"

text\<open>A topology is regular if every closed set can be separated from a point in its complement
  by (disjoint) opens sets.\<close>

definition
  IsRegular ("_ {is regular}" 90)
  where "T {is regular} \<equiv> \<forall>D. D {is closed in} T \<longrightarrow> (\<forall>x\<in>\<Union>T-D.\<exists>U\<in>T.\<exists>V\<in>T. D\<subseteq>U\<and>x\<in>V\<and>U\<inter>V=0)"

text\<open>Some sources (e.g. Metamath) use a different definition of regularity:
  any open neighborhood has a closed subneighborhood. The next lemma shows the equivalence
  of this with our definition.\<close>

lemma is_regular_def_alt: assumes "T {is a topology}"
  shows "T {is regular} \<longleftrightarrow> (\<forall>W\<in>T. \<forall>x\<in>W. \<exists>V\<in>T. x\<in>V \<and> Closure(V,T)\<subseteq>W)"
proof
  let ?X = "\<Union>T"
  from assms(1) have cntx: "topology0(T)"
    unfolding topology0_def by simp
  assume "T {is regular}"
  { fix W x assume "W\<in>T" "x\<in>W"
    have "\<exists>V\<in>T. x\<in>V \<and> Closure(V,T)\<subseteq>W"
    proof -
      let ?D = "?X-W"
      from cntx \<open>W\<in>T\<close> \<open>T {is regular}\<close> \<open>x\<in>W\<close>
      have "\<exists>U\<in>T.\<exists>V\<in>T. ?D\<subseteq>U\<and>x\<in>V\<and>U\<inter>V=0"
        using topology0.Top_3_L9 unfolding IsRegular_def by auto
      then obtain U V where "U\<in>T" "V\<in>T" "?D\<subseteq>U" "x\<in>V" "V\<inter>U=0"
        by blast
      from cntx \<open>V\<in>T\<close> have "Closure(V,T) \<subseteq> ?X"
        using topology0.Top_3_L11(1) by blast
      from cntx \<open>V\<in>T\<close> \<open>U\<in>T\<close> \<open>V\<inter>U=0\<close> \<open>?D\<subseteq>U\<close>
      have "Closure(V,T) \<inter> ?D = 0"
        using topology0.disj_open_cl_disj by blast
      with \<open>Closure(V,T) \<subseteq> ?X\<close> \<open>V\<in>T\<close> \<open>x\<in>V\<close> show ?thesis
        by blast
    qed
  } thus "\<forall>W\<in>T. \<forall>x\<in>W. \<exists>V\<in>T. x\<in>V \<and> Closure(V,T)\<subseteq>W"
    by simp
next
  let ?X = "\<Union>T"
  from assms(1) have cntx: "topology0(T)"
    unfolding topology0_def by simp
  assume regAlt: "\<forall>W\<in>T. \<forall>x\<in>W. \<exists>V\<in>T. x\<in>V \<and> Closure(V,T)\<subseteq>W"
  { fix A assume "A {is closed in} T"
    have "\<forall>x\<in>?X-A.\<exists>U\<in>T.\<exists>V\<in>T. A\<subseteq>U \<and> x\<in>V \<and> U\<inter>V=0"
    proof -
      { let ?W = "?X-A"
        from \<open>A {is closed in} T\<close> have "A\<subseteq>?X" and "?W\<in>T"
          unfolding IsClosed_def by auto
        fix x assume "x\<in>?W"
        with regAlt \<open>?W\<in>T\<close> have "\<exists>V\<in>T. x\<in>V \<and> Closure(V,T)\<subseteq>?W"
          by simp
        then obtain V where "V\<in>T" "x\<in>V" "Closure(V,T)\<subseteq>?W"
          by auto
        let ?U = "?X-Closure(V,T)"
        from cntx \<open>V\<in>T\<close> have "V\<subseteq>?X" and "V\<subseteq>Closure(V,T)"
          using topology0.cl_contains_set by auto
        with cntx \<open>A\<subseteq>?X\<close> \<open>Closure(V,T)\<subseteq>?W\<close>
        have "?U\<in>T" "A\<subseteq>?U" "?U\<inter>V = 0"
          using topology0.cl_is_closed(2) by auto
        with \<open>V\<in>T\<close> \<open>x\<in>V\<close> have "\<exists>U\<in>T.\<exists>V\<in>T. A\<subseteq>U \<and> x\<in>V \<and> U\<inter>V=0"
          by blast
      } thus ?thesis by blast
    qed
  } then show "T {is regular}" unfolding IsRegular_def
    by blast
qed

text\<open>If a topology is $T_1$ then it is $T_0$.
  We don't really assume here that $T$ is a topology on $X$.
  Instead, we prove the relation between isT0 condition and isT1.\<close>

lemma T1_is_T0: assumes A1: "T {is T\<^sub>1}" shows "T {is T\<^sub>0}"
proof -
  from A1 have "\<forall> x y. x \<in> \<Union>T \<and> y \<in> \<Union>T \<and> x\<noteq>y \<longrightarrow>
    (\<exists>U\<in>T. x\<in>U \<and> y\<notin>U)"
    using isT1_def by simp
  then have "\<forall> x y. x \<in> \<Union>T \<and> y \<in> \<Union>T \<and> x\<noteq>y \<longrightarrow>
    (\<exists>U\<in>T. x\<in>U \<and> y\<notin>U \<or> y\<in>U \<and> x\<notin>U)"
    by auto
  then show "T {is T\<^sub>0}" using isT0_def by simp
qed

text\<open>If a topology is $T_2$ then it is $T_1$.\<close>

lemma T2_is_T1: assumes A1: "T {is T\<^sub>2}" shows "T {is T\<^sub>1}"
proof -
  { fix x y assume "x \<in> \<Union>T"  "y \<in> \<Union>T"  "x\<noteq>y"
    with A1 have "\<exists>U\<in>T. \<exists>V\<in>T. x\<in>U \<and> y\<in>V \<and> U\<inter>V=0"
      using isT2_def by auto
    then have "\<exists>U\<in>T. x\<in>U \<and> y\<notin>U" by auto
  } then have "\<forall> x y. x \<in> \<Union>T \<and> y \<in> \<Union>T \<and>  x\<noteq>y \<longrightarrow>
      (\<exists>U\<in>T. x\<in>U \<and> y\<notin>U)" by simp
  then show "T {is T\<^sub>1}" using isT1_def by simp
qed

text\<open>In a $T_0$ space two points that can not be separated
  by an open set are equal. Proof by contradiction.\<close>

lemma Top_1_1_L1: assumes A1: "T {is T\<^sub>0}" and A2: "x \<in> \<Union>T"  "y \<in> \<Union>T"
  and A3: "\<forall>U\<in>T. (x\<in>U \<longleftrightarrow> y\<in>U)"
  shows "x=y"
proof -
  { assume "x\<noteq>y"
    with A1 A2 have "\<exists>U\<in>T. x\<in>U \<and> y\<notin>U \<or> y\<in>U \<and> x\<notin>U"
      using isT0_def by simp
    with A3 have False by auto
  } then show "x=y" by auto
qed

subsection\<open>Bases and subbases\<close>

text\<open>Sometimes it is convenient to talk about topologies in terms of their bases
  and subbases. These are certain collections of open sets that define
  the whole topology.\<close>

text\<open>A base of topology is a collection of open sets such that every
  open set is a union of the sets from the base.\<close>

definition
  IsAbaseFor (infixl "{is a base for}" 65) where
  "B {is a base for} T \<equiv> B\<subseteq>T \<and> T = {\<Union>A. A\<in>Pow(B)}"

text\<open>A subbase is a collection
  of open sets such that finite intersection of those sets form a base.\<close>

definition
  IsAsubBaseFor (infixl "{is a subbase for}" 65) where
  "B {is a subbase for} T \<equiv>
  B \<subseteq> T \<and> {\<Inter>A. A \<in> FinPow(B)} {is a base for} T"

text\<open>Below we formulate a condition that we will prove to be necessary and
  sufficient for a collection $B$ of open sets to form a base.
  It says that for any two sets $U,V$ from the collection $B$ we can
  find a point $x\in U\cap V$ with a neighboorhod
  from $B$ contained in $U\cap V$.\<close>

definition
  SatisfiesBaseCondition ("_ {satisfies the base condition}" [50] 50)
  where
  "B {satisfies the base condition} \<equiv>
  \<forall>U V. ((U\<in>B \<and> V\<in>B) \<longrightarrow> (\<forall>x \<in> U\<inter>V. \<exists>W\<in>B. x\<in>W \<and> W \<subseteq> U\<inter>V))"

text\<open>A collection that is closed with respect to intersection
  satisfies the base condition.\<close>

lemma inter_closed_base: assumes "\<forall>U\<in>B.(\<forall>V\<in>B. U\<inter>V \<in> B)"
  shows  "B {satisfies the base condition}"
proof -
    { fix U V x assume "U\<in>B" and "V\<in>B" and "x \<in> U\<inter>V"
      with assms have "\<exists>W\<in>B. x\<in>W \<and> W \<subseteq> U\<inter>V" by blast
    } then show ?thesis using SatisfiesBaseCondition_def by simp
qed

text\<open>Each open set is a union of some sets from the base.\<close>

lemma Top_1_2_L1: assumes "B {is a base for} T"  and "U\<in>T"
  shows "\<exists>A\<in>Pow(B). U = \<Union>A"
  using assms IsAbaseFor_def by simp

text\<open>Elements of base are open.\<close>

lemma base_sets_open:
  assumes "B {is a base for} T" and "U \<in> B"
  shows "U \<in> T"
  using assms IsAbaseFor_def by auto

text\<open>A base defines topology uniquely.\<close>

lemma same_base_same_top:
  assumes "B {is a base for} T" and "B {is a base for} S"
  shows "T = S"
  using assms IsAbaseFor_def by simp

text\<open>Every point from an open set has a neighboorhood from the base
  that is contained in the set.\<close>

lemma point_open_base_neigh:
  assumes A1: "B {is a base for} T" and A2: "U\<in>T" and A3: "x\<in>U"
  shows "\<exists>V\<in>B. V\<subseteq>U \<and> x\<in>V"
proof -
  from A1 A2 obtain A where "A \<in> Pow(B)" and "U = \<Union>A"
    using Top_1_2_L1 by blast
  with A3 obtain V where "V\<in>A" and "x\<in>V" by auto
  with \<open>A \<in> Pow(B)\<close> \<open>U = \<Union>A\<close> show ?thesis by auto
qed

text\<open>A criterion for a collection to be a base for a topology
  that is a slight reformulation of the definition. The only thing
  different that in the definition is that we assume only that
  every open set is a union of some sets from the base. The definition
  requires also the opposite inclusion that every union of the
  sets from the base is open, but that we can prove if we assume that
  $T$ is a topology.\<close>

lemma is_a_base_criterion: assumes A1: "T {is a topology}"
  and A2: "B \<subseteq> T" and A3: "\<forall>V \<in> T. \<exists>A \<in> Pow(B). V = \<Union>A"
  shows "B {is a base for} T"
proof -
  from A3 have "T \<subseteq> {\<Union>A. A\<in>Pow(B)}" by auto
  moreover have "{\<Union>A. A\<in>Pow(B)} \<subseteq> T"
  proof
    fix U assume "U \<in> {\<Union>A. A\<in>Pow(B)}"
    then obtain A where "A \<in> Pow(B)" and "U = \<Union>A"
      by auto
    with \<open>B \<subseteq> T\<close> have "A \<in> Pow(T)" by auto
    with A1 \<open>U = \<Union>A\<close> show "U \<in> T"
      unfolding IsATopology_def by simp
  qed
  ultimately have "T = {\<Union>A. A\<in>Pow(B)}" by auto
  with A2 show "B {is a base for} T"
    unfolding IsAbaseFor_def by simp
qed

text\<open>A necessary condition for a collection of sets to be a base for some
  topology : every point in the intersection
  of two sets in the base has a neighboorhood from the base contained
  in the intersection.\<close>

lemma Top_1_2_L2:
  assumes A1:"\<exists>T. T {is a topology} \<and> B {is a base for} T"
  and A2: "V\<in>B"  "W\<in>B"
  shows "\<forall> x \<in> V\<inter>W. \<exists>U\<in>B. x\<in>U \<and> U \<subseteq> V \<inter> W"
proof -
  from A1 obtain T where
    D1: "T {is a topology}"   "B {is a base for} T"
    by auto
  then have "B \<subseteq> T" using IsAbaseFor_def by auto
  with A2 have "V\<in>T" and "W\<in>T" using IsAbaseFor_def by auto
  with D1 have "\<exists>A\<in>Pow(B). V\<inter>W = \<Union>A" using IsATopology_def Top_1_2_L1
    by auto
  then obtain A where "A \<subseteq> B" and "V \<inter> W = \<Union>A" by auto
  then show "\<forall> x \<in> V\<inter>W. \<exists>U\<in>B. (x\<in>U \<and> U \<subseteq> V \<inter> W)" by auto
qed

text\<open>We will construct a topology as the collection of unions of (would-be)
  base. First we prove that if the collection of sets satisfies the
  condition we want to show to be sufficient, the the intersection belongs
  to what we will define as topology (am I clear here?). Having this fact
  ready simplifies the proof of the next lemma. There is not much topology
  here, just some set theory.\<close>

lemma Top_1_2_L3:
  assumes A1: "\<forall>x\<in> V\<inter>W . \<exists>U\<in>B. x\<in>U \<and> U \<subseteq> V\<inter>W"
  shows "V\<inter>W \<in> {\<Union>A. A\<in>Pow(B)}"
proof
  let ?A = "\<Union>x\<in>V\<inter>W. {U\<in>B. x\<in>U \<and> U \<subseteq> V\<inter>W}"
  show "?A\<in>Pow(B)" by auto
  from A1 show "V\<inter>W = \<Union>?A" by blast
qed

text\<open>The next lemma is needed when proving that the would-be topology is
  closed with respect to taking intersections. We show here that intersection
  of two sets from this (would-be) topology can be written as union of sets
  from the topology.\<close>

lemma Top_1_2_L4:
  assumes A1:  "U\<^sub>1 \<in> {\<Union>A. A\<in>Pow(B)}"   "U\<^sub>2 \<in> {\<Union>A. A\<in>Pow(B)}"
  and A2: "B {satisfies the base condition}"
  shows "\<exists>C. C \<subseteq> {\<Union>A. A\<in>Pow(B)} \<and> U\<^sub>1\<inter>U\<^sub>2 = \<Union>C"
proof -
  from A1 A2 obtain A\<^sub>1 A\<^sub>2 where
    D1: "A\<^sub>1\<in> Pow(B)"  "U\<^sub>1 = \<Union>A\<^sub>1"  "A\<^sub>2 \<in> Pow(B)"  "U\<^sub>2 = \<Union>A\<^sub>2"
    by auto
  let ?C = "\<Union>U\<in>A\<^sub>1.{U\<inter>V. V\<in>A\<^sub>2}"
  from D1 have "(\<forall>U\<in>A\<^sub>1. U\<in>B) \<and> (\<forall>V\<in>A\<^sub>2. V\<in>B)" by auto
  with A2 have "?C \<subseteq> {\<Union>A . A \<in> Pow(B)}"
    using Top_1_2_L3 SatisfiesBaseCondition_def by auto
  moreover from D1 have "U\<^sub>1 \<inter> U\<^sub>2 = \<Union>?C" by auto
  ultimately show ?thesis by auto
qed

text\<open>If $B$ satisfies the base condition, then the collection of unions
  of sets from $B$ is a topology and $B$ is a base for this topology.\<close>

theorem Top_1_2_T1:
  assumes A1: "B {satisfies the base condition}"
  and A2: "T = {\<Union>A. A\<in>Pow(B)}"
  shows "T {is a topology}" and "B {is a base for} T"
proof -
  show "T {is a topology}"
  proof -
    have I: "\<forall>C\<in>Pow(T). \<Union>C \<in> T"
    proof -
      { fix C assume A3: "C \<in> Pow(T)"
        let ?Q = "\<Union> {\<Union>{A\<in>Pow(B). U = \<Union>A}. U\<in>C}"
        from A2 A3 have "\<forall>U\<in>C. \<exists>A\<in>Pow(B). U = \<Union>A" by auto
        then have "\<Union>?Q = \<Union>C" using ZF1_1_L10 by simp
        moreover from A2 have "\<Union>?Q \<in> T" by auto
        ultimately have "\<Union>C \<in> T" by simp
      } thus "\<forall>C\<in>Pow(T). \<Union>C \<in> T" by auto
    qed
    moreover have "\<forall>U\<in>T. \<forall> V\<in>T. U\<inter>V \<in> T"
    proof -
      { fix U V assume  "U \<in> T"  "V \<in> T"
        with A1 A2 have "\<exists>C.(C \<subseteq> T \<and> U\<inter>V = \<Union>C)"
        using Top_1_2_L4 by simp
        then obtain C where "C \<subseteq> T" and  "U\<inter>V = \<Union>C"
          by auto
          with I have "U\<inter>V \<in> T" by simp
      } then show "\<forall>U\<in>T. \<forall> V\<in>T. U\<inter>V \<in> T" by simp
    qed
    ultimately show "T {is a topology}" using IsATopology_def
      by simp
  qed
  from A2 have "B\<subseteq>T" by auto
  with A2 show "B {is a base for} T" using IsAbaseFor_def
    by simp
qed

text\<open>The carrier of the base and topology are the same.\<close>

lemma Top_1_2_L5: assumes "B {is a base for} T"
  shows "\<Union>T = \<Union>B"
  using assms IsAbaseFor_def by auto

text\<open>If $B$ is a base for $T$, then $T$ is the smallest topology containing $B$.
\<close>

lemma base_smallest_top:
  assumes A1: "B {is a base for} T" and  A2: "S {is a topology}" and A3: "B\<subseteq>S"
  shows "T\<subseteq>S"
proof
  fix U assume "U\<in>T"
  with A1 obtain B\<^sub>U where "B\<^sub>U \<subseteq> B" and "U = \<Union>B\<^sub>U" using IsAbaseFor_def by auto
  with A3 have "B\<^sub>U \<subseteq> S" by auto
  with A2 \<open>U = \<Union>B\<^sub>U\<close> show "U\<in>S" using IsATopology_def by simp
qed

text\<open>If $B$ is a base for $T$ and $B$ is a topology, then $B=T$.\<close>

lemma base_topology: assumes "B {is a topology}" and "B {is a base for} T"
  shows "B=T" using assms base_sets_open base_smallest_top by blast

subsection\<open>Product topology\<close>

text\<open>In this section we consider a topology defined on a product of two sets.\<close>

text\<open>Given two topological spaces we can define a topology on the product of
  the carriers such that the cartesian products of the sets of the topologies
  are a base for the product topology. Recall that for two collections $S,T$
  of sets the product collection is defined (in \<open>ZF1.thy\<close>) as the collections of cartesian
  products $A\times B$, where $A\in S, B\in T$. The $T\times_tS$ notation is defined as
  an alternative to the verbose  \<open>ProductTopology(T,S)\<close>). \<close>

definition ProductTopology (infixl "\<times>\<^sub>t" 65) where
  "T \<times>\<^sub>t S  \<equiv> {\<Union>W. W \<in> Pow(ProductCollection(T,S))}"

text\<open>The product collection satisfies the base condition.\<close>

lemma Top_1_4_L1:
  assumes A1: "T {is a topology}"   "S {is a topology}"
  and A2: "A \<in> ProductCollection(T,S)"  "B \<in> ProductCollection(T,S)"
  shows "\<forall>x\<in>(A\<inter>B). \<exists>W\<in>ProductCollection(T,S). (x\<in>W \<and> W \<subseteq> A \<inter> B)"
proof
  fix x assume A3: "x \<in> A\<inter>B"
  from A2 obtain U\<^sub>1 V\<^sub>1 U\<^sub>2 V\<^sub>2 where
    D1: "U\<^sub>1\<in>T"  "V\<^sub>1\<in>S"   "A=U\<^sub>1\<times>V\<^sub>1"  "U\<^sub>2\<in>T"  "V\<^sub>2\<in>S"   "B=U\<^sub>2\<times>V\<^sub>2"
    using ProductCollection_def by auto
  let ?W = "(U\<^sub>1\<inter>U\<^sub>2) \<times> (V\<^sub>1\<inter>V\<^sub>2)"
  from A1 D1 have "U\<^sub>1\<inter>U\<^sub>2 \<in> T" and "V\<^sub>1\<inter>V\<^sub>2 \<in> S"
    using IsATopology_def by auto
  then have "?W \<in> ProductCollection(T,S)" using ProductCollection_def
    by auto
  moreover from A3 D1 have "x\<in>?W" and "?W \<subseteq> A\<inter>B" by auto
  ultimately have "\<exists>W. (W \<in> ProductCollection(T,S) \<and> x\<in>W \<and> W \<subseteq> A\<inter>B)"
    by auto
  thus "\<exists>W\<in>ProductCollection(T,S). (x\<in>W \<and> W \<subseteq> A \<inter> B)" by auto
qed

text\<open>The product topology is indeed a topology on the product.\<close>

theorem Top_1_4_T1: assumes A1: "T {is a topology}"  "S {is a topology}"
  shows
  "(T\<times>\<^sub>tS) {is a topology}"
  "ProductCollection(T,S) {is a base for} (T\<times>\<^sub>tS)"
  "\<Union>(T\<times>\<^sub>tS) = \<Union>T \<times> \<Union>S"
proof -
  from A1 show
    "(T\<times>\<^sub>tS) {is a topology}"
    "ProductCollection(T,S) {is a base for} (T\<times>\<^sub>tS)"
    using Top_1_4_L1 ProductCollection_def
      SatisfiesBaseCondition_def ProductTopology_def Top_1_2_T1
    by auto
  then show "\<Union>(T\<times>\<^sub>tS) = \<Union>T \<times> \<Union>S"
    using Top_1_2_L5 ZF1_1_L6 by simp
qed

text\<open>Each point of a set open in the product topology has a neighborhood
  which is a cartesian product of open sets.\<close>

lemma prod_top_point_neighb:
  assumes A1: "T {is a topology}"  "S {is a topology}" and
  A2: "U \<in> ProductTopology(T,S)" and A3: "x \<in> U"
  shows "\<exists>V W. V\<in>T \<and> W\<in>S \<and> V\<times>W \<subseteq> U \<and> x \<in> V\<times>W"
proof -
  from A1 have
    "ProductCollection(T,S) {is a base for} ProductTopology(T,S)"
    using Top_1_4_T1 by simp
  with A2 A3 obtain Z where
    "Z \<in> ProductCollection(T,S)" and "Z \<subseteq> U \<and> x\<in>Z"
    using point_open_base_neigh by blast
  then obtain V W where "V \<in> T" and "W\<in>S" and" V\<times>W \<subseteq> U \<and> x \<in> V\<times>W"
    using ProductCollection_def by auto
  thus ?thesis by auto
qed

text\<open>Products of open sets are open in the product topology.\<close>

lemma prod_open_open_prod:
  assumes A1: "T {is a topology}"  "S {is a topology}" and
  A2: "U\<in>T" "V\<in>S"
  shows "U\<times>V \<in> ProductTopology(T,S)"
proof -
  from A1 have
    "ProductCollection(T,S) {is a base for} ProductTopology(T,S)"
    using Top_1_4_T1 by simp
  moreover from A2 have "U\<times>V \<in> ProductCollection(T,S)"
    unfolding ProductCollection_def by auto
  ultimately show "U\<times>V \<in> ProductTopology(T,S)"
    using base_sets_open by simp
qed

text\<open>Sets that are open in the product topology are contained in the product
  of the carrier.\<close>

lemma prod_open_type: assumes A1: "T {is a topology}"  "S {is a topology}" and
  A2: "V \<in> ProductTopology(T,S)"
  shows "V \<subseteq> \<Union>T \<times> \<Union>S"
proof -
  from A2 have "V \<subseteq> \<Union> ProductTopology(T,S)" by auto
  with A1 show ?thesis using Top_1_4_T1 by simp
qed

text\<open>A reverse of \<open>prod_top_point_neighb\<close>: if each point of set has an neighborhood in the set
  that is a cartesian product of open sets, then the set is open.\<close>

lemma point_neighb_prod_top:
  assumes "T {is a topology}"  "S {is a topology}"
  and "\<forall>p\<in>V. \<exists>U\<in>T.\<exists>W\<in>S. p\<in>U\<times>W \<and> U\<times>W \<subseteq> V"
shows "V \<in> ProductTopology(T,S)"
proof -
  from assms(1,2) have I: "topology0(ProductTopology(T,S))"
    using Top_1_4_T1(1) topology0_def by simp
  moreover
  { fix p assume "p\<in>V"
    with assms(3) obtain U W where "U\<in>T" "W\<in>S" "p\<in>U\<times>W" "U\<times>W \<subseteq> V"
      by auto
    with assms(1,2) have "\<exists>N\<in>ProductTopology(T,S). p\<in>N \<and> N\<subseteq>V"
      using prod_open_open_prod by auto
  } hence "\<forall>p\<in>V. \<exists>N\<in>ProductTopology(T,S). p\<in>N \<and> N\<subseteq>V" by blast
  ultimately show ?thesis using topology0.open_neigh_open by simp
qed

text\<open>Suppose we have subsets $A\subseteq X, B\subseteq Y$, where
  $X,Y$ are topological spaces with topologies $T,S$. We can the consider
  relative topologies on $T_A, S_B$ on sets $A,B$ and the collection
  of cartesian products of sets open in $T_A, S_B$, (namely
  $\{U\times V: U\in T_A, V\in S_B\}$. The next lemma states that
  this collection is a base of the product topology on $X\times Y$
  restricted to the product $A\times B$.\<close>

lemma prod_restr_base_restr:
  assumes A1: "T {is a topology}"  "S {is a topology}"
  shows
  "ProductCollection(T {restricted to} A, S {restricted to} B)
  {is a base for} (ProductTopology(T,S) {restricted to} A\<times>B)"
proof -
  let ?\<B> = "ProductCollection(T {restricted to} A, S {restricted to} B)"
  let ?\<tau> = "ProductTopology(T,S)"
  from A1 have "(?\<tau> {restricted to} A\<times>B) {is a topology}"
    using Top_1_4_T1 topology0_def topology0.Top_1_L4
    by simp
  moreover have "?\<B> \<subseteq> (?\<tau> {restricted to} A\<times>B)"
  proof
    fix U assume "U \<in> ?\<B>"
    then obtain U\<^sub>A U\<^sub>B where "U = U\<^sub>A \<times> U\<^sub>B" and
      "U\<^sub>A \<in> (T {restricted to} A)" and "U\<^sub>B \<in> (S {restricted to} B)"
      using ProductCollection_def by auto
    then obtain W\<^sub>A W\<^sub>B where
      "W\<^sub>A \<in> T"  "U\<^sub>A = W\<^sub>A \<inter> A" and "W\<^sub>B \<in> S"  "U\<^sub>B = W\<^sub>B \<inter> B"
      using RestrictedTo_def by auto
    with \<open>U = U\<^sub>A \<times> U\<^sub>B\<close> have "U = W\<^sub>A\<times>W\<^sub>B \<inter> (A\<times>B)" by auto
    moreover from A1 \<open>W\<^sub>A \<in> T\<close> and \<open>W\<^sub>B \<in> S\<close> have "W\<^sub>A\<times>W\<^sub>B \<in> ?\<tau>"
      using prod_open_open_prod by simp
    ultimately show "U \<in> ?\<tau> {restricted to} A\<times>B"
      using RestrictedTo_def by auto
  qed
  moreover have "\<forall>U \<in> ?\<tau> {restricted to} A\<times>B.
    \<exists>C \<in> Pow(?\<B>). U = \<Union>C"
  proof
    fix U assume "U \<in> ?\<tau> {restricted to} A\<times>B"
    then obtain W where "W \<in> ?\<tau>" and "U = W \<inter> (A\<times>B)"
      using RestrictedTo_def by auto
    from A1 \<open>W \<in> ?\<tau>\<close> obtain A\<^sub>W  where
      "A\<^sub>W \<in> Pow(ProductCollection(T,S))" and "W = \<Union>A\<^sub>W"
       using Top_1_4_T1 IsAbaseFor_def by auto
    let ?C = "{V \<inter> A\<times>B. V \<in> A\<^sub>W}"
    have "?C \<in> Pow(?\<B>)" and "U = \<Union>?C"
    proof -
      { fix R assume "R \<in> ?C"
	then obtain V where "V \<in> A\<^sub>W" and "R = V \<inter> A\<times>B"
	  by auto
	with \<open>A\<^sub>W \<in> Pow(ProductCollection(T,S))\<close> obtain V\<^sub>T V\<^sub>S where
	  "V\<^sub>T \<in> T" and "V\<^sub>S \<in> S" and "V = V\<^sub>T \<times> V\<^sub>S"
	  using ProductCollection_def by auto
	with \<open>R = V \<inter> A\<times>B\<close> have "R \<in> ?\<B>"
	  using ProductCollection_def RestrictedTo_def
	  by auto
      } then show "?C \<in> Pow(?\<B>)" by auto
      from \<open>U = W \<inter> (A\<times>B)\<close> and \<open>W = \<Union>A\<^sub>W\<close>
      show "U = \<Union>?C" by auto
    qed
    thus "\<exists>C \<in> Pow(?\<B>). U = \<Union>C" by blast
  qed
  ultimately show ?thesis by (rule is_a_base_criterion)
qed

text\<open>We can commute taking restriction (relative topology) and
  product topology. The reason the two topologies are the same is
  that they have the same base.\<close>

lemma prod_top_restr_comm:
  assumes A1: "T {is a topology}"  "S {is a topology}"
  shows
  "ProductTopology(T {restricted to} A,S {restricted to} B) =
  ProductTopology(T,S) {restricted to} (A\<times>B)"
proof -
  let ?\<B> = "ProductCollection(T {restricted to} A, S {restricted to} B)"
  from A1 have
    "?\<B> {is a base for} ProductTopology(T {restricted to} A,S {restricted to} B)"
    using topology0_def topology0.Top_1_L4 Top_1_4_T1 by simp
  moreover from A1 have
    "?\<B> {is a base for} ProductTopology(T,S) {restricted to} (A\<times>B)"
    using prod_restr_base_restr by simp
  ultimately show ?thesis by (rule same_base_same_top)
qed

text\<open>Projection of a section of an open set is open.\<close>

lemma prod_sec_open1: assumes A1: "T {is a topology}"  "S {is a topology}" and
  A2: "V \<in> ProductTopology(T,S)" and A3: "x \<in> \<Union>T"
  shows "{y \<in> \<Union>S. \<langle>x,y\<rangle> \<in> V} \<in> S"
proof -
  let ?A = "{y \<in> \<Union>S. \<langle>x,y\<rangle> \<in> V}"
  from A1 have "topology0(S)" using topology0_def by simp
  moreover have "\<forall>y\<in>?A.\<exists>W\<in>S. (y\<in>W \<and> W\<subseteq>?A)"
    proof
      fix y assume "y \<in> ?A"
      then have "\<langle>x,y\<rangle> \<in> V" by simp
      with A1 A2 have "\<langle>x,y\<rangle> \<in> \<Union>T \<times> \<Union>S" using prod_open_type by blast
      hence "x \<in> \<Union>T" and "y \<in> \<Union>S" by auto
      from A1 A2 \<open>\<langle>x,y\<rangle> \<in> V\<close> have "\<exists>U W. U\<in>T \<and> W\<in>S \<and> U\<times>W \<subseteq> V \<and> \<langle>x,y\<rangle> \<in> U\<times>W"
        by (rule prod_top_point_neighb)
      then obtain U W where  "U\<in>T" "W\<in>S" "U\<times>W \<subseteq> V" "\<langle>x,y\<rangle> \<in> U\<times>W"
        by auto
      with A1 A2 show "\<exists>W\<in>S. (y\<in>W \<and> W\<subseteq>?A)" using prod_open_type section_proj
        by auto
    qed
  ultimately show ?thesis by (rule topology0.open_neigh_open)
qed

text\<open>Projection of a section of an open set is open. This is dual of
\<open>prod_sec_open1\<close> with a very similar proof.\<close>

lemma prod_sec_open2: assumes A1: "T {is a topology}"  "S {is a topology}" and
  A2: "V \<in> ProductTopology(T,S)" and A3: "y \<in> \<Union>S"
  shows "{x \<in> \<Union>T. \<langle>x,y\<rangle> \<in> V} \<in> T"
proof -
  let ?A = "{x \<in> \<Union>T. \<langle>x,y\<rangle> \<in> V}"
  from A1 have "topology0(T)" using topology0_def by simp
  moreover have "\<forall>x\<in>?A.\<exists>W\<in>T. (x\<in>W \<and> W\<subseteq>?A)"
    proof
      fix x assume "x \<in> ?A"
      then have "\<langle>x,y\<rangle> \<in> V" by simp
      with A1 A2 have "\<langle>x,y\<rangle> \<in> \<Union>T \<times> \<Union>S" using prod_open_type by blast
      hence "x \<in> \<Union>T" and "y \<in> \<Union>S" by auto
      from A1 A2 \<open>\<langle>x,y\<rangle> \<in> V\<close> have "\<exists>U W. U\<in>T \<and> W\<in>S \<and> U\<times>W \<subseteq> V \<and> \<langle>x,y\<rangle> \<in> U\<times>W"
        by (rule prod_top_point_neighb)
      then obtain U W where  "U\<in>T" "W\<in>S" "U\<times>W \<subseteq> V" "\<langle>x,y\<rangle> \<in> U\<times>W"
        by auto
      with A1 A2 show "\<exists>W\<in>T. (x\<in>W \<and> W\<subseteq>?A)" using prod_open_type section_proj
        by auto
    qed
  ultimately show ?thesis by (rule topology0.open_neigh_open)
qed

subsection\<open>Hausdorff spaces\<close>

text\<open>In this section we study properties of Hausdorff spaces (sometimes called separated spaces)
  These are topological spaces that are $T_2$ as defined above.\<close>

text\<open>A space is Hausdorff if and only if the diagonal $\Delta = \{\langle x,x\rangle : x\in X\}$
  is closed in the product topology on $X\times X$. \<close>

theorem t2_iff_diag_closed: assumes "T {is a topology}"
  shows "T {is T\<^sub>2} \<longleftrightarrow> {\<langle>x,x\<rangle>. x\<in>\<Union>T} {is closed in} ProductTopology(T,T)"
proof
  let ?X = "\<Union>T"
  from assms(1) have I: "topology0(ProductTopology(T,T))"
    using Top_1_4_T1(1) topology0_def by simp
  assume "T {is T\<^sub>2}" show "{\<langle>x,x\<rangle>. x\<in>?X} {is closed in} ProductTopology(T,T)"
  proof -
    let ?D\<^sub>c = "?X\<times>?X - {\<langle>x,x\<rangle>. x\<in>?X}"
    have "\<forall>p\<in>?D\<^sub>c.\<exists>U\<in>T.\<exists>V\<in>T. p\<in>U\<times>V \<and> U\<times>V \<subseteq> ?D\<^sub>c"
    proof -
      { fix p assume "p\<in>?D\<^sub>c"
        then obtain x y where "p=\<langle>x,y\<rangle>" "x\<in>?X" "y\<in>?X" "x\<noteq>y" by auto
        with \<open>T {is T\<^sub>2}\<close> obtain U V where "U\<in>T" "V\<in>T" "x\<in>U" "y\<in>V" "U\<inter>V = 0"
          unfolding isT2_def by blast
        with assms \<open>p=\<langle>x,y\<rangle>\<close> have "\<exists>U\<in>T.\<exists>V\<in>T. p\<in>U\<times>V \<and> U\<times>V \<subseteq> ?D\<^sub>c" by auto
      } hence "\<forall>p. p\<in>?D\<^sub>c \<longrightarrow> (\<exists>U\<in>T.\<exists>V\<in>T. p\<in>U\<times>V \<and> U\<times>V \<subseteq> ?D\<^sub>c)" by simp
      then show ?thesis by (rule exists_in_set)
    qed
    with assms show ?thesis using Top_1_4_T1(3) point_neighb_prod_top
      unfolding IsClosed_def by auto
  qed
next
  let ?X = "\<Union>T"
  assume A: "{\<langle>x,x\<rangle>. x\<in>?X} {is closed in} ProductTopology(T,T)" show "T {is T\<^sub>2}"
  proof -
    { let ?D\<^sub>c = "?X\<times>?X - {\<langle>x,x\<rangle>. x\<in>?X}"
      fix x y assume "x\<in>?X" "y\<in>?X" "x\<noteq>y"
      with assms A have "?D\<^sub>c \<in> ProductTopology(T,T)" and "\<langle>x,y\<rangle> \<in> ?D\<^sub>c"
        using Top_1_4_T1(3) unfolding IsClosed_def by auto
      with assms obtain U V where "U\<in>T" "V\<in>T" "U\<times>V \<subseteq> ?D\<^sub>c" "\<langle>x,y\<rangle> \<in> U\<times>V"
        using prod_top_point_neighb by blast
      moreover from \<open>U\<times>V \<subseteq> ?D\<^sub>c\<close> have "U\<inter>V = 0" by auto
      ultimately have "\<exists>U\<in>T.\<exists>V\<in>T. x\<in>U \<and> y\<in>V \<and> U\<inter>V=0" by auto
    } then show "T {is T\<^sub>2}" unfolding isT2_def by simp
  qed
qed

end


theory prop_40
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun elem :: "Nat => Nat list => bool" where
  "elem x (Nil2) = False"
  | "elem x (Cons2 z xs) = (if equal2 x z then True else elem x xs)"
  fun subset :: "Nat list => Nat list => bool" where
  "subset (Nil2) y = True"
  | "subset (Cons2 z xs) y =
       (if elem z y then subset xs y else False)"
  fun union :: "Nat list => Nat list => Nat list" where
  "union (Nil2) y = y"
  | "union (Cons2 z xs) y =
       (if elem z y then union xs y else Cons2 z (union xs y))"
  (*hipster equal2 elem subset union *)
(*
hipster_cond subset union
*)
  theorem x0 :
    "(subset x y) ==> ((union x y) = y)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory List_Join_Split
  imports
    Main
begin

section "Join and split functions for lists of lists"

text "This implements a join and split function for a list of lists, where the lists are delimited by a single type. Works great for strings, which are lists of characters, where the delimiter is a single character."

fun join :: "'t \<Rightarrow> 't list list \<Rightarrow> 't list" where
  "join d [] = []" |
  "join d [x] = x" |
  "join d (x#xs) = x @ [d] @ (join d xs)"

fun join_alt :: "'t \<Rightarrow> 't list list \<Rightarrow> 't list" where
  "join_alt d [] = []" |
  "join_alt d [x] = x" |
  "join_alt d (xs) = join_alt d (butlast (xs)) @ [d] @ last (xs)"

fun split_rec :: "'t \<Rightarrow> 't list \<Rightarrow> 't list list \<Rightarrow> 't list \<Rightarrow> 't list list" where
  "split_rec d [] xss ys = xss @ [ys]" |
  "split_rec d (x#xs) xss ys = (if x = d then split_rec d xs (xss @ [ys]) [] else split_rec d xs xss (ys @ [x]))"

definition split :: "'t \<Rightarrow> 't list \<Rightarrow> 't list list" where
  "split d s \<equiv> split_rec d s [] []"

subsection "Lemma's on definitions"

lemma join_prepend: "xs \<noteq> [] \<Longrightarrow> join d (x#xs) = x @ [d] @ join d xs"
  by (induct xs) simp_all

lemma join_append: "xs \<noteq> [] \<Longrightarrow> join d (xs @ [x]) = join d xs @ [d] @ x"
proof (induct xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons y ys)
  then show ?case
  proof (induct ys)
    case Nil
    then show ?case
      by simp
  next
    case (Cons z zs)
    then show ?case
      by simp
  qed
qed

lemma join_alt_append: "xs \<noteq> [] \<Longrightarrow> join_alt d (xs @ [x]) = join_alt d xs @ [d] @ x"
proof-
  fix xs :: "'a list list"
  fix x :: "'a list"
  assume "xs \<noteq> []"
  then have "join_alt d (xs @ [x]) = join_alt d (butlast (xs @ [x])) @ [d] @ last (xs @ [x])"
  proof (induct xs)
    case Nil
    then show ?case
      by simp
  next
    case (Cons y ys)
    then show ?case
    proof (induct ys)
      case Nil
      then show ?case
        by simp
    next
      case (Cons z zs)
      then show ?case
        by simp
    qed
  qed
  then show "join_alt d (xs @ [x]) = join_alt d xs @ [d] @ x"
    by simp
qed

lemma join_alt_def: "join d = join_alt d"
proof
  fix d :: "'t"
  fix x :: "'t list list"
  show "join d x = join_alt d x"
  proof (induct x rule: rev_induct)
    case Nil
    then show ?case
      by simp
  next
    case (snoc x xs)
    then show ?case
      using append_Nil join.simps(2) join_alt.simps(2) join_alt_append join_append
      by metis
  qed
qed

lemma join_alt_prepend: "xs \<noteq> [] \<Longrightarrow> join_alt d (x#xs) = x @ [d] @ join_alt d xs"
  using join_alt_def join_prepend
  by metis

lemma join_singleton_preserve: "d \<notin> set xs \<Longrightarrow> d \<notin> set (join d [xs])"
  by simp

lemma split_rec_base_list: "\<And>xss ys. split_rec d xs xss ys = xss @ split_rec d xs [] ys"
proof (induct xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons x xs)
  then show ?case
  proof (induct "x = d")
    case True
    then have "split_rec d (x # xs) xss ys = split_rec d xs (xss @ [ys]) []"
      using split_rec.simps(2)
      by metis
    then have "split_rec d xs (xss @ [ys]) [] = xss @ [ys] @ split_rec d xs [] []"
      using True.prems append.assoc
      by metis
    then show ?case
      using True.prems append_Nil split_rec.simps(2)
      by metis
  next
    case False
    then have "split_rec d (x # xs) xss ys = split_rec d xs xss (ys @ [x])"
      using split_rec.simps(2)
      by metis
    then show ?case
      using False.hyps False.prems split_rec.simps(2)
      by metis
  qed
qed

lemma split_rec_delimiter_char: "\<And>xss ys. split_rec d ([d] @ xs) xss ys = xss @ [ys] @ split_rec d xs [] []"
  using append_Cons append_Nil split_rec.simps(2) split_rec_base_list
  by metis

lemma split_rec_not_empty: "\<And>xss ys. xs \<noteq> [] \<Longrightarrow> split_rec d xs xss ys \<noteq> []"
proof-
  fix xs :: "'a list"
  assume "xs \<noteq> []"
  then show "\<And>xss ys. split_rec d xs xss ys \<noteq> []"
  proof (induct xs)
    case Nil
    then show ?case
      by simp
  next
    case (Cons x xs)
    then show ?case
      using snoc_eq_iff_butlast split_rec.simps
      by metis
  qed
qed

lemma split_rec_singleton_build: "\<And>xss ys. d \<notin> set xs \<Longrightarrow> split_rec d xs xss ys = split_rec d [] xss (ys @ xs)"
proof-
  fix xs :: "'a list"
  assume "d \<notin> set xs"
  then show "\<And>xss ys. split_rec d xs xss ys = split_rec d [] xss (ys @ xs)"
  proof (induct xs)
    case Nil
    then show ?case
      by simp
  next
    case (Cons x xs)
    then show ?case
      by fastforce
  qed
qed

lemma split_rec_singleton_left: "\<And>xss ys. d \<notin> set xs \<Longrightarrow> split_rec d xs xss ys = xss @ [ys @ xs]"
  by (simp add: split_rec_singleton_build)

lemma split_rec_singleton: "d \<notin> set xs \<Longrightarrow> split_rec d xs [] [] = [xs]"
  by (simp add: split_rec_singleton_left)

lemma split_rec_append: "\<And>xss zs. d \<notin> set ys \<Longrightarrow> split_rec d (xs @ [d] @ ys) xss zs = split_rec d xs xss zs @ [ys]"
  by (induct xs) (simp_all add: split_rec_singleton_left)

lemma split_rec_prepend: "\<And>xss zs. d \<notin> set ys \<Longrightarrow> split_rec d (ys @ [d] @ xs) xss zs = xss @ [zs @ ys] @ split_rec d xs [] []"
proof (induct ys)
  case Nil
  then show ?case
  proof (induct xs)
    case Nil
    then show ?case
      by simp
  next
    case (Cons x xs)
    then show ?case
      using append_Nil append_Nil2 split_rec_delimiter_char
      by metis
  qed
next
  case (Cons y ys)
  then show ?case
    by auto
qed

lemma split_empty: "split d [] = [[]]"
  by (simp add: split_def)

lemma split_singleton: "d \<notin> set xs \<Longrightarrow> split d xs = [xs]"
  by (simp add: split_def split_rec_singleton)

lemma split_append: "d \<notin> set ys \<Longrightarrow> split d (xs @ [d] @ ys) = split d xs @ [ys]"
  using split_def split_rec_append
  by metis

lemma split_prepend: "d \<notin> set ys \<Longrightarrow> split d (ys @ [d] @ xs) = [ys] @ split d xs"
  using split_def append.left_neutral split_rec_prepend
  by metis

subsection "Domain & Range"

inductive_set join_bij_domain :: "'t \<Rightarrow> 't list list set"
  for d :: "'t"
  where
    rule_first_elem: "d \<notin> set xs \<Longrightarrow> [xs] \<in> join_bij_domain d" |
    rule_append: "xs \<in> join_bij_domain d \<Longrightarrow> d \<notin> set ys \<Longrightarrow> xs @ [ys] \<in> join_bij_domain d"

inductive_set split_bij_domain :: "'t \<Rightarrow> 't list set"
  for d :: "'t"
  where
    rule_no_delim: "d \<notin> set xs \<Longrightarrow> xs \<in> split_bij_domain d" |
    rule_append: "xs \<in> split_bij_domain d \<Longrightarrow> d \<notin> set ys \<Longrightarrow> xs @ [d] @ ys \<in> split_bij_domain d"

subsection "Inverse function"

lemma join_inverse: "x \<in> join_bij_domain d \<Longrightarrow> split d (join d x) = x"
proof (induct x rule: join_bij_domain.induct)
  case (rule_first_elem xs)
  then show ?case
    by (simp add: split_singleton)
next
  case (rule_append xs ys)
  then have "split d (join d (xs @ [ys])) = split d (join d xs @ [d] @ ys)"
    using join.simps(1) join_append list.distinct(1) split_empty
    by metis
  then have "split d (join d (xs @ [ys])) = split d (join d xs) @ [ys]"
    using rule_append.hyps(3) split_append by fastforce
  then show ?case
    by (simp add: rule_append.hyps(2))
qed

lemma split_inverse: "x \<in> split_bij_domain d \<Longrightarrow> join d (split d x) = x"
proof (induct x rule: split_bij_domain.induct)
  case (rule_no_delim xs)
  then show ?case
    by (simp add: split_singleton)
next
  case (rule_append xs ys)
  then have "join d (split d (xs @ [d] @ ys)) = join d (split d (xs) @ [ys])"
    using split_append by fastforce
  then have "join d (split d (xs @ [d] @ ys)) = join d (split d (xs)) @ [d] @ ys"
    using join.simps(1) join_append list.distinct(1) rule_append.hyps(2) split_empty
    by metis
  then show ?case
    by (simp add: rule_append.hyps(2))
qed

subsection "Bijection range of join and split"

lemma join_bij_range: "join d ` join_bij_domain d = split_bij_domain d"
proof
  show "join d ` join_bij_domain d \<subseteq> split_bij_domain d"
  proof
    fix x
    assume "x \<in> join d ` join_bij_domain d"
    then show "x \<in> split_bij_domain d"
    proof
      fix xa
      assume x_is_xa: "x = join d xa"
      assume "xa \<in> join_bij_domain d"
      then have "join d xa \<in> split_bij_domain d"
      proof (induct)
        case (rule_first_elem xs)
        then show ?case
          by (simp add: split_bij_domain.rule_no_delim)
      next
        case (rule_append xs ys)
        then show ?case
          using join.simps(2) join_append self_append_conv2 split_bij_domain.simps
          by metis
      qed
      then show "x \<in> split_bij_domain d"
        by (simp add: x_is_xa)
    qed
  qed
next
  show "split_bij_domain d \<subseteq> join d ` join_bij_domain d"
  proof
    fix x
    assume "x \<in> split_bij_domain d"
    then show "x \<in> join d ` join_bij_domain d"
    proof (induct)
      case (rule_no_delim ys)
      then show ?case
        using image_iff join_bij_domain.rule_first_elem by fastforce
    next
      case (rule_append xs ys)
      then have xss_domain_existance: "\<exists>xss. xss \<in> join_bij_domain d \<and> xs = join d xss"
        by auto
      assume "d \<notin> set ys"
      then have "\<And>xss. xss \<in> join_bij_domain d \<Longrightarrow> xss @ [ys] \<in> join_bij_domain d"
        by (fact join_bij_domain.rule_append)
      then have "\<And>xss. xss \<in> join_bij_domain d \<Longrightarrow> join d (xss @ [ys]) \<in> join d ` join_bij_domain d"
        by simp
      then have "\<And>xss. xss \<in> join_bij_domain d \<Longrightarrow> join d xss @ [d] @ ys \<in> join d ` join_bij_domain d"
        using Nil_is_append_conv append_Nil in_set_conv_decomp_last join.simps(1) join.simps(2) join_append join_bij_domain.rule_append list.distinct(1)
        by metis
      then show ?case
        using xss_domain_existance by blast
    qed
  qed
qed

lemma split_bij_range: "split d ` split_bij_domain d = join_bij_domain d"
proof
  show "split d ` split_bij_domain d \<subseteq> join_bij_domain d"
  proof
    fix x
    assume "x \<in> split d ` split_bij_domain d"
    then show "x \<in> join_bij_domain d"
    proof
      fix xa
      assume x_is_xa: "x = split d xa"
      assume "xa \<in> split_bij_domain d"
      then have "split d xa \<in> join_bij_domain d"
      proof (induct)
        case (rule_no_delim ys)
        then show ?case
          by (simp add: join_bij_domain.rule_first_elem split_singleton)
      next
        case (rule_append xs ys)
        then show ?case
          using join_bij_domain.rule_append split_append by fastforce
      qed
      then show "x \<in> join_bij_domain d"
        by (simp add: x_is_xa)
    qed
  qed
next
  show "join_bij_domain d \<subseteq> split d ` split_bij_domain d"
  proof
    fix x
    assume "x \<in> join_bij_domain d"
    then show "x \<in> split d ` split_bij_domain d"
    proof (induct)
      case (rule_first_elem xs)
      then show ?case
        using image_iff split_bij_domain.rule_no_delim split_singleton by fastforce
    next
      case (rule_append xs ys)
      then have xss_domain_existance: "\<exists>xss. xss \<in> split_bij_domain d \<and> xs = split d xss"
        by auto
      assume "d \<notin> set ys"
      then have "\<And>xss. xss \<in> split_bij_domain d \<Longrightarrow> xss @ [d] @ ys \<in> split_bij_domain d"
        by (fact split_bij_domain.rule_append)
      then have "\<And>xss. xss \<in> split_bij_domain d \<Longrightarrow> split d (xss @ [d] @ ys) \<in> split d ` split_bij_domain d"
        by simp
      then have "\<And>xss. xss \<in> split_bij_domain d \<Longrightarrow> split d xss @ [ys] \<in> split d ` split_bij_domain d"
        using rule_append.hyps(3) split_append by fastforce
      then show ?case
        using xss_domain_existance by blast
    qed
  qed
qed

subsection "Surjectivity"

lemma join_surj[simp]: "surj (join d)"
proof
  show "range (join d) \<subseteq> UNIV"
    by simp
next
  show "UNIV \<subseteq> range (join d)"
    using join.simps(2) surj_def top_greatest
    by metis
qed

subsection "Injectivity"

lemma join_inj[simp]: "inj_on (join d) (join_bij_domain d)"
proof
  fix x y :: "'a list list"
  assume x_in_domain: "x \<in> join_bij_domain d"
  assume y_in_domain: "y \<in> join_bij_domain d"
  assume mapping_eq: "join d x = join d y"
  then show "x = y"
    using join_inverse x_in_domain y_in_domain
    by metis
qed

lemma split_inj[simp]: "inj_on (split d) (split_bij_domain d)"
proof
  fix x y :: "'a list"
  assume x_in_domain: "x \<in> split_bij_domain d"
  assume y_in_domain: "y \<in> split_bij_domain d"
  assume mapping_eq: "split d x = split d y"
  then show "x = y"
    using split_inverse x_in_domain y_in_domain
    by metis
qed

subsection "Bijectivity"

lemma join_bij[simp]: "bij_betw (join d) (join_bij_domain d) (split_bij_domain d)"
  unfolding bij_betw_def
  using join_inj join_bij_range
  by simp

lemma split_bij[simp]: "bij_betw (split d) (split_bij_domain d) (join_bij_domain d)"
  unfolding bij_betw_def
  using split_inj split_bij_range
  by simp

end


(*  Title:       Category theory using Isar and Locales
    Author:      Greg O'Keefe, June, July, August 2003
    License: LGPL
*)

section \<open>Yonedas Lemma\<close>

theory Yoneda
imports HomFunctors NatTrans
begin

subsection \<open>The Sandwich Natural Transformation\<close>

locale Yoneda = "functor" + into_set +
  assumes "TERM (AA :: ('o,'a,'m)category_scheme)"
  fixes sandwich :: "['o,'a,'o] \<Rightarrow> 'a set_arrow"  ("\<sigma>'(_,_')")
  defines "sandwich A a \<equiv> (\<lambda>B\<in>Ob. \<lparr>
  set_dom=Hom A B,
  set_func=(\<lambda>f\<in>Hom A B. set_func (F\<^bsub>\<a>\<^esub> f) a),
  set_cod=F\<^bsub>\<o>\<^esub> B
  \<rparr>)"
  fixes unsandwich :: "['o,'o \<Rightarrow> 'a set_arrow] \<Rightarrow> 'a" ("\<sigma>\<^sup>\<leftarrow>'(_,_')")
  defines "unsandwich A u \<equiv> set_func (u A) (Id A)"

lemma (in Yoneda) F_into_set:
  "Functor F : AA \<longrightarrow> Set"
proof-
  from F_axioms have "Functor F : AA \<longrightarrow> BB" by intro_locales
  thus ?thesis
    by (simp only: BB_Set)
qed

lemma (in Yoneda) F_comp_func:
  assumes 1: "A \<in> Ob" and 2: "B \<in> Ob" and 3: "C \<in> Ob"
  and 4: "g \<in> Hom A B" and 5: "f \<in> Hom B C"
  shows "set_func (F\<^bsub>\<a>\<^esub> (f \<bullet> g)) = compose (F\<^bsub>\<o>\<^esub> A) (set_func (F\<^bsub>\<a>\<^esub> f)) (set_func (F\<^bsub>\<a>\<^esub> g))"
proof-
  from 4 and 5
  have 7: "Cod g = Dom f"
    and 8: "g \<in> Ar"
    and 9: "f \<in> Ar"
    and 10: "Dom g = A"
    by (simp_all add: hom_def)
  from F_preserves_dom and 8 and 10
  have 11: "set_dom (F\<^bsub>\<a>\<^esub> g) = F\<^bsub>\<o>\<^esub> A"
    by (simp add: preserves_dom_def BB_Set Set_def) auto
  from F_preserves_comp and 7 and 8 and 9
  have "F\<^bsub>\<a>\<^esub> (f \<bullet> g) = (F\<^bsub>\<a>\<^esub> f) \<bullet>\<^bsub>BB\<^esub> (F\<^bsub>\<a>\<^esub> g)"
    by (simp add: preserves_comp_def)
  hence "set_func (F\<^bsub>\<a>\<^esub> (f \<bullet> g))  = set_func ((F\<^bsub>\<a>\<^esub> f) \<odot> (F\<^bsub>\<a>\<^esub> g))"
    by (simp add: BB_Set Set_def)
  also have "\<dots> = compose (F\<^bsub>\<o>\<^esub> A) (set_func (F\<^bsub>\<a>\<^esub> f)) (set_func (F\<^bsub>\<a>\<^esub> g))"
    by (simp add: set_comp_def 11)
  finally show ?thesis .
qed

lemma (in Yoneda) sandwich_type:
  assumes A: "A \<in> Ob" and B: "B \<in> Ob"
  and "a \<in> F\<^bsub>\<o>\<^esub> A"
  shows "\<sigma>(A,a) B \<in> hom Set (Hom A B) (F\<^bsub>\<o>\<^esub> B)"
proof-
  have "\<sigma>(A,a) \<in> Ob \<rightarrow> Ar\<^bsub>Set\<^esub>"
    using A and \<open>a \<in> F\<^bsub>\<o>\<^esub> A\<close> by (rule sandwich_funcset)
  hence "\<sigma>(A,a) B \<in> ar Set"
    using B by (rule funcset_mem)
  thus ?thesis
    using B by (simp add: sandwich_def hom_def Set_def)
qed

lemma (in Yoneda) sandwich_commutes:
  assumes AOb: "A \<in> Ob" and BOb: "B \<in> Ob" and COb: "C \<in> Ob"
  and aFa: "a \<in> F\<^bsub>\<o>\<^esub> A"
  and fBC: "f \<in> Hom B C"
  shows "(F\<^bsub>\<a>\<^esub> f) \<odot> (\<sigma>(A,a) B) = (\<sigma>(A,a) C) \<odot> (Hom(A,_)\<^bsub>\<a>\<^esub> f)"
proof-
  from fBC have 1: "f \<in> Ar" and 2: "Dom f = B" and 3: "Cod f = C"
    by (simp_all add: hom_def)
  from BOb have "set_dom ((F\<^bsub>\<a>\<^esub> f) \<odot> (\<sigma>(A,a) B)) = Hom A B"
    by (simp add: set_comp_def sandwich_def)
  also have "\<dots> = set_dom ((\<sigma>(A,a) C) \<odot> (Hom(A,_)\<^bsub>\<a>\<^esub> f))"
    by (simp add: set_comp_def homf_def 1 2)
  finally have set_dom_eq:
    "set_dom ((F\<^bsub>\<a>\<^esub> f) \<odot> (\<sigma>(A,a) B))
    = set_dom ((\<sigma>(A,a) C) \<odot> (Hom(A,_)\<^bsub>\<a>\<^esub> f))" .
  from BOb COb fBC have "(F\<^bsub>\<a>\<^esub> f) \<in> Hom\<^bsub>BB\<^esub> (F\<^bsub>\<o>\<^esub> B) (F\<^bsub>\<o>\<^esub> C)"
    by (rule functors_preserve_homsets)
  hence "set_cod ((F\<^bsub>\<a>\<^esub> f) \<odot> (\<sigma>(A,a) B)) = F\<^bsub>\<o>\<^esub> C"
    by (simp add: set_comp_def BB_Set Set_def set_cat_def hom_def)
  also from COb
  have "\<dots> = set_cod ((\<sigma>(A,a) C) \<odot> (Hom(A,_)\<^bsub>\<a>\<^esub> f))"
    by (simp add: set_comp_def sandwich_def)
  finally have set_cod_eq:
    "set_cod ((F\<^bsub>\<a>\<^esub> f) \<odot> (\<sigma>(A,a) B))
    = set_cod ((\<sigma>(A,a) C) \<odot> (Hom(A,_)\<^bsub>\<a>\<^esub> f))" .
  from AOb and BOb and COb and fBC and aFa
  have set_func_lhs:
    "set_func ((F\<^bsub>\<a>\<^esub> f) \<odot> (\<sigma>(A,a) B)) =
    (\<lambda>g\<in>Hom A B. set_func (F\<^bsub>\<a>\<^esub> (f \<bullet> g)) a)"
    apply (simp add:  set_comp_def sandwich_def compose_def)
    apply (rule extensionalityI, rule restrict_extensional, rule restrict_extensional)
    by (simp add: F_comp_func compose_def)
  have "(\<bullet>) : Hom B C \<rightarrow> Hom A B \<rightarrow> Hom A C" ..
  from this and fBC
  have opfType: "(\<bullet>) f : Hom A B \<rightarrow> Hom A C"
    by (rule funcset_mem)
  from 1 and 2
  have "set_func ((\<sigma>(A,a) C) \<odot> (Hom(A,_)\<^bsub>\<a>\<^esub> f)) =
    (\<lambda>g\<in>Hom A B. set_func (\<sigma>(A,a) C) (f \<bullet> g))"
    apply (simp add: set_comp_def homf_def)
    apply (simp add: compose_def)
    apply (rule extensionalityI, rule restrict_extensional, rule restrict_extensional)
    by auto
  also from COb and opfType
  have " \<dots> = (\<lambda>g\<in>Hom A B. set_func (F\<^bsub>\<a>\<^esub> (f \<bullet> g)) a)"
    apply (simp add: sandwich_def)
    apply (rule extensionalityI, rule restrict_extensional, rule restrict_extensional)
    by (simp add:Pi_def)
  finally have set_func_rhs:
    "set_func ((\<sigma>(A,a) C) \<odot> (Hom(A,_)\<^bsub>\<a>\<^esub> f)) =
    (\<lambda>g\<in>Hom A B. set_func (F\<^bsub>\<a>\<^esub> (f \<bullet> g)) a)" .
  from set_func_lhs and set_func_rhs have
    "set_func ((F\<^bsub>\<a>\<^esub> f) \<odot> (\<sigma>(A,a) B))
    = set_func ((\<sigma>(A,a) C) \<odot> (Hom(A,_)\<^bsub>\<a>\<^esub> f))"
    by simp
  with set_dom_eq and set_cod_eq show ?thesis
    by simp
qed

lemma (in Yoneda) sandwich_natural:
  assumes "A \<in> Ob"
  and "a \<in> F\<^bsub>\<o>\<^esub> A"
  shows "\<sigma>(A,a) : Hom(A,_) \<Rightarrow> F in Func(AA,Set)"
proof (intro natural_transformation.intro natural_transformation_axioms.intro two_cats.intro)
  show "category AA" ..
  show "category Set"
    by (simp only: Set_def)(rule set_cat_cat)
  show "Functor Hom(A,_) : AA \<longrightarrow> Set"
    by (rule homf_into_set)
  show "Functor F : AA \<longrightarrow> Set"
    by (rule F_into_set)
  show "\<forall>B\<in>Ob. \<sigma>(A,a) B \<in> hom Set (Hom(A,_)\<^bsub>\<o>\<^esub> B) (F\<^bsub>\<o>\<^esub> B)"
    using assms by (auto simp add: homf_def intro: sandwich_type)
  show "\<sigma>(A,a) : Ob \<rightarrow> ar Set"
    using assms by (rule sandwich_funcset)
  show "\<sigma>(A,a) \<in> extensional (Ob)"
    unfolding sandwich_def by (rule restrict_extensional)
  show "\<forall>B\<in>Ob. \<forall>C\<in>Ob. \<forall>f\<in>Hom B C.
    comp Set (F \<^bsub>\<a>\<^esub> f) (\<sigma>(A,a) B) = comp Set (\<sigma>(A,a) C) (Hom(A,_)\<^bsub>\<a>\<^esub> f)"
    using assms by (auto simp add: Set_def intro: sandwich_commutes)
qed

subsection \<open>Sandwich Components are Bijective\<close>

lemma (in Yoneda) unsandwich_left_inverse:
  assumes 1: "A \<in> Ob"
  and 2: "a \<in> F\<^bsub>\<o>\<^esub> A"
  shows "\<sigma>\<^sup>\<leftarrow>(A,\<sigma>(A,a)) = a"
proof-
  from 1 have "Id A \<in> Hom A A" ..
  with 1
  have 3: "\<sigma>\<^sup>\<leftarrow>(A,\<sigma>(A,a)) = set_func (F\<^bsub>\<a>\<^esub> (Id A)) a"
    by (simp add: sandwich_def homf_def unsandwich_def)
  from F_preserves_id and 1
  have 4: "F\<^bsub>\<a>\<^esub> (Id A) = id Set (F\<^bsub>\<o>\<^esub> A)"
    by (simp add: preserves_id_def BB_Set)
  from F_preserves_objects and 1
  have "F\<^bsub>\<o>\<^esub> A \<in> Ob\<^bsub>BB\<^esub>"
    by (rule funcset_mem)
  hence "F\<^bsub>\<o>\<^esub> A \<subseteq> U"
    by (simp add: BB_Set Set_def set_cat_def)
  with 2
  have 5: "set_func (id Set (F\<^bsub>\<o>\<^esub> A)) a = a"
    by (simp add: Set_def  set_id_def)
  show ?thesis
    by (simp add: 3 4 5)
qed

lemma (in Yoneda) unsandwich_right_inverse:
  assumes 1: "A \<in> Ob"
  and 2: "u : Hom(A,_) \<Rightarrow> F in Func(AA,Set)"
  shows "\<sigma>(A,\<sigma>\<^sup>\<leftarrow>(A,u)) = u"
proof (rule extensionalityI)
  show "\<sigma>(A,\<sigma>\<^sup>\<leftarrow>(A,u)) \<in> extensional (Ob)"
    by (unfold sandwich_def, rule restrict_extensional)
  from 2 show "u \<in>  extensional (Ob)"
    by (simp add: natural_transformation_def natural_transformation_axioms_def)
  fix B
  assume 3: "B \<in> Ob"
  with 1
  have one: "\<sigma>(A,\<sigma>\<^sup>\<leftarrow>(A,u)) B = \<lparr>
    set_dom = Hom A B,
    set_func = (\<lambda>f\<in>Hom A B. (set_func (F\<^bsub>\<a>\<^esub> f)) (set_func (u A) (Id A))),
    set_cod = F\<^bsub>\<o>\<^esub> B \<rparr>"
    by (simp add: sandwich_def unsandwich_def)
  from 1 have "Hom(A,_)\<^bsub>\<o>\<^esub> A = Hom A A"
    by (simp add: homf_def)
  with 1 and 2 have "(u A) \<in> hom Set (Hom A A) (F\<^bsub>\<o>\<^esub> A)"
    by (simp add: natural_transformation_def natural_transformation_axioms_def,
      auto)
  hence "set_dom (u A) = Hom A A"
    by (simp add: hom_def Set_def)
  with 1 have applicable: "Id A \<in> set_dom (u A)"
    by (simp)(rule)
  have two: "(\<lambda>f\<in>Hom A B. (set_func (F\<^bsub>\<a>\<^esub> f)) (set_func (u A) (Id A)))
    = (\<lambda>f\<in>Hom A B. (set_func ((F\<^bsub>\<a>\<^esub> f) \<odot> (u A)) (Id A)))"
    by (rule extensionalityI,
      rule restrict_extensional, rule restrict_extensional,
      simp add: set_comp_def compose_def applicable)
  from 2
  have "(\<forall>X\<in>Ob. \<forall>Y\<in>Ob. \<forall>f\<in>Hom X Y. (F\<^bsub>\<a>\<^esub> f) \<bullet>\<^bsub>BB\<^esub> (u X) = (u Y) \<bullet>\<^bsub>BB\<^esub> (Hom(A,_)\<^bsub>\<a>\<^esub> f))"
    by (simp add: natural_transformation_def natural_transformation_axioms_def BB_Set)
  with 1 and 3
  have three: "(\<lambda>f\<in>Hom A B. (set_func ((F\<^bsub>\<a>\<^esub> f) \<odot> (u A)) (Id A)))
    = (\<lambda>f\<in>Hom A B. (set_func ((u B) \<odot> (Hom(A,_))\<^bsub>\<a>\<^esub> f)) (Id A))"
    apply (simp add: BB_Set Set_def)
    apply (rule extensionalityI)
    apply (rule restrict_extensional, rule restrict_extensional)
    by simp
  have "\<forall>f \<in> Hom A B. set_dom (Hom(A,_)\<^bsub>\<a>\<^esub> f) = Hom A A"
    by (intro ballI, simp add: homf_def hom_def)
  have roolz: "\<And>f. f \<in> Hom A B \<Longrightarrow> set_dom (Hom(A,_)\<^bsub>\<a>\<^esub> f) = Hom A A"
    by (simp add: homf_def hom_def)
  from 1 have rooly: "Id A \<in> Hom A A" ..
  have roolx: "\<And>f. f \<in> Hom A B \<Longrightarrow> f \<in> Ar"
    by (simp add: hom_def)
  have roolw: "\<And>f. f \<in> Hom A B \<Longrightarrow> Id A \<in> Hom A (Dom f)"
  proof-
    fix f
    assume "f \<in> Hom A B"
    hence "Dom f = A" by (simp add: hom_def)
    thus "Id A \<in> Hom A (Dom f)"
      by (simp add: rooly)
  qed
  have annoying: "\<And>f. f \<in> Hom A B \<Longrightarrow> Id A = Id (Dom f)"
    by (simp add: hom_def)
  have "(\<lambda>f\<in>Hom A B. (set_func ((u B) \<odot> (Hom(A,_))\<^bsub>\<a>\<^esub> f)) (Id A))
    = (\<lambda>f\<in>Hom A B. (compose (Hom A A) (set_func (u B)) (set_func (Hom(A,_)\<^bsub>\<a>\<^esub> f))) (Id A))"
    apply (rule extensionalityI)
    apply (rule restrict_extensional, rule restrict_extensional)
    by (simp add: compose_def set_comp_def roolz rooly)
  also have "\<dots> = (\<lambda>f\<in>Hom A B. (set_func (u B) f))"
    apply (rule extensionalityI)
    apply (rule restrict_extensional, rule restrict_extensional)
    apply (simp add: compose_def homf_def rooly roolx roolw)
    apply (simp only: annoying)
    apply (simp add: roolx id_right)
    done
  finally have four:
    "(\<lambda>f\<in>Hom A B. (set_func ((u B) \<odot> (Hom(A,_))\<^bsub>\<a>\<^esub> f)) (Id A))
    = (\<lambda>f\<in>Hom A B. (set_func (u B) f))" .
  from 2 and  3
  have uBhom: "u B \<in> hom Set (Hom(A,_)\<^bsub>\<o>\<^esub> B) (F\<^bsub>\<o>\<^esub> B)"
    by (simp add: natural_transformation_def natural_transformation_axioms_def)
  with 3
  have five: "set_dom (u B) = Hom A B"
    by (simp add: hom_def homf_def Set_def set_cat_def)
  from uBhom
  have six: "set_cod (u B) = F\<^bsub>\<o>\<^esub> B"
    by (simp add: hom_def homf_def Set_def set_cat_def)
  have seven: "restrict (set_func (u B)) (Hom A B) = set_func (u B)"
    apply (rule extensionalityI)
    apply (rule restrict_extensional)
  proof-
    from uBhom have "u B \<in> ar Set"
      by (simp add: hom_def)
    hence almost: "set_func (u B) \<in> extensional (set_dom (u B))"
      by (simp add: Set_def set_cat_def set_arrow_def)
    from almost and five
    show "set_func (u B) \<in> extensional (Hom A B)"
      by simp
    fix f
    assume "f \<in> Hom A B"
    thus "restrict (set_func (u B)) (Hom A B) f = set_func (u B) f"
      by simp
  qed
  from one and two and three and four and five and six and seven
  show "\<sigma>(A,\<sigma>\<^sup>\<leftarrow>(A,u)) B = u B"
    by simp
qed

text \<open>In order to state the lemma, we must rectify a curious
omission from the Isabelle/HOL library. They define the idea of
injectivity on a given set, but surjectivity is only defined relative
to the entire universe of the target type.\<close>

definition
  surj_on :: "['a \<Rightarrow> 'b, 'a set, 'b set] \<Rightarrow> bool" where
  "surj_on f A B \<longleftrightarrow> (\<forall>y\<in>B. \<exists>x\<in>A. f(x)=y)"

definition
  bij_on :: "['a \<Rightarrow> 'b, 'a set, 'b set] \<Rightarrow> bool" where
  "bij_on f A B \<longleftrightarrow> inj_on f A & surj_on f A B"

definition
  equinumerous :: "['a set, 'b set] \<Rightarrow> bool"  (infix "\<cong>" 40) where
  "equinumerous A B \<longleftrightarrow> (\<exists>f. bij_betw f A B)"

lemma bij_betw_eq:
  "bij_betw f A B \<longleftrightarrow>
    inj_on f A \<and> (\<forall>y\<in>B. \<exists>x\<in>A. f(x)=y) \<and> (\<forall>x\<in>A. f x \<in> B)"
unfolding bij_betw_def by auto

theorem (in Yoneda) Yoneda:
  assumes 1: "A \<in> Ob"
  shows "F\<^bsub>\<o>\<^esub> A \<cong> {u. u : Hom(A,_) \<Rightarrow> F in Func(AA,Set)}"
unfolding equinumerous_def bij_betw_eq inj_on_def
proof (intro exI conjI bexI ballI impI)
  \<comment> \<open>Sandwich is injective\<close>
  fix x and y
  assume 2: "x \<in> F\<^bsub>\<o>\<^esub> A" and 3: "y \<in> F\<^bsub>\<o>\<^esub> A"
  and 4: "\<sigma>(A,x) = \<sigma>(A,y)"
  hence "\<sigma>\<^sup>\<leftarrow>(A,\<sigma>(A,x)) = \<sigma>\<^sup>\<leftarrow>(A,\<sigma>(A,y))"
    by simp
  with unsandwich_left_inverse
  show "x = y"
    by (simp add: 1 2 3)
next
  \<comment> \<open>Sandwich covers F A\<close>
  fix u
  assume "u \<in> {y. y : Hom(A,_) \<Rightarrow> F in Func (AA,Set)}"
  hence 2: "u : Hom(A,_) \<Rightarrow> F in Func (AA,Set)"
    by simp
  with 1 show "\<sigma>(A,\<sigma>\<^sup>\<leftarrow>(A,u)) = u"
    by (rule unsandwich_right_inverse)
  \<comment> \<open>Sandwich is into F A\<close> (* there is really similar reasoning elsewhere*)
  from 1 and 2
  have "u A \<in> hom Set (Hom A A) (F\<^bsub>\<o>\<^esub> A)"
    by (simp add: natural_transformation_def natural_transformation_axioms_def homf_def)
  hence "u A \<in> ar Set" and "dom Set (u A) = Hom A A" and "cod Set (u A) = F\<^bsub>\<o>\<^esub> A"
    by (simp_all add: hom_def)
  hence uAfuncset: "set_func (u A) : (Hom A A) \<rightarrow> (F\<^bsub>\<o>\<^esub> A)"
    by (simp add: Set_def set_cat_def set_arrow_def)
  from 1 have "Id A \<in> Hom A A" ..
  with uAfuncset
  show "\<sigma>\<^sup>\<leftarrow>(A,u) \<in> F\<^bsub>\<o>\<^esub> A"
    by (simp add: unsandwich_def, rule funcset_mem)
next
  fix x
  assume "x \<in> F\<^bsub>\<o>\<^esub> A"
  with 1 have "\<sigma>(A,x) : Hom(A,_) \<Rightarrow> F in Func (AA,Set)"
    by (rule sandwich_natural)
  thus "\<sigma>(A,x) \<in> {y. y : Hom(A,_) \<Rightarrow> F in Func (AA,Set)}"
    by simp
qed

end


theory Ex003
imports Main
begin

lemma "\<not>A \<longrightarrow> A \<longrightarrow> B"
proof -
{
  assume "\<not>A"
  {
    assume A
    with \<open>\<not>A\<close> have B by (rule notE)
  }
  hence "A \<longrightarrow> B" by (rule impI)
}
thus ?thesis by (rule impI)
qed


theory Gen_Hash
imports "../Intf/Intf_Hash"
begin

definition "prod_bhc bhc1 bhc2 \<equiv> \<lambda>n (a,b). (bhc1 n a * 33 + bhc2 n b) mod n"

lemma prod_bhc_ga[autoref_ga_rules]:
  "\<lbrakk> GEN_ALGO_tag (is_bounded_hashcode R eq1 bhc1);
     GEN_ALGO_tag (is_bounded_hashcode S eq2 bhc2)\<rbrakk>
  \<Longrightarrow> is_bounded_hashcode (R\<times>\<^sub>rS) (prod_eq eq1 eq2) (prod_bhc bhc1 bhc2)"
  unfolding is_bounded_hashcode_def prod_bhc_def prod_eq_def[abs_def]
  apply safe
  apply (auto dest: fun_relD simp: Domain_unfold; metis)+
  done

lemma prod_dhs_ga[autoref_ga_rules]:
  "\<lbrakk> GEN_ALGO_tag (is_valid_def_hm_size TYPE('a) n1);
     GEN_ALGO_tag (is_valid_def_hm_size TYPE('b) n2) \<rbrakk>
   \<Longrightarrow> is_valid_def_hm_size TYPE('a*'b) (n1+n2)"
   unfolding is_valid_def_hm_size_def by auto

end